diff --git a/.travis.yml b/.travis.yml index 22cd358e..5e032609 100644 --- a/.travis.yml +++ b/.travis.yml @@ -9,12 +9,12 @@ sudo: false addons: apt: packages: + - zlib1g-dev + - libgmp3-dev - gfortran - gcc - liblapack-dev - graphviz -# - zlib1g-dev -# - libgmp3-dev cache: directories: @@ -25,8 +25,8 @@ python: - "2.6" script: - - ./configure --production ./config/travis.cfg - - source ./quantum_package.rc ; qp_module.py install Full_CI Full_CI_ZMQ Hartree_Fock CAS_SD_ZMQ mrcepa0 All_singles + - ./configure --production ./config/gfortran.cfg + - 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 + - source ./quantum_package.rc ; cd tests ; ./run_tests.sh #-v diff --git a/README.md b/README.md index c9e1b12d..eacecaf7 100644 --- a/README.md +++ b/README.md @@ -24,7 +24,7 @@ Demo * Python >= 2.6 * GNU make * Bash -* Blas/Lapack +* Blast/Lapack * unzip * g++ (For ninja) diff --git a/config/gfortran_debug.cfg b/config/gfortran_debug.cfg index 4b06c5e9..03663eea 100644 --- a/config/gfortran_debug.cfg +++ b/config/gfortran_debug.cfg @@ -13,7 +13,7 @@ FC : gfortran -g -ffree-line-length-none -I . -static-libgcc LAPACK_LIB : -llapack -lblas IRPF90 : irpf90 -IRPF90_FLAGS : --ninja --align=32 +IRPF90_FLAGS : --ninja --assert --align=32 # Global options ################ diff --git a/config/ifort.cfg b/config/ifort.cfg index 843e887b..4b1429b8 100644 --- a/config/ifort.cfg +++ b/config/ifort.cfg @@ -38,7 +38,7 @@ FCFLAGS : -xSSE4.2 -O2 -ip -ftz -g ################# # [PROFILE] -FC : -p -g +FC : -p -g -traceback FCFLAGS : -xSSE4.2 -O2 -ip -ftz # Debugging flags @@ -53,6 +53,7 @@ FCFLAGS : -xSSE4.2 -O2 -ip -ftz [DEBUG] FC : -g -traceback FCFLAGS : -xSSE2 -C -fpe0 +IRPF90_FLAGS : --openmp # OpenMP flags ################# diff --git a/config/travis.cfg b/config/travis.cfg deleted file mode 100644 index 024e330b..00000000 --- a/config/travis.cfg +++ /dev/null @@ -1,62 +0,0 @@ -# Common flags -############## -# -# -ffree-line-length-none : Needed for IRPF90 which produces long lines -# -lblas -llapack : Link with libblas and liblapack libraries provided by the system -# -I . : Include the curent directory (Mandatory) -# -# --ninja : Allow the utilisation of ninja. (Mandatory) -# --align=32 : Align all provided arrays on a 32-byte boundary -# -# -[COMMON] -FC : gfortran -ffree-line-length-none -I . -g -LAPACK_LIB : -llapack -lblas -IRPF90 : irpf90 -IRPF90_FLAGS : --ninja --align=32 - -# Global options -################ -# -# 1 : Activate -# 0 : Deactivate -# -[OPTION] -MODE : OPT ; [ OPT | PROFILE | DEBUG ] : Chooses the section below -CACHE : 1 ; Enable cache_compile.py -OPENMP : 1 ; Append OpenMP flags - -# Optimization flags -#################### -# -# -Ofast : Disregard strict standards compliance. Enables all -O3 optimizations. -# It also enables optimizations that are not valid -# for all standard-compliant programs. It turns on -# -ffast-math and the Fortran-specific -# -fno-protect-parens and -fstack-arrays. -[OPT] -FCFLAGS : -Ofast -march=native - -# Profiling flags -################# -# -[PROFILE] -FC : -p -g -FCFLAGS : -Ofast - -# Debugging flags -################# -# -# -fcheck=all : Checks uninitialized variables, array subscripts, etc... -# -g : Extra debugging information -# -[DEBUG] -FCFLAGS : -fcheck=all -g - -# OpenMP flags -################# -# -[OPENMP] -FC : -fopenmp -IRPF90_FLAGS : --openmp - diff --git a/configure b/configure index a602eced..bb27fffe 100755 --- a/configure +++ b/configure @@ -71,8 +71,8 @@ d_dependency = { "emsl": ["python"], "gcc": [], "g++": [], - "zeromq" : [ "g++", "make" ], - "f77zmq" : [ "zeromq", "python", "make" ], + "zeromq" : [ "g++" ], + "f77zmq" : [ "zeromq", "python" ], "python": [], "ninja": ["g++", "python"], "make": [], @@ -102,7 +102,7 @@ curl = Info( default_path=join(QP_ROOT_BIN, "curl")) zlib = Info( - url='http://www.zlib.net/zlib-1.2.11.tar.gz', + url='http://zlib.net/zlib-1.2.8.tar.gz', description=' zlib', default_path=join(QP_ROOT_LIB, "libz.a")) @@ -150,6 +150,7 @@ f77zmq = Info( url='{head}/zeromq/f77_zmq/{tail}'.format(**path_github), description=' F77-ZeroMQ', default_path=join(QP_ROOT_LIB, "libf77zmq.a") ) +# join(QP_ROOT, "src", "ZMQ", "f77zmq.h") ) p_graphviz = Info( url='https://github.com/xflr6/graphviz/archive/master.tar.gz', @@ -165,7 +166,7 @@ d_info = dict() for m in ["ocaml", "m4", "curl", "zlib", "patch", "irpf90", "docopt", "resultsFile", "ninja", "emsl", "ezfio", "p_graphviz", - "zeromq", "f77zmq","bats"]: + "zeromq", "f77zmq","bats" ]: exec ("d_info['{0}']={0}".format(m)) @@ -493,24 +494,16 @@ def create_ninja_and_rc(l_installed): 'export PYTHONPATH="${QP_EZFIO}/Python":"${QP_PYTHON}":"${PYTHONPATH}"', 'export PATH="${QP_PYTHON}":"${QP_ROOT}"/bin:"${QP_ROOT}"/ocaml:"${PATH}"', 'export LD_LIBRARY_PATH="${QP_ROOT}"/lib:"${LD_LIBRARY_PATH}"', - 'export LIBRARY_PATH="${QP_ROOT}"/lib:"${LIBRARY_PATH}"', - 'export C_INCLUDE_PATH="${C_INCLUDE_PATH}":"${QP_ROOT}"/include', - '', - 'source ${QP_ROOT}/install/EZFIO/Bash/ezfio.sh', + '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', - '' + "" ] - qp_opam_root = os.getenv('OPAMROOT') - if not qp_opam_root: - qp_opam_root = '${HOME}/.opam' - l_rc.append('export QP_OPAM={0}'.format(qp_opam_root)) - l_rc.append('source ${QP_OPAM}/opam-init/init.sh > /dev/null 2> /dev/null || true') - l_rc.append('') - path = join(QP_ROOT, "quantum_package.rc") with open(path, "w+") as f: f.write("\n".join(l_rc)) diff --git a/include/.empty b/include/.empty deleted file mode 100644 index e69de29b..00000000 diff --git a/install/scripts/build.sh b/install/scripts/build.sh index 5071b5aa..79a71065 100755 --- a/install/scripts/build.sh +++ b/install/scripts/build.sh @@ -4,11 +4,7 @@ BUILD=_build/${TARGET} rm -rf -- ${BUILD} mkdir ${BUILD} || exit 1 -if [[ -f Downloads/${TARGET}.tar.gz ]] ; then - tar -zxf Downloads/${TARGET}.tar.gz --strip-components=1 --directory=${BUILD} || exit 1 -elif [[ -f Downloads/${TARGET}.tar.bz2 ]] ; then - tar -jxf Downloads/${TARGET}.tar.bz2 --strip-components=1 --directory=${BUILD} || exit 1 -fi +tar -zxf Downloads/${TARGET}.tar.gz --strip-components=1 --directory=${BUILD} || exit 1 _install || exit 1 rm -rf -- ${BUILD} _build/${TARGET}.log exit 0 diff --git a/install/scripts/install_curl.sh b/install/scripts/install_curl.sh index 6194a0e0..c3a48024 100755 --- a/install/scripts/install_curl.sh +++ b/install/scripts/install_curl.sh @@ -10,4 +10,10 @@ function _install() mv curl.ermine ${QP_ROOT}/bin/curl || return 1 } -source scripts/build.sh +BUILD=_build/${TARGET} +rm -rf -- ${BUILD} +mkdir ${BUILD} || exit 1 +tar -xvjf Downloads/${TARGET}.tar.bz2 --strip-components=1 --directory=${BUILD} || exit 1 +_install || exit 1 +rm -rf -- ${BUILD} _build/${TARGET}.log +exit 0 \ No newline at end of file diff --git a/install/scripts/install_f77zmq.sh b/install/scripts/install_f77zmq.sh index 92388337..8357857c 100755 --- a/install/scripts/install_f77zmq.sh +++ b/install/scripts/install_f77zmq.sh @@ -7,9 +7,10 @@ function _install() cd .. QP_ROOT=$PWD cd - + export C_INCLUDE_PATH="${C_INCLUDE_PATH}":"${QP_ROOT}"/lib set -e set -u - export ZMQ_H="${QP_ROOT}"/include/zmq.h + export ZMQ_H="${QP_ROOT}"/lib/zmq.h cd "${BUILD}" make -j 8 || exit 1 mv libf77zmq.a "${QP_ROOT}"/lib || exit 1 diff --git a/install/scripts/install_gmp.sh b/install/scripts/install_gmp.sh deleted file mode 100755 index 9aea2973..00000000 --- a/install/scripts/install_gmp.sh +++ /dev/null @@ -1,17 +0,0 @@ -#!/bin/bash -x - -TARGET=gmp - -function _install() -{ - rm -rf -- ${TARGET} - mkdir ${TARGET} || exit 1 - cd .. - QP_ROOT=$PWD - cd - - cd ${BUILD} - ./configure --prefix=$QP_ROOT && make -j 8 || exit 1 - make install || exit 1 -} - -source scripts/build.sh diff --git a/install/scripts/install_m4.sh b/install/scripts/install_m4.sh index 5a52d757..ca62a025 100755 --- a/install/scripts/install_m4.sh +++ b/install/scripts/install_m4.sh @@ -8,7 +8,8 @@ function _install() QP_ROOT=$PWD cd - cd ${BUILD} - ./configure --prefix=$QP_ROOT && make || exit 1 + ./configure && make || exit 1 + ln -sf ${PWD}/src/m4 ${QP_ROOT}/bin || exit 1 } source scripts/build.sh diff --git a/install/scripts/install_ocaml.sh b/install/scripts/install_ocaml.sh index b82216d3..913ae75d 100755 --- a/install/scripts/install_ocaml.sh +++ b/install/scripts/install_ocaml.sh @@ -5,11 +5,11 @@ QP_ROOT=$PWD cd - # Normal installation -PACKAGES="core cryptokit.1.10 ocamlfind sexplib ZMQ" +PACKAGES="core cryptokit zarith ocamlfind sexplib ZMQ" #ppx_sexp_conv # Needed for ZeroMQ -export C_INCLUDE_PATH="${QP_ROOT}"/include:"${C_INCLUDE_PATH}" +export C_INCLUDE_PATH="${QP_ROOT}"/lib:"${C_INCLUDE_PATH}" export LIBRARY_PATH="${QP_ROOT}"/lib:"${LIBRARY_PATH}" export LD_LIBRARY_PATH="${QP_ROOT}"/lib:"${LD_LIBRARY_PATH}" diff --git a/install/scripts/install_patch.sh b/install/scripts/install_patch.sh index 224ac8f8..10522401 100755 --- a/install/scripts/install_patch.sh +++ b/install/scripts/install_patch.sh @@ -9,11 +9,11 @@ function _install() QP_ROOT=$PWD cd - cd ${BUILD} - ./configure --prefix=${QP_ROOT} && make || exit 1 + ./configure --prefix=${QP_ROOT}/install/${TARGET} && make || exit 1 make install || exit 1 cd - cp ${TARGET}/bin/${TARGET} ${QP_ROOT}/bin || exit 1 rm -R -- ${TARGET} || exit 1 } -source scripts/build.sh +source scripts/build.sh \ No newline at end of file diff --git a/install/scripts/install_zeromq.sh b/install/scripts/install_zeromq.sh index f6596f9c..3bf2a715 100755 --- a/install/scripts/install_zeromq.sh +++ b/install/scripts/install_zeromq.sh @@ -7,13 +7,22 @@ function _install() cd .. QP_ROOT=$PWD cd - + export C_INCLUDE_PATH="${C_INCLUDE_PATH}":./ set -e set -u ORIG=$(pwd) cd "${BUILD}" - ./configure --prefix=$QP_ROOT --without-libsodium || exit 1 + ./configure --without-libsodium || exit 1 make -j 8 || exit 1 - make install || 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 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 cd ${ORIG} return 0 } diff --git a/install/scripts/install_zlib.sh b/install/scripts/install_zlib.sh index ea268f2e..06ce67f3 100755 --- a/install/scripts/install_zlib.sh +++ b/install/scripts/install_zlib.sh @@ -11,8 +11,11 @@ function _install() cd - cd ${BUILD} ./configure && make || exit 1 - ./configure --prefix=$QP_ROOT && make || exit 1 - make install || exit 1 + make install prefix=$QP_ROOT/install/${TARGET} || exit 1 + ln -s -f $QP_ROOT/install/${TARGET}/lib/libz.so $QP_ROOT/lib || exit 1 + ln -s -f $QP_ROOT/install/${TARGET}/lib/libz.a $QP_ROOT/lib || exit 1 + ln -s -f $QP_ROOT/install/${TARGET}/include/zlib.h $QP_ROOT/lib || exit 1 + ln -s -f $QP_ROOT/install/${TARGET}/include/zconf.h $QP_ROOT/lib || exit 1 } source scripts/build.sh diff --git a/ocaml/Pseudo.ml b/ocaml/Pseudo.ml index 7f813937..3fb4736e 100644 --- a/ocaml/Pseudo.ml +++ b/ocaml/Pseudo.ml @@ -124,27 +124,23 @@ let to_string t = let find in_channel element = In_channel.seek in_channel 0L; - let loop, element_read, old_pos = - ref true, - ref None, + let element_read, old_pos = + ref Element.X, ref (In_channel.pos in_channel) in - - while !loop + while !element_read <> element do + let buffer = + old_pos := In_channel.pos in_channel; + match In_channel.input_line in_channel with + | Some line -> String.split ~on:' ' line + |> List.hd_exn + | None -> "" + in try - let buffer = - old_pos := In_channel.pos in_channel; - match In_channel.input_line in_channel with - | Some line -> String.split ~on:' ' line - |> List.hd_exn - | None -> raise End_of_file - in - element_read := Some (Element.of_string buffer); - loop := !element_read <> (Some element) + element_read := Element.of_string buffer with | Element.ElementError _ -> () - | End_of_file -> loop := false done ; In_channel.seek in_channel !old_pos; !element_read @@ -152,126 +148,124 @@ let find in_channel element = (** Read the Pseudopotential in GAMESS format *) let read_element in_channel element = - match find in_channel element with - | Some e when e = element -> + ignore (find in_channel element); + + let rec read result = + match In_channel.input_line in_channel with + | None -> result + | Some line -> + if (String.strip line = "") then + result + else + read (line::result) + in + + let data = + read [] + |> List.rev + in + + let debug_data = + String.concat ~sep:"\n" data + in + + let decode_first_line = function + | first_line :: rest -> begin - let rec read result = - match In_channel.input_line in_channel with - | None -> result - | Some line -> - if (String.strip line = "") then - result - else - read (line::result) + let first_line_split = + String.split first_line ~on:' ' + |> List.filter ~f:(fun x -> (String.strip x) <> "") in - - let data = - read [] - |> List.rev - in - - let debug_data = - String.concat ~sep:"\n" data - in - - let decode_first_line = function - | first_line :: rest -> - begin - let first_line_split = - String.split first_line ~on:' ' - |> List.filter ~f:(fun x -> (String.strip x) <> "") - in - match first_line_split with - | e :: "GEN" :: n :: p -> - { element = Element.of_string e ; - n_elec = Int.of_string n |> Positive_int.of_int ; - local = [] ; - non_local = [] - }, rest - | _ -> failwith ( - Printf.sprintf "Unable to read Pseudopotential : \n%s\n" - debug_data ) - end - | _ -> failwith ("Error reading pseudopotential\n"^debug_data) - in - - let rec loop create_primitive accu = function - | (0,rest) -> List.rev accu, rest - | (n,line::rest) -> - begin - match - String.split line ~on:' ' - |> List.filter ~f:(fun x -> String.strip x <> "") - with - | c :: i :: e :: [] -> - let i = - Int.of_string i - in - let elem = - ( create_primitive - (Float.of_string e |> AO_expo.of_float) - (i-2 |> R_power.of_int), - Float.of_string c |> AO_coef.of_float - ) - in - loop create_primitive (elem::accu) (n-1, rest) - | _ -> failwith ("Error reading pseudopotential\n"^debug_data) - end - | _ -> failwith ("Error reading pseudopotential\n"^debug_data) - in - - let decode_local (pseudo,data) = - let decode_local_n n rest = - let result, rest = - loop Primitive_local.of_expo_r_power [] (Positive_int.to_int n,rest) - in - { pseudo with local = result }, rest - in - match data with - | n :: rest -> - let n = - String.strip n - |> Int.of_string - |> Positive_int.of_int - in - decode_local_n n rest - | _ -> failwith ("Unable to read (non-)local pseudopotential\n"^debug_data) - in - - let decode_non_local (pseudo,data) = - let decode_non_local_n proj n (pseudo,data) = - let result, rest = - loop (Primitive_non_local.of_proj_expo_r_power proj) - [] (Positive_int.to_int n, data) - in - { pseudo with non_local = pseudo.non_local @ result }, rest - in - let rec new_proj (pseudo,data) proj = - match data with - | n :: rest -> - let n = - String.strip n - |> Int.of_string - |> Positive_int.of_int - in - let result = - decode_non_local_n proj n (pseudo,rest) - and proj_next = - (Positive_int.to_int proj)+1 - |> Positive_int.of_int - in - new_proj result proj_next - | _ -> pseudo - in - new_proj (pseudo,data) (Positive_int.of_int 0) - in - - decode_first_line data - |> decode_local - |> decode_non_local + match first_line_split with + | e :: "GEN" :: n :: p -> + { element = Element.of_string e ; + n_elec = Int.of_string n |> Positive_int.of_int ; + local = [] ; + non_local = [] + }, rest + | _ -> failwith ( + Printf.sprintf "Unable to read Pseudopotential : \n%s\n" + debug_data ) end - | _ -> empty element + | _ -> failwith ("Error reading pseudopotential\n"^debug_data) + in + let rec loop create_primitive accu = function + | (0,rest) -> List.rev accu, rest + | (n,line::rest) -> + begin + match + String.split line ~on:' ' + |> List.filter ~f:(fun x -> String.strip x <> "") + with + | c :: i :: e :: [] -> + let i = + Int.of_string i + in + let elem = + ( create_primitive + (Float.of_string e |> AO_expo.of_float) + (i-2 |> R_power.of_int), + Float.of_string c |> AO_coef.of_float + ) + in + loop create_primitive (elem::accu) (n-1, rest) + | _ -> failwith ("Error reading pseudopotential\n"^debug_data) + end + | _ -> failwith ("Error reading pseudopotential\n"^debug_data) + in + + let decode_local (pseudo,data) = + let decode_local_n n rest = + let result, rest = + loop Primitive_local.of_expo_r_power [] (Positive_int.to_int n,rest) + in + { pseudo with local = result }, rest + in + match data with + | n :: rest -> + let n = + String.strip n + |> Int.of_string + |> Positive_int.of_int + in + decode_local_n n rest + | _ -> failwith ("Unable to read (non-)local pseudopotential\n"^debug_data) + in + + let decode_non_local (pseudo,data) = + let decode_non_local_n proj n (pseudo,data) = + let result, rest = + loop (Primitive_non_local.of_proj_expo_r_power proj) + [] (Positive_int.to_int n, data) + in + { pseudo with non_local = pseudo.non_local @ result }, rest + in + let rec new_proj (pseudo,data) proj = + match data with + | n :: rest -> + let n = + String.strip n + |> Int.of_string + |> Positive_int.of_int + in + let result = + decode_non_local_n proj n (pseudo,rest) + and proj_next = + (Positive_int.to_int proj)+1 + |> Positive_int.of_int + in + new_proj result proj_next + | _ -> pseudo + in + new_proj (pseudo,data) (Positive_int.of_int 0) + in + + decode_first_line data + |> decode_local + |> decode_non_local + + include To_md5 diff --git a/ocaml/qp_create_guess.ml b/ocaml/qp_create_guess.ml index bebfdad3..62af57de 100644 --- a/ocaml/qp_create_guess.ml +++ b/ocaml/qp_create_guess.ml @@ -88,9 +88,8 @@ let run ~multiplicity ezfio_file = ~alpha:(Elec_alpha_number.of_int alpha_new) ~beta:(Elec_beta_number.of_int beta_new) pair ) in - let c = - Array.init (List.length determinants) (fun _ -> Det_coef.of_float ((Random.float 2.)-.1.)) + Array.create ~len:(List.length determinants) (Det_coef.of_float 1.) in determinants diff --git a/plugins/All_singles/H_apply.irp.f b/plugins/All_singles/H_apply.irp.f index cb0976af..f34f003c 100644 --- a/plugins/All_singles/H_apply.irp.f +++ b/plugins/All_singles/H_apply.irp.f @@ -8,13 +8,6 @@ s.unset_skip() s.filter_only_1h1p() print s -s = H_apply("just_1h_1p_singles",do_double_exc=False) -s.set_selection_pt2("epstein_nesbet_2x2") -s.unset_skip() -s.filter_only_1h1p() -print s - - s = H_apply("just_mono",do_double_exc=False) s.set_selection_pt2("epstein_nesbet_2x2") s.unset_skip() diff --git a/plugins/All_singles/README.rst b/plugins/All_singles/README.rst index 8836ddd6..d3888edc 100644 --- a/plugins/All_singles/README.rst +++ b/plugins/All_singles/README.rst @@ -15,7 +15,6 @@ Needed Modules * `Properties `_ * `Selectors_no_sorted `_ * `Utils `_ -* `Davidson `_ Documentation ============= diff --git a/plugins/All_singles/all_1h_1p.irp.f b/plugins/All_singles/all_1h_1p.irp.f index 7a3700b1..a2786248 100644 --- a/plugins/All_singles/all_1h_1p.irp.f +++ b/plugins/All_singles/all_1h_1p.irp.f @@ -49,7 +49,7 @@ subroutine routine endif call save_wavefunction if(n_det_before == N_det)then - selection_criterion_factor = selection_criterion_factor * 0.5d0 + selection_criterion = selection_criterion * 0.5d0 endif enddo diff --git a/plugins/All_singles/all_1h_1p_singles.irp.f b/plugins/All_singles/all_1h_1p_singles.irp.f deleted file mode 100644 index b76a14b3..00000000 --- a/plugins/All_singles/all_1h_1p_singles.irp.f +++ /dev/null @@ -1,76 +0,0 @@ -program restart_more_singles - BEGIN_DOC - ! Generates and select single and double excitations of type 1h-1p - ! on the top of a given restart wave function of type CAS - END_DOC - read_wf = .true. - touch read_wf - print*,'ref_bitmask_energy = ',ref_bitmask_energy - call routine - -end -subroutine routine - implicit none - integer :: i,k - double precision, allocatable :: pt2(:), norm_pert(:), H_pert_diag(:),E_before(:) - integer :: N_st, degree - integer :: n_det_before - N_st = N_states - allocate (pt2(N_st), norm_pert(N_st),H_pert_diag(N_st),E_before(N_st)) - i = 0 - print*,'N_det = ',N_det - print*,'n_det_max = ',n_det_max - print*,'pt2_max = ',pt2_max - pt2=-1.d0 - E_before = ref_bitmask_energy - do while (N_det < n_det_max.and.maxval(abs(pt2(1:N_st))) > pt2_max) - n_det_before = N_det - i += 1 - print*,'-----------------------' - print*,'i = ',i - call H_apply_just_1h_1p_singles(pt2, norm_pert, H_pert_diag, N_st) - call diagonalize_CI - print*,'N_det = ',N_det - print*,'E = ',CI_energy(1) - print*,'pt2 = ',pt2(1) - print*,'E+PT2 = ',E_before + pt2(1) - E_before = CI_energy - if(N_states_diag.gt.1)then - print*,'Variational Energy difference' - do i = 2, N_st - print*,'Delta E = ',CI_energy(i) - CI_energy(1) - enddo - endif - if(N_states.gt.1)then - print*,'Variational + perturbative Energy difference' - do i = 2, N_st - print*,'Delta E = ',E_before(i)+ pt2(i) - (E_before(1) + pt2(1)) - enddo - endif - call save_wavefunction - if(n_det_before == N_det)then - selection_criterion_factor = selection_criterion_factor * 0.5d0 - endif - - enddo - - threshold_davidson = 1.d-10 - soft_touch threshold_davidson davidson_criterion - call diagonalize_CI - if(N_states_diag.gt.1)then - print*,'Variational Energy difference' - do i = 2, N_st - print*,'Delta E = ',CI_energy(i) - CI_energy(1) - enddo - endif - if(N_states.gt.1)then - print*,'Variational + perturbative Energy difference' - do i = 2, N_st - print*,'Delta E = ',CI_energy(i)+ pt2(i) - (CI_energy(1) + pt2(1)) - enddo - endif - call ezfio_set_all_singles_energy(CI_energy) - - call save_wavefunction - deallocate(pt2,norm_pert) -end diff --git a/plugins/All_singles/tree_dependency.png b/plugins/All_singles/tree_dependency.png deleted file mode 100644 index e69de29b..00000000 diff --git a/plugins/CAS_SD/.gitignore b/plugins/CAS_SD/.gitignore index 57b1926f..380d6cbf 100644 --- a/plugins/CAS_SD/.gitignore +++ b/plugins/CAS_SD/.gitignore @@ -3,7 +3,6 @@ .ninja_log AO_Basis Bitmask -Davidson Determinants Electrons Ezfio_files diff --git a/plugins/CAS_SD/README.rst b/plugins/CAS_SD/README.rst index 20ffa64f..11f5d4cc 100644 --- a/plugins/CAS_SD/README.rst +++ b/plugins/CAS_SD/README.rst @@ -107,7 +107,6 @@ Needed Modules * `Perturbation `_ * `Selectors_full `_ * `Generators_CAS `_ -* `Davidson `_ Documentation ============= @@ -194,6 +193,31 @@ h_apply_cas_s_selected_monoexc 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_sd_selected.irp.f b/plugins/CAS_SD/cas_sd_selected.irp.f index acca7dd8..d12e8430 100644 --- a/plugins/CAS_SD/cas_sd_selected.irp.f +++ b/plugins/CAS_SD/cas_sd_selected.irp.f @@ -93,8 +93,8 @@ program full_ci call diagonalize_CI if(do_pt2_end)then print*,'Last iteration only to compute the PT2' - threshold_selectors = max(threshold_selectors,threshold_selectors_pt2) - threshold_generators = max(threshold_generators,threshold_generators_pt2) + threshold_selectors = 1.d0 + threshold_generators = 0.999d0 call H_apply_CAS_SD_PT2(pt2, norm_pert, H_pert_diag, N_st) print *, 'Final step' diff --git a/plugins/CAS_SD_ZMQ/EZFIO.cfg b/plugins/CAS_SD_ZMQ/EZFIO.cfg deleted file mode 100644 index 7425c8ba..00000000 --- a/plugins/CAS_SD_ZMQ/EZFIO.cfg +++ /dev/null @@ -1,10 +0,0 @@ -[energy] -type: double precision -doc: "Calculated CAS-SD energy" -interface: ezfio - -[energy_pt2] -type: double precision -doc: "Calculated selected CAS-SD energy with PT2 correction" -interface: ezfio - diff --git a/plugins/CAS_SD_ZMQ/NEEDED_CHILDREN_MODULES b/plugins/CAS_SD_ZMQ/NEEDED_CHILDREN_MODULES deleted file mode 100644 index ae599426..00000000 --- a/plugins/CAS_SD_ZMQ/NEEDED_CHILDREN_MODULES +++ /dev/null @@ -1,2 +0,0 @@ -Generators_CAS Perturbation Selectors_CASSD ZMQ - diff --git a/plugins/CAS_SD_ZMQ/README.rst b/plugins/CAS_SD_ZMQ/README.rst deleted file mode 100644 index 45ba97e4..00000000 --- a/plugins/CAS_SD_ZMQ/README.rst +++ /dev/null @@ -1,14 +0,0 @@ -========== -CAS_SD_ZMQ -========== - -Selected CAS+SD module with Zero-MQ parallelization. - -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/CAS_SD_ZMQ/cassd_zmq.irp.f b/plugins/CAS_SD_ZMQ/cassd_zmq.irp.f deleted file mode 100644 index 881f74c3..00000000 --- a/plugins/CAS_SD_ZMQ/cassd_zmq.irp.f +++ /dev/null @@ -1,255 +0,0 @@ -program fci_zmq - implicit none - integer :: i,j,k - logical, external :: detEq - - double precision, allocatable :: pt2(:) - integer :: degree - double precision :: threshold_davidson_in - - allocate (pt2(N_states)) - - pt2 = 1.d0 - threshold_davidson_in = threshold_davidson - threshold_davidson = threshold_davidson_in * 100.d0 - SOFT_TOUCH threshold_davidson - - - 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, to_select - 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) ) - - 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_zmq_energy(CI_energy(1)) - - n_det_before = N_det - to_select = 2*N_det - to_select = max(64-to_select, to_select) - to_select = min(to_select,N_det_max-n_det_before) - call ZMQ_selection(to_select, pt2) - - PROVIDE psi_coef - PROVIDE psi_det - PROVIDE psi_det_sorted - - if (N_det == N_det_max) then - threshold_davidson = threshold_davidson_in - SOFT_TOUCH threshold_davidson - endif - call diagonalize_CI - call save_wavefunction - call ezfio_set_cas_sd_zmq_energy(CI_energy(1)) - enddo - - if (N_det < N_det_max) then - threshold_davidson = threshold_davidson_in - SOFT_TOUCH threshold_davidson - call diagonalize_CI - call save_wavefunction - call ezfio_set_cas_sd_zmq_energy(CI_energy(1)) - endif - - integer :: exc_max, degree_min - exc_max = 0 - print *, 'CAS determinants : ', N_det_cas - do i=1,min(N_det_cas,20) - do k=i,N_det_cas - 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 - print *, 'Max excitation degree in the CAS :', exc_max - - if(do_pt2_end)then - print*,'Last iteration only to compute the PT2' - threshold_selectors = max(threshold_selectors,threshold_selectors_pt2) - threshold_generators = max(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(k) - print *, 'E = ', E_CI_before(k) - print *, 'E+PT2 = ', E_CI_before(k)+pt2(k) - print *, '-----' - enddo - call ezfio_set_cas_sd_zmq_energy_pt2(E_CI_before+pt2) - endif - call save_wavefunction - call ezfio_set_cas_sd_zmq_energy(CI_energy(1)) - call ezfio_set_cas_sd_zmq_energy_pt2(E_CI_before(1)+pt2(1)) - -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) - - - if (.True.) then - PROVIDE pt2_e0_denominator - N = max(N_in,1) - provide nproc - call new_parallel_job(zmq_to_qp_run_socket,"selection") - call zmq_put_psi(zmq_to_qp_run_socket,1,pt2_e0_denominator,size(pt2_e0_denominator)) - call zmq_set_running(zmq_to_qp_run_socket) - call create_selection_buffer(N, N*2, b) - endif - - 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= 1, N_det_generators,step - i_generator_start = i - i_generator_max = min(i+step-1,N_det_generators) - 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(shared) SHARED(b, pt2) PRIVATE(i) NUM_THREADS(nproc+1) - 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() - if (s2_eig) then - call make_s2_eigenfunction - endif - endif -end subroutine - - -subroutine selection_slave_inproc(i) - implicit none - integer, intent(in) :: i - - call run_selection_slave(1,i,pt2_e0_denominator) -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/CAS_SD_ZMQ/e_corr_selectors.irp.f b/plugins/CAS_SD_ZMQ/e_corr_selectors.irp.f deleted file mode 100644 index fec480f0..00000000 --- a/plugins/CAS_SD_ZMQ/e_corr_selectors.irp.f +++ /dev/null @@ -1,79 +0,0 @@ - -use bitmasks - BEGIN_PROVIDER [integer, exc_degree_per_selectors, (N_det_selectors)] -&BEGIN_PROVIDER [integer, double_index_selectors, (N_det_selectors)] -&BEGIN_PROVIDER [integer, n_double_selectors] - implicit none - BEGIN_DOC - ! degree of excitation respect to Hartree Fock for the wave function - ! - ! for the all the selectors determinants - ! - ! double_index_selectors = list of the index of the double excitations - ! - ! n_double_selectors = number of double excitations in the selectors determinants - END_DOC - integer :: i,degree - n_double_selectors = 0 - do i = 1, N_det_selectors - call get_excitation_degree(psi_selectors(1,1,i),ref_bitmask,degree,N_int) - exc_degree_per_selectors(i) = degree - if(degree==2)then - n_double_selectors += 1 - double_index_selectors(n_double_selectors) =i - endif - enddo -END_PROVIDER - - BEGIN_PROVIDER[double precision, coef_hf_selector] - &BEGIN_PROVIDER[double precision, inv_selectors_coef_hf] - &BEGIN_PROVIDER[double precision, inv_selectors_coef_hf_squared] - &BEGIN_PROVIDER[double precision, E_corr_per_selectors, (N_det_selectors)] - &BEGIN_PROVIDER[double precision, i_H_HF_per_selectors, (N_det_selectors)] - &BEGIN_PROVIDER[double precision, Delta_E_per_selector, (N_det_selectors)] - &BEGIN_PROVIDER[double precision, E_corr_double_only ] - &BEGIN_PROVIDER[double precision, E_corr_second_order ] - implicit none - BEGIN_DOC - ! energy of correlation per determinant respect to the Hartree Fock determinant - ! - ! for the all the double excitations in the selectors determinants - ! - ! E_corr_per_selectors(i) = * c(D_i)/c(HF) if |D_i> is a double excitation - ! - ! E_corr_per_selectors(i) = -1000.d0 if it is not a double excitation - ! - ! coef_hf_selector = coefficient of the Hartree Fock determinant in the selectors determinants - END_DOC - PROVIDE ref_bitmask_energy psi_selectors ref_bitmask N_int psi_selectors - integer :: i,degree - double precision :: hij,diag_H_mat_elem - E_corr_double_only = 0.d0 - E_corr_second_order = 0.d0 - do i = 1, N_det_selectors - if(exc_degree_per_selectors(i)==2)then - call i_H_j(ref_bitmask,psi_selectors(1,1,i),N_int,hij) - i_H_HF_per_selectors(i) = hij - E_corr_per_selectors(i) = psi_selectors_coef(i,1) * hij - E_corr_double_only += E_corr_per_selectors(i) -! E_corr_second_order += hij * hij /(ref_bitmask_energy - diag_H_mat_elem(psi_selectors(1,1,i),N_int)) - elseif(exc_degree_per_selectors(i) == 0)then - coef_hf_selector = psi_selectors_coef(i,1) - E_corr_per_selectors(i) = -1000.d0 - Delta_E_per_selector(i) = 0.d0 - else - E_corr_per_selectors(i) = -1000.d0 - endif - enddo - if (dabs(coef_hf_selector) > 1.d-8) then - inv_selectors_coef_hf = 1.d0/coef_hf_selector - inv_selectors_coef_hf_squared = inv_selectors_coef_hf * inv_selectors_coef_hf - else - inv_selectors_coef_hf = 0.d0 - inv_selectors_coef_hf_squared = 0.d0 - endif - do i = 1,n_double_selectors - E_corr_per_selectors(double_index_selectors(i)) *=inv_selectors_coef_hf - enddo - E_corr_double_only = E_corr_double_only * inv_selectors_coef_hf - END_PROVIDER diff --git a/plugins/CAS_SD_ZMQ/energy.irp.f b/plugins/CAS_SD_ZMQ/energy.irp.f deleted file mode 100644 index db1e7d1a..00000000 --- a/plugins/CAS_SD_ZMQ/energy.irp.f +++ /dev/null @@ -1,11 +0,0 @@ -BEGIN_PROVIDER [ double precision, pt2_E0_denominator, (N_states) ] - implicit none - BEGIN_DOC - ! E0 in the denominator of the PT2 - END_DOC - pt2_E0_denominator(1:N_states) = CI_electronic_energy(1:N_states) -! pt2_E0_denominator(1:N_states) = HF_energy - nuclear_repulsion -! pt2_E0_denominator(1:N_states) = barycentric_electronic_energy(1:N_states) - call write_double(6,pt2_E0_denominator(1)+nuclear_repulsion, 'PT2 Energy denominator') -END_PROVIDER - diff --git a/plugins/CAS_SD_ZMQ/ezfio_interface.irp.f b/plugins/CAS_SD_ZMQ/ezfio_interface.irp.f deleted file mode 100644 index 8adab518..00000000 --- a/plugins/CAS_SD_ZMQ/ezfio_interface.irp.f +++ /dev/null @@ -1,4 +0,0 @@ -! DO NOT MODIFY BY HAND -! Created by $QP_ROOT/scripts/ezfio_interface/ei_handler.py -! from file /home/scemama/quantum_package/src/CAS_SD_ZMQ/EZFIO.cfg - diff --git a/plugins/CAS_SD_ZMQ/run_selection_slave.irp.f b/plugins/CAS_SD_ZMQ/run_selection_slave.irp.f deleted file mode 100644 index dfaee629..00000000 --- a/plugins/CAS_SD_ZMQ/run_selection_slave.irp.f +++ /dev/null @@ -1,156 +0,0 @@ - -subroutine run_selection_slave(thread,iproc,energy) - use f77_zmq - use selection_types - implicit none - - double precision, intent(in) :: energy(N_states) - 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/CAS_SD_ZMQ/selection_buffer.irp.f b/plugins/CAS_SD_ZMQ/selection_buffer.irp.f deleted file mode 100644 index 2bcb11d3..00000000 --- a/plugins/CAS_SD_ZMQ/selection_buffer.irp.f +++ /dev/null @@ -1,70 +0,0 @@ - -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/CAS_SD_ZMQ/selection_cassd_slave.irp.f b/plugins/CAS_SD_ZMQ/selection_cassd_slave.irp.f deleted file mode 100644 index 657ad63c..00000000 --- a/plugins/CAS_SD_ZMQ/selection_cassd_slave.irp.f +++ /dev/null @@ -1,93 +0,0 @@ -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 pt2_e0_denominator 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) - 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) - - !$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) - 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,N_states - 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) - integer, intent(in) :: i - - call run_selection_slave(0,i,energy) -end - diff --git a/plugins/CAS_SD_ZMQ/selection_types.f90 b/plugins/CAS_SD_ZMQ/selection_types.f90 deleted file mode 100644 index 9506629c..00000000 --- a/plugins/CAS_SD_ZMQ/selection_types.f90 +++ /dev/null @@ -1,9 +0,0 @@ -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/DFT_Utils/EZFIO.cfg b/plugins/DFT_Utils/EZFIO.cfg deleted file mode 100644 index 21cc5b98..00000000 --- a/plugins/DFT_Utils/EZFIO.cfg +++ /dev/null @@ -1,4 +0,0 @@ -[energy] -type: double precision -doc: Calculated energy -interface: ezfio diff --git a/plugins/DFT_Utils/NEEDED_CHILDREN_MODULES b/plugins/DFT_Utils/NEEDED_CHILDREN_MODULES deleted file mode 100644 index bff2467f..00000000 --- a/plugins/DFT_Utils/NEEDED_CHILDREN_MODULES +++ /dev/null @@ -1 +0,0 @@ -Determinants diff --git a/plugins/DFT_Utils/grid_density.irp.f b/plugins/DFT_Utils/grid_density.irp.f deleted file mode 100644 index 6071a18b..00000000 --- a/plugins/DFT_Utils/grid_density.irp.f +++ /dev/null @@ -1,165 +0,0 @@ -BEGIN_PROVIDER [integer, n_points_angular_grid] - implicit none - n_points_angular_grid = 50 -END_PROVIDER - -BEGIN_PROVIDER [integer, n_points_radial_grid] - implicit none - n_points_radial_grid = 10000 -END_PROVIDER - - - BEGIN_PROVIDER [double precision, angular_quadrature_points, (n_points_angular_grid,3) ] -&BEGIN_PROVIDER [double precision, weights_angular_points, (n_points_angular_grid)] - implicit none - BEGIN_DOC -! weights and grid points for the integration on the angular variables on -! the unit sphere centered on (0,0,0) -! According to the LEBEDEV scheme - END_DOC - call cal_quad(n_points_angular_grid, angular_quadrature_points,weights_angular_points) - include 'constants.include.F' - integer :: i - double precision :: accu - double precision :: degre_rad -!degre_rad = 180.d0/pi -!accu = 0.d0 -!do i = 1, n_points_integration_angular_lebedev -! accu += weights_angular_integration_lebedev(i) -! weights_angular_points(i) = weights_angular_integration_lebedev(i) * 2.d0 * pi -! angular_quadrature_points(i,1) = dcos ( degre_rad * theta_angular_integration_lebedev(i)) & -! * dsin ( degre_rad * phi_angular_integration_lebedev(i)) -! angular_quadrature_points(i,2) = dsin ( degre_rad * theta_angular_integration_lebedev(i)) & -! * dsin ( degre_rad * phi_angular_integration_lebedev(i)) -! angular_quadrature_points(i,3) = dcos ( degre_rad * phi_angular_integration_lebedev(i)) -!enddo -!print*,'ANGULAR' -!print*,'' -!print*,'accu = ',accu -!ASSERT( dabs(accu - 1.D0) < 1.d-10) - -END_PROVIDER - -BEGIN_PROVIDER [integer , m_knowles] - implicit none - BEGIN_DOC -! value of the "m" parameter in the equation (7) of the paper of Knowles (JCP, 104, 1996) - END_DOC - m_knowles = 3 -END_PROVIDER - - BEGIN_PROVIDER [double precision, grid_points_radial, (n_points_radial_grid)] -&BEGIN_PROVIDER [double precision, dr_radial_integral] - - implicit none - BEGIN_DOC -! points in [0,1] to map the radial integral [0,\infty] - END_DOC - dr_radial_integral = 1.d0/dble(n_points_radial_grid-1) - integer :: i - do i = 1, n_points_radial_grid-1 - grid_points_radial(i) = (i-1) * dr_radial_integral - enddo - -END_PROVIDER - -BEGIN_PROVIDER [double precision, grid_points_per_atom, (3,n_points_angular_grid,n_points_radial_grid,nucl_num)] - BEGIN_DOC -! points for integration over space - END_DOC - implicit none - integer :: i,j,k - double precision :: dr,x_ref,y_ref,z_ref - double precision :: knowles_function - do i = 1, nucl_num - x_ref = nucl_coord(i,1) - y_ref = nucl_coord(i,2) - z_ref = nucl_coord(i,3) - do j = 1, n_points_radial_grid-1 - double precision :: x,r - x = grid_points_radial(j) ! x value for the mapping of the [0, +\infty] to [0,1] - r = knowles_function(alpha_knowles(int(nucl_charge(i))),m_knowles,x) ! value of the radial coordinate for the integration - do k = 1, n_points_angular_grid ! explicit values of the grid points centered around each atom - grid_points_per_atom(1,k,j,i) = x_ref + angular_quadrature_points(k,1) * r - grid_points_per_atom(2,k,j,i) = y_ref + angular_quadrature_points(k,2) * r - grid_points_per_atom(3,k,j,i) = z_ref + angular_quadrature_points(k,3) * r - enddo - enddo - enddo -END_PROVIDER - -BEGIN_PROVIDER [double precision, weight_functions_at_grid_points, (n_points_angular_grid,n_points_radial_grid,nucl_num) ] - BEGIN_DOC -! Weight function at grid points : w_n(r) according to the equation (22) of Becke original paper (JCP, 88, 1988) -! the "n" discrete variable represents the nucleis which in this array is represented by the last dimension -! and the points are labelled by the other dimensions - END_DOC - implicit none - integer :: i,j,k,l,m - double precision :: r(3) - double precision :: accu,cell_function_becke - double precision :: tmp_array(nucl_num) - ! run over all points in space - do j = 1, nucl_num ! that are referred to each atom - do k = 1, n_points_radial_grid -1 !for each radial grid attached to the "jth" atom - do l = 1, n_points_angular_grid ! for each angular point attached to the "jth" atom - r(1) = grid_points_per_atom(1,l,k,j) - r(2) = grid_points_per_atom(2,l,k,j) - r(3) = grid_points_per_atom(3,l,k,j) - accu = 0.d0 - do i = 1, nucl_num ! For each of these points in space, ou need to evaluate the P_n(r) - ! function defined for each atom "i" by equation (13) and (21) with k == 3 - tmp_array(i) = cell_function_becke(r,i) ! P_n(r) - ! Then you compute the summ the P_n(r) function for each of the "r" points - accu += tmp_array(i) - enddo - accu = 1.d0/accu - weight_functions_at_grid_points(l,k,j) = tmp_array(j) * accu -! print*,weight_functions_at_grid_points(l,k,j) - enddo - enddo - enddo - - -END_PROVIDER - - BEGIN_PROVIDER [double precision, one_body_dm_mo_alpha_at_grid_points, (n_points_angular_grid,n_points_radial_grid,nucl_num) ] -&BEGIN_PROVIDER [double precision, one_body_dm_mo_beta_at_grid_points, (n_points_angular_grid,n_points_radial_grid,nucl_num) ] - implicit none - integer :: i,j,k,l,m - double precision :: contrib - double precision :: r(3) - double precision :: aos_array(ao_num),mos_array(mo_tot_num) - do j = 1, nucl_num - do k = 1, n_points_radial_grid -1 - do l = 1, n_points_angular_grid - one_body_dm_mo_alpha_at_grid_points(l,k,j) = 0.d0 - one_body_dm_mo_beta_at_grid_points(l,k,j) = 0.d0 - r(1) = grid_points_per_atom(1,l,k,j) - r(2) = grid_points_per_atom(2,l,k,j) - r(3) = grid_points_per_atom(3,l,k,j) - -! call give_all_aos_at_r(r,aos_array) -! do i = 1, ao_num -! do m = 1, ao_num -! contrib = aos_array(i) * aos_array(m) -! one_body_dm_mo_alpha_at_grid_points(l,k,j) += one_body_dm_ao_alpha(i,m) * contrib -! one_body_dm_mo_beta_at_grid_points(l,k,j) += one_body_dm_ao_beta(i,m) * contrib -! enddo -! enddo - - call give_all_mos_at_r(r,mos_array) - do i = 1, mo_tot_num - do m = 1, mo_tot_num - contrib = mos_array(i) * mos_array(m) - one_body_dm_mo_alpha_at_grid_points(l,k,j) += one_body_dm_mo_alpha(i,m) * contrib - one_body_dm_mo_beta_at_grid_points(l,k,j) += one_body_dm_mo_beta(i,m) * contrib - enddo - enddo - - enddo - enddo - enddo - -END_PROVIDER - diff --git a/plugins/DFT_Utils/integration_3d.irp.f b/plugins/DFT_Utils/integration_3d.irp.f deleted file mode 100644 index 43eb1ab8..00000000 --- a/plugins/DFT_Utils/integration_3d.irp.f +++ /dev/null @@ -1,54 +0,0 @@ -double precision function step_function_becke(x) - implicit none - double precision, intent(in) :: x - double precision :: f_function_becke - integer :: i,n_max_becke - -!if(x.lt.-1.d0)then -! step_function_becke = 0.d0 -!else if (x .gt.1)then -! step_function_becke = 0.d0 -!else - step_function_becke = f_function_becke(x) -!!n_max_becke = 1 - do i = 1, 4 - step_function_becke = f_function_becke(step_function_becke) - enddo - step_function_becke = 0.5d0*(1.d0 - step_function_becke) -!endif -end - -double precision function f_function_becke(x) - implicit none - double precision, intent(in) :: x - f_function_becke = 1.5d0 * x - 0.5d0 * x*x*x -end - -double precision function cell_function_becke(r,atom_number) - implicit none - double precision, intent(in) :: r(3) - integer, intent(in) :: atom_number - BEGIN_DOC - ! atom_number :: atom on which the cell function of Becke (1988, JCP,88(4)) - ! r(1:3) :: x,y,z coordinantes of the current point - END_DOC - double precision :: mu_ij,nu_ij - double precision :: distance_i,distance_j,step_function_becke - integer :: j - distance_i = (r(1) - nucl_coord_transp(1,atom_number) ) * (r(1) - nucl_coord_transp(1,atom_number)) - distance_i += (r(2) - nucl_coord_transp(2,atom_number) ) * (r(2) - nucl_coord_transp(2,atom_number)) - distance_i += (r(3) - nucl_coord_transp(3,atom_number) ) * (r(3) - nucl_coord_transp(3,atom_number)) - distance_i = dsqrt(distance_i) - cell_function_becke = 1.d0 - do j = 1, nucl_num - if(j==atom_number)cycle - distance_j = (r(1) - nucl_coord_transp(1,j) ) * (r(1) - nucl_coord_transp(1,j)) - distance_j+= (r(2) - nucl_coord_transp(2,j) ) * (r(2) - nucl_coord_transp(2,j)) - distance_j+= (r(3) - nucl_coord_transp(3,j) ) * (r(3) - nucl_coord_transp(3,j)) - distance_j = dsqrt(distance_j) - mu_ij = (distance_i - distance_j)/nucl_dist(atom_number,j) - nu_ij = mu_ij + slater_bragg_type_inter_distance_ua(atom_number,j) * (1.d0 - mu_ij*mu_ij) - cell_function_becke *= step_function_becke(nu_ij) - enddo -end - diff --git a/plugins/DFT_Utils/integration_radial.irp.f b/plugins/DFT_Utils/integration_radial.irp.f deleted file mode 100644 index 4943783b..00000000 --- a/plugins/DFT_Utils/integration_radial.irp.f +++ /dev/null @@ -1,109 +0,0 @@ - BEGIN_PROVIDER [ double precision, integral_density_alpha_knowles_becke_per_atom, (nucl_num)] -&BEGIN_PROVIDER [ double precision, integral_density_beta_knowles_becke_per_atom, (nucl_num)] - implicit none - double precision :: accu - integer :: i,j,k,l - double precision :: x - double precision :: integrand(n_points_angular_grid), weights(n_points_angular_grid) - double precision :: f_average_angular_alpha,f_average_angular_beta - double precision :: derivative_knowles_function,knowles_function - - ! Run over all nuclei in order to perform the Voronoi partition - ! according ot equation (6) of the paper of Becke (JCP, (88), 1988) - ! Here the m index is referred to the w_m(r) weight functions of equation (22) - ! Run over all points of integrations : there are - ! n_points_radial_grid (i) * n_points_angular_grid (k) - do j = 1, nucl_num - integral_density_alpha_knowles_becke_per_atom(j) = 0.d0 - integral_density_beta_knowles_becke_per_atom(j) = 0.d0 - do i = 1, n_points_radial_grid-1 - ! Angular integration over the solid angle Omega for a FIXED angular coordinate "r" - f_average_angular_alpha = 0.d0 - f_average_angular_beta = 0.d0 - do k = 1, n_points_angular_grid - f_average_angular_alpha += weights_angular_points(k) * one_body_dm_mo_alpha_at_grid_points(k,i,j) * weight_functions_at_grid_points(k,i,j) - f_average_angular_beta += weights_angular_points(k) * one_body_dm_mo_beta_at_grid_points(k,i,j) * weight_functions_at_grid_points(k,i,j) - enddo - ! - x = grid_points_radial(i) ! x value for the mapping of the [0, +\infty] to [0,1] - double precision :: contrib_integration -! print*,m_knowles - contrib_integration = derivative_knowles_function(alpha_knowles(int(nucl_charge(j))),m_knowles,x) & - *knowles_function(alpha_knowles(int(nucl_charge(j))),m_knowles,x)**2 - integral_density_alpha_knowles_becke_per_atom(j) += contrib_integration *f_average_angular_alpha - integral_density_beta_knowles_becke_per_atom(j) += contrib_integration *f_average_angular_beta - enddo - integral_density_alpha_knowles_becke_per_atom(j) *= dr_radial_integral - integral_density_beta_knowles_becke_per_atom(j) *= dr_radial_integral - enddo - -END_PROVIDER - - double precision function knowles_function(alpha,m,x) - implicit none - BEGIN_DOC -! function proposed by Knowles (JCP, 104, 1996) for distributing the radial points : -! the Log "m" function ( equation (7) in the paper ) - END_DOC - double precision, intent(in) :: alpha,x - integer, intent(in) :: m - knowles_function = -alpha * dlog(1.d0-x**m) - end - - double precision function derivative_knowles_function(alpha,m,x) - implicit none - BEGIN_DOC -! derivative of the function proposed by Knowles (JCP, 104, 1996) for distributing the radial points - END_DOC - double precision, intent(in) :: alpha,x - integer, intent(in) :: m - derivative_knowles_function = alpha * dble(m) * x**(m-1) / (1.d0 - x**m) - end - - BEGIN_PROVIDER [double precision, alpha_knowles, (100)] - implicit none - integer :: i - BEGIN_DOC -! recommended values for the alpha parameters according to the paper of Knowles (JCP, 104, 1996) -! as a function of the nuclear charge - END_DOC - - ! H-He - alpha_knowles(1) = 5.d0 - alpha_knowles(2) = 5.d0 - - ! Li-Be - alpha_knowles(3) = 7.d0 - alpha_knowles(4) = 7.d0 - - ! B-Ne - do i = 5, 10 - alpha_knowles(i) = 5.d0 - enddo - - ! Na-Mg - do i = 11, 12 - alpha_knowles(i) = 7.d0 - enddo - - ! Al-Ar - do i = 13, 18 - alpha_knowles(i) = 5.d0 - enddo - - ! K-Ca - do i = 19, 20 - alpha_knowles(i) = 7.d0 - enddo - - ! Sc-Zn - do i = 21, 30 - alpha_knowles(i) = 5.d0 - enddo - - ! Ga-Kr - do i = 31, 36 - alpha_knowles(i) = 7.d0 - enddo - - END_PROVIDER diff --git a/plugins/DFT_Utils/routines_roland.irp.f b/plugins/DFT_Utils/routines_roland.irp.f deleted file mode 100644 index 0f555902..00000000 --- a/plugins/DFT_Utils/routines_roland.irp.f +++ /dev/null @@ -1,219 +0,0 @@ - - subroutine cal_quad(n_quad, quad, weight) -! -------------------------------------------------------------------------------- -! -! Arguments : subroutine cal_quad -! Description: evaluates quadrature points an weights -! -! Authors : B. Lévy, P. Pernot -! Date : 15 Nov 2000 -! -------------------------------------------------------------------------------- - implicit none - integer, intent(in) :: n_quad - double precision, intent(out) :: weight(n_quad) - double precision, intent(out) :: quad(n_quad,3) - -! local: - double precision, parameter :: zero=0.d0, one= 1.d0 - - double precision, parameter :: p=0.707106781186547462d0 - double precision, parameter :: q=0.577350269189625842d0 - double precision, parameter :: r=0.301511344577763629d0 - double precision, parameter :: s=0.904534033733290888d0 - - double precision, parameter :: fourpi= 12.5663706143591725d0 - - double precision, parameter :: a6=0.166666666666666657d0 - double precision, parameter :: a18=0.333333333333333329d-01 - double precision, parameter :: b18=0.666666666666666657d-01 - double precision, parameter :: a26=0.476190476190476164d-01 - double precision, parameter :: b26=0.380952380952380987d-01 - double precision, parameter :: c26=0.321428571428571397d-01 - double precision, parameter :: a50=0.126984126984126984d-01 - double precision, parameter :: b50=0.225749559082892431d-01 - double precision, parameter :: c50=0.210937500000000014d-01 - double precision, parameter :: d50=0.201733355379188697d-01 - - double precision :: apt(3,6),bpt(3,12),cpt(3,8),dpt(3,24) - double precision :: awght,bwght,cwght,dwght - double precision :: s1, s2, s3 - integer :: idim, ipt, i1, i2, i3, is1, is2, is3 - integer :: iquad - -! begin: -! l_here ='cal_quad' -! call enter (l_here,3) - -! verifications: -! message = 'in '//trim(l_here)//', number of dimensions='//& -! trim(encode(dimensions_nb))//', must be 3' -! call ensure(message, dimensions_nb .eq. 3 ) - -! message = 'in '//trim(l_here)//', invalid number of quadrature points ='& -! //trim(encode(n_quad)) -! call ensure(message,(n_quad-2)*(n_quad-6)*(n_quad-18)*(n_quad-26)*(n_quad-50) .eq. 0) - -! initialize weights - awght = zero - bwght = zero - cwght = zero - dwght = zero - -! type A points : (+/-1,0,0) - awght=a6*fourpi - ipt= 1 - apt=0. - do idim = 1, 3 - apt(idim,ipt)=one - ipt=ipt+1 - apt(idim,ipt)=-one - ipt=ipt+1 - enddo - -! type B points : (+/-p,+/-p,0) with p= 1/sqrt(2) - if(n_quad.gt.6) then - - awght=a18*fourpi - bwght=b18*fourpi - - s1=p - s2=p - ipt= 1 - bpt=0. - do idim = 1, 3 - i1=idim+1 - if(i1.gt.3) i1=i1-3 - i2=idim+2 - if(i2.gt.3) i2=i2-3 - do is1= 1,2 - do is2= 1,2 - bpt(i1,ipt)=s1 - bpt(i2,ipt)=s2 - s2=-s2 - ipt=ipt+1 - enddo - s1=-s1 - enddo - enddo - endif - -! type C points : (+/-q,+/-q,+/-q) with q= 1/sqrt(3) - if(n_quad.gt.18) then - - awght=a26*fourpi - bwght=b26*fourpi - cwght=c26*fourpi - - s1=q - s2=q - s3=q - ipt= 1 - cpt=0. - do is1= 1,2 - do is2= 1,2 - do is3= 1,2 - cpt(1,ipt)=s1 - cpt(2,ipt)=s2 - cpt(3,ipt)=s3 - s3=-s3 - ipt=ipt+1 - enddo - s2=-s2 - enddo - s1=-s1 - enddo - endif - -! type D points : (+/-r,+/-r,+/-s) - if(n_quad.gt.26) then - - awght=a50*fourpi - bwght=b50*fourpi - cwght=c50*fourpi - dwght=d50*fourpi - - ipt= 1 - dpt=0. - do i1= 1, 3 - s1=s - s2=r - s3=r - i2=i1+1 - if(i2.gt.3) i2=i2-3 - i3=i1+2 - if(i3.gt.3) i3=i3-3 - do is1= 1,2 - do is2= 1,2 - do is3= 1,2 - dpt(i1,ipt)=s1 - dpt(i2,ipt)=s2 - dpt(i3,ipt)=s3 - s3=-s3 - ipt=ipt+1 - enddo - s2=-s2 - enddo - s1=-s1 - enddo - enddo - endif - -! fill the points and weights tables - iquad= 1 - do ipt= 1, 6 - do idim = 1, 3 - quad(iquad,idim)=apt(idim,ipt) - enddo - weight(iquad)=awght - iquad=iquad+1 - enddo - - if(n_quad.gt.6) then - do ipt= 1,12 - do idim = 1, 3 - quad(iquad,idim)=bpt(idim,ipt) - enddo - weight(iquad)=bwght - iquad=iquad+1 - enddo - endif - - if(n_quad.gt.18) then - do ipt= 1,8 - do idim = 1, 3 - quad(iquad,idim)=cpt(idim,ipt) - enddo - weight(iquad)=cwght - iquad=iquad+1 - enddo - endif - - if(n_quad.gt.26) then - do ipt= 1,24 - do idim = 1, 3 - quad(iquad,idim)=dpt(idim,ipt) - enddo - weight(iquad)=dwght - iquad=iquad+1 - enddo - endif - -! if (debug) then -! write(6,*) -! write(6,'(1X,a)') trim(l_here)//'-d : '//& -! '------------------------------------------------------' -! write(6,'(1X,a)') trim(l_here)//'-d : '//' I Weight Quad_points' -! write(6,'(1X,a)') trim(l_here)//'-d : '//& -! '----- ---------- -----------------------------------' -! do iquad= 1, n_quad -! write(6,'(1X,A,i5,4e12.3)') trim(l_here)//'-d : ',& -! iquad,weight(iquad),quad(iquad,1:3) -! enddo -! write(6,'(1X,a)') trim(l_here)//'-d : '//& -! '------------------------------------------------------' -! write(6,*) -! endif - -! call exit (l_here,3) - - end subroutine cal_quad diff --git a/plugins/DFT_Utils/test_integration_3d_density.irp.f b/plugins/DFT_Utils/test_integration_3d_density.irp.f deleted file mode 100644 index 93ce58f4..00000000 --- a/plugins/DFT_Utils/test_integration_3d_density.irp.f +++ /dev/null @@ -1,24 +0,0 @@ -program pouet - print*,'coucou' - read_wf = .True. - touch read_wf - print*,'m_knowles = ',m_knowles - call routine - -end -subroutine routine - implicit none - integer :: i - double precision :: accu(2) - accu = 0.d0 - do i = 1, nucl_num - accu(1) += integral_density_alpha_knowles_becke_per_atom(i) - accu(2) += integral_density_beta_knowles_becke_per_atom(i) - enddo - print*,'accu(1) = ',accu(1) - print*,'Nalpha = ',elec_alpha_num - print*,'accu(2) = ',accu(2) - print*,'Nalpha = ',elec_beta_num - - -end diff --git a/plugins/FOBOCI/EZFIO.cfg b/plugins/FOBOCI/EZFIO.cfg index 9b9f7d71..88189608 100644 --- a/plugins/FOBOCI/EZFIO.cfg +++ b/plugins/FOBOCI/EZFIO.cfg @@ -19,15 +19,10 @@ default: 0.00001 [do_it_perturbative] type: logical -doc: if true, when a given 1h or 1p determinant is not selected because of its perturbation estimate, then if its coefficient is lower than threshold_perturbative, it is acounted in the FOBOCI differential density matrices +doc: if true, you do the FOBOCI calculation perturbatively interface: ezfio,provider,ocaml default: .False. -[threshold_perturbative] -type: double precision -doc: when do_it_perturbative is True, threshold_perturbative select if a given determinant ia selected or not for beign taken into account in the FOBO-SCF treatment. In practive, if the coefficient is larger then threshold_perturbative it means that it not selected as the perturbation should not be too importan. A value of 0.01 is in general OK. -interface: ezfio,provider,ocaml -default: 0.001 [speed_up_convergence_foboscf] type: logical @@ -54,9 +49,3 @@ doc: if true, you do all 2p type excitation on the LMCT interface: ezfio,provider,ocaml default: .True. -[selected_fobo_ci] -type: logical -doc: if true, for each CI step you will run a CIPSI calculation that stops at pt2_max -interface: ezfio,provider,ocaml -default: .False. - diff --git a/plugins/FOBOCI/SC2_1h1p.irp.f b/plugins/FOBOCI/SC2_1h1p.irp.f deleted file mode 100644 index 7733831c..00000000 --- a/plugins/FOBOCI/SC2_1h1p.irp.f +++ /dev/null @@ -1,889 +0,0 @@ -subroutine dressing_1h1p(dets_in,u_in,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 ROHF+1h1p (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) :: diag_H_elements(dim_in) - double precision, intent(in) :: convergence - - integer :: i,j,k,l - integer :: n_singles - integer :: index_singles(sze),hole_particles_singles(sze,3) - integer :: n_doubles - integer :: index_doubles(sze),hole_particles_doubles(sze,2) - integer :: index_hf - double precision :: e_corr_singles(mo_tot_num,2) - double precision :: e_corr_doubles(mo_tot_num) - double precision :: e_corr_singles_total(2) - double precision :: e_corr_doubles_1h1p - - integer :: exc(0:2,2,2),degree - integer :: h1,h2,p1,p2,s1,s2 - integer :: other_spin(2) - 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 - double precision :: hij,c_ref,contrib - integer :: iorb - - other_spin(1) = 2 - other_spin(2) = 1 - - n_singles = 0 - n_doubles = 0 - do i = 1,sze - call get_excitation(ref_bitmask,dets_in(1,1,i),exc,degree,phase,N_int) - call decode_exc(exc,degree,h1,p1,h2,p2,s1,s2) - call i_H_j(dets_in(1,1,i),dets_in(1,1,i),N_int,hij) - diag_H_elements(i) = hij - if(degree == 0)then - index_hf = i - else if (degree == 1)then - n_singles +=1 - index_singles(n_singles) = i - ! h1 = inactive orbital of the hole - hole_particles_singles(n_singles,1) = h1 - ! p1 = virtual orbital of the particle - hole_particles_singles(n_singles,2) = p1 - ! s1 = spin of the electron excited - hole_particles_singles(n_singles,3) = s1 - else if (degree == 2)then - n_doubles +=1 - index_doubles(n_doubles) = i - ! h1 = inactive orbital of the hole (beta of course) - hole_particles_doubles(n_doubles,1) = h1 - ! p1 = virtual orbital of the particle (alpha of course) - hole_particles_doubles(n_doubles,2) = p2 - else - print*,'PB !! found out other thing than a single or double' - print*,'stopping ..' - stop - endif - enddo - - e_corr_singles = 0.d0 - e_corr_doubles = 0.d0 - e_corr_singles_total = 0.d0 - e_corr_doubles_1h1p = 0.d0 - c_ref = 1.d0/u_in(index_hf,1) - print*,'c_ref = ',c_ref - do i = 1,sze - call get_excitation(ref_bitmask,dets_in(1,1,i),exc,degree,phase,N_int) - call decode_exc(exc,degree,h1,p1,h2,p2,s1,s2) - call i_H_j(ref_bitmask,dets_in(1,1,i),N_int,hij) - contrib = hij * u_in(i,1) * c_ref - if (degree == 1)then - e_corr_singles(h1,s1) += contrib - e_corr_singles(p1,s1) += contrib - e_corr_singles_total(s1)+= contrib - else if (degree == 2)then - e_corr_doubles_1h1p += contrib - e_corr_doubles(h1) += contrib - e_corr_doubles(p2) += contrib - endif - enddo - print*,'e_corr_singles alpha = ',e_corr_singles_total(1) - print*,'e_corr_singles beta = ',e_corr_singles_total(2) - print*,'e_corr_doubles_1h1p = ',e_corr_doubles_1h1p - - ! repeat all the correlation energy on the singles - do i = 1,n_singles - ! you can repeat all the correlation energy of the single excitation of the other spin - diag_H_elements(index_singles(i)) += e_corr_singles_total(other_spin(hole_particles_singles(i,3))) - - ! you can repeat all the correlation energy of the single excitation of the same spin - do j = 1, n_inact_orb - iorb = list_inact(j) - ! except the one of the hole - if(iorb == hole_particles_singles(i,1))cycle - ! ispin = hole_particles_singles(i,3) - diag_H_elements(index_singles(i)) += e_corr_singles(iorb,hole_particles_singles(i,3)) - enddo - ! also exclude all the energy coming from the virtual orbital - diag_H_elements(index_singles(i)) -= e_corr_singles(hole_particles_singles(i,2),hole_particles_singles(i,3)) - - ! If it is a single excitation alpha, you can repeat : - ! +) all the double excitation 1h1p, appart the part involving the virtual orbital "r" - ! If it is a single excitation alpha, you can repeat : - ! +) all the double excitation 1h1p, appart the part involving the inactive orbital "i" - diag_H_elements(index_singles(i)) += e_corr_doubles_1h1p - if(hole_particles_singles(i,3) == 1)then ! alpha single excitation - diag_H_elements(index_singles(i)) -= e_corr_doubles(hole_particles_singles(i,2)) - else ! beta single exctitation - diag_H_elements(index_singles(i)) -= e_corr_doubles(hole_particles_singles(i,1)) - endif - enddo - - ! repeat all the correlation energy on the doubles - ! as all the doubles involve the active space, you cannot repeat any of them one on another - do i = 1, n_doubles - ! on a given double, you can repeat all the correlation energy of the singles alpha - do j = 1, n_inact_orb - iorb = list_inact(j) - ! ispin = hole_particles_singles(i,3) - diag_H_elements(index_doubles(i)) += e_corr_singles(iorb,1) - enddo - ! except the part involving the virtual orbital "hole_particles_doubles(i,2)" - diag_H_elements(index_doubles(i)) -= e_corr_singles(hole_particles_doubles(i,2),1) - ! on a given double, you can repeat all the correlation energy of the singles beta - do j = 1, n_inact_orb - iorb = list_inact(j) - ! except the one of the hole - if(iorb == hole_particles_doubles(i,1))cycle - ! ispin = hole_particles_singles(i,3) - diag_H_elements(index_doubles(i)) += e_corr_singles(iorb,2) - enddo - enddo - - - ! Taking into account the connected part of the 2h2p on the HF determinant - ! 1/2 \sum_{ir,js} c_{ir}^{sigma} c_{js}^{sigma} - -! diag_H_elements(index_hf) += total_corr_e_2h2p - return - c_ref = c_ref * c_ref - print*,'diag_H_elements(index_hf) = ',diag_H_elements(index_hf) - do i = 1, n_singles - ! start on the single excitation "|i>" - h1 = hole_particles_singles(i,1) - p1 = hole_particles_singles(i,2) - do j = 1, n_singles - do k = 1, N_int - key_tmp(k,1) = dets_in(k,1,index_singles(i)) - key_tmp(k,2) = dets_in(k,2,index_singles(i)) - enddo - h2 = hole_particles_singles(j,1) - p2 = hole_particles_singles(j,2) - call do_mono_excitation(key_tmp,h2,p2,hole_particles_singles(j,3),i_ok) - ! apply the excitation operator from the single excitation "|j>" - if(i_ok .ne. 1)cycle - double precision :: phase_ref_other_single,diag_H_mat_elem,hijj,contrib_e2,coef_1 - call get_excitation(key_tmp,dets_in(1,1,index_singles(i)),exc,degree,phase_single_double,N_int) - call get_excitation(ref_bitmask,dets_in(1,1,index_singles(j)),exc,degree,phase_ref_other_single,N_int) - call i_H_j(ref_bitmask,key_tmp,N_int,hij) - diag_H_elements(index_hf) += u_in(index_singles(i),1) * u_in(index_singles(j),1) * c_ref * hij & - * phase_single_double * phase_ref_other_single - enddo - enddo - print*,'diag_H_elements(index_hf) = ',diag_H_elements(index_hf) - -end - - -subroutine dressing_1h1p_by_2h2p(dets_in,u_in,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 ROHF+1h1p (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) :: diag_H_elements(0:dim_in) - double precision, intent(in) :: convergence - - integer :: i,j,k,l - integer :: r,s,i0,j0,r0,s0 - integer :: n_singles - integer :: index_singles(sze),hole_particles_singles(sze,3) - integer :: n_doubles - integer :: index_doubles(sze),hole_particles_doubles(sze,2) - integer :: index_hf - double precision :: e_corr_singles(mo_tot_num,2) - double precision :: e_corr_doubles(mo_tot_num) - double precision :: e_corr_singles_total(2) - double precision :: e_corr_doubles_1h1p - - integer :: exc(0:2,2,2),degree - integer :: h1,h2,p1,p2,s1,s2 - integer :: other_spin(2) - 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 - double precision :: hij,c_ref,contrib - integer :: iorb - - other_spin(1) = 2 - other_spin(2) = 1 - - n_singles = 0 - n_doubles = 0 - do i = 1,sze - call get_excitation(ref_bitmask,dets_in(1,1,i),exc,degree,phase,N_int) - call decode_exc(exc,degree,h1,p1,h2,p2,s1,s2) - call i_H_j(dets_in(1,1,i),dets_in(1,1,i),N_int,hij) - diag_H_elements(i) = hij - if(degree == 0)then - index_hf = i - else if (degree == 1)then - n_singles +=1 - index_singles(n_singles) = i - ! h1 = inactive orbital of the hole - hole_particles_singles(n_singles,1) = h1 - ! p1 = virtual orbital of the particle - hole_particles_singles(n_singles,2) = p1 - ! s1 = spin of the electron excited - hole_particles_singles(n_singles,3) = s1 - else if (degree == 2)then - n_doubles +=1 - index_doubles(n_doubles) = i - ! h1 = inactive orbital of the hole (beta of course) - hole_particles_doubles(n_doubles,1) = h1 - ! p1 = virtual orbital of the particle (alpha of course) - hole_particles_doubles(n_doubles,2) = p2 - else - print*,'PB !! found out other thing than a single or double' - print*,'stopping ..' - stop - endif - enddo - double precision :: delta_e - double precision :: coef_ijrs - diag_H_elements = 0.d0 - do i0 = 1, n_core_inact_orb - i= list_core_inact(i0) - do j0 = i0+1, n_core_inact_orb - j = list_core_inact(j0) - print*, i,j - do r0 = 1, n_virt_orb - r = list_virt(r0) - do s0 = r0+1, n_virt_orb - s = list_virt(s0) - !!! alpha (i-->r) / beta (j-->s) - s1 = 1 - s2 = 2 - key_tmp = ref_bitmask - call do_mono_excitation(key_tmp,i,r,s1,i_ok) - if(i_ok .ne.1)then - print*, 'pb !!' - stop - endif - call do_mono_excitation(key_tmp,j,s,s2,i_ok) - if(i_ok .ne.1)then - print*, 'pb !!' - stop - endif - call i_H_j(ref_bitmask, key_tmp, N_int,hij) - delta_e = Fock_matrix_diag_mo(i) + Fock_matrix_diag_mo(j) - Fock_matrix_diag_mo(r) - Fock_matrix_diag_mo(s) - coef_ijrs = hij/delta_e - do k = 1, n_singles - l = index_singles(k) - call i_H_j(dets_in(1,1,l), key_tmp, N_int,hij) - diag_H_elements(l) += coef_ijrs * hij - enddo - !if(i>j.and.r>s)then - !! alpha (i-->r) / alpha (j-->s) - s1 = 1 - s2 = 1 - key_tmp = ref_bitmask - call do_mono_excitation(key_tmp,i,r,s1,i_ok) - if(i_ok .ne.1)then - print*, 'pb !!' - stop - endif - call do_mono_excitation(key_tmp,j,s,s2,i_ok) - if(i_ok .ne.1)then - print*, 'pb !!' - stop - endif - call i_H_j(ref_bitmask, key_tmp, N_int,hij) - delta_e = Fock_matrix_diag_mo(i) + Fock_matrix_diag_mo(j) - Fock_matrix_diag_mo(r) - Fock_matrix_diag_mo(s) - coef_ijrs = hij/delta_e - do k = 1, n_singles - l = index_singles(k) - call i_H_j(dets_in(1,1,l), key_tmp, N_int,hij) - diag_H_elements(l) += coef_ijrs * hij - enddo - !! beta (i-->r) / beta (j-->s) - s1 = 2 - s2 = 2 - key_tmp = ref_bitmask - call do_mono_excitation(key_tmp,i,r,s1,i_ok) - if(i_ok .ne.1)then - print*, 'pb !!' - stop - endif - call do_mono_excitation(key_tmp,j,s,s2,i_ok) - if(i_ok .ne.1)then - print*, 'pb !!' - stop - endif - call i_H_j(ref_bitmask, key_tmp, N_int,hij) - delta_e = Fock_matrix_diag_mo(i) + Fock_matrix_diag_mo(j) - Fock_matrix_diag_mo(r) - Fock_matrix_diag_mo(s) - coef_ijrs = hij/delta_e - do k = 1, n_singles - l = index_singles(k) - call i_H_j(dets_in(1,1,l), key_tmp, N_int,hij) - diag_H_elements(l) += coef_ijrs * hij - enddo - !endif - enddo - enddo - enddo - enddo - c_ref = 1.d0/u_in(index_hf,1) - do k = 1, n_singles - l = index_singles(k) - diag_H_elements(0) -= diag_H_elements(l) - enddo -! do k = 1, n_doubles -! l = index_doubles(k) -! diag_H_elements(0) += diag_H_elements(l) -! enddo - - -end - - -subroutine dressing_1h1p_full(dets_in,u_in,H_matrix,dim_in,sze,N_st,Nint,convergence) - use bitmasks - implicit none - BEGIN_DOC - ! CISD+SC2 method :: take off all the disconnected terms of a ROHF+1h1p (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(in) :: u_in(dim_in,N_st) - double precision, intent(inout) :: H_matrix(sze,sze) - double precision, intent(in) :: convergence - - integer :: i,j,k,l - integer :: n_singles - integer :: index_singles(sze),hole_particles_singles(sze,3) - integer :: n_doubles - integer :: index_doubles(sze),hole_particles_doubles(sze,2) - integer :: index_hf - double precision :: e_corr_singles(mo_tot_num,2) - double precision :: e_corr_doubles(mo_tot_num) - double precision :: e_corr_singles_total(2) - double precision :: e_corr_doubles_1h1p - - integer :: exc(0:2,2,2),degree - integer :: h1,h2,p1,p2,s1,s2 - integer :: other_spin(2) - 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 - double precision :: hij,c_ref,contrib - integer :: iorb - - other_spin(1) = 2 - other_spin(2) = 1 - - n_singles = 0 - n_doubles = 0 - do i = 1,sze - call get_excitation(ref_bitmask,dets_in(1,1,i),exc,degree,phase,N_int) - call decode_exc(exc,degree,h1,p1,h2,p2,s1,s2) - if(degree == 0)then - index_hf = i - else if (degree == 1)then - n_singles +=1 - index_singles(n_singles) = i - ! h1 = inactive orbital of the hole - hole_particles_singles(n_singles,1) = h1 - ! p1 = virtual orbital of the particle - hole_particles_singles(n_singles,2) = p1 - ! s1 = spin of the electron excited - hole_particles_singles(n_singles,3) = s1 - else if (degree == 2)then - n_doubles +=1 - index_doubles(n_doubles) = i - ! h1 = inactive orbital of the hole (beta of course) - hole_particles_doubles(n_doubles,1) = h1 - ! p1 = virtual orbital of the particle (alpha of course) - hole_particles_doubles(n_doubles,2) = p2 - else - print*,'PB !! found out other thing than a single or double' - print*,'stopping ..' - stop - endif - enddo - double precision, allocatable :: dressing_H_mat_elem(:) - allocate(dressing_H_mat_elem(N_det)) - logical :: lmct - dressing_H_mat_elem = 0.d0 - call dress_diag_elem_2h2p(dressing_H_mat_elem,N_det) - lmct = .False. - call dress_diag_elem_2h1p(dressing_H_mat_elem,N_det,lmct,1000) - lmct = .true. - call dress_diag_elem_1h2p(dressing_H_mat_elem,N_det,lmct,1000) - do i = 1, N_det - H_matrix(i,i) += dressing_H_mat_elem(i) - enddo - - e_corr_singles = 0.d0 - e_corr_doubles = 0.d0 - e_corr_singles_total = 0.d0 - e_corr_doubles_1h1p = 0.d0 - c_ref = 1.d0/u_in(index_hf,1) - print*,'c_ref = ',c_ref - do i = 1,sze - call get_excitation(ref_bitmask,dets_in(1,1,i),exc,degree,phase,N_int) - call decode_exc(exc,degree,h1,p1,h2,p2,s1,s2) - call i_H_j(ref_bitmask,dets_in(1,1,i),N_int,hij) - contrib = hij * u_in(i,1) * c_ref - if (degree == 1)then - e_corr_singles(h1,s1) += contrib - e_corr_singles(p1,s1) += contrib - e_corr_singles_total(s1)+= contrib - else if (degree == 2)then - e_corr_doubles_1h1p += contrib - e_corr_doubles(h1) += contrib - e_corr_doubles(p2) += contrib - endif - enddo - print*,'e_corr_singles alpha = ',e_corr_singles_total(1) - print*,'e_corr_singles beta = ',e_corr_singles_total(2) - print*,'e_corr_doubles_1h1p = ',e_corr_doubles_1h1p - - - ! repeat all the correlation energy on the singles -! do i = 1,n_singles -! ! you can repeat all the correlation energy of the single excitation of the other spin -! H_matrix(index_singles(i),index_singles(i)) += e_corr_singles_total(other_spin(hole_particles_singles(i,3))) - -! ! you can repeat all the correlation energy of the single excitation of the same spin -! do j = 1, n_inact_orb -! iorb = list_inact(j) -! ! except the one of the hole -! if(iorb == hole_particles_singles(i,1))cycle -! ! ispin = hole_particles_singles(i,3) -! H_matrix(index_singles(i),index_singles(i)) += e_corr_singles(iorb,hole_particles_singles(i,3)) -! enddo -! ! also exclude all the energy coming from the virtual orbital -! H_matrix(index_singles(i),index_singles(i)) -= e_corr_singles(hole_particles_singles(i,2),hole_particles_singles(i,3)) -! -! ! If it is a single excitation alpha, you can repeat : -! ! +) all the double excitation 1h1p, appart the part involving the virtual orbital "r" -! ! If it is a single excitation alpha, you can repeat : -! ! +) all the double excitation 1h1p, appart the part involving the inactive orbital "i" -! H_matrix(index_singles(i),index_singles(i)) += e_corr_doubles_1h1p -! if(hole_particles_singles(i,3) == 1)then ! alpha single excitation -! H_matrix(index_singles(i),index_singles(i)) -= e_corr_doubles(hole_particles_singles(i,2)) -! else ! beta single exctitation -! H_matrix(index_singles(i),index_singles(i)) -= e_corr_doubles(hole_particles_singles(i,1)) -! endif -! enddo - -! ! repeat all the correlation energy on the doubles -! ! as all the doubles involve the active space, you cannot repeat any of them one on another -! do i = 1, n_doubles -! ! on a given double, you can repeat all the correlation energy of the singles alpha -! do j = 1, n_inact_orb -! iorb = list_inact(j) -! ! ispin = hole_particles_singles(i,3) -! H_matrix(index_doubles(i),index_doubles(i)) += e_corr_singles(iorb,1) -! enddo -! ! except the part involving the virtual orbital "hole_particles_doubles(i,2)" -! H_matrix(index_doubles(i),index_doubles(i)) -= e_corr_singles(hole_particles_doubles(i,2),1) -! ! on a given double, you can repeat all the correlation energy of the singles beta -! do j = 1, n_inact_orb -! iorb = list_inact(j) -! ! except the one of the hole -! if(iorb == hole_particles_doubles(i,1))cycle -! ! ispin = hole_particles_singles(i,3) -! H_matrix(index_doubles(i),index_doubles(i)) += e_corr_singles(iorb,2) -! enddo -! enddo - - - ! Taking into account the connected part of the 2h2p on the HF determinant - ! 1/2 \sum_{ir,js} c_{ir}^{sigma} c_{js}^{sigma} - -! H_matrix(index_hf) += total_corr_e_2h2p - print*,'H_matrix(index_hf,index_hf) = ',H_matrix(index_hf,index_hf) - do i = 1, n_singles - ! start on the single excitation "|i>" - h1 = hole_particles_singles(i,1) - p1 = hole_particles_singles(i,2) - print*,'i = ',i - do j = i+1, n_singles - do k = 1, N_int - key_tmp(k,1) = dets_in(k,1,index_singles(i)) - key_tmp(k,2) = dets_in(k,2,index_singles(i)) - enddo - h2 = hole_particles_singles(j,1) - p2 = hole_particles_singles(j,2) - call do_mono_excitation(key_tmp,h2,p2,hole_particles_singles(j,3),i_ok) - ! apply the excitation operator from the single excitation "|j>" - if(i_ok .ne. 1)cycle - double precision :: H_array(sze),diag_H_mat_elem,hjj - do k = 1, sze - call get_excitation_degree(dets_in(1,1,k),key_tmp,degree,N_int) - H_array(k) = 0.d0 - if(degree > 2)cycle - call i_H_j(dets_in(1,1,k),key_tmp,N_int,hij) - H_array(k) = hij - enddo - hjj = 1.d0/(ref_bitmask_energy - diag_H_mat_elem(key_tmp,N_int)) -! contrib_e2 = 0.5d0 * (delta_e + dsqrt(delta_e * delta_e + 4.d0 * hij * hij)) - do l = 2, sze -! pause - H_matrix(l,l) += H_array(l) * H_array(l) * hjj -! H_matrix(1,l) += H_array(1) * H_array(l) * hjj -! H_matrix(l,1) += H_array(1) * H_array(l) * hjj - enddo - enddo - enddo - print*,'H_matrix(index_hf,index_hf) = ',H_matrix(index_hf,index_hf) - -end - -subroutine SC2_1h1p_full(dets_in,u_in,energies,H_matrix,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) :: H_matrix(sze,sze) - 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(:,:) - allocate (H_matrix_tmp(size(H_matrix_all_dets,1),sze),eigenvalues(sze),eigenvectors(size(H_matrix_all_dets,1),sze)) - H_matrix_tmp = 0.d0 - call dressing_1h1p_full(dets_in,u_in,H_matrix_tmp,dim_in,sze,N_st,Nint,convergence) - do j=1,sze - do i=1,sze - H_matrix_tmp(i,j) += H_matrix_all_dets(i,j) - enddo - enddo - print*,'passed the dressing' - 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,diag_H_elements,energies,dim_in,sze,N_st,Nint,output_determinants) -! endif - print*,'E = ',energies(1) + nuclear_repulsion - - enddo - - -end - - -subroutine SC2_1h1p(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 :: 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) -! 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 - H_matrix_tmp(1,1) += extra_diag_H_elements(1) - do i = 2,sze - H_matrix_tmp(1,i) += extra_diag_H_elements(i) - H_matrix_tmp(i,1) += extra_diag_H_elements(i) - enddo - !do i = 1,sze - ! H_matrix_tmp(i,i) = diag_H_elements(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,diag_H_elements,energies,dim_in,sze,N_st,Nint,output_determinants) -! endif - print*,'E = ',energies(1) + nuclear_repulsion - - enddo - - -end - - -subroutine density_matrix_1h1p(dets_in,u_in,density_matrix_alpha,density_matrix_beta,norm,dim_in,sze,N_st,Nint) - use bitmasks - implicit none - BEGIN_DOC - ! CISD+SC2 method :: take off all the disconnected terms of a ROHF+1h1p (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(inout) :: density_matrix_alpha(mo_tot_num_align,mo_tot_num) - double precision, intent(inout) :: density_matrix_beta(mo_tot_num_align,mo_tot_num) - double precision, intent(inout) :: norm - - integer :: i,j,k,l - integer :: n_singles - integer :: index_singles(sze),hole_particles_singles(sze,3) - integer :: n_doubles - integer :: index_doubles(sze),hole_particles_doubles(sze,2) - integer :: index_hf - - integer :: exc(0:2,2,2),degree - integer :: h1,h2,p1,p2,s1,s2 - integer :: other_spin(2) - 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 - double precision :: hij,c_ref,contrib - integer :: iorb - - other_spin(1) = 2 - other_spin(2) = 1 - - n_singles = 0 - n_doubles = 0 - norm = 0.d0 - do i = 1,sze - call get_excitation(ref_bitmask,dets_in(1,1,i),exc,degree,phase,N_int) - call decode_exc(exc,degree,h1,p1,h2,p2,s1,s2) - norm += u_in(i,1)* u_in(i,1) - if(degree == 0)then - index_hf = i - c_ref = 1.d0/psi_coef(i,1) - else if (degree == 1)then - n_singles +=1 - index_singles(n_singles) = i - ! h1 = inactive orbital of the hole - hole_particles_singles(n_singles,1) = h1 - ! p1 = virtual orbital of the particle - hole_particles_singles(n_singles,2) = p1 - ! s1 = spin of the electron excited - hole_particles_singles(n_singles,3) = s1 - else if (degree == 2)then - n_doubles +=1 - index_doubles(n_doubles) = i - ! h1 = inactive orbital of the hole (beta of course) - hole_particles_doubles(n_doubles,1) = h1 - ! p1 = virtual orbital of the particle (alpha of course) - hole_particles_doubles(n_doubles,2) = p2 - else - print*,'PB !! found out other thing than a single or double' - print*,'stopping ..' - stop - endif - enddo - print*,'norm = ',norm - - ! Taking into account the connected part of the 2h2p on the HF determinant - ! 1/2 \sum_{ir,js} c_{ir}^{sigma} c_{js}^{sigma} - - do i = 1, n_singles - ! start on the single excitation "|i>" - h1 = hole_particles_singles(i,1) - p1 = hole_particles_singles(i,2) - do j = 1, n_singles - do k = 1, N_int - key_tmp(k,1) = dets_in(k,1,index_singles(i)) - key_tmp(k,2) = dets_in(k,2,index_singles(i)) - enddo - h2 = hole_particles_singles(j,1) - p2 = hole_particles_singles(j,2) - call do_mono_excitation(key_tmp,h2,p2,hole_particles_singles(j,3),i_ok) - ! apply the excitation operator from the single excitation "|j>" - if(i_ok .ne. 1)cycle - double precision :: coef_ijrs,phase_other_single_ref - integer :: occ(N_int*bit_kind_size,2),n_occ(2) - call get_excitation(key_tmp,dets_in(1,1,index_singles(i)),exc,degree,phase_single_double,N_int) - call get_excitation(ref_bitmask,dets_in(1,1,index_singles(j)),exc,degree,phase_other_single_ref,N_int) - call get_excitation(key_tmp,dets_in(1,1,index_singles(j)),exc,degree,phase_other_single_ref,N_int) - coef_ijrs = u_in(index_singles(i),1) * u_in(index_singles(j),1) * c_ref * c_ref & - * phase_single_double * phase_other_single_ref - call bitstring_to_list_ab(key_tmp, occ, n_occ, N_int) - do k=1,elec_alpha_num - l = occ(k,1) - density_matrix_alpha(l,l) += coef_ijrs*coef_ijrs - enddo - do k=1,elec_beta_num - l = occ(k,1) - density_matrix_beta(l,l) += coef_ijrs*coef_ijrs - enddo - norm += coef_ijrs* coef_ijrs - if(hole_particles_singles(j,3) == 1)then ! single alpha - density_matrix_alpha(h2,p2) += coef_ijrs * phase_single_double * u_in(index_singles(i),1) * c_ref - density_matrix_alpha(p2,h2) += coef_ijrs * phase_single_double * u_in(index_singles(i),1) * c_ref - else - density_matrix_beta(h2,p2) += coef_ijrs * phase_single_double * u_in(index_singles(i),1) * c_ref - density_matrix_beta(p2,h2) += coef_ijrs * phase_single_double * u_in(index_singles(i),1) * c_ref - endif - enddo - enddo - - - do i = 1, n_doubles - ! start on the double excitation "|i>" - h1 = hole_particles_doubles(i,1) - p1 = hole_particles_doubles(i,2) - do j = 1, n_singles - do k = 1, N_int - key_tmp(k,1) = dets_in(k,1,index_doubles(i)) - key_tmp(k,2) = dets_in(k,2,index_doubles(i)) - enddo - h2 = hole_particles_singles(j,1) - p2 = hole_particles_singles(j,2) - call do_mono_excitation(key_tmp,h2,p2,hole_particles_singles(j,3),i_ok) - ! apply the excitation operator from the single excitation "|j>" - if(i_ok .ne. 1)cycle - double precision :: coef_ijrs_kv,phase_double_triple - call get_excitation(key_tmp,dets_in(1,1,index_singles(i)),exc,degree,phase_double_triple,N_int) - call get_excitation(ref_bitmask,dets_in(1,1,index_singles(j)),exc,degree,phase_other_single_ref,N_int) - call get_excitation(key_tmp,dets_in(1,1,index_singles(j)),exc,degree,phase_other_single_ref,N_int) - coef_ijrs_kv = u_in(index_doubles(i),1) * u_in(index_singles(j),1) * c_ref * c_ref & - * phase_double_triple * phase_other_single_ref - call bitstring_to_list_ab(key_tmp, occ, n_occ, N_int) - do k=1,elec_alpha_num - l = occ(k,1) - density_matrix_alpha(l,l) += coef_ijrs_kv*coef_ijrs_kv - enddo - do k=1,elec_beta_num - l = occ(k,1) - density_matrix_beta(l,l) += coef_ijrs_kv*coef_ijrs_kv - enddo - norm += coef_ijrs_kv* coef_ijrs_kv - if(hole_particles_singles(j,3) == 1)then ! single alpha - density_matrix_alpha(h2,p2) += coef_ijrs_kv * phase_double_triple * u_in(index_doubles(i),1) * c_ref - density_matrix_alpha(p2,h2) += coef_ijrs_kv * phase_double_triple * u_in(index_doubles(i),1) * c_ref - else - density_matrix_beta(h2,p2) += coef_ijrs_kv * phase_double_triple * u_in(index_doubles(i),1) * c_ref - density_matrix_beta(p2,h2) += coef_ijrs_kv * phase_double_triple * u_in(index_doubles(i),1) * c_ref - endif - enddo - enddo - - - - - print*,'norm = ',norm - norm = 1.d0/norm - do i = 1, mo_tot_num - do j = 1, mo_tot_num - density_matrix_alpha(i,j) *= norm - density_matrix_beta(i,j) *= norm - enddo - enddo - coef_ijrs = 0.d0 - do i = 1, mo_tot_num - coef_ijrs += density_matrix_beta(i,i) + density_matrix_beta(i,i) - enddo - print*,'accu = ',coef_ijrs - -end - diff --git a/plugins/FOBOCI/all_singles.irp.f b/plugins/FOBOCI/all_singles.irp.f index 65d81e07..0594e56e 100644 --- a/plugins/FOBOCI/all_singles.irp.f +++ b/plugins/FOBOCI/all_singles.irp.f @@ -1,25 +1,13 @@ -subroutine all_single(e_pt2) +subroutine all_single implicit none - double precision, intent(in) :: e_pt2 integer :: i,k double precision, allocatable :: pt2(:), norm_pert(:), H_pert_diag(:) integer :: N_st, degree double precision,allocatable :: E_before(:) N_st = N_states allocate (pt2(N_st), norm_pert(N_st),H_pert_diag(N_st),E_before(N_st)) - if(.not.selected_fobo_ci)then - selection_criterion = 0.d0 - soft_touch selection_criterion - else - selection_criterion = 0.1d0 - selection_criterion_factor = 0.01d0 - selection_criterion_min = selection_criterion - soft_touch selection_criterion - endif - print*, 'e_pt2 = ',e_pt2 - pt2_max = 0.15d0 * e_pt2 - soft_touch pt2_max - print*, 'pt2_max = ',pt2_max + selection_criterion = 0.d0 + soft_touch selection_criterion threshold_davidson = 1.d-9 soft_touch threshold_davidson davidson_criterion i = 0 @@ -29,8 +17,6 @@ subroutine all_single(e_pt2) print*,'pt2_max = ',pt2_max print*,'N_det_generators = ',N_det_generators pt2=-1.d0 - print*, 'ref_bitmask_energy =',ref_bitmask_energy - print*, 'CI_expectation_value =',psi_energy(1) E_before = ref_bitmask_energy print*,'Initial Step ' @@ -43,7 +29,7 @@ subroutine all_single(e_pt2) print*,'S^2 = ',CI_eigenvectors_s2(i) enddo n_det_max = 100000 - do while (N_det < n_det_max.and.maxval(abs(pt2(1:N_st))) > dabs(pt2_max)) + do while (N_det < n_det_max.and.maxval(abs(pt2(1:N_st))) > pt2_max) i += 1 print*,'-----------------------' print*,'i = ',i @@ -53,8 +39,6 @@ subroutine all_single(e_pt2) print*,'E = ',CI_energy(1) print*,'pt2 = ',pt2(1) print*,'E+PT2 = ',E_before + pt2(1) - print*,'pt2_max = ',pt2_max - print*, maxval(abs(pt2(1:N_st))) > dabs(pt2_max) if(N_states_diag.gt.1)then print*,'Variational Energy difference' do i = 2, N_st @@ -69,6 +53,7 @@ subroutine all_single(e_pt2) endif E_before = CI_energy !!!!!!!!!!!!!!!!!!!!!!!!!!! DOING ONLY ONE ITERATION OF SELECTION AS THE SELECTION CRITERION IS SET TO ZERO + exit enddo ! threshold_davidson = 1.d-8 ! soft_touch threshold_davidson davidson_criterion diff --git a/plugins/FOBOCI/corr_energy_2h2p.irp.f b/plugins/FOBOCI/corr_energy_2h2p.irp.f index 40bfa5aa..ada46bf2 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,hij,delta_e,exc,contrib + double precision :: get_mo_bielec_integral_schwartz,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(i_hole,j_hole,k_part,l_part,mo_integrals_map) + hij = get_mo_bielec_integral_schwartz(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(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) + 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) 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(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) + 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) 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,hij,delta_e,exc,contrib + double precision :: get_mo_bielec_integral_schwartz,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(i_hole,j_hole,k_part,l_part,mo_integrals_map) + hij = get_mo_bielec_integral_schwartz(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(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) + 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) 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(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) + 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) 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,hij,delta_e,exc,contrib + double precision :: get_mo_bielec_integral_schwartz,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(i_hole,j_hole,k_part,l_part,mo_integrals_map) + hij = get_mo_bielec_integral_schwartz(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(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) + 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) 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(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) + 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) 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,hij,delta_e,exc,contrib + double precision :: get_mo_bielec_integral_schwartz,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(i_hole,j_hole,k_part,l_part,mo_integrals_map) + hij = get_mo_bielec_integral_schwartz(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/create_1h_or_1p.irp.f b/plugins/FOBOCI/create_1h_or_1p.irp.f index 41ec7b6c..140ed504 100644 --- a/plugins/FOBOCI/create_1h_or_1p.irp.f +++ b/plugins/FOBOCI/create_1h_or_1p.irp.f @@ -68,9 +68,7 @@ subroutine create_restart_and_1h(i_hole) SOFT_TOUCH N_det psi_det psi_coef logical :: found_duplicates - if(n_act_orb.gt.1)then call remove_duplicates_in_psi_det(found_duplicates) - endif end subroutine create_restart_and_1p(i_particle) @@ -215,8 +213,6 @@ subroutine create_restart_1h_1p(i_hole,i_part) SOFT_TOUCH N_det psi_det psi_coef logical :: found_duplicates - if(n_act_orb.gt.1)then call remove_duplicates_in_psi_det(found_duplicates) - endif end diff --git a/plugins/FOBOCI/diag_fock_inactiv_virt.irp.f b/plugins/FOBOCI/diag_fock_inactiv_virt.irp.f index 40d75fc4..83955e61 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 + double precision :: tmp(mo_tot_num_align,mo_tot_num),accu,get_mo_bielec_integral_schwartz 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(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) + 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) 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(i_virt,k_act,j_virt,k_act,mo_integrals_map) + accu += get_mo_bielec_integral_schwartz(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 dd1ed221..a18f8fe5 100644 --- a/plugins/FOBOCI/dress_simple.irp.f +++ b/plugins/FOBOCI/dress_simple.irp.f @@ -58,7 +58,24 @@ subroutine standard_dress(delta_ij_generators_,size_buffer,Ndet_generators,i_gen call i_h_j(det_buffer(1,1,i),det_buffer(1,1,i),Nint,haa) f = 1.d0/(E_ref-haa) +! if(second_order_h)then lambda_i = f +! else +! ! You write the new Hamiltonian matrix +! do k = 1, Ndet_generators +! H_matrix_tmp(k,Ndet_generators+1) = H_array(k) +! H_matrix_tmp(Ndet_generators+1,k) = H_array(k) +! enddo +! H_matrix_tmp(Ndet_generators+1,Ndet_generators+1) = haa +! ! Then diagonalize it +! call lapack_diag(eigenvalues,eigenvectors,H_matrix_tmp,Ndet_generators+1,Ndet_generators+1) +! ! Then you extract the effective denominator +! accu = 0.d0 +! do k = 1, Ndet_generators +! accu += eigenvectors(k,1) * H_array(k) +! enddo +! lambda_i = eigenvectors(Ndet_generators+1,1)/accu +! endif do k=1,idx(0) contrib = H_array(idx(k)) * H_array(idx(k)) * lambda_i delta_ij_generators_(idx(k), idx(k)) += contrib @@ -72,21 +89,20 @@ subroutine standard_dress(delta_ij_generators_,size_buffer,Ndet_generators,i_gen end -subroutine is_a_good_candidate(threshold,is_ok,e_pt2,verbose,exit_loop,is_ok_perturbative) +subroutine is_a_good_candidate(threshold,is_ok,verbose) use bitmasks implicit none double precision, intent(in) :: threshold - double precision, intent(out):: e_pt2 - logical, intent(out) :: is_ok,exit_loop,is_ok_perturbative + logical, intent(out) :: is_ok logical, intent(in) :: verbose integer :: l,k,m double precision,allocatable :: dressed_H_matrix(:,:) - double precision, allocatable :: psi_coef_diagonalized_tmp(:,:) + double precision,allocatable :: psi_coef_diagonalized_tmp(:,:) integer(bit_kind), allocatable :: psi_det_generators_input(:,:,:) - double precision :: hij - allocate(psi_det_generators_input(N_int,2,N_det_generators),dressed_H_matrix(N_det_generators,N_det_generators),psi_coef_diagonalized_tmp(N_det_generators,N_states)) + allocate(psi_det_generators_input(N_int,2,N_det_generators),dressed_H_matrix(N_det_generators,N_det_generators)) + allocate(psi_coef_diagonalized_tmp(N_det_generators,N_states)) dressed_H_matrix = 0.d0 do k = 1, N_det_generators do l = 1, N_int @@ -95,20 +111,9 @@ subroutine is_a_good_candidate(threshold,is_ok,e_pt2,verbose,exit_loop,is_ok_per enddo enddo !call H_apply_dressed_pert(dressed_H_matrix,N_det_generators,psi_det_generators_input) - call dress_H_matrix_from_psi_det_input(psi_det_generators_input,N_det_generators,is_ok,psi_coef_diagonalized_tmp, dressed_H_matrix,threshold,verbose,exit_loop,is_ok_perturbative) -!do m = 1, N_states -! do k = 1, N_det_generators -! do l = 1, N_int -! psi_selectors(l,1,k) = psi_det_generators_input(l,1,k) -! psi_selectors(l,2,k) = psi_det_generators_input(l,2,k) -! enddo -! psi_selectors_coef(k,m) = psi_coef_diagonalized_tmp(k,m) -! enddo -!enddo -!soft_touch psi_selectors psi_selectors_coef -!if(do_it_perturbative)then - print*, 'is_ok_perturbative',is_ok_perturbative - if(is_ok.or.is_ok_perturbative)then + call dress_H_matrix_from_psi_det_input(psi_det_generators_input,N_det_generators,is_ok,psi_coef_diagonalized_tmp, dressed_H_matrix,threshold,verbose) + if(do_it_perturbative)then + if(is_ok)then N_det = N_det_generators do m = 1, N_states do k = 1, N_det_generators @@ -117,19 +122,11 @@ subroutine is_a_good_candidate(threshold,is_ok,e_pt2,verbose,exit_loop,is_ok_per psi_det(l,2,k) = psi_det_generators_input(l,2,k) enddo psi_coef(k,m) = psi_coef_diagonalized_tmp(k,m) - print*, 'psi_coef(k,m)',psi_coef(k,m) - enddo - enddo - soft_touch psi_det psi_coef N_det - e_pt2 = 0.d0 - do m =1, N_det_generators - do l = 1, N_det_generators - call i_h_j(psi_det_generators_input(1,1,m),psi_det_generators_input(1,1,l),N_int,hij) ! Fill the zeroth order H matrix - e_pt2 += (dressed_H_matrix(m,l) - hij)* psi_coef_diagonalized_tmp(m,1)* psi_coef_diagonalized_tmp(l,1) enddo enddo + touch psi_coef psi_det N_det endif -!endif + endif deallocate(psi_det_generators_input,dressed_H_matrix,psi_coef_diagonalized_tmp) @@ -138,14 +135,14 @@ subroutine is_a_good_candidate(threshold,is_ok,e_pt2,verbose,exit_loop,is_ok_per end -subroutine dress_H_matrix_from_psi_det_input(psi_det_generators_input,Ndet_generators,is_ok,psi_coef_diagonalized_tmp, dressed_H_matrix,threshold,verbose,exit_loop,is_ok_perturbative) +subroutine dress_H_matrix_from_psi_det_input(psi_det_generators_input,Ndet_generators,is_ok,psi_coef_diagonalized_tmp, dressed_H_matrix,threshold,verbose) use bitmasks implicit none integer(bit_kind), intent(in) :: psi_det_generators_input(N_int,2,Ndet_generators) integer, intent(in) :: Ndet_generators double precision, intent(in) :: threshold logical, intent(in) :: verbose - logical, intent(out) :: is_ok,exit_loop,is_ok_perturbative + logical, intent(out) :: is_ok double precision, intent(out) :: psi_coef_diagonalized_tmp(Ndet_generators,N_states) double precision, intent(inout) :: dressed_H_matrix(Ndet_generators, Ndet_generators) @@ -154,7 +151,6 @@ subroutine dress_H_matrix_from_psi_det_input(psi_det_generators_input,Ndet_gener double precision :: eigvalues(Ndet_generators), eigvectors(Ndet_generators,Ndet_generators),hij double precision :: psi_coef_ref(Ndet_generators,N_states),diag_h_mat_average,diag_h_mat_no_ref_average logical :: is_a_ref_det(Ndet_generators) - exit_loop = .False. is_a_ref_det = .False. do i = 1, N_det_generators @@ -195,7 +191,6 @@ subroutine dress_H_matrix_from_psi_det_input(psi_det_generators_input,Ndet_gener if(number_of_holes(psi_det_generators_input(1,1,i)).eq.0 .and. number_of_particles(psi_det_generators_input(1,1,i)).eq.1)then if(diag_h_mat_average - dressed_H_matrix(index_ref_generators_restart,index_ref_generators_restart) .gt.2.d0)then is_ok = .False. - exit_loop = .True. return endif endif @@ -283,11 +278,9 @@ subroutine dress_H_matrix_from_psi_det_input(psi_det_generators_input,Ndet_gener do k = 1, N_states accu = 0.d0 do j =1, Ndet_generators - print*,'',eigvectors(j,i) , psi_coef_ref(j,k) accu += eigvectors(j,i) * psi_coef_ref(j,k) enddo - print*,'accu = ',accu - if(dabs(accu).ge.0.72d0)then + if(dabs(accu).ge.0.8d0)then i_good_state(0) +=1 i_good_state(i_good_state(0)) = i endif @@ -328,124 +321,10 @@ subroutine dress_H_matrix_from_psi_det_input(psi_det_generators_input,Ndet_gener exit endif enddo - if(.not.is_ok)then - is_ok_perturbative = .True. - do i = 1, Ndet_generators - if(is_a_ref_det(i))cycle - do k = 1, N_states - print*, psi_coef_diagonalized_tmp(i,k),threshold_perturbative - if(dabs(psi_coef_diagonalized_tmp(i,k)) .gt.threshold_perturbative)then - is_ok_perturbative = .False. - exit - endif - enddo - if(.not.is_ok_perturbative)then - exit - endif - enddo - endif if(verbose)then - print*,'is_ok = ',is_ok - print*,'is_ok_perturbative = ',is_ok_perturbative + print*,'is_ok = ',is_ok endif end -subroutine fill_H_apply_buffer_no_selection_first_order_coef(n_selected,det_buffer,Nint,iproc) - use bitmasks - implicit none - BEGIN_DOC - ! Fill the H_apply buffer with determiants for CISD - END_DOC - - integer, intent(in) :: n_selected, Nint, iproc - integer(bit_kind), intent(in) :: det_buffer(Nint,2,n_selected) - integer :: i,j,k - integer :: new_size - PROVIDE H_apply_buffer_allocated - call omp_set_lock(H_apply_buffer_lock(1,iproc)) - new_size = H_apply_buffer(iproc)%N_det + n_selected - if (new_size > H_apply_buffer(iproc)%sze) then - call resize_h_apply_buffer(max(2*H_apply_buffer(iproc)%sze,new_size),iproc) - endif - do i=1,H_apply_buffer(iproc)%N_det - ASSERT (sum(popcnt(H_apply_buffer(iproc)%det(:,1,i)) )== elec_alpha_num) - ASSERT (sum(popcnt(H_apply_buffer(iproc)%det(:,2,i))) == elec_beta_num) - enddo - do i=1,n_selected - do j=1,N_int - H_apply_buffer(iproc)%det(j,1,i+H_apply_buffer(iproc)%N_det) = det_buffer(j,1,i) - H_apply_buffer(iproc)%det(j,2,i+H_apply_buffer(iproc)%N_det) = det_buffer(j,2,i) - enddo - ASSERT (sum(popcnt(H_apply_buffer(iproc)%det(:,1,i+H_apply_buffer(iproc)%N_det)) )== elec_alpha_num) - ASSERT (sum(popcnt(H_apply_buffer(iproc)%det(:,2,i+H_apply_buffer(iproc)%N_det))) == elec_beta_num) - enddo - double precision :: i_H_psi_array(N_states),h,diag_H_mat_elem_fock,delta_e - do i=1,N_selected - 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 - 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 - H_apply_buffer(iproc)%N_det = new_size - do i=1,H_apply_buffer(iproc)%N_det - ASSERT (sum(popcnt(H_apply_buffer(iproc)%det(:,1,i)) )== elec_alpha_num) - ASSERT (sum(popcnt(H_apply_buffer(iproc)%det(:,2,i))) == elec_beta_num) - enddo - call omp_unset_lock(H_apply_buffer_lock(1,iproc)) -end - - - -subroutine make_s2_eigenfunction_first_order - implicit none - integer :: i,j,k - integer :: smax, s - integer(bit_kind), allocatable :: d(:,:,:), det_buffer(:,:,:) - integer :: N_det_new - integer, parameter :: bufsze = 1000 - logical, external :: is_in_wavefunction - - allocate (d(N_int,2,1), det_buffer(N_int,2,bufsze) ) - smax = 1 - N_det_new = 0 - - do i=1,N_occ_pattern - call occ_pattern_to_dets_size(psi_occ_pattern(1,1,i),s,elec_alpha_num,N_int) - s += 1 - if (s > smax) then - deallocate(d) - allocate ( d(N_int,2,s) ) - smax = s - endif - call occ_pattern_to_dets(psi_occ_pattern(1,1,i),d,s,elec_alpha_num,N_int) - do j=1,s - if (.not. is_in_wavefunction(d(1,1,j), N_int) ) then - N_det_new += 1 - do k=1,N_int - det_buffer(k,1,N_det_new) = d(k,1,j) - det_buffer(k,2,N_det_new) = d(k,2,j) - enddo - if (N_det_new == bufsze) then - call fill_H_apply_buffer_no_selection(bufsze,det_buffer,N_int,0) - N_det_new = 0 - endif - endif - enddo - enddo - - if (N_det_new > 0) then - call fill_H_apply_buffer_no_selection_first_order_coef(N_det_new,det_buffer,N_int,0) - call copy_H_apply_buffer_to_wf - SOFT_TOUCH N_det psi_coef psi_det - endif - - deallocate(d,det_buffer) - - call write_int(output_determinants,N_det_new, 'Added deteminants for S^2') - -end - diff --git a/plugins/FOBOCI/fobo_scf.irp.f b/plugins/FOBOCI/fobo_scf.irp.f index 8a709154..8656b633 100644 --- a/plugins/FOBOCI/fobo_scf.irp.f +++ b/plugins/FOBOCI/fobo_scf.irp.f @@ -1,13 +1,8 @@ program foboscf implicit none -!if(disk_access_ao_integrals == "None" .or. disk_access_ao_integrals == "Read" )then -! disk_access_ao_integrals = "Write" -! touch disk_access_ao_integrals -!endif -!print*, 'disk_access_ao_integrals',disk_access_ao_integrals + call run_prepare no_oa_or_av_opt = .True. touch no_oa_or_av_opt - call run_prepare call routine_fobo_scf call save_mos @@ -15,8 +10,8 @@ end subroutine run_prepare implicit none -! no_oa_or_av_opt = .False. -! touch no_oa_or_av_opt + no_oa_or_av_opt = .False. + touch no_oa_or_av_opt call damping_SCF call diag_inactive_virt_and_update_mos end @@ -32,7 +27,6 @@ subroutine routine_fobo_scf print*,'*******************************************************************************' print*,'*******************************************************************************' print*,'FOBO-SCF Iteration ',i - print*, 'ao_bielec_integrals_in_map = ',ao_bielec_integrals_in_map print*,'*******************************************************************************' print*,'*******************************************************************************' if(speed_up_convergence_foboscf)then @@ -52,7 +46,7 @@ subroutine routine_fobo_scf soft_touch threshold_lmct threshold_mlct endif endif - call FOBOCI_lmct_mlct_old_thr(i) + call FOBOCI_lmct_mlct_old_thr call save_osoci_natural_mos call damping_SCF call diag_inactive_virt_and_update_mos diff --git a/plugins/FOBOCI/foboci_lmct_mlct_threshold_old.irp.f b/plugins/FOBOCI/foboci_lmct_mlct_threshold_old.irp.f index 46ca9662..dc6519b8 100644 --- a/plugins/FOBOCI/foboci_lmct_mlct_threshold_old.irp.f +++ b/plugins/FOBOCI/foboci_lmct_mlct_threshold_old.irp.f @@ -1,8 +1,7 @@ -subroutine FOBOCI_lmct_mlct_old_thr(iter) +subroutine FOBOCI_lmct_mlct_old_thr use bitmasks implicit none - integer, intent(in) :: iter integer :: i,j,k,l integer(bit_kind),allocatable :: unpaired_bitmask(:,:) integer, allocatable :: occ(:,:) @@ -11,7 +10,7 @@ subroutine FOBOCI_lmct_mlct_old_thr(iter) logical :: test_sym double precision :: thr,hij double precision, allocatable :: dressing_matrix(:,:) - logical :: verbose,is_ok,is_ok_perturbative + logical :: verbose,is_ok verbose = .True. thr = 1.d-12 allocate(unpaired_bitmask(N_int,2)) @@ -39,7 +38,6 @@ subroutine FOBOCI_lmct_mlct_old_thr(iter) integer(bit_kind) , allocatable :: psi_singles(:,:,:) logical :: lmct double precision, allocatable :: psi_singles_coef(:,:) - logical :: exit_loop allocate( zero_bitmask(N_int,2) ) do i = 1, n_inact_orb lmct = .True. @@ -47,45 +45,87 @@ subroutine FOBOCI_lmct_mlct_old_thr(iter) i_hole_osoci = list_inact(i) print*,'--------------------------' ! First set the current generators to the one of restart - call check_symetry(i_hole_osoci,thr,test_sym) - if(.not.test_sym)cycle call set_generators_to_generators_restart call set_psi_det_to_generators + call check_symetry(i_hole_osoci,thr,test_sym) + if(.not.test_sym)cycle print*,'i_hole_osoci = ',i_hole_osoci call create_restart_and_1h(i_hole_osoci) call set_generators_to_psi_det print*,'Passed set generators' call set_bitmask_particl_as_input(reunion_of_bitmask) call set_bitmask_hole_as_input(reunion_of_bitmask) - double precision :: e_pt2 - call is_a_good_candidate(threshold_lmct,is_ok,e_pt2,verbose,exit_loop,is_ok_perturbative) + call is_a_good_candidate(threshold_lmct,is_ok,verbose) print*,'is_ok = ',is_ok - if(is_ok)then - allocate(dressing_matrix(N_det_generators,N_det_generators)) - dressing_matrix = 0.d0 - do k = 1, N_det_generators - do l = 1, N_det_generators - call i_h_j(psi_det_generators(1,1,k),psi_det_generators(1,1,l),N_int,hkl) - dressing_matrix(k,l) = hkl - enddo + if(.not.is_ok)cycle + allocate(dressing_matrix(N_det_generators,N_det_generators)) + dressing_matrix = 0.d0 + if(.not.do_it_perturbative)then + + do k = 1, N_det_generators + do l = 1, N_det_generators + call i_h_j(psi_det_generators(1,1,k),psi_det_generators(1,1,l),N_int,hkl) + dressing_matrix(k,l) = hkl enddo - hkl = dressing_matrix(1,1) - do k = 1, N_det_generators - dressing_matrix(k,k) = dressing_matrix(k,k) - hkl - enddo - print*,'Naked matrix' - do k = 1, N_det_generators - write(*,'(100(F12.5,X))')dressing_matrix(k,:) - enddo - - ! Do all the single excitations on top of the CAS and 1h determinants - call set_bitmask_particl_as_input(reunion_of_bitmask) - call set_bitmask_hole_as_input(reunion_of_bitmask) - call all_single(e_pt2) - call make_s2_eigenfunction_first_order - threshold_davidson = 1.d-6 - soft_touch threshold_davidson davidson_criterion - call diagonalize_ci + enddo + hkl = dressing_matrix(1,1) + do k = 1, N_det_generators + dressing_matrix(k,k) = dressing_matrix(k,k) - hkl + enddo + print*,'Naked matrix' + do k = 1, N_det_generators + write(*,'(100(F12.5,X))')dressing_matrix(k,:) + enddo + + ! Do all the single excitations on top of the CAS and 1h determinants + call set_bitmask_particl_as_input(reunion_of_bitmask) + call set_bitmask_hole_as_input(reunion_of_bitmask) + call all_single +! if(dressing_2h2p)then +! call diag_dressed_2h2p_hamiltonian_and_update_psi_det(i_hole_osoci,lmct) +! endif + +! ! Change the mask of the holes and particles to perform all the +! ! double excitations that starts from the active space in order +! ! to introduce the Coulomb hole in the active space +! ! These are the 1h2p excitations that have the i_hole_osoci hole in common +! ! and the 2p if there is more than one electron in the active space +! do k = 1, N_int +! zero_bitmask(k,1) = 0_bit_kind +! zero_bitmask(k,2) = 0_bit_kind +! enddo +! ! hole is possible only in the orbital i_hole_osoci +! call set_bit_to_integer(i_hole_osoci,zero_bitmask(1,1),N_int) +! call set_bit_to_integer(i_hole_osoci,zero_bitmask(1,2),N_int) +! ! and in the active space +! do k = 1, n_act_orb +! call set_bit_to_integer(list_act(k),zero_bitmask(1,1),N_int) +! call set_bit_to_integer(list_act(k),zero_bitmask(1,2),N_int) +! enddo +! call set_bitmask_hole_as_input(zero_bitmask) + +! call set_bitmask_particl_as_input(reunion_of_bitmask) + +! call all_1h2p +! call diagonalize_CI_SC2 +! call provide_matrix_dressing(dressing_matrix,n_det_generators,psi_det_generators) + +! ! Change the mask of the holes and particles to perform all the +! ! double excitations that from the orbital i_hole_osoci +! do k = 1, N_int +! zero_bitmask(k,1) = 0_bit_kind +! zero_bitmask(k,2) = 0_bit_kind +! enddo +! ! hole is possible only in the orbital i_hole_osoci +! call set_bit_to_integer(i_hole_osoci,zero_bitmask(1,1),N_int) +! call set_bit_to_integer(i_hole_osoci,zero_bitmask(1,2),N_int) +! call set_bitmask_hole_as_input(zero_bitmask) + +! call set_bitmask_particl_as_input(reunion_of_bitmask) + +! call set_psi_det_to_generators +! call all_2h2p +! call diagonalize_CI_SC2 double precision :: hkl call provide_matrix_dressing(dressing_matrix,n_det_generators,psi_det_generators) hkl = dressing_matrix(1,1) @@ -96,10 +136,7 @@ subroutine FOBOCI_lmct_mlct_old_thr(iter) do k = 1, N_det_generators write(*,'(100(F12.5,X))')dressing_matrix(k,:) enddo - deallocate(dressing_matrix) - else - if(.not.do_it_perturbative)cycle - if(.not. is_ok_perturbative)cycle +! call diag_dressed_matrix_and_set_to_psi_det(psi_det_generators,N_det_generators,dressing_matrix) endif call set_intermediate_normalization_lmct_old(norm_tmp,i_hole_osoci) @@ -108,6 +145,7 @@ subroutine FOBOCI_lmct_mlct_old_thr(iter) norm_total(k) += norm_tmp(k) enddo call update_density_matrix_osoci + deallocate(dressing_matrix) enddo if(.True.)then @@ -121,10 +159,10 @@ subroutine FOBOCI_lmct_mlct_old_thr(iter) print*,'--------------------------' ! First set the current generators to the one of restart - call check_symetry(i_particl_osoci,thr,test_sym) - if(.not.test_sym)cycle call set_generators_to_generators_restart call set_psi_det_to_generators + call check_symetry(i_particl_osoci,thr,test_sym) + if(.not.test_sym)cycle print*,'i_particl_osoci= ',i_particl_osoci ! Initialize the bitmask to the restart ones call initialize_bitmask_to_restart_ones @@ -140,33 +178,24 @@ subroutine FOBOCI_lmct_mlct_old_thr(iter) call set_bitmask_particl_as_input(reunion_of_bitmask) call set_bitmask_hole_as_input(reunion_of_bitmask) !! ! so all the mono excitation on the new generators - call is_a_good_candidate(threshold_mlct,is_ok,e_pt2,verbose,exit_loop,is_ok_perturbative) + call is_a_good_candidate(threshold_mlct,is_ok,verbose) print*,'is_ok = ',is_ok - if(is_ok)then - allocate(dressing_matrix(N_det_generators,N_det_generators)) - dressing_matrix = 0.d0 - do k = 1, N_det_generators - do l = 1, N_det_generators - call i_h_j(psi_det_generators(1,1,k),psi_det_generators(1,1,l),N_int,hkl) - dressing_matrix(k,l) = hkl - enddo + if(.not.is_ok)cycle + allocate(dressing_matrix(N_det_generators,N_det_generators)) + if(.not.do_it_perturbative)then + dressing_matrix = 0.d0 + do k = 1, N_det_generators + do l = 1, N_det_generators + call i_h_j(psi_det_generators(1,1,k),psi_det_generators(1,1,l),N_int,hkl) + dressing_matrix(k,l) = hkl enddo - call all_single(e_pt2) - call make_s2_eigenfunction_first_order - threshold_davidson = 1.d-6 - soft_touch threshold_davidson davidson_criterion - - call diagonalize_ci - deallocate(dressing_matrix) - else - if(exit_loop)then - call set_generators_to_generators_restart - call set_psi_det_to_generators - exit - else - if(.not.do_it_perturbative)cycle - if(.not. is_ok_perturbative)cycle - endif + enddo + ! call all_single_split(psi_det_generators,psi_coef_generators,N_det_generators,dressing_matrix) + ! call diag_dressed_matrix_and_set_to_psi_det(psi_det_generators,N_det_generators,dressing_matrix) + call all_single +! if(dressing_2h2p)then +! call diag_dressed_2h2p_hamiltonian_and_update_psi_det(i_particl_osoci,lmct) +! endif endif call set_intermediate_normalization_mlct_old(norm_tmp,i_particl_osoci) do k = 1, N_states @@ -174,6 +203,7 @@ subroutine FOBOCI_lmct_mlct_old_thr(iter) norm_total(k) += norm_tmp(k) enddo call update_density_matrix_osoci + deallocate(dressing_matrix) enddo endif @@ -200,7 +230,7 @@ subroutine FOBOCI_mlct_old double precision :: norm_tmp,norm_total logical :: test_sym double precision :: thr - logical :: verbose,is_ok,exit_loop + logical :: verbose,is_ok verbose = .False. thr = 1.d-12 allocate(unpaired_bitmask(N_int,2)) @@ -240,7 +270,7 @@ subroutine FOBOCI_mlct_old call set_bitmask_particl_as_input(reunion_of_bitmask) call set_bitmask_hole_as_input(reunion_of_bitmask) ! ! so all the mono excitation on the new generators - call is_a_good_candidate(threshold_mlct,is_ok,verbose,exit_loop) + call is_a_good_candidate(threshold_mlct,is_ok,verbose) print*,'is_ok = ',is_ok is_ok =.True. if(.not.is_ok)cycle @@ -274,7 +304,7 @@ subroutine FOBOCI_lmct_old double precision :: norm_tmp,norm_total logical :: test_sym double precision :: thr - logical :: verbose,is_ok,exit_loop + logical :: verbose,is_ok verbose = .False. thr = 1.d-12 allocate(unpaired_bitmask(N_int,2)) @@ -312,7 +342,7 @@ subroutine FOBOCI_lmct_old call set_generators_to_psi_det call set_bitmask_particl_as_input(reunion_of_bitmask) call set_bitmask_hole_as_input(reunion_of_bitmask) - call is_a_good_candidate(threshold_lmct,is_ok,verbose,exit_loop) + call is_a_good_candidate(threshold_lmct,is_ok,verbose) print*,'is_ok = ',is_ok if(.not.is_ok)cycle ! ! so all the mono excitation on the new generators @@ -335,303 +365,3 @@ subroutine FOBOCI_lmct_old enddo print*,'accu = ',accu end - -subroutine FOBOCI_lmct_mlct_old_thr_restart(iter) - use bitmasks - implicit none - integer, intent(in) :: iter - integer :: i,j,k,l - integer(bit_kind),allocatable :: unpaired_bitmask(:,:) - integer, allocatable :: occ(:,:) - integer :: n_occ_alpha, n_occ_beta - double precision :: norm_tmp(N_states),norm_total(N_states) - logical :: test_sym - double precision :: thr,hij - double precision, allocatable :: dressing_matrix(:,:) - logical :: verbose,is_ok,is_ok_perturbative - verbose = .True. - thr = 1.d-12 - allocate(unpaired_bitmask(N_int,2)) - allocate (occ(N_int*bit_kind_size,2)) - do i = 1, N_int - unpaired_bitmask(i,1) = unpaired_alpha_electrons(i) - unpaired_bitmask(i,2) = unpaired_alpha_electrons(i) - enddo - norm_total = 0.d0 - call initialize_density_matrix_osoci - call bitstring_to_list(inact_bitmask(1,1), occ(1,1), n_occ_beta, N_int) - print*,'' - print*,'' - print*,'mulliken spin population analysis' - accu =0.d0 - do i = 1, nucl_num - accu += mulliken_spin_densities(i) - print*,i,nucl_charge(i),mulliken_spin_densities(i) - enddo - print*,'' - print*,'' - print*,'DOING FIRST LMCT !!' - print*,'Threshold_lmct = ',threshold_lmct - integer(bit_kind) , allocatable :: zero_bitmask(:,:) - integer(bit_kind) , allocatable :: psi_singles(:,:,:) - logical :: lmct - double precision, allocatable :: psi_singles_coef(:,:) - logical :: exit_loop - allocate( zero_bitmask(N_int,2) ) - if(iter.ne.1)then - do i = 1, n_inact_orb - lmct = .True. - integer :: i_hole_osoci - i_hole_osoci = list_inact(i) - print*,'--------------------------' - ! First set the current generators to the one of restart - call check_symetry(i_hole_osoci,thr,test_sym) - if(.not.test_sym)cycle - call set_generators_to_generators_restart - call set_psi_det_to_generators - print*,'i_hole_osoci = ',i_hole_osoci - call create_restart_and_1h(i_hole_osoci) - call set_generators_to_psi_det - print*,'Passed set generators' - call set_bitmask_particl_as_input(reunion_of_bitmask) - call set_bitmask_hole_as_input(reunion_of_bitmask) - double precision :: e_pt2 - call is_a_good_candidate(threshold_lmct,is_ok,e_pt2,verbose,exit_loop,is_ok_perturbative) - print*,'is_ok = ',is_ok - if(is_ok)then - allocate(dressing_matrix(N_det_generators,N_det_generators)) - dressing_matrix = 0.d0 - do k = 1, N_det_generators - do l = 1, N_det_generators - call i_h_j(psi_det_generators(1,1,k),psi_det_generators(1,1,l),N_int,hkl) - dressing_matrix(k,l) = hkl - enddo - enddo - hkl = dressing_matrix(1,1) - do k = 1, N_det_generators - dressing_matrix(k,k) = dressing_matrix(k,k) - hkl - enddo - print*,'Naked matrix' - do k = 1, N_det_generators - write(*,'(100(F12.5,X))')dressing_matrix(k,:) - enddo - - ! Do all the single excitations on top of the CAS and 1h determinants - call set_bitmask_particl_as_input(reunion_of_bitmask) - call set_bitmask_hole_as_input(reunion_of_bitmask) - call all_single(e_pt2) - call make_s2_eigenfunction_first_order - threshold_davidson = 1.d-6 - soft_touch threshold_davidson davidson_criterion - call diagonalize_ci - double precision :: hkl - call provide_matrix_dressing(dressing_matrix,n_det_generators,psi_det_generators) - hkl = dressing_matrix(1,1) - do k = 1, N_det_generators - dressing_matrix(k,k) = dressing_matrix(k,k) - hkl - enddo - print*,'Dressed matrix' - do k = 1, N_det_generators - write(*,'(100(F12.5,X))')dressing_matrix(k,:) - enddo - deallocate(dressing_matrix) - else - if(.not.do_it_perturbative)cycle - if(.not. is_ok_perturbative)cycle - endif - call set_intermediate_normalization_lmct_old(norm_tmp,i_hole_osoci) - - do k = 1, N_states - print*,'norm_tmp = ',norm_tmp(k) - norm_total(k) += norm_tmp(k) - enddo - call update_density_matrix_osoci - enddo - else - double precision :: array_dm(mo_tot_num) - call read_dm_from_lmct(array_dm) - call update_density_matrix_beta_osoci_read(array_dm) - endif - - if(iter.ne.1)then - if(.True.)then - print*,'' - print*,'DOING THEN THE MLCT !!' - print*,'Threshold_mlct = ',threshold_mlct - lmct = .False. - do i = 1, n_virt_orb - integer :: i_particl_osoci - i_particl_osoci = list_virt(i) - - print*,'--------------------------' - ! First set the current generators to the one of restart - call check_symetry(i_particl_osoci,thr,test_sym) - if(.not.test_sym)cycle - call set_generators_to_generators_restart - call set_psi_det_to_generators - print*,'i_particl_osoci= ',i_particl_osoci - ! Initialize the bitmask to the restart ones - call initialize_bitmask_to_restart_ones - ! Impose that only the hole i_hole_osoci can be done - call modify_bitmasks_for_particl(i_particl_osoci) - call print_generators_bitmasks_holes - ! Impose that only the active part can be reached - call set_bitmask_hole_as_input(unpaired_bitmask) -!!! call all_single_h_core - call create_restart_and_1p(i_particl_osoci) -!!! ! Update the generators - call set_generators_to_psi_det - call set_bitmask_particl_as_input(reunion_of_bitmask) - call set_bitmask_hole_as_input(reunion_of_bitmask) -!!! ! so all the mono excitation on the new generators - call is_a_good_candidate(threshold_mlct,is_ok,e_pt2,verbose,exit_loop,is_ok_perturbative) - print*,'is_ok = ',is_ok - if(is_ok)then - allocate(dressing_matrix(N_det_generators,N_det_generators)) - dressing_matrix = 0.d0 - do k = 1, N_det_generators - do l = 1, N_det_generators - call i_h_j(psi_det_generators(1,1,k),psi_det_generators(1,1,l),N_int,hkl) - dressing_matrix(k,l) = hkl - enddo - enddo - call all_single(e_pt2) - call make_s2_eigenfunction_first_order - threshold_davidson = 1.d-6 - soft_touch threshold_davidson davidson_criterion - - call diagonalize_ci - deallocate(dressing_matrix) - else - if(exit_loop)then - call set_generators_to_generators_restart - call set_psi_det_to_generators - exit - else - if(.not.do_it_perturbative)cycle - if(.not. is_ok_perturbative)cycle - endif - endif - call set_intermediate_normalization_mlct_old(norm_tmp,i_particl_osoci) - do k = 1, N_states - print*,'norm_tmp = ',norm_tmp(k) - norm_total(k) += norm_tmp(k) - enddo - call update_density_matrix_osoci - enddo - endif - else - integer :: norb - call read_dm_from_mlct(array_dm,norb) - call update_density_matrix_alpha_osoci_read(array_dm) - do i = norb+1, n_virt_orb - i_particl_osoci = list_virt(i) - - print*,'--------------------------' - ! First set the current generators to the one of restart - call check_symetry(i_particl_osoci,thr,test_sym) - if(.not.test_sym)cycle - call set_generators_to_generators_restart - call set_psi_det_to_generators - print*,'i_particl_osoci= ',i_particl_osoci - ! Initialize the bitmask to the restart ones - call initialize_bitmask_to_restart_ones - ! Impose that only the hole i_hole_osoci can be done - call modify_bitmasks_for_particl(i_particl_osoci) - call print_generators_bitmasks_holes - ! Impose that only the active part can be reached - call set_bitmask_hole_as_input(unpaired_bitmask) -!!! call all_single_h_core - call create_restart_and_1p(i_particl_osoci) -!!! ! Update the generators - call set_generators_to_psi_det - call set_bitmask_particl_as_input(reunion_of_bitmask) - call set_bitmask_hole_as_input(reunion_of_bitmask) -!!! ! so all the mono excitation on the new generators - call is_a_good_candidate(threshold_mlct,is_ok,e_pt2,verbose,exit_loop,is_ok_perturbative) - print*,'is_ok = ',is_ok - if(is_ok)then - allocate(dressing_matrix(N_det_generators,N_det_generators)) - dressing_matrix = 0.d0 - do k = 1, N_det_generators - do l = 1, N_det_generators - call i_h_j(psi_det_generators(1,1,k),psi_det_generators(1,1,l),N_int,hkl) - dressing_matrix(k,l) = hkl - enddo - enddo - call all_single(e_pt2) - call make_s2_eigenfunction_first_order - threshold_davidson = 1.d-6 - soft_touch threshold_davidson davidson_criterion - - call diagonalize_ci - deallocate(dressing_matrix) - else - if(exit_loop)then - call set_generators_to_generators_restart - call set_psi_det_to_generators - exit - else - if(.not.do_it_perturbative)cycle - if(.not. is_ok_perturbative)cycle - endif - endif - call set_intermediate_normalization_mlct_old(norm_tmp,i_particl_osoci) - do k = 1, N_states - print*,'norm_tmp = ',norm_tmp(k) - norm_total(k) += norm_tmp(k) - enddo - call update_density_matrix_osoci - enddo - endif - - print*,'norm_total = ',norm_total - norm_total = norm_generators_restart - norm_total = 1.d0/norm_total -! call rescale_density_matrix_osoci(norm_total) - double precision :: accu - accu = 0.d0 - do i = 1, mo_tot_num - accu += one_body_dm_mo_alpha_osoci(i,i) + one_body_dm_mo_beta_osoci(i,i) - enddo - print*,'accu = ',accu -end - -subroutine read_dm_from_lmct(array) - implicit none - integer :: i,iunit ,getUnitAndOpen - double precision :: stuff - double precision, intent(out) :: array(mo_tot_num) - character*(128) :: input - input=trim("fort.33") - iunit= getUnitAndOpen(input,'r') - print*, iunit - array = 0.d0 - do i = 1, n_inact_orb - read(iunit,*) stuff - print*, list_inact(i),stuff - array(list_inact(i)) = stuff - enddo -end - -subroutine read_dm_from_mlct(array,norb) - implicit none - integer :: i,iunit ,getUnitAndOpen - double precision :: stuff - double precision, intent(out) :: array(mo_tot_num) - character*(128) :: input - input=trim("fort.35") - iunit= getUnitAndOpen(input,'r') - integer,intent(out) :: norb - read(iunit,*)norb - print*, iunit - input=trim("fort.34") - iunit= getUnitAndOpen(input,'r') - array = 0.d0 - print*, 'norb = ',norb - do i = 1, norb - read(iunit,*) stuff - print*, list_virt(i),stuff - array(list_virt(i)) = stuff - enddo -end diff --git a/plugins/FOBOCI/generators_restart_save.irp.f b/plugins/FOBOCI/generators_restart_save.irp.f index eba9f0ad..09d4aa2b 100644 --- a/plugins/FOBOCI/generators_restart_save.irp.f +++ b/plugins/FOBOCI/generators_restart_save.irp.f @@ -9,7 +9,6 @@ BEGIN_PROVIDER [ integer, N_det_generators_restart ] integer :: i integer, save :: ifirst = 0 double precision :: norm - print*, ' Providing N_det_generators_restart' if(ifirst == 0)then call ezfio_get_determinants_n_det(N_det_generators_restart) ifirst = 1 @@ -31,7 +30,6 @@ END_PROVIDER integer :: i, k integer, save :: ifirst = 0 double precision, allocatable :: psi_coef_read(:,:) - print*, ' Providing psi_det_generators_restart' if(ifirst == 0)then call read_dets(psi_det_generators_restart,N_int,N_det_generators_restart) do k = 1, N_int diff --git a/plugins/FOBOCI/hcc_1h1p.irp.f b/plugins/FOBOCI/hcc_1h1p.irp.f new file mode 100644 index 00000000..bad073db --- /dev/null +++ b/plugins/FOBOCI/hcc_1h1p.irp.f @@ -0,0 +1,82 @@ +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 + allocate(H_matrix(N_det,N_det)) + stop 'SC2_1h1p_full is not in the git!' +! 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 7d194a54..6fc60fae 100644 --- a/plugins/FOBOCI/routines_foboci.irp.f +++ b/plugins/FOBOCI/routines_foboci.irp.f @@ -212,50 +212,12 @@ subroutine update_density_matrix_osoci integer :: iorb,jorb do i = 1, mo_tot_num do j = 1, mo_tot_num - one_body_dm_mo_alpha_osoci(i,j) = one_body_dm_mo_alpha_osoci(i,j) + (one_body_dm_mo_alpha_average(i,j) - one_body_dm_mo_alpha_generators_restart(i,j)) - one_body_dm_mo_beta_osoci(i,j) = one_body_dm_mo_beta_osoci(i,j) + (one_body_dm_mo_beta_average(i,j) - one_body_dm_mo_beta_generators_restart(i,j)) + one_body_dm_mo_alpha_osoci(i,j) = one_body_dm_mo_alpha_osoci(i,j) + (one_body_dm_mo_alpha(i,j) - one_body_dm_mo_alpha_generators_restart(i,j)) + one_body_dm_mo_beta_osoci(i,j) = one_body_dm_mo_beta_osoci(i,j) + (one_body_dm_mo_beta(i,j) - one_body_dm_mo_beta_generators_restart(i,j)) enddo enddo -end - -subroutine update_density_matrix_beta_osoci_read(array) - implicit none - BEGIN_DOC - ! one_body_dm_mo_alpha_osoci += Delta rho alpha - ! one_body_dm_mo_beta_osoci += Delta rho beta - END_DOC - integer :: i,j - integer :: iorb,jorb - double precision :: array(mo_tot_num) - do i = 1, mo_tot_num - j = list_act(1) - one_body_dm_mo_beta_osoci(i,j) += array(i) - one_body_dm_mo_beta_osoci(j,i) += array(i) - one_body_dm_mo_beta_osoci(i,i) += array(i) * array(i) - enddo - - -end - -subroutine update_density_matrix_alpha_osoci_read(array) - implicit none - BEGIN_DOC - ! one_body_dm_mo_alpha_osoci += Delta rho alpha - ! one_body_dm_mo_beta_osoci += Delta rho beta - END_DOC - integer :: i,j - integer :: iorb,jorb - double precision :: array(mo_tot_num) - do i = 1, mo_tot_num - j = list_act(1) - one_body_dm_mo_alpha_osoci(i,j) += array(i) - one_body_dm_mo_alpha_osoci(j,i) += array(i) - one_body_dm_mo_alpha_osoci(i,i) += array(i) * array(i) - enddo - - end @@ -425,14 +387,14 @@ subroutine save_osoci_natural_mos print*,'ACTIVE ORBITAL ',iorb do j = 1, n_inact_orb jorb = list_inact(j) - if(dabs(tmp(iorb,jorb)).gt.0.0001d0)then + if(dabs(tmp(iorb,jorb)).gt.threshold_lmct)then print*,'INACTIVE ' print*,'DM ',iorb,jorb,(tmp(iorb,jorb)) endif enddo do j = 1, n_virt_orb jorb = list_virt(j) - if(dabs(tmp(iorb,jorb)).gt.0.0001d0)then + if(dabs(tmp(iorb,jorb)).gt.threshold_mlct)then print*,'VIRT ' print*,'DM ',iorb,jorb,(tmp(iorb,jorb)) endif @@ -450,10 +412,6 @@ subroutine save_osoci_natural_mos label = "Natural" call mo_as_eigvectors_of_mo_matrix(tmp,size(tmp,1),size(tmp,2),label,1) -!if(disk_access_ao_integrals == "None" .or. disk_access_ao_integrals == "Write" )then -! disk_access_ao_integrals = "Read" -! touch disk_access_ao_integrals -!endif !soft_touch mo_coef deallocate(tmp,occ) @@ -630,14 +588,14 @@ end integer :: i double precision :: accu_tot,accu_sd print*,'touched the one_body_dm_mo_beta' - one_body_dm_mo_alpha_average = one_body_dm_mo_alpha_osoci - one_body_dm_mo_beta_average = one_body_dm_mo_beta_osoci + one_body_dm_mo_alpha = one_body_dm_mo_alpha_osoci + one_body_dm_mo_beta = one_body_dm_mo_beta_osoci touch one_body_dm_mo_alpha one_body_dm_mo_beta accu_tot = 0.d0 accu_sd = 0.d0 do i = 1, mo_tot_num - accu_tot += one_body_dm_mo_alpha_average(i,i) + one_body_dm_mo_beta_average(i,i) - accu_sd += one_body_dm_mo_alpha_average(i,i) - one_body_dm_mo_beta_average(i,i) + accu_tot += one_body_dm_mo_alpha(i,i) + one_body_dm_mo_beta(i,i) + accu_sd += one_body_dm_mo_alpha(i,i) - one_body_dm_mo_beta(i,i) enddo print*,'accu_tot = ',accu_tot print*,'accu_sdt = ',accu_sd diff --git a/plugins/Full_CI/.gitignore b/plugins/Full_CI/.gitignore index 70d637ea..674f56da 100644 --- a/plugins/Full_CI/.gitignore +++ b/plugins/Full_CI/.gitignore @@ -3,7 +3,6 @@ .ninja_log AO_Basis Bitmask -Davidson Determinants Electrons Ezfio_files @@ -29,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 79599065..d870e4b0 100644 --- a/plugins/Full_CI/H_apply.irp.f +++ b/plugins/Full_CI/H_apply.irp.f @@ -7,17 +7,16 @@ s.set_selection_pt2("epstein_nesbet_2x2") #s.unset_openmp() print s -s = H_apply("FCI_PT2") +#s = H_apply("FCI_PT2") +#s.set_perturbation("epstein_nesbet_2x2") +#s.unset_openmp() +#print s + +s = H_apply_zmq("FCI_PT2") s.set_perturbation("epstein_nesbet_2x2") s.unset_openmp() print s -s = H_apply("FCI_PT2_new") -s.set_perturbation("decontracted") -s.unset_openmp() -print s - - s = H_apply("FCI_no_skip") s.set_selection_pt2("epstein_nesbet_2x2") s.unset_skip() diff --git a/plugins/Full_CI/README.rst b/plugins/Full_CI/README.rst index 77a0bd64..750db44c 100644 --- a/plugins/Full_CI/README.rst +++ b/plugins/Full_CI/README.rst @@ -16,7 +16,6 @@ Needed Modules * `Perturbation `_ * `Selectors_full `_ * `Generators_full `_ -* `Davidson `_ Documentation ============= @@ -78,31 +77,6 @@ h_apply_fci_monoexc Assume N_int is already provided. -h_apply_fci_no_selection - 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_no_selection_diexc - Undocumented - - -h_apply_fci_no_selection_diexcorg - Generate all double excitations of key_in using the bit masks of holes and - particles. - Assume N_int is already provided. - - -h_apply_fci_no_selection_diexcp - Undocumented - - -h_apply_fci_no_selection_monoexc - Generate all single excitations of key_in using the bit masks of holes and - particles. - Assume N_int is already provided. - - h_apply_fci_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. @@ -170,6 +144,118 @@ 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. + + +h_apply_pt2_mono_delta_rho_diexc + Undocumented + + +h_apply_pt2_mono_delta_rho_diexcorg + Generate all double excitations of key_in using the bit masks of holes and + particles. + Assume N_int is already provided. + + +h_apply_pt2_mono_delta_rho_diexcp + Undocumented + + +h_apply_pt2_mono_delta_rho_monoexc + Generate all single excitations of key_in using the bit masks of holes and + particles. + Assume N_int is already provided. + + +h_apply_pt2_mono_di_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. + + +h_apply_pt2_mono_di_delta_rho_diexc + Undocumented + + +h_apply_pt2_mono_di_delta_rho_diexcorg + Generate all double excitations of key_in using the bit masks of holes and + particles. + Assume N_int is already provided. + + +h_apply_pt2_mono_di_delta_rho_diexcp + Undocumented + + +h_apply_pt2_mono_di_delta_rho_monoexc + Generate all single excitations of key_in using the bit masks of holes and + particles. + Assume N_int is already provided. + + +h_apply_select_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. + + +h_apply_select_mono_delta_rho_diexc + Undocumented + + +h_apply_select_mono_delta_rho_diexcorg + Generate all double excitations of key_in using the bit masks of holes and + particles. + Assume N_int is already provided. + + +h_apply_select_mono_delta_rho_diexcp + Undocumented + + +h_apply_select_mono_delta_rho_monoexc + Generate all single excitations of key_in using the bit masks of holes and + particles. + Assume N_int is already provided. + + +h_apply_select_mono_di_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. + + +h_apply_select_mono_di_delta_rho_diexc + Undocumented + + +h_apply_select_mono_di_delta_rho_diexcorg + Generate all double excitations of key_in using the bit masks of holes and + particles. + Assume N_int is already provided. + + +h_apply_select_mono_di_delta_rho_diexcp + Undocumented + + +h_apply_select_mono_di_delta_rho_monoexc + Generate all single excitations of key_in using the bit masks of holes and + particles. + 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 a53064b4..42e773eb 100644 --- a/plugins/Full_CI/full_ci.irp.f +++ b/plugins/Full_CI/full_ci.irp.f @@ -92,9 +92,8 @@ program full_ci call diagonalize_CI if(do_pt2_end)then print*,'Last iteration only to compute the PT2' - threshold_generators = threshold_generators_pt2 - threshold_selectors = threshold_selectors_pt2 - SOFT_TOUCH threshold_generators threshold_selectors + threshold_selectors = 1.d0 + threshold_generators = 0.999d0 call H_apply_FCI_PT2(pt2, norm_pert, H_pert_diag, N_st) print *, 'Final step' diff --git a/plugins/Full_CI/full_ci_no_skip.irp.f b/plugins/Full_CI/full_ci_no_skip.irp.f index 078334f7..82cc9b79 100644 --- a/plugins/Full_CI/full_ci_no_skip.irp.f +++ b/plugins/Full_CI/full_ci_no_skip.irp.f @@ -73,11 +73,9 @@ program full_ci call diagonalize_CI if(do_pt2_end)then print*,'Last iteration only to compute the PT2' - threshold_generators = threshold_generators_pt2 - threshold_selectors = threshold_selectors_pt2 - SOFT_TOUCH threshold_generators threshold_selectors - ! print*,'The thres' + threshold_selectors = 1.d0 + threshold_generators = 0.999d0 call H_apply_FCI_PT2(pt2, norm_pert, H_pert_diag, N_st) print *, 'Final step' diff --git a/plugins/Full_CI_ZMQ/EZFIO.cfg b/plugins/Full_CI_ZMQ/EZFIO.cfg deleted file mode 100644 index 26f1a8e5..00000000 --- a/plugins/Full_CI_ZMQ/EZFIO.cfg +++ /dev/null @@ -1,11 +0,0 @@ -[energy] -type: double precision -doc: Calculated Selected FCI energy -interface: ezfio - -[energy_pt2] -type: double precision -doc: Calculated FCI energy + PT2 -interface: ezfio - - diff --git a/plugins/Full_CI_ZMQ/NEEDED_CHILDREN_MODULES b/plugins/Full_CI_ZMQ/NEEDED_CHILDREN_MODULES index 7ff203d4..cb6ff46e 100644 --- a/plugins/Full_CI_ZMQ/NEEDED_CHILDREN_MODULES +++ b/plugins/Full_CI_ZMQ/NEEDED_CHILDREN_MODULES @@ -1 +1 @@ -Perturbation Selectors_full Generators_full ZMQ +Perturbation Selectors_full Generators_full ZMQ Full_CI diff --git a/plugins/Full_CI_ZMQ/energy.irp.f b/plugins/Full_CI_ZMQ/energy.irp.f deleted file mode 100644 index db1e7d1a..00000000 --- a/plugins/Full_CI_ZMQ/energy.irp.f +++ /dev/null @@ -1,11 +0,0 @@ -BEGIN_PROVIDER [ double precision, pt2_E0_denominator, (N_states) ] - implicit none - BEGIN_DOC - ! E0 in the denominator of the PT2 - END_DOC - pt2_E0_denominator(1:N_states) = CI_electronic_energy(1:N_states) -! pt2_E0_denominator(1:N_states) = HF_energy - nuclear_repulsion -! pt2_E0_denominator(1:N_states) = barycentric_electronic_energy(1:N_states) - call write_double(6,pt2_E0_denominator(1)+nuclear_repulsion, 'PT2 Energy denominator') -END_PROVIDER - diff --git a/plugins/Full_CI_ZMQ/fci_zmq.irp.f b/plugins/Full_CI_ZMQ/fci_zmq.irp.f index ae0d7989..c81b1266 100644 --- a/plugins/Full_CI_ZMQ/fci_zmq.irp.f +++ b/plugins/Full_CI_ZMQ/fci_zmq.irp.f @@ -5,15 +5,11 @@ program fci_zmq double precision, allocatable :: pt2(:) integer :: degree - integer :: n_det_before, to_select - double precision :: threshold_davidson_in allocate (pt2(N_states)) pt2 = 1.d0 - threshold_davidson_in = threshold_davidson - threshold_davidson = threshold_davidson_in * 100.d0 - SOFT_TOUCH threshold_davidson + diag_algorithm = "Lapack" if (N_det > N_det_max) then call diagonalize_CI @@ -37,11 +33,29 @@ program fci_zmq 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) - n_det_before = 0 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 @@ -65,40 +79,13 @@ program fci_zmq enddo endif E_CI_before(1:N_states) = CI_energy(1:N_states) - call ezfio_set_full_ci_zmq_energy(CI_energy(1)) - - n_det_before = N_det - to_select = 2*N_det - to_select = max(64-to_select, to_select) - to_select = min(to_select, N_det_max-n_det_before) - call ZMQ_selection(to_select, pt2) - - PROVIDE psi_coef - PROVIDE psi_det - PROVIDE psi_det_sorted - - if (N_det == N_det_max) then - threshold_davidson = threshold_davidson_in - SOFT_TOUCH threshold_davidson - endif - call diagonalize_CI - call save_wavefunction - call ezfio_set_full_ci_zmq_energy(CI_energy(1)) + call ezfio_set_full_ci_energy(CI_energy) enddo - if (N_det < N_det_max) then - threshold_davidson = threshold_davidson_in - SOFT_TOUCH threshold_davidson - call diagonalize_CI - call save_wavefunction - call ezfio_set_full_ci_zmq_energy(CI_energy(1)) - endif - if(do_pt2_end)then print*,'Last iteration only to compute the PT2' - threshold_selectors = max(threshold_selectors,threshold_selectors_pt2) - threshold_generators = max(threshold_generators,threshold_generators_pt2) - TOUCH threshold_selectors threshold_generators + threshold_selectors = 1.d0 + threshold_generators = 0.9999d0 E_CI_before(1:N_states) = CI_energy(1:N_states) call ZMQ_selection(0, pt2) print *, 'Final step' @@ -111,11 +98,9 @@ program fci_zmq print *, 'E+PT2 = ', E_CI_before+pt2 print *, '-----' enddo - call ezfio_set_full_ci_zmq_energy_pt2(E_CI_before(1)+pt2(1)) + call ezfio_set_full_ci_energy_pt2(E_CI_before+pt2) endif call save_wavefunction - call ezfio_set_full_ci_zmq_energy(CI_energy(1)) - call ezfio_set_full_ci_zmq_energy_pt2(E_CI_before(1)+pt2(1)) end @@ -136,43 +121,38 @@ subroutine ZMQ_selection(N_in, pt2) double precision, intent(out) :: pt2(N_states) - if (.True.) then - PROVIDE pt2_e0_denominator - N = max(N_in,1) - provide nproc - call new_parallel_job(zmq_to_qp_run_socket,"selection") - call zmq_put_psi(zmq_to_qp_run_socket,1,pt2_e0_denominator,size(pt2_e0_denominator)) - call zmq_set_running(zmq_to_qp_run_socket) - call create_selection_buffer(N, N*2, b) - endif + 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= 1, N_det_generators,step - i_generator_start = i - i_generator_max = min(i+step-1,N_det_generators) + 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(shared) SHARED(b, pt2) PRIVATE(i) NUM_THREADS(nproc+1) - i = omp_get_thread_num() - if (i==0) then - call selection_collector(b, pt2) - else - call selection_slave_inproc(i) - endif + !$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') + 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() - if (s2_eig) then - call make_s2_eigenfunction - endif endif end subroutine @@ -181,7 +161,7 @@ subroutine selection_slave_inproc(i) implicit none integer, intent(in) :: i - call run_selection_slave(1,i,pt2_e0_denominator) + call run_selection_slave(1,i,ci_electronic_energy) end subroutine selection_collector(b, pt2) diff --git a/plugins/Full_CI_ZMQ/run_selection_slave.irp.f b/plugins/Full_CI_ZMQ/run_selection_slave.irp.f index dfaee629..36550116 100644 --- a/plugins/Full_CI_ZMQ/run_selection_slave.irp.f +++ b/plugins/Full_CI_ZMQ/run_selection_slave.irp.f @@ -4,7 +4,7 @@ subroutine run_selection_slave(thread,iproc,energy) use selection_types implicit none - double precision, intent(in) :: energy(N_states) + double precision, intent(in) :: energy(N_states_diag) integer, intent(in) :: thread, iproc integer :: rc, i diff --git a/plugins/Full_CI_ZMQ/selection.irp.f b/plugins/Full_CI_ZMQ/selection.irp.f index 3f351004..a0209cc5 100644 --- a/plugins/Full_CI_ZMQ/selection.irp.f +++ b/plugins/Full_CI_ZMQ/selection.irp.f @@ -6,20 +6,8 @@ double precision function integral8(i,j,k,l) integer, intent(in) :: i,j,k,l double precision, external :: get_mo_bielec_integral - integer :: ii - 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 - integral8 = get_mo_bielec_integral(i,j,k,l,mo_integrals_map) - 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) - integral8 = mo_integrals_cache(ii) - endif + + integral8 = get_mo_bielec_integral(i,j,k,l,mo_integrals_map) end function @@ -116,1087 +104,3 @@ end subroutine -! Selection single -! ---------------- - -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, tmp - 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) + vect(istate, p1) - delta_E = E0(istate) - Hii - tmp = dsqrt(delta_E * delta_E + val * val) - if (delta_E < 0.d0) then - tmp = -tmp - endif - e_pert = 0.5d0 * ( tmp - delta_E) - 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 - - - - -! Selection double -! ---------------- - -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,tmp - 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) + mat(istate, p1, p2) - tmp = dsqrt(delta_E * delta_E + val * val) - if (delta_E < 0.d0) then - tmp = -tmp - endif - e_pert = 0.5d0 * ( tmp - delta_E) - pt2(istate) = pt2(istate) + e_pert - max_e_pert = min(e_pert,max_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_davidson_slave.irp.f b/plugins/Full_CI_ZMQ/selection_davidson_slave.irp.f index d6204cc3..6e4cf44f 100644 --- a/plugins/Full_CI_ZMQ/selection_davidson_slave.irp.f +++ b/plugins/Full_CI_ZMQ/selection_davidson_slave.irp.f @@ -13,7 +13,7 @@ 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 pt2_e0_denominator mo_tot_num N_int +! PROVIDE ci_electronic_energy mo_tot_num N_int end subroutine run_wf @@ -22,7 +22,7 @@ subroutine run_wf integer(ZMQ_PTR), external :: new_zmq_to_qp_run_socket integer(ZMQ_PTR) :: zmq_to_qp_run_socket - double precision :: energy(N_states) + double precision :: energy(N_states_diag) character*(64) :: states(2) integer :: rc, i @@ -48,7 +48,7 @@ subroutine run_wf ! --------- print *, 'Selection' - call zmq_get_psi(zmq_to_qp_run_socket,1,energy,N_states) + call zmq_get_psi(zmq_to_qp_run_socket,1,energy,N_states_diag) !$OMP PARALLEL PRIVATE(i) i = omp_get_thread_num() @@ -76,7 +76,7 @@ end subroutine update_energy(energy) implicit none - double precision, intent(in) :: energy(N_states) + double precision, intent(in) :: energy(N_states_diag) BEGIN_DOC ! Update energy when it is received from ZMQ END_DOC @@ -88,7 +88,7 @@ subroutine update_energy(energy) enddo call u_0_S2_u_0(CI_eigenvectors_s2,CI_eigenvectors,N_det,psi_det,N_int) if (.True.) then - do k=1,N_states + do k=1,size(ci_electronic_energy) ci_electronic_energy(k) = energy(k) enddo TOUCH ci_electronic_energy CI_eigenvectors_s2 CI_eigenvectors @@ -99,7 +99,7 @@ end subroutine selection_slave_tcp(i,energy) implicit none - double precision, intent(in) :: energy(N_states) + double precision, intent(in) :: energy(N_states_diag) integer, intent(in) :: i call run_selection_slave(0,i,energy) diff --git a/plugins/CAS_SD_ZMQ/selection.irp.f b/plugins/Full_CI_ZMQ/selection_double.irp.f similarity index 55% rename from plugins/CAS_SD_ZMQ/selection.irp.f rename to plugins/Full_CI_ZMQ/selection_double.irp.f index f90ee488..977622fd 100644 --- a/plugins/CAS_SD_ZMQ/selection.irp.f +++ b/plugins/Full_CI_ZMQ/selection_double.irp.f @@ -1,1207 +1,726 @@ -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 - integer :: ii - 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 - integral8 = get_mo_bielec_integral(i,j,k,l,mo_integrals_map) - 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) - integral8 = mo_integrals_cache(ii) - endif -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_selectors(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 - - - -! Selection single -! ---------------- - -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_selectors, 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, tmp - 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) + vect(istate, p1) - delta_E = E0(istate) - Hii - tmp = dsqrt(delta_E * delta_E + val * val) - if (delta_E < 0.d0) then - tmp = -tmp - endif - e_pert = 0.5d0 * ( tmp - delta_E) - 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) - endif - 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 - - 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 -end subroutine - - - - -! Selection double -! ---------------- - -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_selectors(j,1,i)) - mobMask(j,2) = iand(negMask(j,2), psi_selectors(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_selectors(j,1,i)) - mobMask(j,2) = iand(negMask(j,2), psi_selectors(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_selectors(:,:,i) - if(nt <= 2) then - fullinteresting(0) += 1 - fullinteresting(fullinteresting(0)) = i - fullminilist(:,:,fullinteresting(0)) = psi_selectors(:,:,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_selectors(j,1,i)) - mobMask(j,2) = iand(negMask(j,2), psi_selectors(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_selectors(:,:,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,tmp - 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) -logical, external :: is_in_wavefunction -if (is_in_wavefunction(det,N_int)) then - cycle -endif - - - 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) + mat(istate, p1, p2) - tmp = dsqrt(delta_E * delta_E + val * val) - if (delta_E < 0.d0) then - tmp = -tmp - endif - e_pert = 0.5d0 * ( tmp - delta_E) - pt2(istate) = pt2(istate) + e_pert - max_e_pert = min(e_pert,max_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 - + +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 index 657ad63c..06bcf533 100644 --- a/plugins/Full_CI_ZMQ/selection_slave.irp.f +++ b/plugins/Full_CI_ZMQ/selection_slave.irp.f @@ -13,7 +13,7 @@ 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 pt2_e0_denominator mo_tot_num N_int +! PROVIDE ci_electronic_energy mo_tot_num N_int end subroutine run_wf @@ -22,7 +22,7 @@ subroutine run_wf integer(ZMQ_PTR), external :: new_zmq_to_qp_run_socket integer(ZMQ_PTR) :: zmq_to_qp_run_socket - double precision :: energy(N_states) + double precision :: energy(N_states_diag) character*(64) :: states(1) integer :: rc, i @@ -47,7 +47,7 @@ subroutine run_wf ! --------- print *, 'Selection' - call zmq_get_psi(zmq_to_qp_run_socket,1,energy,N_states) + call zmq_get_psi(zmq_to_qp_run_socket,1,energy,N_states_diag) !$OMP PARALLEL PRIVATE(i) i = omp_get_thread_num() @@ -62,7 +62,7 @@ end subroutine update_energy(energy) implicit none - double precision, intent(in) :: energy(N_states) + double precision, intent(in) :: energy(N_states_diag) BEGIN_DOC ! Update energy when it is received from ZMQ END_DOC @@ -74,7 +74,7 @@ subroutine update_energy(energy) enddo call u_0_S2_u_0(CI_eigenvectors_s2,CI_eigenvectors,N_det,psi_det,N_int) if (.True.) then - do k=1,N_states + do k=1,size(ci_electronic_energy) ci_electronic_energy(k) = energy(k) enddo TOUCH ci_electronic_energy CI_eigenvectors_s2 CI_eigenvectors @@ -85,7 +85,7 @@ end subroutine selection_slave_tcp(i,energy) implicit none - double precision, intent(in) :: energy(N_states) + double precision, intent(in) :: energy(N_states_diag) integer, intent(in) :: i call run_selection_slave(0,i,energy) diff --git a/plugins/Full_CI_ZMQ/tree_dependency.png b/plugins/Full_CI_ZMQ/tree_dependency.png deleted file mode 100644 index e69de29b..00000000 diff --git a/plugins/Generators_full/README.rst b/plugins/Generators_full/README.rst index d1fc68ec..c30193a2 100644 --- a/plugins/Generators_full/README.rst +++ b/plugins/Generators_full/README.rst @@ -33,7 +33,7 @@ Documentation .. by the `update_README.py` script. -`degree_max_generators `_ +`degree_max_generators `_ Max degree of excitation (respect to HF) of the generators @@ -52,10 +52,10 @@ Documentation Hartree-Fock determinant -`select_max `_ +`select_max `_ Memo to skip useless selectors -`size_select_max `_ +`size_select_max `_ Size of the select_max array diff --git a/plugins/Generators_restart/tree_dependency.png b/plugins/Generators_restart/tree_dependency.png deleted file mode 100644 index e69de29b..00000000 diff --git a/plugins/Hartree_Fock/README.rst b/plugins/Hartree_Fock/README.rst index 2e329163..77521b94 100644 --- a/plugins/Hartree_Fock/README.rst +++ b/plugins/Hartree_Fock/README.rst @@ -67,11 +67,11 @@ Documentation 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 @@ -79,7 +79,7 @@ Documentation Alpha Fock matrix in AO basis set -`fock_matrix_beta_mo `_ +`fock_matrix_beta_mo `_ Fock matrix on the MO basis @@ -115,7 +115,7 @@ Documentation .br -`fock_mo_to_ao `_ +`fock_mo_to_ao `_ Undocumented @@ -135,7 +135,7 @@ Documentation S^-1 Beta density matrix in the AO basis x S^-1 -`hf_energy `_ +`hf_energy `_ Hartree-Fock energy diff --git a/plugins/MP2/mp2.irp.f b/plugins/MP2/mp2.irp.f index d4721c71..3a049f7b 100644 --- a/plugins/MP2/mp2.irp.f +++ b/plugins/MP2/mp2.irp.f @@ -1,10 +1,4 @@ program mp2 - no_vvvv_integrals = .True. - SOFT_TOUCH no_vvvv_integrals - call run -end - -subroutine run implicit none double precision, allocatable :: pt2(:), norm_pert(:) double precision :: H_pert_diag, E_old diff --git a/plugins/MP2/mp2_wf.irp.f b/plugins/MP2/mp2_wf.irp.f index e7419319..5efbb9cd 100644 --- a/plugins/MP2/mp2_wf.irp.f +++ b/plugins/MP2/mp2_wf.irp.f @@ -1,10 +1,4 @@ program mp2_wf - no_vvvv_integrals = .True. - SOFT_TOUCH no_vvvv_integrals - call run -end - -subroutine run implicit none BEGIN_DOC ! Save the MP2 wave function diff --git a/plugins/MRCC_Utils/.gitignore b/plugins/MRCC_Utils/.gitignore index 7a0dd517..4c65ce66 100644 --- a/plugins/MRCC_Utils/.gitignore +++ b/plugins/MRCC_Utils/.gitignore @@ -3,7 +3,6 @@ .ninja_log AO_Basis Bitmask -Davidson Determinants Electrons Ezfio_files diff --git a/plugins/MRCC_Utils/README.rst b/plugins/MRCC_Utils/README.rst index ae041734..39b5684c 100644 --- a/plugins/MRCC_Utils/README.rst +++ b/plugins/MRCC_Utils/README.rst @@ -36,19 +36,11 @@ Documentation Compute 1st dimension such that it is aligned for vectorization. -`apply_hole_local `_ - Undocumented - - -`apply_particle_local `_ - Undocumented - - -`apply_rotation `_ +`apply_rotation `_ Apply the rotation found by find_rotation -`approx_dble `_ +`approx_dble `_ Undocumented @@ -71,23 +63,23 @@ Documentation Binomial coefficients -`ci_eigenvectors_dressed `_ - Eigenvectors/values of the dressed CI matrix +`ci_eigenvectors_dressed `_ + Eigenvectors/values of the CI matrix -`ci_eigenvectors_s2_dressed `_ - Eigenvectors/values of the dressed CI matrix +`ci_eigenvectors_s2_dressed `_ + Eigenvectors/values of the CI matrix -`ci_electronic_energy_dressed `_ - Eigenvectors/values of the dressed CI matrix +`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 -`davidson_diag_hjj_mrcc `_ +`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 @@ -103,39 +95,12 @@ Documentation .br N_st : Number of eigenstates .br - N_st_diag : Number of states in which H is diagonalized - .br iunit : Unit for the I/O .br Initial guess vectors are not necessarily orthonormal -`davidson_diag_hjj_sjj_mrcc `_ - Davidson diagonalization with specific diagonal elements of the H matrix - .br - H_jj : specific diagonal H matrix elements to diagonalize de Davidson - .br - S2_jj : specific diagonal S^2 matrix elements - .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 - N_st_diag : Number of states in which H is diagonalized. Assumed > sze - .br - iunit : Unit for the I/O - .br - Initial guess vectors are not necessarily orthonormal - - -`davidson_diag_mrcc `_ +`davidson_diag_mrcc `_ Davidson diagonalization. .br dets_in : bitmasks corresponding to determinants @@ -154,38 +119,19 @@ Documentation Initial guess vectors are not necessarily orthonormal -`davidson_diag_mrcc_hs2 `_ - 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 - - -`dble_fact `_ +`dble_fact `_ Undocumented -`dble_fact_even `_ +`dble_fact_even `_ n!! -`dble_fact_odd `_ +`dble_fact_odd `_ n!! -`dble_logfact `_ +`dble_logfact `_ n!! @@ -193,23 +139,19 @@ Documentation Undocumented -`dec_exc `_ - Undocumented +`delta_ii `_ + Dressing matrix in N_det basis -`diagonalize_ci_dressed `_ +`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 -`dij `_ - Undocumented - - -`dij_unique `_ - Undocumented - - `dset_order `_ array A has already been sorted, and iorder has contains the new order of elements of A. This subroutine changes the order of x to match the new order of A. @@ -228,26 +170,10 @@ Documentation contains the new order of the elements. -`dtranspose `_ - Transpose input matrix A into output matrix B - - `erf0 `_ Undocumented -`exc_inf `_ - Undocumented - - -`exccmp `_ - Undocumented - - -`exceq `_ - Undocumented - - `f_integral `_ function that calculates the following integral \int_{\-infty}^{+\infty} x^n \exp(-p x^2) dx @@ -257,19 +183,19 @@ Documentation n! -`fact_inv `_ +`fact_inv `_ 1/n! -`find_rotation `_ +`find_rotation `_ Find A.C = B -`find_triples_and_quadruples `_ +`find_triples_and_quadruples `_ Undocumented -`find_triples_and_quadruples_micro `_ +`find_triples_and_quadruples_micro `_ Undocumented @@ -295,15 +221,7 @@ Documentation Undocumented -`get_dij `_ - Undocumented - - -`get_dij_index `_ - Undocumented - - -`get_pseudo_inverse `_ +`get_pseudo_inverse `_ Find C = A^-1 @@ -388,63 +306,11 @@ h_apply_mrcc_pt2_monoexc Assume N_int is already provided. -h_apply_mrcepa_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_mrcepa_pt2_collector - Collects results from the selection in an array of generators - - -h_apply_mrcepa_pt2_diexc - Undocumented - - -h_apply_mrcepa_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_mrcepa_pt2_diexcp - Undocumented - - -h_apply_mrcepa_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_mrcepa_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_mrcepa_pt2_slave_inproc - Computes a buffer using threads - - -h_apply_mrcepa_pt2_slave_tcp - Computes a buffer over the network - - -`h_matrix_dressed `_ +`h_matrix_dressed `_ Dressed H with Delta_ij -`h_s2_u_0_mrcc_nstates `_ - Computes v_0 = H|u_0> and s_0 = S^2 |u_0> - .br - n : number of determinants - .br - H_jj : array of - .br - S2_jj : array of - - -`h_u_0_mrcc_nstates `_ +`h_u_0_mrcc `_ Computes v_0 = H|u_0> .br n : number of determinants @@ -526,15 +392,7 @@ h_apply_mrcepa_pt2_slave_tcp Hermite polynomial -`hh_exists `_ - Undocumented - - -`hh_shortcut `_ - Undocumented - - -`hij_mrcc `_ +`hij_mrcc `_ < ref | H | Non-ref > matrix @@ -665,7 +523,7 @@ h_apply_mrcepa_pt2_slave_tcp to be in integer*8 format -`inv_int `_ +`inv_int `_ 1/i @@ -683,10 +541,6 @@ h_apply_mrcepa_pt2_slave_tcp iradix should be -1 in input. -`is_generable `_ - Undocumented - - `iset_order `_ array A has already been sorted, and iorder has contains the new order of elements of A. This subroutine changes the order of x to match the new order of A. @@ -705,19 +559,15 @@ h_apply_mrcepa_pt2_slave_tcp contains the new order of the elements. -`lambda_mrcc `_ +`lambda_mrcc `_ cm/ or perturbative 1/Delta_E(m) -`lambda_mrcc_kept `_ +`lambda_mrcc_pt2 `_ cm/ or perturbative 1/Delta_E(m) -`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 @@ -728,7 +578,7 @@ h_apply_mrcepa_pt2_slave_tcp .br -`lapack_diag_s2 `_ +`lapack_diag_s2 `_ Diagonalize matrix H .br H is untouched between input and ouptut @@ -739,7 +589,7 @@ h_apply_mrcepa_pt2_slave_tcp .br -`lapack_diagd `_ +`lapack_diagd `_ Diagonalize matrix H .br H is untouched between input and ouptut @@ -750,7 +600,7 @@ h_apply_mrcepa_pt2_slave_tcp .br -`lapack_partial_diag `_ +`lapack_partial_diag `_ Diagonalize matrix H .br H is untouched between input and ouptut @@ -761,27 +611,19 @@ h_apply_mrcepa_pt2_slave_tcp .br -`logfact `_ +`logfact `_ n! -`lowercase `_ +`lowercase `_ Transform to lower case -`map_load_from_disk `_ - Undocumented - - -`map_save_to_disk `_ - Undocumented - - `mrcc_dress `_ Undocumented -`mrmode `_ +`mrcc_iterations `_ Undocumented @@ -790,24 +632,12 @@ h_apply_mrcepa_pt2_slave_tcp D(t) =! D(t) +( B(t)*C(t)) -`n_ex_exists `_ - Undocumented - - -`n_hh_exists `_ - Undocumented - - -`n_pp_exists `_ - Undocumented - - -`normalize `_ +`normalize `_ Normalizes vector u u is expected to be aligned in memory. -`nproc `_ +`nproc `_ Number of current OpenMP threads @@ -829,7 +659,7 @@ h_apply_mrcepa_pt2_slave_tcp .br -`ortho_lowdin `_ +`ortho_lowdin `_ Compute C_new=C_old.S^-1/2 orthogonalization. .br overlap : overlap matrix @@ -847,19 +677,6 @@ h_apply_mrcepa_pt2_slave_tcp .br -`ortho_qr `_ - Orthogonalization using Q.R factorization - .br - A : matrix to orthogonalize - .br - LDA : leftmost dimension of A - .br - n : Number of rows of A - .br - m : Number of columns of A - .br - - `overlap_a_b_c `_ Undocumented @@ -890,10 +707,6 @@ h_apply_mrcepa_pt2_slave_tcp Undocumented -`pp_exists `_ - Undocumented - - `progress_active `_ Current status for displaying progress bars. Global variable. @@ -914,14 +727,6 @@ h_apply_mrcepa_pt2_slave_tcp Current status for displaying progress bars. Global variable. -`psi_non_ref_sorted `_ - Undocumented - - -`psi_non_ref_sorted_idx `_ - Undocumented - - `psi_ref_lock `_ Locks on ref determinants to fill delta_ij @@ -930,10 +735,6 @@ h_apply_mrcepa_pt2_slave_tcp Recenter two polynomials -`rho_mrcc `_ - Undocumented - - `rint `_ .. math:: .br @@ -961,6 +762,10 @@ h_apply_mrcepa_pt2_slave_tcp Undocumented +`run_mrcc `_ + Undocumented + + `run_progress `_ Display a progress bar with documentation of what is happening @@ -969,15 +774,7 @@ h_apply_mrcepa_pt2_slave_tcp Undocumented -`searchdet `_ - Undocumented - - -`searchexc `_ - Undocumented - - -`set_generators_bitmasks_as_holes_and_particles `_ +`set_generators_bitmasks_as_holes_and_particles `_ Undocumented @@ -993,7 +790,7 @@ h_apply_mrcepa_pt2_slave_tcp to be in integer*8 format -`set_zero_extra_diag `_ +`set_zero_extra_diag `_ Undocumented @@ -1003,14 +800,6 @@ h_apply_mrcepa_pt2_slave_tcp contains the new order of the elements. -`sort_det `_ - Undocumented - - -`sort_exc `_ - Undocumented - - `start_progress `_ Starts the progress bar @@ -1028,37 +817,18 @@ h_apply_mrcepa_pt2_slave_tcp .br -`tamise_exc `_ - Uncodumented : TODO - - -`transpose `_ - Transpose input matrix A into output matrix B - - -`u_0_h_u_0_mrcc_nstates `_ - Computes e_0 = / - .br - n : number of determinants - .br - - -`u_dot_u `_ +`u_dot_u `_ Compute -`u_dot_v `_ +`u_dot_v `_ Compute -`unsortedsearchdet `_ - Undocumented - - -`wall_time `_ +`wall_time `_ The equivalent of cpu_time, but for the wall time. -`write_git_log `_ +`write_git_log `_ Write the last git commit in file iunit. diff --git a/plugins/MRCC_Utils/amplitudes.irp.f b/plugins/MRCC_Utils/amplitudes.irp.f deleted file mode 100644 index 0e6a4cf4..00000000 --- a/plugins/MRCC_Utils/amplitudes.irp.f +++ /dev/null @@ -1,238 +0,0 @@ - BEGIN_PROVIDER [ integer, n_exc_active ] -&BEGIN_PROVIDER [ integer, active_pp_idx, (hh_nex) ] -&BEGIN_PROVIDER [ integer, active_hh_idx, (hh_nex) ] -&BEGIN_PROVIDER [ logical, is_active_exc, (hh_nex) ] - implicit none - BEGIN_DOC - ! is_active_exc : True if the excitation involves at least one active MO - ! - ! n_exc_active : Number of active excitations : Number of excitations without the inactive ones. - ! - ! active_hh_idx : - ! - ! active_pp_idx : - END_DOC - integer :: hh, pp, II - integer :: ind - logical :: ok - integer(bit_kind) :: myDet(N_int, 2), myMask(N_int, 2) - - integer, allocatable :: pathTo(:) - integer, external :: searchDet - - allocate(pathTo(N_det_non_ref)) - - pathTo(:) = 0 - is_active_exc(:) = .false. - n_exc_active = 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 - is_active_exc(pp) = .true. - is_active_exc(pathTo(ind)) = .true. - end if - end do - end do - end do -!is_active_exc=.true. - do hh = 1, hh_shortcut(0) - do pp = hh_shortcut(hh), hh_shortcut(hh+1)-1 - if(is_active_exc(pp)) then - n_exc_active = n_exc_active + 1 - active_hh_idx(n_exc_active) = hh - active_pp_idx(n_exc_active) = pp - end if - end do - end do - - deallocate(pathTo) - - print *, n_exc_active, "active excitations /", hh_nex - -END_PROVIDER - -BEGIN_PROVIDER [ integer, n_exc_active_sze ] - implicit none - BEGIN_DOC - ! Dimension of arrays to avoid zero-sized arrays - END_DOC - n_exc_active_sze = max(n_exc_active,1) -END_PROVIDER - - - - BEGIN_PROVIDER [ integer, active_excitation_to_determinants_idx, (0:N_det_ref+1, n_exc_active_sze) ] -&BEGIN_PROVIDER [ double precision, active_excitation_to_determinants_val, (N_states,N_det_ref+1, n_exc_active_sze) ] - implicit none - BEGIN_DOC - ! Sparse matrix A containing the matrix to transform the active excitations to - ! determinants : A | \Psi_0 > = | \Psi_SD > - END_DOC - integer :: s, ppp, pp, hh, II, ind, wk, i - integer, allocatable :: lref(:) - integer(bit_kind) :: myDet(N_int,2), myMask(N_int,2) - double precision :: phase - logical :: ok - integer, external :: searchDet - - - !$OMP PARALLEL default(none) shared(psi_non_ref, hh_exists, pp_exists, N_int,& - !$OMP active_excitation_to_determinants_val, active_excitation_to_determinants_idx)& - !$OMP shared(hh_shortcut, psi_ref_coef, N_det_non_ref, psi_non_ref_sorted, & - !$OMP psi_non_ref_sorted_idx, psi_ref, N_det_ref, N_states)& - !$OMP shared(is_active_exc, active_hh_idx, active_pp_idx, n_exc_active)& - !$OMP private(lref, pp, II, ok, myMask, myDet, ind, phase, wk, ppp, hh, s) - allocate(lref(N_det_non_ref)) - !$OMP DO schedule(dynamic) - do ppp=1,n_exc_active - active_excitation_to_determinants_val(:,:,ppp) = 0d0 - active_excitation_to_determinants_idx(:,ppp) = 0 - 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 - do s=1,N_states - active_excitation_to_determinants_val(s,wk, ppp) = psi_ref_coef(lref(i), s) - enddo - active_excitation_to_determinants_idx(wk, ppp) = i - else if(lref(i) < 0) then - wk += 1 - do s=1,N_states - active_excitation_to_determinants_val(s,wk, ppp) = -psi_ref_coef(-lref(i), s) - enddo - active_excitation_to_determinants_idx(wk, ppp) = i - end if - end do - active_excitation_to_determinants_idx(0,ppp) = wk - end do - !$OMP END DO - deallocate(lref) - !$OMP END PARALLEL - -END_PROVIDER - - - BEGIN_PROVIDER [ integer, mrcc_AtA_ind, (N_det_ref * n_exc_active_sze) ] -&BEGIN_PROVIDER [ double precision, mrcc_AtA_val, (N_states, N_det_ref * n_exc_active_sze) ] -&BEGIN_PROVIDER [ integer, mrcc_col_shortcut, (n_exc_active_sze) ] -&BEGIN_PROVIDER [ integer, mrcc_N_col, (n_exc_active_sze) ] - implicit none - BEGIN_DOC - ! A is active_excitation_to_determinants in At.A - END_DOC - integer :: AtA_size, i,k - integer :: at_roww, at_row, wk, a_coll, a_col, r1, r2, s - double precision, allocatable :: t(:), A_val_mwen(:,:), As2_val_mwen(:,:) - integer, allocatable :: A_ind_mwen(:) - double precision :: sij - PROVIDE psi_non_ref - - mrcc_AtA_ind(:) = 0 - mrcc_AtA_val(:,:) = 0.d0 - mrcc_col_shortcut(:) = 0 - mrcc_N_col(:) = 0 - AtA_size = 0 - - - !$OMP PARALLEL default(none) shared(k, active_excitation_to_determinants_idx,& - !$OMP active_excitation_to_determinants_val, hh_nex) & - !$OMP private(at_row, a_col, t, i, r1, r2, wk, A_ind_mwen, A_val_mwen,& - !$OMP As2_val_mwen, a_coll, at_roww,sij) & - !$OMP shared(N_states,mrcc_col_shortcut, mrcc_N_col, AtA_size, mrcc_AtA_val, mrcc_AtA_ind, & - !$OMP n_exc_active, active_pp_idx,psi_non_ref) - allocate(A_val_mwen(N_states,hh_nex), As2_val_mwen(N_states,hh_nex), A_ind_mwen(hh_nex), t(N_states) ) - - !$OMP DO schedule(dynamic, 100) - do at_roww = 1, n_exc_active ! hh_nex - at_row = active_pp_idx(at_roww) - wk = 0 - - do a_coll = 1, n_exc_active - a_col = active_pp_idx(a_coll) - t(:) = 0d0 - r1 = 1 - r2 = 1 - do while ((active_excitation_to_determinants_idx(r1, at_roww) /= 0).and.(active_excitation_to_determinants_idx(r2, a_coll) /= 0)) - if(active_excitation_to_determinants_idx(r1, at_roww) > active_excitation_to_determinants_idx(r2, a_coll)) then - r2 = r2+1 - else if(active_excitation_to_determinants_idx(r1, at_roww) < active_excitation_to_determinants_idx(r2, a_coll)) then - r1 = r1+1 - else - do s=1,N_states - t(s) = t(s) - active_excitation_to_determinants_val(s,r1, at_roww) * active_excitation_to_determinants_val(s,r2, a_coll) - enddo - r1 = r1+1 - r2 = r2+1 - end if - end do - - if (a_col == at_row) then - t(:) = t(:) + 1.d0 - endif - if (sum(dabs(t(:))) > 0.d0) then - wk = wk+1 - A_ind_mwen(wk) = a_col - A_val_mwen(:,wk) = t(:) - endif - - end do - - if(wk /= 0) then - !$OMP CRITICAL - mrcc_col_shortcut(at_roww) = AtA_size+1 - mrcc_N_col(at_roww) = wk - if (AtA_size+wk > size(mrcc_AtA_ind,1)) then - print *, AtA_size+wk , size(mrcc_AtA_ind,1) - stop 'too small' - endif - do i=1,wk - mrcc_AtA_ind(AtA_size+i) = A_ind_mwen(i) - do s=1,N_states - mrcc_AtA_val(s,AtA_size+i) = A_val_mwen(s,i) - enddo - enddo - AtA_size += wk - !$OMP END CRITICAL - end if - end do - !$OMP END DO NOWAIT - deallocate (A_ind_mwen, A_val_mwen, As2_val_mwen, t) - !$OMP END PARALLEL - - print *, "At.A SIZE", ata_size - -END_PROVIDER - diff --git a/plugins/MRCC_Utils/davidson.irp.f b/plugins/MRCC_Utils/davidson.irp.f index 6bdadb24..a67ca676 100644 --- a/plugins/MRCC_Utils/davidson.irp.f +++ b/plugins/MRCC_Utils/davidson.irp.f @@ -94,6 +94,7 @@ subroutine davidson_diag_hjj_mrcc(dets_in,u_in,H_jj,energies,dim_in,sze,N_st,N_s double precision, allocatable :: overlap(:,:) double precision :: u_dot_v, u_dot_u + integer, allocatable :: kl_pairs(:,:) integer :: k_pairs, kl integer :: iter2 @@ -143,6 +144,7 @@ subroutine davidson_diag_hjj_mrcc(dets_in,u_in,H_jj,energies,dim_in,sze,N_st,N_s sze_8 = align_double(sze) allocate( & + 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), & @@ -207,6 +209,19 @@ subroutine davidson_diag_hjj_mrcc(dets_in,u_in,H_jj,energies,dim_in,sze,N_st,N_s ! ------------------------------------------- +! 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)) @@ -315,10 +330,20 @@ subroutine davidson_diag_hjj_mrcc(dets_in,u_in,H_jj,energies,dim_in,sze,N_st,N_s ! ----------- do k=1,N_st_diag + energies(k) = lambda(k) do i=1,sze u_in(i,k) = 0.d0 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, & @@ -326,9 +351,6 @@ subroutine davidson_diag_hjj_mrcc(dets_in,u_in,H_jj,energies,dim_in,sze,N_st,N_s enddo - do k=1,N_st_diag - energies(k) = lambda(k) - enddo write_buffer = '===== ' do i=1,N_st write_buffer = trim(write_buffer)//' ================ ================' @@ -338,6 +360,7 @@ subroutine davidson_diag_hjj_mrcc(dets_in,u_in,H_jj,energies,dim_in,sze,N_st,N_s call write_time(iunit) deallocate ( & + kl_pairs, & W, residual_norm, & U, overlap, & R, c, & @@ -550,7 +573,7 @@ subroutine davidson_diag_mrcc_hs2(dets_in,u_in,dim_in,energies,sze,N_st,N_st_dia 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_diag) + double precision, intent(out) :: energies(N_st) double precision, allocatable :: H_jj(:), S2_jj(:) double precision :: diag_h_mat_elem @@ -623,12 +646,14 @@ subroutine davidson_diag_hjj_sjj_mrcc(dets_in,u_in,H_jj,S2_jj,energies,dim_in,sz integer :: i,j,k,l,m logical :: converged + 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(:,:), S(:,:), overlap(:,:) + double precision, allocatable :: W(:,:), U(:,:), R(:,:), S(:,:) double precision, allocatable :: y(:,:), h(:,:), lambda(:), s2(:) double precision, allocatable :: c(:), s_(:,:), s_tmp(:,:) double precision :: diag_h_mat_elem @@ -636,14 +661,12 @@ subroutine davidson_diag_hjj_sjj_mrcc(dets_in,u_in,H_jj,S2_jj,energies,dim_in,sz character*(16384) :: write_buffer double precision :: to_print(3,N_st) double precision :: cpu, wall - integer :: shift, shift2, itermax + integer :: shift, shift2 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 + !DIR$ ATTRIBUTES ALIGN : $IRP_ALIGN :: U, W, R, S, y, h, lambda + if (N_st_diag > sze) then + stop 'error in Davidson : N_st_diag > sze' endif PROVIDE nuclear_repulsion @@ -668,7 +691,7 @@ subroutine davidson_diag_hjj_sjj_mrcc(dets_in,u_in,H_jj,S2_jj,energies,dim_in,sz write(iunit,'(A)') trim(write_buffer) write_buffer = ' Iter' do i=1,N_st - write_buffer = trim(write_buffer)//' Energy S^2 Residual ' + write_buffer = trim(write_buffer)//' Energy S^2 Residual' enddo write(iunit,'(A)') trim(write_buffer) write_buffer = '===== ' @@ -680,30 +703,30 @@ subroutine davidson_diag_hjj_sjj_mrcc(dets_in,u_in,H_jj,S2_jj,energies,dim_in,sz integer, external :: align_double sze_8 = align_double(sze) - itermax = min(davidson_sze_max, sze/N_st_diag) + double precision :: delta + + if (s2_eig) then + delta = 1.d0 + else + delta = 0.d0 + endif + 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), & + 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), & + S(sze_8,N_st_diag*davidson_sze_max), & + 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), & + s_(N_st_diag*davidson_sze_max,N_st_diag*davidson_sze_max), & + s_tmp(N_st_diag*davidson_sze_max,N_st_diag*davidson_sze_max), & residual_norm(N_st_diag), & - c(N_st_diag*itermax), & - s2(N_st_diag*itermax), & - overlap(N_st_diag*itermax,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 - - + overlap(N_st_diag,N_st_diag), & + c(N_st_diag*davidson_sze_max), & + s2(N_st_diag*davidson_sze_max), & + lambda(N_st_diag*davidson_sze_max)) + ASSERT (N_st > 0) ASSERT (N_st_diag >= N_st) ASSERT (sze > 0) @@ -715,19 +738,25 @@ subroutine davidson_diag_hjj_sjj_mrcc(dets_in,u_in,H_jj,S2_jj,energies,dim_in,sz converged = .False. - double precision :: r1, r2 + do k=1,N_st + call normalize(u_in(1,k),sze) + enddo + do k=N_st+1,N_st_diag - u_in(k,k) = 10.d0 do i=1,sze + double precision :: r1, r2 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) = dsqrt(-2.d0*dlog(r1))*dcos(dtwo_pi*r2) enddo - enddo - do k=1,N_st_diag - call normalize(u_in(1,k),sze) + + ! 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 @@ -744,10 +773,10 @@ subroutine davidson_diag_hjj_sjj_mrcc(dets_in,u_in,H_jj,S2_jj,energies,dim_in,sz 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) @@ -757,57 +786,31 @@ subroutine davidson_diag_hjj_sjj_mrcc(dets_in,u_in,H_jj,S2_jj,energies,dim_in,sz ! ------------------------------------------- - call dgemm('T','N', shift2, shift2, sze, & - 1.d0, U, size(U,1), W, size(W,1), & - 0.d0, h, size(h,1)) - - call dgemm('T','N', shift2, shift2, sze, & - 1.d0, U, size(U,1), S, size(S,1), & - 0.d0, s_, size(s_,1)) - -! ! Diagonalize S^2 -! ! --------------- -! -! call lapack_diag(s2,y,s_,size(s_,1),shift2) -! -! ! Rotate H in the basis of eigenfunctions of s2 -! ! --------------------------------------------- -! -! call dgemm('N','N',shift2,shift2,shift2, & -! 1.d0, h, size(h,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, h, size(h,1)) -! -! ! Damp interaction between different spin states -! ! ------------------------------------------------ -! -! do k=1,shift2 -! do l=1,shift2 -! if (dabs(s2(k) - s2(l)) > 1.d0) then -! h(k,l) = h(k,l)*(max(0.d0,1.d0 - dabs(s2(k) - s2(l)))) -! endif +! 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 -! -! ! Rotate back H -! ! ------------- -! -! call dgemm('N','T',shift2,shift2,shift2, & -! 1.d0, h, size(h,1), y, size(y,1), & -! 0.d0, s_tmp, size(s_tmp,1)) -! -! call dgemm('N','N',shift2,shift2,shift2, & -! 1.d0, y, size(y,1), s_tmp, size(s_tmp,1), & -! 0.d0, h, size(h,1)) - + 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 ! ------------------------------- @@ -824,81 +827,46 @@ subroutine davidson_diag_hjj_sjj_mrcc(dets_in,u_in,H_jj,S2_jj,energies,dim_in,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 - else - do k=1,size(state_ok) - state_ok(k) = .True. - enddo - endif - - 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 - - if (state_following) then - - ! Compute overlap with U_in - ! ------------------------- - - integer :: order(N_st_diag) - double precision :: cmax - overlap = -1.d0 + logical :: state_ok(N_st_diag*davidson_sze_max) do k=1,shift2 - do i=1,shift2 - overlap(k,i) = dabs(y(k,i)) - enddo + state_ok(k) = (dabs(s2(k)-expected_s2) < 0.3d0) enddo - do k=1,N_st - cmax = -1.d0 - do i=1,N_st - if (overlap(i,k) > cmax) then - cmax = overlap(i,k) - order(k) = i - endif - enddo - do i=1,shift2 - overlap(order(k),i) = -1.d0 - enddo - enddo - overlap = y - do k=1,N_st - l = order(k) - if (k /= l) then - y(1:shift2,k) = overlap(1:shift2,l) + 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 - do k=1,N_st - overlap(k,1) = lambda(k) - overlap(k,2) = s2(k) - enddo - do k=1,N_st - l = order(k) - if (k /= l) then - lambda(k) = overlap(l,1) - s2(k) = overlap(l,2) - endif - enddo - endif ! Express eigenvectors of h in the determinant basis ! -------------------------------------------------- +! do k=1,N_st_diag +! do i=1,sze +! U(i,shift2+k) = 0.d0 +! W(i,shift2+k) = 0.d0 +! S(i,shift2+k) = 0.d0 +! enddo +! do l=1,N_st_diag*iter +! do i=1,sze +! U(i,shift2+k) = U(i,shift2+k) + U(i,l)*y(l,k) +! W(i,shift2+k) = W(i,shift2+k) + W(i,l)*y(l,k) +! S(i,shift2+k) = S(i,shift2+k) + S(i,l)*y(l,k) +! enddo +! enddo +! enddo +! +! 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, & @@ -908,65 +876,102 @@ subroutine davidson_diag_hjj_sjj_mrcc(dets_in,u_in,H_jj,S2_jj,energies,dim_in,sz ! Compute residual vector ! ----------------------- - + +! do k=1,N_st_diag +! print *, s2(k) +! s2(k) = u_dot_v(U(1,shift2+k), S(1,shift2+k), sze) + S_z2_Sz +! print *, s2(k) +! print *, '' +! pause +! enddo do k=1,N_st_diag -! if (state_ok(k)) then - 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 -! else -! ! Randomize components with bad -! do i=1,sze-2,2 -! call random_number(r1) -! call random_number(r2) -! r1 = dsqrt(-2.d0*dlog(r1)) -! r2 = dtwo_pi*r2 -! U(i,shift2+k) = r1*dcos(r2) -! U(i+1,shift2+k) = r1*dsin(r2) -! enddo -! do i=sze-2+1,sze -! call random_number(r1) -! call random_number(r2) -! r1 = dsqrt(-2.d0*dlog(r1)) -! r2 = dtwo_pi*r2 -! U(i,shift2+k) = r1*dcos(r2) -! enddo -! endif - + do i=1,sze + R(i,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) + enddo if (k <= N_st) then - residual_norm(k) = u_dot_u(U(1,shift2+k),sze) + residual_norm(k) = u_dot_u(R(1,k),sze) to_print(1,k) = lambda(k) + nuclear_repulsion to_print(2,k) = s2(k) to_print(3,k) = residual_norm(k) + if (residual_norm(k) > 1.e9) then + stop 'Davidson failed' + endif 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) + write(iunit,'(X,I3,X,100(X,F16.10,X,F11.6,X,E11.3))') iter, to_print(:,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 + + ! Davidson step + ! ------------- + + do k=1,N_st_diag + do i=1,sze + U(i,shift2+k) = - R(i,k)/max(H_jj(i) - lambda(k),1.d-2) + enddo + enddo + + ! Gram-Schmidt + ! ------------ + + do k=1,N_st_diag + +! do l=1,N_st_diag*iter +! c(1) = u_dot_v(U(1,shift2+k),U(1,l),sze) +! do i=1,sze +! U(i,k,iter+1) = U(i,shift2+k) - c(1) * U(i,l) +! enddo +! enddo +! + call dgemv('T',sze,N_st_diag*iter,1.d0,U,size(U,1), & + U(1,shift2+k),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,shift2+k),1) +! +! do l=1,k-1 +! c(1) = u_dot_v(U(1,shift2+k),U(1,shift2+l),sze) +! do i=1,sze +! U(i,k,iter+1) = U(i,shift2+k) - c(1) * U(i,shift2+l) +! enddo +! enddo +! + call dgemv('T',sze,k-1,1.d0,U(1,shift2+1),size(U,1), & + U(1,shift2+k),1,0.d0,c,1) + call dgemv('N',sze,k-1,-1.d0,U(1,shift2+1),size(U,1), & + c,1,1.d0,U(1,shift2+k),1) + + call normalize( U(1,shift2+k), sze ) + enddo enddo + if (.not.converged) then + iter = davidson_sze_max-1 + endif + ! Re-contract to u_in ! ----------- - call dgemm('N','N', sze, N_st_diag, shift2, & - 1.d0, U, size(U,1), y, size(y,1), 0.d0, u_in, size(u_in,1)) + do k=1,N_st_diag + energies(k) = lambda(k) + enddo - enddo +! do k=1,N_st_diag +! do i=1,sze +! do l=1,iter*N_st_diag +! u_in(i,k) += U(i,l)*y(l,k) +! 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), 0.d0, u_in, size(u_in,1)) - do k=1,N_st_diag - energies(k) = lambda(k) enddo write_buffer = '===== ' @@ -978,9 +983,10 @@ subroutine davidson_diag_hjj_sjj_mrcc(dets_in,u_in,H_jj,S2_jj,energies,dim_in,sz call write_time(iunit) deallocate ( & + kl_pairs, & W, residual_norm, & U, overlap, & - c, S, & + R, c, S, & h, & y, s_, s_tmp, & lambda & @@ -1042,16 +1048,15 @@ subroutine H_S2_u_0_mrcc_nstates(v_0,s_0,u_0,H_jj,S2_jj,n,keys_tmp,Nint,istate_i 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) - PROVIDE delta_ij_s2 !$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, delta_ij_s2,istate_in) + !$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(guided) + !$OMP DO SCHEDULE(dynamic) do sh=1,shortcut(0,1) do sh2=sh,shortcut(0,1) exa = 0 @@ -1093,8 +1098,8 @@ subroutine H_S2_u_0_mrcc_nstates(v_0,s_0,u_0,H_jj,S2_jj,n,keys_tmp,Nint,istate_i enddo enddo enddo - !$OMP END DO - !$OMP DO SCHEDULE(guided) + !$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) @@ -1117,7 +1122,7 @@ subroutine H_S2_u_0_mrcc_nstates(v_0,s_0,u_0,H_jj,S2_jj,n,keys_tmp,Nint,istate_i end do end do enddo - !$OMP END DO + !$OMP END DO NOWAIT ! -------------------------- ! Begin Specific to dressing @@ -1131,8 +1136,6 @@ subroutine H_S2_u_0_mrcc_nstates(v_0,s_0,u_0,H_jj,S2_jj,n,keys_tmp,Nint,istate_i 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) - st (istate,i) = st (istate,i) + delta_ij_s2(istate_in,jj,ii)*ut(istate,j) - st (istate,j) = st (istate,j) + delta_ij_s2(istate_in,jj,ii)*ut(istate,i) enddo enddo enddo diff --git a/plugins/MRCC_Utils/mrcc_dummy.irp.f b/plugins/MRCC_Utils/mrcc_dummy.irp.f new file mode 100644 index 00000000..8f1deda8 --- /dev/null +++ b/plugins/MRCC_Utils/mrcc_dummy.irp.f @@ -0,0 +1,4 @@ +program pouet + + +end diff --git a/plugins/MRCC_Utils/mrcc_utils.irp.f b/plugins/MRCC_Utils/mrcc_utils.irp.f index d6b9cc79..84bca0b4 100644 --- a/plugins/MRCC_Utils/mrcc_utils.irp.f +++ b/plugins/MRCC_Utils/mrcc_utils.irp.f @@ -33,7 +33,6 @@ END_PROVIDER if (ihpsi_current(k) == 0.d0) then ihpsi_current(k) = 1.d-32 endif -! lambda_mrcc(k,i) = psi_non_ref_coef(i,k)/ihpsi_current(k) 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 @@ -78,6 +77,19 @@ BEGIN_PROVIDER [ double precision, hij_mrcc, (N_det_non_ref,N_det_ref) ] END_PROVIDER + BEGIN_PROVIDER [ double precision, delta_ij, (N_states,N_det_non_ref,N_det_ref) ] +&BEGIN_PROVIDER [ double precision, delta_ii, (N_states,N_det_ref) ] + implicit none + BEGIN_DOC + ! Dressing matrix in N_det basis + END_DOC + integer :: i,j,m + delta_ij = 0.d0 + delta_ii = 0.d0 + 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 @@ -127,6 +139,7 @@ END_PROVIDER integer :: mrcc_state + 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) @@ -135,34 +148,17 @@ END_PROVIDER if (diag_algorithm == "Davidson") then - allocate (eigenvectors(size(CI_eigenvectors_dressed,1),size(CI_eigenvectors_dressed,2)), & - eigenvalues(size(CI_electronic_energy_dressed,1))) - do j=1,min(N_states,N_det) - do i=1,N_det - eigenvectors(i,j) = psi_coef(i,j) - enddo - enddo - do mrcc_state=1,N_states - do j=mrcc_state,min(N_states,N_det) - do i=1,N_det - eigenvectors(i,j) = psi_coef(i,j) - enddo - enddo - call davidson_diag_mrcc_HS2(psi_det,eigenvectors,& - size(eigenvectors,1), & - eigenvalues,N_det,N_states,N_states_diag,N_int, & - output_determinants,mrcc_state) - CI_eigenvectors_dressed(1:N_det,mrcc_state) = eigenvectors(1:N_det,mrcc_state) - CI_electronic_energy_dressed(mrcc_state) = eigenvalues(mrcc_state) - enddo - do k=N_states+1,N_states_diag - CI_eigenvectors_dressed(1:N_det,k) = eigenvectors(1:N_det,k) - CI_electronic_energy_dressed(k) = eigenvalues(k) - enddo - 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)) +! 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)) - deallocate (eigenvectors,eigenvalues) else if (diag_algorithm == "Lapack") then @@ -618,52 +614,207 @@ END_PROVIDER END_PROVIDER - BEGIN_PROVIDER [ double precision, dIj_unique, (hh_nex, N_states) ] + 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, a_col, at_row + 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, r1, r2 - double precision , allocatable :: AtB(:), x(:), x_new(:), A_val_mwen(:,:), t(:) - double precision :: norm, cx, res - integer, allocatable :: lref(:), A_ind_mwen(:) + 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 - double precision, allocatable :: rho_mrcc_init(:) - integer :: a_coll, at_roww + integer, allocatable :: pathTo(:), active_hh_idx(:), active_pp_idx(:) + logical, allocatable :: active(:) + double precision, allocatable :: rho_mrcc_init(:,:) + integer :: nactive - print *, "TI", hh_nex, N_det_non_ref - - allocate(rho_mrcc_init(N_det_non_ref)) - allocate(x_new(hh_nex)) - allocate(x(hh_nex), AtB(hh_nex)) - - do s=1,N_states - - AtB(:) = 0.d0 - !$OMP PARALLEL default(none) shared(k, psi_non_ref_coef, active_excitation_to_determinants_idx,& - !$OMP active_excitation_to_determinants_val, N_det_ref, hh_nex, N_det_non_ref) & - !$OMP private(at_row, a_col, i, j, r1, r2, wk, A_ind_mwen, A_val_mwen, a_coll, at_roww)& - !$OMP shared(N_states,mrcc_col_shortcut, mrcc_N_col, AtB, mrcc_AtA_val, mrcc_AtA_ind, s, n_exc_active, active_pp_idx) - - !$OMP DO schedule(dynamic, 100) - do at_roww = 1, n_exc_active ! hh_nex - at_row = active_pp_idx(at_roww) - do i=1,active_excitation_to_determinants_idx(0,at_roww) - AtB(at_row) = AtB(at_row) + psi_non_ref_coef(active_excitation_to_determinants_idx(i, at_roww), s) * active_excitation_to_determinants_val(s,i, at_roww) + 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 - !$OMP END DO - - !$OMP END PARALLEL + 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)) + - X(:) = 0d0 + + 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 - do a_coll = 1, n_exc_active + 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 @@ -671,11 +822,12 @@ END_PROVIDER rho_mrcc_init = 0d0 allocate(lref(N_det_ref)) + !$OMP PARALLEL DO default(shared) schedule(static, 1) & + !$OMP private(lref, hh, pp, II, myMask, myDet, ok, ind, phase) do hh = 1, hh_shortcut(0) do pp = hh_shortcut(hh), hh_shortcut(hh+1)-1 - if(is_active_exc(pp)) cycle + if(active(pp)) cycle lref = 0 - AtB(pp) = 0.d0 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 @@ -685,75 +837,79 @@ END_PROVIDER 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 < 0.d0) lref(II) = -ind + if(phase < 0d0) lref(II) = -ind end do - X(pp) = AtB(pp) + X(pp) = AtB(pp) / X(pp) do II=1,N_det_ref if(lref(II) > 0) then - rho_mrcc_init(lref(II)) = psi_ref_coef(II,s) * X(pp) + rho_mrcc_init(lref(II),s) = psi_ref_coef(II,s) * X(pp) else if(lref(II) < 0) then - rho_mrcc_init(-lref(II)) = -psi_ref_coef(II,s) * X(pp) + rho_mrcc_init(-lref(II),s) = -psi_ref_coef(II,s) * X(pp) end if end do end do end do - deallocate(lref) - - do i=1,N_det_non_ref - rho_mrcc(i,s) = rho_mrcc_init(i) - enddo - + !$OMP END PARALLEL DO + x_new = x double precision :: factor, resold factor = 1.d0 resold = huge(1.d0) - - do k=0,10*hh_nex - res = 0.d0 - !$OMP PARALLEL default(shared) private(cx, i, a_col, a_coll) reduction(+:res) + do k=0,100000 + !$OMP PARALLEL default(shared) private(cx, i, j, a_col, a_coll) + !$OMP DO - do a_coll = 1, n_exc_active + 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 = 0.d0 - do i=mrcc_col_shortcut(a_coll), mrcc_col_shortcut(a_coll) + mrcc_N_col(a_coll) - 1 - cx = cx + x(mrcc_AtA_ind(i)) * mrcc_AtA_val(s,i) + 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 - 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 !$OMP END DO + !$OMP END PARALLEL - if (res > resold) then - factor = factor * 0.5d0 + 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(iand(k, 4095) == 0) then + if(mod(k, 100) == 0) then print *, "res ", k, res end if - if(res < 1d-10) exit + if(res < 1d-9) exit end do - dIj_unique(1:size(X), s) = X(1:size(X)) - - enddo - - do s=1,N_states - - do a_coll=1,n_exc_active - a_col = active_pp_idx(a_coll) - do j=1,N_det_non_ref - i = active_excitation_to_determinants_idx(j,a_coll) - if (i==0) exit - rho_mrcc(i,s) = rho_mrcc(i,s) + active_excitation_to_determinants_val(s,j,a_coll) * dIj_unique(a_col,s) - enddo - end do - + + + norm = 0.d0 do i=1,N_det_non_ref norm = norm + rho_mrcc(i,s)*rho_mrcc(i,s) @@ -765,11 +921,122 @@ END_PROVIDER enddo ! Norm now contains the norm of Psi + A.X - print *, "norm : ", sqrt(norm) - enddo - + print *, k, "res : ", res, "norm : ", sqrt(norm) - do s=1,N_states +!--------------- +! 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 @@ -777,16 +1044,12 @@ END_PROVIDER rho_mrcc(i,s) = 1.d-32 endif - if (lambda_type == 2) then - f = 1.d0 - else - ! f is such that f.\tilde{c_i} = c_i - f = psi_non_ref_coef(i,s) / rho_mrcc(i,s) + ! 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) - endif + ! 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 @@ -807,9 +1070,6 @@ END_PROVIDER norm = norm*f print *, 'norm of |T Psi_0> = ', dsqrt(norm) - if (dsqrt(norm) > 1.d0) then - stop 'Error : Norm of the SD larger than the norm of the reference.' - endif do i=1,N_det_ref norm = norm + psi_ref_coef(i,s)*psi_ref_coef(i,s) @@ -821,6 +1081,7 @@ END_PROVIDER ! rho_mrcc now contains the product of the scaling factors and the ! normalization constant + dIj_unique(:size(X), s) = X(:) end do END_PROVIDER @@ -832,14 +1093,17 @@ 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 - !DIR$ FORCEINLINE 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 @@ -855,13 +1119,9 @@ double precision function get_dij_index(II, i, s, Nint) 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 if(lambda_type == 1) then + 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) - else if(lambda_type == 2) 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) end if end function @@ -919,21 +1179,9 @@ end function BEGIN_PROVIDER [ integer*2, hh_exists, (4, N_hh_exists) ] -&BEGIN_PROVIDER [ integer*2, pp_exists, (4, N_pp_exists) ] &BEGIN_PROVIDER [ integer, hh_shortcut, (0:N_hh_exists + 1) ] -&BEGIN_PROVIDER [ integer, hh_nex ] +&BEGIN_PROVIDER [ integer*2, pp_exists, (4, N_pp_exists) ] implicit none - BEGIN_DOC - ! - ! hh_exists : - ! - ! pp_exists : - ! - ! hh_shortcut : - ! - ! hh_nex : Total number of excitation operators - ! - END_DOC integer*2,allocatable :: num(:,:) integer :: exc(0:2, 2, 2), degree, n, on, s, l, i integer*2 :: h1, h2, p1, p2 @@ -999,7 +1247,6 @@ end function end if end do end do - hh_nex = hh_shortcut(hh_shortcut(0)+1)-1 END_PROVIDER diff --git a/plugins/MRCC_Utils/multi_state.irp.f b/plugins/MRCC_Utils/multi_state.irp.f deleted file mode 100644 index b4a2a3cb..00000000 --- a/plugins/MRCC_Utils/multi_state.irp.f +++ /dev/null @@ -1,101 +0,0 @@ -subroutine multi_state(CI_electronic_energy_dressed_,CI_eigenvectors_dressed_,LDA) - implicit none - BEGIN_DOC - ! Multi-state mixing - END_DOC - integer, intent(in) :: LDA - double precision, intent(inout) :: CI_electronic_energy_dressed_(N_states) - double precision, intent(inout) :: CI_eigenvectors_dressed_(LDA,N_states) - double precision, allocatable :: h(:,:,:), s(:,:), Psi(:,:), H_Psi(:,:,:), H_jj(:) - - allocate( h(N_states,N_states,0:N_states), s(N_states,N_states) ) - allocate( Psi(LDA,N_states), H_Psi(LDA,N_states,0:N_states) ) - allocate (H_jj(LDA) ) - -! e_0(i) = u_dot_v(v_0(1,i),u_0(1,i),n)/u_dot_u(u_0(1,i),n) - - integer :: i,j,k,istate - double precision :: U(N_states,N_states), Vt(N_states,N_states), D(N_states) - double precision, external :: diag_H_mat_elem - do istate=1,N_states - do i=1,N_det - H_jj(i) = diag_H_mat_elem(psi_det(1,1,i),N_int) - enddo - - do i=1,N_det_ref - H_jj(idx_ref(i)) += delta_ii(istate,i) - enddo - - do k=1,N_states - do i=1,N_det - Psi(i,k) = CI_eigenvectors_dressed_(i,k) - enddo - enddo - call H_u_0_mrcc_nstates(H_Psi(1,1,istate),Psi,H_jj,N_det,psi_det,N_int,istate,N_states,LDA) - - do k=1,N_states - do i=1,N_states - double precision, external :: u_dot_v - h(i,k,istate) = u_dot_v(Psi(1,i), H_Psi(1,k,istate), N_det) - enddo - enddo - enddo - - do k=1,N_states - do i=1,N_states - s(i,k) = u_dot_v(Psi(1,i), Psi(1,k), N_det) - enddo - enddo - - print *, s(:,:) - print *, '' - - h(:,:,0) = h(:,:,1) - do istate=2,N_states - U(:,:) = h(:,:,0) - call dgemm('N','N',N_states,N_states,N_states,1.d0,& - U, size(U,1), h(1,1,istate), size(h,1), 0.d0, & - h(1,1,0), size(Vt,1)) - enddo - - call svd(h(1,1,0), size(h,1), U, size(U,1), D, Vt, size(Vt,1), N_states, N_states) - do k=1,N_states - D(k) = D(k)**(1./dble(N_states)) - if (D(k) > 0.d0) then - D(k) = -D(k) - endif - enddo - - do j=1,N_states - do i=1,N_states - h(i,j,0) = 0.d0 - do k=1,N_states - h(i,j,0) += U(i,k) * D(k) * Vt(k,j) - enddo - enddo - enddo - - print *, h(:,:,0) - print *,'' - - integer :: LWORK, INFO - double precision, allocatable :: WORK(:) - LWORK=3*N_states - allocate (WORK(LWORK)) - call dsygv(1, 'V', 'U', N_states, h(1,1,0), size(h,1), s, size(s,1), D, WORK, LWORK, INFO) - deallocate(WORK) - - do j=1,N_states - do i=1,N_det - CI_eigenvectors_dressed_(i,j) = 0.d0 - do k=1,N_states - CI_eigenvectors_dressed_(i,j) += Psi(i,k) * h(k,j,0) - enddo - enddo - CI_electronic_energy_dressed_(j) = D(j) - enddo - - - deallocate (h,s, H_jj) - deallocate( Psi, H_Psi ) -end diff --git a/plugins/MRPT/MRPT_Utils.main.irp.f b/plugins/MRPT/MRPT_Utils.main.irp.f deleted file mode 100644 index 13c8228a..00000000 --- a/plugins/MRPT/MRPT_Utils.main.irp.f +++ /dev/null @@ -1,43 +0,0 @@ -program MRPT_Utils - implicit none - read_wf = .True. - touch read_wf -! call routine -! call routine_2 - call routine_3 -end - - -subroutine routine_3 - implicit none -!provide fock_virt_total_spin_trace - provide delta_ij - - print *, 'N_det = ', N_det - print *, 'N_states = ', N_states - print *, 'PT2 = ', second_order_pt_new(1) - print *, 'E = ', CI_energy(1) - print *, 'E+PT2 = ', CI_energy(1)+second_order_pt_new(1) - print *,'****** DIAGONALIZATION OF DRESSED MATRIX ******' - print *, 'E dressed= ', CI_dressed_pt2_new_energy(1) - -end - -subroutine routine_2 - implicit none - integer :: i - do i = 1, n_core_inact_orb - print*,fock_core_inactive_total(i,1,1),fock_core_inactive(i) - enddo - double precision :: accu - accu = 0.d0 - do i = 1, n_act_orb - integer :: j_act_orb - j_act_orb = list_act(i) - accu += one_body_dm_mo_alpha(j_act_orb,j_act_orb,1) - print*,one_body_dm_mo_alpha(j_act_orb,j_act_orb,1),one_body_dm_mo_beta(j_act_orb,j_act_orb,1) - enddo - print*,'accu = ',accu - -end - diff --git a/plugins/MRPT/NEEDED_CHILDREN_MODULES b/plugins/MRPT/NEEDED_CHILDREN_MODULES deleted file mode 100644 index 7340c609..00000000 --- a/plugins/MRPT/NEEDED_CHILDREN_MODULES +++ /dev/null @@ -1 +0,0 @@ -MRPT_Utils Selectors_full Generators_full diff --git a/plugins/MRPT/README.rst b/plugins/MRPT/README.rst deleted file mode 100644 index a9a0860c..00000000 --- a/plugins/MRPT/README.rst +++ /dev/null @@ -1,14 +0,0 @@ -==== -MRPT -==== - -Executables for Multi-reference perturbation. - -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/mrpt.irp.f b/plugins/MRPT/mrpt.irp.f deleted file mode 100644 index 8c8d746d..00000000 --- a/plugins/MRPT/mrpt.irp.f +++ /dev/null @@ -1,38 +0,0 @@ -program MRPT - implicit none - BEGIN_DOC -! TODO - END_DOC - print *, ' _/ ' - print *, ' -:\_?, _Jm####La ' - print *, 'J"(:" > _]#AZ#Z#UUZ##, ' - print *, '_,::./ %(|i%12XmX1*1XL _?, ' - print *, ' \..\ _\(vmWQwodY+ia%lnL _",/ ( ' - print *, ' .:< ]J=mQD?WXn|,)nr" ' - print *, ' 4XZ#Xov1v}=)vnXAX1nnv;1n" ' - print *, ' ]XX#ZXoovvvivnnnlvvo2*i7 ' - print *, ' "23Z#1S2oo2XXSnnnoSo2>v" ' - print *, ' miX#L -~`""!!1}oSoe|i7 ' - print *, ' 4cn#m, v221=|v[ ' - print *, ' ]hI3Zma,;..__wXSe=+vo ' - print *, ' ]Zov*XSUXXZXZXSe||vo2 ' - print *, ' ]Z#>=|< ' - print *, ' -ziiiii||||||+||==+> ' - print *, ' -%|+++||=|=+|=|==/ ' - print *, ' -a>====+|====-:- ' - print *, ' "~,- -- /- ' - print *, ' -. )> ' - print *, ' .~ +- ' - print *, ' . .... : . ' - print *, ' -------~ ' - print *, '' -end diff --git a/plugins/MRPT/print_1h2p.irp.f b/plugins/MRPT/print_1h2p.irp.f deleted file mode 100644 index d10e1fb5..00000000 --- a/plugins/MRPT/print_1h2p.irp.f +++ /dev/null @@ -1,51 +0,0 @@ -program print_1h2p - implicit none - read_wf = .True. - touch read_wf - call routine -end - -subroutine routine - implicit none - double precision,allocatable :: matrix_1h2p(:,:,:) - allocate (matrix_1h2p(N_det,N_det,N_states)) - integer :: i,j,istate - do i = 1, N_det - do j = 1, N_det - do istate = 1, N_states - matrix_1h2p(i,j,istate) = 0.d0 - enddo - enddo - enddo - if(.False.)then - call give_1h2p_contrib(matrix_1h2p) - double precision :: accu - accu = 0.d0 - do i = 1, N_det - do j = 1, N_det - accu += matrix_1h2p(i,j,1) * psi_coef(i,1) * psi_coef(j,1) - enddo - enddo - print*, 'second order ', accu - endif - - if(.True.)then - do i = 1, N_det - do j = 1, N_det - do istate = 1, N_states - matrix_1h2p(i,j,istate) = 0.d0 - enddo - enddo - enddo - call give_1h2p_new(matrix_1h2p) - accu = 0.d0 - do i = 1, N_det - do j = 1, N_det - accu += matrix_1h2p(i,j,1) * psi_coef(i,1) * psi_coef(j,1) - enddo - enddo - endif - print*, 'third order ', accu - - deallocate (matrix_1h2p) -end diff --git a/plugins/MRPT_Utils/EZFIO.cfg b/plugins/MRPT_Utils/EZFIO.cfg deleted file mode 100644 index 2fcc26ad..00000000 --- a/plugins/MRPT_Utils/EZFIO.cfg +++ /dev/null @@ -1,7 +0,0 @@ -[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/H_apply.irp.f b/plugins/MRPT_Utils/H_apply.irp.f deleted file mode 100644 index 6f17ab05..00000000 --- a/plugins/MRPT_Utils/H_apply.irp.f +++ /dev/null @@ -1,187 +0,0 @@ -use bitmasks -BEGIN_SHELL [ /usr/bin/env python ] -from generate_h_apply import * - -s = H_apply("mrpt") -s.data["parameters"] = ", delta_ij_, Ndet" -s.data["declarations"] += """ - integer, intent(in) :: Ndet - double precision, intent(in) :: delta_ij_(Ndet,Ndet,*) -""" -s.data["keys_work"] = "call mrpt_dress(delta_ij_,Ndet,i_generator,key_idx,keys_out,N_int,iproc,key_mask)" -s.data["params_post"] += ", delta_ij_, Ndet" -s.data["params_main"] += "delta_ij_, Ndet" -s.data["decls_main"] += """ - integer, intent(in) :: Ndet - double precision, intent(in) :: delta_ij_(Ndet,Ndet,*) -""" -s.data["finalization"] = "" -s.data["copy_buffer"] = "" -s.data["generate_psi_guess"] = "" -s.data["size_max"] = "3072" -print s - -s = H_apply("mrpt_1h") -s.filter_only_1h() -s.data["parameters"] = ", delta_ij_, Ndet" -s.data["declarations"] += """ - integer, intent(in) :: Ndet - double precision, intent(in) :: delta_ij_(Ndet,Ndet,*) -""" -s.data["keys_work"] = "call mrpt_dress(delta_ij_,Ndet,i_generator,key_idx,keys_out,N_int,iproc,key_mask)" -s.data["params_post"] += ", delta_ij_, Ndet" -s.data["params_main"] += "delta_ij_, Ndet" -s.data["decls_main"] += """ - integer, intent(in) :: Ndet - double precision, intent(in) :: delta_ij_(Ndet,Ndet,*) -""" -s.data["finalization"] = "" -s.data["copy_buffer"] = "" -s.data["generate_psi_guess"] = "" -s.data["size_max"] = "3072" -print s - -s = H_apply("mrpt_1p") -s.filter_only_1p() -s.data["parameters"] = ", delta_ij_, Ndet" -s.data["declarations"] += """ - integer, intent(in) :: Ndet - double precision, intent(in) :: delta_ij_(Ndet,Ndet,*) -""" -s.data["keys_work"] = "call mrpt_dress(delta_ij_,Ndet,i_generator,key_idx,keys_out,N_int,iproc,key_mask)" -s.data["params_post"] += ", delta_ij_, Ndet" -s.data["params_main"] += "delta_ij_, Ndet" -s.data["decls_main"] += """ - integer, intent(in) :: Ndet - double precision, intent(in) :: delta_ij_(Ndet,Ndet,*) -""" -s.data["finalization"] = "" -s.data["copy_buffer"] = "" -s.data["generate_psi_guess"] = "" -s.data["size_max"] = "3072" -print s - -s = H_apply("mrpt_1h1p") -s.filter_only_1h1p() -s.data["parameters"] = ", delta_ij_, Ndet" -s.data["declarations"] += """ - integer, intent(in) :: Ndet - double precision, intent(in) :: delta_ij_(Ndet,Ndet,*) -""" -s.data["keys_work"] = "call mrpt_dress(delta_ij_,Ndet,i_generator,key_idx,keys_out,N_int,iproc,key_mask)" -s.data["params_post"] += ", delta_ij_, Ndet" -s.data["params_main"] += "delta_ij_, Ndet" -s.data["decls_main"] += """ - integer, intent(in) :: Ndet - double precision, intent(in) :: delta_ij_(Ndet,Ndet,*) -""" -s.data["finalization"] = "" -s.data["copy_buffer"] = "" -s.data["generate_psi_guess"] = "" -s.data["size_max"] = "3072" -print s - -s = H_apply("mrpt_2p") -s.filter_only_2p() -s.data["parameters"] = ", delta_ij_, Ndet" -s.data["declarations"] += """ - integer, intent(in) :: Ndet - double precision, intent(in) :: delta_ij_(Ndet,Ndet,*) -""" -s.data["keys_work"] = "call mrpt_dress(delta_ij_,Ndet,i_generator,key_idx,keys_out,N_int,iproc,key_mask)" -s.data["params_post"] += ", delta_ij_, Ndet" -s.data["params_main"] += "delta_ij_, Ndet" -s.data["decls_main"] += """ - integer, intent(in) :: Ndet - double precision, intent(in) :: delta_ij_(Ndet,Ndet,*) -""" -s.data["finalization"] = "" -s.data["copy_buffer"] = "" -s.data["generate_psi_guess"] = "" -s.data["size_max"] = "3072" -print s - -s = H_apply("mrpt_2h") -s.filter_only_2h() -s.data["parameters"] = ", delta_ij_, Ndet" -s.data["declarations"] += """ - integer, intent(in) :: Ndet - double precision, intent(in) :: delta_ij_(Ndet,Ndet,*) -""" -s.data["keys_work"] = "call mrpt_dress(delta_ij_,Ndet,i_generator,key_idx,keys_out,N_int,iproc,key_mask)" -s.data["params_post"] += ", delta_ij_, Ndet" -s.data["params_main"] += "delta_ij_, Ndet" -s.data["decls_main"] += """ - integer, intent(in) :: Ndet - double precision, intent(in) :: delta_ij_(Ndet,Ndet,*) -""" -s.data["finalization"] = "" -s.data["copy_buffer"] = "" -s.data["generate_psi_guess"] = "" -s.data["size_max"] = "3072" -print s - - -s = H_apply("mrpt_1h2p") -s.filter_only_1h2p() -s.data["parameters"] = ", delta_ij_, Ndet" -s.data["declarations"] += """ - integer, intent(in) :: Ndet - double precision, intent(in) :: delta_ij_(Ndet,Ndet,*) -""" -s.data["keys_work"] = "call mrpt_dress(delta_ij_,Ndet,i_generator,key_idx,keys_out,N_int,iproc,key_mask)" -s.data["params_post"] += ", delta_ij_, Ndet" -s.data["params_main"] += "delta_ij_, Ndet" -s.data["decls_main"] += """ - integer, intent(in) :: Ndet - double precision, intent(in) :: delta_ij_(Ndet,Ndet,*) -""" -s.data["finalization"] = "" -s.data["copy_buffer"] = "" -s.data["generate_psi_guess"] = "" -s.data["size_max"] = "3072" -print s - -s = H_apply("mrpt_2h1p") -s.filter_only_2h1p() -s.data["parameters"] = ", delta_ij_, Ndet" -s.data["declarations"] += """ - integer, intent(in) :: Ndet - double precision, intent(in) :: delta_ij_(Ndet,Ndet,*) -""" -s.data["keys_work"] = "call mrpt_dress(delta_ij_,Ndet,i_generator,key_idx,keys_out,N_int,iproc,key_mask)" -s.data["params_post"] += ", delta_ij_, Ndet" -s.data["params_main"] += "delta_ij_, Ndet" -s.data["decls_main"] += """ - integer, intent(in) :: Ndet - double precision, intent(in) :: delta_ij_(Ndet,Ndet,*) -""" -s.data["finalization"] = "" -s.data["copy_buffer"] = "" -s.data["generate_psi_guess"] = "" -s.data["size_max"] = "3072" -print s - -s = H_apply("mrpt_2h2p") -s.filter_only_2h2p() -s.data["parameters"] = ", delta_ij_, Ndet" -s.data["declarations"] += """ - integer, intent(in) :: Ndet - double precision, intent(in) :: delta_ij_(Ndet,Ndet,*) -""" -s.data["keys_work"] = "call mrpt_dress(delta_ij_,Ndet,i_generator,key_idx,keys_out,N_int,iproc,key_mask)" -s.data["params_post"] += ", delta_ij_, Ndet" -s.data["params_main"] += "delta_ij_, Ndet" -s.data["decls_main"] += """ - integer, intent(in) :: Ndet - double precision, intent(in) :: delta_ij_(Ndet,Ndet,*) -""" -s.data["finalization"] = "" -s.data["copy_buffer"] = "" -s.data["generate_psi_guess"] = "" -s.data["size_max"] = "3072" -print s - - -END_SHELL - diff --git a/plugins/MRPT_Utils/NEEDED_CHILDREN_MODULES b/plugins/MRPT_Utils/NEEDED_CHILDREN_MODULES deleted file mode 100644 index 34de8ddb..00000000 --- a/plugins/MRPT_Utils/NEEDED_CHILDREN_MODULES +++ /dev/null @@ -1 +0,0 @@ -Determinants Davidson diff --git a/plugins/MRPT_Utils/README.rst b/plugins/MRPT_Utils/README.rst deleted file mode 100644 index 6b7a8eff..00000000 --- a/plugins/MRPT_Utils/README.rst +++ /dev/null @@ -1,13 +0,0 @@ -========== -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/energies_cas.irp.f b/plugins/MRPT_Utils/energies_cas.irp.f deleted file mode 100644 index ac399ce7..00000000 --- a/plugins/MRPT_Utils/energies_cas.irp.f +++ /dev/null @@ -1,1114 +0,0 @@ -BEGIN_PROVIDER [ double precision, energy_cas_dyall, (N_states)] - implicit none - integer :: i - double precision :: energies(N_states_diag) - do i = 1, N_states - call u0_H_dyall_u0(energies,psi_active,psi_coef,n_det,psi_det_size,psi_det_size,N_states_diag,i) - energy_cas_dyall(i) = energies(i) - print*, 'energy_cas_dyall(i)', energy_cas_dyall(i) - enddo -END_PROVIDER - - -BEGIN_PROVIDER [ double precision, energy_cas_dyall_no_exchange, (N_states)] - implicit none - integer :: i - double precision :: energies(N_states_diag) - do i = 1, N_states - call u0_H_dyall_u0_no_exchange(energies,psi_active,psi_coef,n_det,psi_det_size,psi_det_size,N_states_diag,i) - energy_cas_dyall_no_exchange(i) = energies(i) - print*, 'energy_cas_dyall(i)_no_exchange', energy_cas_dyall_no_exchange(i) - enddo -END_PROVIDER - - - -BEGIN_PROVIDER [ double precision, one_creat, (n_act_orb,2,N_states)] - implicit none - integer :: i,j - integer :: ispin - integer :: orb, hole_particle,spin_exc - double precision :: norm_out(N_states_diag) - integer(bit_kind), allocatable :: psi_in_out(:,:,:) - double precision, allocatable :: psi_in_out_coef(:,:) - allocate (psi_in_out(N_int,2,n_det),psi_in_out_coef(n_det,N_states_diag)) - use bitmasks - - integer :: iorb - integer :: state_target - double precision :: energies(n_states_diag) - do iorb = 1,n_act_orb - do ispin = 1,2 - orb = list_act(iorb) - hole_particle = 1 - spin_exc = ispin - do i = 1, n_det - do j = 1, n_states_diag - psi_in_out_coef(i,j) = psi_coef(i,j) - enddo - do j = 1, N_int - psi_in_out(j,1,i) = psi_active(j,1,i) - psi_in_out(j,2,i) = psi_active(j,2,i) - enddo - enddo - do state_target = 1,N_states - call apply_exc_to_psi(orb,hole_particle,spin_exc, & - norm_out,psi_in_out,psi_in_out_coef, n_det,n_det,n_det,N_states_diag) - call u0_H_dyall_u0(energies,psi_in_out,psi_in_out_coef,n_det,n_det,n_det,N_states_diag,state_target) - one_creat(iorb,ispin,state_target) = energy_cas_dyall(state_target) - energies(state_target) - enddo - enddo - enddo - deallocate(psi_in_out,psi_in_out_coef) - -END_PROVIDER - -BEGIN_PROVIDER [ double precision, one_anhil, (n_act_orb,2,N_states)] - implicit none - integer :: i,j - integer :: ispin - integer :: orb, hole_particle,spin_exc - double precision :: norm_out(N_states_diag) - integer(bit_kind), allocatable :: psi_in_out(:,:,:) - double precision, allocatable :: psi_in_out_coef(:,:) - use bitmasks - allocate (psi_in_out(N_int,2,n_det),psi_in_out_coef(n_det,N_states_diag)) - - integer :: iorb - integer :: state_target - double precision :: energies(n_states_diag) - do iorb = 1,n_act_orb - do ispin = 1,2 - orb = list_act(iorb) - hole_particle = -1 - spin_exc = ispin - do i = 1, n_det - do j = 1, n_states_diag - psi_in_out_coef(i,j) = psi_coef(i,j) - enddo - do j = 1, N_int - psi_in_out(j,1,i) = psi_active(j,1,i) - psi_in_out(j,2,i) = psi_active(j,2,i) - enddo - enddo - do state_target = 1, N_states - call apply_exc_to_psi(orb,hole_particle,spin_exc, & - norm_out,psi_in_out,psi_in_out_coef, n_det,n_det,n_det,N_states_diag) - call u0_H_dyall_u0(energies,psi_in_out,psi_in_out_coef,n_det,n_det,n_det,N_states_diag,state_target) - one_anhil(iorb,ispin,state_target) = energy_cas_dyall(state_target) - energies(state_target) - enddo - enddo - enddo - deallocate(psi_in_out,psi_in_out_coef) - -END_PROVIDER - -BEGIN_PROVIDER [ double precision, two_creat, (n_act_orb,n_act_orb,2,2,N_states)] - implicit none - integer :: i,j - integer :: ispin,jspin - integer :: orb_i, hole_particle_i,spin_exc_i - integer :: orb_j, hole_particle_j,spin_exc_j - double precision :: norm_out(N_states_diag) - integer(bit_kind), allocatable :: psi_in_out(:,:,:) - double precision, allocatable :: psi_in_out_coef(:,:) - use bitmasks - allocate (psi_in_out(N_int,2,n_det),psi_in_out_coef(n_det,N_states_diag)) - - integer :: iorb,jorb - integer :: state_target - double precision :: energies(n_states_diag) - do iorb = 1,n_act_orb - do ispin = 1,2 - orb_i = list_act(iorb) - hole_particle_i = 1 - spin_exc_i = ispin - do jorb = 1, n_act_orb - do jspin = 1,2 - orb_j = list_act(jorb) - hole_particle_j = 1 - spin_exc_j = jspin - do i = 1, n_det - do j = 1, n_states_diag - psi_in_out_coef(i,j) = psi_coef(i,j) - enddo - do j = 1, N_int - psi_in_out(j,1,i) = psi_active(j,1,i) - psi_in_out(j,2,i) = psi_active(j,2,i) - enddo - enddo - do state_target = 1 , N_states - call apply_exc_to_psi(orb_i,hole_particle_i,spin_exc_i, & - norm_out,psi_in_out,psi_in_out_coef, n_det,n_det,n_det,N_states_diag) - call apply_exc_to_psi(orb_j,hole_particle_j,spin_exc_j, & - norm_out,psi_in_out,psi_in_out_coef, n_det,n_det,n_det,N_states_diag) - call u0_H_dyall_u0(energies,psi_in_out,psi_in_out_coef,n_det,n_det,n_det,N_states_diag,state_target) - two_creat(iorb,jorb,ispin,jspin,state_target) = energy_cas_dyall(state_target) - energies(state_target) - enddo - enddo - enddo - enddo - enddo - deallocate(psi_in_out,psi_in_out_coef) - -END_PROVIDER - -BEGIN_PROVIDER [ double precision, two_anhil, (n_act_orb,n_act_orb,2,2,N_states)] - implicit none - integer :: i,j - integer :: ispin,jspin - integer :: orb_i, hole_particle_i,spin_exc_i - integer :: orb_j, hole_particle_j,spin_exc_j - double precision :: norm_out(N_states_diag) - integer(bit_kind), allocatable :: psi_in_out(:,:,:) - double precision, allocatable :: psi_in_out_coef(:,:) - use bitmasks - allocate (psi_in_out(N_int,2,n_det),psi_in_out_coef(n_det,N_states_diag)) - - integer :: iorb,jorb - integer :: state_target - state_target = 1 - double precision :: energies(n_states_diag) - do iorb = 1,n_act_orb - do ispin = 1,2 - orb_i = list_act(iorb) - hole_particle_i = -1 - spin_exc_i = ispin - do jorb = 1, n_act_orb - do jspin = 1,2 - orb_j = list_act(jorb) - hole_particle_j = -1 - spin_exc_j = jspin - do i = 1, n_det - do j = 1, n_states_diag - psi_in_out_coef(i,j) = psi_coef(i,j) - enddo - do j = 1, N_int - psi_in_out(j,1,i) = psi_active(j,1,i) - psi_in_out(j,2,i) = psi_active(j,2,i) - enddo - enddo - call apply_exc_to_psi(orb_i,hole_particle_i,spin_exc_i, & - norm_out,psi_in_out,psi_in_out_coef, n_det,n_det,n_det,N_states_diag) - call apply_exc_to_psi(orb_j,hole_particle_j,spin_exc_j, & - norm_out,psi_in_out,psi_in_out_coef, n_det,n_det,n_det,N_states_diag) - call u0_H_dyall_u0(energies,psi_in_out,psi_in_out_coef,n_det,n_det,n_det,N_states_diag,state_target) - two_anhil(iorb,jorb,ispin,jspin,state_target) = energy_cas_dyall(state_target) - energies(state_target) - enddo - enddo - enddo - enddo - deallocate(psi_in_out,psi_in_out_coef) - -END_PROVIDER - -BEGIN_PROVIDER [ double precision, one_anhil_one_creat, (n_act_orb,n_act_orb,2,2,N_States)] - implicit none - integer :: i,j - integer :: ispin,jspin - integer :: orb_i, hole_particle_i,spin_exc_i - integer :: orb_j, hole_particle_j,spin_exc_j - double precision :: norm_out(N_states_diag) - integer(bit_kind), allocatable :: psi_in_out(:,:,:) - double precision, allocatable :: psi_in_out_coef(:,:) - use bitmasks - - allocate (psi_in_out(N_int,2,n_det),psi_in_out_coef(n_det,N_states_diag)) - integer :: iorb,jorb - integer :: state_target - double precision :: energies(n_states_diag) - do iorb = 1,n_act_orb - do ispin = 1,2 - orb_i = list_act(iorb) - hole_particle_i = 1 - spin_exc_i = ispin - do jorb = 1, n_act_orb - do jspin = 1,2 - orb_j = list_act(jorb) - hole_particle_j = -1 - spin_exc_j = jspin - do i = 1, n_det - do j = 1, n_states_diag - psi_in_out_coef(i,j) = psi_coef(i,j) - enddo - do j = 1, N_int - psi_in_out(j,1,i) = psi_active(j,1,i) - psi_in_out(j,2,i) = psi_active(j,2,i) - enddo - enddo - do state_target = 1, N_states - call apply_exc_to_psi(orb_j,hole_particle_j,spin_exc_j, & - norm_out,psi_in_out,psi_in_out_coef, n_det,n_det,n_det,N_states_diag) - call apply_exc_to_psi(orb_i,hole_particle_i,spin_exc_i, & - norm_out,psi_in_out,psi_in_out_coef, n_det,n_det,n_det,N_states_diag) - if(orb_i == orb_j .and. ispin .ne. jspin)then - call u0_H_dyall_u0_no_exchange(energies,psi_in_out,psi_in_out_coef,n_det,n_det,n_det,N_states_diag,state_target) - one_anhil_one_creat(iorb,jorb,ispin,jspin,state_target) = energy_cas_dyall_no_exchange(state_target) - energies(state_target) - else - call u0_H_dyall_u0(energies,psi_in_out,psi_in_out_coef,n_det,n_det,n_det,N_states_diag,state_target) - one_anhil_one_creat(iorb,jorb,ispin,jspin,state_target) = energy_cas_dyall(state_target) - energies(state_target) - endif - enddo - enddo - enddo - enddo - enddo - -END_PROVIDER - - -BEGIN_PROVIDER [ double precision, two_anhil_one_creat, (n_act_orb,n_act_orb,n_act_orb,2,2,2,N_states)] - implicit none - integer :: i,j - integer :: ispin,jspin,kspin - integer :: orb_i, hole_particle_i,spin_exc_i - integer :: orb_j, hole_particle_j,spin_exc_j - integer :: orb_k, hole_particle_k,spin_exc_k - double precision :: norm_out(N_states_diag) - integer(bit_kind), allocatable :: psi_in_out(:,:,:) - double precision, allocatable :: psi_in_out_coef(:,:) - use bitmasks - allocate (psi_in_out(N_int,2,n_det),psi_in_out_coef(n_det,N_states_diag)) - - integer :: iorb,jorb - integer :: korb - integer :: state_target - double precision :: energies(n_states_diag) - do iorb = 1,n_act_orb - do ispin = 1,2 - orb_i = list_act(iorb) - hole_particle_i = 1 - spin_exc_i = ispin - do jorb = 1, n_act_orb - do jspin = 1,2 - orb_j = list_act(jorb) - hole_particle_j = -1 - spin_exc_j = jspin - do korb = 1, n_act_orb - do kspin = 1,2 - orb_k = list_act(korb) - hole_particle_k = -1 - spin_exc_k = kspin - do i = 1, n_det - do j = 1, n_states_diag - psi_in_out_coef(i,j) = psi_coef(i,j) - enddo - do j = 1, N_int - psi_in_out(j,1,i) = psi_active(j,1,i) - psi_in_out(j,2,i) = psi_active(j,2,i) - enddo - enddo - - do state_target = 1, N_states - call apply_exc_to_psi(orb_j,hole_particle_j,spin_exc_j, & - norm_out,psi_in_out,psi_in_out_coef, n_det,n_det,n_det,N_states_diag) - call apply_exc_to_psi(orb_k,hole_particle_k,spin_exc_k, & - norm_out,psi_in_out,psi_in_out_coef, n_det,n_det,n_det,N_states_diag) - call apply_exc_to_psi(orb_i,hole_particle_i,spin_exc_i, & - norm_out,psi_in_out,psi_in_out_coef, n_det,n_det,n_det,N_states_diag) - call u0_H_dyall_u0(energies,psi_in_out,psi_in_out_coef,n_det,n_det,n_det,N_states_diag,state_target) - two_anhil_one_creat(iorb,jorb,korb,ispin,jspin,kspin,state_target) = energy_cas_dyall(state_target) - energies(state_target) - enddo - enddo - enddo - enddo - enddo - enddo - enddo - deallocate(psi_in_out,psi_in_out_coef) - -END_PROVIDER - -BEGIN_PROVIDER [ double precision, two_creat_one_anhil, (n_act_orb,n_act_orb,n_act_orb,2,2,2,N_states)] - implicit none - integer :: i,j - integer :: ispin,jspin,kspin - integer :: orb_i, hole_particle_i,spin_exc_i - integer :: orb_j, hole_particle_j,spin_exc_j - integer :: orb_k, hole_particle_k,spin_exc_k - double precision :: norm_out(N_states_diag) - integer(bit_kind), allocatable :: psi_in_out(:,:,:) - double precision, allocatable :: psi_in_out_coef(:,:) - use bitmasks - allocate (psi_in_out(N_int,2,n_det),psi_in_out_coef(n_det,N_states_diag)) - - integer :: iorb,jorb - integer :: korb - integer :: state_target - double precision :: energies(n_states_diag) - do iorb = 1,n_act_orb - do ispin = 1,2 - orb_i = list_act(iorb) - hole_particle_i = 1 - spin_exc_i = ispin - do jorb = 1, n_act_orb - do jspin = 1,2 - orb_j = list_act(jorb) - hole_particle_j = 1 - spin_exc_j = jspin - do korb = 1, n_act_orb - do kspin = 1,2 - orb_k = list_act(korb) - hole_particle_k = -1 - spin_exc_k = kspin - do i = 1, n_det - do j = 1, n_states_diag - psi_in_out_coef(i,j) = psi_coef(i,j) - enddo - do j = 1, N_int - psi_in_out(j,1,i) = psi_active(j,1,i) - psi_in_out(j,2,i) = psi_active(j,2,i) - enddo - enddo - do state_target = 1, N_states - call apply_exc_to_psi(orb_k,hole_particle_k,spin_exc_k, & - norm_out,psi_in_out,psi_in_out_coef, n_det,n_det,n_det,N_states_diag) - call apply_exc_to_psi(orb_i,hole_particle_i,spin_exc_i, & - norm_out,psi_in_out,psi_in_out_coef, n_det,n_det,n_det,N_states_diag) - call apply_exc_to_psi(orb_j,hole_particle_j,spin_exc_j, & - norm_out,psi_in_out,psi_in_out_coef, n_det,n_det,n_det,N_states_diag) - call u0_H_dyall_u0(energies,psi_in_out,psi_in_out_coef,n_det,n_det,n_det,N_states_diag,state_target) - two_creat_one_anhil(iorb,jorb,korb,ispin,jspin,kspin,state_target) = energy_cas_dyall(state_target) - energies(state_target) - enddo - enddo - enddo - enddo - enddo - enddo - enddo - deallocate(psi_in_out,psi_in_out_coef) - -END_PROVIDER - -BEGIN_PROVIDER [ double precision, three_creat, (n_act_orb,n_act_orb,n_act_orb,2,2,2,N_states)] - implicit none - integer :: i,j - integer :: ispin,jspin,kspin - integer :: orb_i, hole_particle_i,spin_exc_i - integer :: orb_j, hole_particle_j,spin_exc_j - integer :: orb_k, hole_particle_k,spin_exc_k - double precision :: norm_out(N_states_diag) - integer(bit_kind), allocatable :: psi_in_out(:,:,:) - double precision, allocatable :: psi_in_out_coef(:,:) - use bitmasks - allocate (psi_in_out(N_int,2,n_det),psi_in_out_coef(n_det,N_states_diag)) - - integer :: iorb,jorb - integer :: korb - integer :: state_target - double precision :: energies(n_states_diag) - do iorb = 1,n_act_orb - do ispin = 1,2 - orb_i = list_act(iorb) - hole_particle_i = 1 - spin_exc_i = ispin - do jorb = 1, n_act_orb - do jspin = 1,2 - orb_j = list_act(jorb) - hole_particle_j = 1 - spin_exc_j = jspin - do korb = 1, n_act_orb - do kspin = 1,2 - orb_k = list_act(korb) - hole_particle_k = 1 - spin_exc_k = kspin - do i = 1, n_det - do j = 1, n_states_diag - psi_in_out_coef(i,j) = psi_coef(i,j) - enddo - do j = 1, N_int - psi_in_out(j,1,i) = psi_active(j,1,i) - psi_in_out(j,2,i) = psi_active(j,2,i) - enddo - enddo - do state_target = 1, N_states - call apply_exc_to_psi(orb_i,hole_particle_i,spin_exc_i, & - norm_out,psi_in_out,psi_in_out_coef, n_det,n_det,n_det,N_states_diag) - call apply_exc_to_psi(orb_j,hole_particle_j,spin_exc_j, & - norm_out,psi_in_out,psi_in_out_coef, n_det,n_det,n_det,N_states_diag) - call apply_exc_to_psi(orb_k,hole_particle_k,spin_exc_k, & - norm_out,psi_in_out,psi_in_out_coef, n_det,n_det,n_det,N_states_diag) - call u0_H_dyall_u0(energies,psi_in_out,psi_in_out_coef,n_det,n_det,n_det,N_states_diag,state_target) - three_creat(iorb,jorb,korb,ispin,jspin,kspin,state_target) = energy_cas_dyall(state_target) - energies(state_target) - enddo - enddo - enddo - enddo - enddo - enddo - enddo - deallocate(psi_in_out,psi_in_out_coef) - -END_PROVIDER - -BEGIN_PROVIDER [ double precision, three_anhil, (n_act_orb,n_act_orb,n_act_orb,2,2,2,N_states)] - implicit none - integer :: i,j - integer :: ispin,jspin,kspin - integer :: orb_i, hole_particle_i,spin_exc_i - integer :: orb_j, hole_particle_j,spin_exc_j - integer :: orb_k, hole_particle_k,spin_exc_k - double precision :: norm_out(N_states_diag) - integer(bit_kind), allocatable :: psi_in_out(:,:,:) - double precision, allocatable :: psi_in_out_coef(:,:) - use bitmasks - allocate (psi_in_out(N_int,2,n_det),psi_in_out_coef(n_det,N_states_diag)) - - integer :: iorb,jorb - integer :: korb - integer :: state_target - double precision :: energies(n_states_diag) - do iorb = 1,n_act_orb - do ispin = 1,2 - orb_i = list_act(iorb) - hole_particle_i = -1 - spin_exc_i = ispin - do jorb = 1, n_act_orb - do jspin = 1,2 - orb_j = list_act(jorb) - hole_particle_j = -1 - spin_exc_j = jspin - do korb = 1, n_act_orb - do kspin = 1,2 - orb_k = list_act(korb) - hole_particle_k = -1 - spin_exc_k = kspin - do i = 1, n_det - do j = 1, n_states_diag - psi_in_out_coef(i,j) = psi_coef(i,j) - enddo - do j = 1, N_int - psi_in_out(j,1,i) = psi_active(j,1,i) - psi_in_out(j,2,i) = psi_active(j,2,i) - enddo - enddo - do state_target = 1, N_states - call apply_exc_to_psi(orb_i,hole_particle_i,spin_exc_i, & - norm_out,psi_in_out,psi_in_out_coef, n_det,n_det,n_det,N_states_diag) - call apply_exc_to_psi(orb_j,hole_particle_j,spin_exc_j, & - norm_out,psi_in_out,psi_in_out_coef, n_det,n_det,n_det,N_states_diag) - call apply_exc_to_psi(orb_k,hole_particle_k,spin_exc_k, & - norm_out,psi_in_out,psi_in_out_coef, n_det,n_det,n_det,N_states_diag) - call u0_H_dyall_u0(energies,psi_in_out,psi_in_out_coef,n_det,n_det,n_det,N_states_diag,state_target) - three_anhil(iorb,jorb,korb,ispin,jspin,kspin,state_target) = energy_cas_dyall(state_target) - energies(state_target) - enddo - enddo - enddo - enddo - enddo - enddo - enddo - deallocate(psi_in_out,psi_in_out_coef) - -END_PROVIDER - - - - BEGIN_PROVIDER [ double precision, one_anhil_one_creat_inact_virt, (n_inact_orb,n_virt_orb,N_States)] -&BEGIN_PROVIDER [ double precision, one_anhil_one_creat_inact_virt_norm, (n_inact_orb,n_virt_orb,N_States,2)] - implicit none - integer :: i,vorb,j - integer :: ispin,jspin - integer :: orb_i, hole_particle_i - integer :: orb_v - double precision :: norm_out(N_states_diag) - integer(bit_kind), allocatable :: psi_in_out(:,:,:) - double precision, allocatable :: psi_in_out_coef(:,:) - use bitmasks - allocate (psi_in_out(N_int,2,n_det),psi_in_out_coef(n_det,N_states_diag)) - - integer :: iorb,jorb,i_ok - integer :: state_target - double precision :: energies(n_states_diag) - double precision :: hij - double precision :: norm(N_states,2),norm_no_inv(N_states,2),norm_bis(N_states,2) - double precision :: energies_alpha_beta(N_states,2) - - - double precision :: thresh_norm - - thresh_norm = 1.d-10 - - - - do vorb = 1,n_virt_orb - orb_v = list_virt(vorb) - do iorb = 1, n_inact_orb - orb_i = list_inact(iorb) - norm = 0.d0 - norm_bis = 0.d0 - do ispin = 1,2 - do state_target =1 , N_states - one_anhil_one_creat_inact_virt_norm(iorb,vorb,state_target,ispin) = 0.d0 - enddo - do i = 1, n_det - do j = 1, N_int - psi_in_out(j,1,i) = psi_det(j,1,i) - psi_in_out(j,2,i) = psi_det(j,2,i) - enddo - call do_mono_excitation(psi_in_out(1,1,i),orb_i,orb_v,ispin,i_ok) - if(i_ok.ne.1)then - print*, orb_i,orb_v - call debug_det(psi_in_out,N_int) - print*, 'pb, i_ok ne 0 !!!' - endif - call i_H_j(psi_in_out(1,1,i),psi_det(1,1,i),N_int,hij) - do j = 1, n_states - double precision :: coef,contrib - coef = psi_coef(i,j) !* psi_coef(i,j) - psi_in_out_coef(i,j) = sign(coef,psi_coef(i,j)) * hij - norm(j,ispin) += psi_in_out_coef(i,j) * psi_in_out_coef(i,j) - enddo - enddo - do j = 1, N_states - if (dabs(norm(j,ispin)) .le. thresh_norm)then - norm(j,ispin) = 0.d0 - norm_no_inv(j,ispin) = norm(j,ispin) - one_anhil_one_creat_inact_virt_norm(iorb,vorb,j,ispin) = 0.d0 - else - norm_no_inv(j,ispin) = norm(j,ispin) - one_anhil_one_creat_inact_virt_norm(iorb,vorb,j,ispin) = 1.d0 / norm(j,ispin) - norm(j,ispin) = 1.d0/dsqrt(norm(j,ispin)) - endif - enddo - do i = 1, N_det - do j = 1, N_states - psi_in_out_coef(i,j) = psi_in_out_coef(i,j) * norm(j,ispin) - norm_bis(j,ispin) += psi_in_out_coef(i,j) * psi_in_out_coef(i,j) - enddo - do j = 1, N_int - psi_in_out(j,1,i) = psi_active(j,1,i) - psi_in_out(j,2,i) = psi_active(j,2,i) - enddo - enddo - do state_target = 1, N_states - energies_alpha_beta(state_target, ispin) = - mo_bielec_integral_jj_exchange(orb_i,orb_v) -! energies_alpha_beta(state_target, ispin) = 0.d0 - if(norm(state_target,ispin) .ne. 0.d0 .and. dabs(norm_no_inv(state_target,ispin)) .gt. thresh_norm)then - call u0_H_dyall_u0(energies,psi_in_out,psi_in_out_coef,n_det,n_det,n_det,N_states_diag,state_target) - energies_alpha_beta(state_target, ispin) += energies(state_target) - endif - enddo - enddo ! ispin - do state_target = 1, N_states - if((norm_no_inv(state_target,1) + norm_no_inv(state_target,2)) .ne. 0.d0)then -! one_anhil_one_creat_inact_virt(iorb,vorb,state_target) = 0.5d0 * & -! ( energy_cas_dyall(state_target) - energies_alpha_beta(state_target,1) + & -! energy_cas_dyall(state_target) - energies_alpha_beta(state_target,2) ) -! print*, energies_alpha_beta(state_target,1) , energies_alpha_beta(state_target,2) -! print*, norm_bis(state_target,1) , norm_bis(state_target,2) - one_anhil_one_creat_inact_virt(iorb,vorb,state_target) = energy_cas_dyall(state_target) - & - ( energies_alpha_beta(state_target,1) + energies_alpha_beta(state_target,2) ) & - /( norm_bis(state_target,1) + norm_bis(state_target,2) ) - else - one_anhil_one_creat_inact_virt(iorb,vorb,state_target) = 0.d0 - endif - enddo - enddo - enddo - deallocate(psi_in_out,psi_in_out_coef) - -END_PROVIDER - - -BEGIN_PROVIDER [ double precision, one_anhil_inact, (n_inact_orb,n_act_orb,N_States)] - implicit none - integer :: i,iorb,j - integer :: ispin,jspin - integer :: orb_i, hole_particle_i - double precision :: norm_out(N_states_diag) - integer(bit_kind), allocatable :: psi_in_out(:,:,:) - double precision, allocatable :: psi_in_out_coef(:,:) - use bitmasks - allocate (psi_in_out(N_int,2,n_det),psi_in_out_coef(n_det,N_states_diag)) - - integer :: jorb,i_ok,aorb,orb_a - integer :: state_target - double precision :: energies(n_states_diag) - double precision :: hij - double precision :: norm(N_states,2),norm_no_inv(N_states,2) - double precision :: energies_alpha_beta(N_states,2) - double precision :: norm_alpha_beta(N_states,2) - - double precision :: thresh_norm - - thresh_norm = 1.d-10 - - do aorb = 1,n_act_orb - orb_a = list_act(aorb) - do iorb = 1, n_inact_orb - orb_i = list_inact(iorb) - do state_target = 1, N_states - one_anhil_inact(iorb,aorb,state_target) = 0.d0 - enddo - norm_alpha_beta = 0.d0 - norm = 0.d0 - norm_bis = 0.d0 - do ispin = 1,2 - do i = 1, n_det - do j = 1, N_int - psi_in_out(j,1,i) = psi_det(j,1,i) - psi_in_out(j,2,i) = psi_det(j,2,i) - enddo - call do_mono_excitation(psi_in_out(1,1,i),orb_i,orb_a,ispin,i_ok) - if(i_ok.ne.1)then - do j = 1, n_states - psi_in_out_coef(i,j) = 0.d0 - enddo - else - call i_H_j(psi_in_out(1,1,i),psi_det(1,1,i),N_int,hij) - do j = 1, n_states - double precision :: coef,contrib - coef = psi_coef(i,j) !* psi_coef(i,j) - psi_in_out_coef(i,j) = sign(coef,psi_coef(i,j)) * hij - norm(j,ispin) += psi_in_out_coef(i,j) * psi_in_out_coef(i,j) - enddo - endif - enddo - do j = 1, N_states - if (dabs(norm(j,ispin)) .le. thresh_norm)then - norm(j,ispin) = 0.d0 - norm_no_inv(j,ispin) = norm(j,ispin) - else - norm_no_inv(j,ispin) = norm(j,ispin) - norm(j,ispin) = 1.d0/dsqrt(norm(j,ispin)) - endif - enddo - double precision :: norm_bis(N_states,2) - do i = 1, N_det - do j = 1, N_states - psi_in_out_coef(i,j) = psi_in_out_coef(i,j) * norm(j,ispin) - norm_bis(j,ispin) += psi_in_out_coef(i,j)* psi_in_out_coef(i,j) - enddo - do j = 1, N_int - psi_in_out(j,1,i) = iand(psi_in_out(j,1,i),cas_bitmask(j,1,1)) - psi_in_out(j,2,i) = iand(psi_in_out(j,2,i),cas_bitmask(j,1,1)) - enddo - enddo - do state_target = 1, N_states - energies_alpha_beta(state_target, ispin) = 0.d0 - if(norm(state_target,ispin) .ne. 0.d0 .and. dabs(norm_no_inv(state_target,ispin)) .gt. thresh_norm)then - call u0_H_dyall_u0(energies,psi_in_out,psi_in_out_coef,n_det,n_det,n_det,N_states_diag,state_target) - energies_alpha_beta(state_target, ispin) += energies(state_target) - endif - enddo - enddo ! ispin - do state_target = 1, N_states - if((norm_no_inv(state_target,1) + norm_no_inv(state_target,2)) .ne. 0.d0)then - one_anhil_inact(iorb,aorb,state_target) = energy_cas_dyall(state_target) - & - ( energies_alpha_beta(state_target,1) + energies_alpha_beta(state_target,2) ) & - /( norm_bis(state_target,1) + norm_bis(state_target,2) ) - else - one_anhil_inact(iorb,aorb,state_target) = 0.d0 - endif -! print*, '********' -! print*, energies_alpha_beta(state_target,1) , energies_alpha_beta(state_target,2) -! print*, norm_bis(state_target,1) , norm_bis(state_target,2) -! print*, one_anhil_inact(iorb,aorb,state_target) -! print*, one_creat(aorb,1,state_target) - enddo - enddo - enddo - deallocate(psi_in_out,psi_in_out_coef) -END_PROVIDER - - -BEGIN_PROVIDER [ double precision, one_creat_virt, (n_act_orb,n_virt_orb,N_States)] - implicit none - integer :: i,vorb,j - integer :: ispin,jspin - integer :: orb_i, hole_particle_i - integer :: orb_v - double precision :: norm_out(N_states_diag) - integer(bit_kind), allocatable :: psi_in_out(:,:,:) - double precision, allocatable :: psi_in_out_coef(:,:) - use bitmasks - allocate (psi_in_out(N_int,2,n_det),psi_in_out_coef(n_det,N_states_diag)) - - integer :: iorb,jorb,i_ok,aorb,orb_a - integer :: state_target - double precision :: energies(n_states_diag) - double precision :: hij - double precision :: norm(N_states,2),norm_no_inv(N_states,2) - double precision :: energies_alpha_beta(N_states,2) - double precision :: norm_alpha_beta(N_states,2) - - double precision :: thresh_norm - - thresh_norm = 1.d-10 - - do aorb = 1,n_act_orb - orb_a = list_act(aorb) - do vorb = 1, n_virt_orb - orb_v = list_virt(vorb) - do state_target = 1, N_states - one_creat_virt(aorb,vorb,state_target) = 0.d0 - enddo - norm_alpha_beta = 0.d0 - norm = 0.d0 - norm_bis = 0.d0 - do ispin = 1,2 - do i = 1, n_det - do j = 1, N_int - psi_in_out(j,1,i) = psi_det(j,1,i) - psi_in_out(j,2,i) = psi_det(j,2,i) - enddo - call do_mono_excitation(psi_in_out(1,1,i),orb_a,orb_v,ispin,i_ok) - if(i_ok.ne.1)then - do j = 1, n_states - psi_in_out_coef(i,j) = 0.d0 - enddo - else - call i_H_j(psi_in_out(1,1,i),psi_det(1,1,i),N_int,hij) - do j = 1, n_states - double precision :: coef,contrib - coef = psi_coef(i,j) !* psi_coef(i,j) - psi_in_out_coef(i,j) = sign(coef,psi_coef(i,j)) * hij - norm(j,ispin) += psi_in_out_coef(i,j) * psi_in_out_coef(i,j) - enddo - endif - enddo - do j = 1, N_states - if (dabs(norm(j,ispin)) .le. thresh_norm)then - norm(j,ispin) = 0.d0 - norm_no_inv(j,ispin) = norm(j,ispin) - else - norm_no_inv(j,ispin) = norm(j,ispin) - norm(j,ispin) = 1.d0/dsqrt(norm(j,ispin)) - endif - enddo - double precision :: norm_bis(N_states,2) - do i = 1, N_det - do j = 1, N_states - psi_in_out_coef(i,j) = psi_in_out_coef(i,j) * norm(j,ispin) - norm_bis(j,ispin) += psi_in_out_coef(i,j)* psi_in_out_coef(i,j) - enddo - do j = 1, N_int - psi_in_out(j,1,i) = iand(psi_in_out(j,1,i),cas_bitmask(j,1,1)) - psi_in_out(j,2,i) = iand(psi_in_out(j,2,i),cas_bitmask(j,1,1)) - enddo - enddo - do state_target = 1, N_states - energies_alpha_beta(state_target, ispin) = 0.d0 - if(norm(state_target,ispin) .ne. 0.d0 .and. dabs(norm_no_inv(state_target,ispin)) .gt. thresh_norm)then - call u0_H_dyall_u0(energies,psi_in_out,psi_in_out_coef,n_det,n_det,n_det,N_states_diag,state_target) -! print*, energies(state_target) - energies_alpha_beta(state_target, ispin) += energies(state_target) - endif - enddo - enddo ! ispin - do state_target = 1, N_states - if((norm_no_inv(state_target,1) + norm_no_inv(state_target,2)) .ne. 0.d0)then - one_creat_virt(aorb,vorb,state_target) = energy_cas_dyall(state_target) - & - ( energies_alpha_beta(state_target,1) + energies_alpha_beta(state_target,2) ) & - /( norm_bis(state_target,1) + norm_bis(state_target,2) ) - else - one_creat_virt(aorb,vorb,state_target) = 0.d0 - endif -! print*, '********' -! print*, energies_alpha_beta(state_target,1) , energies_alpha_beta(state_target,2) -! print*, norm_bis(state_target,1) , norm_bis(state_target,2) -! print*, one_creat_virt(aorb,vorb,state_target) -! print*, one_anhil(aorb,1,state_target) - enddo - enddo - enddo - deallocate(psi_in_out,psi_in_out_coef) - -END_PROVIDER - - - BEGIN_PROVIDER [ double precision, one_anhil_one_creat_inact_virt_bis, (n_inact_orb,n_virt_orb,N_det,N_States)] -&BEGIN_PROVIDER [ double precision, corr_e_from_1h1p, (N_States)] - implicit none - integer :: i,vorb,j - integer :: ispin,jspin - integer :: orb_i, hole_particle_i - integer :: orb_v - double precision :: norm_out(N_states_diag),diag_elem(N_det),interact_psi0(N_det) - double precision :: delta_e_inact_virt(N_states) - integer(bit_kind), allocatable :: psi_in_out(:,:,:) - double precision, allocatable :: psi_in_out_coef(:,:) - double precision, allocatable :: H_matrix(:,:),eigenvectors(:,:),eigenvalues(:) - use bitmasks - allocate (psi_in_out(N_int,2,n_det),psi_in_out_coef(n_det,N_states_diag),H_matrix(N_det+1,N_det+1)) - allocate (eigenvectors(size(H_matrix,1),N_det+1)) - allocate (eigenvalues(N_det+1)) - - integer :: iorb,jorb,i_ok - integer :: state_target - double precision :: energies(n_states_diag) - double precision :: hij - double precision :: energies_alpha_beta(N_states,2) - - - double precision :: accu(N_states),norm - double precision :: amplitudes_alpha_beta(N_det,2) - double precision :: delta_e_alpha_beta(N_det,2) - - corr_e_from_1h1p = 0.d0 - do vorb = 1,n_virt_orb - orb_v = list_virt(vorb) - do iorb = 1, n_inact_orb - orb_i = list_inact(iorb) -! print*, '---------------------------------------------------------------------------' - do j = 1, N_states - delta_e_inact_virt(j) = fock_core_inactive_total_spin_trace(orb_i,j) & - - fock_virt_total_spin_trace(orb_v,j) - enddo - do ispin = 1,2 - do i = 1, n_det - do j = 1, N_int - psi_in_out(j,1,i) = psi_det(j,1,i) - psi_in_out(j,2,i) = psi_det(j,2,i) - enddo - call do_mono_excitation(psi_in_out(1,1,i),orb_i,orb_v,ispin,i_ok) - if(i_ok.ne.1)then - print*, orb_i,orb_v - call debug_det(psi_in_out,N_int) - print*, 'pb, i_ok ne 0 !!!' - endif - interact_psi0(i) = 0.d0 - do j = 1 , N_det - call i_H_j(psi_in_out(1,1,i),psi_det(1,1,j),N_int,hij) - interact_psi0(i) += hij * psi_coef(j,1) - enddo - do j = 1, N_int - psi_in_out(j,1,i) = psi_active(j,1,i) - psi_in_out(j,2,i) = psi_active(j,2,i) - enddo - call i_H_j_dyall(psi_active(1,1,i),psi_active(1,1,i),N_int,hij) - diag_elem(i) = hij - enddo - do state_target = 1, N_states - ! Building the Hamiltonian matrix - H_matrix(1,1) = energy_cas_dyall(state_target) - do i = 1, N_det - ! interaction with psi0 - H_matrix(1,i+1) = interact_psi0(i)!* psi_coef(i,state_target) - H_matrix(i+1,1) = interact_psi0(i)!* psi_coef(i,state_target) - ! diagonal elements - H_matrix(i+1,i+1) = diag_elem(i) - delta_e_inact_virt(state_target) -! print*, 'H_matrix(i+1,i+1)',H_matrix(i+1,i+1) - do j = i+1, N_det - call i_H_j_dyall(psi_in_out(1,1,i),psi_in_out(1,1,j),N_int,hij) - H_matrix(i+1,j+1) = hij !0.d0 ! - H_matrix(j+1,i+1) = hij !0.d0 ! - enddo - enddo - print*, '***' - do i = 1, N_det+1 - write(*,'(100(F16.10,X))')H_matrix(i,:) - enddo - call lapack_diag(eigenvalues,eigenvectors,H_matrix,size(H_matrix,1),N_det+1) - corr_e_from_1h1p(state_target) += eigenvalues(1) - energy_cas_dyall(state_target) - norm = 0.d0 - do i = 1, N_det - psi_in_out_coef(i,state_target) = eigenvectors(i+1,1)/eigenvectors(1,1) -!! if(dabs(psi_coef(i,state_target)*) .gt. 1.d-8)then - if(dabs(psi_in_out_coef(i,state_target)) .gt. 1.d-8)then -! if(dabs(interact_psi0(i)) .gt. 1.d-8)then - delta_e_alpha_beta(i,ispin) = H_matrix(1,i+1) / psi_in_out_coef(i,state_target) -! delta_e_alpha_beta(i,ispin) = interact_psi0(i) / psi_in_out_coef(i,state_target) - amplitudes_alpha_beta(i,ispin) = psi_in_out_coef(i,state_target) / psi_coef(i,state_target) - else - amplitudes_alpha_beta(i,ispin) = 0.d0 - delta_e_alpha_beta(i,ispin) = delta_e_inact_virt(state_target) - endif -!! one_anhil_one_creat_inact_virt_bis(iorb,vorb,i,ispin,state_target) = amplitudes_alpha_beta(i,ispin) - norm += psi_in_out_coef(i,state_target) * psi_in_out_coef(i,state_target) - enddo - print*, 'Coef ' - write(*,'(100(X,F16.10))')psi_coef(1:N_det,state_target) - write(*,'(100(X,F16.10))')psi_in_out_coef(:,state_target) - double precision :: coef_tmp(N_det) - do i = 1, N_det - coef_tmp(i) = psi_coef(i,1) * interact_psi0(i) / delta_e_alpha_beta(i,ispin) - enddo - write(*,'(100(X,F16.10))')coef_tmp(:) - print*, 'naked interactions' - write(*,'(100(X,F16.10))')interact_psi0(:) - print*, '' - - print*, 'norm ',norm - norm = 1.d0/(norm) - accu(state_target) = 0.d0 - do i = 1, N_det - accu(state_target) += psi_in_out_coef(i,state_target) * psi_in_out_coef(i,state_target) * H_matrix(i+1,i+1) - do j = i+1, N_det - accu(state_target) += 2.d0 * psi_in_out_coef(i,state_target) * psi_in_out_coef(j,state_target) * H_matrix(i+1,j+1) - enddo - enddo - accu(state_target) = accu(state_target) * norm - print*, delta_e_inact_virt(state_target) - print*, eigenvalues(1),accu(state_target),eigenvectors(1,1) - print*, energy_cas_dyall(state_target) - accu(state_target), one_anhil_one_creat_inact_virt(iorb,vorb,state_target) + delta_e_inact_virt(state_target) - - enddo - enddo ! ispin - do state_target = 1, N_states - do i = 1, N_det - one_anhil_one_creat_inact_virt_bis(iorb,vorb,i,state_target) = 0.5d0 * & - ( delta_e_alpha_beta(i,1) + delta_e_alpha_beta(i,1)) - enddo - enddo - print*, '***' - write(*,'(100(X,F16.10))') - write(*,'(100(X,F16.10))')delta_e_alpha_beta(:,2) - ! write(*,'(100(X,F16.10))')one_anhil_one_creat_inact_virt_bis(iorb,vorb,:,1,:) - ! write(*,'(100(X,F16.10))')one_anhil_one_creat_inact_virt_bis(iorb,vorb,:,2,:) - print*, '---------------------------------------------------------------------------' - enddo - enddo - deallocate(psi_in_out,psi_in_out_coef,H_matrix,eigenvectors,eigenvalues) - print*, 'corr_e_from_1h1p,',corr_e_from_1h1p(:) - -END_PROVIDER - -subroutine give_singles_and_partial_doubles_1h1p_contrib(matrix_1h1p,e_corr_from_1h1p_singles) - implicit none - double precision , intent(inout) :: matrix_1h1p(N_det,N_det,N_states) - double precision , intent(out) :: e_corr_from_1h1p_singles(N_states) - integer :: i,vorb,j - integer :: ispin,jspin - integer :: orb_i, hole_particle_i - integer :: orb_v - double precision :: norm_out(N_states_diag),diag_elem(N_det),interact_psi0(N_det) - double precision :: delta_e_inact_virt(N_states) - integer(bit_kind), allocatable :: psi_in_out(:,:,:) - double precision, allocatable :: psi_in_out_coef(:,:) - double precision, allocatable :: H_matrix(:,:),eigenvectors(:,:),eigenvalues(:),interact_cas(:,:) - double precision, allocatable :: delta_e_det(:,:) - use bitmasks - allocate (psi_in_out(N_int,2,n_det),psi_in_out_coef(n_det,N_states_diag),H_matrix(N_det+1,N_det+1)) - allocate (eigenvectors(size(H_matrix,1),N_det+1)) - allocate (eigenvalues(N_det+1),interact_cas(N_det,N_det)) - allocate (delta_e_det(N_det,N_det)) - - integer :: iorb,jorb,i_ok - integer :: state_target - double precision :: energies(n_states_diag) - double precision :: hij - double precision :: energies_alpha_beta(N_states,2) - double precision :: lamda_pt2(N_det) - - - double precision :: accu(N_states),norm - double precision :: amplitudes_alpha_beta(N_det,2) - double precision :: delta_e_alpha_beta(N_det,2) - double precision :: coef_array(N_states) - double precision :: coef_perturb(N_det) - double precision :: coef_perturb_bis(N_det) - - do vorb = 1,n_virt_orb - orb_v = list_virt(vorb) - do iorb = 1, n_inact_orb - orb_i = list_inact(iorb) - do j = 1, N_states - delta_e_inact_virt(j) = fock_core_inactive_total_spin_trace(orb_i,j) & - - fock_virt_total_spin_trace(orb_v,j) - enddo - do ispin = 1,2 - do i = 1, n_det - do j = 1, N_int - psi_in_out(j,1,i) = psi_det(j,1,i) - psi_in_out(j,2,i) = psi_det(j,2,i) - enddo - call do_mono_excitation(psi_in_out(1,1,i),orb_i,orb_v,ispin,i_ok) - if(i_ok.ne.1)then - print*, orb_i,orb_v - call debug_det(psi_in_out,N_int) - print*, 'pb, i_ok ne 0 !!!' - endif - interact_psi0(i) = 0.d0 - do j = 1 , N_det - call i_H_j(psi_in_out(1,1,i),psi_det(1,1,j),N_int,hij) - call get_delta_e_dyall(psi_det(1,1,j),psi_in_out(1,1,i),coef_array,hij,delta_e_det(i,j)) - interact_cas(i,j) = hij - interact_psi0(i) += hij * psi_coef(j,1) - enddo - do j = 1, N_int - psi_in_out(j,1,i) = psi_active(j,1,i) - psi_in_out(j,2,i) = psi_active(j,2,i) - enddo - call i_H_j_dyall(psi_active(1,1,i),psi_active(1,1,i),N_int,hij) - diag_elem(i) = hij - enddo - do state_target = 1, N_states - ! Building the Hamiltonian matrix - H_matrix(1,1) = energy_cas_dyall(state_target) - do i = 1, N_det - ! interaction with psi0 - H_matrix(1,i+1) = interact_psi0(i)!* psi_coef(i,state_target) - H_matrix(i+1,1) = interact_psi0(i)!* psi_coef(i,state_target) - ! diagonal elements - H_matrix(i+1,i+1) = diag_elem(i) - delta_e_inact_virt(state_target) -! print*, 'H_matrix(i+1,i+1)',H_matrix(i+1,i+1) - do j = i+1, N_det - call i_H_j_dyall(psi_in_out(1,1,i),psi_in_out(1,1,j),N_int,hij) - H_matrix(i+1,j+1) = hij !0.d0 ! - H_matrix(j+1,i+1) = hij !0.d0 ! - enddo - enddo - call lapack_diag(eigenvalues,eigenvectors,H_matrix,size(H_matrix,1),N_det+1) - e_corr_from_1h1p_singles(state_target) += eigenvalues(1) - energy_cas_dyall(state_target) - - do i = 1, N_det - psi_in_out_coef(i,state_target) = eigenvectors(i+1,1)/eigenvectors(1,1) - coef_perturb(i) = 0.d0 - do j = 1, N_det - coef_perturb(i) += psi_coef(j,state_target) * interact_cas(i,j) *1.d0/delta_e_det(i,j) - enddo - coef_perturb_bis(i) = interact_psi0(i) / (eigenvalues(1) - H_matrix(i+1,i+1)) - if(dabs(interact_psi0(i)) .gt. 1.d-12)then - lamda_pt2(i) = psi_in_out_coef(i,state_target) / interact_psi0(i) - else - lamda_pt2(i) =energy_cas_dyall(state_target) - H_matrix(i+1,i+1) - endif - enddo - if(dabs(eigenvalues(1) - energy_cas_dyall(state_target)).gt.1.d-10)then - print*, '' - do i = 1, N_det+1 - write(*,'(100(F16.10))') H_matrix(i,:) - enddo - accu = 0.d0 - do i = 1, N_det - accu(state_target) += psi_in_out_coef(i,state_target) * interact_psi0(i) - enddo - print*, '' - print*, 'e corr diagonal ',accu(state_target) - accu = 0.d0 - do i = 1, N_det - accu(state_target) += coef_perturb(i) * interact_psi0(i) - enddo - print*, 'e corr perturb ',accu(state_target) - accu = 0.d0 - do i = 1, N_det - accu(state_target) += coef_perturb_bis(i) * interact_psi0(i) - enddo - print*, 'e corr perturb EN',accu(state_target) - print*, '' - print*, 'coef diagonalized' - write(*,'(100(F16.10,X))')psi_in_out_coef(:,state_target) - print*, 'coef_perturb' - write(*,'(100(F16.10,X))')coef_perturb(:) - print*, 'coef_perturb EN' - write(*,'(100(F16.10,X))')coef_perturb_bis(:) - endif - integer :: k - do k = 1, N_det - do i = 1, N_det - matrix_1h1p(i,i,state_target) += interact_cas(k,i) * interact_cas(k,i) * lamda_pt2(k) - do j = i+1, N_det - matrix_1h1p(i,j,state_target) += interact_cas(k,i) * interact_cas(k,j) * lamda_pt2(k) - matrix_1h1p(j,i,state_target) += interact_cas(k,i) * interact_cas(k,j) * lamda_pt2(k) - enddo - enddo - enddo - enddo - enddo ! ispin - enddo - enddo - deallocate(psi_in_out,psi_in_out_coef,H_matrix,eigenvectors,eigenvalues,interact_cas) - deallocate(delta_e_det) -end diff --git a/plugins/MRPT_Utils/excitations_cas.irp.f b/plugins/MRPT_Utils/excitations_cas.irp.f deleted file mode 100644 index 10cfe7c0..00000000 --- a/plugins/MRPT_Utils/excitations_cas.irp.f +++ /dev/null @@ -1,708 +0,0 @@ -subroutine apply_exc_to_psi(orb,hole_particle,spin_exc, & - norm_out,psi_in_out,psi_in_out_coef, ndet,dim_psi_in,dim_psi_coef,N_states_in) - use bitmasks - implicit none - integer, intent(in) :: orb, hole_particle,spin_exc,N_states_in,ndet,dim_psi_in,dim_psi_coef - double precision, intent(out) :: norm_out(N_states_in) - integer(bit_kind), intent(inout) :: psi_in_out(N_int,2,dim_psi_in) - double precision, intent(inout) :: psi_in_out_coef(dim_psi_coef,N_states_in) - BEGIN_DOC - ! apply a contracted excitation to psi_in_out whose coefficients - ! are psi_in_out_coef - ! hole_particle = 1 ===> creation of an electron in psi_in_out - ! = -1 ===> annhilation of an electron in psi_in_out - ! orb ===> is the index of orbital where you want wether to create or - ! annhilate an electron - ! spin_exc ===> is the spin of the electron (1 == alpha) (2 == beta) - ! the wave function gets out normalized to unity - ! - ! norm_out is the sum of the squared of the coefficients - ! on which the excitation has been possible - END_DOC - - integer :: elec_num_tab_local(2) - integer :: i,j,accu_elec,k - integer :: det_tmp(N_int), det_tmp_bis(N_int) - double precision :: phase - double precision :: norm_factor - - elec_num_tab_local = 0 - do i = 1, ndet - if( psi_in_out_coef (i,1) .ne. 0.d0)then - do j = 1, N_int - elec_num_tab_local(1) += popcnt(psi_in_out(j,1,i)) - elec_num_tab_local(2) += popcnt(psi_in_out(j,2,i)) - enddo - exit - endif - enddo - if(hole_particle == 1)then - do i = 1, ndet - call set_bit_to_integer(orb,psi_in_out(1,spin_exc,i),N_int) - accu_elec = 0 - do j = 1, N_int - accu_elec += popcnt(psi_in_out(j,spin_exc,i)) - enddo - if(accu_elec .ne. elec_num_tab_local(spin_exc)+1)then - do j = 1, N_int - psi_in_out(j,1,i) = 0_bit_kind - psi_in_out(j,2,i) = 0_bit_kind - enddo - do j = 1, N_states_in - psi_in_out_coef(i,j) = 0.d0 - enddo - endif - phase = 1.d0 - do k = 1, orb - do j = 1, N_int - det_tmp(j) = 0_bit_kind - enddo - call set_bit_to_integer(k,det_tmp,N_int) - accu_elec = 0 - do j = 1, N_int - det_tmp_bis(j) = iand(det_tmp(j),(psi_in_out(j,spin_exc,i))) - accu_elec += popcnt(det_tmp_bis(j)) - enddo - if(accu_elec == 1)then - phase = -phase - endif - enddo - do j = 1, N_states_in - psi_in_out_coef(i,j) = psi_in_out_coef(i,j) * phase - enddo - enddo - - else if (hole_particle == -1)then - - do i = 1, ndet - call clear_bit_to_integer(orb,psi_in_out(1,spin_exc,i),N_int) - accu_elec = 0 - do j = 1, N_int - accu_elec += popcnt(psi_in_out(j,spin_exc,i)) - enddo - if(accu_elec .ne. elec_num_tab_local(spin_exc)-1)then - do j = 1, N_int - psi_in_out(j,1,i) = 0_bit_kind - psi_in_out(j,2,i) = 0_bit_kind - enddo - do j = 1, N_states_in - psi_in_out_coef(i,j) = 0.d0 - enddo - endif - - phase = 1.d0 - do k = 1, orb-1 - do j = 1, N_int - det_tmp(j) = 0_bit_kind - enddo - call set_bit_to_integer(k,det_tmp,N_int) - accu_elec = 0 - do j = 1, N_int - det_tmp_bis(j) = iand(det_tmp(j),(psi_in_out(j,spin_exc,i))) - accu_elec += popcnt(det_tmp_bis(j)) - enddo - if(accu_elec == 1)then - phase = -phase - endif - enddo - do j = 1, N_states_in - psi_in_out_coef(i,j) = psi_in_out_coef(i,j) * phase - enddo - enddo - endif - - - norm_out = 0.d0 - do j = 1, N_states_in - do i = 1, ndet - norm_out(j) += psi_in_out_coef(i,j) * psi_in_out_coef(i,j) - enddo - if(norm_out(j).le.1.d-10)then - norm_factor = 0.d0 - else - norm_factor = 1.d0/(dsqrt(norm_out(j))) - endif - do i = 1, ndet - psi_in_out_coef(i,j) = psi_in_out_coef(i,j) * norm_factor - enddo - enddo -end - - -double precision function diag_H_mat_elem_no_elec_check(det_in,Nint) - implicit none - BEGIN_DOC - ! Computes - END_DOC - integer,intent(in) :: Nint - integer(bit_kind),intent(in) :: det_in(Nint,2) - - integer :: i, j, iorb, jorb - integer :: occ(Nint*bit_kind_size,2) - integer :: elec_num_tab_local(2) - - double precision :: core_act - double precision :: alpha_alpha - double precision :: alpha_beta - double precision :: beta_beta - double precision :: mono_elec - core_act = 0.d0 - alpha_alpha = 0.d0 - alpha_beta = 0.d0 - beta_beta = 0.d0 - mono_elec = 0.d0 - - diag_H_mat_elem_no_elec_check = 0.d0 - call bitstring_to_list(det_in(1,1), occ(1,1), elec_num_tab_local(1), N_int) - call bitstring_to_list(det_in(1,2), occ(1,2), elec_num_tab_local(2), N_int) - ! alpha - alpha -! print*, 'elec_num_tab_local(1)',elec_num_tab_local(1) -! print*, 'elec_num_tab_local(2)',elec_num_tab_local(2) - do i = 1, elec_num_tab_local(1) - iorb = occ(i,1) - diag_H_mat_elem_no_elec_check += mo_mono_elec_integral(iorb,iorb) - mono_elec += mo_mono_elec_integral(iorb,iorb) - do j = i+1, elec_num_tab_local(1) - jorb = occ(j,1) - diag_H_mat_elem_no_elec_check += mo_bielec_integral_jj_anti(jorb,iorb) - alpha_alpha += mo_bielec_integral_jj_anti(jorb,iorb) - enddo - enddo - - ! beta - beta - do i = 1, elec_num_tab_local(2) - iorb = occ(i,2) - diag_H_mat_elem_no_elec_check += mo_mono_elec_integral(iorb,iorb) - mono_elec += mo_mono_elec_integral(iorb,iorb) - do j = i+1, elec_num_tab_local(2) - jorb = occ(j,2) - diag_H_mat_elem_no_elec_check += mo_bielec_integral_jj_anti(jorb,iorb) - beta_beta += mo_bielec_integral_jj_anti(jorb,iorb) - enddo - enddo - - - ! alpha - beta - do i = 1, elec_num_tab_local(2) - iorb = occ(i,2) - do j = 1, elec_num_tab_local(1) - jorb = occ(j,1) - diag_H_mat_elem_no_elec_check += mo_bielec_integral_jj(jorb,iorb) - alpha_beta += mo_bielec_integral_jj(jorb,iorb) - enddo - enddo - - - ! alpha - core-act - do i = 1, elec_num_tab_local(1) - iorb = occ(i,1) - do j = 1, n_core_inact_orb - jorb = list_core_inact(j) - diag_H_mat_elem_no_elec_check += 2.d0 * mo_bielec_integral_jj(jorb,iorb) - mo_bielec_integral_jj_exchange(jorb,iorb) - core_act += 2.d0 * mo_bielec_integral_jj(jorb,iorb) - mo_bielec_integral_jj_exchange(jorb,iorb) - enddo - enddo - - ! beta - core-act - do i = 1, elec_num_tab_local(2) - iorb = occ(i,2) - do j = 1, n_core_inact_orb - jorb = list_core_inact(j) - diag_H_mat_elem_no_elec_check += 2.d0 * mo_bielec_integral_jj(jorb,iorb) - mo_bielec_integral_jj_exchange(jorb,iorb) - core_act += 2.d0 * mo_bielec_integral_jj(jorb,iorb) - mo_bielec_integral_jj_exchange(jorb,iorb) - enddo - enddo -! print*,'core_act = ',core_act -! print*,'alpha_alpha = ',alpha_alpha -! print*,'alpha_beta = ',alpha_beta -! print*,'beta_beta = ',beta_beta -! print*,'mono_elec = ',mono_elec - -! do i = 1, n_core_inact_orb -! iorb = list_core_inact(i) -! diag_H_mat_elem_no_elec_check += 2.d0 * fock_core_inactive_total_spin_trace(iorb,1) -! enddo - - -!!!!!!!!!!!! -return -!!!!!!!!!!!! - - - ! alpha - alpha - do i = 1, n_core_inact_orb - iorb = list_core_inact(i) - diag_H_mat_elem_no_elec_check += 1.d0 * mo_mono_elec_integral(iorb,iorb) - do j = i+1, n_core_inact_orb - jorb = list_core_inact(j) - diag_H_mat_elem_no_elec_check += 1.d0 * mo_bielec_integral_jj(jorb,iorb) - 1.d0 * mo_bielec_integral_jj_exchange(jorb,iorb) - enddo - enddo - - do i = 1, n_core_inact_orb - iorb = list_core_inact(i) - diag_H_mat_elem_no_elec_check += 1.d0 * mo_mono_elec_integral(iorb,iorb) - do j = i+1, n_core_inact_orb - jorb = list_core_inact(j) - diag_H_mat_elem_no_elec_check += 1.d0 * mo_bielec_integral_jj(jorb,iorb) - 1.d0 * mo_bielec_integral_jj_exchange(jorb,iorb) - enddo - enddo - - do i = 1, n_core_inact_orb - iorb = list_core_inact(i) - do j = 1, n_core_inact_orb - jorb = list_core_inact(j) - diag_H_mat_elem_no_elec_check += 1.d0 * mo_bielec_integral_jj(jorb,iorb) - enddo - enddo - -end - -subroutine i_H_j_dyall(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_no_elec_check, 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) - - hij = 0.d0 - !DIR$ FORCEINLINE - call get_excitation_degree(key_i,key_j,degree,Nint) - 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) - do k = 1, n_occ_ab(1) - 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, n_occ_ab(2) - 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, n_occ_ab(1) - hij = hij + mipi(occ(k,1)) - miip(occ(k,1)) - enddo - do k = 1, n_occ_ab(2) - hij = hij + mipi(occ(k,2)) - enddo - - else - ! Mono beta - m = exc(1,1,2) - p = exc(1,2,2) - do k = 1, n_occ_ab(2) - 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, n_occ_ab(1) - 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, n_occ_ab(1) - hij = hij + mipi(occ(k,1)) - enddo - do k = 1, n_occ_ab(2) - hij = hij + mipi(occ(k,2)) - miip(occ(k,2)) - enddo - - endif - hij = phase*(hij + mo_mono_elec_integral(m,p) + fock_operator_active_from_core_inact(m,p) ) - - case (0) - hij = diag_H_mat_elem_no_elec_check(key_i,Nint) - end select -end - - -subroutine u0_H_dyall_u0(energies,psi_in,psi_in_coef,ndet,dim_psi_in,dim_psi_coef,N_states_in,state_target) - use bitmasks - implicit none - integer, intent(in) :: N_states_in,ndet,dim_psi_in,dim_psi_coef,state_target - integer(bit_kind), intent(in) :: psi_in(N_int,2,dim_psi_in) - double precision, intent(in) :: psi_in_coef(dim_psi_coef,N_states_in) - double precision, intent(out) :: energies(N_states_in) - - integer :: i,j - double precision :: hij,accu - energies = 0.d0 - accu = 0.d0 - double precision, allocatable :: psi_coef_tmp(:) - allocate(psi_coef_tmp(ndet)) - - do i = 1, ndet - psi_coef_tmp(i) = psi_in_coef(i,state_target) - enddo - - double precision :: hij_bis - do i = 1, ndet - if(psi_coef_tmp(i)==0.d0)cycle - do j = 1, ndet - if(psi_coef_tmp(j)==0.d0)cycle - call i_H_j_dyall(psi_in(1,1,i),psi_in(1,1,j),N_int,hij) - accu += psi_coef_tmp(i) * psi_coef_tmp(j) * hij - enddo - enddo - energies(state_target) = accu - deallocate(psi_coef_tmp) -end - - -double precision function coulomb_value_no_check(det_in,Nint) - implicit none - BEGIN_DOC - ! Computes - END_DOC - integer,intent(in) :: Nint - integer(bit_kind),intent(in) :: det_in(Nint,2) - - integer :: i, j, iorb, jorb - integer :: occ(Nint*bit_kind_size,2) - integer :: elec_num_tab_local(2) - - double precision :: core_act - double precision :: alpha_alpha - double precision :: alpha_beta - double precision :: beta_beta - double precision :: mono_elec - core_act = 0.d0 - alpha_alpha = 0.d0 - alpha_beta = 0.d0 - beta_beta = 0.d0 - mono_elec = 0.d0 - - coulomb_value_no_check = 0.d0 - call bitstring_to_list(det_in(1,1), occ(1,1), elec_num_tab_local(1), N_int) - call bitstring_to_list(det_in(1,2), occ(1,2), elec_num_tab_local(2), N_int) - ! alpha - alpha - do i = 1, elec_num_tab_local(1) - iorb = occ(i,1) - do j = i+1, elec_num_tab_local(1) - jorb = occ(j,1) - coulomb_value_no_check += mo_bielec_integral_jj_anti(jorb,iorb) - alpha_alpha += mo_bielec_integral_jj_anti(jorb,iorb) - enddo - enddo - - ! beta - beta - do i = 1, elec_num_tab_local(2) - iorb = occ(i,2) - do j = i+1, elec_num_tab_local(2) - jorb = occ(j,2) - coulomb_value_no_check += mo_bielec_integral_jj_anti(jorb,iorb) - beta_beta += mo_bielec_integral_jj_anti(jorb,iorb) - enddo - enddo - - - ! alpha - beta - do i = 1, elec_num_tab_local(2) - iorb = occ(i,2) - do j = 1, elec_num_tab_local(1) - jorb = occ(j,1) - coulomb_value_no_check += mo_bielec_integral_jj(jorb,iorb) - alpha_beta += mo_bielec_integral_jj(jorb,iorb) - enddo - enddo - - -end - -subroutine i_H_j_dyall_no_exchange(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_no_elec_check_no_exchange, phase,phase_2 - integer :: n_occ_ab(2) - logical :: has_mipi(Nint*bit_kind_size) - double precision :: mipi(Nint*bit_kind_size) - PROVIDE mo_bielec_integrals_in_map mo_integrals_map - - ASSERT (Nint > 0) - ASSERT (Nint == N_int) - - hij = 0.d0 - !DIR$ FORCEINLINE - call get_excitation_degree(key_i,key_j,degree,Nint) - 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 - if(exc(1,1,1) == exc(1,2,2) .and. exc(1,2,1) == exc(1,1,2))then - hij = 0.d0 - else - 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) - endif - 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) - 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) - 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) - do k = 1, n_occ_ab(1) - 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, n_occ_ab(2) - 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, n_occ_ab(1) - hij = hij + mipi(occ(k,1)) - enddo - do k = 1, n_occ_ab(2) - hij = hij + mipi(occ(k,2)) - enddo - - else - ! Mono beta - m = exc(1,1,2) - p = exc(1,2,2) - do k = 1, n_occ_ab(2) - 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, n_occ_ab(1) - 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, n_occ_ab(1) - hij = hij + mipi(occ(k,1)) - enddo - do k = 1, n_occ_ab(2) - hij = hij + mipi(occ(k,2)) - enddo - - endif - hij = phase*(hij + mo_mono_elec_integral(m,p) + fock_operator_active_from_core_inact(m,p) ) - - case (0) - hij = diag_H_mat_elem_no_elec_check_no_exchange(key_i,Nint) - end select -end - - -double precision function diag_H_mat_elem_no_elec_check_no_exchange(det_in,Nint) - implicit none - BEGIN_DOC - ! Computes - END_DOC - integer,intent(in) :: Nint - integer(bit_kind),intent(in) :: det_in(Nint,2) - - integer :: i, j, iorb, jorb - integer :: occ(Nint*bit_kind_size,2) - integer :: elec_num_tab_local(2) - - double precision :: core_act_exchange(2) - core_act_exchange = 0.d0 - diag_H_mat_elem_no_elec_check_no_exchange = 0.d0 - call bitstring_to_list(det_in(1,1), occ(1,1), elec_num_tab_local(1), N_int) - call bitstring_to_list(det_in(1,2), occ(1,2), elec_num_tab_local(2), N_int) - ! alpha - alpha - do i = 1, elec_num_tab_local(1) - iorb = occ(i,1) - diag_H_mat_elem_no_elec_check_no_exchange += mo_mono_elec_integral(iorb,iorb) - do j = i+1, elec_num_tab_local(1) - jorb = occ(j,1) - diag_H_mat_elem_no_elec_check_no_exchange += mo_bielec_integral_jj(jorb,iorb) - enddo - enddo - - ! beta - beta - do i = 1, elec_num_tab_local(2) - iorb = occ(i,2) - diag_H_mat_elem_no_elec_check_no_exchange += mo_mono_elec_integral(iorb,iorb) - do j = i+1, elec_num_tab_local(2) - jorb = occ(j,2) - diag_H_mat_elem_no_elec_check_no_exchange += mo_bielec_integral_jj(jorb,iorb) - enddo - enddo - - - ! alpha - beta - do i = 1, elec_num_tab_local(2) - iorb = occ(i,2) - do j = 1, elec_num_tab_local(1) - jorb = occ(j,1) - diag_H_mat_elem_no_elec_check_no_exchange += mo_bielec_integral_jj(jorb,iorb) - enddo - enddo - - - ! alpha - core-act - do i = 1, elec_num_tab_local(1) - iorb = occ(i,1) - do j = 1, n_core_inact_orb - jorb = list_core_inact(j) - diag_H_mat_elem_no_elec_check_no_exchange += 2.d0 * mo_bielec_integral_jj(jorb,iorb) - core_act_exchange(1) += - mo_bielec_integral_jj_exchange(jorb,iorb) - enddo - enddo - - ! beta - core-act - do i = 1, elec_num_tab_local(2) - iorb = occ(i,2) - do j = 1, n_core_inact_orb - jorb = list_core_inact(j) - diag_H_mat_elem_no_elec_check_no_exchange += 2.d0 * mo_bielec_integral_jj(jorb,iorb) - core_act_exchange(2) += - mo_bielec_integral_jj_exchange(jorb,iorb) - enddo - enddo - -end - -subroutine u0_H_dyall_u0_no_exchange(energies,psi_in,psi_in_coef,ndet,dim_psi_in,dim_psi_coef,N_states_in,state_target) - use bitmasks - implicit none - integer, intent(in) :: N_states_in,ndet,dim_psi_in,dim_psi_coef,state_target - integer(bit_kind), intent(in) :: psi_in(N_int,2,dim_psi_in) - double precision, intent(in) :: psi_in_coef(dim_psi_coef,N_states_in) - double precision, intent(out) :: energies(N_states_in) - - integer :: i,j - double precision :: hij,accu - energies = 0.d0 - accu = 0.d0 - double precision, allocatable :: psi_coef_tmp(:) - allocate(psi_coef_tmp(ndet)) - - do i = 1, ndet - psi_coef_tmp(i) = psi_in_coef(i,state_target) - enddo - - double precision :: hij_bis - do i = 1, ndet - if(psi_coef_tmp(i)==0.d0)cycle - do j = 1, ndet - if(psi_coef_tmp(j)==0.d0)cycle - call i_H_j_dyall_no_exchange(psi_in(1,1,i),psi_in(1,1,j),N_int,hij) - accu += psi_coef_tmp(i) * psi_coef_tmp(j) * hij - enddo - enddo - energies(state_target) = accu - deallocate(psi_coef_tmp) -end diff --git a/plugins/MRPT_Utils/ezfio_interface.irp.f b/plugins/MRPT_Utils/ezfio_interface.irp.f deleted file mode 100644 index 6bd8931d..00000000 --- a/plugins/MRPT_Utils/ezfio_interface.irp.f +++ /dev/null @@ -1,23 +0,0 @@ -! DO NOT MODIFY BY HAND -! Created by $QP_ROOT/scripts/ezfio_interface/ei_handler.py -! from file /home/scemama/quantum_package/src/MRPT_Utils/EZFIO.cfg - - -BEGIN_PROVIDER [ logical, do_third_order_1h1p ] - implicit none - BEGIN_DOC -! If true, compute the third order contribution for the 1h1p - END_DOC - - logical :: has - PROVIDE ezfio_filename - - call ezfio_has_mrpt_utils_do_third_order_1h1p(has) - if (has) then - call ezfio_get_mrpt_utils_do_third_order_1h1p(do_third_order_1h1p) - else - print *, 'mrpt_utils/do_third_order_1h1p not found in EZFIO file' - stop 1 - endif - -END_PROVIDER diff --git a/plugins/MRPT_Utils/fock_like_operators.irp.f b/plugins/MRPT_Utils/fock_like_operators.irp.f deleted file mode 100644 index d4ce0661..00000000 --- a/plugins/MRPT_Utils/fock_like_operators.irp.f +++ /dev/null @@ -1,210 +0,0 @@ - BEGIN_PROVIDER [double precision, fock_core_inactive, (mo_tot_num)] - BEGIN_DOC -! inactive part of the fock operator with contributions only from the inactive - END_DOC - implicit none - integer :: i,j - double precision :: accu - - integer :: j_inact_core_orb,i_inact_core_orb - do i = 1, n_core_inact_orb - accu = 0.d0 - i_inact_core_orb = list_core_inact(i) - do j = 1, n_core_inact_orb - j_inact_core_orb = list_core_inact(j) - accu += 2.d0 * mo_bielec_integral_jj(i_inact_core_orb,j_inact_core_orb) & - - mo_bielec_integral_jj_exchange(i_inact_core_orb,j_inact_core_orb) - enddo - fock_core_inactive(i_inact_core_orb) = accu + mo_mono_elec_integral(i_inact_core_orb,i_inact_core_orb) - enddo - END_PROVIDER - - BEGIN_PROVIDER [double precision, fock_virt_from_core_inact, (mo_tot_num)] - BEGIN_DOC -! fock operator for the virtuals that comes from the doubly occupied orbitals - END_DOC - implicit none - integer :: i,j - double precision :: accu - - integer :: j_inact_core_orb,i_virt_orb - do i = 1, n_virt_orb - accu = 0.d0 - i_virt_orb = list_virt(i) - do j = 1, n_core_inact_orb -! do j = 1, elec_alpha_num -! j_inact_core_orb = j - j_inact_core_orb = list_core_inact(j) - accu += 2.d0 * mo_bielec_integral_jj(i_virt_orb,j_inact_core_orb) & - - mo_bielec_integral_jj_exchange(i_virt_orb,j_inact_core_orb) - enddo - fock_virt_from_core_inact(i_virt_orb) = accu - enddo - END_PROVIDER - - BEGIN_PROVIDER [double precision, fock_core_inactive_from_act, (mo_tot_num,2,N_states)] - BEGIN_DOC -! inactive part of the fock operator with contributions only from the active - END_DOC - implicit none - integer :: i,j,k - double precision :: accu_coulomb,accu_exchange(2) - double precision :: na,nb,ntot - double precision :: coulomb, exchange - double precision :: get_mo_bielec_integral - integer :: j_act_orb,k_act_orb,i_inact_core_orb - integer :: i_state - - do i_state = 1,N_states - do i = 1, n_core_inact_orb - accu_coulomb = 0.d0 - accu_exchange = 0.d0 - i_inact_core_orb = list_core_inact(i) - do j = 1, n_act_orb - j_act_orb = list_act(j) - na = one_body_dm_mo_alpha(j_act_orb,j_act_orb,i_state) - nb = one_body_dm_mo_beta(j_act_orb,j_act_orb,i_state) - ntot = na + nb - coulomb = mo_bielec_integral_jj(i_inact_core_orb,j_act_orb) - exchange = mo_bielec_integral_jj_exchange(i_inact_core_orb,j_act_orb) - accu_coulomb += ntot * coulomb - accu_exchange(1) += na * exchange - accu_exchange(2) += nb * exchange - do k = j+1, n_act_orb - k_act_orb = list_act(k) - na = one_body_dm_mo_alpha(j_act_orb,k_act_orb,i_state) - nb = one_body_dm_mo_beta(j_act_orb,k_act_orb,i_state) - ntot = na + nb - coulomb = get_mo_bielec_integral(j_act_orb,i_inact_core_orb,k_act_orb,i_inact_core_orb,mo_integrals_map) - exchange = get_mo_bielec_integral(j_act_orb,k_act_orb,i_inact_core_orb,i_inact_core_orb,mo_integrals_map) - accu_coulomb += 2.d0 * ntot * coulomb - accu_exchange(1) += 2.d0 * na * exchange - accu_exchange(2) += 2.d0 * nb * exchange - enddo - enddo - fock_core_inactive_from_act(i_inact_core_orb,1,i_state) = accu_coulomb - accu_exchange(1) - fock_core_inactive_from_act(i_inact_core_orb,2,i_state) = accu_coulomb - accu_exchange(2) - enddo - enddo - END_PROVIDER - - BEGIN_PROVIDER [double precision, fock_virt_from_act, (mo_tot_num,2,N_states)] - BEGIN_DOC -! virtual part of the fock operator with contributions only from the active - END_DOC - implicit none - integer :: i,j,k - double precision :: accu_coulomb,accu_exchange(2) - double precision :: na,nb,ntot - double precision :: coulomb, exchange - double precision :: get_mo_bielec_integral - integer :: j_act_orb,i_virt_orb,k_act_orb - integer :: i_state - ! TODO : inverse loop of i_state - - do i_state = 1, N_states - do i = 1, n_virt_orb - accu_coulomb = 0.d0 - accu_exchange = 0.d0 - i_virt_orb = list_virt(i) - do j = 1, n_act_orb - j_act_orb = list_act(j) - na = one_body_dm_mo_alpha(j_act_orb,j_act_orb,i_state) - nb = one_body_dm_mo_beta(j_act_orb,j_act_orb,i_state) - ntot = na + nb - coulomb = mo_bielec_integral_jj(i_virt_orb,j_act_orb) - exchange = mo_bielec_integral_jj_exchange(i_virt_orb,j_act_orb) - accu_coulomb += ntot * coulomb - accu_exchange(1) += na * exchange - accu_exchange(2) += nb * exchange - do k = j+1, n_act_orb - k_act_orb = list_act(k) - na = one_body_dm_mo_alpha(j_act_orb,k_act_orb,i_state) - nb = one_body_dm_mo_beta(j_act_orb,k_act_orb,i_state) - ntot = na + nb - coulomb = get_mo_bielec_integral(j_act_orb,i_virt_orb,k_act_orb,i_virt_orb,mo_integrals_map) - exchange = get_mo_bielec_integral(j_act_orb,k_act_orb,i_virt_orb,i_virt_orb,mo_integrals_map) - accu_coulomb += 2.d0 * ntot * coulomb - accu_exchange(1) += 2.d0 * na * exchange - accu_exchange(2) += 2.d0 * nb * exchange - enddo - enddo - fock_virt_from_act(i_virt_orb,1,i_state) = accu_coulomb - accu_exchange(1) - fock_virt_from_act(i_virt_orb,2,i_state) = accu_coulomb - accu_exchange(2) - enddo - enddo - END_PROVIDER - - BEGIN_PROVIDER [double precision, fock_core_inactive_total, (mo_tot_num,2,N_states)] -&BEGIN_PROVIDER [double precision, fock_core_inactive_total_spin_trace, (mo_tot_num,N_states)] - BEGIN_DOC -! inactive part of the fock operator - END_DOC - implicit none - integer :: i - integer :: i_inact_core_orb - integer :: i_state - do i_state = 1, N_states - do i = 1, n_core_inact_orb - i_inact_core_orb = list_core_inact(i) - fock_core_inactive_total(i_inact_core_orb,1,i_state) = fock_core_inactive(i_inact_core_orb) + fock_core_inactive_from_act(i_inact_core_orb,1,i_state) - fock_core_inactive_total(i_inact_core_orb,2,i_state) = fock_core_inactive(i_inact_core_orb) + fock_core_inactive_from_act(i_inact_core_orb,2,i_state) - fock_core_inactive_total_spin_trace(i_inact_core_orb,i_state) = 0.5d0 * (fock_core_inactive_total(i_inact_core_orb,1,i_state) + fock_core_inactive_total(i_inact_core_orb,2,i_state)) - enddo - enddo - END_PROVIDER - - BEGIN_PROVIDER [double precision, fock_virt_total, (mo_tot_num,2,N_states)] -&BEGIN_PROVIDER [double precision, fock_virt_total_spin_trace, (mo_tot_num,N_states)] - BEGIN_DOC -! inactive part of the fock operator - END_DOC - implicit none - integer :: i - integer :: i_virt_orb - integer :: i_state - do i_state = 1, N_states - do i = 1, n_virt_orb - i_virt_orb= list_virt(i) - fock_virt_total(i_virt_orb,1,i_state) = fock_virt_from_core_inact(i_virt_orb) + fock_virt_from_act(i_virt_orb,1,i_state)+ mo_mono_elec_integral(i_virt_orb,i_virt_orb) - fock_virt_total(i_virt_orb,2,i_state) = fock_virt_from_core_inact(i_virt_orb) + fock_virt_from_act(i_virt_orb,2,i_state)+ mo_mono_elec_integral(i_virt_orb,i_virt_orb) - fock_virt_total_spin_trace(i_virt_orb,i_state) = 0.5d0 * ( fock_virt_total(i_virt_orb,1,i_state) + fock_virt_total(i_virt_orb,2,i_state) ) - enddo - enddo - END_PROVIDER - - - - - - BEGIN_PROVIDER [double precision, fock_operator_active_from_core_inact, (mo_tot_num,mo_tot_num)] - BEGIN_DOC -! active part of the fock operator with contributions only from the inactive - END_DOC - implicit none - integer :: i,j,k,k_inact_core_orb - integer :: iorb,jorb - double precision :: accu - double precision :: get_mo_bielec_integral,coulomb, exchange - PROVIDE mo_bielec_integrals_in_map - fock_operator_active_from_core_inact = 0.d0 - do i = 1, n_act_orb - iorb = list_act(i) - do j = 1, n_act_orb - jorb = list_act(j) - accu = 0.d0 - do k = 1, n_core_inact_orb - k_inact_core_orb = list_core_inact(k) - coulomb = get_mo_bielec_integral(k_inact_core_orb,iorb,k_inact_core_orb,jorb,mo_integrals_map) - exchange = get_mo_bielec_integral(k_inact_core_orb,jorb,iorb,k_inact_core_orb,mo_integrals_map) - accu += 2.d0 * coulomb - exchange - enddo - fock_operator_active_from_core_inact(iorb,jorb) = accu - enddo - enddo - - END_PROVIDER - - - - diff --git a/plugins/MRPT_Utils/give_2h2p.irp.f b/plugins/MRPT_Utils/give_2h2p.irp.f deleted file mode 100644 index df71e594..00000000 --- a/plugins/MRPT_Utils/give_2h2p.irp.f +++ /dev/null @@ -1,35 +0,0 @@ -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_dress.irp.f b/plugins/MRPT_Utils/mrpt_dress.irp.f deleted file mode 100644 index 275af0e4..00000000 --- a/plugins/MRPT_Utils/mrpt_dress.irp.f +++ /dev/null @@ -1,186 +0,0 @@ -use omp_lib -use bitmasks - -BEGIN_PROVIDER [ integer(omp_lock_kind), psi_ref_bis_lock, (psi_det_size) ] - implicit none - BEGIN_DOC - ! Locks on ref determinants to fill delta_ij - END_DOC - integer :: i - do i=1,psi_det_size - call omp_init_lock( psi_ref_bis_lock(i) ) - enddo - -END_PROVIDER - - -subroutine mrpt_dress(delta_ij_, Ndet,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 - integer(bit_kind),intent(in) :: key_mask(Nint, 2) - integer(bit_kind), intent(in) :: det_buffer(Nint,2,n_selected) - double precision, intent(inout) :: delta_ij_(Ndet,Ndet,*) - - - integer :: i,j,k,l - integer :: idx_alpha(0:psi_det_size) - integer :: degree_alpha(psi_det_size) - logical :: fullMatch - - double precision :: delta_e_inv_array(psi_det_size,N_states) - double precision :: hij_array(psi_det_size) - - integer(bit_kind) :: tq(Nint,2,n_selected) - integer :: N_tq - - double precision :: hialpha,hij - integer :: i_state, i_alpha - - integer(bit_kind),allocatable :: miniList(:,:,:) - integer,allocatable :: idx_miniList(:) - integer :: N_miniList, leng - double precision :: delta_e(N_states),hij_tmp - integer :: index_i,index_j - double precision :: phase_array(N_det),phase - integer :: exc(0:2,2,2),degree - - - leng = max(N_det_generators, N_det) - allocate(miniList(Nint, 2, leng), idx_miniList(leng)) - - !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_connections_previous(i_generator,n_selected,det_buffer,Nint,tq,N_tq,miniList,N_minilist) - - if(N_tq > 0) then - call create_minilist(key_mask, psi_det, miniList, idx_miniList, N_det, N_minilist, Nint) - end if - - - do i_alpha=1,N_tq - 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)) - enddo - -! double precision :: ihpsi0,coef_pert -! ihpsi0 = 0.d0 -! coef_pert = 0.d0 - phase_array =0.d0 - do i = 1,idx_alpha(0) - index_i = idx_alpha(i) - call i_h_j(tq(1,1,i_alpha),psi_det(1,1,index_i),Nint,hialpha) - double precision :: coef_array(N_states) - do i_state = 1, N_states - coef_array(i_state) = psi_coef(index_i,i_state) - enddo - call get_delta_e_dyall(psi_det(1,1,index_i),tq(1,1,i_alpha),coef_array,hialpha,delta_e) - hij_array(index_i) = hialpha - call get_excitation(psi_det(1,1,index_i),tq(1,1,i_alpha),exc,degree,phase,N_int) -! phase_array(index_i) = phase - do i_state = 1,N_states - delta_e_inv_array(index_i,i_state) = 1.d0/delta_e(i_state) - enddo - enddo - - do i=1,idx_alpha(0) - index_i = idx_alpha(i) - hij_tmp = hij_array(index_i) - call omp_set_lock( psi_ref_bis_lock(index_i) ) - do j = 1, idx_alpha(0) - index_j = idx_alpha(j) -! call get_excitation(psi_det(1,1,index_i),psi_det(1,1,index_i),exc,degree,phase,N_int) -! if(index_j.ne.index_i)then -! if(phase_array(index_j) * phase_array(index_i) .ne. phase)then -! print*, phase_array(index_j) , phase_array(index_i) ,phase -! call debug_det(psi_det(1,1,index_i),N_int) -! call debug_det(psi_det(1,1,index_j),N_int) -! call debug_det(tq(1,1,i_alpha),N_int) -! stop -! endif -! endif - do i_state=1,N_states -! standard dressing first order - delta_ij_(index_i,index_j,i_state) += hij_array(index_j) * hij_tmp * delta_e_inv_array(index_j,i_state) - enddo - enddo - call omp_unset_lock( psi_ref_bis_lock(index_i)) - enddo - enddo - 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_connections_previous(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 :: 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) :: miniList(Nint,2,N_det_generators) - integer,intent(in) :: N_miniList - - - - 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 - end if - - if (.not. is_in_wavefunction(det_buffer(1,1,i),Nint,N_det)) then - N_tq += 1 - do k=1,N_int - tq(k,1,N_tq) = det_buffer(k,1,i) - tq(k,2,N_tq) = det_buffer(k,2,i) - enddo - endif - enddo i_loop -end - - - - - - - diff --git a/plugins/MRPT_Utils/mrpt_utils.irp.f b/plugins/MRPT_Utils/mrpt_utils.irp.f deleted file mode 100644 index d7b1f0f6..00000000 --- a/plugins/MRPT_Utils/mrpt_utils.irp.f +++ /dev/null @@ -1,367 +0,0 @@ - - BEGIN_PROVIDER [ double precision, delta_ij, (N_det,N_det,N_states) ] -&BEGIN_PROVIDER [ double precision, second_order_pt_new, (N_states) ] -&BEGIN_PROVIDER [ double precision, second_order_pt_new_1h, (N_states) ] -&BEGIN_PROVIDER [ double precision, second_order_pt_new_1p, (N_states) ] -&BEGIN_PROVIDER [ double precision, second_order_pt_new_1h1p, (N_states) ] -&BEGIN_PROVIDER [ double precision, second_order_pt_new_2h, (N_states) ] -&BEGIN_PROVIDER [ double precision, second_order_pt_new_2p, (N_states) ] -&BEGIN_PROVIDER [ double precision, second_order_pt_new_1h2p, (N_states) ] -&BEGIN_PROVIDER [ double precision, second_order_pt_new_2h1p, (N_states) ] -&BEGIN_PROVIDER [ double precision, second_order_pt_new_2h2p, (N_states) ] - implicit none - BEGIN_DOC - ! Dressing matrix in N_det basis - END_DOC - integer :: i,j,m - integer :: i_state - double precision :: accu(N_states) - double precision, allocatable :: delta_ij_tmp(:,:,:) - - - delta_ij = 0.d0 - - allocate (delta_ij_tmp(N_det,N_det,N_states)) - - - ! 1h - delta_ij_tmp = 0.d0 - call H_apply_mrpt_1h(delta_ij_tmp,N_det) - accu = 0.d0 - do i_state = 1, N_states - do i = 1, N_det - do j = 1, N_det - accu(i_state) += delta_ij_tmp(j,i,i_state) * psi_coef(i,i_state) * psi_coef(j,i_state) - delta_ij(j,i,i_state) += delta_ij_tmp(j,i,i_state) - enddo - enddo - second_order_pt_new_1h(i_state) = accu(i_state) - enddo - print*, '1h = ',accu - - ! 1p - delta_ij_tmp = 0.d0 - call H_apply_mrpt_1p(delta_ij_tmp,N_det) - accu = 0.d0 - do i_state = 1, N_states - do i = 1, N_det - do j = 1, N_det - accu(i_state) += delta_ij_tmp(j,i,i_state) * psi_coef(i,i_state) * psi_coef(j,i_state) - delta_ij(j,i,i_state) += delta_ij_tmp(j,i,i_state) - enddo - enddo - second_order_pt_new_1p(i_state) = accu(i_state) - enddo - print*, '1p = ',accu - - ! 1h1p - delta_ij_tmp = 0.d0 - call H_apply_mrpt_1h1p(delta_ij_tmp,N_det) - double precision :: e_corr_from_1h1p_singles(N_states) -!call give_singles_and_partial_doubles_1h1p_contrib(delta_ij_tmp,e_corr_from_1h1p_singles) -!call give_1h1p_only_doubles_spin_cross(delta_ij_tmp) - accu = 0.d0 - do i_state = 1, N_states - do i = 1, N_det - do j = 1, N_det - accu(i_state) += delta_ij_tmp(j,i,i_state) * psi_coef(i,i_state) * psi_coef(j,i_state) - delta_ij(j,i,i_state) += delta_ij_tmp(j,i,i_state) - enddo - enddo - second_order_pt_new_1h1p(i_state) = accu(i_state) - enddo - print*, '1h1p = ',accu - - ! 1h1p third order - if(do_third_order_1h1p)then - delta_ij_tmp = 0.d0 - call give_1h1p_sec_order_singles_contrib(delta_ij_tmp) - accu = 0.d0 - do i_state = 1, N_states - do i = 1, N_det - do j = 1, N_det - accu(i_state) += delta_ij_tmp(j,i,i_state) * psi_coef(i,i_state) * psi_coef(j,i_state) - delta_ij(j,i,i_state) += delta_ij_tmp(j,i,i_state) - enddo - enddo - second_order_pt_new_1h1p(i_state) = accu(i_state) - enddo - print*, '1h1p(3)',accu - endif - - ! 2h - delta_ij_tmp = 0.d0 - call H_apply_mrpt_2h(delta_ij_tmp,N_det) - accu = 0.d0 - do i_state = 1, N_states - do i = 1, N_det - do j = 1, N_det - accu(i_state) += delta_ij_tmp(j,i,i_state) * psi_coef(i,i_state) * psi_coef(j,i_state) - delta_ij(j,i,i_state) += delta_ij_tmp(j,i,i_state) - enddo - enddo - second_order_pt_new_2h(i_state) = accu(i_state) - enddo - print*, '2h = ',accu - - ! 2p - delta_ij_tmp = 0.d0 - call H_apply_mrpt_2p(delta_ij_tmp,N_det) - accu = 0.d0 - do i_state = 1, N_states - do i = 1, N_det - do j = 1, N_det - accu(i_state) += delta_ij_tmp(j,i,i_state) * psi_coef(i,i_state) * psi_coef(j,i_state) - delta_ij(j,i,i_state) += delta_ij_tmp(j,i,i_state) - enddo - enddo - second_order_pt_new_2p(i_state) = accu(i_state) - enddo - print*, '2p = ',accu - - ! 1h2p - delta_ij_tmp = 0.d0 -!call give_1h2p_contrib(delta_ij_tmp) - call H_apply_mrpt_1h2p(delta_ij_tmp,N_det) - accu = 0.d0 - do i_state = 1, N_states - do i = 1, N_det - do j = 1, N_det - accu(i_state) += delta_ij_tmp(j,i,i_state) * psi_coef(i,i_state) * psi_coef(j,i_state) - delta_ij(j,i,i_state) += delta_ij_tmp(j,i,i_state) - enddo - enddo - second_order_pt_new_1h2p(i_state) = accu(i_state) - enddo - print*, '1h2p = ',accu - - ! 2h1p - delta_ij_tmp = 0.d0 -!call give_2h1p_contrib(delta_ij_tmp) - call H_apply_mrpt_2h1p(delta_ij_tmp,N_det) - accu = 0.d0 - do i_state = 1, N_states - do i = 1, N_det - do j = 1, N_det - accu(i_state) += delta_ij_tmp(j,i,i_state) * psi_coef(i,i_state) * psi_coef(j,i_state) - delta_ij(j,i,i_state) += delta_ij_tmp(j,i,i_state) - enddo - enddo - second_order_pt_new_2h1p(i_state) = accu(i_state) - enddo - print*, '2h1p = ',accu - - ! 2h2p -!delta_ij_tmp = 0.d0 -!call H_apply_mrpt_2h2p(delta_ij_tmp,N_det) -!accu = 0.d0 -!do i_state = 1, N_states -!do i = 1, N_det -! do j = 1, N_det -! accu(i_state) += delta_ij_tmp(j,i,i_state) * psi_coef(i,i_state) * psi_coef(j,i_state) -! delta_ij(j,i,i_state) += delta_ij_tmp(j,i,i_state) -! enddo -!enddo -!second_order_pt_new_2h2p(i_state) = accu(i_state) -!enddo -!print*, '2h2p = ',accu - - double precision :: contrib_2h2p(N_states) - call give_2h2p(contrib_2h2p) - do i_state = 1, N_states - do i = 1, N_det - delta_ij(i,i,i_state) += contrib_2h2p(i_state) - enddo - second_order_pt_new_2h2p(i_state) = contrib_2h2p(i_state) - enddo - print*, '2h2p = ',contrib_2h2p(1) - - - ! total - accu = 0.d0 - do i_state = 1, N_states - do i = 1, N_det -! write(*,'(1000(F16.10,x))')delta_ij(i,:,:) - do j = i_state, N_det - accu(i_state) += delta_ij(j,i,i_state) * psi_coef(i,i_state) * psi_coef(j,i_state) - enddo - enddo - second_order_pt_new(i_state) = accu(i_state) - print*, 'total= ',accu(i_state) - enddo - - - - -END_PROVIDER - - BEGIN_PROVIDER [double precision, Hmatrix_dressed_pt2_new, (N_det,N_det,N_states)] - implicit none - integer :: i,j,i_state - do i_state = 1, N_states - do i = 1,N_det - do j = 1,N_det - Hmatrix_dressed_pt2_new(j,i,i_state) = H_matrix_all_dets(j,i) + delta_ij(j,i,i_state) - enddo - enddo - enddo - END_PROVIDER - - - - BEGIN_PROVIDER [double precision, Hmatrix_dressed_pt2_new_symmetrized, (N_det,N_det,N_states)] - implicit none - integer :: i,j,i_state - do i_state = 1, N_states - do i = 1,N_det - do j = i,N_det - Hmatrix_dressed_pt2_new_symmetrized(j,i,i_state) = H_matrix_all_dets(j,i) & - + 0.5d0 * ( delta_ij(j,i,i_state) + delta_ij(i,j,i_state) ) - Hmatrix_dressed_pt2_new_symmetrized(i,j,i_state) = Hmatrix_dressed_pt2_new_symmetrized(j,i,i_state) - enddo - enddo - enddo - END_PROVIDER - - BEGIN_PROVIDER [ double precision, CI_electronic_dressed_pt2_new_energy, (N_states_diag) ] - &BEGIN_PROVIDER [ double precision, CI_dressed_pt2_new_eigenvectors, (N_det,N_states_diag) ] - &BEGIN_PROVIDER [ double precision, CI_dressed_pt2_new_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_dressed_pt2_new_eigenvectors - do j=1,min(N_states_diag,N_det) - do i=1,N_det - CI_dressed_pt2_new_eigenvectors(i,j) = psi_coef(i,j) - enddo - enddo - - do j=N_det+1,N_states_diag - do i=1,N_det - CI_dressed_pt2_new_eigenvectors(i,j) = 0.d0 - enddo - enddo - - if (diag_algorithm == "Davidson") then - - 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, & - 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 - - -BEGIN_PROVIDER [ double precision, CI_dressed_pt2_new_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_dressed_pt2_new_energy(j) = CI_electronic_dressed_pt2_new_energy(j) + nuclear_repulsion - write(st,'(I4)') j - call write_double(output_determinants,CI_dressed_pt2_new_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 diff --git a/plugins/MRPT_Utils/new_way.irp.f b/plugins/MRPT_Utils/new_way.irp.f deleted file mode 100644 index fa5812e1..00000000 --- a/plugins/MRPT_Utils/new_way.irp.f +++ /dev/null @@ -1,958 +0,0 @@ -subroutine give_2h1p_contrib(matrix_2h1p) - use bitmasks - implicit none - double precision , intent(inout) :: matrix_2h1p(N_det,N_det,*) - integer :: i,j,r,a,b - integer :: iorb, jorb, rorb, aorb, borb - integer :: ispin,jspin - integer :: idet,jdet - integer(bit_kind) :: perturb_dets(N_int,2,n_act_orb,2,2) - double precision :: perturb_dets_phase(n_act_orb,2,2) - double precision :: perturb_dets_hij(n_act_orb,2,2) - double precision :: coef_perturb_from_idet(n_act_orb,2,2,N_states) - integer :: inint - integer :: elec_num_tab_local(2),acu_elec - integer(bit_kind) :: det_tmp(N_int,2) - integer :: exc(0:2,2,2) - integer :: accu_elec - double precision :: get_mo_bielec_integral - double precision :: active_int(n_act_orb,2) - double precision :: hij,phase -!matrix_2h1p = 0.d0 - - elec_num_tab_local = 0 - do inint = 1, N_int - elec_num_tab_local(1) += popcnt(psi_det(inint,1,1)) - elec_num_tab_local(2) += popcnt(psi_det(inint,2,1)) - enddo - do i = 1, n_inact_orb ! First inactive - iorb = list_inact(i) - do j = 1, n_inact_orb ! Second inactive - jorb = list_inact(j) - do r = 1, n_virt_orb ! First virtual - rorb = list_virt(r) - ! take all the integral you will need for i,j,r fixed - do a = 1, n_act_orb - aorb = list_act(a) - active_int(a,1) = get_mo_bielec_integral(iorb,jorb,rorb,aorb,mo_integrals_map) ! direct - active_int(a,2) = get_mo_bielec_integral(iorb,jorb,aorb,rorb,mo_integrals_map) ! exchange - enddo - - integer :: degree(N_det) - integer :: idx(0:N_det) - double precision :: delta_e(n_act_orb,2,N_states) - integer :: istate - integer :: index_orb_act_mono(N_det,3) - - do idet = 1, N_det - call get_excitation_degree_vector_mono(psi_det,psi_det(1,1,idet),degree,N_int,N_det,idx) - !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! Precomputation of matrix elements - do ispin = 1, 2 ! spin of the couple a-a^dagger (i,r) - do jspin = 1, 2 ! spin of the couple z-a^dagger (j,a) - if(ispin == jspin .and. iorb.le.jorb)cycle ! condition not to double count - do a = 1, n_act_orb ! First active - aorb = list_act(a) - do inint = 1, N_int - det_tmp(inint,1) = psi_det(inint,1,idet) - det_tmp(inint,2) = psi_det(inint,2,idet) - enddo - ! Do the excitation inactive -- > virtual - call clear_bit_to_integer(iorb,det_tmp(1,ispin),N_int) ! hole in "iorb" of spin Ispin - call set_bit_to_integer(rorb,det_tmp(1,ispin),N_int) ! particle in "rorb" of spin Ispin - - ! Do the excitation inactive -- > active - call clear_bit_to_integer(jorb,det_tmp(1,jspin),N_int) ! hole in "jorb" of spin Jspin - call set_bit_to_integer(aorb,det_tmp(1,jspin),N_int) ! particle in "aorb" of spin Jspin - - ! Check if the excitation is possible or not on psi_det(idet) - accu_elec= 0 - do inint = 1, N_int - accu_elec+= popcnt(det_tmp(inint,jspin)) - enddo - if(accu_elec .ne. elec_num_tab_local(jspin))then - perturb_dets_phase(a,jspin,ispin) = 0.0 - perturb_dets_hij(a,jspin,ispin) = 0.d0 - do istate = 1, N_states - coef_perturb_from_idet(a,jspin,ispin,istate) = 0.d0 - enddo - cycle - endif - do inint = 1, N_int - perturb_dets(inint,1,a,jspin,ispin) = det_tmp(inint,1) - perturb_dets(inint,2,a,jspin,ispin) = det_tmp(inint,2) - enddo - call get_double_excitation(psi_det(1,1,idet),det_tmp,exc,phase,N_int) - perturb_dets_phase(a,jspin,ispin) = phase - do istate = 1, N_states - delta_e(a,jspin,istate) = one_creat(a,jspin,istate) & - - fock_virt_total_spin_trace(rorb,istate) & - + fock_core_inactive_total_spin_trace(iorb,istate) & - + fock_core_inactive_total_spin_trace(jorb,istate) - enddo - if(ispin == jspin)then - perturb_dets_hij(a,jspin,ispin) = phase * (active_int(a,2) - active_int(a,1) ) - else - perturb_dets_hij(a,jspin,ispin) = phase * active_int(a,1) - endif -!!!!!!!!!!!!!!!!!!!!!1 Computation of the coefficient at first order coming from idet -!!!!!!!!!!!!!!!!!!!!! for the excitation (i,j)(ispin,jspin) ---> (r,a)(ispin,jspin) - do istate = 1, N_states - coef_perturb_from_idet(a,jspin,ispin,istate) = perturb_dets_hij(a,jspin,ispin) / delta_e(a,jspin,istate) - enddo - - enddo - enddo - enddo - -!!!!!!!!!!!!!!!!!!!!!!!!!!! determination of the connections between I and the other J determinants mono excited in the CAS -!!!!!!!!!!!!!!!!!!!!!!!!!!!! the determinants I and J must be connected by the following operator -!!!!!!!!!!!!!!!!!!!!!!!!!!!! - do jdet = 1, idx(0) - if(idx(jdet).ne.idet)then - call get_mono_excitation(psi_det(1,1,idet),psi_det(1,1,idx(jdet)),exc,phase,N_int) - if (exc(0,1,1) == 1) then - ! Mono alpha - index_orb_act_mono(idx(jdet),1) = list_act_reverse(exc(1,2,1)) !!! a^{\dagger}_a - index_orb_act_mono(idx(jdet),2) = list_act_reverse(exc(1,1,1)) !!! a_{b} - index_orb_act_mono(idx(jdet),3) = 1 - else - ! Mono beta - index_orb_act_mono(idx(jdet),1) = list_act_reverse(exc(1,2,2)) !!! a^{\dagger}_a - index_orb_act_mono(idx(jdet),2) = list_act_reverse(exc(1,1,2)) !!! a_{b} - index_orb_act_mono(idx(jdet),3) = 2 - endif - else - index_orb_act_mono(idx(jdet),1) = -1 - endif - enddo - - integer :: kspin - do jdet = 1, idx(0) - if(idx(jdet).ne.idet)then - ! two determinants | Idet > and | Jdet > which are connected throw a mono excitation operator - ! are connected by the presence of the perturbers determinants |det_tmp> - aorb = index_orb_act_mono(idx(jdet),1) ! a^{\dagger}_{aorb} - borb = index_orb_act_mono(idx(jdet),2) ! a_{borb} - kspin = index_orb_act_mono(idx(jdet),3) ! spin of the excitation - ! the determinants Idet and Jdet interact throw the following operator - ! | Jdet > = a_{borb,kspin} a^{\dagger}_{aorb, kspin} | Idet > - - do ispin = 1, 2 ! you loop on all possible spin for the excitation - ! a^{\dagger}_r a_{i} (ispin) - if(ispin == kspin .and. iorb.le.jorb)cycle ! 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 - det_tmp(inint,1) = perturb_dets(inint,1,aorb,kspin,ispin) - det_tmp(inint,2) = perturb_dets(inint,2,aorb,kspin,ispin) - enddo - double precision :: hja - ! you determine the interaction between the excited determinant and the other parent | Jdet > - ! | det_tmp > = a^{\dagger}_{rorb,ispin} a^{\dagger}_{borb,kspin} a_{jorb,kspin} a_{iorb,ispin} | Jdet > - ! hja = < det_tmp | H | Jdet > - call get_double_excitation(psi_det(1,1,idx(jdet)),det_tmp,exc,phase,N_int) - if(kspin == ispin)then - hja = phase * (active_int(borb,2) - active_int(borb,1) ) - else - hja = phase * active_int(borb,1) - endif - - do istate = 1, N_states - matrix_2h1p(idx(jdet),idet,istate) += hja * coef_perturb_from_idet(aorb,kspin,ispin,istate) - enddo - enddo ! ispin - - else - ! diagonal part of the dressing : interaction of | Idet > with all the perturbers generated by the excitations - ! - ! | det_tmp > = a^{\dagger}_{rorb,ispin} a^{\dagger}_{aorb,kspin} a_{jorb,kspin} a_{iorb,ispin} | Idet > - do ispin = 1, 2 - do kspin = 1, 2 - if(ispin == kspin .and. iorb.le.jorb)cycle ! condition not to double count - do a = 1, n_act_orb ! First active - do istate = 1, N_states - matrix_2h1p(idet,idet,istate) += coef_perturb_from_idet(a,kspin,ispin,istate) * perturb_dets_hij(a,kspin,ispin) - enddo - enddo - enddo - enddo - - endif - - enddo - enddo - enddo - enddo - enddo - - - - - -end - - -subroutine give_1h2p_contrib(matrix_1h2p) - use bitmasks - implicit none - double precision , intent(inout) :: matrix_1h2p(N_det,N_det,*) - integer :: i,v,r,a,b - integer :: iorb, vorb, rorb, aorb, borb - integer :: ispin,jspin - integer :: idet,jdet - integer(bit_kind) :: perturb_dets(N_int,2,n_act_orb,2,2) - double precision :: perturb_dets_phase(n_act_orb,2,2) - double precision :: perturb_dets_hij(n_act_orb,2,2) - double precision :: coef_perturb_from_idet(n_act_orb,2,2,N_states) - integer :: inint - integer :: elec_num_tab_local(2),acu_elec - integer(bit_kind) :: det_tmp(N_int,2) - integer :: exc(0:2,2,2) - integer :: accu_elec - double precision :: get_mo_bielec_integral - double precision :: active_int(n_act_orb,2) - double precision :: hij,phase -!matrix_1h2p = 0.d0 - - elec_num_tab_local = 0 - do inint = 1, N_int - elec_num_tab_local(1) += popcnt(psi_det(inint,1,1)) - elec_num_tab_local(2) += popcnt(psi_det(inint,2,1)) - enddo - do i = 1, n_inact_orb ! First inactive - iorb = list_inact(i) - do v = 1, n_virt_orb ! First virtual - vorb = list_virt(v) - do r = 1, n_virt_orb ! Second virtual - rorb = list_virt(r) - ! take all the integral you will need for i,j,r fixed - do a = 1, n_act_orb - aorb = list_act(a) - active_int(a,1) = get_mo_bielec_integral(iorb,aorb,rorb,vorb,mo_integrals_map) ! direct - active_int(a,2) = get_mo_bielec_integral(iorb,aorb,vorb,rorb,mo_integrals_map) ! exchange - enddo - - integer :: degree(N_det) - integer :: idx(0:N_det) - double precision :: delta_e(n_act_orb,2,N_states) - integer :: istate - integer :: index_orb_act_mono(N_det,3) - - do idet = 1, N_det - call get_excitation_degree_vector_mono(psi_det,psi_det(1,1,idet),degree,N_int,N_det,idx) - !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! Precomputation of matrix elements - do ispin = 1, 2 ! spin of the couple a-a^dagger (iorb,rorb) - do jspin = 1, 2 ! spin of the couple a-a^dagger (aorb,vorb) - do a = 1, n_act_orb ! First active - aorb = list_act(a) - if(ispin == jspin .and. vorb.le.rorb)cycle ! condition not to double count - do inint = 1, N_int - det_tmp(inint,1) = psi_det(inint,1,idet) - det_tmp(inint,2) = psi_det(inint,2,idet) - enddo - ! Do the excitation inactive -- > virtual - call clear_bit_to_integer(iorb,det_tmp(1,ispin),N_int) ! hole in "iorb" of spin Ispin - call set_bit_to_integer(rorb,det_tmp(1,ispin),N_int) ! particle in "rorb" of spin Ispin - - ! Do the excitation active -- > virtual - call clear_bit_to_integer(aorb,det_tmp(1,jspin),N_int) ! hole in "aorb" of spin Jspin - call set_bit_to_integer(vorb,det_tmp(1,jspin),N_int) ! particle in "vorb" of spin Jspin - - ! Check if the excitation is possible or not on psi_det(idet) - accu_elec= 0 - do inint = 1, N_int - accu_elec+= popcnt(det_tmp(inint,jspin)) - enddo - if(accu_elec .ne. elec_num_tab_local(jspin))then - perturb_dets_phase(a,jspin,ispin) = 0.0 - perturb_dets_hij(a,jspin,ispin) = 0.d0 - do istate = 1, N_states - coef_perturb_from_idet(a,jspin,ispin,istate) = 0.d0 - enddo - cycle - endif - do inint = 1, N_int - perturb_dets(inint,1,a,jspin,ispin) = det_tmp(inint,1) - perturb_dets(inint,2,a,jspin,ispin) = det_tmp(inint,2) - enddo - do inint = 1, N_int - det_tmp(inint,1) = perturb_dets(inint,1,a,jspin,ispin) - det_tmp(inint,2) = perturb_dets(inint,2,a,jspin,ispin) - enddo - - call get_double_excitation(psi_det(1,1,idet),det_tmp,exc,phase,N_int) - perturb_dets_phase(a,jspin,ispin) = phase - do istate = 1, N_states - delta_e(a,jspin,istate) = one_anhil(a,jspin,istate) & - - fock_virt_total_spin_trace(rorb,istate) & - - fock_virt_total_spin_trace(vorb,istate) & - + fock_core_inactive_total_spin_trace(iorb,istate) - enddo - if(ispin == jspin)then - perturb_dets_hij(a,jspin,ispin) = phase * (active_int(a,1) - active_int(a,2) ) - else - perturb_dets_hij(a,jspin,ispin) = phase * active_int(a,1) - endif -!!!!!!!!!!!!!!!!!!!!!1 Computation of the coefficient at first order coming from idet -!!!!!!!!!!!!!!!!!!!!! for the excitation (i,j)(ispin,jspin) ---> (r,a)(ispin,jspin) - do istate = 1, N_states - coef_perturb_from_idet(a,jspin,ispin,istate) = perturb_dets_hij(a,jspin,ispin) / delta_e(a,jspin,istate) - enddo - - enddo - enddo - enddo - -!!!!!!!!!!!!!!!!!!!!!!!!!!! determination of the connections between I and the other J determinants mono excited in the CAS -!!!!!!!!!!!!!!!!!!!!!!!!!!!! the determinants I and J must be connected by the following operator -!!!!!!!!!!!!!!!!!!!!!!!!!!!! - do jdet = 1, idx(0) - if(idx(jdet).ne.idet)then - call get_mono_excitation(psi_det(1,1,idet),psi_det(1,1,idx(jdet)),exc,phase,N_int) - if (exc(0,1,1) == 1) then - ! Mono alpha - index_orb_act_mono(idx(jdet),1) = list_act_reverse(exc(1,1,1)) !!! a_a - index_orb_act_mono(idx(jdet),2) = list_act_reverse(exc(1,2,1)) !!! a^{\dagger}_{b} - index_orb_act_mono(idx(jdet),3) = 1 - else - ! Mono beta - index_orb_act_mono(idx(jdet),1) = list_act_reverse(exc(1,1,2)) !!! a_a - index_orb_act_mono(idx(jdet),2) = list_act_reverse(exc(1,2,2)) !!! a^{\dagger}_{b} - index_orb_act_mono(idx(jdet),3) = 2 - endif - else - index_orb_act_mono(idx(jdet),1) = -1 - endif - enddo - - integer :: kspin - do jdet = 1, idx(0) - if(idx(jdet).ne.idet)then - ! two determinants | Idet > and | Jdet > which are connected throw a mono excitation operator - ! are connected by the presence of the perturbers determinants |det_tmp> - aorb = index_orb_act_mono(idx(jdet),1) ! a_{aorb} - borb = index_orb_act_mono(idx(jdet),2) ! a^{\dagger}_{borb} - kspin = index_orb_act_mono(idx(jdet),3) ! spin of the excitation - ! the determinants Idet and Jdet interact throw the following operator - ! | Jdet > = a^{\dagger}_{borb,kspin} a_{aorb, kspin} | Idet > - - do ispin = 1, 2 ! you loop on all possible spin for the excitation - ! a^{\dagger}_r a_{i} (ispin) - if(ispin == kspin .and. vorb.le.rorb)cycle ! condition not to double count - - ! | det_tmp > = a^{\dagger}_{rorb,ispin} a^{\dagger}_{vorb,kspin} a_{aorb,kspin} a_{iorb,ispin} | Idet > - do inint = 1, N_int - det_tmp(inint,1) = perturb_dets(inint,1,aorb,kspin,ispin) - det_tmp(inint,2) = perturb_dets(inint,2,aorb,kspin,ispin) - enddo - double precision :: hja - ! you determine the interaction between the excited determinant and the other parent | Jdet > - ! | det_tmp > = a^{\dagger}_{rorb,ispin} a^{\dagger}_{vorb,kspin} a_{borb,kspin} a_{iorb,ispin} | Jdet > - ! hja = < det_tmp | H | Jdet > - - call get_double_excitation(psi_det(1,1,idx(jdet)),det_tmp,exc,phase,N_int) - if(kspin == ispin)then - hja = phase * (active_int(borb,1) - active_int(borb,2) ) - else - hja = phase * active_int(borb,1) - endif - - do istate = 1, N_states - matrix_1h2p(idx(jdet),idet,istate) += hja * coef_perturb_from_idet(aorb,kspin,ispin,istate) - enddo - enddo ! ispin - - else - ! diagonal part of the dressing : interaction of | Idet > with all the perturbers generated by the excitations - ! - ! | det_tmp > = a^{\dagger}_{rorb,ispin} a^{\dagger}_{vorb,kspin} a_{aorb,kspin} a_{iorb,ispin} | Idet > - do ispin = 1, 2 - do kspin = 1, 2 - do a = 1, n_act_orb ! First active - aorb = list_act(a) - if(ispin == kspin .and. vorb.le.rorb)cycle ! condition not to double count - do istate = 1, N_states - matrix_1h2p(idet,idet,istate) += coef_perturb_from_idet(a,kspin,ispin,istate) * perturb_dets_hij(a,kspin,ispin) - enddo - enddo - enddo - enddo - - endif - - enddo - enddo - enddo - enddo - enddo - - - - - -end - - -subroutine give_1h1p_contrib(matrix_1h1p) - use bitmasks - implicit none - double precision , intent(inout) :: matrix_1h1p(N_det,N_det,*) - integer :: i,j,r,a,b - integer :: iorb, jorb, rorb, aorb, borb - integer :: ispin,jspin - integer :: idet,jdet - integer :: inint - integer :: elec_num_tab_local(2),acu_elec - integer(bit_kind) :: det_tmp(N_int,2) - integer :: exc(0:2,2,2) - integer :: accu_elec - double precision :: get_mo_bielec_integral - double precision :: active_int(n_act_orb,2) - double precision :: hij,phase - integer :: degree(N_det) - integer :: idx(0:N_det) - integer :: istate - double precision :: hja,delta_e_inact_virt(N_states) - integer :: kspin,degree_scalar -!matrix_1h1p = 0.d0 - - elec_num_tab_local = 0 - do inint = 1, N_int - elec_num_tab_local(1) += popcnt(psi_det(inint,1,1)) - elec_num_tab_local(2) += popcnt(psi_det(inint,2,1)) - enddo - do i = 1, n_inact_orb ! First inactive - iorb = list_inact(i) - do r = 1, n_virt_orb ! First virtual - rorb = list_virt(r) - do j = 1, N_states - delta_e_inact_virt(j) = fock_core_inactive_total_spin_trace(iorb,j) & - - fock_virt_total_spin_trace(rorb,j) - enddo - do idet = 1, N_det - call get_excitation_degree_vector_mono(psi_det,psi_det(1,1,idet),degree,N_int,N_det,idx) - !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! Precomputation of matrix elements - !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! Case of the mono excitations - do jdet = 1, idx(0) - do ispin = 1, 2 ! spin of the couple a-a^dagger (i,r) - do inint = 1, N_int - det_tmp(inint,1) = psi_det(inint,1,idet) - det_tmp(inint,2) = psi_det(inint,2,idet) - enddo - ! Do the excitation inactive -- > virtual - double precision :: himono,delta_e(N_states),coef_mono(N_states) - call clear_bit_to_integer(iorb,det_tmp(1,ispin),N_int) ! hole in "iorb" of spin Ispin - call set_bit_to_integer(rorb,det_tmp(1,ispin),N_int) ! particle in "rorb" of spin Ispin - call i_H_j(psi_det(1,1,idet),det_tmp,N_int,himono) - - do state_target = 1, N_states -! delta_e(state_target) = one_anhil_one_creat_inact_virt(i,r,state_target) + delta_e_inact_virt(state_target) - delta_e(state_target) = one_anhil_one_creat_inact_virt_bis(i,r,idet,state_target) - coef_mono(state_target) = himono / delta_e(state_target) - enddo - if(idx(jdet).ne.idet)then - call get_mono_excitation(psi_det(1,1,idet),psi_det(1,1,idx(jdet)),exc,phase,N_int) - if (exc(0,1,1) == 1) then - ! Mono alpha - aorb = (exc(1,2,1)) !!! a^{\dagger}_a - borb = (exc(1,1,1)) !!! a_{b} - jspin = 1 - else - ! Mono beta - aorb = (exc(1,2,2)) !!! a^{\dagger}_a - borb = (exc(1,1,2)) !!! a_{b} - jspin = 2 - endif - - call get_excitation_degree(psi_det(1,1,idx(jdet)),det_tmp,degree_scalar,N_int) - if(degree_scalar .ne. 2)then - print*, 'pb !!!' - print*, degree_scalar - call debug_det(psi_det(1,1,idx(jdet)),N_int) - call debug_det(det_tmp,N_int) - stop - endif - call get_double_excitation(psi_det(1,1,idx(jdet)),det_tmp,exc,phase,N_int) - if(ispin == jspin )then - hij = -get_mo_bielec_integral(iorb,aorb,rorb,borb,mo_integrals_map) & - + get_mo_bielec_integral(iorb,aorb,borb,rorb,mo_integrals_map) - else - hij = get_mo_bielec_integral(iorb,borb,rorb,aorb,mo_integrals_map) - endif - hij = hij * phase - double precision :: hij_test - integer :: state_target - call i_H_j(psi_det(1,1,idx(jdet)),det_tmp,N_int,hij_test) - if(dabs(hij - hij_test).gt.1.d-10)then - print*, 'ahah pb !!' - print*, 'hij .ne. hij_test' - print*, hij,hij_test - call debug_det(psi_det(1,1,idx(jdet)),N_int) - call debug_det(det_tmp,N_int) - print*, ispin, jspin - print*,iorb,borb,rorb,aorb - print*, phase - call i_H_j_verbose(psi_det(1,1,idx(jdet)),det_tmp,N_int,hij_test) - stop - endif - do state_target = 1, N_states - matrix_1h1p(idx(jdet),idet,state_target) += hij* coef_mono(state_target) - enddo - else - do state_target = 1, N_states - matrix_1h1p(idet,idet,state_target) += himono * coef_mono(state_target) - enddo - endif - enddo - enddo - - - - enddo - enddo - enddo -end - -subroutine give_1h1p_sec_order_singles_contrib(matrix_1h1p) - use bitmasks - implicit none - double precision , intent(inout) :: matrix_1h1p(N_det,N_det,*) - integer :: i,j,r,a,b - integer :: iorb, jorb, rorb, aorb, borb,s,sorb - integer :: ispin,jspin - integer :: idet,jdet - integer :: inint - integer :: elec_num_tab_local(2),acu_elec - integer(bit_kind) :: det_tmp(N_int,2),det_tmp_bis(N_int,2) - integer(bit_kind) :: det_pert(N_int,2,n_inact_orb,n_virt_orb,2) - double precision :: coef_det_pert(n_inact_orb,n_virt_orb,2,N_states,2) - double precision :: delta_e_det_pert(n_inact_orb,n_virt_orb,2,N_states) - double precision :: hij_det_pert(n_inact_orb,n_virt_orb,2,N_states) - integer :: exc(0:2,2,2) - integer :: accu_elec - double precision :: get_mo_bielec_integral - double precision :: active_int(n_act_orb,2) - double precision :: hij,phase - integer :: degree(N_det) - integer :: idx(0:N_det) - integer :: istate - double precision :: hja,delta_e_inact_virt(N_states) - integer :: kspin,degree_scalar -!matrix_1h1p = 0.d0 - - elec_num_tab_local = 0 - do inint = 1, N_int - elec_num_tab_local(1) += popcnt(psi_det(inint,1,1)) - elec_num_tab_local(2) += popcnt(psi_det(inint,2,1)) - enddo - double precision :: himono,delta_e(N_states),coef_mono(N_states) - integer :: state_target - do idet = 1, N_det - call get_excitation_degree_vector_mono(psi_det,psi_det(1,1,idet),degree,N_int,N_det,idx) - do i = 1, n_inact_orb ! First inactive - iorb = list_inact(i) - do r = 1, n_virt_orb ! First virtual - rorb = list_virt(r) - do ispin = 1, 2 ! spin of the couple a-a^dagger (i,r) - do state_target = 1, N_states - coef_det_pert(i,r,ispin,state_target,1) = 0.d0 - coef_det_pert(i,r,ispin,state_target,2) = 0.d0 - enddo - do j = 1, N_states - delta_e_inact_virt(j) = fock_core_inactive_total_spin_trace(iorb,j) & - - fock_virt_total_spin_trace(rorb,j) - enddo - do inint = 1, N_int - det_tmp(inint,1) = psi_det(inint,1,idet) - det_tmp(inint,2) = psi_det(inint,2,idet) - enddo - ! Do the excitation inactive -- > virtual - call clear_bit_to_integer(iorb,det_tmp(1,ispin),N_int) ! hole in "iorb" of spin Ispin - call set_bit_to_integer(rorb,det_tmp(1,ispin),N_int) ! particle in "rorb" of spin Ispin - call i_H_j(psi_det(1,1,idet),det_tmp,N_int,himono) - do inint = 1, N_int - det_pert(inint,1,i,r,ispin) = det_tmp(inint,1) - det_pert(inint,2,i,r,ispin) = det_tmp(inint,2) - enddo - do state_target = 1, N_states - delta_e_det_pert(i,r,ispin,state_target) = one_anhil_one_creat_inact_virt(i,r,state_target) + delta_e_inact_virt(state_target) - coef_det_pert(i,r,ispin,state_target,1) = himono / delta_e_det_pert(i,r,ispin,state_target) - enddo - !!!!!!!!!!!!!!!!!!!!!!!!!!!!! Precomputation of matrix elements - !!!!!!!!!!!!!!!!!!!!!!!!!!!!! Case of the mono excitations - enddo ! ispin - enddo ! rorb - enddo ! iorb - - do i = 1, n_inact_orb ! First inactive - iorb = list_inact(i) - do r = 1, n_virt_orb ! First virtual - rorb = list_virt(r) - do ispin = 1, 2 ! spin of the couple a-a^dagger (i,r) - do inint = 1, N_int - det_tmp(inint,1) = det_pert(inint,1,i,r,ispin) - det_tmp(inint,2) = det_pert(inint,2,i,r,ispin) - enddo - do j = 1, n_inact_orb ! First inactive - jorb = list_inact(j) - do s = 1, n_virt_orb ! First virtual - sorb = list_virt(s) - do jspin = 1, 2 ! spin of the couple a-a^dagger (i,r) - if(i==j.and.r==s.and.ispin==jspin)cycle - do inint = 1, N_int - det_tmp_bis(inint,1) = det_pert(inint,1,j,s,jspin) - det_tmp_bis(inint,2) = det_pert(inint,2,j,s,jspin) - enddo - call i_H_j(det_tmp_bis,det_tmp,N_int,himono) - do state_target = 1, N_states - coef_det_pert(i,r,ispin,state_target,2) += & - coef_det_pert(j,s,jspin,state_target,1) * himono / delta_e_det_pert(i,r,ispin,state_target) - enddo - enddo - enddo - enddo - enddo ! ispin - enddo ! rorb - enddo ! iorb - do i = 1, n_inact_orb ! First inactive - iorb = list_inact(i) - do r = 1, n_virt_orb ! First virtual - rorb = list_virt(r) - do ispin = 1, 2 ! spin of the couple a-a^dagger (i,r) - do state_target = 1, N_states - coef_det_pert(i,r,ispin,state_target,1) += coef_det_pert(i,r,ispin,state_target,2) - enddo - - do inint = 1, N_int - det_tmp(inint,1) = det_pert(inint,1,i,r,ispin) - det_tmp(inint,2) = det_pert(inint,2,i,r,ispin) - enddo - do jdet = 1, idx(0) -! - if(idx(jdet).ne.idet)then - call get_mono_excitation(psi_det(1,1,idet),psi_det(1,1,idx(jdet)),exc,phase,N_int) - if (exc(0,1,1) == 1) then - ! Mono alpha - aorb = (exc(1,2,1)) !!! a^{\dagger}_a - borb = (exc(1,1,1)) !!! a_{b} - jspin = 1 - else - aorb = (exc(1,2,2)) !!! a^{\dagger}_a - borb = (exc(1,1,2)) !!! a_{b} - jspin = 2 - endif - - call get_excitation_degree(psi_det(1,1,idx(jdet)),det_tmp,degree_scalar,N_int) - if(degree_scalar .ne. 2)then - print*, 'pb !!!' - print*, degree_scalar - call debug_det(psi_det(1,1,idx(jdet)),N_int) - call debug_det(det_tmp,N_int) - stop - endif - call get_double_excitation(psi_det(1,1,idx(jdet)),det_tmp,exc,phase,N_int) - double precision :: hij_test - hij_test = 0.d0 - call i_H_j(psi_det(1,1,idx(jdet)),det_tmp,N_int,hij_test) - do state_target = 1, N_states - matrix_1h1p(idx(jdet),idet,state_target) += hij_test* coef_det_pert(i,r,ispin,state_target,2) - enddo - else - hij_test = 0.d0 - call i_H_j(psi_det(1,1,idet),det_tmp,N_int,hij_test) - do state_target = 1, N_states - matrix_1h1p(idet,idet,state_target) += hij_test* coef_det_pert(i,r,ispin,state_target,2) - enddo - endif - enddo - enddo - enddo - enddo - - enddo ! idet -end - - -subroutine give_1p_sec_order_singles_contrib(matrix_1p) - use bitmasks - implicit none - double precision , intent(inout) :: matrix_1p(N_det,N_det,*) - integer :: i,j,r,a,b - integer :: iorb, jorb, rorb, aorb, borb,s,sorb - integer :: ispin,jspin - integer :: idet,jdet - integer :: inint - integer :: elec_num_tab_local(2),acu_elec - integer(bit_kind) :: det_tmp(N_int,2),det_tmp_bis(N_int,2) - integer(bit_kind) :: det_pert(N_int,2,n_act_orb,n_virt_orb,2) - double precision :: coef_det_pert(n_act_orb,n_virt_orb,2,N_states,2) - double precision :: delta_e_det_pert(n_act_orb,n_virt_orb,2,N_states) - double precision :: hij_det_pert(n_act_orb,n_virt_orb,2) - integer :: exc(0:2,2,2) - integer :: accu_elec - double precision :: get_mo_bielec_integral - double precision :: hij,phase - integer :: degree(N_det) - integer :: idx(0:N_det) - integer :: istate - double precision :: hja,delta_e_act_virt(N_states) - integer :: kspin,degree_scalar -!matrix_1p = 0.d0 - - elec_num_tab_local = 0 - do inint = 1, N_int - elec_num_tab_local(1) += popcnt(psi_det(inint,1,1)) - elec_num_tab_local(2) += popcnt(psi_det(inint,2,1)) - enddo - double precision :: himono,delta_e(N_states),coef_mono(N_states) - integer :: state_target - do idet = 1, N_det - call get_excitation_degree_vector_mono(psi_det,psi_det(1,1,idet),degree,N_int,N_det,idx) - do i = 1, n_act_orb ! First active - iorb = list_act(i) - do r = 1, n_virt_orb ! First virtual - rorb = list_virt(r) - do ispin = 1, 2 ! spin of the couple a-a^dagger (i,r) - do state_target = 1, N_states - coef_det_pert(i,r,ispin,state_target,1) = 0.d0 - coef_det_pert(i,r,ispin,state_target,2) = 0.d0 - enddo - do j = 1, N_states - delta_e_act_virt(j) = - fock_virt_total_spin_trace(rorb,j) - enddo - do inint = 1, N_int - det_tmp(inint,1) = psi_det(inint,1,idet) - det_tmp(inint,2) = psi_det(inint,2,idet) - enddo - ! Do the excitation active -- > virtual - call do_mono_excitation(det_tmp,iorb,rorb,ispin,i_ok) - integer :: i_ok - if(i_ok .ne.1)then - do state_target = 1, N_states - coef_det_pert(i,r,ispin,state_target,1) = -1.d+10 - coef_det_pert(i,r,ispin,state_target,2) = -1.d+10 - hij_det_pert(i,r,ispin) = 0.d0 - enddo - do inint = 1, N_int - det_pert(inint,1,i,r,ispin) = 0_bit_kind - det_pert(inint,2,i,r,ispin) = 0_bit_kind - enddo - cycle - endif - call i_H_j(psi_det(1,1,idet),det_tmp,N_int,himono) - do inint = 1, N_int - det_pert(inint,1,i,r,ispin) = det_tmp(inint,1) - det_pert(inint,2,i,r,ispin) = det_tmp(inint,2) - enddo - do state_target = 1, N_states - delta_e_det_pert(i,r,ispin,state_target) = one_creat_virt(i,r,state_target) + delta_e_act_virt(state_target) - coef_det_pert(i,r,ispin,state_target,1) = himono / delta_e_det_pert(i,r,ispin,state_target) - hij_det_pert(i,r,ispin) = himono - enddo - !!!!!!!!!!!!!!!!!!!!!!!!!!!!! Precomputation of matrix elements - !!!!!!!!!!!!!!!!!!!!!!!!!!!!! Case of the mono excitations - enddo ! ispin - enddo ! rorb - enddo ! iorb - -! do i = 1, n_act_orb ! First active -! do ispin = 1, 2 ! spin of the couple a-a^dagger (i,r) -! if(coef_det_pert(i,1,ispin,1,1) == -1.d+10)cycle -! iorb = list_act(i) -! do r = 1, n_virt_orb ! First virtual -! rorb = list_virt(r) -! do inint = 1, N_int -! det_tmp(inint,1) = det_pert(inint,1,i,r,ispin) -! det_tmp(inint,2) = det_pert(inint,2,i,r,ispin) -! enddo -! do j = 1, n_act_orb ! First active -! do jspin = 1, 2 ! spin of the couple a-a^dagger (i,r) -! if(coef_det_pert(j,1,jspin,1,1) == -1.d+10)cycle -! jorb = list_act(j) -! do s = 1, n_virt_orb ! First virtual -! sorb = list_virt(s) -! if(i==j.and.r==s.and.ispin==jspin)cycle -! do inint = 1, N_int -! det_tmp_bis(inint,1) = det_pert(inint,1,j,s,jspin) -! det_tmp_bis(inint,2) = det_pert(inint,2,j,s,jspin) -! enddo -! call i_H_j(det_tmp_bis,det_tmp,N_int,himono) -! do state_target = 1, N_states -! coef_det_pert(i,r,ispin,state_target,2) += & -! coef_det_pert(j,s,jspin,state_target,1) * himono / delta_e_det_pert(i,r,ispin,state_target) -! enddo -! enddo -! enddo -! enddo -! enddo ! ispin -! enddo ! rorb -! enddo ! iorb - - do i = 1, n_act_orb ! First active - do ispin = 1, 2 ! spin of the couple a-a^dagger (i,r) - if(coef_det_pert(i,1,ispin,1,1) == -1.d+10)cycle - iorb = list_act(i) - do r = 1, n_virt_orb ! First virtual - rorb = list_virt(r) -! do state_target = 1, N_states -! coef_det_pert(i,r,ispin,state_target,1) += coef_det_pert(i,r,ispin,state_target,2) -! enddo - do inint = 1, N_int - det_tmp(inint,1) = det_pert(inint,1,i,r,ispin) - det_tmp(inint,2) = det_pert(inint,2,i,r,ispin) - enddo - do jdet = 1,N_det - double precision :: coef_array(N_states),hij_test - call i_H_j(det_tmp,psi_det(1,1,jdet),N_int,himono) - call get_delta_e_dyall(psi_det(1,1,jdet),det_tmp,coef_array,hij_test,delta_e) - do state_target = 1, N_states -! matrix_1p(idet,jdet,state_target) += himono * coef_det_pert(i,r,ispin,state_target,1) - matrix_1p(idet,jdet,state_target) += himono * hij_det_pert(i,r,ispin) / delta_e(state_target) - enddo - enddo - enddo - enddo - enddo - - enddo ! idet -end - - - -subroutine give_1h1p_only_doubles_spin_cross(matrix_1h1p) - use bitmasks - implicit none - double precision , intent(inout) :: matrix_1h1p(N_det,N_det,*) - integer :: i,j,r,a,b - integer :: iorb, jorb, rorb, aorb, borb - integer :: ispin,jspin - integer :: idet,jdet - integer :: inint - integer :: elec_num_tab_local(2),acu_elec - integer(bit_kind) :: det_tmp(N_int,2) - integer :: exc(0:2,2,2) - integer :: accu_elec - double precision :: get_mo_bielec_integral - double precision :: active_int(n_act_orb,2) - double precision :: hij,phase - integer :: degree(N_det) - integer :: idx(0:N_det) - integer :: istate - double precision :: hja,delta_e_inact_virt(N_states) - integer(bit_kind) :: pert_det(N_int,2,n_act_orb,n_act_orb,2) - double precision :: pert_det_coef(n_act_orb,n_act_orb,2,N_states) - integer :: kspin,degree_scalar - integer :: other_spin(2) - other_spin(1) = 2 - other_spin(2) = 1 - double precision :: hidouble,delta_e(N_states) -!matrix_1h1p = 0.d0 - - elec_num_tab_local = 0 - do inint = 1, N_int - elec_num_tab_local(1) += popcnt(psi_det(inint,1,1)) - elec_num_tab_local(2) += popcnt(psi_det(inint,2,1)) - enddo - do i = 1, n_inact_orb ! First inactive - iorb = list_inact(i) - do r = 1, n_virt_orb ! First virtual - rorb = list_virt(r) - do j = 1, N_states - delta_e_inact_virt(j) = fock_core_inactive_total_spin_trace(iorb,j) & - - fock_virt_total_spin_trace(rorb,j) - enddo - do idet = 1, N_det - call get_excitation_degree_vector_double_alpha_beta(psi_det,psi_det(1,1,idet),degree,N_int,N_det,idx) - !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! Precomputation of matrix elements - !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! Case of the mono excitations - do ispin = 1, 2 - jspin = other_spin(ispin) - do a = 1, n_act_orb - aorb = list_act(a) - do b = 1, n_act_orb - borb = list_act(b) - do inint = 1, N_int - det_tmp(inint,1) = psi_det(inint,1,idet) - det_tmp(inint,2) = psi_det(inint,2,idet) - enddo - ! Do the excitation (i-->a)(ispin) + (b-->r)(other_spin(ispin)) - integer :: i_ok,corb,dorb - call do_mono_excitation(det_tmp,iorb,aorb,ispin,i_ok) - if(i_ok .ne. 1)then - do state_target = 1, N_states - pert_det_coef(a,b,ispin,state_target) = -100000.d0 - enddo - do inint = 1, N_int - pert_det(inint,1,a,b,ispin) = 0_bit_kind - pert_det(inint,2,a,b,ispin) = 0_bit_kind - enddo - cycle - endif - call do_mono_excitation(det_tmp,borb,rorb,jspin,i_ok) - if(i_ok .ne. 1)then - do state_target = 1, N_states - pert_det_coef(a,b,ispin,state_target) = -100000.d0 - enddo - do inint = 1, N_int - pert_det(inint,1,a,b,ispin) = 0_bit_kind - pert_det(inint,2,a,b,ispin) = 0_bit_kind - enddo - cycle - endif - do inint = 1, N_int - pert_det(inint,1,a,b,ispin) = det_tmp(inint,1) - pert_det(inint,2,a,b,ispin) = det_tmp(inint,2) - enddo - - call i_H_j(psi_det(1,1,idet),det_tmp,N_int,hidouble) - do state_target = 1, N_states - delta_e(state_target) = one_anhil_one_creat(a,b,ispin,jspin,state_target) + delta_e_inact_virt(state_target) - pert_det_coef(a,b,ispin,state_target) = hidouble / delta_e(state_target) - matrix_1h1p(idet,idet,state_target) += hidouble * pert_det_coef(a,b,ispin,state_target) - enddo - enddo - enddo - enddo - do jdet = 1, idx(0) - if(idx(jdet).ne.idet)then - call get_double_excitation(psi_det(1,1,idet),psi_det(1,1,idx(jdet)),exc,phase,N_int) - integer :: c,d,state_target - integer(bit_kind) :: det_tmp_bis(N_int,2) - ! excitation from I --> J - ! (a->c) (alpha) + (b->d) (beta) - aorb = exc(1,1,1) - corb = exc(1,2,1) - c = list_act_reverse(corb) - borb = exc(1,1,2) - dorb = exc(1,2,2) - d = list_act_reverse(dorb) - ispin = 1 - jspin = 2 - do inint = 1, N_int - det_tmp(inint,1) = pert_det(inint,1,c,d,1) - det_tmp(inint,2) = pert_det(inint,2,c,d,1) - det_tmp_bis(inint,1) = pert_det(inint,1,c,d,2) - det_tmp_bis(inint,2) = pert_det(inint,2,c,d,2) - enddo - double precision :: hjdouble_1,hjdouble_2 - call i_H_j(psi_det(1,1,idx(jdet)),det_tmp,N_int,hjdouble_1) - call i_H_j(psi_det(1,1,idx(jdet)),det_tmp_bis,N_int,hjdouble_2) - do state_target = 1, N_states - matrix_1h1p(idx(jdet),idet,state_target) += (pert_det_coef(c,d,1,state_target) * hjdouble_1 + pert_det_coef(c,d,2,state_target) * hjdouble_2 ) - enddo - endif - enddo - - - - enddo - enddo - enddo - - - - - -end - - diff --git a/plugins/MRPT_Utils/new_way_second_order_coef.irp.f b/plugins/MRPT_Utils/new_way_second_order_coef.irp.f deleted file mode 100644 index 4c12dbe1..00000000 --- a/plugins/MRPT_Utils/new_way_second_order_coef.irp.f +++ /dev/null @@ -1,796 +0,0 @@ -subroutine give_2h1p_contrib_sec_order(matrix_2h1p) - use bitmasks - implicit none - double precision , intent(inout) :: matrix_2h1p(N_det,N_det,*) - integer :: i,j,r,a,b - integer :: iorb, jorb, rorb, aorb, borb - integer :: ispin,jspin - integer :: idet,jdet - integer(bit_kind) :: perturb_dets(N_int,2,n_act_orb,2,2) - double precision :: perturb_dets_phase(n_act_orb,2,2) - double precision :: perturb_dets_hij(n_act_orb,2,2) - double precision :: coef_perturb_from_idet(n_act_orb,2,2,N_states,3) - integer :: inint - integer :: elec_num_tab_local(2),acu_elec - integer(bit_kind) :: det_tmp(N_int,2) - integer(bit_kind) :: det_tmp_j(N_int,2) - integer :: exc(0:2,2,2) - integer :: accu_elec - double precision :: get_mo_bielec_integral - double precision :: active_int(n_act_orb,2) - double precision :: hij,phase - integer :: index_orb_act_mono(N_det,6) -!matrix_2h1p = 0.d0 - - elec_num_tab_local = 0 - do inint = 1, N_int - elec_num_tab_local(1) += popcnt(psi_det(inint,1,1)) - elec_num_tab_local(2) += popcnt(psi_det(inint,2,1)) - enddo - do i = 1, n_inact_orb ! First inactive - iorb = list_inact(i) - do j = 1, n_inact_orb ! Second inactive - jorb = list_inact(j) - do r = 1, n_virt_orb ! First virtual - rorb = list_virt(r) - ! take all the integral you will need for i,j,r fixed - do a = 1, n_act_orb - aorb = list_act(a) - active_int(a,1) = get_mo_bielec_integral(iorb,jorb,rorb,aorb,mo_integrals_map) ! direct - active_int(a,2) = get_mo_bielec_integral(iorb,jorb,aorb,rorb,mo_integrals_map) ! exchange - perturb_dets_phase(a,1,1) = -1000.d0 - perturb_dets_phase(a,1,2) = -1000.d0 - perturb_dets_phase(a,2,2) = -1000.d0 - perturb_dets_phase(a,2,1) = -1000.d0 - enddo - - integer :: degree(N_det) - integer :: idx(0:N_det) - double precision :: delta_e(n_act_orb,2,N_states) - integer :: istate - - do idet = 1, N_det - call get_excitation_degree_vector_mono_or_exchange(psi_det,psi_det(1,1,idet),degree,N_int,N_det,idx) -! if(idet == 81)then -! call get_excitation_degree_vector_mono_or_exchange_verbose(psi_det(1,1,1),psi_det(1,1,idet),degree,N_int,N_det,idx) -! endif - !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! Precomputation of matrix elements - do ispin = 1, 2 ! spin of the couple a-a^dagger (i,r) - do jspin = 1, 2 ! spin of the couple z-a^dagger (j,a) - if(ispin == jspin .and. iorb.le.jorb)cycle ! condition not to double count - do a = 1, n_act_orb ! First active - aorb = list_act(a) - do inint = 1, N_int - det_tmp(inint,1) = psi_det(inint,1,idet) - det_tmp(inint,2) = psi_det(inint,2,idet) - enddo - ! Do the excitation inactive -- > virtual - call clear_bit_to_integer(iorb,det_tmp(1,ispin),N_int) ! hole in "iorb" of spin Ispin - call set_bit_to_integer(rorb,det_tmp(1,ispin),N_int) ! particle in "rorb" of spin Ispin - - ! Do the excitation inactive -- > active - call clear_bit_to_integer(jorb,det_tmp(1,jspin),N_int) ! hole in "jorb" of spin Jspin - call set_bit_to_integer(aorb,det_tmp(1,jspin),N_int) ! particle in "aorb" of spin Jspin - - ! Check if the excitation is possible or not on psi_det(idet) - accu_elec= 0 - do inint = 1, N_int - accu_elec+= popcnt(det_tmp(inint,jspin)) - enddo - if(accu_elec .ne. elec_num_tab_local(jspin))then - perturb_dets_phase(a,jspin,ispin) = -1000.d0 - perturb_dets_hij(a,jspin,ispin) = 0.d0 - do istate = 1, N_states - coef_perturb_from_idet(a,jspin,ispin,istate,1) = 0.d0 - coef_perturb_from_idet(a,jspin,ispin,istate,2) = 0.d0 - enddo - cycle - endif - do inint = 1, N_int - perturb_dets(inint,1,a,jspin,ispin) = det_tmp(inint,1) - perturb_dets(inint,2,a,jspin,ispin) = det_tmp(inint,2) - enddo - call get_double_excitation(psi_det(1,1,idet),det_tmp,exc,phase,N_int) - perturb_dets_phase(a,jspin,ispin) = phase - do istate = 1, N_states - delta_e(a,jspin,istate) = one_creat(a,jspin,istate) & - - fock_virt_total_spin_trace(rorb,istate) & - + fock_core_inactive_total_spin_trace(iorb,istate) & - + fock_core_inactive_total_spin_trace(jorb,istate) - enddo - if(ispin == jspin)then - perturb_dets_hij(a,jspin,ispin) = phase * (active_int(a,2) - active_int(a,1) ) - else - perturb_dets_hij(a,jspin,ispin) = phase * active_int(a,1) - endif -!!!!!!!!!!!!!!!!!!!!!1 Computation of the coefficient at first order coming from idet -!!!!!!!!!!!!!!!!!!!!! for the excitation (i,j)(ispin,jspin) ---> (r,a)(ispin,jspin) - do istate = 1, N_states - coef_perturb_from_idet(a,jspin,ispin,istate,1) = perturb_dets_hij(a,jspin,ispin) / delta_e(a,jspin,istate) - enddo - - enddo - enddo - enddo - - -!!!!!!!!!!!!!!!!!!!!!!!!!!! determination of the connections between I and the other J determinants mono excited in the CAS -!!!!!!!!!!!!!!!!!!!!!!!!!!!! the determinants I and J must be connected by the following operator -!!!!!!!!!!!!!!!!!!!!!!!!!!!! -!!!!!!!!!!!!!!!!!!!!!!!!!!!! - integer :: i_hole,i_part - double precision :: hij_test - double precision :: fock_operator_local(n_act_orb,n_act_orb,2) - do jdet = 1, idx(0) - if(idx(jdet).ne.idet)then - if(degree(jdet)==1)then - call get_mono_excitation(psi_det(1,1,idet),psi_det(1,1,idx(jdet)),exc,phase,N_int) - if (exc(0,1,1) == 1) then - ! Mono alpha - i_hole = list_act_reverse(exc(1,1,1)) !!! a_a - i_part = list_act_reverse(exc(1,2,1)) !!! a^{\dagger}_{b} - kspin = 1 !!! kspin - index_orb_act_mono(idx(jdet),1) = i_hole - index_orb_act_mono(idx(jdet),2) = i_part - index_orb_act_mono(idx(jdet),3) = kspin - call i_H_j_dyall(psi_active(1,1,idet),psi_active(1,1,idx(jdet)),N_int,hij) - fock_operator_local(i_hole,i_part,kspin) = hij * phase ! phase less fock operator - fock_operator_local(i_part,i_hole,kspin) = hij * phase ! phase less fock operator - else - ! Mono beta - i_hole = list_act_reverse(exc(1,1,2)) !!! a_a - i_part = list_act_reverse(exc(1,2,2)) !!! a^{\dagger}_{b} - kspin = 2 !!! kspin - index_orb_act_mono(idx(jdet),1) = i_hole - index_orb_act_mono(idx(jdet),2) = i_part - index_orb_act_mono(idx(jdet),3) = kspin - call i_H_j_dyall(psi_active(1,1,idet),psi_active(1,1,idx(jdet)),N_int,hij) - fock_operator_local(i_hole,i_part,kspin) = hij * phase ! phase less fock operator - fock_operator_local(i_part,i_hole,kspin) = hij * phase ! phase less fock operator - endif - else if(degree(jdet)==2)then - call get_double_excitation(psi_det(1,1,idet),psi_det(1,1,idx(jdet)),exc,phase,N_int) - ! Mono alpha - index_orb_act_mono(idx(jdet),1) = list_act_reverse(exc(1,1,1)) !!! a_a - index_orb_act_mono(idx(jdet),2) = list_act_reverse(exc(1,2,1)) !!! a^{\dagger}_{b} - index_orb_act_mono(idx(jdet),3) = 1 - ! Mono beta - index_orb_act_mono(idx(jdet),4) = list_act_reverse(exc(1,1,2)) !!! a_a - index_orb_act_mono(idx(jdet),5) = list_act_reverse(exc(1,2,2)) !!! a^{\dagger}_{b} - index_orb_act_mono(idx(jdet),6) = 2 - endif - else - index_orb_act_mono(idx(jdet),1) = -1 - endif - enddo - - integer :: kspin - integer :: corb,i_ok - integer(bit_kind) :: det_tmp_bis(N_int,2) - double precision :: hib , hab , hja - double precision :: delta_e_ab(N_states) - double precision :: hib_test,hja_test,hab_test - do jdet = 1, idx(0) - if(idx(jdet).ne.idet)then -!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! CASE OF THE MONO EXCITATIONS - if(degree(jdet) == 1)then - ! ! two determinants | Idet > and | Jdet > which are connected throw a mono excitation operator - ! ! are connected by the presence of the perturbers determinants |det_tmp> - aorb = index_orb_act_mono(idx(jdet),1) ! a^{\dagger}_{aorb} - borb = index_orb_act_mono(idx(jdet),2) ! a_{borb} - kspin = index_orb_act_mono(idx(jdet),3) ! spin of the excitation - do ispin = 1, 2 ! you loop on all possible spin for the excitation - ! a^{\dagger}_r a_{i} (ispin) - ! ! the determinants Idet and Jdet interact throw the following operator - ! ! | Jdet > = a_{borb,kspin} a^{\dagger}_{aorb, kspin} | Idet > - do jspin = 1, 2 - if (jspin .ne. kspin)then - - do corb = 1, n_act_orb - if(perturb_dets_phase(corb,jspin,ispin).le.-100d0)cycle - ! ! | det_tmp > = a^{\dagger}_{rorb,ispin} a^{\dagger}_{corb,kspin} a_{jorb,kspin} a_{iorb,ispin} | Idet > - do inint = 1, N_int - det_tmp(inint,1) = perturb_dets(inint,1,corb,jspin,ispin) - det_tmp(inint,2) = perturb_dets(inint,2,corb,jspin,ispin) - det_tmp_bis(inint,1) = perturb_dets(inint,1,corb,jspin,ispin) - det_tmp_bis(inint,2) = perturb_dets(inint,2,corb,jspin,ispin) - enddo - ! ! < idet | H | det_tmp > = phase * (ir|cv) - call get_double_excitation(psi_det(1,1,idet),det_tmp,exc,phase,N_int) - if(ispin == jspin)then - hib= phase * (active_int(corb,1) - active_int(corb,2)) - else - hib= phase * active_int(corb,1) - endif - - ! | det_tmp_bis > = a^{\dagger}_{borb,kspin} a_{aorb,kspin} | det_tmp > - call do_mono_excitation(det_tmp_bis,list_act(aorb),list_act(borb),kspin,i_ok) - if(i_ok .ne. 1)cycle - call get_mono_excitation(det_tmp,det_tmp_bis,exc,phase,N_int) - - ! < det_tmp | H | det_tmp_bis > = F_{aorb,borb} - hab = (fock_operator_local(aorb,borb,kspin) ) * phase - if(isnan(hab))then - print*, '1' - stop - endif - ! < jdet | H | det_tmp_bis > = phase * (ir|cv) - call get_double_excitation(det_tmp_bis,psi_det(1,1,idx(jdet)),exc,phase,N_int) - if(ispin == jspin)then - hja= phase * (active_int(corb,1) - active_int(corb,2)) - else - hja= phase * (active_int(corb,1)) - endif - do istate = 1, N_states - delta_e_ab(istate) = delta_e(corb,jspin,istate) + one_anhil_one_creat(borb,aorb,kspin,kspin,istate) - matrix_2h1p(idx(jdet),idet,istate) = matrix_2h1p(idx(jdet),idet,istate) + & - hib / delta_e(corb,jspin,istate) * hab / delta_e_ab(istate) * hja - ! ! < det_tmp | H | Idet > / delta_E (Idet --> det_tmp ) - ! ! < det_tmp | H | det_tmp_bis > / delta_E (Idet --> det_tmp --> det_tmp_bis) - ! ! < det_tmp_bis | H | Jdet > - enddo - enddo ! corb - else - if(ispin == kspin .and. iorb.le.jorb)cycle ! condition not to double count - do corb = 1, n_act_orb - if(corb == aorb .or. corb == borb) cycle - if(perturb_dets_phase(corb,jspin,ispin).le.-100d0)cycle - ! ! | det_tmp > = a^{\dagger}_{rorb,ispin} a^{\dagger}_{vorb,kspin} a_{corb,jspin} a_{iorb,ispin} | Idet > - do inint = 1, N_int - det_tmp(inint,1) = perturb_dets(inint,1,corb,jspin,ispin) - det_tmp(inint,2) = perturb_dets(inint,2,corb,jspin,ispin) - det_tmp_bis(inint,1) = perturb_dets(inint,1,corb,jspin,ispin) - det_tmp_bis(inint,2) = perturb_dets(inint,2,corb,jspin,ispin) - enddo - ! < idet | H | det_tmp > = phase * ( (ir|cv) - (iv|cr) ) - call get_double_excitation(psi_det(1,1,idet),det_tmp,exc,phase,N_int) - if(ispin == jspin)then - hib= phase * (active_int(corb,1) - active_int(corb,2)) - else - hib= phase * active_int(corb,1) - endif - ! | det_tmp_bis > = a^{\dagger}_{borb,kspin} a_{aorb,kspin} | det_tmp > - call do_mono_excitation(det_tmp_bis,list_act(aorb),list_act(borb),kspin,i_ok) - if(i_ok .ne. 1)cycle - call get_mono_excitation(det_tmp,det_tmp_bis,exc,phase,N_int) -! ! < det_tmp | H | det_tmp_bis > = F_{aorb,borb} - hab = fock_operator_local(aorb,borb,kspin) * phase - if(isnan(hab))then - print*, '2' - stop - endif - ! < jdet | H | det_tmp_bis > = phase * ( (ir|cv) - (iv|cr) ) - call get_double_excitation(det_tmp_bis,psi_det(1,1,idx(jdet)),exc,phase,N_int) - if(ispin == jspin)then - hja= phase * (active_int(corb,1) - active_int(corb,2)) - else - hja= phase * (active_int(corb,1)) - endif - do istate = 1, N_states - delta_e_ab(istate) = delta_e(corb,jspin,istate) + one_anhil_one_creat(borb,aorb,kspin,kspin,istate) - matrix_2h1p(idx(jdet),idet,istate) = matrix_2h1p(idx(jdet),idet,istate) + & - hib / delta_e(corb,jspin,istate) * hab / delta_e_ab(istate) * hja - ! ! < det_tmp | H | Idet > / delta_E (Idet --> det_tmp ) - ! ! < det_tmp | H | det_tmp_bis > / delta_E (Idet --> det_tmp --> det_tmp_bis) - ! ! < det_tmp_bis | H | Jdet > - enddo - enddo ! corb - endif - enddo - enddo - ! - else !! Double excitation operators - ! - if (index_orb_act_mono(idx(jdet),1) == index_orb_act_mono(idx(jdet),5))then !! spin exchange - do ispin = 1, 2 ! you loop on all possible spin for the excitation - ! a^{\dagger}_r a_{i} (ispin) - !!! ! first combination of spin :: | det_tmp > = a^{\dagger}_{aorb,beta} | Idet > - jspin = 2 - aorb = index_orb_act_mono(idx(jdet),1) ! hole of the alpha electron - borb = index_orb_act_mono(idx(jdet),2) ! particle of the alpha electron - if(perturb_dets_phase(aorb,jspin,ispin).le.-100d0)cycle - do inint = 1, N_int - det_tmp(inint,1) = perturb_dets(inint,1,aorb,jspin,ispin) - det_tmp(inint,2) = perturb_dets(inint,2,aorb,jspin,ispin) - det_tmp_bis(inint,1) = perturb_dets(inint,1,aorb,jspin,ispin) - det_tmp_bis(inint,2) = perturb_dets(inint,2,aorb,jspin,ispin) - enddo - ! | det_tmp > = a^{\dagger}_{aorb,beta} | Idet > - call get_double_excitation(det_tmp,psi_det(1,1,idet),exc,phase,N_int) - if(ispin == jspin)then - hib= phase * (active_int(aorb,1) - active_int(aorb,2)) - else - hib= phase * (active_int(aorb,1)) - endif - if(hib .ne. perturb_dets_hij(aorb,jspin,ispin))then - print*, 'pb !!' - print*, 'hib .ne. perturb_dets_hij(aorb,jspin,ispin)' - stop - endif - enddo !! ispin - - else if(index_orb_act_mono(idx(jdet),1) == index_orb_act_mono(idx(jdet),4))then !! closed shell double excitation - - else - call get_excitation(psi_det(1,1,idet),psi_det(1,1,idx(jdet)),exc,degree_scalar,phase,N_int) - integer :: h1,h2,p1,p2,s1,s2 , degree_scalar - call decode_exc(exc,degree,h1,p1,h2,p2,s1,s2) - print*, h1,p1,h2,p2,s1,s2 - call debug_det(psi_det(1,1,idet),N_int) - call debug_det(psi_det(1,1,idx(jdet)),N_int) - print*, idet,idx(jdet) - print*, 'pb !!!!!!!!!!!!!' - call get_excitation_degree_vector_mono_or_exchange_verbose(psi_det(1,1,1),psi_det(1,1,idet),degree,N_int,N_det,idx) - stop - endif - endif - - else - !! diagonal part of the dressing : interaction of | Idet > with all the perturbers generated by the excitations - !! - !! | det_tmp > = a^{\dagger}_{rorb,ispin} a^{\dagger}_{aorb,kspin} a_{jorb,kspin} a_{iorb,ispin} | Idet > - !!do ispin = 1, 2 - !! do kspin = 1, 2 - !! if(ispin == kspin .and. iorb.le.jorb)cycle ! condition not to double count - !! do a = 1, n_act_orb ! First active - !! do istate = 1, N_states - !! matrix_2h1p(idet,idet,istate) += coef_perturb_from_idet(a,kspin,ispin,istate,2) * perturb_dets_hij(a,kspin,ispin) - !! enddo - !! enddo - !! enddo - !!enddo - ! - endif - - enddo - enddo - enddo - enddo - enddo - - - - - -end - - -subroutine give_1h2p_contrib_sec_order(matrix_1h2p) - use bitmasks - implicit none - double precision , intent(inout) :: matrix_1h2p(N_det,N_det,*) - integer :: i,v,r,a,b,c - integer :: iorb, vorb, rorb, aorb, borb,corb - integer :: ispin,jspin - integer :: idet,jdet - integer(bit_kind) :: perturb_dets(N_int,2,n_act_orb,2,2) - double precision :: perturb_dets_phase(n_act_orb,2,2) - double precision :: perturb_dets_hij(n_act_orb,2,2) - double precision :: perturb_dets_hpsi0(n_act_orb,2,2,N_states) - double precision :: coef_perturb_from_idet(n_act_orb,2,2,N_states,2) - logical :: already_generated(n_act_orb,2,2) - integer :: inint - integer :: elec_num_tab_local(2),acu_elec - integer(bit_kind) :: det_tmp(N_int,2) - integer(bit_kind) :: det_tmp_j(N_int,2) - integer :: exc(0:2,2,2) - integer :: accu_elec - double precision :: get_mo_bielec_integral - double precision :: active_int(n_act_orb,2) - double precision :: hij,phase - double precision :: accu_contrib - integer :: degree(N_det) - integer :: idx(0:N_det) - double precision :: delta_e(n_act_orb,2,N_states) - integer :: istate - integer :: index_orb_act_mono(N_det,6) - double precision :: delta_e_inactive_virt(N_states) - integer :: kspin - double precision :: delta_e_ja(N_states) - double precision :: hja - double precision :: contrib_hij - double precision :: fock_operator_local(n_act_orb,n_act_orb,2) - double precision :: fock_operator_from_core(n_act_orb,n_act_orb) - double precision :: fock_operator_from_virt(n_act_orb,n_act_orb) - double precision :: fock_operator_from_act(n_act_orb,n_act_orb,n_act_orb,2) - accu_contrib = 0.d0 -!matrix_1h2p = 0.d0 - - elec_num_tab_local = 0 - do inint = 1, N_int - elec_num_tab_local(1) += popcnt(psi_det(inint,1,1)) - elec_num_tab_local(2) += popcnt(psi_det(inint,2,1)) - enddo - do i = 1, n_inact_orb ! First inactive - iorb = list_inact(i) - do v = 1, n_virt_orb ! First virtual - vorb = list_virt(v) - do r = 1, n_virt_orb ! Second virtual - rorb = list_virt(r) - ! take all the integral you will need for i,j,r fixed - do a = 1, n_act_orb - aorb = list_act(a) - active_int(a,1) = get_mo_bielec_integral(iorb,aorb,rorb,vorb,mo_integrals_map) ! direct - active_int(a,2) = get_mo_bielec_integral(iorb,aorb,vorb,rorb,mo_integrals_map) ! exchange - perturb_dets_phase(a,1,1) = -1000.d0 - perturb_dets_phase(a,1,2) = -1000.d0 - perturb_dets_phase(a,2,2) = -1000.d0 - perturb_dets_phase(a,2,1) = -1000.d0 - already_generated(a,1,1) = .False. - already_generated(a,1,2) = .False. - already_generated(a,2,2) = .False. - already_generated(a,2,1) = .False. - enddo - - - do istate = 1, N_states - delta_e_inactive_virt(istate) = & - - fock_virt_total_spin_trace(rorb,istate) & - - fock_virt_total_spin_trace(vorb,istate) & - + fock_core_inactive_total_spin_trace(iorb,istate) - enddo - do idet = 1, N_det - call get_excitation_degree_vector_mono_or_exchange(psi_det,psi_det(1,1,idet),degree,N_int,N_det,idx) - !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! Precomputation of matrix elements - do ispin = 1, 2 ! spin of the couple a-a^dagger (iorb,rorb) - do jspin = 1, 2 ! spin of the couple a-a^dagger (aorb,vorb) - do a = 1, n_act_orb ! First active - aorb = list_act(a) - do istate = 1, N_states - perturb_dets_hpsi0(a,jspin,ispin,istate) = 0.d0 - coef_perturb_from_idet(a,jspin,ispin,istate,1) = 0.d0 - coef_perturb_from_idet(a,jspin,ispin,istate,2) = 0.d0 - enddo - if(ispin == jspin .and. vorb.le.rorb)cycle ! condition not to double count - do inint = 1, N_int - det_tmp(inint,1) = psi_det(inint,1,idet) - det_tmp(inint,2) = psi_det(inint,2,idet) - enddo - ! Do the excitation inactive -- > virtual - call clear_bit_to_integer(iorb,det_tmp(1,ispin),N_int) ! hole in "iorb" of spin Ispin - call set_bit_to_integer(rorb,det_tmp(1,ispin),N_int) ! particle in "rorb" of spin Ispin - - ! Do the excitation active -- > virtual - call clear_bit_to_integer(aorb,det_tmp(1,jspin),N_int) ! hole in "aorb" of spin Jspin - call set_bit_to_integer(vorb,det_tmp(1,jspin),N_int) ! particle in "vorb" of spin Jspin - - ! Check if the excitation is possible or not on psi_det(idet) - accu_elec= 0 - do inint = 1, N_int - accu_elec+= popcnt(det_tmp(inint,jspin)) - enddo - if(accu_elec .ne. elec_num_tab_local(jspin))then - perturb_dets_phase(a,jspin,ispin) = -1000.0d0 - perturb_dets_hij(a,jspin,ispin) = 0.d0 - do istate = 1, N_states - coef_perturb_from_idet(a,jspin,ispin,istate,1) = 0.d0 - coef_perturb_from_idet(a,jspin,ispin,istate,2) = 0.d0 - enddo - cycle - endif - do inint = 1, N_int - perturb_dets(inint,1,a,jspin,ispin) = det_tmp(inint,1) - perturb_dets(inint,2,a,jspin,ispin) = det_tmp(inint,2) - enddo - do inint = 1, N_int - det_tmp(inint,1) = perturb_dets(inint,1,a,jspin,ispin) - det_tmp(inint,2) = perturb_dets(inint,2,a,jspin,ispin) - enddo - - call get_double_excitation(psi_det(1,1,idet),det_tmp,exc,phase,N_int) - perturb_dets_phase(a,jspin,ispin) = phase - - do istate = 1, N_states - delta_e(a,jspin,istate) = one_anhil(a,jspin,istate) + delta_e_inactive_virt(istate) - enddo - if(ispin == jspin)then - perturb_dets_hij(a,jspin,ispin) = phase * (active_int(a,1) - active_int(a,2) ) - else - perturb_dets_hij(a,jspin,ispin) = phase * active_int(a,1) - endif - enddo - enddo - enddo - -!!!!!!!!!!!!!!!!!!!!!!!!!!! determination of the connections between I and the other J determinants mono excited in the CAS -!!!!!!!!!!!!!!!!!!!!!!!!!!!! the determinants I and J must be connected by the following operator -!!!!!!!!!!!!!!!!!!!!!!!!!!!! -!!!!!!!!!!!!!!!!!!!!!!!!!!!! - integer :: i_hole,i_part - double precision :: hij_test - do jdet = 1, idx(0) - if(idx(jdet).ne.idet)then - if(degree(jdet)==1)then - call get_mono_excitation(psi_det(1,1,idet),psi_det(1,1,idx(jdet)),exc,phase,N_int) - if (exc(0,1,1) == 1) then - ! Mono alpha - i_hole = list_act_reverse(exc(1,1,1)) !!! a_a - i_part = list_act_reverse(exc(1,2,1)) !!! a^{\dagger}_{b} - kspin = 1 !!! kspin - index_orb_act_mono(idx(jdet),1) = i_hole - index_orb_act_mono(idx(jdet),2) = i_part - index_orb_act_mono(idx(jdet),3) = kspin - call i_H_j_dyall(psi_active(1,1,idet),psi_active(1,1,idx(jdet)),N_int,hij) - fock_operator_local(i_hole,i_part,kspin) = hij * phase ! phase less fock operator - fock_operator_local(i_part,i_hole,kspin) = hij * phase ! phase less fock operator - else - ! Mono beta - i_hole = list_act_reverse(exc(1,1,2)) !!! a_a - i_part = list_act_reverse(exc(1,2,2)) !!! a^{\dagger}_{b} - kspin = 2 !!! kspin - index_orb_act_mono(idx(jdet),1) = i_hole - index_orb_act_mono(idx(jdet),2) = i_part - index_orb_act_mono(idx(jdet),3) = kspin - call i_H_j_dyall(psi_active(1,1,idet),psi_active(1,1,idx(jdet)),N_int,hij) - fock_operator_local(i_hole,i_part,kspin) = hij * phase ! phase less fock operator - fock_operator_local(i_part,i_hole,kspin) = hij * phase ! phase less fock operator - endif - else if(degree(jdet)==2)then - call get_double_excitation(psi_det(1,1,idet),psi_det(1,1,idx(jdet)),exc,phase,N_int) - ! Mono alpha - index_orb_act_mono(idx(jdet),1) = list_act_reverse(exc(1,1,1)) !!! a_a - index_orb_act_mono(idx(jdet),2) = list_act_reverse(exc(1,2,1)) !!! a^{\dagger}_{b} - index_orb_act_mono(idx(jdet),3) = 1 - ! Mono beta - index_orb_act_mono(idx(jdet),4) = list_act_reverse(exc(1,1,2)) !!! a_a - index_orb_act_mono(idx(jdet),5) = list_act_reverse(exc(1,2,2)) !!! a^{\dagger}_{b} - index_orb_act_mono(idx(jdet),6) = 2 - endif - else - index_orb_act_mono(idx(jdet),1) = -1 - endif - enddo - - integer ::dorb,i_ok - integer(bit_kind) :: det_tmp_bis(N_int,2) - double precision :: hib , hab - double precision :: delta_e_ab(N_states) - double precision :: hib_test,hja_test,hab_test - - - do jdet = 1, idx(0) - if(idx(jdet).ne.idet)then -!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! CASE OF THE MONO EXCITATIONS - if(degree(jdet) == 1)then - ! two determinants | Idet > and | Jdet > which are connected throw a mono excitation operator - ! are connected by the presence of the perturbers determinants |det_tmp> - aorb = index_orb_act_mono(idx(jdet),1) ! a_{aorb} - borb = index_orb_act_mono(idx(jdet),2) ! a^{\dagger}_{borb} - kspin = index_orb_act_mono(idx(jdet),3) ! spin of the excitation - ! the determinants Idet and Jdet interact throw the following operator - ! | Jdet > = a^{\dagger}_{borb,kspin} a_{aorb, kspin} | Idet > - - do ispin = 1, 2 ! you loop on all possible spin for the excitation - ! a^{\dagger}_r a_{i} (ispin) - if(ispin == kspin .and. vorb.le.rorb)cycle ! condition not to double count - do jspin = 1, 2 - if (jspin .ne. kspin)then - do corb = 1, n_act_orb - if(perturb_dets_phase(corb,jspin,ispin).le.-100d0)cycle - ! | det_tmp > = a^{\dagger}_{rorb,ispin} a^{\dagger}_{vorb,kspin} a_{corb,kspin} a_{iorb,ispin} | Idet > - do inint = 1, N_int - det_tmp(inint,1) = perturb_dets(inint,1,corb,jspin,ispin) - det_tmp(inint,2) = perturb_dets(inint,2,corb,jspin,ispin) - det_tmp_bis(inint,1) = perturb_dets(inint,1,corb,jspin,ispin) - det_tmp_bis(inint,2) = perturb_dets(inint,2,corb,jspin,ispin) - enddo - ! < idet | H | det_tmp > = phase * (ir|cv) - call get_double_excitation(psi_det(1,1,idet),det_tmp,exc,phase,N_int) - if(ispin == jspin)then - hib= phase * (active_int(corb,1) - active_int(corb,2)) - else - hib= phase * active_int(corb,1) - endif - - ! | det_tmp_bis > = a^{\dagger}_{borb,kspin} a_{aorb,kspin} | det_tmp > - call do_mono_excitation(det_tmp_bis,list_act(aorb),list_act(borb),kspin,i_ok) - if(i_ok .ne. 1)cycle - call get_mono_excitation(det_tmp,det_tmp_bis,exc,phase,N_int) - - ! < det_tmp | H | det_tmp_bis > = F_{aorb,borb} - hab = (fock_operator_local(aorb,borb,kspin) ) * phase - ! < jdet | H | det_tmp_bis > = phase * (ir|cv) - call get_double_excitation(det_tmp_bis,psi_det(1,1,idx(jdet)),exc,phase,N_int) - if(ispin == jspin)then - hja= phase * (active_int(corb,1) - active_int(corb,2)) - else - hja= phase * (active_int(corb,1)) - endif - do istate = 1, N_states - delta_e_ab(istate) = delta_e(corb,jspin,istate) + one_anhil_one_creat(borb,aorb,kspin,kspin,istate) - matrix_1h2p(idx(jdet),idet,istate) = matrix_1h2p(idx(jdet),idet,istate) + & - hib / delta_e(corb,jspin,istate) * hab / delta_e_ab(istate) * hja - ! < det_tmp | H | Idet > / delta_E (Idet --> det_tmp ) - ! < det_tmp | H | det_tmp_bis > / delta_E (Idet --> det_tmp --> det_tmp_bis) - ! < det_tmp_bis | H | Jdet > - enddo - enddo ! corb - else - do corb = 1, n_act_orb - if(corb == aorb .or. corb == borb) cycle - if(perturb_dets_phase(corb,jspin,ispin).le.-100d0)cycle - ! | det_tmp > = a^{\dagger}_{rorb,ispin} a^{\dagger}_{vorb,kspin} a_{corb,jspin} a_{iorb,ispin} | Idet > - do inint = 1, N_int - det_tmp(inint,1) = perturb_dets(inint,1,corb,jspin,ispin) - det_tmp(inint,2) = perturb_dets(inint,2,corb,jspin,ispin) - det_tmp_bis(inint,1) = perturb_dets(inint,1,corb,jspin,ispin) - det_tmp_bis(inint,2) = perturb_dets(inint,2,corb,jspin,ispin) - enddo - ! < idet | H | det_tmp > = phase * ( (ir|cv) - (iv|cr) ) - call get_double_excitation(psi_det(1,1,idet),det_tmp,exc,phase,N_int) - if(ispin == jspin)then - hib= phase * (active_int(corb,1) - active_int(corb,2)) - else - hib= phase * active_int(corb,1) - endif - ! | det_tmp_bis > = a^{\dagger}_{borb,kspin} a_{aorb,kspin} | det_tmp > - call do_mono_excitation(det_tmp_bis,list_act(aorb),list_act(borb),kspin,i_ok) - if(i_ok .ne. 1)cycle - call get_mono_excitation(det_tmp,det_tmp_bis,exc,phase,N_int) -! ! < det_tmp | H | det_tmp_bis > = F_{aorb,borb} - hab = fock_operator_local(aorb,borb,kspin) * phase - ! < jdet | H | det_tmp_bis > = phase * ( (ir|cv) - (iv|cr) ) - call get_double_excitation(det_tmp_bis,psi_det(1,1,idx(jdet)),exc,phase,N_int) - if(ispin == jspin)then - hja= phase * (active_int(corb,1) - active_int(corb,2)) - else - hja= phase * (active_int(corb,1)) - endif - do istate = 1, N_states - delta_e_ab(istate) = delta_e(corb,jspin,istate) + one_anhil_one_creat(borb,aorb,kspin,kspin,istate) - matrix_1h2p(idx(jdet),idet,istate) = matrix_1h2p(idx(jdet),idet,istate) + & - hib / delta_e(corb,jspin,istate) * hab / delta_e_ab(istate) * hja - ! < det_tmp | H | Idet > / delta_E (Idet --> det_tmp ) - ! < det_tmp | H | det_tmp_bis > / delta_E (Idet --> det_tmp --> det_tmp_bis) - ! < det_tmp_bis | H | Jdet > - enddo - enddo ! corb - - endif - enddo ! jspin - enddo ! ispin - else -!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! Case of double excitations !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! - ! a^{\dagger}_r a_{i} (ispin) - aorb = index_orb_act_mono(idx(jdet),4) ! hole of a beta electron - borb = index_orb_act_mono(idx(jdet),5) ! propagation of the hole :: mono excitation of alpha spin - do ispin = 1, 2 ! you loop on all possible spin for the excitation - ! a^{\dagger}_r a_{i} (ispin) - ! ! first combination of spin :: | det_tmp > = a_{aorb,beta} | Idet > - jspin = 2 - if(perturb_dets_phase(aorb,jspin,ispin).le.-100d0)cycle - do inint = 1, N_int - det_tmp(inint,1) = perturb_dets(inint,1,aorb,jspin,ispin) - det_tmp(inint,2) = perturb_dets(inint,2,aorb,jspin,ispin) - det_tmp_bis(inint,1) = perturb_dets(inint,1,aorb,jspin,ispin) - det_tmp_bis(inint,2) = perturb_dets(inint,2,aorb,jspin,ispin) - enddo - call get_double_excitation(det_tmp,psi_det(1,1,idet),exc,phase,N_int) - if(ispin == jspin)then - hib= phase * (active_int(borb,1) - active_int(borb,2)) - else - hib= phase * (active_int(borb,1)) - endif - if( index_orb_act_mono(idx(jdet),1) == index_orb_act_mono(idx(jdet),5))then - call do_mono_excitation(det_tmp_bis,list_act(borb),list_act(aorb),1,i_ok) - if(i_ok .ne. 1)then - call debug_det(psi_det(1,1,idet),N_int) - call debug_det(psi_det(1,1,idx(jdet)),N_int) - print*, aorb, borb - call debug_det(det_tmp,N_int) - stop - endif - else - call do_mono_excitation(det_tmp_bis,list_act(aorb),list_act(borb),1,i_ok) - endif - - if(i_ok .ne. 1)cycle - call get_mono_excitation(det_tmp,det_tmp_bis,exc,phase,N_int) - ! < det_tmp | H | det_tmp_bis > = F_{aorb,borb} - if (aorb == borb)then - print*, 'iahaha' - stop - endif - hab = fock_operator_local(aorb,borb,1) * phase - call get_double_excitation(det_tmp_bis,psi_det(1,1,idx(jdet)),exc,phase,N_int) - if(ispin == jspin)then - hja= phase * (active_int(borb,1) - active_int(borb,2)) - else - hja= phase * (active_int(borb,1)) - endif - do istate = 1, N_states - delta_e_ab(istate) = delta_e(aorb,jspin,istate) + one_anhil_one_creat(borb,aorb,1,1,istate) - matrix_1h2p(idx(jdet),idet,istate) = matrix_1h2p(idx(jdet),idet,istate) + & - hib / delta_e(aorb,jspin,istate) * hab / delta_e_ab(istate) * hja - ! < det_tmp | H | Idet > / delta_E (Idet --> det_tmp ) - ! < det_tmp | H | det_tmp_bis > / delta_E (Idet --> det_tmp --> det_tmp_bis) - ! < det_tmp_bis | H | Jdet > - enddo !! istate - - ! ! second combination of spin :: | det_tmp > = a_{aorb,alpha} | Idet > - jspin = 1 - if(perturb_dets_phase(aorb,jspin,ispin).le.-100d0)cycle - do inint = 1, N_int - det_tmp(inint,1) = perturb_dets(inint,1,aorb,jspin,ispin) - det_tmp(inint,2) = perturb_dets(inint,2,aorb,jspin,ispin) - det_tmp_bis(inint,1) = perturb_dets(inint,1,aorb,jspin,ispin) - det_tmp_bis(inint,2) = perturb_dets(inint,2,aorb,jspin,ispin) - enddo - call get_double_excitation(det_tmp,psi_det(1,1,idet),exc,phase,N_int) - if(ispin == jspin)then - hib= phase * (active_int(borb,1) - active_int(borb,2)) - else - hib= phase * (active_int(borb,1)) - endif - if( index_orb_act_mono(idx(jdet),1) == index_orb_act_mono(idx(jdet),5))then - call do_mono_excitation(det_tmp_bis,list_act(borb),list_act(aorb),2,i_ok) - if(i_ok .ne. 1)then - call debug_det(psi_det(1,1,idet),N_int) - call debug_det(psi_det(1,1,idx(jdet)),N_int) - print*, aorb, borb - call debug_det(det_tmp,N_int) - stop - endif - else - call do_mono_excitation(det_tmp_bis,list_act(aorb),list_act(borb),2,i_ok) - endif - - if(i_ok .ne. 1)cycle - call get_mono_excitation(det_tmp,det_tmp_bis,exc,phase,N_int) - ! < det_tmp | H | det_tmp_bis > = F_{aorb,borb} - hab = fock_operator_local(aorb,borb,2) * phase - call get_double_excitation(det_tmp_bis,psi_det(1,1,idx(jdet)),exc,phase,N_int) - if(ispin == jspin)then - hja= phase * (active_int(borb,1) - active_int(borb,2)) - else - hja= phase * (active_int(borb,1)) - endif - do istate = 1, N_states - delta_e_ab(istate) = delta_e(aorb,jspin,istate) + one_anhil_one_creat(borb,aorb,1,1,istate) - matrix_1h2p(idx(jdet),idet,istate) = matrix_1h2p(idx(jdet),idet,istate) + & - hib / delta_e(aorb,jspin,istate) * hab / delta_e_ab(istate) * hja - ! < det_tmp | H | Idet > / delta_E (Idet --> det_tmp ) - ! < det_tmp | H | det_tmp_bis > / delta_E (Idet --> det_tmp --> det_tmp_bis) - ! < det_tmp_bis | H | Jdet > - enddo !! istate - enddo !! ispin - - - endif !! en of test if jdet is a single or a double excitation of type K_ab - - else !! jdet is idet - ! diagonal part of the dressing : interaction of | Idet > with all the perturbers generated by the excitations - ! - ! | det_tmp > = a^{\dagger}_{rorb,ispin} a^{\dagger}_{vorb,kspin} a_{aorb,kspin} a_{iorb,ispin} | Idet > - do ispin = 1, 2 - do kspin = 1, 2 - do a = 1, n_act_orb ! First active - if( perturb_dets_phase(a,kspin,ispin) .le. -10.d0)cycle - if(ispin == kspin .and. vorb.le.rorb)cycle ! condition not to double count - contrib_hij = perturb_dets_hij(a,kspin,ispin) * perturb_dets_hij(a,kspin,ispin) - do istate = 1, N_states -! matrix_1h2p(idet,idet,istate) += contrib_hij * delta_e(a,kspin,istate) -! perturb_dets_hpsi0(a,kspin,ispin,istate) += psi_coef(idet,istate) * perturb_dets_hij(a,kspin,ispin) -! coef_perturb_from_idet(a,kspin,ispin,istate,1) += psi_coef(idet,istate) & -! * perturb_dets_hij(a,kspin,ispin) * delta_e(a,kspin,istate) - enddo - enddo - enddo - enddo - - endif - - enddo !! jdet - - - enddo - enddo - enddo - enddo - - - - - -end - diff --git a/plugins/MRPT_Utils/psi_active_prov.irp.f b/plugins/MRPT_Utils/psi_active_prov.irp.f deleted file mode 100644 index 794742b4..00000000 --- a/plugins/MRPT_Utils/psi_active_prov.irp.f +++ /dev/null @@ -1,435 +0,0 @@ - - use bitmasks -BEGIN_PROVIDER [integer(bit_kind), psi_active, (N_int,2,psi_det_size)] - BEGIN_DOC -! active part of psi - END_DOC - implicit none - use bitmasks - integer :: i,j,k,l - provide cas_bitmask -!print*, 'psi_active ' - do i = 1, N_det - do j = 1, N_int - psi_active(j,1,i) = iand(psi_det(j,1,i),cas_bitmask(j,1,1)) - psi_active(j,2,i) = iand(psi_det(j,2,i),cas_bitmask(j,1,1)) - enddo - enddo -END_PROVIDER - - -subroutine give_holes_and_particles_in_active_space(det_1,det_2,n_holes_spin,n_particles_spin,n_holes,n_particles,& - holes_active_list,particles_active_list) - implicit none - use bitmasks - integer(bit_kind),intent(in) :: det_1(N_int,2) - integer(bit_kind),intent(in ) :: det_2(N_int,2) - integer, intent(out) :: n_holes_spin(2),n_particles_spin(2) - integer, intent(out) :: n_holes,n_particles - integer, intent(out) :: holes_active_list(2 * n_act_orb,2) - integer, intent(out) :: particles_active_list(2 * n_act_orb,2) - integer :: i - integer(bit_kind) :: holes(N_int,2) - integer(bit_kind) :: particles(N_int,2) - integer(bit_kind) :: det_tmp_2(N_int,2),det_tmp_1(N_int,2) - BEGIN_DOC -! returns the holes and particles operators WITHIN THE ACTIVE SPACE -! that connect det_1 and det_2. By definition, the holes/particles -! are such that one starts from det_1 and goes to det_2 -! -! n_holes is the total number of holes -! n_particles is the total number of particles -! n_holes_spin is the number of number of holes per spin (1=alpha, 2=beta) -! n_particles_spin is the number of number of particles per spin (1=alpha, 2=beta) -! holes_active_list is the index of the holes per spin, that ranges from 1 to n_act_orb -! particles_active_list is the index of the particles per spin, that ranges from 1 to n_act_orb - END_DOC - - call give_active_part_determinant(det_1,det_tmp_1) - call give_active_part_determinant(det_2,det_tmp_2) - do i = 1, N_int - holes(i,1) = iand(det_tmp_1(i,1),xor(det_tmp_1(i,1),det_tmp_2(i,1))) - holes(i,2) = iand(det_tmp_1(i,2),xor(det_tmp_1(i,2),det_tmp_2(i,2))) - particles(i,1) = iand(det_tmp_2(i,1),xor(det_tmp_1(i,1),det_tmp_2(i,1))) - particles(i,2) = iand(det_tmp_2(i,2),xor(det_tmp_1(i,2),det_tmp_2(i,2))) - enddo - - integer :: holes_list(N_int*bit_kind_size,2) - holes_list = 0 - call bitstring_to_list(holes(1,1), holes_list(1,1), n_holes_spin(1), N_int) - call bitstring_to_list(holes(1,2), holes_list(1,2), n_holes_spin(2), N_int) - - n_holes = 0 - do i = 1, n_holes_spin(1) - n_holes +=1 - holes_active_list(i,1) = list_act_reverse(holes_list(i,1)) - enddo - do i = 1, n_holes_spin(2) - n_holes +=1 - holes_active_list(i,2) = list_act_reverse(holes_list(i,2)) - enddo - - - integer :: particles_list(N_int*bit_kind_size,2) - particles_list = 0 - call bitstring_to_list(particles(1,1), particles_list(1,1), n_particles_spin(1), N_int) - call bitstring_to_list(particles(1,2), particles_list(1,2), n_particles_spin(2), N_int) - n_particles = 0 - do i = 1, n_particles_spin(1) - n_particles += 1 - particles_active_list(i,1) = list_act_reverse(particles_list(i,1)) - enddo - do i = 1, n_particles_spin(2) - n_particles += 1 - particles_active_list(i,2) = list_act_reverse(particles_list(i,2)) - enddo - -end - -subroutine give_holes_in_inactive_space(det_1,n_holes_spin,n_holes,holes_list) - BEGIN_DOC -! returns the holes operators WITHIN THE INACTIVE SPACE -! that has lead to det_1. -! -! n_holes is the total number of holes -! n_holes_spin is the number of number of holes per spin (1=alpha, 2=beta) -! holes_inactive_list is the index of the holes per spin, that ranges from 1 to mo_tot_num - END_DOC - implicit none - use bitmasks - integer(bit_kind),intent(in) :: det_1(N_int,2) - integer, intent(out) :: n_holes_spin(2) - integer, intent(out) :: n_holes - integer, intent(out) :: holes_list(N_int*bit_kind_size,2) - integer :: i - integer(bit_kind) :: holes(N_int,2) - integer(bit_kind) :: det_tmp_1(N_int,2) - - call give_core_inactive_part_determinant(det_1,det_tmp_1) - - do i = 1, N_int - holes(i,1) = iand(reunion_of_core_inact_bitmask(i,1),xor(det_tmp_1(i,1),reunion_of_core_inact_bitmask(i,1))) - holes(i,2) = iand(reunion_of_core_inact_bitmask(i,2),xor(det_tmp_1(i,2),reunion_of_core_inact_bitmask(i,2))) - enddo - holes_list = 0 - call bitstring_to_list(holes(1,1), holes_list(1,1), n_holes_spin(1), N_int) - call bitstring_to_list(holes(1,2), holes_list(1,2), n_holes_spin(2), N_int) - n_holes = n_holes_spin(1) + n_holes_spin(2) - -end - -subroutine give_particles_in_virt_space(det_1,n_particles_spin,n_particles,particles_list) - BEGIN_DOC -! returns the holes operators WITHIN THE VIRTUAL SPACE -! that has lead to det_1. -! -! n_particles is the total number of particles -! n_particles_spin is the number of number of particles per spin (1=alpha, 2=beta) -! particles_inactive_list is the index of the particles per spin, that ranges from 1 to mo_tot_num - END_DOC - implicit none - use bitmasks - integer(bit_kind),intent(in) :: det_1(N_int,2) - integer, intent(out) :: n_particles_spin(2) - integer, intent(out) :: n_particles - integer, intent(out) :: particles_list(N_int*bit_kind_size,2) - integer :: i - integer(bit_kind) :: det_tmp_1(N_int,2) - integer(bit_kind) :: particles(N_int,2) - - call give_virt_part_determinant(det_1,det_tmp_1) - - do i = 1, N_int - particles(i,1) = iand(virt_bitmask(i,1),det_tmp_1(i,1)) - particles(i,2) = iand(virt_bitmask(i,2),det_tmp_1(i,2)) - enddo - - particles_list = 0 - call bitstring_to_list(particles(1,1), particles_list(1,1), n_particles_spin(1), N_int) - call bitstring_to_list(particles(1,2), particles_list(1,2), n_particles_spin(2), N_int) - n_particles = n_particles_spin(1) + n_particles_spin(2) - - -end - -subroutine get_delta_e_dyall(det_1,det_2,coef_array,hij,delta_e_final) - BEGIN_DOC - ! routine that returns the delta_e with the Moller Plesset and Dyall operators - ! - ! with det_1 being a determinant from the cas, and det_2 being a perturber - ! - ! Delta_e(det_1,det_2) = sum (hole) epsilon(hole) + sum(part) espilon(part) + delta_e(act) - ! - ! where hole is necessary in the inactive, part necessary in the virtuals - ! - ! and delta_e(act) is obtained from the contracted application of the excitation - ! - ! operator in the active space that lead from det_1 to det_2 - END_DOC - implicit none - use bitmasks - double precision, intent(out) :: delta_e_final(N_states) - integer(bit_kind), intent(in) :: det_1(N_int,2),det_2(N_int,2) - double precision, intent(in) :: coef_array(N_states),hij - integer :: i,j,k,l - integer :: i_state - - integer :: n_holes_spin(2) - integer :: n_holes - integer :: holes_list(N_int*bit_kind_size,2) - - - 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 - do i = 1, n_holes_spin(1) - i_hole_inact = holes_list(i,1) - do i_state = 1, N_states - delta_e_inactive += fock_core_inactive_total_spin_trace(i_hole_inact,i_state) - enddo - enddo - - do i = 1, n_holes_spin(2) - i_hole_inact = holes_list(i,2) - do i_state = 1, N_states - delta_e_inactive(i_state) += fock_core_inactive_total_spin_trace(i_hole_inact,i_state) - enddo - enddo - - double precision :: delta_e_virt(N_states) - integer :: i_part_virt - integer :: n_particles_spin(2) - integer :: n_particles - integer :: particles_list(N_int*bit_kind_size,2) - - call give_particles_in_virt_space(det_2,n_particles_spin,n_particles,particles_list) - delta_e_virt = 0.d0 - do i = 1, n_particles_spin(1) - i_part_virt = particles_list(i,1) - do i_state = 1, N_states - delta_e_virt += fock_virt_total_spin_trace(i_part_virt,i_state) - enddo - enddo - - do i = 1, n_particles_spin(2) - i_part_virt = particles_list(i,2) - do i_state = 1, N_states - delta_e_virt += fock_virt_total_spin_trace(i_part_virt,i_state) - enddo - enddo - - - integer :: n_holes_spin_act(2),n_particles_spin_act(2) - integer :: n_holes_act,n_particles_act - integer :: holes_active_list(2*n_act_orb,2) - integer :: holes_active_list_spin_traced(4*n_act_orb) - integer :: particles_active_list(2*n_act_orb,2) - integer :: particles_active_list_spin_traced(4*n_act_orb) - double precision :: delta_e_act(N_states) - delta_e_act = 0.d0 - call give_holes_and_particles_in_active_space(det_1,det_2,n_holes_spin_act,n_particles_spin_act, & - n_holes_act,n_particles_act,holes_active_list,particles_active_list) - integer :: icount,icountbis - integer :: hole_list_practical(2,elec_num_tab(1)+elec_num_tab(2)), particle_list_practical(2,elec_num_tab(1)+elec_num_tab(2)) - icount = 0 - icountbis = 0 - do i = 1, n_holes_spin_act(1) - icount += 1 - icountbis += 1 - hole_list_practical(1,icountbis) = 1 - hole_list_practical(2,icountbis) = holes_active_list(i,1) - holes_active_list_spin_traced(icount) = holes_active_list(i,1) - enddo - do i = 1, n_holes_spin_act(2) - icount += 1 - icountbis += 1 - hole_list_practical(1,icountbis) = 2 - hole_list_practical(2,icountbis) = holes_active_list(i,2) - holes_active_list_spin_traced(icount) = holes_active_list(i,2) - enddo - if(icount .ne. n_holes_act) then - print*,'' - print*, icount, n_holes_act - print * , 'pb in holes_active_list_spin_traced !!' - stop - endif - - icount = 0 - icountbis = 0 - do i = 1, n_particles_spin_act(1) - icount += 1 - icountbis += 1 - particle_list_practical(1,icountbis) = 1 - particle_list_practical(2,icountbis) = particles_active_list(i,1) - particles_active_list_spin_traced(icount) = particles_active_list(i,1) - enddo - do i = 1, n_particles_spin_act(2) - icount += 1 - icountbis += 1 - particle_list_practical(1,icountbis) = 2 - particle_list_practical(2,icountbis) = particles_active_list(i,2) - particles_active_list_spin_traced(icount) = particles_active_list(i,2) - enddo - if(icount .ne. n_particles_act) then - print*, icount, n_particles_act - print * , 'pb in particles_active_list_spin_traced !!' - stop - endif - - - integer :: i_hole_act, j_hole_act, k_hole_act - integer :: i_particle_act, j_particle_act, k_particle_act - - - integer :: ispin,jspin,kspin - if (n_holes_act == 0 .and. n_particles_act == 1) then - ispin = particle_list_practical(1,1) - i_particle_act = particle_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_inact_reverse(h1) -! i_part = list_act_reverse(p1) -! do i_state = 1, N_states -! delta_e_act(i_state) += one_anhil_inact(i_hole,i_part,i_state) -! enddo -! else if (degree == 2)then - do i_state = 1, N_states - delta_e_act(i_state) += one_creat(i_particle_act,ispin,i_state) - enddo -! endif - - 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) - do i_state = 1, N_states - delta_e_act(i_state) += one_anhil(i_hole_act , ispin,i_state) - enddo - - else if (n_holes_act == 1 .and. n_particles_act == 1) then - ! first hole - ispin = hole_list_practical(1,1) - i_hole_act = hole_list_practical(2,1) - ! first particle - jspin = particle_list_practical(1,1) - i_particle_act = particle_list_practical(2,1) - do i_state = 1, N_states - delta_e_act(i_state) += one_anhil_one_creat(i_particle_act,i_hole_act,jspin,ispin,i_state) - enddo - - else if (n_holes_act == 2 .and. n_particles_act == 0) then - ispin = hole_list_practical(1,1) - i_hole_act = hole_list_practical(2,1) - jspin = hole_list_practical(1,2) - j_hole_act = hole_list_practical(2,2) - do i_state = 1, N_states - delta_e_act(i_state) += two_anhil(i_hole_act,j_hole_act,ispin,jspin,i_state) - enddo - - else if (n_holes_act == 0 .and. n_particles_act == 2) then - ispin = particle_list_practical(1,1) - i_particle_act = particle_list_practical(2,1) - jspin = particle_list_practical(1,2) - j_particle_act = particle_list_practical(2,2) - do i_state = 1, N_states - delta_e_act(i_state) += two_creat(i_particle_act,j_particle_act,ispin,jspin,i_state) - enddo - - else if (n_holes_act == 2 .and. n_particles_act == 1) then - ! first hole - ispin = hole_list_practical(1,1) - i_hole_act = hole_list_practical(2,1) - ! second hole - jspin = hole_list_practical(1,2) - j_hole_act = hole_list_practical(2,2) - ! first particle - kspin = particle_list_practical(1,1) - i_particle_act = particle_list_practical(2,1) - do i_state = 1, N_states - delta_e_act(i_state) += two_anhil_one_creat(i_particle_act,i_hole_act,j_hole_act,kspin,ispin,jspin,i_state) - enddo - - else if (n_holes_act == 1 .and. n_particles_act == 2) then - ! first hole - ispin = hole_list_practical(1,1) - i_hole_act = hole_list_practical(2,1) - ! first particle - jspin = particle_list_practical(1,1) - i_particle_act = particle_list_practical(2,1) - ! second particle - kspin = particle_list_practical(1,2) - j_particle_act = particle_list_practical(2,2) - - do i_state = 1, N_states - delta_e_act(i_state) += two_creat_one_anhil(i_particle_act,j_particle_act,i_hole_act,jspin,kspin,ispin,i_state) - enddo - - else if (n_holes_act == 3 .and. n_particles_act == 0) then - ! first hole - ispin = hole_list_practical(1,1) - i_hole_act = hole_list_practical(2,1) - ! second hole - jspin = hole_list_practical(1,2) - j_hole_act = hole_list_practical(2,2) - ! third hole - kspin = hole_list_practical(1,3) - k_hole_act = hole_list_practical(2,3) - do i_state = 1, N_states - delta_e_act(i_state) += three_anhil(i_hole_act,j_hole_act,k_hole_act,ispin,jspin,kspin,i_state) - enddo - - else if (n_holes_act == 0 .and. n_particles_act == 3) then - ! first particle - ispin = particle_list_practical(1,1) - i_particle_act = particle_list_practical(2,1) - ! second particle - jspin = particle_list_practical(1,2) - j_particle_act = particle_list_practical(2,2) - ! 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 - - else if (n_holes_act .eq. 0 .and. n_particles_act .eq.0)then - integer :: degree - integer(bit_kind) :: det_1_active(N_int,2) - integer :: h1,h2,p1,p2,s1,s2 - integer :: exc(0:2,2,2) - integer :: i_hole, i_part - double precision :: phase - 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_inact_reverse(h1) - i_part = list_virt_reverse(p1) - do i_state = 1, N_states - 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' -!print*, one_anhil_spin_trace(1), one_anhil_spin_trace(2) - - - 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 deleted file mode 100644 index ba3b421b..00000000 --- a/plugins/MRPT_Utils/second_order_new.irp.f +++ /dev/null @@ -1,757 +0,0 @@ - -subroutine give_1h2p_new(matrix_1h2p) - use bitmasks - implicit none - double precision , intent(inout) :: matrix_1h2p(N_det,N_det,*) - integer :: i,v,r,a,b,c - integer :: iorb, vorb, rorb, aorb, borb,corb - integer :: ispin,jspin - integer :: idet,jdet - integer(bit_kind) :: perturb_dets(N_int,2,n_act_orb,2,2) - double precision :: perturb_dets_phase(n_act_orb,2,2) - double precision :: perturb_dets_hij(n_act_orb,2,2) - double precision :: perturb_dets_hpsi0(n_act_orb,2,2,N_states) - logical :: already_generated(n_act_orb,2,2) - integer :: inint - integer :: elec_num_tab_local(2),acu_elec - integer(bit_kind) :: det_tmp(N_int,2) - integer(bit_kind) :: det_tmp_j(N_int,2) - integer :: exc(0:2,2,2) - integer :: accu_elec - double precision :: get_mo_bielec_integral - double precision :: active_int(n_act_orb,2) - double precision :: hij,phase - double precision :: accu_contrib(N_states) - integer :: degree(N_det) - integer :: idx(0:N_det) - double precision :: delta_e(n_act_orb,2,N_states) - double precision :: delta_e_inv(n_act_orb,2,N_states) - double precision :: delta_e_inactive_virt(N_states) - integer :: istate - integer :: index_orb_act_mono(N_det,6) - integer :: kspin - double precision :: delta_e_ja(N_states) - double precision :: hja - double precision :: contrib_hij - double precision :: fock_operator_local(n_act_orb,n_act_orb,2) - double precision :: hij_test - integer ::i_ok - integer(bit_kind) :: det_tmp_bis(N_int,2) - double precision :: hib , hab - double precision :: delta_e_ab(N_states) - double precision :: hib_test,hja_test,hab_test - integer :: i_hole,i_part - double precision :: hia,hjb - integer :: other_spin(2) - other_spin(1) = 2 - other_spin(2) = 1 - - accu_contrib = 0.d0 -!matrix_1h2p = 0.d0 - - elec_num_tab_local = 0 - do inint = 1, N_int - elec_num_tab_local(1) += popcnt(psi_det(inint,1,1)) - elec_num_tab_local(2) += popcnt(psi_det(inint,2,1)) - enddo - do i = 1, n_inact_orb ! First inactive - iorb = list_inact(i) - do v = 1, n_virt_orb ! First virtual - vorb = list_virt(v) - do r = 1, n_virt_orb ! Second virtual - rorb = list_virt(r) - ! take all the integral you will need for i,j,r fixed - do a = 1, n_act_orb - aorb = list_act(a) - active_int(a,1) = get_mo_bielec_integral(iorb,aorb,rorb,vorb,mo_integrals_map) ! direct - active_int(a,2) = get_mo_bielec_integral(iorb,aorb,vorb,rorb,mo_integrals_map) ! exchange - perturb_dets_phase(a,1,1) = -1000.d0 - perturb_dets_phase(a,1,2) = -1000.d0 - perturb_dets_phase(a,2,2) = -1000.d0 - perturb_dets_phase(a,2,1) = -1000.d0 - enddo - - - do istate = 1, N_states - delta_e_inactive_virt(istate) = & - - fock_virt_total_spin_trace(rorb,istate) & - - fock_virt_total_spin_trace(vorb,istate) & - + fock_core_inactive_total_spin_trace(iorb,istate) - enddo - do idet = 1, N_det - call get_excitation_degree_vector_mono_or_exchange(psi_det,psi_det(1,1,idet),degree,N_int,N_det,idx) - !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! Precomputation of matrix elements - do ispin = 1, 2 ! spin of the couple a-a^dagger (iorb,rorb) - do jspin = 1, 2 ! spin of the couple a-a^dagger (aorb,vorb) - do a = 1, n_act_orb ! First active - aorb = list_act(a) - do istate = 1, N_states - perturb_dets_hpsi0(a,jspin,ispin,istate) = 0.d0 - enddo - if(ispin == jspin .and. vorb.le.rorb)cycle ! condition not to double count - do inint = 1, N_int - det_tmp(inint,1) = psi_det(inint,1,idet) - det_tmp(inint,2) = psi_det(inint,2,idet) - enddo - ! Do the excitation inactive -- > virtual - call clear_bit_to_integer(iorb,det_tmp(1,ispin),N_int) ! hole in "iorb" of spin Ispin - call set_bit_to_integer(rorb,det_tmp(1,ispin),N_int) ! particle in "rorb" of spin Ispin - - ! Do the excitation active -- > virtual - call clear_bit_to_integer(aorb,det_tmp(1,jspin),N_int) ! hole in "aorb" of spin Jspin - call set_bit_to_integer(vorb,det_tmp(1,jspin),N_int) ! particle in "vorb" of spin Jspin - - ! Check if the excitation is possible or not on psi_det(idet) - accu_elec= 0 - do inint = 1, N_int - accu_elec+= popcnt(det_tmp(inint,jspin)) - enddo - if(accu_elec .ne. elec_num_tab_local(jspin))then - perturb_dets_phase(a,jspin,ispin) = -1000.0d0 - perturb_dets_hij(a,jspin,ispin) = 0.d0 - cycle - endif - do inint = 1, N_int - perturb_dets(inint,1,a,jspin,ispin) = det_tmp(inint,1) - perturb_dets(inint,2,a,jspin,ispin) = det_tmp(inint,2) - enddo - - call get_double_excitation(psi_det(1,1,idet),det_tmp,exc,phase,N_int) - perturb_dets_phase(a,jspin,ispin) = phase - - do istate = 1, N_states - delta_e(a,jspin,istate) = one_anhil(a,jspin,istate) + delta_e_inactive_virt(istate) - delta_e_inv(a,jspin,istate) = 1.d0 / delta_e(a,jspin,istate) - enddo - if(ispin == jspin)then - perturb_dets_hij(a,jspin,ispin) = phase * (active_int(a,1) - active_int(a,2) ) - else - perturb_dets_hij(a,jspin,ispin) = phase * active_int(a,1) - endif - enddo - enddo - enddo - -!!!!!!!!!!!!!!!!!!!!!!!!!!! determination of the connections between I and the other J determinants mono excited in the CAS -!!!!!!!!!!!!!!!!!!!!!!!!!!!! the determinants I and J must be connected by the following operator -!!!!!!!!!!!!!!!!!!!!!!!!!!!! -!!!!!!!!!!!!!!!!!!!!!!!!!!!! - do jdet = 1, idx(0) - if(degree(jdet)==1)then - call get_mono_excitation(psi_det(1,1,idet),psi_det(1,1,idx(jdet)),exc,phase,N_int) - if (exc(0,1,1) == 1) then - ! Mono alpha - i_hole = list_act_reverse(exc(1,1,1)) !!! a_a - i_part = list_act_reverse(exc(1,2,1)) !!! a^{\dagger}_{b} - kspin = 1 !!! kspin - index_orb_act_mono(idx(jdet),1) = i_hole - index_orb_act_mono(idx(jdet),2) = i_part - index_orb_act_mono(idx(jdet),3) = kspin - call i_H_j_dyall(psi_active(1,1,idet),psi_active(1,1,idx(jdet)),N_int,hij) - fock_operator_local(i_hole,i_part,kspin) = hij * phase ! phase less fock operator - fock_operator_local(i_part,i_hole,kspin) = hij * phase ! phase less fock operator - else - ! Mono beta - i_hole = list_act_reverse(exc(1,1,2)) !!! a_a - i_part = list_act_reverse(exc(1,2,2)) !!! a^{\dagger}_{b} - kspin = 2 !!! kspin - index_orb_act_mono(idx(jdet),1) = i_hole - index_orb_act_mono(idx(jdet),2) = i_part - index_orb_act_mono(idx(jdet),3) = kspin - call i_H_j_dyall(psi_active(1,1,idet),psi_active(1,1,idx(jdet)),N_int,hij) - fock_operator_local(i_hole,i_part,kspin) = hij * phase ! phase less fock operator - fock_operator_local(i_part,i_hole,kspin) = hij * phase ! phase less fock operator - endif - else if(degree(jdet)==2)then - call get_double_excitation(psi_det(1,1,idet),psi_det(1,1,idx(jdet)),exc,phase,N_int) - ! Mono alpha - index_orb_act_mono(idx(jdet),1) = list_act_reverse(exc(1,1,1)) !!! a_a ALPHA - index_orb_act_mono(idx(jdet),2) = list_act_reverse(exc(1,2,1)) !!! a^{\dagger}_{b} ALPHA - index_orb_act_mono(idx(jdet),3) = 1 - ! Mono beta - index_orb_act_mono(idx(jdet),4) = list_act_reverse(exc(1,1,2)) !!! a_a BETA - index_orb_act_mono(idx(jdet),5) = list_act_reverse(exc(1,2,2)) !!! a^{\dagger}_{b} BETA - index_orb_act_mono(idx(jdet),6) = 2 - endif - enddo - - - - do jdet = 1, idx(0) -!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! CASE OF THE MONO EXCITATIONS - if(degree(jdet) == 1)then - ! two determinants | Idet > and | Jdet > which are connected throw a mono excitation operator - ! are connected by the presence of the perturbers determinants |det_tmp> - aorb = index_orb_act_mono(idx(jdet),1) ! a_{aorb} - borb = index_orb_act_mono(idx(jdet),2) ! a^{\dagger}_{borb} - kspin = index_orb_act_mono(idx(jdet),3) ! spin of the excitation - ! the determinants Idet and Jdet interact throw the following operator - ! | Jdet > = a^{\dagger}_{borb,kspin} a_{aorb, kspin} | Idet > - - accu_contrib = 0.d0 - do ispin = 1, 2 ! you loop on all possible spin for the excitation - ! a^{\dagger}_r a_{i} (ispin) - -! if(ispin == kspin .and. vorb.le.rorb)cycle ! condition not to double count - logical :: cycle_same_spin_first_order - cycle_same_spin_first_order = .False. - 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 .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 - - ! | det_tmp > = a^{\dagger}_{rorb,ispin} a^{\dagger}_{vorb,kspin} a_{aorb,kspin} a_{iorb,ispin} | Idet > - if(perturb_dets_phase(aorb,kspin,ispin) .le. -10.d0)cycle - do inint = 1, N_int - det_tmp(inint,1) = perturb_dets(inint,1,aorb,kspin,ispin) - det_tmp(inint,2) = perturb_dets(inint,2,aorb,kspin,ispin) - enddo - call get_double_excitation(psi_det(1,1,idet),det_tmp,exc,phase,N_int) - if(kspin == ispin)then - hia = phase * (active_int(aorb,1) - active_int(aorb,2) ) - else - hia = phase * active_int(aorb,1) - endif - call get_double_excitation(psi_det(1,1,idx(jdet)),det_tmp,exc,phase,N_int) - if(kspin == ispin)then - hja = phase * (active_int(borb,1) - active_int(borb,2) ) - else - hja = phase * active_int(borb,1) - endif - - contrib_hij = hja * hia - do istate = 1, N_states - accu_contrib(istate) += contrib_hij * delta_e_inv(aorb,kspin,istate) - enddo - endif - !!!! SECOND ORDER CONTRIBTIONS - ! | det_tmp > = a^{\dagger}_{rorb,ispin} a^{\dagger}_{vorb,jspin} a_{corb,jspin} a_{iorb,ispin} | Idet > - do jspin = 1, 2 - logical :: cycle_same_spin_second_order - cycle_same_spin_second_order = .False. - if(ispin == jspin .and. vorb.le.rorb)then - cycle_same_spin_second_order = .True. - endif - 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 - det_tmp(inint,1) = perturb_dets(inint,1,corb,jspin,ispin) - det_tmp(inint,2) = perturb_dets(inint,2,corb,jspin,ispin) - det_tmp_bis(inint,1) = perturb_dets(inint,1,corb,jspin,ispin) - det_tmp_bis(inint,2) = perturb_dets(inint,2,corb,jspin,ispin) - enddo - ! | det_tmp_bis > = a^{\dagger}_{borb,kspin} a_{aorb,kspin} a_{iorb,ispin} | Idet > - call do_mono_excitation(det_tmp_bis,list_act(aorb),list_act(borb),kspin,i_ok) - if(i_ok .ne. 1)cycle - call get_mono_excitation(det_tmp,det_tmp_bis,exc,phase,N_int) - hia = perturb_dets_hij(corb,jspin,ispin) - hab = fock_operator_local(aorb,borb,kspin) * phase - - if(dabs(hia).le.1.d-12)cycle - if(dabs(hab).le.1.d-12)cycle - - call get_double_excitation(psi_det(1,1,idx(jdet)),det_tmp_bis,exc,phase,N_int) - if(jspin == ispin)then - hjb = phase * (active_int(corb,1) - active_int(corb,2) ) - else - hjb = phase * active_int(corb,1) - endif - if(dabs(hjb).le.1.d-12)cycle - do istate = 1, N_states - accu_contrib(istate)+=hia * delta_e_inv(corb,jspin,istate) & ! | Idet > --> | det_tmp > - ! | det_tmp > --> | det_tmp_bis > - *hab / (delta_e(corb,jspin,istate) + one_anhil_one_creat(aorb,borb,kspin,kspin,istate)) & - *hjb - enddo - enddo - endif - enddo - - - - enddo ! ispin - do istate = 1, N_states - matrix_1h2p(idet,idx(jdet),istate) += accu_contrib(istate) - enddo - - else if (degree(jdet) == 2)then - ! CASE OF THE DOUBLE EXCITATIONS, ONLY THIRD ORDER EFFECTS - accu_contrib = 0.d0 - do ispin = 1, 2 ! you loop on all possible spin for the excitation - ! a^{\dagger}_r a_{i} (ispin) - ! if it is standard exchange case, the hole ALPHA == the part. BETA - if (index_orb_act_mono(idx(jdet),1) == index_orb_act_mono(idx(jdet),5))then - aorb = index_orb_act_mono(idx(jdet),1) !! the HOLE of the ALPHA electron - borb = index_orb_act_mono(idx(jdet),4) !! the HOLE of the BETA electron - ! first case :: | det_tmp > == a_{borb,\beta} | Idet > - cycle_same_spin_second_order = .False. - if(ispin == 2 .and. vorb.le.rorb)then - cycle_same_spin_second_order = .True. - endif - 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) - det_tmp(inint,2) = perturb_dets(inint,2,borb,2,ispin) - det_tmp_bis(inint,1) = perturb_dets(inint,1,borb,2,ispin) - det_tmp_bis(inint,2) = perturb_dets(inint,2,borb,2,ispin) - enddo - hia = perturb_dets_hij(borb,2,ispin) - if(dabs(hia).le.1.d-12)cycle - call do_mono_excitation(det_tmp_bis,list_act(aorb),list_act(borb),1,i_ok) - call get_mono_excitation(det_tmp,det_tmp_bis,exc,phase,N_int) - hab = fock_operator_local(aorb,borb,1) * phase - - if(dabs(hab).le.1.d-12)cycle - call get_double_excitation(psi_det(1,1,idx(jdet)),det_tmp_bis,exc,phase,N_int) - if(ispin == 2)then - hjb = phase * (active_int(aorb,1) - active_int(aorb,2) ) - else if (ispin == 1)then - hjb = phase * active_int(aorb,1) - endif - if(dabs(hjb).le.1.d-12)cycle - do istate = 1, N_states - accu_contrib(istate) += hia * delta_e_inv(borb,2,istate) & ! | Idet > --> | det_tmp > - ! | det_tmp > --> | det_tmp_bis > - * hab / (delta_e(borb,2,istate) + one_anhil_one_creat(aorb,borb,1,1,istate)) & - * hjb - enddo - endif - ! second case :: | det_tmp > == a_{aorb,\alpha} | Idet > - cycle_same_spin_second_order = .False. - if(ispin == 1 .and. vorb.le.rorb)then - cycle_same_spin_second_order = .True. - endif - 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) - det_tmp(inint,2) = perturb_dets(inint,2,aorb,1,ispin) - det_tmp_bis(inint,1) = perturb_dets(inint,1,aorb,1,ispin) - det_tmp_bis(inint,2) = perturb_dets(inint,2,aorb,1,ispin) - enddo - hia = perturb_dets_hij(aorb,1,ispin) - if(dabs(hia).le.1.d-12)cycle - call do_mono_excitation(det_tmp_bis,list_act(borb),list_act(aorb),2,i_ok) - call get_mono_excitation(det_tmp,det_tmp_bis,exc,phase,N_int) - hab = fock_operator_local(aorb,borb,2) * phase - - if(dabs(hab).le.1.d-12)cycle - call get_double_excitation(psi_det(1,1,idx(jdet)),det_tmp_bis,exc,phase,N_int) - if(ispin == 1)then - hjb = phase * (active_int(borb,1) - active_int(borb,2) ) - else if (ispin == 2)then - hjb = phase * active_int(borb,1) - endif - if(dabs(hjb).le.1.d-12)cycle - do istate = 1, N_states - accu_contrib(istate) += hia * delta_e_inv(aorb,1,istate) & ! | Idet > --> | det_tmp > - ! | det_tmp > --> | det_tmp_bis > - * hab / (delta_e(aorb,1,istate) + one_anhil_one_creat(borb,aorb,2,2,istate)) & - * hjb - enddo - endif - - ! if it is a closed shell double excitation, the hole ALPHA == the hole BETA - else if (index_orb_act_mono(idx(jdet),1) == index_orb_act_mono(idx(jdet),4))then - aorb = index_orb_act_mono(idx(jdet),1) !! the HOLE of the ALPHA electron - borb = index_orb_act_mono(idx(jdet),2) !! the PART of the ALPHA electron - ! first case :: | det_tmp > == a_{aorb,\beta} | Idet > - cycle_same_spin_second_order = .False. - if(ispin == 2 .and. vorb.le.rorb)then - cycle_same_spin_second_order = .True. - endif - 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) - det_tmp(inint,2) = perturb_dets(inint,2,aorb,2,ispin) - det_tmp_bis(inint,1) = perturb_dets(inint,1,aorb,2,ispin) - det_tmp_bis(inint,2) = perturb_dets(inint,2,aorb,2,ispin) - enddo - hia = perturb_dets_hij(aorb,2,ispin) - if(dabs(hia).le.1.d-12)cycle - call do_mono_excitation(det_tmp_bis,list_act(aorb),list_act(borb),1,i_ok) - call get_mono_excitation(det_tmp,det_tmp_bis,exc,phase,N_int) - hab = fock_operator_local(aorb,borb,1) * phase - - if(dabs(hab).le.1.d-12)cycle - call get_double_excitation(psi_det(1,1,idx(jdet)),det_tmp_bis,exc,phase,N_int) - if(ispin == 2)then - hjb = phase * (active_int(borb,1) - active_int(borb,2) ) - else if (ispin == 1)then - hjb = phase * active_int(borb,1) - endif - if(dabs(hjb).le.1.d-12)cycle - do istate = 1, N_states - accu_contrib(istate) += hia * delta_e_inv(aorb,2,istate) & ! | Idet > --> | det_tmp > - ! | det_tmp > --> | det_tmp_bis > - * hab / (delta_e(aorb,2,istate) + one_anhil_one_creat(aorb,borb,1,1,istate)) & - * hjb - enddo - endif - - ! second case :: | det_tmp > == a_{aorb,\alpha} | Idet > - cycle_same_spin_second_order = .False. - if(ispin == 1 .and. vorb.le.rorb)then - cycle_same_spin_second_order = .True. - endif - 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) - det_tmp(inint,2) = perturb_dets(inint,2,aorb,1,ispin) - det_tmp_bis(inint,1) = perturb_dets(inint,1,aorb,1,ispin) - det_tmp_bis(inint,2) = perturb_dets(inint,2,aorb,1,ispin) - enddo - hia = perturb_dets_hij(aorb,1,ispin) - if(dabs(hia).le.1.d-12)cycle - call do_mono_excitation(det_tmp_bis,list_act(aorb),list_act(borb),2,i_ok) - call get_mono_excitation(det_tmp,det_tmp_bis,exc,phase,N_int) - hab = fock_operator_local(aorb,borb,2) * phase - - if(dabs(hab).le.1.d-12)cycle - call get_double_excitation(psi_det(1,1,idx(jdet)),det_tmp_bis,exc,phase,N_int) - if(ispin == 1)then - hjb = phase * (active_int(borb,1) - active_int(borb,2) ) - else if (ispin == 2)then - hjb = phase * active_int(borb,1) - endif - if(dabs(hjb).le.1.d-12)cycle - do istate = 1, N_states - accu_contrib(istate) += hia * delta_e_inv(aorb,1,istate) & ! | Idet > --> | det_tmp > - ! | det_tmp > --> | det_tmp_bis > - * hab / (delta_e(aorb,1,istate) + one_anhil_one_creat(aorb,borb,2,2,istate)) & - * hjb - enddo - endif - - - else - ! one should not fall in this case ... - call debug_det(psi_det(1,1,i),N_int) - call debug_det(psi_det(1,1,idx(jdet)),N_int) - call get_double_excitation(psi_det(1,1,idet),psi_det(1,1,idx(jdet)),exc,phase,N_int) - call decode_exc(exc,2,h1,p1,h2,p2,s1,s2) - integer :: h1, p1, h2, p2, s1, s2 - print*, h1, p1, h2, p2, s1, s2 - - print*, 'pb !!! it is a double but not an exchange case ....' - stop - endif - enddo ! ispin - do istate = 1, N_states - matrix_1h2p(idet,idx(jdet),istate) += accu_contrib(istate) - enddo - - else if (degree(jdet) == 0)then - ! diagonal part of the dressing : interaction of | Idet > with all the perturbers generated by the excitations - ! - ! | det_tmp > = a^{\dagger}_{rorb,ispin} a^{\dagger}_{vorb,kspin} a_{aorb,kspin} a_{iorb,ispin} | Idet > - accu_contrib = 0.d0 - do ispin = 1, 2 - do kspin = 1, 2 - do a = 1, n_act_orb ! First active - if( perturb_dets_phase(a,kspin,ispin) .le. -10.d0)cycle - if(ispin == kspin .and. vorb.le.rorb)cycle ! condition not to double count - contrib_hij = perturb_dets_hij(a,kspin,ispin) * perturb_dets_hij(a,kspin,ispin) - do istate = 1, N_states - accu_contrib(istate) += contrib_hij * delta_e_inv(a,kspin,istate) - enddo - enddo - enddo - enddo - do istate = 1, N_states - matrix_1h2p(idet,idet,istate) += accu_contrib(istate) - enddo - - endif - enddo !! jdet - - - enddo - enddo - enddo - enddo -end - -subroutine give_2h1p_new(matrix_2h1p) - use bitmasks - implicit none - double precision , intent(inout) :: matrix_2h1p(N_det,N_det,*) - integer :: i,j,r,a,b - integer :: iorb, jorb, rorb, aorb, borb - integer :: ispin,jspin - integer :: idet,jdet - integer(bit_kind) :: perturb_dets(N_int,2,n_act_orb,2,2) - double precision :: perturb_dets_phase(n_act_orb,2,2) - double precision :: perturb_dets_hij(n_act_orb,2,2) - integer :: inint - integer :: elec_num_tab_local(2),acu_elec - integer(bit_kind) :: det_tmp(N_int,2) - integer :: exc(0:2,2,2) - integer :: accu_elec - double precision :: get_mo_bielec_integral - double precision :: active_int(n_act_orb,2) - double precision :: hij,phase - integer :: i_hole,i_part - double precision :: delta_e_inv(n_act_orb,2,N_states) - double precision :: fock_operator_local(n_act_orb,n_act_orb,2) - double precision :: delta_e_inactive_virt(N_states) - integer :: degree(N_det) - integer :: idx(0:N_det) - double precision :: delta_e(n_act_orb,2,N_states) - integer :: istate - integer :: index_orb_act_mono(N_det,3) - integer :: kspin - double precision :: hij_test - double precision :: accu_contrib(N_states) - double precision :: contrib_hij - double precision :: hja - integer :: corb,i_ok - integer(bit_kind) :: det_tmp_bis(N_int,2) - double precision :: hia,hjb,hab -!matrix_2h1p = 0.d0 - - elec_num_tab_local = 0 - do inint = 1, N_int - elec_num_tab_local(1) += popcnt(psi_det(inint,1,1)) - elec_num_tab_local(2) += popcnt(psi_det(inint,2,1)) - enddo - do i = 1, n_inact_orb ! First inactive - iorb = list_inact(i) - do j = 1, n_inact_orb ! Second inactive - jorb = list_inact(j) - do r = 1, n_virt_orb ! First virtual - rorb = list_virt(r) - ! take all the integral you will need for i,j,r fixed - do a = 1, n_act_orb - aorb = list_act(a) - active_int(a,1) = get_mo_bielec_integral(iorb,jorb,rorb,aorb,mo_integrals_map) ! direct - active_int(a,2) = get_mo_bielec_integral(iorb,jorb,aorb,rorb,mo_integrals_map) ! exchange - perturb_dets_phase(a,1,1) = -1000.d0 - perturb_dets_phase(a,1,2) = -1000.d0 - perturb_dets_phase(a,2,2) = -1000.d0 - perturb_dets_phase(a,2,1) = -1000.d0 - enddo - - do istate = 1, N_states - delta_e_inactive_virt(istate) = & - - fock_virt_total_spin_trace(rorb,istate) & - + fock_core_inactive_total_spin_trace(iorb,istate) & - + fock_core_inactive_total_spin_trace(jorb,istate) - enddo - - do idet = 1, N_det - call get_excitation_degree_vector_mono(psi_det,psi_det(1,1,idet),degree,N_int,N_det,idx) - !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! Precomputation of matrix elements - do ispin = 1, 2 ! spin of the couple a-a^dagger (i,r) - do jspin = 1, 2 ! spin of the couple z-a^dagger (j,a) - if(ispin == jspin .and. iorb.le.jorb)cycle ! condition not to double count - do a = 1, n_act_orb ! First active - aorb = list_act(a) - do inint = 1, N_int - det_tmp(inint,1) = psi_det(inint,1,idet) - det_tmp(inint,2) = psi_det(inint,2,idet) - enddo - ! Do the excitation inactive -- > virtual - call clear_bit_to_integer(iorb,det_tmp(1,ispin),N_int) ! hole in "iorb" of spin Ispin - call set_bit_to_integer(rorb,det_tmp(1,ispin),N_int) ! particle in "rorb" of spin Ispin - - ! Do the excitation inactive -- > active - call clear_bit_to_integer(jorb,det_tmp(1,jspin),N_int) ! hole in "jorb" of spin Jspin - call set_bit_to_integer(aorb,det_tmp(1,jspin),N_int) ! particle in "aorb" of spin Jspin - - ! Check if the excitation is possible or not on psi_det(idet) - accu_elec= 0 - do inint = 1, N_int - accu_elec+= popcnt(det_tmp(inint,jspin)) - enddo - if(accu_elec .ne. elec_num_tab_local(jspin))then - perturb_dets_phase(a,jspin,ispin) = -1000.0d0 - perturb_dets_hij(a,jspin,ispin) = 0.d0 - cycle - endif - do inint = 1, N_int - perturb_dets(inint,1,a,jspin,ispin) = det_tmp(inint,1) - perturb_dets(inint,2,a,jspin,ispin) = det_tmp(inint,2) - enddo - call get_double_excitation(psi_det(1,1,idet),det_tmp,exc,phase,N_int) - perturb_dets_phase(a,jspin,ispin) = phase - do istate = 1, N_states - delta_e(a,jspin,istate) = one_creat(a,jspin,istate) + delta_e_inactive_virt(istate) - delta_e_inv(a,jspin,istate) = 1.d0 / delta_e(a,jspin,istate) - enddo - if(ispin == jspin)then - perturb_dets_hij(a,jspin,ispin) = phase * (active_int(a,1) - active_int(a,2) ) - else - perturb_dets_hij(a,jspin,ispin) = phase * active_int(a,1) - endif -!!!!!!!!!!!!!!!!!!!!!1 Computation of the coefficient at first order coming from idet -!!!!!!!!!!!!!!!!!!!!! for the excitation (i,j)(ispin,jspin) ---> (r,a)(ispin,jspin) - enddo - enddo - enddo - -!!!!!!!!!!!!!!!!!!!!!!!!!!! determination of the connections between I and the other J determinants mono excited in the CAS -!!!!!!!!!!!!!!!!!!!!!!!!!!!! the determinants I and J must be connected by the following operator -!!!!!!!!!!!!!!!!!!!!!!!!!!!! - do jdet = 1, idx(0) - if(degree(jdet)==1)then - call get_mono_excitation(psi_det(1,1,idet),psi_det(1,1,idx(jdet)),exc,phase,N_int) - if (exc(0,1,1) == 1) then - ! Mono alpha - i_part = list_act_reverse(exc(1,2,1)) ! a^{\dagger}_{aorb} - i_hole = list_act_reverse(exc(1,1,1)) ! a_{borb} - kspin = 1 - index_orb_act_mono(idx(jdet),1) = i_part !!! a^{\dagger}_a - index_orb_act_mono(idx(jdet),2) = i_hole !!! a_{b} - index_orb_act_mono(idx(jdet),3) = 1 - call i_H_j_dyall(psi_active(1,1,idet),psi_active(1,1,idx(jdet)),N_int,hij) - fock_operator_local(i_hole,i_part,kspin) = hij * phase ! phase less fock operator - fock_operator_local(i_part,i_hole,kspin) = hij * phase ! phase less fock operator - else - ! Mono beta - i_part = list_act_reverse(exc(1,2,2)) - i_hole = list_act_reverse(exc(1,1,2)) - kspin = 2 - index_orb_act_mono(idx(jdet),1) = i_part !!! a^{\dagger}_a - index_orb_act_mono(idx(jdet),2) = i_hole !!! a_{b} - index_orb_act_mono(idx(jdet),3) = 2 - call i_H_j_dyall(psi_active(1,1,idet),psi_active(1,1,idx(jdet)),N_int,hij) - fock_operator_local(i_hole,i_part,kspin) = hij * phase ! phase less fock operator - fock_operator_local(i_part,i_hole,kspin) = hij * phase ! phase less fock operator - endif - endif - enddo - - do jdet = 1, idx(0) - ! two determinants | Idet > and | Jdet > which are connected throw a mono excitation operator - ! are connected by the presence of the perturbers determinants |det_tmp> - if(degree(jdet) == 1)then - aorb = index_orb_act_mono(idx(jdet),1) ! a^{\dagger}_{aorb} - borb = index_orb_act_mono(idx(jdet),2) ! a_{borb} - kspin = index_orb_act_mono(idx(jdet),3) ! spin of the excitation - ! the determinants Idet and Jdet interact throw the following operator - ! | Jdet > = a_{borb,kspin} a^{\dagger}_{aorb, kspin} | Idet > - - accu_contrib = 0.d0 - do ispin = 1, 2 ! you loop on all possible spin for the excitation - ! a^{\dagger}_r a_{i} (ispin) -! if(ispin == kspin .and. iorb.le.jorb)cycle ! condition not to double count - logical :: cycle_same_spin_first_order - cycle_same_spin_first_order = .False. - 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 .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 - det_tmp(inint,1) = perturb_dets(inint,1,aorb,kspin,ispin) - det_tmp(inint,2) = perturb_dets(inint,2,aorb,kspin,ispin) - enddo - ! you determine the interaction between the excited determinant and the other parent | Jdet > - ! | det_tmp > = a^{\dagger}_{rorb,ispin} a^{\dagger}_{borb,kspin} a_{jorb,kspin} a_{iorb,ispin} | Jdet > - ! hja = < det_tmp | H | Jdet > - call get_double_excitation(psi_det(1,1,idx(jdet)),det_tmp,exc,phase,N_int) - if(kspin == ispin)then - hja = phase * (active_int(borb,1) - active_int(borb,2) ) - else - hja = phase * active_int(borb,1) - endif -!! if(dabs(hja).le.1.d-10)cycle - - - do istate = 1, N_states - accu_contrib(istate) += hja * perturb_dets_hij(aorb,kspin,ispin) * delta_e_inv(aorb,kspin,istate) - enddo - endif - logical :: cycle_same_spin_second_order - !!!! SECOND ORDER CONTRIBUTIONS - !!!! SECOND ORDER CONTRIBTIONS - ! | det_tmp > = a^{\dagger}_{rorb,ispin} a^{\dagger}_{corb,jspin} a_{jorb,jspin} a_{iorb,ispin} | Idet > - do jspin = 1, 2 - cycle_same_spin_second_order = .False. - 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 .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 - det_tmp(inint,1) = perturb_dets(inint,1,corb,jspin,ispin) - det_tmp(inint,2) = perturb_dets(inint,2,corb,jspin,ispin) - det_tmp_bis(inint,1) = perturb_dets(inint,1,corb,jspin,ispin) - det_tmp_bis(inint,2) = perturb_dets(inint,2,corb,jspin,ispin) - enddo - ! | det_tmp_bis > = a^{\dagger}_{aorb,kspin} a_{borb,kspin} a_{iorb,kspin} | Idet > - call do_mono_excitation(det_tmp_bis,list_act(borb),list_act(aorb),kspin,i_ok) - if(i_ok .ne. 1)cycle - hia = perturb_dets_hij(corb,jspin,ispin) - if(dabs(hia).le.1.d-10)cycle - call get_mono_excitation(det_tmp,det_tmp_bis,exc,phase,N_int) - hab = fock_operator_local(borb,aorb,kspin) * phase - if(dabs(hab).le.1.d-10)cycle - - call get_double_excitation(psi_det(1,1,idx(jdet)),det_tmp_bis,exc,phase,N_int) - if(jspin == ispin)then - hjb = phase * (active_int(corb,1) - active_int(corb,2) ) - else - hjb = phase * active_int(corb,1) - endif - if(dabs(hjb).le.1.d-10)cycle - do istate = 1, N_states - accu_contrib(istate)+=hia * delta_e_inv(corb,jspin,istate) & ! | Idet > --> | det_tmp > - ! | det_tmp > --> | det_tmp_bis > - *hab / (delta_e(corb,jspin,istate) + one_anhil_one_creat(borb,aorb,kspin,kspin,istate)) & - *hjb - enddo - enddo ! jspin - endif - enddo - enddo ! ispin - do istate = 1, N_states - matrix_2h1p(idx(jdet),idet,istate) += accu_contrib(istate) - enddo - - else if (degree(jdet) == 0 )then - ! diagonal part of the dressing : interaction of | Idet > with all the perturbers generated by the excitations - ! - ! | det_tmp > = a^{\dagger}_{rorb,ispin} a^{\dagger}_{aorb,kspin} a_{jorb,kspin} a_{iorb,ispin} | Idet > - accu_contrib = 0.d0 - do ispin = 1, 2 - do kspin = 1, 2 - if(ispin == kspin .and. iorb.le.jorb)cycle ! condition not to double count - do a = 1, n_act_orb ! First active - contrib_hij = perturb_dets_hij(a,kspin,ispin) * perturb_dets_hij(a,kspin,ispin) - if(dabs(contrib_hij).le.1.d-10)cycle - do istate = 1, N_states - accu_contrib(istate) += contrib_hij * delta_e_inv(a,kspin,istate) - enddo - enddo - enddo - enddo - do istate =1, N_states - matrix_2h1p(idet,idet,istate) += accu_contrib(istate) - enddo - - endif - - enddo - enddo - enddo - enddo - enddo - - - - - -end - - diff --git a/plugins/MRPT_Utils/second_order_new_2p.irp.f b/plugins/MRPT_Utils/second_order_new_2p.irp.f deleted file mode 100644 index 11ae18da..00000000 --- a/plugins/MRPT_Utils/second_order_new_2p.irp.f +++ /dev/null @@ -1,283 +0,0 @@ - -subroutine give_2p_new(matrix_2p) - use bitmasks - implicit none - double precision , intent(inout) :: matrix_2p(N_det,N_det,*) - integer :: i,v,r,a,b,c - integer :: iorb, vorb, rorb, aorb, borb,corb - integer :: ispin,jspin - integer :: idet,jdet - integer(bit_kind) :: perturb_dets(N_int,2,n_act_orb,n_act_orb,2,2) - double precision :: perturb_dets_phase(n_act_orb,n_act_orb,2,2) - double precision :: perturb_dets_hij(n_act_orb,n_act_orb,2,2) - double precision :: perturb_dets_hpsi0(n_act_orb,n_act_orb,2,2,N_states) - integer :: inint - integer :: elec_num_tab_local(2),acu_elec - integer(bit_kind) :: det_tmp(N_int,2) - integer(bit_kind) :: det_tmp_j(N_int,2) - integer :: exc(0:2,2,2) - integer :: accu_elec - double precision :: get_mo_bielec_integral - double precision :: active_int(n_act_orb,n_act_orb,2) - double precision :: hij,phase - double precision :: accu_contrib(N_states) - integer :: degree(N_det) - integer :: idx(0:N_det) - double precision :: delta_e(n_act_orb,n_act_orb,2,2,N_states) - double precision :: delta_e_inv(n_act_orb,n_act_orb,2,2,N_states) - double precision :: delta_e_inactive_virt(N_states) - integer :: istate - integer :: index_orb_act_mono(N_det,6) - integer :: kspin - double precision :: delta_e_ja(N_states) - double precision :: hja - double precision :: contrib_hij - double precision :: fock_operator_local(n_act_orb,n_act_orb,2) - double precision :: hij_test - integer ::i_ok - integer(bit_kind) :: det_tmp_bis(N_int,2) - double precision :: hib , hab - double precision :: delta_e_ab(N_states) - double precision :: hib_test,hja_test,hab_test - integer :: i_hole,i_part - double precision :: hia,hjb - integer :: other_spin(2) - other_spin(1) = 2 - other_spin(2) = 1 - - accu_contrib = 0.d0 -!matrix_2p = 0.d0 - - elec_num_tab_local = 0 - do inint = 1, N_int - elec_num_tab_local(1) += popcnt(psi_det(inint,1,1)) - elec_num_tab_local(2) += popcnt(psi_det(inint,2,1)) - enddo - do v = 1, n_virt_orb ! First virtual - vorb = list_virt(v) - do r = 1, n_virt_orb ! Second virtual - rorb = list_virt(r) - ! take all the integral you will need for r,v fixed - do a = 1, n_act_orb - aorb = list_act(a) - do b = 1, n_act_orb - borb = list_act(b) - active_int(a,b,1) = get_mo_bielec_integral(aorb,borb,rorb,vorb,mo_integrals_map) ! direct ( a--> r | b--> v ) - active_int(a,b,2) = get_mo_bielec_integral(aorb,borb,vorb,rorb,mo_integrals_map) ! exchange ( b--> r | a--> v ) - perturb_dets_phase(a,b,1,1) = -1000.d0 - perturb_dets_phase(a,b,1,2) = -1000.d0 - perturb_dets_phase(a,b,2,2) = -1000.d0 - perturb_dets_phase(a,b,2,1) = -1000.d0 - perturb_dets_phase(b,a,1,1) = -1000.d0 - perturb_dets_phase(b,a,1,2) = -1000.d0 - perturb_dets_phase(b,a,2,2) = -1000.d0 - perturb_dets_phase(b,a,2,1) = -1000.d0 - enddo - enddo - - - do istate = 1, N_states - delta_e_inactive_virt(istate) = & - - fock_virt_total_spin_trace(rorb,istate) & - - fock_virt_total_spin_trace(vorb,istate) - enddo - do idet = 1, N_det -! call get_excitation_degree_vector_mono(psi_det,psi_det(1,1,idet),degree,N_int,N_det,idx) - call get_excitation_degree_vector(psi_det,psi_det(1,1,idet),degree,N_int,N_det,idx) - !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! Precomputation of matrix elements - do ispin = 1, 2 ! spin of the couple a-a^dagger (aorb,rorb) - do jspin = 1, 2 ! spin of the couple a-a^dagger (borb,vorb) - do b = 1, n_act_orb ! First active - borb = list_act(b) - do a = 1, n_act_orb ! First active - aorb = list_act(a) -! if(ispin == 2.and. jspin ==1)then -! perturb_dets_phase(a,b,ispin,jspin) = -1000.0d0 -! perturb_dets_hij(a,b,ispin,jspin) = 0.d0 -! cycle ! condition not to double count -! endif - - if(ispin == jspin .and. vorb.le.rorb)then - perturb_dets_phase(a,b,ispin,jspin) = -1000.0d0 - perturb_dets_hij(a,b,ispin,jspin) = 0.d0 - cycle ! condition not to double count - endif - if(ispin == jspin .and. aorb.le.borb) then - perturb_dets_phase(a,b,ispin,jspin) = -1000.0d0 - perturb_dets_hij(a,b,ispin,jspin) = 0.d0 - cycle ! condition not to double count - endif - do inint = 1, N_int - det_tmp(inint,1) = psi_det(inint,1,idet) - det_tmp(inint,2) = psi_det(inint,2,idet) - enddo - ! Do the excitation (aorb,ispin) --> (rorb,ispin) - call clear_bit_to_integer(aorb,det_tmp(1,ispin),N_int) ! hole in "aorb" of spin Ispin - call set_bit_to_integer(rorb,det_tmp(1,ispin),N_int) ! particle in "rorb" of spin Ispin - - ! Do the excitation (borb,jspin) --> (vorb,jspin) - call clear_bit_to_integer(borb,det_tmp(1,jspin),N_int) ! hole in "borb" of spin Jspin - call set_bit_to_integer(vorb,det_tmp(1,jspin),N_int) ! particle in "vorb" of spin Jspin - - ! Check if the excitation is possible or not on psi_det(idet) - accu_elec= 0 - do inint = 1, N_int - accu_elec+= popcnt(det_tmp(inint,1)) + popcnt(det_tmp(inint,2)) - enddo - if(accu_elec .ne. elec_num_tab_local(2)+elec_num_tab_local(1))then - perturb_dets_phase(a,b,ispin,jspin) = -1000.0d0 - perturb_dets_hij(a,b,ispin,jspin) = 0.d0 - cycle - endif - do inint = 1, N_int - perturb_dets(inint,1,a,b,ispin,jspin) = det_tmp(inint,1) - perturb_dets(inint,2,a,b,ispin,jspin) = det_tmp(inint,2) - enddo - - call get_double_excitation(psi_det(1,1,idet),det_tmp,exc,phase,N_int) - perturb_dets_phase(a,b,ispin,jspin) = phase - - do istate = 1, N_states - delta_e(a,b,ispin,jspin,istate) = two_anhil(a,b,ispin,jspin,istate) + delta_e_inactive_virt(istate) - delta_e_inv(a,b,ispin,jspin,istate) = 1.d0 / delta_e(a,b,ispin,jspin,istate) - enddo - if(ispin == jspin)then - perturb_dets_hij(a,b,ispin,jspin) = phase * (active_int(a,b,2) - active_int(a,b,1) ) - else - perturb_dets_hij(a,b,ispin,jspin) = phase * active_int(a,b,1) - endif - call i_H_j(psi_det(1,1,idet),det_tmp,N_int,hij) - if(hij.ne.perturb_dets_hij(a,b,ispin,jspin))then - print*, active_int(a,b,1) , active_int(b,a,1) - double precision :: hmono,hdouble - call i_H_j_verbose(psi_det(1,1,idet),det_tmp,N_int,hij,hmono,hdouble) - print*, 'pb !! hij.ne.perturb_dets_hij(a,b,ispin,jspin)' - print*, ispin,jspin - print*, aorb,rorb,borb,vorb - print*, hij,perturb_dets_hij(a,b,ispin,jspin) - call debug_det(psi_det(1,1,idet),N_int) - call debug_det(det_tmp,N_int) - stop - endif - enddo ! b - enddo ! a - enddo ! jspin - enddo ! ispin - -!!!!!!!!!!!!!!!!!!!!!!!!!!! determination of the connections between I and the other J determinants mono excited in the CAS -!!!!!!!!!!!!!!!!!!!!!!!!!!!! the determinants I and J must be connected by the following operator -!!!!!!!!!!!!!!!!!!!!!!!!!!!! -!!!!!!!!!!!!!!!!!!!!!!!!!!!! - do jdet = 1, idx(0) - if(degree(jdet)==1)then - call get_mono_excitation(psi_det(1,1,idet),psi_det(1,1,idx(jdet)),exc,phase,N_int) - if (exc(0,1,1) == 1) then - ! Mono alpha - i_hole = list_act_reverse(exc(1,1,1)) !!! a_a - i_part = list_act_reverse(exc(1,2,1)) !!! a^{\dagger}_{b} - kspin = 1 !!! kspin - index_orb_act_mono(idx(jdet),1) = i_hole - index_orb_act_mono(idx(jdet),2) = i_part - index_orb_act_mono(idx(jdet),3) = kspin - call i_H_j_dyall(psi_active(1,1,idet),psi_active(1,1,idx(jdet)),N_int,hij) - fock_operator_local(i_hole,i_part,kspin) = hij * phase ! phase less fock operator - fock_operator_local(i_part,i_hole,kspin) = hij * phase ! phase less fock operator - else - ! Mono beta - i_hole = list_act_reverse(exc(1,1,2)) !!! a_a - i_part = list_act_reverse(exc(1,2,2)) !!! a^{\dagger}_{b} - kspin = 2 !!! kspin - index_orb_act_mono(idx(jdet),1) = i_hole - index_orb_act_mono(idx(jdet),2) = i_part - index_orb_act_mono(idx(jdet),3) = kspin - call i_H_j_dyall(psi_active(1,1,idet),psi_active(1,1,idx(jdet)),N_int,hij) - fock_operator_local(i_hole,i_part,kspin) = hij * phase ! phase less fock operator - fock_operator_local(i_part,i_hole,kspin) = hij * phase ! phase less fock operator - endif - else if(degree(jdet)==2)then - call get_double_excitation(psi_det(1,1,idet),psi_det(1,1,idx(jdet)),exc,phase,N_int) - if (exc(0,1,1) == 1) then - ! Mono alpha - index_orb_act_mono(idx(jdet),1) = list_act_reverse(exc(1,1,1)) !!! a_a ALPHA - index_orb_act_mono(idx(jdet),2) = list_act_reverse(exc(1,2,1)) !!! a^{\dagger}_{b} ALPHA - index_orb_act_mono(idx(jdet),3) = 1 - ! Mono beta - index_orb_act_mono(idx(jdet),4) = list_act_reverse(exc(1,1,2)) !!! a_a BETA - index_orb_act_mono(idx(jdet),5) = list_act_reverse(exc(1,2,2)) !!! a^{\dagger}_{b} BETA - index_orb_act_mono(idx(jdet),6) = 2 - else if (exc(0,1,1) == 2) then - index_orb_act_mono(idx(jdet),1) = list_act_reverse(exc(1,1,1)) !!! a_a ALPHA - index_orb_act_mono(idx(jdet),2) = list_act_reverse(exc(1,2,1)) !!! a^{\dagger}_{b} ALPHA - index_orb_act_mono(idx(jdet),3) = 1 - index_orb_act_mono(idx(jdet),4) = list_act_reverse(exc(2,1,1)) !!! a_c ALPHA - index_orb_act_mono(idx(jdet),5) = list_act_reverse(exc(2,2,1)) !!! a^{\dagger}_{d} ALPHA - index_orb_act_mono(idx(jdet),6) = 1 - else if (exc(0,1,2) == 2) then - index_orb_act_mono(idx(jdet),1) = list_act_reverse(exc(1,1,2)) !!! a_a BETA - index_orb_act_mono(idx(jdet),2) = list_act_reverse(exc(2,1,2)) !!! a^{\dagger}_{b} BETA - index_orb_act_mono(idx(jdet),3) = 2 - index_orb_act_mono(idx(jdet),4) = list_act_reverse(exc(1,2,2)) !!! a_c BETA - index_orb_act_mono(idx(jdet),5) = list_act_reverse(exc(2,2,2)) !!! a^{\dagger}_{d} BETA - index_orb_act_mono(idx(jdet),6) = 2 - endif - endif - enddo - - - -! do jdet = 1, idx(0) -!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! CASE OF THE MONO EXCITATIONS -! if(degree(jdet) == 1)then -! ! two determinants | Idet > and | Jdet > which are connected throw a mono excitation operator -! ! are connected by the presence of the perturbers determinants |det_tmp> -! aorb = index_orb_act_mono(idx(jdet),1) ! a_{aorb} -! borb = index_orb_act_mono(idx(jdet),2) ! a^{\dagger}_{borb} -! kspin = index_orb_act_mono(idx(jdet),3) ! spin of the excitation -! ! the determinants Idet and Jdet interact throw the following operator -! ! | Jdet > = a^{\dagger}_{borb,kspin} a_{aorb, kspin} | Idet > - -! accu_contrib = 0.d0 - do ispin = 1, 2 ! you loop on all possible spin for the excitation - ! a^{\dagger}_r a_{a} (ispin) - !!!! SECOND ORDER CONTRIBTIONS - ! | det_tmp > = a^{\dagger}_{rorb,ispin} a^{\dagger}_{vorb,jspin} a_{corb,jspin} a_{iorb,ispin} | Idet > - do jspin = 1, 2 - if(ispin == 2 .and. jspin ==1)cycle - do b = 1, n_act_orb - do a = 1, n_act_orb - logical :: cycle_same_spin_second_order(2) - cycle_same_spin_second_order(1) = .False. - cycle_same_spin_second_order(2) = .False. - if(perturb_dets_phase(a,b,ispin,jspin).le.-10d0)cycle - if(ispin == jspin .and. vorb.le.rorb)then - cycle_same_spin_second_order(1) = .True. - endif - if(ispin == jspin .and. aorb.le.borb)then - cycle_same_spin_second_order(2) = .True. - endif - do inint = 1, N_int - det_tmp(inint,1) = perturb_dets(inint,1,a,b,ispin,jspin) - det_tmp(inint,2) = perturb_dets(inint,2,a,b,ispin,jspin) - enddo - do jdet = 1, idx(0) -! if(idx(jdet).gt.idet)cycle - do istate = 1, N_states - call i_H_j(psi_det(1,1,idx(jdet)),det_tmp,N_int,hij) - matrix_2p(idx(jdet),idet,istate) += hij * perturb_dets_hij(a,b,ispin,jspin) * delta_e_inv(a,b,ispin,jspin,istate) - enddo - enddo ! jdet - enddo ! b - enddo ! a - enddo ! jspin - enddo ! ispin - -! else if (degree(jdet) == 0)then -! -! endif -! enddo !! jdet - - - enddo - enddo - enddo -end diff --git a/plugins/MRPT_Utils/utils_bitmask.irp.f b/plugins/MRPT_Utils/utils_bitmask.irp.f deleted file mode 100644 index 1b262eb6..00000000 --- a/plugins/MRPT_Utils/utils_bitmask.irp.f +++ /dev/null @@ -1,36 +0,0 @@ - -subroutine give_active_part_determinant(det_in,det_out) - implicit none - use bitmasks - integer(bit_kind),intent(in) :: det_in(N_int,2) - integer(bit_kind),intent(out) :: det_out(N_int,2) - integer :: i - do i = 1,N_int - det_out(i,1) = iand(det_in(i,1),cas_bitmask(i,1,1)) - det_out(i,2) = iand(det_in(i,2),cas_bitmask(i,1,1)) - enddo -end - -subroutine give_core_inactive_part_determinant(det_in,det_out) - implicit none - use bitmasks - integer(bit_kind),intent(in) :: det_in(N_int,2) - integer(bit_kind),intent(out) :: det_out(N_int,2) - integer :: i - do i = 1,N_int - det_out(i,1) = iand(det_in(i,1),reunion_of_core_inact_bitmask(i,1)) - det_out(i,2) = iand(det_in(i,2),reunion_of_core_inact_bitmask(i,1)) - enddo -end - -subroutine give_virt_part_determinant(det_in,det_out) - implicit none - use bitmasks - integer(bit_kind),intent(in) :: det_in(N_int,2) - integer(bit_kind),intent(out) :: det_out(N_int,2) - integer :: i - do i = 1,N_int - det_out(i,1) = iand(det_in(i,1),virt_bitmask(i,1)) - det_out(i,2) = iand(det_in(i,2),virt_bitmask(i,1)) - enddo -end diff --git a/plugins/Perturbation/EZFIO.cfg b/plugins/Perturbation/EZFIO.cfg index 4f0457a2..ad26cfe5 100644 --- a/plugins/Perturbation/EZFIO.cfg +++ b/plugins/Perturbation/EZFIO.cfg @@ -16,17 +16,4 @@ type: Normalized_float doc: The selection process stops when the energy ratio variational/(variational+PT2) is equal to var_pt2_ratio interface: ezfio,provider,ocaml -default: 0.75 - -[threshold_generators_pt2] -type: Threshold -doc: Thresholds on generators (fraction of the norm) for final PT2 calculation -interface: ezfio,provider,ocaml -default: 0.999 - -[threshold_selectors_pt2] -type: Threshold -doc: Thresholds on selectors (fraction of the norm) for final PT2 calculation -interface: ezfio,provider,ocaml -default: 1. - +default: 0.75 \ No newline at end of file diff --git a/plugins/Perturbation/NEEDED_CHILDREN_MODULES b/plugins/Perturbation/NEEDED_CHILDREN_MODULES index 25b89c5f..eba3650e 100644 --- a/plugins/Perturbation/NEEDED_CHILDREN_MODULES +++ b/plugins/Perturbation/NEEDED_CHILDREN_MODULES @@ -1 +1 @@ -Determinants Properties Hartree_Fock Davidson MRPT_Utils +Properties Hartree_Fock Davidson diff --git a/plugins/Perturbation/README.rst b/plugins/Perturbation/README.rst index 1657e079..810a58e1 100644 --- a/plugins/Perturbation/README.rst +++ b/plugins/Perturbation/README.rst @@ -88,7 +88,6 @@ Needed Modules * `Properties `_ * `Hartree_Fock `_ -* `Davidson `_ Documentation ============= @@ -108,13 +107,13 @@ Documentation Undocumented -perturb_buffer_by_mono_dipole_moment_z - Applly pertubration ``dipole_moment_z`` to the buffer of determinants generated in the H_apply +perturb_buffer_by_mono_delta_rho_one_point + Applly pertubration ``delta_rho_one_point`` to the buffer of determinants generated in the H_apply routine. -perturb_buffer_by_mono_dummy - Applly pertubration ``dummy`` to the buffer of determinants generated in the H_apply +perturb_buffer_by_mono_dipole_moment_z + Applly pertubration ``dipole_moment_z`` to the buffer of determinants generated in the H_apply routine. @@ -153,13 +152,13 @@ perturb_buffer_by_mono_moller_plesset routine. -perturb_buffer_dipole_moment_z - Applly pertubration ``dipole_moment_z`` to the buffer of determinants generated in the H_apply +perturb_buffer_delta_rho_one_point + Applly pertubration ``delta_rho_one_point`` to the buffer of determinants generated in the H_apply routine. -perturb_buffer_dummy - Applly pertubration ``dummy`` to the buffer of determinants generated in the H_apply +perturb_buffer_dipole_moment_z + Applly pertubration ``dipole_moment_z`` to the buffer of determinants generated in the H_apply routine. @@ -198,6 +197,27 @@ perturb_buffer_moller_plesset routine. +`pt2_delta_rho_one_point `_ + compute the perturbatibe contribution to the Integrated Spin density at z = z_one point of one determinant + .br + for the various n_st states, at various level of theory. + .br + c_pert(i) = /( - ) + .br + e_2_pert(i) = c_pert(i) * + .br + H_pert_diag(i) = c_pert(i)^2 * + .br + To get the contribution of the first order : + .br + = sum(over i) e_2_pert(i) + .br + To get the contribution of the diagonal elements of the second order : + .br + [ + + sum(over i) H_pert_diag(i) ] / [1. + sum(over i) c_pert(i) **2] + .br + + `pt2_dipole_moment_z `_ compute the perturbatibe contribution to the dipole moment of one determinant .br @@ -219,11 +239,7 @@ perturb_buffer_moller_plesset .br -`pt2_dummy `_ - Dummy perturbation to add all connected determinants. - - -`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. @@ -234,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. @@ -245,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 @@ -256,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, @@ -280,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, @@ -315,12 +331,12 @@ perturb_buffer_moller_plesset .br -`pt2_max `_ +`pt2_max `_ The selection process stops when the largest PT2 (for all the state) is lower 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. @@ -352,7 +368,7 @@ perturb_buffer_moller_plesset Threshold to select determinants. Set by selection routines. -`var_pt2_ratio `_ +`var_pt2_ratio `_ The selection process stops when the energy ratio variational/(variational+PT2) is equal to var_pt2_ratio diff --git a/plugins/Perturbation/pt2_equations.irp.f b/plugins/Perturbation/pt2_equations.irp.f index b29e130f..66083f6f 100644 --- a/plugins/Perturbation/pt2_equations.irp.f +++ b/plugins/Perturbation/pt2_equations.irp.f @@ -45,37 +45,6 @@ subroutine pt2_epstein_nesbet ($arguments) end - -subroutine pt2_decontracted ($arguments) - use bitmasks - implicit none - $declarations - - BEGIN_DOC - END_DOC - - integer :: i,j - double precision :: diag_H_mat_elem_fock, h - double precision :: i_H_psi_array(N_st) - double precision :: coef_pert - PROVIDE selection_criterion - - ASSERT (Nint == N_int) - ASSERT (Nint > 0) - !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_pert_new_minilist(det_pert,minilist,idx_minilist,N_minilist,psi_selectors_coef,Nint,N_minilist,psi_selectors_size,N_st,i_H_psi_array,coef_pert) - H_pert_diag = 0.d0 - - - c_pert(1) = coef_pert - e_2_pert(1) = coef_pert * i_H_psi_array(1) -! print*,coef_pert,i_H_psi_array(1) - -end - - - - subroutine pt2_epstein_nesbet_2x2 ($arguments) use bitmasks implicit none @@ -98,8 +67,8 @@ subroutine pt2_epstein_nesbet_2x2 ($arguments) ASSERT (Nint == N_int) ASSERT (Nint > 0) - 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) + !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_fock(det_ref,det_pert,fock_diag_tmp,Nint) do i =1,N_st @@ -116,75 +85,6 @@ subroutine pt2_epstein_nesbet_2x2 ($arguments) c_pert(i) = 0.d0 endif H_pert_diag(i) = h*c_pert(i)*c_pert(i) -! print*, 'N_det,N_det_selectors = ',N_det,N_det_selectors -! print*, 'threshold_selectors',threshold_selectors -! print*, delta_e,i_H_psi_array(1) -! double precision :: hij,accu -! accu = 0.d0 -! do j = 1, N_det -! call i_H_j(det_pert,psi_selectors(1,1,j),N_int,hij) -! print*, 'psi_selectors_coef(j,1 = ',psi_selectors_coef(j,1),psi_coef(j,1) -! call debug_det(psi_det(1,1,i),N_int) -! call debug_det(psi_selectors(1,1,i),N_int) -! accu += psi_selectors_coef(j,1) * hij -! enddo -! print*, 'accu,ihpsi0',accu,i_H_psi_array(1) -! stop - else - e_2_pert(i) = 0.d0 - c_pert(i) = 0.d0 - H_pert_diag(i) = 0.d0 - endif - enddo -! if( e_2_pert(1) .ne. 0.d0)then -! print*,' e_2_pert(1) ', e_2_pert(1) -! endif - -end - - - -subroutine pt2_epstein_nesbet_2x2_no_ci_diag($arguments) - use bitmasks - implicit none - $declarations - - BEGIN_DOC - ! compute the Epstein-Nesbet 2x2 diagonalization coefficient and energetic contribution - ! - ! for the various N_st states. - ! - ! e_2_pert(i) = 0.5 * (( - E(i) ) - sqrt( ( - E(i)) ^2 + 4 ^2 ) - ! - ! c_pert(i) = e_2_pert(i)/ - ! - END_DOC - - integer :: i,j - double precision :: diag_H_mat_elem_fock,delta_e, h - double precision :: i_H_psi_array(N_st) - ASSERT (Nint == N_int) - ASSERT (Nint > 0) - 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) - - 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 - 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 - 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))) - endif - if (dabs(i_H_psi_array(i)) > 1.d-6) then - c_pert(i) = e_2_pert(i)/i_H_psi_array(i) - else - c_pert(i) = 0.d0 - endif - H_pert_diag(i) = h*c_pert(i)*c_pert(i) else e_2_pert(i) = 0.d0 c_pert(i) = 0.d0 @@ -194,8 +94,6 @@ subroutine pt2_epstein_nesbet_2x2_no_ci_diag($arguments) end - - subroutine pt2_moller_plesset ($arguments) use bitmasks implicit none @@ -246,11 +144,6 @@ subroutine pt2_moller_plesset ($arguments) endif do i =1,N_st H_pert_diag(i) = h -! if(dabs(i_H_psi_array(i)).gt.1.d-8)then -! print*, i_H_psi_array(i) -! call debug_det(det_pert,N_int) -! print*, h1,p1,h2,p2,s1,s2 -! endif c_pert(i) = i_H_psi_array(i) *delta_e e_2_pert(i) = c_pert(i) * i_H_psi_array(i) enddo diff --git a/plugins/Perturbation/pt2_new.irp.f b/plugins/Perturbation/pt2_new.irp.f deleted file mode 100644 index 2f9cfbfb..00000000 --- a/plugins/Perturbation/pt2_new.irp.f +++ /dev/null @@ -1,71 +0,0 @@ -subroutine i_H_psi_pert_new_minilist(key,keys,idx_key,N_minilist,coef,Nint,Ndet,Ndet_max,Nstate,i_H_psi_array,coef_pert) - 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_H_psi_array(Nstate) - double precision, intent(out) :: coef_pert - - integer :: idx(0:Ndet) - - integer :: i, ii,j, i_in_key, i_in_coef - double precision :: phase - integer :: exc(0:2,2,2) - double precision :: hij - double precision :: delta_e_final - double precision :: hjj - 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_H_psi_array = 0.d0 - 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) - i_in_key = idx(ii) - i_in_coef = idx_key(idx(ii)) - !DIR$ FORCEINLINE - call i_H_j(keys(1,1,i_in_key),key,Nint,hij) - i_H_psi_array(1) = i_H_psi_array(1) + coef(i_in_coef,1)*hij - 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 - print*, coef_pert * i_H_psi_array(1) - endif - - else - - do ii=1,idx(0) - i_in_key = idx(ii) - i_in_coef = idx_key(idx(ii)) - !DIR$ FORCEINLINE - call i_H_j(keys(1,1,i_in_key),key,Nint,hij) - i_H_psi_array(1) = i_H_psi_array(1) + coef(i_in_coef,1)*hij - do j = 1, Nstate - i_H_psi_array(j) = i_H_psi_array(j) + coef(i_in_coef,j)*hij - enddo - enddo - - endif - -end - diff --git a/plugins/Properties/EZFIO.cfg b/plugins/Properties/EZFIO.cfg index 2a5ae803..02f42ad8 100644 --- a/plugins/Properties/EZFIO.cfg +++ b/plugins/Properties/EZFIO.cfg @@ -2,11 +2,4 @@ type: double precision doc: z point on which the integrated delta rho is calculated interface: ezfio,provider,ocaml -default: 3.9 - -[threshld_two_bod_dm] -type: double precision -doc: threshold for the values of the alpha/beta two body dm evaluation -interface: ezfio,provider,ocaml -default: 0.000001 - +default: 3.9 \ No newline at end of file diff --git a/plugins/Properties/NEEDED_CHILDREN_MODULES b/plugins/Properties/NEEDED_CHILDREN_MODULES index 34de8ddb..aae89501 100644 --- a/plugins/Properties/NEEDED_CHILDREN_MODULES +++ b/plugins/Properties/NEEDED_CHILDREN_MODULES @@ -1 +1 @@ -Determinants Davidson +Determinants diff --git a/plugins/Properties/delta_rho.irp.f b/plugins/Properties/delta_rho.irp.f index 7803ba3d..69894c38 100644 --- a/plugins/Properties/delta_rho.irp.f +++ b/plugins/Properties/delta_rho.irp.f @@ -3,9 +3,9 @@ &BEGIN_PROVIDER [double precision, z_max] &BEGIN_PROVIDER [double precision, delta_z] implicit none - z_min = 0.d0 - z_max = 10.d0 - delta_z = 0.005d0 + z_min = -20.d0 + z_max = 20.d0 + delta_z = 0.1d0 N_z_pts = (z_max - z_min)/delta_z print*,'N_z_pts = ',N_z_pts diff --git a/plugins/Properties/give_mos_at_r.irp.f b/plugins/Properties/give_mos_at_r.irp.f deleted file mode 100644 index 20a7f712..00000000 --- a/plugins/Properties/give_mos_at_r.irp.f +++ /dev/null @@ -1,35 +0,0 @@ -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/hyperfine_constants.irp.f b/plugins/Properties/hyperfine_constants.irp.f index 6fa39278..e31b3ba4 100644 --- a/plugins/Properties/hyperfine_constants.irp.f +++ b/plugins/Properties/hyperfine_constants.irp.f @@ -102,11 +102,6 @@ END_PROVIDER conversion_factor_gauss_hcc(3) = 619.9027742370165d0 conversion_factor_cm_1_hcc(3) = 579.4924475562677d0 - ! boron - conversion_factor_mhz_hcc(5) = 1434.3655101868d0 - conversion_factor_gauss_hcc(5) = 511.817264334d0 - conversion_factor_cm_1_hcc(5) = 478.4528336953d0 - ! carbon conversion_factor_mhz_hcc(6) = 1124.18303629792945d0 conversion_factor_gauss_hcc(6) = 401.136570647523058d0 @@ -121,11 +116,6 @@ END_PROVIDER conversion_factor_mhz_hcc(8) = -606.1958551736545d0 conversion_factor_gauss_hcc(8) = -216.30574771560407d0 conversion_factor_cm_1_hcc(8) = -202.20517197179822d0 - - ! Phosphore - conversion_factor_mhz_hcc(15) = 1811.0967763744873d0 - conversion_factor_gauss_hcc(15) = 646.2445276897648d0 - conversion_factor_cm_1_hcc(15) = 604.1170297381395d0 END_PROVIDER @@ -151,7 +141,7 @@ subroutine print_hcc integer :: i,j print*,'Z AU GAUSS MHZ cm^-1' do i = 1, nucl_num - write(*,'(I2,X,F4.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) + write(*,'(I2,X,F3.1,X,4(F16.6,X))')i,nucl_charge(i),spin_density_at_nucleous(i),iso_hcc_gauss(i),iso_hcc_mhz(i),iso_hcc_cm_1(i) enddo end diff --git a/plugins/Properties/iunit_two_bod.irp.f b/plugins/Properties/iunit_two_bod.irp.f deleted file mode 100644 index e14d9893..00000000 --- a/plugins/Properties/iunit_two_bod.irp.f +++ /dev/null @@ -1,45 +0,0 @@ -BEGIN_PROVIDER [integer, i_unit_x_two_body_dm_ab] - implicit none - integer :: getUnitAndOpen - character*(128) :: file_name - file_name = trim(trim(ezfio_filename)//'/properties/two_body_dm_x') - i_unit_x_two_body_dm_ab = getUnitAndOpen(file_name,'w') - -END_PROVIDER - -BEGIN_PROVIDER [integer, i_unit_y_two_body_dm_ab] - implicit none - integer :: getUnitAndOpen - character*(128) :: file_name - file_name = trim(trim(ezfio_filename)//'/properties/two_body_dm_y') - i_unit_y_two_body_dm_ab = getUnitAndOpen(file_name,'w') - -END_PROVIDER - -BEGIN_PROVIDER [integer, i_unit_z_two_body_extra_diag_dm_ab] - implicit none - integer :: getUnitAndOpen - character*(128) :: file_name - file_name = trim(trim(ezfio_filename)//'/properties/two_body_dm_extra_diag') - i_unit_z_two_body_extra_diag_dm_ab = getUnitAndOpen(file_name,'w') - -END_PROVIDER - -BEGIN_PROVIDER [integer, i_unit_z_two_body_diag_dm_ab] - implicit none - integer :: getUnitAndOpen - character*(128) :: file_name - file_name = trim(trim(ezfio_filename)//'/properties/two_body_dm_diag') - i_unit_z_two_body_diag_dm_ab = getUnitAndOpen(file_name,'w') - -END_PROVIDER - -BEGIN_PROVIDER [integer, i_unit_z_two_body_total_dm_ab] - implicit none - integer :: getUnitAndOpen - character*(128) :: file_name - file_name = trim(trim(ezfio_filename)//'/properties/two_body_dm_total') - i_unit_z_two_body_total_dm_ab = getUnitAndOpen(file_name,'w') - -END_PROVIDER - diff --git a/plugins/Properties/mulliken.irp.f b/plugins/Properties/mulliken.irp.f index deeb90bf..cc0a2f8e 100644 --- a/plugins/Properties/mulliken.irp.f +++ b/plugins/Properties/mulliken.irp.f @@ -14,16 +14,13 @@ BEGIN_PROVIDER [double precision, spin_population, (ao_num_align,ao_num)] enddo END_PROVIDER - BEGIN_PROVIDER [double precision, spin_population_angular_momentum, (0:ao_l_max)] -&BEGIN_PROVIDER [double precision, spin_population_angular_momentum_per_atom, (0:ao_l_max,nucl_num)] +BEGIN_PROVIDER [double precision, spin_population_angular_momentum, (0:ao_l_max)] implicit none integer :: i double precision :: accu spin_population_angular_momentum = 0.d0 - spin_population_angular_momentum_per_atom = 0.d0 do i = 1, ao_num spin_population_angular_momentum(ao_l(i)) += spin_gross_orbital_product(i) - spin_population_angular_momentum_per_atom(ao_l(i),ao_nucl(i)) += spin_gross_orbital_product(i) enddo END_PROVIDER @@ -136,16 +133,6 @@ subroutine print_mulliken_sd print*,' ',trim(l_to_charater(i)),spin_population_angular_momentum(i) print*,'sum = ',accu enddo - print*,'Angular momentum analysis per atom' - print*,'Angular momentum analysis' - do j = 1,nucl_num - accu = 0.d0 - do i = 0, ao_l_max - accu += spin_population_angular_momentum_per_atom(i,j) - write(*,'(XX,I3,XX,A4,X,A4,X,F10.7)')j,trim(element_name(int(nucl_charge(j)))),trim(l_to_charater(i)),spin_population_angular_momentum_per_atom(i,j) - print*,'sum = ',accu - enddo - enddo end diff --git a/plugins/Properties/print_spin_density.irp.f b/plugins/Properties/print_spin_density.irp.f deleted file mode 100644 index b9cbe4e8..00000000 --- a/plugins/Properties/print_spin_density.irp.f +++ /dev/null @@ -1,36 +0,0 @@ -program print_sd - implicit none - read_wf = .True. - touch read_wf - call routine - -end - -subroutine routine - implicit none - integer :: i,j,k - double precision :: z - double precision :: r(3),accu,accu_alpha,accu_beta,tmp - double precision, allocatable :: aos_array(:) - allocate(aos_array(ao_num)) - r = 0.d0 - r(1) = z_min - do i = 1, N_z_pts - call give_all_aos_at_r(r,aos_array) - accu = 0.d0 - accu_alpha = 0.d0 - accu_beta = 0.d0 - do j = 1, ao_num - do k = 1, ao_num - tmp = aos_array(k) * aos_array(j) - accu += one_body_spin_density_ao(k,j) * tmp - accu_alpha += one_body_dm_ao_alpha(k,j) * tmp - accu_beta += one_body_dm_ao_beta(k,j) * tmp - enddo - enddo - r(1) += delta_z - write(33,'(100(f16.10,X))')r(1),accu,accu_alpha,accu_beta - enddo - - -end diff --git a/plugins/Properties/provide_deltarho.irp.f b/plugins/Properties/provide_deltarho.irp.f deleted file mode 100644 index d576d622..00000000 --- a/plugins/Properties/provide_deltarho.irp.f +++ /dev/null @@ -1,11 +0,0 @@ -program pouet - implicit none - read_wf = .True. - touch read_wf - call routine -end - -subroutine routine - implicit none - provide integrated_delta_rho_all_points -end diff --git a/plugins/Properties/test_two_body_dm.irp.f b/plugins/Properties/test_two_body_dm.irp.f deleted file mode 100644 index ec203026..00000000 --- a/plugins/Properties/test_two_body_dm.irp.f +++ /dev/null @@ -1,105 +0,0 @@ -program test_two_bod - implicit none - read_wf = .True. - touch read_wf - call routine -end -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 - accu = 0.d0 - - ! Diag part of the core two body dm - do i = 1, n_core_orb - h1 = list_core(i) - do j = 1, n_core_orb - h2 = list_core(j) - accu += two_body_dm_ab_diag_core(j,i) * mo_bielec_integral_jj(h1,h2) - enddo - enddo - - ! Diag part of the active two body dm - do i = 1, n_act_orb - h1 = list_act(i) - do j = 1, n_act_orb - h2 = list_act(j) - accu += two_body_dm_ab_diag_act(j,i) * mo_bielec_integral_jj(h1,h2) - enddo - enddo - - ! Diag part of the active <-> core two body dm - do i = 1, n_act_orb - h1 = list_act(i) - do j = 1, n_core_orb - h2 = list_core(j) - accu += two_body_dm_diag_core_act(j,i) * mo_bielec_integral_jj(h1,h2) - enddo - enddo - print*,'BI ELECTRONIC = ',accu - - double precision :: accu_extra_diag - accu_extra_diag = 0.d0 - ! purely active part of the two body dm - do l = 1, n_act_orb ! p2 - p2 = list_act(l) - do k = 1, n_act_orb ! h2 - h2 = list_act(k) - do j = 1, n_act_orb ! p1 - 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(h1,h2,p1,p2,mo_integrals_map) - enddo - enddo - enddo - enddo - - ! core <-> active part of the two body dm - do l = 1, n_act_orb ! p1 - p1 = list_act(l) - do k = 1, n_act_orb ! h1 - 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(h1,h2,p1,h2,mo_integrals_map) - enddo - enddo - enddo - - print*,'extra_diag = ',accu_extra_diag - double precision :: average_mono - call get_average(mo_mono_elec_integral,one_body_dm_mo,average_mono) - print*,'BI ELECTRONIC = ',accu+accu_extra_diag - print*,'MONO ELECTRONIC = ',average_mono - 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 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) - double precision :: phase - integer :: n_elements - n_elements = 0 - accu = 0.d0 - do i = 1, N_det - do j = i+1, N_det - call get_excitation_degree(psi_det(1,1,i),psi_det(1,1,j),degree,N_int) - if(degree.gt.2)cycle -! if(degree.ne.1)cycle - call get_excitation(psi_det(1,1,i),psi_det(1,1,j),exc,degree,phase,N_int) - call decode_exc(exc,degree,h1,p1,h2,p2,s1,s2) - if(s1.eq.s2)cycle - n_elements += 1 - call i_H_j(psi_det(1,1,i),psi_det(1,1,j),N_int,hij) - accu += 2.d0 * hij * psi_coef(i,1) * psi_coef(j,1) - enddo - enddo - print*,'n_elements = ',n_elements - print*,'`_ -* `Davidson `_ Documentation ============= diff --git a/plugins/Psiref_Utils/README.rst b/plugins/Psiref_Utils/README.rst index 2ceb6b98..35232d23 100644 --- a/plugins/Psiref_Utils/README.rst +++ b/plugins/Psiref_Utils/README.rst @@ -154,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 @@ -181,19 +181,19 @@ Documentation Binomial coefficients -`dble_fact `_ +`dble_fact `_ Undocumented -`dble_fact_even `_ +`dble_fact_even `_ n!! -`dble_fact_odd `_ +`dble_fact_odd `_ n!! -`dble_logfact `_ +`dble_logfact `_ n!! @@ -219,10 +219,6 @@ Documentation contains the new order of the elements. -`dtranspose `_ - Transpose input matrix A into output matrix B - - `erf0 `_ Undocumented @@ -240,11 +236,11 @@ Documentation n! -`fact_inv `_ +`fact_inv `_ 1/n! -`find_rotation `_ +`find_rotation `_ Find A.C = B @@ -274,7 +270,7 @@ Documentation Returns the index of the determinant in the ``psi_ref_sorted_bit`` array -`get_pseudo_inverse `_ +`get_pseudo_inverse `_ Find C = A^-1 @@ -535,7 +531,7 @@ Documentation to be in integer*8 format -`inv_int `_ +`inv_int `_ 1/i @@ -575,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 @@ -586,7 +582,7 @@ Documentation .br -`lapack_diag_s2 `_ +`lapack_diag_s2 `_ Diagonalize matrix H .br H is untouched between input and ouptut @@ -597,7 +593,7 @@ Documentation .br -`lapack_diagd `_ +`lapack_diagd `_ Diagonalize matrix H .br H is untouched between input and ouptut @@ -608,7 +604,7 @@ Documentation .br -`lapack_partial_diag `_ +`lapack_partial_diag `_ Diagonalize matrix H .br H is untouched between input and ouptut @@ -619,22 +615,14 @@ Documentation .br -`logfact `_ +`logfact `_ n! -`lowercase `_ +`lowercase `_ Transform to lower case -`map_load_from_disk `_ - Undocumented - - -`map_save_to_disk `_ - Undocumented - - `multiply_poly `_ Multiply two polynomials D(t) =! D(t) +( B(t)*C(t)) @@ -647,12 +635,12 @@ Documentation idx_non_ref_rev gives the reverse. -`normalize `_ +`normalize `_ Normalizes vector u u is expected to be aligned in memory. -`nproc `_ +`nproc `_ Number of current OpenMP threads @@ -674,7 +662,7 @@ Documentation .br -`ortho_lowdin `_ +`ortho_lowdin `_ Compute C_new=C_old.S^-1/2 orthogonalization. .br overlap : overlap matrix @@ -692,19 +680,6 @@ Documentation .br -`ortho_qr `_ - Orthogonalization using Q.R factorization - .br - A : matrix to orthogonalize - .br - LDA : leftmost dimension of A - .br - n : Number of rows of A - .br - m : Number of columns of A - .br - - `overlap_a_b_c `_ Undocumented @@ -885,7 +860,7 @@ Documentation to be in integer*8 format -`set_zero_extra_diag `_ +`set_zero_extra_diag `_ Undocumented @@ -912,22 +887,18 @@ Documentation .br -`transpose `_ - Transpose input matrix A into output matrix B - - -`u_dot_u `_ +`u_dot_u `_ Compute -`u_dot_v `_ +`u_dot_v `_ Compute -`wall_time `_ +`wall_time `_ The equivalent of cpu_time, but for the wall time. -`write_git_log `_ +`write_git_log `_ Write the last git commit in file iunit. diff --git a/plugins/Psiref_Utils/psi_ref_utils.irp.f b/plugins/Psiref_Utils/psi_ref_utils.irp.f index c4147ebc..41db2f10 100644 --- a/plugins/Psiref_Utils/psi_ref_utils.irp.f +++ b/plugins/Psiref_Utils/psi_ref_utils.irp.f @@ -97,10 +97,6 @@ END_PROVIDER endif enddo N_det_non_ref = i_non_ref - if (N_det_non_ref < 1) then - print *, 'Error : All determinants are in the reference' - stop -1 - endif END_PROVIDER BEGIN_PROVIDER [ integer(bit_kind), psi_non_ref_restart, (N_int,2,psi_det_size) ] diff --git a/plugins/Psiref_threshold/psi_ref.irp.f b/plugins/Psiref_threshold/psi_ref.irp.f index ee69ef5c..5e722822 100644 --- a/plugins/Psiref_threshold/psi_ref.irp.f +++ b/plugins/Psiref_threshold/psi_ref.irp.f @@ -6,22 +6,19 @@ use bitmasks &BEGIN_PROVIDER [ integer, N_det_ref ] implicit none BEGIN_DOC - ! Reference wave function, defined as determinants with amplitudes > 0.05 + ! Reference wave function, defined as determinants with coefficients > 0.05 ! idx_ref gives the indice of the ref determinant in psi_det. END_DOC integer :: i, k, l logical :: good - double precision, parameter :: threshold=0.05d0 - double precision :: t(N_states) + double precision, parameter :: threshold=0.05d0 N_det_ref = 0 - do l = 1, N_states - t(l) = threshold * abs_psi_coef_max(l) - enddo + t = threshold * abs_psi_coef_max do i=1,N_det good = .False. - do l=1, N_states + do l = 1, N_states psi_ref_coef(i,l) = 0.d0 - good = good.or.(dabs(psi_coef(i,l)) > t(l)) + good = good.or.(dabs(psi_coef(i,l)) > t) enddo if (good) then N_det_ref = N_det_ref+1 diff --git a/plugins/QmcChem/e_curve_qmc.irp.f b/plugins/QmcChem/e_curve_qmc.irp.f index 169db84e..4beed3fa 100644 --- a/plugins/QmcChem/e_curve_qmc.irp.f +++ b/plugins/QmcChem/e_curve_qmc.irp.f @@ -1,12 +1,10 @@ program e_curve use bitmasks implicit none - integer :: i,j,k, kk, nab, m, l + integer :: i,j,k, nab, m, l double precision :: norm, E, hij, num, ci, cj integer, allocatable :: iorder(:) double precision , allocatable :: norm_sort(:) - PROVIDE mo_bielec_integrals_in_map - nab = n_det_alpha_unique+n_det_beta_unique allocate ( norm_sort(0:nab), iorder(0:nab) ) @@ -62,7 +60,7 @@ program e_curve num = 0.d0 norm = 0.d0 m = 0 - !$OMP PARALLEL DEFAULT(SHARED) PRIVATE(k,kk,l,det_i,det_j,ci,cj,hij) REDUCTION(+:norm,m,num) + !$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 @@ -70,19 +68,15 @@ program e_curve cycle endif ci = psi_bilinear_matrix_values(k,1) - do kk=1,N_int - det_i(kk,1) = psi_det_alpha_unique(kk,psi_bilinear_matrix_rows(k)) - det_i(kk,2) = psi_det_beta_unique(kk,psi_bilinear_matrix_columns(k)) - enddo + 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) - do kk=1,N_int - det_j(kk,1) = psi_det_alpha_unique(kk,psi_bilinear_matrix_rows(l)) - det_j(kk,2) = psi_det_beta_unique(kk,psi_bilinear_matrix_columns(l)) - enddo + 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 diff --git a/plugins/Selectors_CASSD/NEEDED_CHILDREN_MODULES b/plugins/Selectors_CASSD/NEEDED_CHILDREN_MODULES deleted file mode 100644 index 8b137891..00000000 --- a/plugins/Selectors_CASSD/NEEDED_CHILDREN_MODULES +++ /dev/null @@ -1 +0,0 @@ - diff --git a/plugins/Selectors_CASSD/README.rst b/plugins/Selectors_CASSD/README.rst deleted file mode 100644 index 19b4ec2b..00000000 --- a/plugins/Selectors_CASSD/README.rst +++ /dev/null @@ -1,12 +0,0 @@ -=============== -Selectors_CASSD -=============== - -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/Selectors_CASSD/selectors.irp.f b/plugins/Selectors_CASSD/selectors.irp.f deleted file mode 100644 index ab36527d..00000000 --- a/plugins/Selectors_CASSD/selectors.irp.f +++ /dev/null @@ -1,95 +0,0 @@ -use bitmasks - -BEGIN_PROVIDER [ integer, psi_selectors_size ] - implicit none - psi_selectors_size = psi_det_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 - N_det_selectors = N_det -END_PROVIDER - - BEGIN_PROVIDER [ integer(bit_kind), psi_selectors, (N_int,2,psi_selectors_size) ] -&BEGIN_PROVIDER [ double precision, psi_selectors_coef, (psi_selectors_size,N_states) ] - implicit none - BEGIN_DOC - ! Determinants on which we apply for perturbation. - END_DOC - integer :: i, k, l, m - logical :: good - - do i=1,N_det_generators - do k=1,N_int - psi_selectors(k,1,i) = psi_det_generators(k,1,i) - psi_selectors(k,2,i) = psi_det_generators(k,2,i) - enddo - enddo - do k=1,N_states - do i=1,N_det_selectors - psi_selectors_coef(i,k) = psi_coef_generators(i,k) - enddo - enddo - - m=N_det_generators - - do i=1,N_det - do l=1,n_cas_bitmask - good = .True. - do k=1,N_int - good = good .and. ( & - iand(not(cas_bitmask(k,1,l)), psi_det_sorted(k,1,i)) == & - iand(not(cas_bitmask(k,1,l)), HF_bitmask(k,1)) .and. ( & - iand(not(cas_bitmask(k,2,l)), psi_det_sorted(k,2,i)) == & - iand(not(cas_bitmask(k,2,l)), HF_bitmask(k,2) )) ) - enddo - if (good) then - exit - endif - enddo - if (.not.good) then - m = m+1 - do k=1,N_int - psi_selectors(k,1,m) = psi_det_sorted(k,1,i) - psi_selectors(k,2,m) = psi_det_sorted(k,2,i) - enddo - psi_selectors_coef(m,:) = psi_coef_sorted(i,:) - endif - enddo - if (N_det /= m) then - print *, N_det, m - stop 'N_det /= m' - endif -END_PROVIDER - -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 - END_DOC - integer :: i - double precision :: diag_H_mat_elem - 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 - - diff --git a/plugins/Selectors_CASSD/zmq.irp.f b/plugins/Selectors_CASSD/zmq.irp.f deleted file mode 100644 index 4359a876..00000000 --- a/plugins/Selectors_CASSD/zmq.irp.f +++ /dev/null @@ -1,122 +0,0 @@ -subroutine zmq_put_psi(zmq_to_qp_run_socket,worker_id, energy, size_energy) - use f77_zmq - implicit none - BEGIN_DOC -! Put the wave function on the qp_run scheduler - END_DOC - integer(ZMQ_PTR), intent(in) :: zmq_to_qp_run_socket - integer, intent(in) :: worker_id - integer, intent(in) :: size_energy - double precision, intent(out) :: energy(size_energy) - integer :: rc - character*(256) :: msg - - write(msg,*) 'put_psi ', worker_id, N_states, N_det, psi_det_size, n_det_generators, n_det_selectors - - rc = f77_zmq_send(zmq_to_qp_run_socket,trim(msg),len(trim(msg)),ZMQ_SNDMORE) - if (rc /= len(trim(msg))) then - print *, 'f77_zmq_send(zmq_to_qp_run_socket,trim(msg),len(trim(msg)),ZMQ_SNDMORE)' - stop 'error' - endif - - rc = f77_zmq_send(zmq_to_qp_run_socket,psi_det,N_int*2*N_det*bit_kind,ZMQ_SNDMORE) - if (rc /= N_int*2*N_det*bit_kind) then - print *, 'f77_zmq_send(zmq_to_qp_run_socket,psi_det,N_int*2*N_det*bit_kind,ZMQ_SNDMORE)' - stop 'error' - endif - - rc = f77_zmq_send(zmq_to_qp_run_socket,psi_coef,psi_det_size*N_states*8,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,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 - - rc = f77_zmq_recv(zmq_to_qp_run_socket,msg,len(msg),0) - if (msg(1:rc) /= 'put_psi_reply 1') then - print *, rc, trim(msg) - print *, 'Error in put_psi_reply' - stop 'error' - endif - -end - - - -subroutine zmq_get_psi(zmq_to_qp_run_socket, worker_id, energy, size_energy) - use f77_zmq - implicit none - BEGIN_DOC -! Get the wave function from the qp_run scheduler - END_DOC - integer(ZMQ_PTR), intent(in) :: zmq_to_qp_run_socket - integer, intent(in) :: worker_id - integer, intent(in) :: size_energy - double precision, intent(out) :: energy(size_energy) - integer :: rc - character*(64) :: msg - - write(msg,*) 'get_psi ', worker_id - - rc = f77_zmq_send(zmq_to_qp_run_socket,trim(msg),len(trim(msg)),0) - if (rc /= len(trim(msg))) then - print *, 'f77_zmq_send(zmq_to_qp_run_socket,trim(msg),len(trim(msg)),0)' - stop 'error' - endif - - rc = f77_zmq_recv(zmq_to_qp_run_socket,msg,len(msg),0) - if (msg(1:13) /= 'get_psi_reply') then - print *, rc, trim(msg) - print *, 'Error in get_psi_reply' - stop 'error' - endif - - integer :: N_states_read, N_det_read, psi_det_size_read - integer :: N_det_selectors_read, N_det_generators_read - read(msg(14:rc),*) rc, N_states_read, N_det_read, psi_det_size_read, & - N_det_generators_read, N_det_selectors_read - if (rc /= worker_id) then - print *, 'Wrong worker ID' - stop 'error' - endif - - N_states = N_states_read - N_det = N_det_read - psi_det_size = psi_det_size_read - - rc = f77_zmq_recv(zmq_to_qp_run_socket,psi_det,N_int*2*N_det*bit_kind,ZMQ_SNDMORE) - if (rc /= N_int*2*N_det*bit_kind) then - print *, 'f77_zmq_recv(zmq_to_qp_run_socket,psi_det,N_int*2*N_det*bit_kind,ZMQ_SNDMORE)' - stop 'error' - endif - - rc = f77_zmq_recv(zmq_to_qp_run_socket,psi_coef,psi_det_size*N_states*8,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,ZMQ_SNDMORE)' - stop 'error' - endif - TOUCH psi_det_size N_det N_states 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 *, 'f77_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 - -end - - diff --git a/plugins/Selectors_full/README.rst b/plugins/Selectors_full/README.rst index fc264fc1..393e9421 100644 --- a/plugins/Selectors_full/README.rst +++ b/plugins/Selectors_full/README.rst @@ -161,19 +161,15 @@ Documentation n_double_selectors = number of double excitations in the selectors determinants -`psi_selectors `_ +`psi_selectors `_ Determinants on which we apply for perturbation. -`psi_selectors_coef `_ +`psi_selectors_coef `_ Determinants on which we apply for perturbation. -`psi_selectors_coef_transp `_ - Transposed psi_selectors - - -`psi_selectors_diag_h_mat `_ +`psi_selectors_diag_h_mat `_ Diagonal elements of the H matrix for each selectors @@ -181,7 +177,7 @@ Documentation Undocumented -`zmq_get_psi `_ +`zmq_get_psi `_ Get the wave function from the qp_run scheduler diff --git a/plugins/Selectors_full/e_corr_selectors.irp.f b/plugins/Selectors_full/e_corr_selectors.irp.f index fec480f0..952e1c23 100644 --- a/plugins/Selectors_full/e_corr_selectors.irp.f +++ b/plugins/Selectors_full/e_corr_selectors.irp.f @@ -56,7 +56,7 @@ END_PROVIDER i_H_HF_per_selectors(i) = hij E_corr_per_selectors(i) = psi_selectors_coef(i,1) * hij E_corr_double_only += E_corr_per_selectors(i) -! E_corr_second_order += hij * hij /(ref_bitmask_energy - diag_H_mat_elem(psi_selectors(1,1,i),N_int)) + E_corr_second_order += hij * hij /(ref_bitmask_energy - diag_H_mat_elem(psi_selectors(1,1,i),N_int)) elseif(exc_degree_per_selectors(i) == 0)then coef_hf_selector = psi_selectors_coef(i,1) E_corr_per_selectors(i) = -1000.d0 diff --git a/plugins/Selectors_full/selectors.irp.f b/plugins/Selectors_full/selectors.irp.f index e8e746c8..27036f33 100644 --- a/plugins/Selectors_full/selectors.irp.f +++ b/plugins/Selectors_full/selectors.irp.f @@ -14,13 +14,13 @@ BEGIN_PROVIDER [ integer, N_det_selectors] integer :: i double precision :: norm, norm_max call write_time(output_determinants) - N_det_selectors = N_det + 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 + N_det_selectors = i-1 exit endif enddo diff --git a/plugins/Selectors_no_sorted/selectors.irp.f b/plugins/Selectors_no_sorted/selectors.irp.f index 83a8d472..9273c7bb 100644 --- a/plugins/Selectors_no_sorted/selectors.irp.f +++ b/plugins/Selectors_no_sorted/selectors.irp.f @@ -40,7 +40,6 @@ END_PROVIDER do k=1,N_states do i=1,N_det_selectors psi_selectors_coef(i,k) = psi_coef(i,k) -! print*, 'psi_selectors_coef(i,k) == ',psi_selectors_coef(i,k) enddo enddo END_PROVIDER diff --git a/plugins/Selectors_no_sorted/tree_dependency.png b/plugins/Selectors_no_sorted/tree_dependency.png deleted file mode 100644 index e69de29b..00000000 diff --git a/plugins/loc_cele/NEEDED_CHILDREN_MODULES b/plugins/loc_cele/NEEDED_CHILDREN_MODULES index fbba67dd..6731bb70 100644 --- a/plugins/loc_cele/NEEDED_CHILDREN_MODULES +++ b/plugins/loc_cele/NEEDED_CHILDREN_MODULES @@ -1 +1 @@ -MO_Basis Integrals_Bielec Bitmask +MO_Basis \ No newline at end of file diff --git a/plugins/loc_cele/loc_cele.irp.f b/plugins/loc_cele/loc_cele.irp.f index 2d47c633..52e0ef28 100644 --- a/plugins/loc_cele/loc_cele.irp.f +++ b/plugins/loc_cele/loc_cele.irp.f @@ -92,7 +92,7 @@ - nrot(1) = 2 ! number of orbitals to be localized + nrot(1) = 64 ! number of orbitals to be localized integer :: index_rot(1000,1) @@ -101,73 +101,261 @@ cmoref = 0.d0 irot = 0 - irot(1,1) = 11 - irot(2,1) = 12 - cmoref(15,1,1) = 1.d0 ! - cmoref(14,2,1) = 1.d0 ! +! H2 molecule for the mixed localization + do i=1,64 + irot(i,1) = i+2 + enddo -! ESATRIENE with 3 bonding and anti bonding orbitals -! First bonding orbital for esa -! cmoref(7,1,1) = 1.d0 ! -! cmoref(26,1,1) = 1.d0 ! -! Second bonding orbital for esa -! cmoref(45,2,1) = 1.d0 ! -! cmoref(64,2,1) = 1.d0 ! -! Third bonding orbital for esa -! cmoref(83,3,1) = 1.d0 ! -! cmoref(102,3,1) = 1.d0 ! - -! First anti bonding orbital for esa -! cmoref(7,4,1) = 1.d0 ! -! cmoref(26,4,1) = -1.d0 ! -! Second anti bonding orbital for esa -! cmoref(45,5,1) = 1.d0 ! -! cmoref(64,5,1) = -1.d0 ! -! Third anti bonding orbital for esa -! cmoref(83,6,1) = 1.d0 ! -! cmoref(102,6,1) = -1.d0 ! - -! ESATRIENE with 2 bonding and anti bonding orbitals -! AND 2 radical orbitals -! First radical orbital -! cmoref(7,1,1) = 1.d0 ! -! First bonding orbital -! cmoref(26,2,1) = 1.d0 ! -! cmoref(45,2,1) = 1.d0 ! -! Second bonding orbital -! cmoref(64,3,1) = 1.d0 ! -! cmoref(83,3,1) = 1.d0 ! -! Second radical orbital for esa -! cmoref(102,4,1) = 1.d0 ! - -! First anti bonding orbital for esa -! cmoref(26,5,1) = 1.d0 ! -! cmoref(45,5,1) =-1.d0 ! -! Second anti bonding orbital for esa -! cmoref(64,6,1) = 1.d0 ! -! cmoref(83,6,1) =-1.d0 ! - -! ESATRIENE with 1 central bonding and anti bonding orbitals -! AND 4 radical orbitals -! First radical orbital - cmoref(7,1,1) = 1.d0 ! -! Second radical orbital - cmoref(26,2,1) = 1.d0 ! -! First bonding orbital - cmoref(45,3,1) = 1.d0 ! - cmoref(64,3,1) = 1.d0 ! -! Third radical orbital for esa - cmoref(83,4,1) = 1.d0 ! -! Fourth radical orbital for esa - cmoref(102,5,1) = 1.d0 ! -! First anti bonding orbital - cmoref(45,6,1) = 1.d0 ! - cmoref(64,6,1) =-1.d0 ! + do i=1,17 + cmoref(i+1,i,1)=1.d0 + enddo + cmoref(19,19-1,1)=1.d0 + cmoref(20,19-1,1)=-1.d0 + cmoref(19,20-1,1)=-1.d0 + cmoref(20,20-1,1)=-1.d0 + cmoref(21,20-1,1)=2.d0 + cmoref(22,21-1,1)=1.d0 + cmoref(23,22-1,1)=1.d0 + cmoref(24,23-1,1)=1.d0 + cmoref(25,24-1,1)=1.d0 + cmoref(26,24-1,1)=-1.d0 + cmoref(25,25-1,1)=-1.d0 + cmoref(26,25-1,1)=-1.d0 + cmoref(27,25-1,1)=2.d0 + cmoref(28,26-1,1)=1.d0 + cmoref(29,27-1,1)=1.d0 + cmoref(30,28-1,1)=1.d0 + + cmoref(31,29-1,1)=1.d0 + cmoref(32,29-1,1)=-1.d0 + cmoref(31,30-1,1)=-1.d0 + cmoref(32,30-1,1)=-1.d0 + cmoref(33,30-1,1)=2.d0 + cmoref(34,31-1,1)=1.d0 + cmoref(35,32-1,1)=1.d0 + cmoref(36,33-1,1)=1.d0 + + do i=33,49 + cmoref(i+5,i,1)= 1.d0 + enddo + + cmoref(55,52-2,1)=1.d0 + cmoref(56,52-2,1)=-1.d0 + cmoref(55,53-2,1)=-1.d0 + cmoref(56,53-2,1)=-1.d0 + cmoref(57,53-2,1)=2.d0 + cmoref(58,54-2,1)=1.d0 + cmoref(59,55-2,1)=1.d0 + cmoref(60,56-2,1)=1.d0 + + cmoref(61,57-2,1)=1.d0 + cmoref(62,57-2,1)=-1.d0 + cmoref(61,58-2,1)=-1.d0 + cmoref(62,58-2,1)=-1.d0 + cmoref(63,58-2,1)=2.d0 + cmoref(64,59-2,1)=1.d0 + cmoref(65,60-2,1)=1.d0 + cmoref(66,61-2,1)=1.d0 + + cmoref(67,62-2,1)=1.d0 + cmoref(68,62-2,1)=-1.d0 + cmoref(67,63-2,1)=-1.d0 + cmoref(68,63-2,1)=-1.d0 + cmoref(69,63-2,1)=2.d0 + cmoref(70,64-2,1)=1.d0 + cmoref(71,65-2,1)=1.d0 + cmoref(72,66-2,1)=1.d0 +! H2 molecule +! do i=1,66 +! irot(i,1) = i +! enddo +! +! do i=1,18 +! cmoref(i,i,1)=1.d0 +! enddo +! cmoref(19,19,1)=1.d0 +! cmoref(20,19,1)=-1.d0 +! cmoref(19,20,1)=-1.d0 +! cmoref(20,20,1)=-1.d0 +! cmoref(21,20,1)=2.d0 +! cmoref(22,21,1)=1.d0 +! cmoref(23,22,1)=1.d0 +! cmoref(24,23,1)=1.d0 +! +! +! cmoref(25,24,1)=1.d0 +! cmoref(26,24,1)=-1.d0 +! cmoref(25,25,1)=-1.d0 +! cmoref(26,25,1)=-1.d0 +! cmoref(27,25,1)=2.d0 +! cmoref(28,26,1)=1.d0 +! cmoref(29,27,1)=1.d0 +! cmoref(30,28,1)=1.d0 +! +! cmoref(31,29,1)=1.d0 +! cmoref(32,29,1)=-1.d0 +! cmoref(31,30,1)=-1.d0 +! cmoref(32,30,1)=-1.d0 +! cmoref(33,30,1)=2.d0 +! cmoref(34,31,1)=1.d0 +! cmoref(35,32,1)=1.d0 +! cmoref(36,33,1)=1.d0 +! +! do i=34,51 +! cmoref(i+3,i,1)= 1.d0 +! enddo +! +! cmoref(55,52,1)=1.d0 +! cmoref(56,52,1)=-1.d0 +! cmoref(55,53,1)=-1.d0 +! cmoref(56,53,1)=-1.d0 +! cmoref(57,53,1)=2.d0 +! cmoref(58,54,1)=1.d0 +! cmoref(59,55,1)=1.d0 +! cmoref(60,56,1)=1.d0 +! +! cmoref(61,57,1)=1.d0 +! cmoref(62,57,1)=-1.d0 +! cmoref(61,58,1)=-1.d0 +! cmoref(62,58,1)=-1.d0 +! cmoref(63,58,1)=2.d0 +! cmoref(64,59,1)=1.d0 +! cmoref(65,60,1)=1.d0 +! cmoref(66,61,1)=1.d0 +! +! cmoref(67,62,1)=1.d0 +! cmoref(68,62,1)=-1.d0 +! cmoref(67,63,1)=-1.d0 +! cmoref(68,63,1)=-1.d0 +! cmoref(69,63,1)=2.d0 +! cmoref(70,64,1)=1.d0 +! cmoref(71,65,1)=1.d0 +! cmoref(72,66,1)=1.d0 +! H atom +! do i=1,33 +! irot(i,1) = i +! enddo +! +! do i=1,18 +! cmoref(i,i,1)=1.d0 +! enddo +! cmoref(19,19,1)=1.d0 +! cmoref(20,19,1)=-1.d0 +! cmoref(19,20,1)=-1.d0 +! cmoref(20,20,1)=-1.d0 +! cmoref(21,20,1)=2.d0 +! cmoref(22,21,1)=1.d0 +! cmoref(23,22,1)=1.d0 +! cmoref(24,23,1)=1.d0 + + +! cmoref(25,24,1)=1.d0 +! cmoref(26,24,1)=-1.d0 +! cmoref(25,25,1)=-1.d0 +! cmoref(26,25,1)=-1.d0 +! cmoref(27,25,1)=2.d0 +! cmoref(28,26,1)=1.d0 +! cmoref(29,27,1)=1.d0 +! cmoref(30,28,1)=1.d0 +! +! cmoref(31,29,1)=1.d0 +! cmoref(32,29,1)=-1.d0 +! cmoref(31,30,1)=-1.d0 +! cmoref(32,30,1)=-1.d0 +! cmoref(33,30,1)=2.d0 +! cmoref(34,31,1)=1.d0 +! cmoref(35,32,1)=1.d0 +! cmoref(36,33,1)=1.d0 + + ! Definition of the index of the MO to be rotated +! irot(2,1) = 21 ! the first mo to be rotated is the 21 th MO +! irot(3,1) = 22 ! etc.... +! irot(4,1) = 23 ! +! irot(5,1) = 24 ! +! irot(6,1) = 25 ! + +!N2 +! irot(1,1) = 5 +! irot(2,1) = 6 +! irot(3,1) = 7 +! irot(4,1) = 8 +! irot(5,1) = 9 +! irot(6,1) = 10 +! +! cmoref(5,1,1) = 1.d0 ! +! cmoref(6,2,1) = 1.d0 ! +! cmoref(7,3,1) = 1.d0 ! +! cmoref(40,4,1) = 1.d0 ! +! cmoref(41,5,1) = 1.d0 ! +! cmoref(42,6,1) = 1.d0 ! +!END N2 + +!HEXATRIENE +! irot(1,1) = 20 +! irot(2,1) = 21 +! irot(3,1) = 22 +! irot(4,1) = 23 +! irot(5,1) = 24 +! irot(6,1) = 25 +! +! cmoref(7,1,1) = 1.d0 ! +! cmoref(26,1,1) = 1.d0 ! +! cmoref(45,2,1) = 1.d0 ! +! cmoref(64,2,1) = 1.d0 ! +! cmoref(83,3,1) = 1.d0 ! +! cmoref(102,3,1) = 1.d0 ! +! cmoref(7,4,1) = 1.d0 ! +! cmoref(26,4,1) = -1.d0 ! +! cmoref(45,5,1) = 1.d0 ! +! cmoref(64,5,1) = -1.d0 ! +! cmoref(83,6,1) = 1.d0 ! +! cmoref(102,6,1) = -1.d0 ! +!END HEXATRIENE + +!!!!H2 H2 CAS +! irot(1,1) = 1 +! irot(2,1) = 2 +! +! cmoref(1,1,1) = 1.d0 +! cmoref(37,2,1) = 1.d0 +!END H2 +!!!! LOCALIZATION ON THE BASIS FUNCTIONS +! do i = 1, nrot(1) +! irot(i,1) = i +! cmoref(i,i,1) = 1.d0 +! enddo + +!END BASISLOC + +! do i = 1, nrot(1) +! irot(i,1) = 4+i +! enddo do i = 1, nrot(1) print*,'irot(i,1) = ',irot(i,1) enddo +! pause + + ! you define the guess vectors that you want + ! the new MO to be close to + ! cmore(i,j,1) = < AO_i | guess_vector_MO(j) > + ! i goes from 1 to ao_num + ! j goes from 1 to nrot(1) + + ! Here you must go to the GAMESS output file + ! where the AOs are listed and explicited + ! From the basis of this knowledge you can build your + ! own guess vectors for the MOs + ! The new MOs are provided in output + ! in the same order than the guess MOs +! do i = 1, nrot(1) +! j = 5+(i-1)*15 +! cmoref(j,i,1) = 0.2d0 +! cmoref(j+3,i,1) = 0.12d0 +! print*,'j = ',j +! enddo +! pause diff --git a/plugins/loc_cele/loc_exchange_int.irp.f b/plugins/loc_cele/loc_exchange_int.irp.f deleted file mode 100644 index 8bb47d89..00000000 --- a/plugins/loc_cele/loc_exchange_int.irp.f +++ /dev/null @@ -1,110 +0,0 @@ -program loc_int - implicit none - integer :: i,j,k,l,iorb,jorb - double precision :: exchange_int(mo_tot_num) - integer :: iorder(mo_tot_num) - integer :: indices(mo_tot_num,2) - logical :: list_core_inact_check(mo_tot_num) - integer :: n_rot - indices = 0 - list_core_inact_check = .True. - n_rot = 0 - do i = 1, n_core_inact_orb - iorb = list_core_inact(i) - exchange_int = 0.d0 - iorder = 0 - print*,'' - if(list_core_inact_check(iorb) .eqv. .False.)cycle - do j = i+1, n_core_inact_orb - jorb = list_core_inact(j) - iorder(jorb) = jorb - exchange_int(jorb) = -mo_bielec_integral_jj_exchange(iorb,jorb) - enddo - n_rot += 1 - call dsort(exchange_int,iorder,mo_tot_num) - indices(n_rot,1) = iorb - indices(n_rot,2) = iorder(1) - list_core_inact_check(iorder(1)) = .False. - print*,indices(n_rot,1),indices(n_rot,2) - print*,'' - print*,'' - enddo - print*,'****************************' - print*,'-+++++++++++++++++++++++++' - do i = 1, n_rot - iorb = indices(i,1) - jorb = indices(i,2) - print*,iorb,jorb - call mix_mo_jk(iorb,jorb) - enddo - - indices = 0 - list_core_inact_check = .True. - n_rot = 0 - do i = 1, n_act_orb - iorb = list_act(i) - exchange_int = 0.d0 - iorder = 0 - print*,'' - if(list_core_inact_check(iorb) .eqv. .False.)cycle - do j = i+1, n_act_orb - jorb = list_act(j) - iorder(jorb) = jorb - exchange_int(jorb) = -mo_bielec_integral_jj_exchange(iorb,jorb) - enddo - n_rot += 1 - call dsort(exchange_int,iorder,mo_tot_num) - indices(n_rot,1) = iorb - indices(n_rot,2) = iorder(1) - list_core_inact_check(iorder(1)) = .False. - print*,indices(n_rot,1),indices(n_rot,2) - print*,'' - print*,'' - enddo - print*,'****************************' - print*,'-+++++++++++++++++++++++++' - do i = 1, n_rot - iorb = indices(i,1) - jorb = indices(i,2) - print*,iorb,jorb - call mix_mo_jk(iorb,jorb) - enddo - - indices = 0 - list_core_inact_check = .True. - n_rot = 0 - do i = 1, n_virt_orb - iorb = list_virt(i) - exchange_int = 0.d0 - iorder = 0 - print*,'' - if(list_core_inact_check(iorb) .eqv. .False.)cycle - do j = i+1, n_virt_orb - jorb = list_virt(j) - iorder(jorb) = jorb - exchange_int(jorb) = -mo_bielec_integral_jj_exchange(iorb,jorb) - enddo - n_rot += 1 - call dsort(exchange_int,iorder,mo_tot_num) - indices(n_rot,1) = iorb - indices(n_rot,2) = iorder(1) - list_core_inact_check(iorder(1)) = .False. - print*,indices(n_rot,1),indices(n_rot,2) - print*,'' - print*,'' - enddo - print*,'****************************' - print*,'-+++++++++++++++++++++++++' - do i = 1, n_rot - iorb = indices(i,1) - jorb = indices(i,2) - print*,iorb,jorb - call mix_mo_jk(iorb,jorb) - enddo - - - - call save_mos - - -end diff --git a/plugins/loc_cele/loc_exchange_int_act.irp.f b/plugins/loc_cele/loc_exchange_int_act.irp.f deleted file mode 100644 index f332dd5d..00000000 --- a/plugins/loc_cele/loc_exchange_int_act.irp.f +++ /dev/null @@ -1,45 +0,0 @@ -program loc_int - implicit none - integer :: i,j,k,l,iorb,jorb - double precision :: exchange_int(mo_tot_num) - integer :: iorder(mo_tot_num) - integer :: indices(mo_tot_num,2) - logical :: list_core_inact_check(mo_tot_num) - integer :: n_rot - - indices = 0 - list_core_inact_check = .True. - n_rot = 0 - do i = 1, n_act_orb - iorb = list_act(i) - exchange_int = 0.d0 - iorder = 0 - print*,'' - if(list_core_inact_check(iorb) .eqv. .False.)cycle - do j = i+1, n_act_orb - jorb = list_act(j) - iorder(jorb) = jorb - exchange_int(jorb) = -mo_bielec_integral_jj_exchange(iorb,jorb) - enddo - n_rot += 1 - call dsort(exchange_int,iorder,mo_tot_num) - indices(n_rot,1) = iorb - indices(n_rot,2) = iorder(1) - list_core_inact_check(iorder(1)) = .False. - print*,indices(n_rot,1),indices(n_rot,2) - print*,'' - print*,'' - enddo - print*,'****************************' - print*,'-+++++++++++++++++++++++++' - do i = 1, n_rot - iorb = indices(i,1) - jorb = indices(i,2) - print*,iorb,jorb - call mix_mo_jk(iorb,jorb) - enddo - - call save_mos - - -end diff --git a/plugins/loc_cele/loc_exchange_int_inact.irp.f b/plugins/loc_cele/loc_exchange_int_inact.irp.f deleted file mode 100644 index fcf20ced..00000000 --- a/plugins/loc_cele/loc_exchange_int_inact.irp.f +++ /dev/null @@ -1,45 +0,0 @@ -program loc_int - implicit none - integer :: i,j,k,l,iorb,jorb - double precision :: exchange_int(mo_tot_num) - integer :: iorder(mo_tot_num) - integer :: indices(mo_tot_num,2) - logical :: list_core_inact_check(mo_tot_num) - integer :: n_rot - indices = 0 - list_core_inact_check = .True. - n_rot = 0 - do i = 1, n_core_inact_orb - iorb = list_core_inact(i) - exchange_int = 0.d0 - iorder = 0 - print*,'' - if(list_core_inact_check(iorb) .eqv. .False.)cycle - do j = i+1, n_core_inact_orb - jorb = list_core_inact(j) - iorder(jorb) = jorb - exchange_int(jorb) = -mo_bielec_integral_jj_exchange(iorb,jorb) - enddo - n_rot += 1 - call dsort(exchange_int,iorder,mo_tot_num) - indices(n_rot,1) = iorb - indices(n_rot,2) = iorder(1) - list_core_inact_check(iorder(1)) = .False. - print*,indices(n_rot,1),indices(n_rot,2) - print*,'' - print*,'' - enddo - print*,'****************************' - print*,'-+++++++++++++++++++++++++' - do i = 1, n_rot - iorb = indices(i,1) - jorb = indices(i,2) - print*,iorb,jorb - call mix_mo_jk(iorb,jorb) - enddo - - - call save_mos - - -end diff --git a/plugins/loc_cele/loc_exchange_int_virt.irp.f b/plugins/loc_cele/loc_exchange_int_virt.irp.f deleted file mode 100644 index 8302b5d2..00000000 --- a/plugins/loc_cele/loc_exchange_int_virt.irp.f +++ /dev/null @@ -1,47 +0,0 @@ -program loc_int - implicit none - integer :: i,j,k,l,iorb,jorb - double precision :: exchange_int(mo_tot_num) - integer :: iorder(mo_tot_num) - integer :: indices(mo_tot_num,2) - logical :: list_core_inact_check(mo_tot_num) - integer :: n_rot - - indices = 0 - list_core_inact_check = .True. - n_rot = 0 - do i = 1, n_virt_orb - iorb = list_virt(i) - exchange_int = 0.d0 - iorder = 0 - print*,'' - if(list_core_inact_check(iorb) .eqv. .False.)cycle - do j = i+1, n_virt_orb - jorb = list_virt(j) - iorder(jorb) = jorb - exchange_int(jorb) = -mo_bielec_integral_jj_exchange(iorb,jorb) - enddo - n_rot += 1 - call dsort(exchange_int,iorder,mo_tot_num) - indices(n_rot,1) = iorb - indices(n_rot,2) = iorder(1) - list_core_inact_check(iorder(1)) = .False. - print*,indices(n_rot,1),indices(n_rot,2) - print*,'' - print*,'' - enddo - print*,'****************************' - print*,'-+++++++++++++++++++++++++' - do i = 1, n_rot - iorb = indices(i,1) - jorb = indices(i,2) - print*,iorb,jorb - call mix_mo_jk(iorb,jorb) - enddo - - - - call save_mos - - -end diff --git a/plugins/mrcc_selected/dressing.irp.f b/plugins/mrcc_selected/dressing.irp.f deleted file mode 100644 index c772e2aa..00000000 --- a/plugins/mrcc_selected/dressing.irp.f +++ /dev/null @@ -1,1076 +0,0 @@ -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) ] -&BEGIN_PROVIDER [ double precision, delta_ij_s2_mrcc, (N_states,N_det_non_ref,N_det_ref) ] -&BEGIN_PROVIDER [ double precision, delta_ii_s2_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 - delta_ij_s2_mrcc = 0d0 - delta_ii_s2_mrcc = 0d0 - PROVIDE dij - 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, delta_ii_s2_mrcc, delta_ij_s2_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) then - call mrcc_part_dress(delta_ij_mrcc, delta_ii_mrcc, delta_ij_s2_mrcc, delta_ii_s2_mrcc, gen,n,buf,N_int,omask) - endif - - 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_,delta_ij_s2_, delta_ii_s2_,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) - double precision, intent(inout) :: delta_ij_s2_(N_states,N_det_non_ref,N_det_ref) - double precision, intent(inout) :: delta_ii_s2_(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, sla, dIk(N_states), dka(N_states), dIa(N_states) - double precision, allocatable :: dIa_hla(:,:), dIa_sla(:,:) - 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(:), sij_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), sij_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), dIa_sla(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)) - call get_s2(tq(1,1,i_alpha),psi_non_ref(1,1,idx_alpha(l_sd)),Nint,sij_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) - sla = sij_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 - dIa_sla(i_state,k_sd) = dIa(i_state) * sla - 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.1.d-3)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) - delta_ij_s2_(i_state,k_sd,i_I) = delta_ij_s2_(i_state,k_sd,i_I) + dIa_sla(i_state,k_sd) - delta_ii_s2_(i_state,i_I) = delta_ii_s2_(i_state,i_I) - dIa_sla(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) - delta_ij_s2_(i_state,k_sd,i_I) = delta_ij_s2_(i_state,k_sd,i_I) + 0.5d0*dIa_sla(i_state,k_sd) - enddo - endif - enddo - call omp_unset_lock( psi_ref_lock(i_I) ) - enddo - enddo - deallocate (dIa_hla,dIa_sla,hij_cache,sij_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) ] -&BEGIN_PROVIDER [ double precision, delta_ij_s2, (N_states,N_det_non_ref,N_det_ref) ] -&BEGIN_PROVIDER [ double precision, delta_ii_s2, (N_states, N_det_ref) ] - use bitmasks - implicit none - integer :: i, j, i_state - - !mrmode : 1=mrcepa0, 2=mrsc2 add, 3=mrcc - - if(mrmode == 3) then - do i = 1, N_det_ref - do i_state = 1, N_states - delta_ii(i_state,i)= delta_ii_mrcc(i_state,i) - delta_ii_s2(i_state,i)= delta_ii_s2_mrcc(i_state,i) - enddo - do j = 1, N_det_non_ref - do i_state = 1, N_states - delta_ij(i_state,j,i) = delta_ij_mrcc(i_state,j,i) - delta_ij_s2(i_state,j,i) = delta_ij_s2_mrcc(i_state,j,i) - enddo - end do - end do - - ! =-=-= BEGIN STATE AVERAGE -! do i = 1, N_det_ref -! delta_ii(:,i)= delta_ii_mrcc(1,i) -! delta_ii_s2(:,i)= delta_ii_s2_mrcc(1,i) -! do i_state = 2, N_states -! delta_ii(:,i) += delta_ii_mrcc(i_state,i) -! delta_ii_s2(:,i) += delta_ii_s2_mrcc(i_state,i) -! enddo -! do j = 1, N_det_non_ref -! delta_ij(:,j,i) = delta_ij_mrcc(1,j,i) -! delta_ij_s2(:,j,i) = delta_ij_s2_mrcc(1,j,i) -! do i_state = 2, N_states -! delta_ij(:,j,i) += delta_ij_mrcc(i_state,j,i) -! delta_ij_s2(:,j,i) += delta_ij_s2_mrcc(i_state,j,i) -! enddo -! end do -! end do -! delta_ij = delta_ij * (1.d0/dble(N_states)) -! delta_ii = delta_ii * (1.d0/dble(N_states)) - ! =-=-= END STATE AVERAGE - ! - ! 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 - do i_state = 1, N_states - delta_ii(i_state,i)= delta_ii_old(i_state,i) - delta_ii_s2(i_state,i)= delta_ii_s2_old(i_state,i) - enddo - do j = 1, N_det_non_ref - do i_state = 1, N_states - delta_ij(i_state,j,i) = delta_ij_old(i_state,j,i) - delta_ij_s2(i_state,j,i) = delta_ij_s2_old(i_state,j,i) - enddo - end do - end do - else if(mrmode == 1) then - do i = 1, N_det_ref - do i_state = 1, N_states - delta_ii(i_state,i)= delta_mrcepa0_ii(i,i_state) - delta_ii_s2(i_state,i)= delta_mrcepa0_ii_s2(i,i_state) - enddo - do j = 1, N_det_non_ref - do i_state = 1, N_states - delta_ij(i_state,j,i) = delta_mrcepa0_ij(i,j,i_state) - delta_ij_s2(i_state,j,i) = delta_mrcepa0_ij_s2(i,j,i_state) - enddo - end do - end do - else - stop "invalid mrmode" - end if -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) ] -&BEGIN_PROVIDER [ double precision, delta_cas_s2, (N_det_ref, N_det_ref, N_states) ] - use bitmasks - implicit none - integer :: i,j,k - double precision :: Sjk,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,Sjk,Hjk,Hki,degree) shared(lambda_mrcc,i_state, N_det_non_ref,psi_ref, psi_non_ref,N_int,delta_cas,delta_cas_s2,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 - delta_cas_s2(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) - call get_s2(psi_ref(1,1,j), psi_non_ref(1,1,k),N_int,Sjk) - - delta_cas(i,j,i_state) += Hjk * dij(i, k, i_state) ! * Hki * lambda_mrcc(i_state, k) - delta_cas_s2(i,j,i_state) += Sjk * dij(i, k, i_state) ! * Ski * lambda_mrcc(i_state, k) - end do - delta_cas(j,i,i_state) = delta_cas(i,j,i_state) - delta_cas_s2(j,i,i_state) = delta_cas_s2(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) ] -&BEGIN_PROVIDER [ double precision, delta_mrcepa0_ij_s2, (N_det_ref,N_det_non_ref,N_states) ] -&BEGIN_PROVIDER [ double precision, delta_mrcepa0_ii_s2, (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, contrib_s2, contrib2_s2, 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) - - delta_mrcepa0_ii(:,:) = 0d0 - delta_mrcepa0_ij(:,:,:) = 0d0 - delta_mrcepa0_ii_s2(:,:) = 0d0 - delta_mrcepa0_ij_s2(:,:,:) = 0d0 - - do i_state = 1, N_states - !$OMP PARALLEL DO default(none) schedule(dynamic) shared(delta_mrcepa0_ij, delta_mrcepa0_ii, delta_mrcepa0_ij_s2, delta_mrcepa0_ii_s2) & - !$OMP private(m,i,II,J,k,degree,myActive,made_hole,made_particle,hjk,contrib,contrib2,contrib_s2,contrib2_s2) & - !$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, delta_cas_s2) & - !$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) - contrib_s2 = delta_cas_s2(II, J, i_state) * dij(J, det_cepa0_idx(k), i_state) - - if(dabs(psi_ref_coef(J,i_state)).ge.1.d-3) then - contrib2 = contrib / psi_ref_coef(J, i_state) * psi_non_ref_coef(det_cepa0_idx(i),i_state) - contrib2_s2 = contrib_s2 / 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 - delta_mrcepa0_ii_s2(J,i_state) -= contrib2_s2 - else - contrib = contrib * 0.5d0 - contrib_s2 = contrib_s2 * 0.5d0 - end if - !$OMP ATOMIC - delta_mrcepa0_ij(J, det_cepa0_idx(i), i_state) += contrib - delta_mrcepa0_ij_s2(J, det_cepa0_idx(i), i_state) += contrib_s2 - - 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 - -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.1.d-3) 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_cache, (N_det_ref,N_det_non_ref) ] -&BEGIN_PROVIDER [ double precision, s2_cache, (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_cache(i,j)) - call get_s2(psi_ref(1,1,i), psi_non_ref(1,1,j), N_int, s2_cache(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/mrcc_selected/dressing_slave.irp.f b/plugins/mrcc_selected/dressing_slave.irp.f deleted file mode 100644 index c2e5dd55..00000000 --- a/plugins/mrcc_selected/dressing_slave.irp.f +++ /dev/null @@ -1,601 +0,0 @@ -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(:,:,:), delta_s2(:,:,:) - - - - 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, contrib_s2, wall, iwall - double precision, allocatable :: dleat(:,:,:), dleat_s2(:,:,:) - 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 (dleat_s2(N_states, N_det_non_ref, 2), delta_s2(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 - n = 0 - delta(:,0,:) = 0d0 - delta(:,:nlink(J),1) = 0d0 - delta(:,:nlink(i_I),2) = 0d0 - delta_s2(:,0,:) = 0d0 - delta_s2(:,:nlink(J),1) = 0d0 - delta_s2(:,: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_cache(J,i) == 0.d0) cycle - if(h_cache(i_I,i) == 0.d0) cycle - - komon(0) += 1 - kn = komon(0) - komon(kn) = i - - do i_state = 1,N_states - dkI = h_cache(J,i) * dij(i_I, i, i_state) - dleat(i_state, kn, 1) = dkI - dleat(i_state, kn, 2) = dkI - - dkI = s2_cache(J,i) * dij(i_I, i, i_state) - dleat_s2(i_state, kn, 1) = dkI - dleat_s2(i_state, kn, 2) = dkI - end do - - end do - - komoned = .true. - end if - - integer :: hpmin(2) - hpmin(1) = 2 - HP(1,k) - hpmin(2) = 2 - HP(2,k) - - do m = 1, komon(0) - - i = komon(m) - if(HP(1,i) <= hpmin(1) .and. HP(2,i) <= hpmin(2) ) then - cycle - end if - - call apply_excitation(psi_non_ref(1,1,i),exc_Ik,det_tmp,ok,N_int) - if(.not. ok) cycle - - do i_state = 1, N_states - contrib = dij(i_I, k, i_state) * dleat(i_state, m, 2) - contrib_s2 = dij(i_I, k, i_state) * dleat_s2(i_state, m, 2) - delta(i_state,ll,1) += contrib - delta_s2(i_state,ll,1) += contrib_s2 - 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) - delta_s2(i_state,0,1) -= contrib_s2 * ci_inv(i_state) * psi_non_ref_coef(l,i_state) - endif - - if(I_i == J) cycle - contrib = dij(J, l, i_state) * dleat(i_state, m, 1) - contrib_s2 = dij(J, l, i_state) * dleat_s2(i_state, m, 1) - delta(i_state,kk,2) += contrib - delta_s2(i_state,kk,2) += contrib_s2 - 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) - delta_s2(i_state,0,2) -= contrib_s2 * 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, delta_s2, 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, delta_s2, 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) - double precision,intent(inout) :: delta_s2(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, delta_s2(1,0,kk), (n(kk)+1)*8*N_states, ZMQ_SNDMORE) ! delta_s2(1,0,1) = delta_I delta_s2(1,0,2) = delta_J - if (rc /= (n(kk)+1)*8*N_states) then - print *, irp_here, 'f77_zmq_send( zmq_socket_push, delta_s2, (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, delta_s2, 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) - double precision, intent(inout) :: delta_s2(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, delta_s2(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_s2, (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, idx(1,kk), 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_,delta_ii_s2_,delta_ij_s2_) - 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) - double precision,intent(inout) :: delta_ij_s2_(N_states,N_det_non_ref,N_det_ref) - double precision,intent(inout) :: delta_ii_s2_(N_states,N_det_ref) - -! integer :: j,l - integer :: rc - - double precision, allocatable :: delta(:,:,:), delta_s2(:,:,:) - - 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 - delta_ii_s2_(:,:) = 0d0 - delta_ij_s2_(:,:,:) = 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), delta_s2(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, delta_s2, 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) - delta_ij_s2_(i_state,idx(l,1),i_I) += delta_s2(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) - delta_ij_s2_(i_state,idx(l,2),J) += delta_s2(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) - delta_ii_s2_(i_state,i_I) += delta_s2(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) - delta_ii_s2_(i_state,J) += delta_s2(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, delta_s2 ) - - 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) ] -&BEGIN_PROVIDER [ double precision, delta_ij_s2_old, (N_states,N_det_non_ref,N_det_ref) ] -&BEGIN_PROVIDER [ double precision, delta_ii_s2_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,delta_ii_s2_old,delta_ij_s2_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,delta_ii_s2_old,delta_ij_s2_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/mrcc_selected/ezfio_interface.irp.f b/plugins/mrcc_selected/ezfio_interface.irp.f deleted file mode 100644 index 062af449..00000000 --- a/plugins/mrcc_selected/ezfio_interface.irp.f +++ /dev/null @@ -1,61 +0,0 @@ -! DO NOT MODIFY BY HAND -! Created by $QP_ROOT/scripts/ezfio_interface/ei_handler.py -! from file /home/scemama/quantum_package/src/mrcc_selected/EZFIO.cfg - - -BEGIN_PROVIDER [ double precision, thresh_dressed_ci ] - implicit none - BEGIN_DOC -! Threshold on the convergence of the dressed CI energy - END_DOC - - logical :: has - PROVIDE ezfio_filename - - call ezfio_has_mrcc_selected_thresh_dressed_ci(has) - if (has) then - call ezfio_get_mrcc_selected_thresh_dressed_ci(thresh_dressed_ci) - else - print *, 'mrcc_selected/thresh_dressed_ci not found in EZFIO file' - stop 1 - endif - -END_PROVIDER - -BEGIN_PROVIDER [ integer, n_it_max_dressed_ci ] - implicit none - BEGIN_DOC -! Maximum number of dressed CI iterations - END_DOC - - logical :: has - PROVIDE ezfio_filename - - call ezfio_has_mrcc_selected_n_it_max_dressed_ci(has) - if (has) then - call ezfio_get_mrcc_selected_n_it_max_dressed_ci(n_it_max_dressed_ci) - else - print *, 'mrcc_selected/n_it_max_dressed_ci not found in EZFIO file' - stop 1 - endif - -END_PROVIDER - -BEGIN_PROVIDER [ integer, lambda_type ] - implicit none - BEGIN_DOC -! lambda type - END_DOC - - logical :: has - PROVIDE ezfio_filename - - call ezfio_has_mrcc_selected_lambda_type(has) - if (has) then - call ezfio_get_mrcc_selected_lambda_type(lambda_type) - else - print *, 'mrcc_selected/lambda_type not found in EZFIO file' - stop 1 - endif - -END_PROVIDER diff --git a/plugins/mrcc_selected/mrcc_selected.irp.f b/plugins/mrcc_selected/mrcc_selected.irp.f deleted file mode 100644 index 91592e62..00000000 --- a/plugins/mrcc_selected/mrcc_selected.irp.f +++ /dev/null @@ -1,19 +0,0 @@ -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/mrcc_selected/mrcepa0_general.irp.f b/plugins/mrcc_selected/mrcepa0_general.irp.f deleted file mode 100644 index e3a2d1f5..00000000 --- a/plugins/mrcc_selected/mrcepa0_general.irp.f +++ /dev/null @@ -1,245 +0,0 @@ - - -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) - - integer :: n_it_mrcc_max - double precision :: thresh_mrcc - double precision, allocatable :: lambda(:) - allocate (lambda(N_states)) - - - 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,j), j=1,N_states) - 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 = max(threshold_selectors,threshold_selectors_pt2) - threshold_generators = max(threshold_generators,threshold_generators_pt2) - - 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/EZFIO.cfg b/plugins/mrcepa0/EZFIO.cfg index b64637e6..61f3392f 100644 --- a/plugins/mrcepa0/EZFIO.cfg +++ b/plugins/mrcepa0/EZFIO.cfg @@ -23,7 +23,7 @@ interface: ezfio type: Threshold doc: Threshold on the convergence of the dressed CI energy interface: ezfio,provider,ocaml -default: 1.e-5 +default: 5.e-5 [n_it_max_dressed_ci] type: Strictly_positive_int diff --git a/plugins/mrcepa0/README.rst b/plugins/mrcepa0/README.rst index 9e66ca0d..997d005e 100644 --- a/plugins/mrcepa0/README.rst +++ b/plugins/mrcepa0/README.rst @@ -6,203 +6,7 @@ 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 `_ -* `ZMQ `_ - Documentation ============= .. Do not edit this section It was auto-generated .. by the `update_README.py` script. - - -`active_sorb `_ - Undocumented - - -`blokmwen `_ - Undocumented - - -`cepa0_shortcut `_ - Undocumented - - -`child_num `_ - Undocumented - - -`delta_cas `_ - Undocumented - - -`delta_ii `_ - Undocumented - - -`delta_ii_mrcc `_ - Undocumented - - -`delta_ii_old `_ - Undocumented - - -`delta_ij `_ - Undocumented - - -`delta_ij_mrcc `_ - Undocumented - - -`delta_ij_old `_ - Undocumented - - -`delta_mrcepa0_ii `_ - Undocumented - - -`delta_mrcepa0_ij `_ - Undocumented - - -`delta_sub_ii `_ - Undocumented - - -`delta_sub_ij `_ - Undocumented - - -`det_cepa0 `_ - Undocumented - - -`det_cepa0_active `_ - Undocumented - - -`det_cepa0_idx `_ - Undocumented - - -`det_ref_active `_ - Undocumented - - -`filter_tq `_ - Undocumented - - -`filter_tq_micro `_ - Undocumented - - -`gethp `_ - Undocumented - - -`h_ `_ - Undocumented - - -`hp `_ - Undocumented - - -`isincassd `_ - Undocumented - - -`lambda_type `_ - lambda type - - -`linked `_ - Undocumented - - -`mrcc_part_dress `_ - Undocumented - - -`mrcepa0 `_ - Undocumented - - -`mrsc2 `_ - Undocumented - - -`mrsc2_dressing_collector `_ - Collects results from the AO integral calculation - - -`mrsc2_dressing_slave `_ - Task for parallel MR-SC2 - - -`mrsc2_dressing_slave_inproc `_ - Task for parallel MR-SC2 - - -`mrsc2_dressing_slave_tcp `_ - Task for parallel MR-SC2 - - -`mrsc2sub `_ - Undocumented - - -`n_it_max_dressed_ci `_ - Maximum number of dressed CI iterations - - -`nlink `_ - Undocumented - - -`print_cas_coefs `_ - Undocumented - - -`pull_mrsc2_results `_ - Push integrals in the push socket - - -`push_mrsc2_results `_ - Push integrals in the push socket - - -`run `_ - Undocumented - - -`run_pt2 `_ - Undocumented - - -`run_pt2_old `_ - Undocumented - - -`searchance `_ - Undocumented - - -`set_det_bit `_ - Undocumented - - -`thresh_dressed_ci `_ - Threshold on the convergence of the dressed CI energy - diff --git a/plugins/mrcepa0/dressing.irp.f b/plugins/mrcepa0/dressing.irp.f index c772e2aa..3646b0b2 100644 --- a/plugins/mrcepa0/dressing.irp.f +++ b/plugins/mrcepa0/dressing.irp.f @@ -4,8 +4,6 @@ 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) ] -&BEGIN_PROVIDER [ double precision, delta_ij_s2_mrcc, (N_states,N_det_non_ref,N_det_ref) ] -&BEGIN_PROVIDER [ double precision, delta_ii_s2_mrcc, (N_states, N_det_ref) ] use bitmasks implicit none integer :: gen, h, p, n, t, i, h1, h2, p1, p2, s1, s2, iproc @@ -16,13 +14,11 @@ use bitmasks delta_ij_mrcc = 0d0 delta_ii_mrcc = 0d0 - delta_ij_s2_mrcc = 0d0 - delta_ii_s2_mrcc = 0d0 - PROVIDE dij + 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, delta_ii_s2_mrcc, delta_ij_s2_mrcc) & + !$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)) @@ -41,9 +37,7 @@ use bitmasks end do n = n - 1 - if(n /= 0) then - call mrcc_part_dress(delta_ij_mrcc, delta_ii_mrcc, delta_ij_s2_mrcc, delta_ii_s2_mrcc, gen,n,buf,N_int,omask) - endif + if(n /= 0) call mrcc_part_dress(delta_ij_mrcc, delta_ii_mrcc,gen,n,buf,N_int,omask) end do deallocate(buf) @@ -58,15 +52,13 @@ END_PROVIDER ! end subroutine -subroutine mrcc_part_dress(delta_ij_, delta_ii_,delta_ij_s2_, delta_ii_s2_,i_generator,n_selected,det_buffer,Nint,key_mask) +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) - double precision, intent(inout) :: delta_ij_s2_(N_states,N_det_non_ref,N_det_ref) - double precision, intent(inout) :: delta_ii_s2_(N_states,N_det_ref) integer(bit_kind), intent(in) :: det_buffer(Nint,2,n_selected) integer :: i,j,k,l,m @@ -76,8 +68,8 @@ subroutine mrcc_part_dress(delta_ij_, delta_ii_,delta_ij_s2_, delta_ii_s2_,i_gen integer(bit_kind),allocatable :: tq(:,:,:) integer :: N_tq, c_ref ,degree - double precision :: hIk, hla, hIl, sla, dIk(N_states), dka(N_states), dIa(N_states) - double precision, allocatable :: dIa_hla(:,:), dIa_sla(:,:) + 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) @@ -90,7 +82,7 @@ subroutine mrcc_part_dress(delta_ij_, delta_ii_,delta_ij_s2_, delta_ii_s2_,i_gen integer(bit_kind),intent(in) :: key_mask(Nint, 2) integer,allocatable :: idx_miniList(:) integer :: N_miniList, ni, leng - double precision, allocatable :: hij_cache(:), sij_cache(:) + double precision, allocatable :: hij_cache(:) integer(bit_kind), allocatable :: microlist(:,:,:), microlist_zero(:,:,:) integer, allocatable :: idx_microlist(:), N_microlist(:), ptr_microlist(:), idx_microlist_zero(:) @@ -100,7 +92,7 @@ subroutine mrcc_part_dress(delta_ij_, delta_ii_,delta_ij_s2_, delta_ii_s2_,i_gen 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), sij_cache(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) @@ -125,7 +117,7 @@ subroutine mrcc_part_dress(delta_ij_, delta_ii_,delta_ij_s2_, delta_ii_s2_,i_gen deallocate(microlist, idx_microlist) - allocate (dIa_hla(N_states,N_det_non_ref), dIa_sla(N_states,N_det_non_ref)) + allocate (dIa_hla(N_states,N_det_non_ref)) ! |I> @@ -193,7 +185,6 @@ subroutine mrcc_part_dress(delta_ij_, delta_ii_,delta_ij_s2_, delta_ii_s2_,i_gen 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)) - call get_s2(tq(1,1,i_alpha),psi_non_ref(1,1,idx_alpha(l_sd)),Nint,sij_cache(k_sd)) enddo ! |I> do i_I=1,N_det_ref @@ -291,36 +282,31 @@ subroutine mrcc_part_dress(delta_ij_, delta_ii_,delta_ij_s2_, delta_ii_s2_,i_gen do l_sd=1,idx_alpha(0) k_sd = idx_alpha(l_sd) hla = hij_cache(k_sd) - sla = sij_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 - dIa_sla(i_state,k_sd) = dIa(i_state) * sla 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.1.d-3)then + 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) - delta_ij_s2_(i_state,k_sd,i_I) = delta_ij_s2_(i_state,k_sd,i_I) + dIa_sla(i_state,k_sd) - delta_ii_s2_(i_state,i_I) = delta_ii_s2_(i_state,i_I) - dIa_sla(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) - delta_ij_s2_(i_state,k_sd,i_I) = delta_ij_s2_(i_state,k_sd,i_I) + 0.5d0*dIa_sla(i_state,k_sd) enddo endif enddo call omp_unset_lock( psi_ref_lock(i_I) ) enddo enddo - deallocate (dIa_hla,dIa_sla,hij_cache,sij_cache) + deallocate (dIa_hla,hij_cache) deallocate(miniList, idx_miniList) end @@ -329,84 +315,45 @@ 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) ] -&BEGIN_PROVIDER [ double precision, delta_ij_s2, (N_states,N_det_non_ref,N_det_ref) ] -&BEGIN_PROVIDER [ double precision, delta_ii_s2, (N_states, N_det_ref) ] use bitmasks implicit none - integer :: i, j, i_state + integer :: i, j, i_state !mrmode : 1=mrcepa0, 2=mrsc2 add, 3=mrcc - if(mrmode == 3) then + do i_state = 1, N_states + if(mrmode == 3) then do i = 1, N_det_ref - do i_state = 1, N_states - delta_ii(i_state,i)= delta_ii_mrcc(i_state,i) - delta_ii_s2(i_state,i)= delta_ii_s2_mrcc(i_state,i) - enddo + delta_ii(i_state,i)= delta_ii_mrcc(i_state,i) do j = 1, N_det_non_ref - do i_state = 1, N_states - delta_ij(i_state,j,i) = delta_ij_mrcc(i_state,j,i) - delta_ij_s2(i_state,j,i) = delta_ij_s2_mrcc(i_state,j,i) - enddo + delta_ij(i_state,j,i) = delta_ij_mrcc(i_state,j,i) end do end do - - ! =-=-= BEGIN STATE AVERAGE -! do i = 1, N_det_ref -! delta_ii(:,i)= delta_ii_mrcc(1,i) -! delta_ii_s2(:,i)= delta_ii_s2_mrcc(1,i) -! do i_state = 2, N_states -! delta_ii(:,i) += delta_ii_mrcc(i_state,i) -! delta_ii_s2(:,i) += delta_ii_s2_mrcc(i_state,i) -! enddo -! do j = 1, N_det_non_ref -! delta_ij(:,j,i) = delta_ij_mrcc(1,j,i) -! delta_ij_s2(:,j,i) = delta_ij_s2_mrcc(1,j,i) -! do i_state = 2, N_states -! delta_ij(:,j,i) += delta_ij_mrcc(i_state,j,i) -! delta_ij_s2(:,j,i) += delta_ij_s2_mrcc(i_state,j,i) -! enddo -! end do -! end do -! delta_ij = delta_ij * (1.d0/dble(N_states)) -! delta_ii = delta_ii * (1.d0/dble(N_states)) - ! =-=-= END STATE AVERAGE - ! - ! 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 - do i_state = 1, N_states +! +! 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) - delta_ii_s2(i_state,i)= delta_ii_s2_old(i_state,i) - enddo - do j = 1, N_det_non_ref - do i_state = 1, N_states + do j = 1, N_det_non_ref delta_ij(i_state,j,i) = delta_ij_old(i_state,j,i) - delta_ij_s2(i_state,j,i) = delta_ij_s2_old(i_state,j,i) - enddo + end do end do - end do - else if(mrmode == 1) then - do i = 1, N_det_ref - do i_state = 1, N_states + else if(mrmode == 1) then + do i = 1, N_det_ref delta_ii(i_state,i)= delta_mrcepa0_ii(i,i_state) - delta_ii_s2(i_state,i)= delta_mrcepa0_ii_s2(i,i_state) - enddo - do j = 1, N_det_non_ref - do i_state = 1, N_states + do j = 1, N_det_non_ref delta_ij(i_state,j,i) = delta_mrcepa0_ij(i,j,i_state) - delta_ij_s2(i_state,j,i) = delta_mrcepa0_ij_s2(i,j,i_state) - enddo + end do end do - end do - else - stop "invalid mrmode" - end if + else + stop "invalid mrmode" + end if + end do END_PROVIDER @@ -590,32 +537,28 @@ END_PROVIDER BEGIN_PROVIDER [ double precision, delta_cas, (N_det_ref, N_det_ref, N_states) ] -&BEGIN_PROVIDER [ double precision, delta_cas_s2, (N_det_ref, N_det_ref, N_states) ] use bitmasks implicit none integer :: i,j,k - double precision :: Sjk,Hjk, Hki, Hij + 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,Sjk,Hjk,Hki,degree) shared(lambda_mrcc,i_state, N_det_non_ref,psi_ref, psi_non_ref,N_int,delta_cas,delta_cas_s2,N_det_ref,dij) + !$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 - delta_cas_s2(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) - call get_s2(psi_ref(1,1,j), psi_non_ref(1,1,k),N_int,Sjk) delta_cas(i,j,i_state) += Hjk * dij(i, k, i_state) ! * Hki * lambda_mrcc(i_state, k) - delta_cas_s2(i,j,i_state) += Sjk * dij(i, k, i_state) ! * Ski * 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) - delta_cas_s2(j,i,i_state) = delta_cas_s2(i,j,i_state) end do end do !$OMP END PARALLEL DO @@ -696,8 +639,6 @@ 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) ] -&BEGIN_PROVIDER [ double precision, delta_mrcepa0_ij_s2, (N_det_ref,N_det_non_ref,N_states) ] -&BEGIN_PROVIDER [ double precision, delta_mrcepa0_ii_s2, (N_det_ref,N_states) ] use bitmasks implicit none @@ -705,7 +646,7 @@ end function 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, contrib_s2, contrib2_s2, HIIi, HJk, wall + 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(:,:,:) @@ -730,16 +671,14 @@ end function ! To provide everything contrib = dij(1, 1, 1) - delta_mrcepa0_ii(:,:) = 0d0 - delta_mrcepa0_ij(:,:,:) = 0d0 - delta_mrcepa0_ii_s2(:,:) = 0d0 - delta_mrcepa0_ij_s2(:,:,:) = 0d0 - do i_state = 1, N_states - !$OMP PARALLEL DO default(none) schedule(dynamic) shared(delta_mrcepa0_ij, delta_mrcepa0_ii, delta_mrcepa0_ij_s2, delta_mrcepa0_ii_s2) & - !$OMP private(m,i,II,J,k,degree,myActive,made_hole,made_particle,hjk,contrib,contrib2,contrib_s2,contrib2_s2) & + 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, delta_cas_s2) & + !$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 @@ -782,21 +721,16 @@ end function ! 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) - contrib_s2 = delta_cas_s2(II, J, i_state) * dij(J, det_cepa0_idx(k), i_state) - if(dabs(psi_ref_coef(J,i_state)).ge.1.d-3) then + 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) - contrib2_s2 = contrib_s2 / 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 - delta_mrcepa0_ii_s2(J,i_state) -= contrib2_s2 else contrib = contrib * 0.5d0 - contrib_s2 = contrib_s2 * 0.5d0 end if !$OMP ATOMIC delta_mrcepa0_ij(J, det_cepa0_idx(i), i_state) += contrib - delta_mrcepa0_ij_s2(J, det_cepa0_idx(i), i_state) += contrib_s2 end do kloop end do @@ -807,7 +741,7 @@ end function deallocate(idx_sorted_bit) call wall_time(wall) print *, "cepa0", wall, notf - + !stop END_PROVIDER @@ -895,7 +829,7 @@ END_PROVIDER 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.1.d-3) then + 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 @@ -926,14 +860,12 @@ subroutine set_det_bit(det, p, s) end subroutine - BEGIN_PROVIDER [ double precision, h_cache, (N_det_ref,N_det_non_ref) ] -&BEGIN_PROVIDER [ double precision, s2_cache, (N_det_ref,N_det_non_ref) ] +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_cache(i,j)) - call get_s2(psi_ref(1,1,i), psi_non_ref(1,1,j), N_int, s2_cache(i,j)) + 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 diff --git a/plugins/mrcepa0/dressing_slave.irp.f b/plugins/mrcepa0/dressing_slave.irp.f index 9e9fa65a..f1d6f029 100644 --- a/plugins/mrcepa0/dressing_slave.irp.f +++ b/plugins/mrcepa0/dressing_slave.irp.f @@ -37,7 +37,7 @@ subroutine mrsc2_dressing_slave(thread,iproc) integer(ZMQ_PTR), external :: new_zmq_push_socket integer(ZMQ_PTR) :: zmq_socket_push - double precision, allocatable :: delta(:,:,:), delta_s2(:,:,:) + double precision, allocatable :: delta(:,:,:) @@ -47,8 +47,8 @@ subroutine mrsc2_dressing_slave(thread,iproc) 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, contrib_s2, wall, iwall - double precision, allocatable :: dleat(:,:,:), dleat_s2(:,:,:) + 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 @@ -63,7 +63,6 @@ subroutine mrsc2_dressing_slave(thread,iproc) 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 (dleat_s2(N_states, N_det_non_ref, 2), delta_s2(N_states,0:N_det_non_ref, 2)) allocate(komon(0:N_det_non_ref)) do @@ -75,14 +74,10 @@ subroutine mrsc2_dressing_slave(thread,iproc) cj_inv(i_state) = 1.d0 / psi_ref_coef(J,i_state) end do !delta = 0.d0 - !delta_s2 = 0.d0 n = 0 delta(:,0,:) = 0d0 delta(:,:nlink(J),1) = 0d0 delta(:,:nlink(i_I),2) = 0d0 - delta_s2(:,0,:) = 0d0 - delta_s2(:,:nlink(J),1) = 0d0 - delta_s2(:,:nlink(i_I),2) = 0d0 komon(0) = 0 komoned = .false. @@ -126,8 +121,8 @@ subroutine mrsc2_dressing_slave(thread,iproc) end if i = det_cepa0_idx(linked(m, i_I)) - if(h_cache(J,i) == 0.d0) cycle - if(h_cache(i_I,i) == 0.d0) cycle + if(h_(J,i) == 0.d0) cycle + if(h_(i_I,i) == 0.d0) cycle !ok = .false. !do i_state=1, N_states @@ -149,13 +144,10 @@ subroutine mrsc2_dressing_slave(thread,iproc) ! if(I_i == J) phase_Ii = phase_Ji do i_state = 1,N_states - dkI = h_cache(J,i) * dij(i_I, i, i_state) + 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 - - dkI = s2_cache(J,i) * dij(i_I, i, i_state) - dleat_s2(i_state, kn, 1) = dkI - dleat_s2(i_state, kn, 2) = dkI end do end do @@ -181,32 +173,26 @@ subroutine mrsc2_dressing_slave(thread,iproc) !if(lambda_mrcc(i_state, i) == 0d0) cycle - !contrib = h_cache(i_I,k) * lambda_mrcc(i_state, k) * dleat(i_state, m, 2)! * phase_al + !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) - contrib_s2 = dij(i_I, k, i_state) * dleat_s2(i_state, m, 2) delta(i_state,ll,1) += contrib - delta_s2(i_state,ll,1) += contrib_s2 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) - delta_s2(i_state,0,1) -= contrib_s2 * ci_inv(i_state) * psi_non_ref_coef(l,i_state) endif if(I_i == J) cycle - !contrib = h_cache(J,l) * lambda_mrcc(i_state, l) * dleat(i_state, m, 1)! * phase_al + !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) - contrib_s2 = dij(J, l, i_state) * dleat_s2(i_state, m, 1) delta(i_state,kk,2) += contrib - delta_s2(i_state,kk,2) += contrib_s2 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) - delta_s2(i_state,0,2) -= contrib_s2 * 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, delta_s2, task_id) + 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 @@ -222,7 +208,7 @@ subroutine mrsc2_dressing_slave(thread,iproc) end -subroutine push_mrsc2_results(zmq_socket_push, I_i, J, delta, delta_s2, task_id) +subroutine push_mrsc2_results(zmq_socket_push, I_i, J, delta, task_id) use f77_zmq implicit none BEGIN_DOC @@ -232,7 +218,6 @@ subroutine push_mrsc2_results(zmq_socket_push, I_i, J, delta, delta_s2, task_id) 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) - double precision,intent(inout) :: delta_s2(N_states, 0:N_det_non_ref, 2) integer, intent(in) :: task_id integer :: rc , i_state, i, kk, li integer,allocatable :: idx(:,:) @@ -293,12 +278,6 @@ subroutine push_mrsc2_results(zmq_socket_push, I_i, J, delta, delta_s2, task_id) 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, delta_s2(1,0,kk), (n(kk)+1)*8*N_states, ZMQ_SNDMORE) ! delta_s2(1,0,1) = delta_I delta_s2(1,0,2) = delta_J - if (rc /= (n(kk)+1)*8*N_states) then - print *, irp_here, 'f77_zmq_send( zmq_socket_push, delta_s2, (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 @@ -326,7 +305,7 @@ end -subroutine pull_mrsc2_results(zmq_socket_pull, I_i, J, n, idx, delta, delta_s2, task_id) +subroutine pull_mrsc2_results(zmq_socket_pull, I_i, J, n, idx, delta, task_id) use f77_zmq implicit none BEGIN_DOC @@ -336,7 +315,6 @@ subroutine pull_mrsc2_results(zmq_socket_pull, I_i, J, n, idx, delta, delta_s2, 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) - double precision, intent(inout) :: delta_s2(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) @@ -368,15 +346,9 @@ subroutine pull_mrsc2_results(zmq_socket_pull, I_i, J, n, idx, delta, delta_s2, stop 'error' endif - rc = f77_zmq_recv( zmq_socket_pull, delta_s2(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_s2, (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, idx(1,kk), n(kk)*4, ZMQ_SNDMORE)' + print *, irp_here, 'f77_zmq_recv( zmq_socket_pull, delta, n(kk)*4, ZMQ_SNDMORE)' stop 'error' endif end if @@ -400,7 +372,7 @@ end -subroutine mrsc2_dressing_collector(delta_ii_,delta_ij_,delta_ii_s2_,delta_ij_s2_) +subroutine mrsc2_dressing_collector(delta_ii_,delta_ij_) use f77_zmq implicit none BEGIN_DOC @@ -409,13 +381,11 @@ subroutine mrsc2_dressing_collector(delta_ii_,delta_ij_,delta_ii_s2_,delta_ij_s2 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) - double precision,intent(inout) :: delta_ij_s2_(N_states,N_det_non_ref,N_det_ref) - double precision,intent(inout) :: delta_ii_s2_(N_states,N_det_ref) ! integer :: j,l integer :: rc - double precision, allocatable :: delta(:,:,:), delta_s2(:,:,:) + double precision, allocatable :: delta(:,:,:) integer(ZMQ_PTR),external :: new_zmq_to_qp_run_socket integer(ZMQ_PTR) :: zmq_to_qp_run_socket @@ -431,47 +401,49 @@ subroutine mrsc2_dressing_collector(delta_ii_,delta_ij_,delta_ii_s2_,delta_ij_s2 delta_ii_(:,:) = 0d0 delta_ij_(:,:,:) = 0d0 - delta_ii_s2_(:,:) = 0d0 - delta_ij_s2_(:,:,:) = 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), delta_s2(N_states,0:N_det_non_ref,2) ) + 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, delta_s2, task_id) + 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) - delta_ij_s2_(i_state,idx(l,1),i_I) += delta_s2(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) - delta_ij_s2_(i_state,idx(l,2),J) += delta_s2(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) - delta_ii_s2_(i_state,i_I) += delta_s2(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) - delta_ii_s2_(i_state,J) += delta_s2(i_state,0,2) end do end if @@ -482,7 +454,7 @@ subroutine mrsc2_dressing_collector(delta_ii_,delta_ij_,delta_ii_s2_,delta_ij_s2 enddo - deallocate( delta, delta_s2 ) + deallocate( delta ) call end_zmq_to_qp_run_socket(zmq_to_qp_run_socket) call end_zmq_pull_socket(zmq_socket_pull) @@ -494,8 +466,6 @@ 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) ] -&BEGIN_PROVIDER [ double precision, delta_ij_s2_old, (N_states,N_det_non_ref,N_det_ref) ] -&BEGIN_PROVIDER [ double precision, delta_ii_s2_old, (N_states,N_det_ref) ] implicit none integer :: i_state, i, i_I, J, k, kk, degree, degree2, m, l, deg, ni, m2 @@ -604,10 +574,10 @@ end ! 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,delta_ii_s2_old,delta_ij_s2_old) PRIVATE(i) NUM_THREADS(nproc+1) + !$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,delta_ii_s2_old,delta_ij_s2_old) + call mrsc2_dressing_collector(delta_ii_old,delta_ij_old) else call mrsc2_dressing_slave_inproc(i) endif diff --git a/plugins/mrcepa0/mrcc.irp.f b/plugins/mrcepa0/mrcc.irp.f index a5614942..91592e62 100644 --- a/plugins/mrcepa0/mrcc.irp.f +++ b/plugins/mrcepa0/mrcc.irp.f @@ -8,16 +8,8 @@ program mrsc2sub read_wf = .True. SOFT_TOUCH read_wf + call print_cas_coefs call set_generators_bitmasks_as_holes_and_particles - if (.True.) then - 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 - endif call run(N_states,energy) if(do_pt2_end)then call run_pt2(N_states,energy) diff --git a/plugins/mrcepa0/mrcepa0.irp.f b/plugins/mrcepa0/mrcepa0.irp.f index aeacbb39..34d3dec5 100644 --- a/plugins/mrcepa0/mrcepa0.irp.f +++ b/plugins/mrcepa0/mrcepa0.irp.f @@ -8,18 +8,8 @@ program mrcepa0 read_wf = .True. SOFT_TOUCH read_wf - call set_generators_bitmasks_as_holes_and_particles - if (.True.) then - integer :: i,j - do j=1,N_states - do i=1,N_det - psi_coef(i,j) = CI_eigenvectors(i,j) - enddo - enddo - TOUCH psi_coef - endif 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) diff --git a/plugins/mrcepa0/mrcepa0_general.irp.f b/plugins/mrcepa0/mrcepa0_general.irp.f index 1b2e2fcb..63f03360 100644 --- a/plugins/mrcepa0/mrcepa0_general.irp.f +++ b/plugins/mrcepa0/mrcepa0_general.irp.f @@ -10,18 +10,18 @@ subroutine run(N_st,energy) double precision :: E_new, E_old, delta_e integer :: iteration - double precision :: E_past(4) + double precision :: E_past(4), lambda integer :: n_it_mrcc_max double precision :: thresh_mrcc - double precision, allocatable :: lambda(:) - allocate (lambda(N_states)) + + 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 + do j=1,N_states_diag do i=1,N_det psi_coef(i,j) = CI_eigenvectors_dressed(i,j) enddo @@ -30,6 +30,7 @@ subroutine run(N_st,energy) 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 @@ -37,21 +38,15 @@ subroutine run(N_st,energy) lambda = 1.d0 do while (delta_E > thresh_mrcc) iteration += 1 - print *, '===============================================' - print *, 'MRCEPA0 Iteration', iteration, '/', n_it_mrcc_max - print *, '===============================================' + print *, '===========================' + print *, 'MRCEPA0 Iteration', iteration + print *, '===========================' print *, '' - E_old = sum(ci_energy_dressed(1:N_states)) - do i=1,N_st - call write_double(6,ci_energy_dressed(i),"MRCEPA0 energy") - enddo + 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(1:N_states)) - delta_E = (E_new - E_old)/dble(N_states) - print *, '' - call write_double(6,thresh_mrcc,"thresh_mrcc") - call write_double(6,delta_E,"delta_E") - delta_E = dabs(delta_E) + 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 @@ -59,8 +54,8 @@ subroutine run(N_st,energy) endif enddo call write_double(6,ci_energy_dressed(1),"Final MRCEPA0 energy") + energy(:) = ci_energy_dressed(:) endif - energy(1:N_st) = ci_energy_dressed(1:N_st) end @@ -71,7 +66,7 @@ subroutine print_cas_coefs print *, 'CAS' print *, '===' do i=1,N_det_cas - print *, (psi_cas_coef(i,j), j=1,N_states) + 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") @@ -144,8 +139,8 @@ subroutine run_pt2_old(N_st,energy) print * ,'Computing the remaining contribution' - threshold_selectors = max(threshold_selectors,threshold_selectors_pt2) - threshold_generators = max(threshold_generators,threshold_generators_pt2) + 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 diff --git a/plugins/mrcepa0/mrsc2.irp.f b/plugins/mrcepa0/mrsc2.irp.f index 948b1b5c..d0f44a33 100644 --- a/plugins/mrcepa0/mrsc2.irp.f +++ b/plugins/mrcepa0/mrsc2.irp.f @@ -7,16 +7,8 @@ program mrsc2 mrmode = 2 read_wf = .True. SOFT_TOUCH read_wf + call print_cas_coefs call set_generators_bitmasks_as_holes_and_particles - if (.True.) then - integer :: i,j - do j=1,N_states - do i=1,N_det - psi_coef(i,j) = CI_eigenvectors(i,j) - enddo - enddo - TOUCH psi_coef - endif call run(N_states,energy) if(do_pt2_end)then call run_pt2(N_states,energy) diff --git a/plugins/mrcepa0/tree_dependency.png b/plugins/mrcepa0/tree_dependency.png deleted file mode 100644 index e69de29b..00000000 diff --git a/plugins/qmcpack/qp_convert_qmcpack_to_ezfio.py b/plugins/qmcpack/qp_convert_qmcpack_to_ezfio.py index a1f47ccd..e911af28 100755 --- a/plugins/qmcpack/qp_convert_qmcpack_to_ezfio.py +++ b/plugins/qmcpack/qp_convert_qmcpack_to_ezfio.py @@ -364,6 +364,10 @@ 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]) diff --git a/scripts/ezfio_interface/qp_convert_output_to_ezfio.py b/scripts/ezfio_interface/qp_convert_output_to_ezfio.py index 6823df81..dbe686c6 100755 --- a/scripts/ezfio_interface/qp_convert_output_to_ezfio.py +++ b/scripts/ezfio_interface/qp_convert_output_to_ezfio.py @@ -26,11 +26,10 @@ except: print "Error: QP_ROOT environment variable not found." sys.exit(1) else: - - sys.path = [ QP_ROOT + "/install/EZFIO/Python", - QP_ROOT + "/resultsFile", - QP_ROOT + "/scripts"] + sys.path - + sys.path = [ + QP_ROOT + "/install/EZFIO/Python", QP_ROOT + "/resultsFile", QP_ROOT + + "/scripts" + ] + sys.path # ~#~#~#~#~#~ # # I m p o r t # @@ -344,19 +343,20 @@ def write_ezfio(res, filename): try: pseudo_str = res_file.get_pseudo() - matrix, array_l_max_block, array_z_remove = parse_str(pseudo_str) - except: ezfio.set_pseudo_do_pseudo(False) else: ezfio.set_pseudo_do_pseudo(True) + matrix, array_l_max_block, array_z_remove = parse_str(pseudo_str) # ~#~#~#~#~#~#~#~#~#~#~#~#~#~#~#~#~#~#~#~#~ # # Z _ e f f , a l p h a / b e t a _ e l e c # # ~#~#~#~#~#~#~#~#~#~#~#~#~#~#~#~#~#~#~#~#~ # ezfio.pseudo_charge_remove = array_z_remove - ezfio.nuclei_nucl_charge = [i - j for i, j in zip(ezfio.nuclei_nucl_charge, array_z_remove)] + ezfio.nuclei_nucl_charge = [ + i - j for i, j in zip(ezfio.nuclei_nucl_charge, array_z_remove) + ] import math num_elec = sum(ezfio.nuclei_nucl_charge) diff --git a/scripts/generate_h_apply.py b/scripts/generate_h_apply.py index c7714e8a..bd66611b 100755 --- a/scripts/generate_h_apply.py +++ b/scripts/generate_h_apply.py @@ -18,14 +18,6 @@ filter1h filter1p only_2p_single only_2p_double -only_2h_single -only_2h_double -only_1h_single -only_1h_double -only_1p_single -only_1p_double -only_2h1p_single -only_2h1p_double filter_only_1h1p_single filter_only_1h1p_double filter_only_1h2p_single @@ -206,55 +198,14 @@ class H_apply(object): if (is_a_1p(hole)) cycle """ - def filter_only_2h(self): - self["only_2h_single"] = """ -! ! DIR$ FORCEINLINE - if (is_a_2h(hole).eqv. .False.) cycle - """ - self["only_2h_double"] = """ -! ! DIR$ FORCEINLINE - if ( is_a_2h(key).eqv. .False. )cycle - """ - - def filter_only_1h(self): - self["only_1h_single"] = """ -! ! DIR$ FORCEINLINE - if (is_a_1h(hole) .eqv. .False.) cycle - """ - self["only_1h_double"] = """ -! ! DIR$ FORCEINLINE - if (is_a_1h(key) .eqv. .False.) cycle - """ - - def filter_only_1p(self): - self["only_1p_single"] = """ -! ! DIR$ FORCEINLINE - if ( is_a_1p(hole) .eqv. .False.) cycle - """ - self["only_1p_double"] = """ -! ! DIR$ FORCEINLINE - if ( is_a_1p(key) .eqv. .False.) cycle - """ - - def filter_only_2h1p(self): - self["only_2h1p_single"] = """ -! ! DIR$ FORCEINLINE - if ( is_a_2h1p(hole) .eqv. .False.) cycle - """ - self["only_2h1p_double"] = """ -! ! DIR$ FORCEINLINE - if (is_a_2h1p(key) .eqv. .False.) cycle - """ - - def filter_only_2p(self): self["only_2p_single"] = """ ! ! DIR$ FORCEINLINE - if (is_a_2p(hole).eqv. .False.) cycle + if (.not. is_a_2p(hole)) cycle """ self["only_2p_double"] = """ ! ! DIR$ FORCEINLINE - if (is_a_2p(key).eqv. .False.) cycle + if (.not. is_a_2p(key)) cycle """ @@ -273,7 +224,7 @@ class H_apply(object): ! ! DIR$ FORCEINLINE if (is_a_two_holes_two_particles(hole).eqv..False.) cycle """ - self["filter_only_2h2p_double"] = """ + self["filter_only_1h1p_double"] = """ ! ! DIR$ FORCEINLINE if (is_a_two_holes_two_particles(key).eqv..False.) cycle """ @@ -422,7 +373,7 @@ class H_apply(object): if (s2_eig) then call make_s2_eigenfunction endif - SOFT_TOUCH psi_det psi_coef N_det +! SOFT_TOUCH psi_det psi_coef N_det selection_criterion_min = min(selection_criterion_min, maxval(select_max))*0.1d0 selection_criterion = selection_criterion_min call write_double(output_determinants,selection_criterion,'Selection criterion') diff --git a/src/AO_Basis/README.rst b/src/AO_Basis/README.rst index d67a3a63..ae9acdf0 100644 --- a/src/AO_Basis/README.rst +++ b/src/AO_Basis/README.rst @@ -133,7 +133,7 @@ Documentation :math:`\int \chi_i(r) \chi_j(r) dr)` -`ao_overlap_abs `_ +`ao_overlap_abs `_ Overlap between absolute value of atomic basis functions: :math:`\int |\chi_i(r)| |\chi_j(r)| dr)` diff --git a/src/AO_Basis/aos.irp.f b/src/AO_Basis/aos.irp.f index 0938d3bd..8d420b15 100644 --- a/src/AO_Basis/aos.irp.f +++ b/src/AO_Basis/aos.irp.f @@ -17,7 +17,7 @@ END_PROVIDER call ezfio_get_ao_basis_ao_prim_num_max(ao_prim_num_max) integer :: align_double ao_prim_num_max_align = align_double(ao_prim_num_max) -END_PROVIDER + END_PROVIDER BEGIN_PROVIDER [ double precision, ao_coef_normalized, (ao_num_align,ao_prim_num_max) ] &BEGIN_PROVIDER [ double precision, ao_coef_normalization_factor, (ao_num) ] @@ -145,7 +145,6 @@ END_PROVIDER BEGIN_PROVIDER [ integer, ao_l, (ao_num) ] &BEGIN_PROVIDER [ integer, ao_l_max ] -&BEGIN_PROVIDER [ character*(128), ao_l_char, (ao_num) ] implicit none BEGIN_DOC ! ao_l = l value of the AO: a+b+c in x^a y^b z^c @@ -153,7 +152,6 @@ END_PROVIDER integer :: i do i=1,ao_num ao_l(i) = ao_power(i,1) + ao_power(i,2) + ao_power(i,3) - ao_l_char(i) = l_to_charater(ao_l(i)) enddo ao_l_max = maxval(ao_l) END_PROVIDER @@ -181,6 +179,20 @@ integer function ao_power_index(nx,ny,nz) ao_power_index = ((l-nx)*(l-nx+1))/2 + nz + 1 end + BEGIN_PROVIDER [ integer, ao_l, (ao_num) ] +&BEGIN_PROVIDER [ integer, ao_l_max ] +&BEGIN_PROVIDER [ character*(128), ao_l_char, (ao_num) ] + implicit none + BEGIN_DOC +! ao_l = l value of the AO: a+b+c in x^a y^b z^c + END_DOC + integer :: i + do i=1,ao_num + ao_l(i) = ao_power(i,1) + ao_power(i,2) + ao_power(i,3) + ao_l_char(i) = l_to_charater(ao_l(i)) + enddo + ao_l_max = maxval(ao_l) +END_PROVIDER BEGIN_PROVIDER [ character*(128), l_to_charater, (0:4)] BEGIN_DOC diff --git a/src/Bitmask/bitmask_cas_routines.irp.f b/src/Bitmask/bitmask_cas_routines.irp.f index 87a02d10..4984d9a8 100644 --- a/src/Bitmask/bitmask_cas_routines.irp.f +++ b/src/Bitmask/bitmask_cas_routines.irp.f @@ -1,113 +1,107 @@ -use bitmasks integer function number_of_holes(key_in) - BEGIN_DOC - ! Function that returns the number of holes in the inact space - END_DOC + ! function that returns the number of holes in the inact space implicit none integer(bit_kind), intent(in) :: key_in(N_int,2) integer :: i number_of_holes = 0 - if(N_int == 1)then number_of_holes = number_of_holes & - + popcnt( xor( iand(reunion_of_core_inact_bitmask(1,1), xor(key_in(1,1),iand(key_in(1,1),cas_bitmask(1,1,1)))), reunion_of_core_inact_bitmask(1,1)) )& - + popcnt( xor( iand(reunion_of_core_inact_bitmask(1,2), xor(key_in(1,2),iand(key_in(1,2),cas_bitmask(1,2,1)))), reunion_of_core_inact_bitmask(1,2)) ) + + popcnt( xor( iand(inact_bitmask(1,1), xor(key_in(1,1),iand(key_in(1,1),cas_bitmask(1,1,1)))), inact_bitmask(1,1)) )& + + popcnt( xor( iand(inact_bitmask(1,2), xor(key_in(1,2),iand(key_in(1,2),cas_bitmask(1,2,1)))), inact_bitmask(1,2)) ) else if(N_int == 2)then number_of_holes = number_of_holes & - + popcnt( xor( iand(reunion_of_core_inact_bitmask(1,1), xor(key_in(1,1),iand(key_in(1,1),cas_bitmask(1,1,1)))), reunion_of_core_inact_bitmask(1,1)) )& - + popcnt( xor( iand(reunion_of_core_inact_bitmask(1,2), xor(key_in(1,2),iand(key_in(1,2),cas_bitmask(1,2,1)))), reunion_of_core_inact_bitmask(1,2)) )& - + popcnt( xor( iand(reunion_of_core_inact_bitmask(2,1), xor(key_in(2,1),iand(key_in(2,1),cas_bitmask(2,1,1)))), reunion_of_core_inact_bitmask(2,1)) )& - + popcnt( xor( iand(reunion_of_core_inact_bitmask(2,2), xor(key_in(2,2),iand(key_in(2,2),cas_bitmask(2,2,1)))), reunion_of_core_inact_bitmask(2,2)) ) + + popcnt( xor( iand(inact_bitmask(1,1), xor(key_in(1,1),iand(key_in(1,1),cas_bitmask(1,1,1)))), inact_bitmask(1,1)) )& + + popcnt( xor( iand(inact_bitmask(1,2), xor(key_in(1,2),iand(key_in(1,2),cas_bitmask(1,2,1)))), inact_bitmask(1,2)) )& + + popcnt( xor( iand(inact_bitmask(2,1), xor(key_in(2,1),iand(key_in(2,1),cas_bitmask(2,1,1)))), inact_bitmask(2,1)) )& + + popcnt( xor( iand(inact_bitmask(2,2), xor(key_in(2,2),iand(key_in(2,2),cas_bitmask(2,2,1)))), inact_bitmask(2,2)) ) else if(N_int == 3)then number_of_holes = number_of_holes & - + popcnt( xor( iand(reunion_of_core_inact_bitmask(1,1), xor(key_in(1,1),iand(key_in(1,1),cas_bitmask(1,1,1)))), reunion_of_core_inact_bitmask(1,1)) )& - + popcnt( xor( iand(reunion_of_core_inact_bitmask(1,2), xor(key_in(1,2),iand(key_in(1,2),cas_bitmask(1,2,1)))), reunion_of_core_inact_bitmask(1,2)) )& - + popcnt( xor( iand(reunion_of_core_inact_bitmask(2,1), xor(key_in(2,1),iand(key_in(2,1),cas_bitmask(2,1,1)))), reunion_of_core_inact_bitmask(2,1)) )& - + popcnt( xor( iand(reunion_of_core_inact_bitmask(2,2), xor(key_in(2,2),iand(key_in(2,2),cas_bitmask(2,2,1)))), reunion_of_core_inact_bitmask(2,2)) )& - + popcnt( xor( iand(reunion_of_core_inact_bitmask(3,1), xor(key_in(3,1),iand(key_in(3,1),cas_bitmask(3,1,1)))), reunion_of_core_inact_bitmask(3,1)) )& - + popcnt( xor( iand(reunion_of_core_inact_bitmask(3,2), xor(key_in(3,2),iand(key_in(3,2),cas_bitmask(3,2,1)))), reunion_of_core_inact_bitmask(3,2)) ) + + popcnt( xor( iand(inact_bitmask(1,1), xor(key_in(1,1),iand(key_in(1,1),cas_bitmask(1,1,1)))), inact_bitmask(1,1)) )& + + popcnt( xor( iand(inact_bitmask(1,2), xor(key_in(1,2),iand(key_in(1,2),cas_bitmask(1,2,1)))), inact_bitmask(1,2)) )& + + popcnt( xor( iand(inact_bitmask(2,1), xor(key_in(2,1),iand(key_in(2,1),cas_bitmask(2,1,1)))), inact_bitmask(2,1)) )& + + popcnt( xor( iand(inact_bitmask(2,2), xor(key_in(2,2),iand(key_in(2,2),cas_bitmask(2,2,1)))), inact_bitmask(2,2)) )& + + popcnt( xor( iand(inact_bitmask(3,1), xor(key_in(3,1),iand(key_in(3,1),cas_bitmask(3,1,1)))), inact_bitmask(3,1)) )& + + popcnt( xor( iand(inact_bitmask(3,2), xor(key_in(3,2),iand(key_in(3,2),cas_bitmask(3,2,1)))), inact_bitmask(3,2)) ) else if(N_int == 4)then number_of_holes = number_of_holes & - + popcnt( xor( iand(reunion_of_core_inact_bitmask(1,1), xor(key_in(1,1),iand(key_in(1,1),cas_bitmask(1,1,1)))), reunion_of_core_inact_bitmask(1,1)) )& - + popcnt( xor( iand(reunion_of_core_inact_bitmask(1,2), xor(key_in(1,2),iand(key_in(1,2),cas_bitmask(1,2,1)))), reunion_of_core_inact_bitmask(1,2)) )& - + popcnt( xor( iand(reunion_of_core_inact_bitmask(2,1), xor(key_in(2,1),iand(key_in(2,1),cas_bitmask(2,1,1)))), reunion_of_core_inact_bitmask(2,1)) )& - + popcnt( xor( iand(reunion_of_core_inact_bitmask(2,2), xor(key_in(2,2),iand(key_in(2,2),cas_bitmask(2,2,1)))), reunion_of_core_inact_bitmask(2,2)) )& - + popcnt( xor( iand(reunion_of_core_inact_bitmask(3,1), xor(key_in(3,1),iand(key_in(3,1),cas_bitmask(3,1,1)))), reunion_of_core_inact_bitmask(3,1)) )& - + popcnt( xor( iand(reunion_of_core_inact_bitmask(3,2), xor(key_in(3,2),iand(key_in(3,2),cas_bitmask(3,2,1)))), reunion_of_core_inact_bitmask(3,2)) )& - + popcnt( xor( iand(reunion_of_core_inact_bitmask(4,1), xor(key_in(4,1),iand(key_in(4,1),cas_bitmask(4,1,1)))), reunion_of_core_inact_bitmask(4,1)) )& - + popcnt( xor( iand(reunion_of_core_inact_bitmask(4,2), xor(key_in(4,2),iand(key_in(4,2),cas_bitmask(4,2,1)))), reunion_of_core_inact_bitmask(4,2)) ) + + popcnt( xor( iand(inact_bitmask(1,1), xor(key_in(1,1),iand(key_in(1,1),cas_bitmask(1,1,1)))), inact_bitmask(1,1)) )& + + popcnt( xor( iand(inact_bitmask(1,2), xor(key_in(1,2),iand(key_in(1,2),cas_bitmask(1,2,1)))), inact_bitmask(1,2)) )& + + popcnt( xor( iand(inact_bitmask(2,1), xor(key_in(2,1),iand(key_in(2,1),cas_bitmask(2,1,1)))), inact_bitmask(2,1)) )& + + popcnt( xor( iand(inact_bitmask(2,2), xor(key_in(2,2),iand(key_in(2,2),cas_bitmask(2,2,1)))), inact_bitmask(2,2)) )& + + popcnt( xor( iand(inact_bitmask(3,1), xor(key_in(3,1),iand(key_in(3,1),cas_bitmask(3,1,1)))), inact_bitmask(3,1)) )& + + popcnt( xor( iand(inact_bitmask(3,2), xor(key_in(3,2),iand(key_in(3,2),cas_bitmask(3,2,1)))), inact_bitmask(3,2)) )& + + popcnt( xor( iand(inact_bitmask(4,1), xor(key_in(4,1),iand(key_in(4,1),cas_bitmask(4,1,1)))), inact_bitmask(4,1)) )& + + popcnt( xor( iand(inact_bitmask(4,2), xor(key_in(4,2),iand(key_in(4,2),cas_bitmask(4,2,1)))), inact_bitmask(4,2)) ) else if(N_int == 5)then number_of_holes = number_of_holes & - + popcnt( xor( iand(reunion_of_core_inact_bitmask(1,1), xor(key_in(1,1),iand(key_in(1,1),cas_bitmask(1,1,1)))), reunion_of_core_inact_bitmask(1,1)) )& - + popcnt( xor( iand(reunion_of_core_inact_bitmask(1,2), xor(key_in(1,2),iand(key_in(1,2),cas_bitmask(1,2,1)))), reunion_of_core_inact_bitmask(1,2)) )& - + popcnt( xor( iand(reunion_of_core_inact_bitmask(2,1), xor(key_in(2,1),iand(key_in(2,1),cas_bitmask(2,1,1)))), reunion_of_core_inact_bitmask(2,1)) )& - + popcnt( xor( iand(reunion_of_core_inact_bitmask(2,2), xor(key_in(2,2),iand(key_in(2,2),cas_bitmask(2,2,1)))), reunion_of_core_inact_bitmask(2,2)) )& - + popcnt( xor( iand(reunion_of_core_inact_bitmask(3,1), xor(key_in(3,1),iand(key_in(3,1),cas_bitmask(3,1,1)))), reunion_of_core_inact_bitmask(3,1)) )& - + popcnt( xor( iand(reunion_of_core_inact_bitmask(3,2), xor(key_in(3,2),iand(key_in(3,2),cas_bitmask(3,2,1)))), reunion_of_core_inact_bitmask(3,2)) )& - + popcnt( xor( iand(reunion_of_core_inact_bitmask(4,1), xor(key_in(4,1),iand(key_in(4,1),cas_bitmask(4,1,1)))), reunion_of_core_inact_bitmask(4,1)) )& - + popcnt( xor( iand(reunion_of_core_inact_bitmask(4,2), xor(key_in(4,2),iand(key_in(4,2),cas_bitmask(4,2,1)))), reunion_of_core_inact_bitmask(4,2)) )& - + popcnt( xor( iand(reunion_of_core_inact_bitmask(5,1), xor(key_in(5,1),iand(key_in(5,1),cas_bitmask(5,1,1)))), reunion_of_core_inact_bitmask(5,1)) )& - + popcnt( xor( iand(reunion_of_core_inact_bitmask(5,2), xor(key_in(5,2),iand(key_in(5,2),cas_bitmask(5,2,1)))), reunion_of_core_inact_bitmask(5,2)) ) + + popcnt( xor( iand(inact_bitmask(1,1), xor(key_in(1,1),iand(key_in(1,1),cas_bitmask(1,1,1)))), inact_bitmask(1,1)) )& + + popcnt( xor( iand(inact_bitmask(1,2), xor(key_in(1,2),iand(key_in(1,2),cas_bitmask(1,2,1)))), inact_bitmask(1,2)) )& + + popcnt( xor( iand(inact_bitmask(2,1), xor(key_in(2,1),iand(key_in(2,1),cas_bitmask(2,1,1)))), inact_bitmask(2,1)) )& + + popcnt( xor( iand(inact_bitmask(2,2), xor(key_in(2,2),iand(key_in(2,2),cas_bitmask(2,2,1)))), inact_bitmask(2,2)) )& + + popcnt( xor( iand(inact_bitmask(3,1), xor(key_in(3,1),iand(key_in(3,1),cas_bitmask(3,1,1)))), inact_bitmask(3,1)) )& + + popcnt( xor( iand(inact_bitmask(3,2), xor(key_in(3,2),iand(key_in(3,2),cas_bitmask(3,2,1)))), inact_bitmask(3,2)) )& + + popcnt( xor( iand(inact_bitmask(4,1), xor(key_in(4,1),iand(key_in(4,1),cas_bitmask(4,1,1)))), inact_bitmask(4,1)) )& + + popcnt( xor( iand(inact_bitmask(4,2), xor(key_in(4,2),iand(key_in(4,2),cas_bitmask(4,2,1)))), inact_bitmask(4,2)) )& + + popcnt( xor( iand(inact_bitmask(5,1), xor(key_in(5,1),iand(key_in(5,1),cas_bitmask(5,1,1)))), inact_bitmask(5,1)) )& + + popcnt( xor( iand(inact_bitmask(5,2), xor(key_in(5,2),iand(key_in(5,2),cas_bitmask(5,2,1)))), inact_bitmask(5,2)) ) else if(N_int == 6)then number_of_holes = number_of_holes & - + popcnt( xor( iand(reunion_of_core_inact_bitmask(1,1), xor(key_in(1,1),iand(key_in(1,1),cas_bitmask(1,1,1)))), reunion_of_core_inact_bitmask(1,1)) )& - + popcnt( xor( iand(reunion_of_core_inact_bitmask(1,2), xor(key_in(1,2),iand(key_in(1,2),cas_bitmask(1,2,1)))), reunion_of_core_inact_bitmask(1,2)) )& - + popcnt( xor( iand(reunion_of_core_inact_bitmask(2,1), xor(key_in(2,1),iand(key_in(2,1),cas_bitmask(2,1,1)))), reunion_of_core_inact_bitmask(2,1)) )& - + popcnt( xor( iand(reunion_of_core_inact_bitmask(2,2), xor(key_in(2,2),iand(key_in(2,2),cas_bitmask(2,2,1)))), reunion_of_core_inact_bitmask(2,2)) )& - + popcnt( xor( iand(reunion_of_core_inact_bitmask(3,1), xor(key_in(3,1),iand(key_in(3,1),cas_bitmask(3,1,1)))), reunion_of_core_inact_bitmask(3,1)) )& - + popcnt( xor( iand(reunion_of_core_inact_bitmask(3,2), xor(key_in(3,2),iand(key_in(3,2),cas_bitmask(3,2,1)))), reunion_of_core_inact_bitmask(3,2)) )& - + popcnt( xor( iand(reunion_of_core_inact_bitmask(4,1), xor(key_in(4,1),iand(key_in(4,1),cas_bitmask(4,1,1)))), reunion_of_core_inact_bitmask(4,1)) )& - + popcnt( xor( iand(reunion_of_core_inact_bitmask(4,2), xor(key_in(4,2),iand(key_in(4,2),cas_bitmask(4,2,1)))), reunion_of_core_inact_bitmask(4,2)) )& - + popcnt( xor( iand(reunion_of_core_inact_bitmask(5,1), xor(key_in(5,1),iand(key_in(5,1),cas_bitmask(5,1,1)))), reunion_of_core_inact_bitmask(5,1)) )& - + popcnt( xor( iand(reunion_of_core_inact_bitmask(5,2), xor(key_in(5,2),iand(key_in(5,2),cas_bitmask(5,2,1)))), reunion_of_core_inact_bitmask(5,2)) )& - + popcnt( xor( iand(reunion_of_core_inact_bitmask(6,1), xor(key_in(6,1),iand(key_in(6,1),cas_bitmask(6,1,1)))), reunion_of_core_inact_bitmask(6,1)) )& - + popcnt( xor( iand(reunion_of_core_inact_bitmask(6,2), xor(key_in(6,2),iand(key_in(6,2),cas_bitmask(6,2,1)))), reunion_of_core_inact_bitmask(6,2)) ) + + popcnt( xor( iand(inact_bitmask(1,1), xor(key_in(1,1),iand(key_in(1,1),cas_bitmask(1,1,1)))), inact_bitmask(1,1)) )& + + popcnt( xor( iand(inact_bitmask(1,2), xor(key_in(1,2),iand(key_in(1,2),cas_bitmask(1,2,1)))), inact_bitmask(1,2)) )& + + popcnt( xor( iand(inact_bitmask(2,1), xor(key_in(2,1),iand(key_in(2,1),cas_bitmask(2,1,1)))), inact_bitmask(2,1)) )& + + popcnt( xor( iand(inact_bitmask(2,2), xor(key_in(2,2),iand(key_in(2,2),cas_bitmask(2,2,1)))), inact_bitmask(2,2)) )& + + popcnt( xor( iand(inact_bitmask(3,1), xor(key_in(3,1),iand(key_in(3,1),cas_bitmask(3,1,1)))), inact_bitmask(3,1)) )& + + popcnt( xor( iand(inact_bitmask(3,2), xor(key_in(3,2),iand(key_in(3,2),cas_bitmask(3,2,1)))), inact_bitmask(3,2)) )& + + popcnt( xor( iand(inact_bitmask(4,1), xor(key_in(4,1),iand(key_in(4,1),cas_bitmask(4,1,1)))), inact_bitmask(4,1)) )& + + popcnt( xor( iand(inact_bitmask(4,2), xor(key_in(4,2),iand(key_in(4,2),cas_bitmask(4,2,1)))), inact_bitmask(4,2)) )& + + popcnt( xor( iand(inact_bitmask(5,1), xor(key_in(5,1),iand(key_in(5,1),cas_bitmask(5,1,1)))), inact_bitmask(5,1)) )& + + popcnt( xor( iand(inact_bitmask(5,2), xor(key_in(5,2),iand(key_in(5,2),cas_bitmask(5,2,1)))), inact_bitmask(5,2)) )& + + popcnt( xor( iand(inact_bitmask(6,1), xor(key_in(6,1),iand(key_in(6,1),cas_bitmask(6,1,1)))), inact_bitmask(6,1)) )& + + popcnt( xor( iand(inact_bitmask(6,2), xor(key_in(6,2),iand(key_in(6,2),cas_bitmask(6,2,1)))), inact_bitmask(6,2)) ) else if(N_int == 7)then number_of_holes = number_of_holes & - + popcnt( xor( iand(reunion_of_core_inact_bitmask(1,1), xor(key_in(1,1),iand(key_in(1,1),cas_bitmask(1,1,1)))), reunion_of_core_inact_bitmask(1,1)) )& - + popcnt( xor( iand(reunion_of_core_inact_bitmask(1,2), xor(key_in(1,2),iand(key_in(1,2),cas_bitmask(1,2,1)))), reunion_of_core_inact_bitmask(1,2)) )& - + popcnt( xor( iand(reunion_of_core_inact_bitmask(2,1), xor(key_in(2,1),iand(key_in(2,1),cas_bitmask(2,1,1)))), reunion_of_core_inact_bitmask(2,1)) )& - + popcnt( xor( iand(reunion_of_core_inact_bitmask(2,2), xor(key_in(2,2),iand(key_in(2,2),cas_bitmask(2,2,1)))), reunion_of_core_inact_bitmask(2,2)) )& - + popcnt( xor( iand(reunion_of_core_inact_bitmask(3,1), xor(key_in(3,1),iand(key_in(3,1),cas_bitmask(3,1,1)))), reunion_of_core_inact_bitmask(3,1)) )& - + popcnt( xor( iand(reunion_of_core_inact_bitmask(3,2), xor(key_in(3,2),iand(key_in(3,2),cas_bitmask(3,2,1)))), reunion_of_core_inact_bitmask(3,2)) )& - + popcnt( xor( iand(reunion_of_core_inact_bitmask(4,1), xor(key_in(4,1),iand(key_in(4,1),cas_bitmask(4,1,1)))), reunion_of_core_inact_bitmask(4,1)) )& - + popcnt( xor( iand(reunion_of_core_inact_bitmask(4,2), xor(key_in(4,2),iand(key_in(4,2),cas_bitmask(4,2,1)))), reunion_of_core_inact_bitmask(4,2)) )& - + popcnt( xor( iand(reunion_of_core_inact_bitmask(5,1), xor(key_in(5,1),iand(key_in(5,1),cas_bitmask(5,1,1)))), reunion_of_core_inact_bitmask(5,1)) )& - + popcnt( xor( iand(reunion_of_core_inact_bitmask(5,2), xor(key_in(5,2),iand(key_in(5,2),cas_bitmask(5,2,1)))), reunion_of_core_inact_bitmask(5,2)) )& - + popcnt( xor( iand(reunion_of_core_inact_bitmask(6,1), xor(key_in(6,1),iand(key_in(6,1),cas_bitmask(6,1,1)))), reunion_of_core_inact_bitmask(6,1)) )& - + popcnt( xor( iand(reunion_of_core_inact_bitmask(6,2), xor(key_in(6,2),iand(key_in(6,2),cas_bitmask(6,2,1)))), reunion_of_core_inact_bitmask(6,2)) )& - + popcnt( xor( iand(reunion_of_core_inact_bitmask(7,1), xor(key_in(7,1),iand(key_in(7,1),cas_bitmask(7,1,1)))), reunion_of_core_inact_bitmask(7,1)) )& - + popcnt( xor( iand(reunion_of_core_inact_bitmask(7,2), xor(key_in(7,2),iand(key_in(7,2),cas_bitmask(7,2,1)))), reunion_of_core_inact_bitmask(7,2)) ) + + popcnt( xor( iand(inact_bitmask(1,1), xor(key_in(1,1),iand(key_in(1,1),cas_bitmask(1,1,1)))), inact_bitmask(1,1)) )& + + popcnt( xor( iand(inact_bitmask(1,2), xor(key_in(1,2),iand(key_in(1,2),cas_bitmask(1,2,1)))), inact_bitmask(1,2)) )& + + popcnt( xor( iand(inact_bitmask(2,1), xor(key_in(2,1),iand(key_in(2,1),cas_bitmask(2,1,1)))), inact_bitmask(2,1)) )& + + popcnt( xor( iand(inact_bitmask(2,2), xor(key_in(2,2),iand(key_in(2,2),cas_bitmask(2,2,1)))), inact_bitmask(2,2)) )& + + popcnt( xor( iand(inact_bitmask(3,1), xor(key_in(3,1),iand(key_in(3,1),cas_bitmask(3,1,1)))), inact_bitmask(3,1)) )& + + popcnt( xor( iand(inact_bitmask(3,2), xor(key_in(3,2),iand(key_in(3,2),cas_bitmask(3,2,1)))), inact_bitmask(3,2)) )& + + popcnt( xor( iand(inact_bitmask(4,1), xor(key_in(4,1),iand(key_in(4,1),cas_bitmask(4,1,1)))), inact_bitmask(4,1)) )& + + popcnt( xor( iand(inact_bitmask(4,2), xor(key_in(4,2),iand(key_in(4,2),cas_bitmask(4,2,1)))), inact_bitmask(4,2)) )& + + popcnt( xor( iand(inact_bitmask(5,1), xor(key_in(5,1),iand(key_in(5,1),cas_bitmask(5,1,1)))), inact_bitmask(5,1)) )& + + popcnt( xor( iand(inact_bitmask(5,2), xor(key_in(5,2),iand(key_in(5,2),cas_bitmask(5,2,1)))), inact_bitmask(5,2)) )& + + popcnt( xor( iand(inact_bitmask(6,1), xor(key_in(6,1),iand(key_in(6,1),cas_bitmask(6,1,1)))), inact_bitmask(6,1)) )& + + popcnt( xor( iand(inact_bitmask(6,2), xor(key_in(6,2),iand(key_in(6,2),cas_bitmask(6,2,1)))), inact_bitmask(6,2)) )& + + popcnt( xor( iand(inact_bitmask(7,1), xor(key_in(7,1),iand(key_in(7,1),cas_bitmask(7,1,1)))), inact_bitmask(7,1)) )& + + popcnt( xor( iand(inact_bitmask(7,2), xor(key_in(7,2),iand(key_in(7,2),cas_bitmask(7,2,1)))), inact_bitmask(7,2)) ) else if(N_int == 8)then number_of_holes = number_of_holes & - + popcnt( xor( iand(reunion_of_core_inact_bitmask(1,1), xor(key_in(1,1),iand(key_in(1,1),cas_bitmask(1,1,1)))), reunion_of_core_inact_bitmask(1,1)) )& - + popcnt( xor( iand(reunion_of_core_inact_bitmask(1,2), xor(key_in(1,2),iand(key_in(1,2),cas_bitmask(1,2,1)))), reunion_of_core_inact_bitmask(1,2)) )& - + popcnt( xor( iand(reunion_of_core_inact_bitmask(2,1), xor(key_in(2,1),iand(key_in(2,1),cas_bitmask(2,1,1)))), reunion_of_core_inact_bitmask(2,1)) )& - + popcnt( xor( iand(reunion_of_core_inact_bitmask(2,2), xor(key_in(2,2),iand(key_in(2,2),cas_bitmask(2,2,1)))), reunion_of_core_inact_bitmask(2,2)) )& - + popcnt( xor( iand(reunion_of_core_inact_bitmask(3,1), xor(key_in(3,1),iand(key_in(3,1),cas_bitmask(3,1,1)))), reunion_of_core_inact_bitmask(3,1)) )& - + popcnt( xor( iand(reunion_of_core_inact_bitmask(3,2), xor(key_in(3,2),iand(key_in(3,2),cas_bitmask(3,2,1)))), reunion_of_core_inact_bitmask(3,2)) )& - + popcnt( xor( iand(reunion_of_core_inact_bitmask(4,1), xor(key_in(4,1),iand(key_in(4,1),cas_bitmask(4,1,1)))), reunion_of_core_inact_bitmask(4,1)) )& - + popcnt( xor( iand(reunion_of_core_inact_bitmask(4,2), xor(key_in(4,2),iand(key_in(4,2),cas_bitmask(4,2,1)))), reunion_of_core_inact_bitmask(4,2)) )& - + popcnt( xor( iand(reunion_of_core_inact_bitmask(5,1), xor(key_in(5,1),iand(key_in(5,1),cas_bitmask(5,1,1)))), reunion_of_core_inact_bitmask(5,1)) )& - + popcnt( xor( iand(reunion_of_core_inact_bitmask(5,2), xor(key_in(5,2),iand(key_in(5,2),cas_bitmask(5,2,1)))), reunion_of_core_inact_bitmask(5,2)) )& - + popcnt( xor( iand(reunion_of_core_inact_bitmask(6,1), xor(key_in(6,1),iand(key_in(6,1),cas_bitmask(6,1,1)))), reunion_of_core_inact_bitmask(6,1)) )& - + popcnt( xor( iand(reunion_of_core_inact_bitmask(6,2), xor(key_in(6,2),iand(key_in(6,2),cas_bitmask(6,2,1)))), reunion_of_core_inact_bitmask(6,2)) )& - + popcnt( xor( iand(reunion_of_core_inact_bitmask(8,1), xor(key_in(8,1),iand(key_in(8,1),cas_bitmask(8,1,1)))), reunion_of_core_inact_bitmask(8,1)) )& - + popcnt( xor( iand(reunion_of_core_inact_bitmask(8,2), xor(key_in(8,2),iand(key_in(8,2),cas_bitmask(8,2,1)))), reunion_of_core_inact_bitmask(8,2)) ) + + popcnt( xor( iand(inact_bitmask(1,1), xor(key_in(1,1),iand(key_in(1,1),cas_bitmask(1,1,1)))), inact_bitmask(1,1)) )& + + popcnt( xor( iand(inact_bitmask(1,2), xor(key_in(1,2),iand(key_in(1,2),cas_bitmask(1,2,1)))), inact_bitmask(1,2)) )& + + popcnt( xor( iand(inact_bitmask(2,1), xor(key_in(2,1),iand(key_in(2,1),cas_bitmask(2,1,1)))), inact_bitmask(2,1)) )& + + popcnt( xor( iand(inact_bitmask(2,2), xor(key_in(2,2),iand(key_in(2,2),cas_bitmask(2,2,1)))), inact_bitmask(2,2)) )& + + popcnt( xor( iand(inact_bitmask(3,1), xor(key_in(3,1),iand(key_in(3,1),cas_bitmask(3,1,1)))), inact_bitmask(3,1)) )& + + popcnt( xor( iand(inact_bitmask(3,2), xor(key_in(3,2),iand(key_in(3,2),cas_bitmask(3,2,1)))), inact_bitmask(3,2)) )& + + popcnt( xor( iand(inact_bitmask(4,1), xor(key_in(4,1),iand(key_in(4,1),cas_bitmask(4,1,1)))), inact_bitmask(4,1)) )& + + popcnt( xor( iand(inact_bitmask(4,2), xor(key_in(4,2),iand(key_in(4,2),cas_bitmask(4,2,1)))), inact_bitmask(4,2)) )& + + popcnt( xor( iand(inact_bitmask(5,1), xor(key_in(5,1),iand(key_in(5,1),cas_bitmask(5,1,1)))), inact_bitmask(5,1)) )& + + popcnt( xor( iand(inact_bitmask(5,2), xor(key_in(5,2),iand(key_in(5,2),cas_bitmask(5,2,1)))), inact_bitmask(5,2)) )& + + popcnt( xor( iand(inact_bitmask(6,1), xor(key_in(6,1),iand(key_in(6,1),cas_bitmask(6,1,1)))), inact_bitmask(6,1)) )& + + popcnt( xor( iand(inact_bitmask(6,2), xor(key_in(6,2),iand(key_in(6,2),cas_bitmask(6,2,1)))), inact_bitmask(6,2)) )& + + popcnt( xor( iand(inact_bitmask(8,1), xor(key_in(8,1),iand(key_in(8,1),cas_bitmask(8,1,1)))), inact_bitmask(8,1)) )& + + popcnt( xor( iand(inact_bitmask(8,2), xor(key_in(8,2),iand(key_in(8,2),cas_bitmask(8,2,1)))), inact_bitmask(8,2)) ) else do i = 1, N_int number_of_holes = number_of_holes & - + popcnt( xor( iand(reunion_of_core_inact_bitmask(i,1), xor(key_in(i,1),iand(key_in(i,1),cas_bitmask(i,1,1)))), reunion_of_core_inact_bitmask(i,1)) )& - + popcnt( xor( iand(reunion_of_core_inact_bitmask(i,1), xor(key_in(i,2),iand(key_in(i,2),cas_bitmask(i,1,1)))), reunion_of_core_inact_bitmask(i,1)) ) + + popcnt( xor( iand(inact_bitmask(i,1), xor(key_in(i,1),iand(key_in(i,1),cas_bitmask(i,1,1)))), inact_bitmask(i,1)) )& + + popcnt( xor( iand(inact_bitmask(i,2), xor(key_in(i,2),iand(key_in(i,2),cas_bitmask(i,2,1)))), inact_bitmask(i,2)) ) enddo endif end integer function number_of_particles(key_in) - BEGIN_DOC ! function that returns the number of particles in the virtual space - END_DOC implicit none integer(bit_kind), intent(in) :: key_in(N_int,2) integer :: i @@ -210,13 +204,11 @@ integer function number_of_particles(key_in) end logical function is_a_two_holes_two_particles(key_in) - BEGIN_DOC ! logical function that returns True if the determinant 'key_in' ! belongs to the 2h-2p excitation class of the DDCI space ! this is calculated using the CAS_bitmask that defines the active ! orbital space, the inact_bitmasl that defines the inactive oribital space ! and the virt_bitmask that defines the virtual orbital space - END_DOC implicit none integer(bit_kind), intent(in) :: key_in(N_int,2) integer :: i,i_diff @@ -229,163 +221,163 @@ logical function is_a_two_holes_two_particles(key_in) i_diff = 0 if(N_int == 1)then i_diff = i_diff & - + popcnt( xor( iand(reunion_of_core_inact_bitmask(1,1), xor(key_in(1,1),iand(key_in(1,1),cas_bitmask(1,1,1)))), reunion_of_core_inact_bitmask(1,1)) ) & - + popcnt( xor( iand(reunion_of_core_inact_bitmask(1,2), xor(key_in(1,2),iand(key_in(1,2),cas_bitmask(1,2,1)))), reunion_of_core_inact_bitmask(1,2)) ) & + + popcnt( xor( iand(inact_bitmask(1,1), xor(key_in(1,1),iand(key_in(1,1),cas_bitmask(1,1,1)))), inact_bitmask(1,1)) ) & + + popcnt( xor( iand(inact_bitmask(1,2), xor(key_in(1,2),iand(key_in(1,2),cas_bitmask(1,2,1)))), inact_bitmask(1,2)) ) & + popcnt( iand( iand( xor(key_in(1,1),iand(key_in(1,1),cas_bitmask(1,1,1))), virt_bitmask(1,1) ), virt_bitmask(1,1)) ) & + popcnt( iand( iand( xor(key_in(1,2),iand(key_in(1,2),cas_bitmask(1,2,1))), virt_bitmask(1,2) ), virt_bitmask(1,2)) ) else if(N_int == 2)then i_diff = i_diff & - + popcnt( xor( iand(reunion_of_core_inact_bitmask(1,1), xor(key_in(1,1),iand(key_in(1,1),cas_bitmask(1,1,1)))), reunion_of_core_inact_bitmask(1,1)) ) & - + popcnt( xor( iand(reunion_of_core_inact_bitmask(1,2), xor(key_in(1,2),iand(key_in(1,2),cas_bitmask(1,2,1)))), reunion_of_core_inact_bitmask(1,2)) ) & + + popcnt( xor( iand(inact_bitmask(1,1), xor(key_in(1,1),iand(key_in(1,1),cas_bitmask(1,1,1)))), inact_bitmask(1,1)) ) & + + popcnt( xor( iand(inact_bitmask(1,2), xor(key_in(1,2),iand(key_in(1,2),cas_bitmask(1,2,1)))), inact_bitmask(1,2)) ) & + popcnt( iand( iand( xor(key_in(1,1),iand(key_in(1,1),cas_bitmask(1,1,1))), virt_bitmask(1,1) ), virt_bitmask(1,1)) ) & + popcnt( iand( iand( xor(key_in(1,2),iand(key_in(1,2),cas_bitmask(1,2,1))), virt_bitmask(1,2) ), virt_bitmask(1,2)) ) & - + popcnt( xor( iand(reunion_of_core_inact_bitmask(2,1), xor(key_in(2,1),iand(key_in(2,1),cas_bitmask(2,1,1)))), reunion_of_core_inact_bitmask(2,1)) ) & - + popcnt( xor( iand(reunion_of_core_inact_bitmask(2,2), xor(key_in(2,2),iand(key_in(2,2),cas_bitmask(2,2,1)))), reunion_of_core_inact_bitmask(2,2)) ) & + + popcnt( xor( iand(inact_bitmask(2,1), xor(key_in(2,1),iand(key_in(2,1),cas_bitmask(2,1,1)))), inact_bitmask(2,1)) ) & + + popcnt( xor( iand(inact_bitmask(2,2), xor(key_in(2,2),iand(key_in(2,2),cas_bitmask(2,2,1)))), inact_bitmask(2,2)) ) & + popcnt( iand( iand( xor(key_in(2,1),iand(key_in(2,1),cas_bitmask(2,1,1))), virt_bitmask(2,1) ), virt_bitmask(2,1)) ) & + popcnt( iand( iand( xor(key_in(2,2),iand(key_in(2,2),cas_bitmask(2,2,1))), virt_bitmask(2,2) ), virt_bitmask(2,2)) ) else if(N_int == 3)then i_diff = i_diff & - + popcnt( xor( iand(reunion_of_core_inact_bitmask(1,1), xor(key_in(1,1),iand(key_in(1,1),cas_bitmask(1,1,1)))), reunion_of_core_inact_bitmask(1,1)) ) & - + popcnt( xor( iand(reunion_of_core_inact_bitmask(1,2), xor(key_in(1,2),iand(key_in(1,2),cas_bitmask(1,2,1)))), reunion_of_core_inact_bitmask(1,2)) ) & + + popcnt( xor( iand(inact_bitmask(1,1), xor(key_in(1,1),iand(key_in(1,1),cas_bitmask(1,1,1)))), inact_bitmask(1,1)) ) & + + popcnt( xor( iand(inact_bitmask(1,2), xor(key_in(1,2),iand(key_in(1,2),cas_bitmask(1,2,1)))), inact_bitmask(1,2)) ) & + popcnt( iand( iand( xor(key_in(1,1),iand(key_in(1,1),cas_bitmask(1,1,1))), virt_bitmask(1,1) ), virt_bitmask(1,1)) ) & + popcnt( iand( iand( xor(key_in(1,2),iand(key_in(1,2),cas_bitmask(1,2,1))), virt_bitmask(1,2) ), virt_bitmask(1,2)) ) & - + popcnt( xor( iand(reunion_of_core_inact_bitmask(2,1), xor(key_in(2,1),iand(key_in(2,1),cas_bitmask(2,1,1)))), reunion_of_core_inact_bitmask(2,1)) ) & - + popcnt( xor( iand(reunion_of_core_inact_bitmask(2,2), xor(key_in(2,2),iand(key_in(2,2),cas_bitmask(2,2,1)))), reunion_of_core_inact_bitmask(2,2)) ) & + + popcnt( xor( iand(inact_bitmask(2,1), xor(key_in(2,1),iand(key_in(2,1),cas_bitmask(2,1,1)))), inact_bitmask(2,1)) ) & + + popcnt( xor( iand(inact_bitmask(2,2), xor(key_in(2,2),iand(key_in(2,2),cas_bitmask(2,2,1)))), inact_bitmask(2,2)) ) & + popcnt( iand( iand( xor(key_in(2,1),iand(key_in(2,1),cas_bitmask(2,1,1))), virt_bitmask(2,1) ), virt_bitmask(2,1)) ) & + popcnt( iand( iand( xor(key_in(2,2),iand(key_in(2,2),cas_bitmask(2,2,1))), virt_bitmask(2,2) ), virt_bitmask(2,2)) ) & - + popcnt( xor( iand(reunion_of_core_inact_bitmask(3,1), xor(key_in(3,1),iand(key_in(3,1),cas_bitmask(3,1,1)))), reunion_of_core_inact_bitmask(3,1)) ) & - + popcnt( xor( iand(reunion_of_core_inact_bitmask(3,2), xor(key_in(3,2),iand(key_in(3,2),cas_bitmask(3,2,1)))), reunion_of_core_inact_bitmask(3,2)) ) & + + popcnt( xor( iand(inact_bitmask(3,1), xor(key_in(3,1),iand(key_in(3,1),cas_bitmask(3,1,1)))), inact_bitmask(3,1)) ) & + + popcnt( xor( iand(inact_bitmask(3,2), xor(key_in(3,2),iand(key_in(3,2),cas_bitmask(3,2,1)))), inact_bitmask(3,2)) ) & + popcnt( iand( iand( xor(key_in(3,1),iand(key_in(3,1),cas_bitmask(3,1,1))), virt_bitmask(3,1) ), virt_bitmask(3,1)) ) & + popcnt( iand( iand( xor(key_in(3,2),iand(key_in(3,2),cas_bitmask(3,2,1))), virt_bitmask(3,2) ), virt_bitmask(3,2)) ) else if(N_int == 4)then i_diff = i_diff & - + popcnt( xor( iand(reunion_of_core_inact_bitmask(1,1), xor(key_in(1,1),iand(key_in(1,1),cas_bitmask(1,1,1)))), reunion_of_core_inact_bitmask(1,1)) ) & - + popcnt( xor( iand(reunion_of_core_inact_bitmask(1,2), xor(key_in(1,2),iand(key_in(1,2),cas_bitmask(1,2,1)))), reunion_of_core_inact_bitmask(1,2)) ) & + + popcnt( xor( iand(inact_bitmask(1,1), xor(key_in(1,1),iand(key_in(1,1),cas_bitmask(1,1,1)))), inact_bitmask(1,1)) ) & + + popcnt( xor( iand(inact_bitmask(1,2), xor(key_in(1,2),iand(key_in(1,2),cas_bitmask(1,2,1)))), inact_bitmask(1,2)) ) & + popcnt( iand( iand( xor(key_in(1,1),iand(key_in(1,1),cas_bitmask(1,1,1))), virt_bitmask(1,1) ), virt_bitmask(1,1)) ) & + popcnt( iand( iand( xor(key_in(1,2),iand(key_in(1,2),cas_bitmask(1,2,1))), virt_bitmask(1,2) ), virt_bitmask(1,2)) ) & - + popcnt( xor( iand(reunion_of_core_inact_bitmask(2,1), xor(key_in(2,1),iand(key_in(2,1),cas_bitmask(2,1,1)))), reunion_of_core_inact_bitmask(2,1)) ) & - + popcnt( xor( iand(reunion_of_core_inact_bitmask(2,2), xor(key_in(2,2),iand(key_in(2,2),cas_bitmask(2,2,1)))), reunion_of_core_inact_bitmask(2,2)) ) & + + popcnt( xor( iand(inact_bitmask(2,1), xor(key_in(2,1),iand(key_in(2,1),cas_bitmask(2,1,1)))), inact_bitmask(2,1)) ) & + + popcnt( xor( iand(inact_bitmask(2,2), xor(key_in(2,2),iand(key_in(2,2),cas_bitmask(2,2,1)))), inact_bitmask(2,2)) ) & + popcnt( iand( iand( xor(key_in(2,1),iand(key_in(2,1),cas_bitmask(2,1,1))), virt_bitmask(2,1) ), virt_bitmask(2,1)) ) & + popcnt( iand( iand( xor(key_in(2,2),iand(key_in(2,2),cas_bitmask(2,2,1))), virt_bitmask(2,2) ), virt_bitmask(2,2)) ) & - + popcnt( xor( iand(reunion_of_core_inact_bitmask(3,1), xor(key_in(3,1),iand(key_in(3,1),cas_bitmask(3,1,1)))), reunion_of_core_inact_bitmask(3,1)) ) & - + popcnt( xor( iand(reunion_of_core_inact_bitmask(3,2), xor(key_in(3,2),iand(key_in(3,2),cas_bitmask(3,2,1)))), reunion_of_core_inact_bitmask(3,2)) ) & + + popcnt( xor( iand(inact_bitmask(3,1), xor(key_in(3,1),iand(key_in(3,1),cas_bitmask(3,1,1)))), inact_bitmask(3,1)) ) & + + popcnt( xor( iand(inact_bitmask(3,2), xor(key_in(3,2),iand(key_in(3,2),cas_bitmask(3,2,1)))), inact_bitmask(3,2)) ) & + popcnt( iand( iand( xor(key_in(3,1),iand(key_in(3,1),cas_bitmask(3,1,1))), virt_bitmask(3,1) ), virt_bitmask(3,1)) ) & + popcnt( iand( iand( xor(key_in(4,2),iand(key_in(3,2),cas_bitmask(3,2,1))), virt_bitmask(3,2) ), virt_bitmask(3,2)) ) & - + popcnt( xor( iand(reunion_of_core_inact_bitmask(4,1), xor(key_in(4,1),iand(key_in(4,1),cas_bitmask(4,1,1)))), reunion_of_core_inact_bitmask(4,1)) ) & - + popcnt( xor( iand(reunion_of_core_inact_bitmask(4,2), xor(key_in(4,2),iand(key_in(4,2),cas_bitmask(4,2,1)))), reunion_of_core_inact_bitmask(4,2)) ) & + + popcnt( xor( iand(inact_bitmask(4,1), xor(key_in(4,1),iand(key_in(4,1),cas_bitmask(4,1,1)))), inact_bitmask(4,1)) ) & + + popcnt( xor( iand(inact_bitmask(4,2), xor(key_in(4,2),iand(key_in(4,2),cas_bitmask(4,2,1)))), inact_bitmask(4,2)) ) & + popcnt( iand( iand( xor(key_in(4,1),iand(key_in(4,1),cas_bitmask(4,1,1))), virt_bitmask(4,1) ), virt_bitmask(4,1)) ) & + popcnt( iand( iand( xor(key_in(4,2),iand(key_in(4,2),cas_bitmask(4,2,1))), virt_bitmask(4,2) ), virt_bitmask(4,2)) ) else if(N_int == 5)then i_diff = i_diff & - + popcnt( xor( iand(reunion_of_core_inact_bitmask(1,1), xor(key_in(1,1),iand(key_in(1,1),cas_bitmask(1,1,1)))), reunion_of_core_inact_bitmask(1,1)) ) & - + popcnt( xor( iand(reunion_of_core_inact_bitmask(1,2), xor(key_in(1,2),iand(key_in(1,2),cas_bitmask(1,2,1)))), reunion_of_core_inact_bitmask(1,2)) ) & + + popcnt( xor( iand(inact_bitmask(1,1), xor(key_in(1,1),iand(key_in(1,1),cas_bitmask(1,1,1)))), inact_bitmask(1,1)) ) & + + popcnt( xor( iand(inact_bitmask(1,2), xor(key_in(1,2),iand(key_in(1,2),cas_bitmask(1,2,1)))), inact_bitmask(1,2)) ) & + popcnt( iand( iand( xor(key_in(1,1),iand(key_in(1,1),cas_bitmask(1,1,1))), virt_bitmask(1,1) ), virt_bitmask(1,1)) ) & + popcnt( iand( iand( xor(key_in(1,2),iand(key_in(1,2),cas_bitmask(1,2,1))), virt_bitmask(1,2) ), virt_bitmask(1,2)) ) & - + popcnt( xor( iand(reunion_of_core_inact_bitmask(2,1), xor(key_in(2,1),iand(key_in(2,1),cas_bitmask(2,1,1)))), reunion_of_core_inact_bitmask(2,1)) ) & - + popcnt( xor( iand(reunion_of_core_inact_bitmask(2,2), xor(key_in(2,2),iand(key_in(2,2),cas_bitmask(2,2,1)))), reunion_of_core_inact_bitmask(2,2)) ) & + + popcnt( xor( iand(inact_bitmask(2,1), xor(key_in(2,1),iand(key_in(2,1),cas_bitmask(2,1,1)))), inact_bitmask(2,1)) ) & + + popcnt( xor( iand(inact_bitmask(2,2), xor(key_in(2,2),iand(key_in(2,2),cas_bitmask(2,2,1)))), inact_bitmask(2,2)) ) & + popcnt( iand( iand( xor(key_in(2,1),iand(key_in(2,1),cas_bitmask(2,1,1))), virt_bitmask(2,1) ), virt_bitmask(2,1)) ) & + popcnt( iand( iand( xor(key_in(2,2),iand(key_in(2,2),cas_bitmask(2,2,1))), virt_bitmask(2,2) ), virt_bitmask(2,2)) ) & - + popcnt( xor( iand(reunion_of_core_inact_bitmask(3,1), xor(key_in(3,1),iand(key_in(3,1),cas_bitmask(3,1,1)))), reunion_of_core_inact_bitmask(3,1)) ) & - + popcnt( xor( iand(reunion_of_core_inact_bitmask(3,2), xor(key_in(3,2),iand(key_in(3,2),cas_bitmask(3,2,1)))), reunion_of_core_inact_bitmask(3,2)) ) & + + popcnt( xor( iand(inact_bitmask(3,1), xor(key_in(3,1),iand(key_in(3,1),cas_bitmask(3,1,1)))), inact_bitmask(3,1)) ) & + + popcnt( xor( iand(inact_bitmask(3,2), xor(key_in(3,2),iand(key_in(3,2),cas_bitmask(3,2,1)))), inact_bitmask(3,2)) ) & + popcnt( iand( iand( xor(key_in(3,1),iand(key_in(3,1),cas_bitmask(3,1,1))), virt_bitmask(3,1) ), virt_bitmask(3,1)) ) & + popcnt( iand( iand( xor(key_in(3,2),iand(key_in(3,2),cas_bitmask(3,2,1))), virt_bitmask(3,2) ), virt_bitmask(3,2)) ) & - + popcnt( xor( iand(reunion_of_core_inact_bitmask(4,1), xor(key_in(4,1),iand(key_in(4,1),cas_bitmask(4,1,1)))), reunion_of_core_inact_bitmask(4,1)) ) & - + popcnt( xor( iand(reunion_of_core_inact_bitmask(4,2), xor(key_in(4,2),iand(key_in(4,2),cas_bitmask(4,2,1)))), reunion_of_core_inact_bitmask(4,2)) ) & + + popcnt( xor( iand(inact_bitmask(4,1), xor(key_in(4,1),iand(key_in(4,1),cas_bitmask(4,1,1)))), inact_bitmask(4,1)) ) & + + popcnt( xor( iand(inact_bitmask(4,2), xor(key_in(4,2),iand(key_in(4,2),cas_bitmask(4,2,1)))), inact_bitmask(4,2)) ) & + popcnt( iand( iand( xor(key_in(4,1),iand(key_in(4,1),cas_bitmask(4,1,1))), virt_bitmask(4,1) ), virt_bitmask(4,1)) ) & + popcnt( iand( iand( xor(key_in(4,2),iand(key_in(4,2),cas_bitmask(4,2,1))), virt_bitmask(4,2) ), virt_bitmask(4,2)) ) & - + popcnt( xor( iand(reunion_of_core_inact_bitmask(5,1), xor(key_in(5,1),iand(key_in(5,1),cas_bitmask(5,1,1)))), reunion_of_core_inact_bitmask(5,1)) ) & - + popcnt( xor( iand(reunion_of_core_inact_bitmask(5,2), xor(key_in(5,2),iand(key_in(5,2),cas_bitmask(5,2,1)))), reunion_of_core_inact_bitmask(5,2)) ) & + + popcnt( xor( iand(inact_bitmask(5,1), xor(key_in(5,1),iand(key_in(5,1),cas_bitmask(5,1,1)))), inact_bitmask(5,1)) ) & + + popcnt( xor( iand(inact_bitmask(5,2), xor(key_in(5,2),iand(key_in(5,2),cas_bitmask(5,2,1)))), inact_bitmask(5,2)) ) & + popcnt( iand( iand( xor(key_in(5,1),iand(key_in(5,1),cas_bitmask(5,1,1))), virt_bitmask(5,1) ), virt_bitmask(5,1)) ) & + popcnt( iand( iand( xor(key_in(5,2),iand(key_in(5,2),cas_bitmask(5,2,1))), virt_bitmask(5,2) ), virt_bitmask(5,2)) ) else if(N_int == 6)then i_diff = i_diff & - + popcnt( xor( iand(reunion_of_core_inact_bitmask(1,1), xor(key_in(1,1),iand(key_in(1,1),cas_bitmask(1,1,1)))), reunion_of_core_inact_bitmask(1,1)) ) & - + popcnt( xor( iand(reunion_of_core_inact_bitmask(1,2), xor(key_in(1,2),iand(key_in(1,2),cas_bitmask(1,2,1)))), reunion_of_core_inact_bitmask(1,2)) ) & + + popcnt( xor( iand(inact_bitmask(1,1), xor(key_in(1,1),iand(key_in(1,1),cas_bitmask(1,1,1)))), inact_bitmask(1,1)) ) & + + popcnt( xor( iand(inact_bitmask(1,2), xor(key_in(1,2),iand(key_in(1,2),cas_bitmask(1,2,1)))), inact_bitmask(1,2)) ) & + popcnt( iand( iand( xor(key_in(1,1),iand(key_in(1,1),cas_bitmask(1,1,1))), virt_bitmask(1,1) ), virt_bitmask(1,1)) ) & + popcnt( iand( iand( xor(key_in(1,2),iand(key_in(1,2),cas_bitmask(1,2,1))), virt_bitmask(1,2) ), virt_bitmask(1,2)) ) & - + popcnt( xor( iand(reunion_of_core_inact_bitmask(2,1), xor(key_in(2,1),iand(key_in(2,1),cas_bitmask(2,1,1)))), reunion_of_core_inact_bitmask(2,1)) ) & - + popcnt( xor( iand(reunion_of_core_inact_bitmask(2,2), xor(key_in(2,2),iand(key_in(2,2),cas_bitmask(2,2,1)))), reunion_of_core_inact_bitmask(2,2)) ) & + + popcnt( xor( iand(inact_bitmask(2,1), xor(key_in(2,1),iand(key_in(2,1),cas_bitmask(2,1,1)))), inact_bitmask(2,1)) ) & + + popcnt( xor( iand(inact_bitmask(2,2), xor(key_in(2,2),iand(key_in(2,2),cas_bitmask(2,2,1)))), inact_bitmask(2,2)) ) & + popcnt( iand( iand( xor(key_in(2,1),iand(key_in(2,1),cas_bitmask(2,1,1))), virt_bitmask(2,1) ), virt_bitmask(2,1)) ) & + popcnt( iand( iand( xor(key_in(2,2),iand(key_in(2,2),cas_bitmask(2,2,1))), virt_bitmask(2,2) ), virt_bitmask(2,2)) ) & - + popcnt( xor( iand(reunion_of_core_inact_bitmask(3,1), xor(key_in(3,1),iand(key_in(3,1),cas_bitmask(3,1,1)))), reunion_of_core_inact_bitmask(3,1)) ) & - + popcnt( xor( iand(reunion_of_core_inact_bitmask(3,2), xor(key_in(3,2),iand(key_in(3,2),cas_bitmask(3,2,1)))), reunion_of_core_inact_bitmask(3,2)) ) & + + popcnt( xor( iand(inact_bitmask(3,1), xor(key_in(3,1),iand(key_in(3,1),cas_bitmask(3,1,1)))), inact_bitmask(3,1)) ) & + + popcnt( xor( iand(inact_bitmask(3,2), xor(key_in(3,2),iand(key_in(3,2),cas_bitmask(3,2,1)))), inact_bitmask(3,2)) ) & + popcnt( iand( iand( xor(key_in(3,1),iand(key_in(3,1),cas_bitmask(3,1,1))), virt_bitmask(3,1) ), virt_bitmask(3,1)) ) & + popcnt( iand( iand( xor(key_in(3,2),iand(key_in(3,2),cas_bitmask(3,2,1))), virt_bitmask(3,2) ), virt_bitmask(3,2)) ) & - + popcnt( xor( iand(reunion_of_core_inact_bitmask(4,1), xor(key_in(4,1),iand(key_in(4,1),cas_bitmask(4,1,1)))), reunion_of_core_inact_bitmask(4,1)) ) & - + popcnt( xor( iand(reunion_of_core_inact_bitmask(4,2), xor(key_in(4,2),iand(key_in(4,2),cas_bitmask(4,2,1)))), reunion_of_core_inact_bitmask(4,2)) ) & + + popcnt( xor( iand(inact_bitmask(4,1), xor(key_in(4,1),iand(key_in(4,1),cas_bitmask(4,1,1)))), inact_bitmask(4,1)) ) & + + popcnt( xor( iand(inact_bitmask(4,2), xor(key_in(4,2),iand(key_in(4,2),cas_bitmask(4,2,1)))), inact_bitmask(4,2)) ) & + popcnt( iand( iand( xor(key_in(4,1),iand(key_in(4,1),cas_bitmask(4,1,1))), virt_bitmask(4,1) ), virt_bitmask(4,1)) ) & + popcnt( iand( iand( xor(key_in(4,2),iand(key_in(4,2),cas_bitmask(4,2,1))), virt_bitmask(4,2) ), virt_bitmask(4,2)) ) & - + popcnt( xor( iand(reunion_of_core_inact_bitmask(5,1), xor(key_in(5,1),iand(key_in(5,1),cas_bitmask(5,1,1)))), reunion_of_core_inact_bitmask(5,1)) ) & - + popcnt( xor( iand(reunion_of_core_inact_bitmask(5,2), xor(key_in(5,2),iand(key_in(5,2),cas_bitmask(5,2,1)))), reunion_of_core_inact_bitmask(5,2)) ) & + + popcnt( xor( iand(inact_bitmask(5,1), xor(key_in(5,1),iand(key_in(5,1),cas_bitmask(5,1,1)))), inact_bitmask(5,1)) ) & + + popcnt( xor( iand(inact_bitmask(5,2), xor(key_in(5,2),iand(key_in(5,2),cas_bitmask(5,2,1)))), inact_bitmask(5,2)) ) & + popcnt( iand( iand( xor(key_in(5,1),iand(key_in(5,1),cas_bitmask(5,1,1))), virt_bitmask(5,1) ), virt_bitmask(5,1)) ) & + popcnt( iand( iand( xor(key_in(5,2),iand(key_in(5,2),cas_bitmask(5,2,1))), virt_bitmask(5,2) ), virt_bitmask(5,2)) ) & - + popcnt( xor( iand(reunion_of_core_inact_bitmask(6,1), xor(key_in(6,1),iand(key_in(6,1),cas_bitmask(6,1,1)))), reunion_of_core_inact_bitmask(6,1)) ) & - + popcnt( xor( iand(reunion_of_core_inact_bitmask(6,2), xor(key_in(6,2),iand(key_in(6,2),cas_bitmask(6,2,1)))), reunion_of_core_inact_bitmask(6,2)) ) & + + popcnt( xor( iand(inact_bitmask(6,1), xor(key_in(6,1),iand(key_in(6,1),cas_bitmask(6,1,1)))), inact_bitmask(6,1)) ) & + + popcnt( xor( iand(inact_bitmask(6,2), xor(key_in(6,2),iand(key_in(6,2),cas_bitmask(6,2,1)))), inact_bitmask(6,2)) ) & + popcnt( iand( iand( xor(key_in(6,1),iand(key_in(6,1),cas_bitmask(6,1,1))), virt_bitmask(6,1) ), virt_bitmask(6,1)) ) & + popcnt( iand( iand( xor(key_in(6,2),iand(key_in(6,2),cas_bitmask(6,2,1))), virt_bitmask(6,2) ), virt_bitmask(6,2)) ) else if(N_int == 7)then i_diff = i_diff & - + popcnt( xor( iand(reunion_of_core_inact_bitmask(1,1), xor(key_in(1,1),iand(key_in(1,1),cas_bitmask(1,1,1)))), reunion_of_core_inact_bitmask(1,1)) ) & - + popcnt( xor( iand(reunion_of_core_inact_bitmask(1,2), xor(key_in(1,2),iand(key_in(1,2),cas_bitmask(1,2,1)))), reunion_of_core_inact_bitmask(1,2)) ) & + + popcnt( xor( iand(inact_bitmask(1,1), xor(key_in(1,1),iand(key_in(1,1),cas_bitmask(1,1,1)))), inact_bitmask(1,1)) ) & + + popcnt( xor( iand(inact_bitmask(1,2), xor(key_in(1,2),iand(key_in(1,2),cas_bitmask(1,2,1)))), inact_bitmask(1,2)) ) & + popcnt( iand( iand( xor(key_in(1,1),iand(key_in(1,1),cas_bitmask(1,1,1))), virt_bitmask(1,1) ), virt_bitmask(1,1)) ) & + popcnt( iand( iand( xor(key_in(1,2),iand(key_in(1,2),cas_bitmask(1,2,1))), virt_bitmask(1,2) ), virt_bitmask(1,2)) ) & - + popcnt( xor( iand(reunion_of_core_inact_bitmask(2,1), xor(key_in(2,1),iand(key_in(2,1),cas_bitmask(2,1,1)))), reunion_of_core_inact_bitmask(2,1)) ) & - + popcnt( xor( iand(reunion_of_core_inact_bitmask(2,2), xor(key_in(2,2),iand(key_in(2,2),cas_bitmask(2,2,1)))), reunion_of_core_inact_bitmask(2,2)) ) & + + popcnt( xor( iand(inact_bitmask(2,1), xor(key_in(2,1),iand(key_in(2,1),cas_bitmask(2,1,1)))), inact_bitmask(2,1)) ) & + + popcnt( xor( iand(inact_bitmask(2,2), xor(key_in(2,2),iand(key_in(2,2),cas_bitmask(2,2,1)))), inact_bitmask(2,2)) ) & + popcnt( iand( iand( xor(key_in(2,1),iand(key_in(2,1),cas_bitmask(2,1,1))), virt_bitmask(2,1) ), virt_bitmask(2,1)) ) & + popcnt( iand( iand( xor(key_in(2,2),iand(key_in(2,2),cas_bitmask(2,2,1))), virt_bitmask(2,2) ), virt_bitmask(2,2)) ) & - + popcnt( xor( iand(reunion_of_core_inact_bitmask(3,1), xor(key_in(3,1),iand(key_in(3,1),cas_bitmask(3,1,1)))), reunion_of_core_inact_bitmask(3,1)) ) & - + popcnt( xor( iand(reunion_of_core_inact_bitmask(3,2), xor(key_in(3,2),iand(key_in(3,2),cas_bitmask(3,2,1)))), reunion_of_core_inact_bitmask(3,2)) ) & + + popcnt( xor( iand(inact_bitmask(3,1), xor(key_in(3,1),iand(key_in(3,1),cas_bitmask(3,1,1)))), inact_bitmask(3,1)) ) & + + popcnt( xor( iand(inact_bitmask(3,2), xor(key_in(3,2),iand(key_in(3,2),cas_bitmask(3,2,1)))), inact_bitmask(3,2)) ) & + popcnt( iand( iand( xor(key_in(3,1),iand(key_in(3,1),cas_bitmask(3,1,1))), virt_bitmask(3,1) ), virt_bitmask(3,1)) ) & + popcnt( iand( iand( xor(key_in(3,2),iand(key_in(3,2),cas_bitmask(3,2,1))), virt_bitmask(3,2) ), virt_bitmask(3,2)) ) & - + popcnt( xor( iand(reunion_of_core_inact_bitmask(4,1), xor(key_in(4,1),iand(key_in(4,1),cas_bitmask(4,1,1)))), reunion_of_core_inact_bitmask(4,1)) ) & - + popcnt( xor( iand(reunion_of_core_inact_bitmask(4,2), xor(key_in(4,2),iand(key_in(4,2),cas_bitmask(4,2,1)))), reunion_of_core_inact_bitmask(4,2)) ) & + + popcnt( xor( iand(inact_bitmask(4,1), xor(key_in(4,1),iand(key_in(4,1),cas_bitmask(4,1,1)))), inact_bitmask(4,1)) ) & + + popcnt( xor( iand(inact_bitmask(4,2), xor(key_in(4,2),iand(key_in(4,2),cas_bitmask(4,2,1)))), inact_bitmask(4,2)) ) & + popcnt( iand( iand( xor(key_in(4,1),iand(key_in(4,1),cas_bitmask(4,1,1))), virt_bitmask(4,1) ), virt_bitmask(4,1)) ) & + popcnt( iand( iand( xor(key_in(4,2),iand(key_in(4,2),cas_bitmask(4,2,1))), virt_bitmask(4,2) ), virt_bitmask(4,2)) ) & - + popcnt( xor( iand(reunion_of_core_inact_bitmask(5,1), xor(key_in(5,1),iand(key_in(5,1),cas_bitmask(5,1,1)))), reunion_of_core_inact_bitmask(5,1)) ) & - + popcnt( xor( iand(reunion_of_core_inact_bitmask(5,2), xor(key_in(5,2),iand(key_in(5,2),cas_bitmask(5,2,1)))), reunion_of_core_inact_bitmask(5,2)) ) & + + popcnt( xor( iand(inact_bitmask(5,1), xor(key_in(5,1),iand(key_in(5,1),cas_bitmask(5,1,1)))), inact_bitmask(5,1)) ) & + + popcnt( xor( iand(inact_bitmask(5,2), xor(key_in(5,2),iand(key_in(5,2),cas_bitmask(5,2,1)))), inact_bitmask(5,2)) ) & + popcnt( iand( iand( xor(key_in(5,1),iand(key_in(5,1),cas_bitmask(5,1,1))), virt_bitmask(5,1) ), virt_bitmask(5,1)) ) & + popcnt( iand( iand( xor(key_in(5,2),iand(key_in(5,2),cas_bitmask(5,2,1))), virt_bitmask(5,2) ), virt_bitmask(5,2)) ) & - + popcnt( xor( iand(reunion_of_core_inact_bitmask(6,1), xor(key_in(6,1),iand(key_in(6,1),cas_bitmask(6,1,1)))), reunion_of_core_inact_bitmask(6,1)) ) & - + popcnt( xor( iand(reunion_of_core_inact_bitmask(6,2), xor(key_in(6,2),iand(key_in(6,2),cas_bitmask(6,2,1)))), reunion_of_core_inact_bitmask(6,2)) ) & + + popcnt( xor( iand(inact_bitmask(6,1), xor(key_in(6,1),iand(key_in(6,1),cas_bitmask(6,1,1)))), inact_bitmask(6,1)) ) & + + popcnt( xor( iand(inact_bitmask(6,2), xor(key_in(6,2),iand(key_in(6,2),cas_bitmask(6,2,1)))), inact_bitmask(6,2)) ) & + popcnt( iand( iand( xor(key_in(6,1),iand(key_in(6,1),cas_bitmask(6,1,1))), virt_bitmask(6,1) ), virt_bitmask(6,1)) ) & + popcnt( iand( iand( xor(key_in(6,2),iand(key_in(6,2),cas_bitmask(6,2,1))), virt_bitmask(6,2) ), virt_bitmask(6,2)) ) & - + popcnt( xor( iand(reunion_of_core_inact_bitmask(7,1), xor(key_in(7,1),iand(key_in(7,1),cas_bitmask(7,1,1)))), reunion_of_core_inact_bitmask(7,1)) ) & - + popcnt( xor( iand(reunion_of_core_inact_bitmask(7,2), xor(key_in(7,2),iand(key_in(7,2),cas_bitmask(7,2,1)))), reunion_of_core_inact_bitmask(7,2)) ) & + + popcnt( xor( iand(inact_bitmask(7,1), xor(key_in(7,1),iand(key_in(7,1),cas_bitmask(7,1,1)))), inact_bitmask(7,1)) ) & + + popcnt( xor( iand(inact_bitmask(7,2), xor(key_in(7,2),iand(key_in(7,2),cas_bitmask(7,2,1)))), inact_bitmask(7,2)) ) & + popcnt( iand( iand( xor(key_in(7,1),iand(key_in(7,1),cas_bitmask(7,1,1))), virt_bitmask(7,1) ), virt_bitmask(7,1)) ) & + popcnt( iand( iand( xor(key_in(7,2),iand(key_in(7,2),cas_bitmask(7,2,1))), virt_bitmask(7,2) ), virt_bitmask(7,2)) ) else if(N_int == 8)then i_diff = i_diff & - + popcnt( xor( iand(reunion_of_core_inact_bitmask(1,1), xor(key_in(1,1),iand(key_in(1,1),cas_bitmask(1,1,1)))), reunion_of_core_inact_bitmask(1,1)) ) & - + popcnt( xor( iand(reunion_of_core_inact_bitmask(1,2), xor(key_in(1,2),iand(key_in(1,2),cas_bitmask(1,2,1)))), reunion_of_core_inact_bitmask(1,2)) ) & + + popcnt( xor( iand(inact_bitmask(1,1), xor(key_in(1,1),iand(key_in(1,1),cas_bitmask(1,1,1)))), inact_bitmask(1,1)) ) & + + popcnt( xor( iand(inact_bitmask(1,2), xor(key_in(1,2),iand(key_in(1,2),cas_bitmask(1,2,1)))), inact_bitmask(1,2)) ) & + popcnt( iand( iand( xor(key_in(1,1),iand(key_in(1,1),cas_bitmask(1,1,1))), virt_bitmask(1,1) ), virt_bitmask(1,1)) ) & + popcnt( iand( iand( xor(key_in(1,2),iand(key_in(1,2),cas_bitmask(1,2,1))), virt_bitmask(1,2) ), virt_bitmask(1,2)) ) & - + popcnt( xor( iand(reunion_of_core_inact_bitmask(2,1), xor(key_in(2,1),iand(key_in(2,1),cas_bitmask(2,1,1)))), reunion_of_core_inact_bitmask(2,1)) ) & - + popcnt( xor( iand(reunion_of_core_inact_bitmask(2,2), xor(key_in(2,2),iand(key_in(2,2),cas_bitmask(2,2,1)))), reunion_of_core_inact_bitmask(2,2)) ) & + + popcnt( xor( iand(inact_bitmask(2,1), xor(key_in(2,1),iand(key_in(2,1),cas_bitmask(2,1,1)))), inact_bitmask(2,1)) ) & + + popcnt( xor( iand(inact_bitmask(2,2), xor(key_in(2,2),iand(key_in(2,2),cas_bitmask(2,2,1)))), inact_bitmask(2,2)) ) & + popcnt( iand( iand( xor(key_in(2,1),iand(key_in(2,1),cas_bitmask(2,1,1))), virt_bitmask(2,1) ), virt_bitmask(2,1)) ) & + popcnt( iand( iand( xor(key_in(2,2),iand(key_in(2,2),cas_bitmask(2,2,1))), virt_bitmask(2,2) ), virt_bitmask(2,2)) ) & - + popcnt( xor( iand(reunion_of_core_inact_bitmask(3,1), xor(key_in(3,1),iand(key_in(3,1),cas_bitmask(3,1,1)))), reunion_of_core_inact_bitmask(3,1)) ) & - + popcnt( xor( iand(reunion_of_core_inact_bitmask(3,2), xor(key_in(3,2),iand(key_in(3,2),cas_bitmask(3,2,1)))), reunion_of_core_inact_bitmask(3,2)) ) & + + popcnt( xor( iand(inact_bitmask(3,1), xor(key_in(3,1),iand(key_in(3,1),cas_bitmask(3,1,1)))), inact_bitmask(3,1)) ) & + + popcnt( xor( iand(inact_bitmask(3,2), xor(key_in(3,2),iand(key_in(3,2),cas_bitmask(3,2,1)))), inact_bitmask(3,2)) ) & + popcnt( iand( iand( xor(key_in(3,1),iand(key_in(3,1),cas_bitmask(3,1,1))), virt_bitmask(3,1) ), virt_bitmask(3,1)) ) & + popcnt( iand( iand( xor(key_in(3,2),iand(key_in(3,2),cas_bitmask(3,2,1))), virt_bitmask(3,2) ), virt_bitmask(3,2)) ) & - + popcnt( xor( iand(reunion_of_core_inact_bitmask(4,1), xor(key_in(4,1),iand(key_in(4,1),cas_bitmask(4,1,1)))), reunion_of_core_inact_bitmask(4,1)) ) & - + popcnt( xor( iand(reunion_of_core_inact_bitmask(4,2), xor(key_in(4,2),iand(key_in(4,2),cas_bitmask(4,2,1)))), reunion_of_core_inact_bitmask(4,2)) ) & + + popcnt( xor( iand(inact_bitmask(4,1), xor(key_in(4,1),iand(key_in(4,1),cas_bitmask(4,1,1)))), inact_bitmask(4,1)) ) & + + popcnt( xor( iand(inact_bitmask(4,2), xor(key_in(4,2),iand(key_in(4,2),cas_bitmask(4,2,1)))), inact_bitmask(4,2)) ) & + popcnt( iand( iand( xor(key_in(4,1),iand(key_in(4,1),cas_bitmask(4,1,1))), virt_bitmask(4,1) ), virt_bitmask(4,1)) ) & + popcnt( iand( iand( xor(key_in(4,2),iand(key_in(4,2),cas_bitmask(4,2,1))), virt_bitmask(4,2) ), virt_bitmask(4,2)) ) & - + popcnt( xor( iand(reunion_of_core_inact_bitmask(5,1), xor(key_in(5,1),iand(key_in(5,1),cas_bitmask(5,1,1)))), reunion_of_core_inact_bitmask(5,1)) ) & - + popcnt( xor( iand(reunion_of_core_inact_bitmask(5,2), xor(key_in(5,2),iand(key_in(5,2),cas_bitmask(5,2,1)))), reunion_of_core_inact_bitmask(5,2)) ) & + + popcnt( xor( iand(inact_bitmask(5,1), xor(key_in(5,1),iand(key_in(5,1),cas_bitmask(5,1,1)))), inact_bitmask(5,1)) ) & + + popcnt( xor( iand(inact_bitmask(5,2), xor(key_in(5,2),iand(key_in(5,2),cas_bitmask(5,2,1)))), inact_bitmask(5,2)) ) & + popcnt( iand( iand( xor(key_in(5,1),iand(key_in(5,1),cas_bitmask(5,1,1))), virt_bitmask(5,1) ), virt_bitmask(5,1)) ) & + popcnt( iand( iand( xor(key_in(5,2),iand(key_in(5,2),cas_bitmask(5,2,1))), virt_bitmask(5,2) ), virt_bitmask(5,2)) ) & - + popcnt( xor( iand(reunion_of_core_inact_bitmask(6,1), xor(key_in(6,1),iand(key_in(6,1),cas_bitmask(6,1,1)))), reunion_of_core_inact_bitmask(6,1)) ) & - + popcnt( xor( iand(reunion_of_core_inact_bitmask(6,2), xor(key_in(6,2),iand(key_in(6,2),cas_bitmask(6,2,1)))), reunion_of_core_inact_bitmask(6,2)) ) & + + popcnt( xor( iand(inact_bitmask(6,1), xor(key_in(6,1),iand(key_in(6,1),cas_bitmask(6,1,1)))), inact_bitmask(6,1)) ) & + + popcnt( xor( iand(inact_bitmask(6,2), xor(key_in(6,2),iand(key_in(6,2),cas_bitmask(6,2,1)))), inact_bitmask(6,2)) ) & + popcnt( iand( iand( xor(key_in(6,1),iand(key_in(6,1),cas_bitmask(6,1,1))), virt_bitmask(6,1) ), virt_bitmask(6,1)) ) & + popcnt( iand( iand( xor(key_in(6,2),iand(key_in(6,2),cas_bitmask(6,2,1))), virt_bitmask(6,2) ), virt_bitmask(6,2)) ) & - + popcnt( xor( iand(reunion_of_core_inact_bitmask(7,1), xor(key_in(7,1),iand(key_in(7,1),cas_bitmask(7,1,1)))), reunion_of_core_inact_bitmask(7,1)) ) & - + popcnt( xor( iand(reunion_of_core_inact_bitmask(7,2), xor(key_in(7,2),iand(key_in(7,2),cas_bitmask(7,2,1)))), reunion_of_core_inact_bitmask(7,2)) ) & + + popcnt( xor( iand(inact_bitmask(7,1), xor(key_in(7,1),iand(key_in(7,1),cas_bitmask(7,1,1)))), inact_bitmask(7,1)) ) & + + popcnt( xor( iand(inact_bitmask(7,2), xor(key_in(7,2),iand(key_in(7,2),cas_bitmask(7,2,1)))), inact_bitmask(7,2)) ) & + popcnt( iand( iand( xor(key_in(7,1),iand(key_in(7,1),cas_bitmask(7,1,1))), virt_bitmask(7,1) ), virt_bitmask(7,1)) ) & + popcnt( iand( iand( xor(key_in(7,2),iand(key_in(7,2),cas_bitmask(7,2,1))), virt_bitmask(7,2) ), virt_bitmask(7,2)) ) & - + popcnt( xor( iand(reunion_of_core_inact_bitmask(8,1), xor(key_in(8,1),iand(key_in(8,1),cas_bitmask(8,1,1)))), reunion_of_core_inact_bitmask(8,1)) ) & - + popcnt( xor( iand(reunion_of_core_inact_bitmask(8,2), xor(key_in(8,2),iand(key_in(8,2),cas_bitmask(8,2,1)))), reunion_of_core_inact_bitmask(8,2)) ) & + + popcnt( xor( iand(inact_bitmask(8,1), xor(key_in(8,1),iand(key_in(8,1),cas_bitmask(8,1,1)))), inact_bitmask(8,1)) ) & + + popcnt( xor( iand(inact_bitmask(8,2), xor(key_in(8,2),iand(key_in(8,2),cas_bitmask(8,2,1)))), inact_bitmask(8,2)) ) & + popcnt( iand( iand( xor(key_in(8,1),iand(key_in(8,1),cas_bitmask(8,1,1))), virt_bitmask(8,1) ), virt_bitmask(8,1)) ) & + popcnt( iand( iand( xor(key_in(8,2),iand(key_in(8,2),cas_bitmask(8,2,1))), virt_bitmask(8,2) ), virt_bitmask(8,2)) ) @@ -393,8 +385,8 @@ logical function is_a_two_holes_two_particles(key_in) do i = 1, N_int i_diff = i_diff & - + popcnt( xor( iand(reunion_of_core_inact_bitmask(i,1), xor(key_in(i,1),iand(key_in(i,1),cas_bitmask(i,1,1)))), reunion_of_core_inact_bitmask(i,1)) ) & - + popcnt( xor( iand(reunion_of_core_inact_bitmask(i,2), xor(key_in(i,2),iand(key_in(i,2),cas_bitmask(i,2,1)))), reunion_of_core_inact_bitmask(i,2)) ) & + + popcnt( xor( iand(inact_bitmask(i,1), xor(key_in(i,1),iand(key_in(i,1),cas_bitmask(i,1,1)))), inact_bitmask(i,1)) ) & + + popcnt( xor( iand(inact_bitmask(i,2), xor(key_in(i,2),iand(key_in(i,2),cas_bitmask(i,2,1)))), inact_bitmask(i,2)) ) & + popcnt( iand( iand( xor(key_in(i,1),iand(key_in(i,1),cas_bitmask(i,1,1))), virt_bitmask(i,1) ), virt_bitmask(i,1)) ) & + popcnt( iand( iand( xor(key_in(i,2),iand(key_in(i,2),cas_bitmask(i,2,1))), virt_bitmask(i,2) ), virt_bitmask(i,2)) ) enddo @@ -406,9 +398,7 @@ logical function is_a_two_holes_two_particles(key_in) integer function number_of_holes_verbose(key_in) - BEGIN_DOC ! function that returns the number of holes in the inact space - END_DOC implicit none integer(bit_kind), intent(in) :: key_in(N_int,2) integer :: i @@ -420,25 +410,23 @@ integer function number_of_holes_verbose(key_in) key_tmp(1,1) = xor(key_in(1,1),iand(key_in(1,1),cas_bitmask(1,1,1))) key_tmp(1,2) = xor(key_in(1,2),iand(key_in(1,2),cas_bitmask(1,1,1))) call debug_det(key_tmp,N_int) - key_tmp(1,1) = iand(key_tmp(1,1),reunion_of_core_inact_bitmask(1,1)) - key_tmp(1,2) = iand(key_tmp(1,2),reunion_of_core_inact_bitmask(1,2)) + key_tmp(1,1) = iand(key_tmp(1,1),inact_bitmask(1,1)) + key_tmp(1,2) = iand(key_tmp(1,2),inact_bitmask(1,2)) call debug_det(key_tmp,N_int) - key_tmp(1,1) = xor(key_tmp(1,1),reunion_of_core_inact_bitmask(1,1)) - key_tmp(1,2) = xor(key_tmp(1,2),reunion_of_core_inact_bitmask(1,2)) + key_tmp(1,1) = xor(key_tmp(1,1),inact_bitmask(1,1)) + key_tmp(1,2) = xor(key_tmp(1,2),inact_bitmask(1,2)) call debug_det(key_tmp,N_int) ! number_of_holes_verbose = number_of_holes_verbose + popcnt(key_tmp(1,1)) & ! + popcnt(key_tmp(1,2)) number_of_holes_verbose = number_of_holes_verbose & - + popcnt( xor( iand(reunion_of_core_inact_bitmask(1,1), xor(key_in(1,1),iand(key_in(1,1),cas_bitmask(1,1,1)))), reunion_of_core_inact_bitmask(1,1)) )& - + popcnt( xor( iand(reunion_of_core_inact_bitmask(1,2), xor(key_in(1,2),iand(key_in(1,2),cas_bitmask(1,2,1)))), reunion_of_core_inact_bitmask(1,2)) ) + + popcnt( xor( iand(inact_bitmask(1,1), xor(key_in(1,1),iand(key_in(1,1),cas_bitmask(1,1,1)))), inact_bitmask(1,1)) )& + + popcnt( xor( iand(inact_bitmask(1,2), xor(key_in(1,2),iand(key_in(1,2),cas_bitmask(1,2,1)))), inact_bitmask(1,2)) ) print*,'----------------------' end integer function number_of_particles_verbose(key_in) - BEGIN_DOC ! function that returns the number of particles in the inact space - END_DOC implicit none integer(bit_kind), intent(in) :: key_in(N_int,2) integer :: i @@ -485,17 +473,6 @@ logical function is_a_1h2p(key_in) end -logical function is_a_2h1p(key_in) - implicit none - integer(bit_kind), intent(in) :: key_in(N_int,2) - integer :: number_of_particles, number_of_holes - is_a_2h1p = .False. - if(number_of_holes(key_in).eq.2 .and. number_of_particles(key_in).eq.1)then - is_a_2h1p = .True. - endif - -end - logical function is_a_1h(key_in) implicit none integer(bit_kind), intent(in) :: key_in(N_int,2) @@ -529,34 +506,3 @@ logical function is_a_2p(key_in) end -logical function is_a_2h(key_in) - implicit none - integer(bit_kind), intent(in) :: key_in(N_int,2) - integer :: number_of_particles, number_of_holes - is_a_2h = .False. - if(number_of_holes(key_in).eq.2 .and. number_of_particles(key_in).eq.0)then - is_a_2h = .True. - endif - -end - -logical function is_i_in_virtual(i) - implicit none - integer,intent(in) :: i - integer(bit_kind) :: key(N_int) - integer :: k,j - integer :: accu - is_i_in_virtual = .False. - key= 0_bit_kind - k = ishft(i-1,-bit_kind_shift)+1 - j = i-ishft(k-1,bit_kind_shift)-1 - key(k) = ibset(key(k),j) - accu = 0 - do k = 1, N_int - accu += popcnt(iand(key(k),virt_bitmask(k,1))) - enddo - if(accu .ne. 0)then - is_i_in_virtual = .True. - endif - -end diff --git a/src/Bitmask/bitmasks.irp.f b/src/Bitmask/bitmasks.irp.f index 964c4ed8..7bb6e16e 100644 --- a/src/Bitmask/bitmasks.irp.f +++ b/src/Bitmask/bitmasks.irp.f @@ -37,30 +37,6 @@ BEGIN_PROVIDER [ integer(bit_kind), full_ijkl_bitmask_4, (N_int,4) ] enddo END_PROVIDER - BEGIN_PROVIDER [ integer(bit_kind), core_inact_act_bitmask_4, (N_int,4) ] - implicit none - integer :: i - do i=1,N_int - core_inact_act_bitmask_4(i,1) = reunion_of_core_inact_act_bitmask(i,1) - core_inact_act_bitmask_4(i,2) = reunion_of_core_inact_act_bitmask(i,1) - core_inact_act_bitmask_4(i,3) = reunion_of_core_inact_act_bitmask(i,1) - core_inact_act_bitmask_4(i,4) = reunion_of_core_inact_act_bitmask(i,1) - enddo -END_PROVIDER - -BEGIN_PROVIDER [ integer(bit_kind), virt_bitmask_4, (N_int,4) ] - implicit none - integer :: i - do i=1,N_int - virt_bitmask_4(i,1) = virt_bitmask(i,1) - virt_bitmask_4(i,2) = virt_bitmask(i,1) - virt_bitmask_4(i,3) = virt_bitmask(i,1) - virt_bitmask_4(i,4) = virt_bitmask(i,1) - enddo -END_PROVIDER - - - BEGIN_PROVIDER [ integer(bit_kind), HF_bitmask, (N_int,2)] implicit none @@ -393,19 +369,11 @@ END_PROVIDER BEGIN_PROVIDER [ integer, list_inact, (n_inact_orb)] &BEGIN_PROVIDER [ integer, list_virt, (n_virt_orb)] - &BEGIN_PROVIDER [ integer, list_inact_reverse, (mo_tot_num)] - &BEGIN_PROVIDER [ integer, list_virt_reverse, (mo_tot_num)] BEGIN_DOC ! list_inact : List of the inactive orbitals which are supposed to be doubly excited ! in post CAS methods ! list_virt : List of vritual orbitals which are supposed to be recieve electrons ! in post CAS methods - ! list_inact_reverse : reverse list of inactive orbitals - ! list_inact_reverse(i) = 0 ::> not an inactive - ! list_inact_reverse(i) = k ::> IS the kth inactive - ! list_virt_reverse : reverse list of virtual orbitals - ! list_virt_reverse(i) = 0 ::> not an virtual - ! list_virt_reverse(i) = k ::> IS the kth virtual END_DOC implicit none integer :: occ_inact(N_int*bit_kind_size) @@ -413,58 +381,25 @@ END_PROVIDER occ_inact = 0 call bitstring_to_list(inact_bitmask(1,1), occ_inact(1), itest, N_int) ASSERT(itest==n_inact_orb) - list_inact_reverse = 0 do i = 1, n_inact_orb list_inact(i) = occ_inact(i) - list_inact_reverse(occ_inact(i)) = i enddo - occ_inact = 0 call bitstring_to_list(virt_bitmask(1,1), occ_inact(1), itest, N_int) ASSERT(itest==n_virt_orb) - list_virt_reverse = 0 do i = 1, n_virt_orb list_virt(i) = occ_inact(i) - list_virt_reverse(occ_inact(i)) = i enddo END_PROVIDER - - BEGIN_PROVIDER [ integer, list_core_inact, (n_core_inact_orb)] -&BEGIN_PROVIDER [ integer, list_core_inact_reverse, (mo_tot_num)] - - implicit none - integer :: occ_inact(N_int*bit_kind_size) - integer :: itest,i - occ_inact = 0 - - call bitstring_to_list(reunion_of_core_inact_bitmask(1,1), occ_inact(1), itest, N_int) - - list_core_inact_reverse = 0 - do i = 1, n_core_inact_orb - list_core_inact(i) = occ_inact(i) - list_core_inact_reverse(occ_inact(i)) = i - enddo - - END_PROVIDER - - BEGIN_PROVIDER [ integer, n_core_inact_orb ] - implicit none - integer :: i - n_core_inact_orb = 0 - do i = 1, N_int - n_core_inact_orb += popcnt(reunion_of_core_inact_bitmask(i,1)) - enddo - ENd_PROVIDER - BEGIN_PROVIDER [ integer(bit_kind), reunion_of_core_inact_bitmask, (N_int,2)] implicit none BEGIN_DOC - ! Reunion of the core and inactive and virtual bitmasks + ! Reunion of the inactive, active and virtual bitmasks END_DOC - integer :: i + integer :: i,j do i = 1, N_int reunion_of_core_inact_bitmask(i,1) = ior(core_bitmask(i,1),inact_bitmask(i,1)) reunion_of_core_inact_bitmask(i,2) = ior(core_bitmask(i,2),inact_bitmask(i,2)) @@ -472,36 +407,6 @@ END_PROVIDER END_PROVIDER - BEGIN_PROVIDER [integer(bit_kind), reunion_of_core_inact_act_bitmask, (N_int,2)] -&BEGIN_PROVIDER [ integer, n_core_inact_act_orb ] - implicit none - BEGIN_DOC - ! Reunion of the core, inactive and active bitmasks - END_DOC - integer :: i,j - - n_core_inact_act_orb = 0 - do i = 1, N_int - reunion_of_core_inact_act_bitmask(i,1) = ior(reunion_of_core_inact_bitmask(i,1),cas_bitmask(i,1,1)) - reunion_of_core_inact_act_bitmask(i,2) = ior(reunion_of_core_inact_bitmask(i,2),cas_bitmask(i,1,1)) - n_core_inact_act_orb +=popcnt(reunion_of_core_inact_act_bitmask(i,1)) - enddo - END_PROVIDER - BEGIN_PROVIDER [ integer, list_core_inact_act, (n_core_inact_act_orb)] -&BEGIN_PROVIDER [ integer, list_core_inact_act_reverse, (mo_tot_num)] - implicit none - integer :: occ_inact(N_int*bit_kind_size) - integer :: itest,i - occ_inact = 0 - call bitstring_to_list(reunion_of_core_inact_act_bitmask(1,1), occ_inact(1), itest, N_int) - list_inact_reverse = 0 - do i = 1, n_core_inact_act_orb - list_core_inact_act(i) = occ_inact(i) - list_core_inact_act_reverse(occ_inact(i)) = i - enddo -END_PROVIDER - - BEGIN_PROVIDER [ integer(bit_kind), reunion_of_bitmask, (N_int,2)] @@ -518,7 +423,6 @@ END_PROVIDER BEGIN_PROVIDER [ integer(bit_kind), inact_virt_bitmask, (N_int,2)] -&BEGIN_PROVIDER [ integer(bit_kind), core_inact_virt_bitmask, (N_int,2)] implicit none BEGIN_DOC ! Reunion of the inactive and virtual bitmasks @@ -527,13 +431,10 @@ END_PROVIDER do i = 1, N_int inact_virt_bitmask(i,1) = ior(inact_bitmask(i,1),virt_bitmask(i,1)) inact_virt_bitmask(i,2) = ior(inact_bitmask(i,2),virt_bitmask(i,2)) - core_inact_virt_bitmask(i,1) = ior(core_bitmask(i,1),inact_virt_bitmask(i,1)) - core_inact_virt_bitmask(i,2) = ior(core_bitmask(i,2),inact_virt_bitmask(i,2)) enddo END_PROVIDER BEGIN_PROVIDER [integer, list_core, (n_core_orb)] -&BEGIN_PROVIDER [integer, list_core_reverse, (mo_tot_num)] BEGIN_DOC ! List of the core orbitals that are never excited in post CAS method END_DOC @@ -543,10 +444,8 @@ END_PROVIDER occ_core = 0 call bitstring_to_list(core_bitmask(1,1), occ_core(1), itest, N_int) ASSERT(itest==n_core_orb) - list_core_reverse = 0 do i = 1, n_core_orb list_core(i) = occ_core(i) - list_core_reverse(occ_core(i)) = i enddo END_PROVIDER @@ -559,8 +458,8 @@ END_PROVIDER integer :: i,j n_core_orb = 0 do i = 1, N_int - core_bitmask(i,1) = xor(full_ijkl_bitmask(i),ior(reunion_of_cas_inact_bitmask(i,1),virt_bitmask(i,1))) - core_bitmask(i,2) = xor(full_ijkl_bitmask(i),ior(reunion_of_cas_inact_bitmask(i,2),virt_bitmask(i,1))) + core_bitmask(i,1) = xor(closed_shell_ref_bitmask(i,1),reunion_of_cas_inact_bitmask(i,1)) + core_bitmask(i,2) = xor(closed_shell_ref_bitmask(i,2),reunion_of_cas_inact_bitmask(i,2)) n_core_orb += popcnt(core_bitmask(i,1)) enddo print*,'n_core_orb = ',n_core_orb @@ -598,17 +497,11 @@ BEGIN_PROVIDER [ integer, n_act_orb] do i = 1, N_int n_act_orb += popcnt(cas_bitmask(i,1,1)) enddo - print*,'n_act_orb = ',n_act_orb END_PROVIDER - BEGIN_PROVIDER [integer, list_act, (n_act_orb)] -&BEGIN_PROVIDER [integer, list_act_reverse, (mo_tot_num)] +BEGIN_PROVIDER [integer, list_act, (n_act_orb)] BEGIN_DOC - ! list_act(i) = index of the ith active orbital - ! - ! list_act_reverse : reverse list of active orbitals - ! list_act_reverse(i) = 0 ::> not an active - ! list_act_reverse(i) = k ::> IS the kth active orbital + ! list of active orbitals END_DOC implicit none integer :: occ_act(N_int*bit_kind_size) @@ -616,11 +509,10 @@ END_PROVIDER occ_act = 0 call bitstring_to_list(cas_bitmask(1,1,1), occ_act(1), itest, N_int) ASSERT(itest==n_act_orb) - list_act_reverse = 0 do i = 1, n_act_orb list_act(i) = occ_act(i) - list_act_reverse(occ_act(i)) = i enddo + END_PROVIDER BEGIN_PROVIDER [integer(bit_kind), closed_shell_ref_bitmask, (N_int,2)] @@ -645,19 +537,4 @@ END_PROVIDER enddo END_PROVIDER - - BEGIN_PROVIDER [integer, n_core_orb_allocate] - implicit none - n_core_orb_allocate = max(n_core_orb,1) - END_PROVIDER - - BEGIN_PROVIDER [integer, n_inact_orb_allocate] - implicit none - n_inact_orb_allocate = max(n_inact_orb,1) - END_PROVIDER - - BEGIN_PROVIDER [integer, n_virt_orb_allocate] - implicit none - n_virt_orb_allocate = max(n_virt_orb,1) - END_PROVIDER diff --git a/src/Davidson/EZFIO.cfg b/src/Davidson/EZFIO.cfg index 7724400f..415e359e 100644 --- a/src/Davidson/EZFIO.cfg +++ b/src/Davidson/EZFIO.cfg @@ -6,25 +6,7 @@ default: 1.e-12 [n_states_diag] type: States_number -doc: Number of states to consider during the Davdison diagonalization +doc: n_states_diag default: 10 interface: ezfio,provider,ocaml -[davidson_sze_max] -type: Strictly_positive_int -doc: Number of micro-iterations before re-contracting -default: 10 -interface: ezfio,provider,ocaml - -[state_following] -type: logical -doc: If true, the states are re-ordered to match the input states -default: False -interface: ezfio,provider,ocaml - -[disk_based_davidson] -type: logical -doc: If true, disk space is used to store the vectors -default: False -interface: ezfio,provider,ocaml - diff --git a/src/Davidson/diagonalization.irp.f b/src/Davidson/diagonalization.irp.f index 9bbd00f5..085a35b7 100644 --- a/src/Davidson/diagonalization.irp.f +++ b/src/Davidson/diagonalization.irp.f @@ -324,17 +324,8 @@ subroutine davidson_diag_hjj(dets_in,u_in,H_jj,energies,dim_in,sze,N_st,N_st_dia 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) @@ -427,13 +418,6 @@ subroutine davidson_diag_hjj(dets_in,u_in,H_jj,energies,dim_in,sze,N_st,N_st_dia ! ----------------------------------------- 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 = = diff --git a/src/Davidson/diagonalization_hs2.irp.f b/src/Davidson/diagonalization_hs2.irp.f index dccc8ee5..d7ec11b6 100644 --- a/src/Davidson/diagonalization_hs2.irp.f +++ b/src/Davidson/diagonalization_hs2.irp.f @@ -22,7 +22,7 @@ subroutine davidson_diag_hs2(dets_in,u_in,s2_out,dim_in,energies,sze,N_st,N_st_d 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_diag), s2_out(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 @@ -45,11 +45,7 @@ subroutine davidson_diag_hs2(dets_in,u_in,s2_out,dim_in,energies,sze,N_st,N_st_d !$OMP END DO !$OMP END PARALLEL - if (disk_based_davidson) then - call davidson_diag_hjj_sjj_mmap(dets_in,u_in,H_jj,S2_jj,energies,dim_in,sze,N_st,N_st_diag,Nint,iunit) - else - call davidson_diag_hjj_sjj(dets_in,u_in,H_jj,S2_jj,energies,dim_in,sze,N_st,N_st_diag,Nint,iunit) - endif + 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 @@ -87,8 +83,8 @@ subroutine davidson_diag_hjj_sjj(dets_in,u_in,H_jj,S2_jj,energies,dim_in,sze,N_s 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) :: 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) @@ -102,7 +98,7 @@ subroutine davidson_diag_hjj_sjj(dets_in,u_in,H_jj,S2_jj,energies,dim_in,sze,N_s integer :: k_pairs, kl integer :: iter2 - double precision, allocatable :: W(:,:), U(:,:), S(:,:), overlap(:,:) + 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 @@ -111,19 +107,17 @@ subroutine davidson_diag_hjj_sjj(dets_in,u_in,H_jj,S2_jj,energies,dim_in,sze,N_s double precision :: to_print(3,N_st) double precision :: cpu, wall integer :: shift, shift2, itermax - double precision :: r1, r2 - logical :: state_ok(N_st_diag*davidson_sze_max) 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 + print *, 'error in Davidson :' + print *, 'Increase n_det_max_jacobi to ', N_st_diag*3 + stop -1 endif - - PROVIDE nuclear_repulsion expected_s2 - + + PROVIDE nuclear_repulsion + call write_time(iunit) call wall_time(wall) call cpu_time(cpu) @@ -142,7 +136,7 @@ subroutine davidson_diag_hjj_sjj(dets_in,u_in,H_jj,S2_jj,energies,dim_in,sze,N_s write(iunit,'(A)') trim(write_buffer) write_buffer = ' Iter' do i=1,N_st - write_buffer = trim(write_buffer)//' Energy S^2 Residual ' + write_buffer = trim(write_buffer)//' Energy S^2 Residual' enddo write(iunit,'(A)') trim(write_buffer) write_buffer = '===== ' @@ -150,32 +144,31 @@ subroutine davidson_diag_hjj_sjj(dets_in,u_in,H_jj,S2_jj,energies,dim_in,sze,N_s write_buffer = trim(write_buffer)//' ================ =========== ===========' enddo write(iunit,'(A)') trim(write_buffer) - - integer, external :: align_double + + integer, external :: align_double sze_8 = align_double(sze) - - itermax = max(3,min(davidson_sze_max, sze/N_st_diag)) + + 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), & + 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), & - overlap(N_st_diag*itermax, N_st_diag*itermax), & + c(N_st_diag*itermax), & + s2(N_st_diag*itermax), & lambda(N_st_diag*itermax)) - h = 0.d0 + h = 0.d0 + s_ = 0.d0 + s_tmp = 0.d0 U = 0.d0 W = 0.d0 S = 0.d0 y = 0.d0 - s_ = 0.d0 - s_tmp = 0.d0 ASSERT (N_st > 0) @@ -189,21 +182,28 @@ subroutine davidson_diag_hjj_sjj(dets_in,u_in,H_jj,S2_jj,energies,dim_in,sze,N_s converged = .False. - do k=N_st+1,N_st_diag - u_in(k,k) = 10.d0 - 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 + 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=1,N_st_diag - call normalize(u_in(1,k),sze) + 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 @@ -211,77 +211,34 @@ subroutine davidson_diag_hjj_sjj(dets_in,u_in,H_jj,S2_jj,energies,dim_in,sze,N_s 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_zmq(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) 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, size(U,1), W, size(W,1), & - 0.d0, h, size(h,1)) - - call dgemm('T','N', shift2, shift2, sze, & - 1.d0, U, size(U,1), S, size(S,1), & - 0.d0, s_, size(s_,1)) + 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 S^2 -! ! --------------- -! -! call lapack_diag(s2,y,s_,size(s_,1),shift2) -! -! -! ! Rotate H in the basis of eigenfunctions of s2 -! ! --------------------------------------------- -! -! call dgemm('N','N',shift2,shift2,shift2, & -! 1.d0, h, size(h,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, h, size(h,1)) -! -! ! Damp interaction between different spin states -! ! ------------------------------------------------ -! -! do k=1,shift2 -! do l=1,shift2 -! if (dabs(s2(k) - s2(l)) > 1.d0) then -! h(k,l) = h(k,l)*(max(0.d0,1.d0 - dabs(s2(k) - s2(l)))) -! endif -! enddo -! enddo -! -! ! Rotate back H -! ! ------------- -! -! call dgemm('N','T',shift2,shift2,shift2, & -! 1.d0, h, size(h,1), y, size(y,1), & -! 0.d0, s_tmp, size(s_tmp,1)) -! -! call dgemm('N','N',shift2,shift2,shift2, & -! 1.d0, y, size(y,1), s_tmp, size(s_tmp,1), & -! 0.d0, h, size(h,1)) - - ! Diagonalize h ! ------------- - call lapack_diag(lambda,y,h,size(h,1),shift2) ! Compute S2 for each eigenvector @@ -294,80 +251,30 @@ subroutine davidson_diag_hjj_sjj(dets_in,u_in,H_jj,S2_jj,energies,dim_in,sze,N_s 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 - do k=1,shift2 - state_ok(k) = (dabs(s2(k)-expected_s2) < 0.6d0) - enddo - else - do k=1,size(state_ok) - state_ok(k) = .True. - enddo - endif - - 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 - - if (state_following) then - - integer :: order(N_st_diag) - double precision :: cmax - - overlap = -1.d0 + logical :: state_ok(N_st_diag*davidson_sze_max) do k=1,shift2 - do i=1,shift2 - overlap(k,i) = dabs(y(k,i)) - enddo + state_ok(k) = (dabs(s2(k)-expected_s2) < 0.6d0) enddo - do k=1,N_st - cmax = -1.d0 - do i=1,N_st - if (overlap(i,k) > cmax) then - cmax = overlap(i,k) - order(k) = i - endif - enddo - do i=1,N_st_diag - overlap(order(k),i) = -1.d0 - enddo - enddo - overlap = y - do k=1,N_st - l = order(k) - if (k /= l) then - y(1:shift2,k) = overlap(1:shift2,l) + 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 - do k=1,N_st - overlap(k,1) = lambda(k) - overlap(k,2) = s2(k) - enddo - do k=1,N_st - l = order(k) - if (k /= l) then - lambda(k) = overlap(l,1) - s2(k) = overlap(l,2) - endif - enddo - endif @@ -386,12 +293,10 @@ subroutine davidson_diag_hjj_sjj(dets_in,u_in,H_jj,S2_jj,energies,dim_in,sze,N_s do k=1,N_st_diag do i=1,sze - U(i,shift2+k) = & - (lambda(k) * U(i,shift2+k) - W(i,shift2+k) ) & + 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) + )/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 @@ -400,10 +305,10 @@ subroutine davidson_diag_hjj_sjj(dets_in,u_in,H_jj,S2_jj,energies,dim_in,sze,N_s 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) + write(iunit,'(X,I3,X,100(X,F16.10,X,F11.6,X,E11.3,A30))') iter, to_print(:,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 + if (residual_norm(k) > 1.e4) then print *, '' stop 'Davidson failed' endif @@ -414,16 +319,23 @@ subroutine davidson_diag_hjj_sjj(dets_in,u_in,H_jj,S2_jj,energies,dim_in,sze,N_s enddo + if (.not.converged) then + iter = itermax-1 + endif + ! Re-contract to u_in ! ----------- - call dgemm('N','N', sze, N_st_diag, shift2, 1.d0, & + 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 - energies(k) = lambda(k) S2_jj(k) = s2(k) enddo write_buffer = '===== ' @@ -436,7 +348,7 @@ subroutine davidson_diag_hjj_sjj(dets_in,u_in,H_jj,S2_jj,energies,dim_in,sze,N_s deallocate ( & W, residual_norm, & - U, overlap, & + U, & c, S, & h, & y, s_, s_tmp, & @@ -444,439 +356,3 @@ subroutine davidson_diag_hjj_sjj(dets_in,u_in,H_jj,S2_jj,energies,dim_in,sze,N_s ) end -subroutine davidson_diag_hjj_sjj_mmap(dets_in,u_in,H_jj,S2_jj,energies,dim_in,sze,N_st,N_st_diag,Nint,iunit) - use bitmasks - use mmap_module - 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, pointer :: W(:,:), U(:,:), S(:,:), overlap(:,:) - 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 - logical :: state_ok(N_st_diag*davidson_sze_max) - 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 expected_s2 - - 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 - integer :: fd(3) - type(c_ptr) :: c_pointer(3) - sze_8 = align_double(sze) - - itermax = min(davidson_sze_max, sze/N_st_diag) - - call mmap( & - trim(ezfio_work_dir)//'U', & - (/ int(sze_8,8),int(N_st_diag*itermax,8) /), & - 8, fd(1), .False., c_pointer(1)) - call c_f_pointer(c_pointer(1), W, (/ sze_8,N_st_diag*itermax /) ) - - call mmap( & - trim(ezfio_work_dir)//'W', & - (/ int(sze_8,8),int(N_st_diag*itermax,8) /), & - 8, fd(2), .False., c_pointer(2)) - call c_f_pointer(c_pointer(2), U, (/ sze_8,N_st_diag*itermax /) ) - - call mmap( & - trim(ezfio_work_dir)//'S', & - (/ int(sze_8,8),int(N_st_diag*itermax,8) /), & - 8, fd(3), .False., c_pointer(3)) - call c_f_pointer(c_pointer(3), S, (/ sze_8,N_st_diag*itermax /) ) - - allocate( & - 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), & - overlap(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 - U = 0.d0 - W = 0.d0 - S = 0.d0 - y = 0.d0 - s_ = 0.d0 - s_tmp = 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 - u_in(k,k) = 10.d0 - do i=1,sze - call random_number(r1) - r1 = dsqrt(-2.d0*dlog(r1)) - r2 = dtwo_pi*r2 - u_in(i,k) = r1*dcos(r2) - enddo - enddo - do k=1,N_st_diag - call normalize(u_in(1,k),sze) - 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_zmq(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) - 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 = = - ! ------------------------------------------- - - do k=1,iter - shift = N_st_diag*(k-1) - call dgemm('T','N', N_st_diag, shift2, sze, & - 1.d0, U(1,shift+1), size(U,1), W, size(W,1), & - 0.d0, h(shift+1,1), size(h,1)) - - call dgemm('T','N', N_st_diag, shift2, sze, & - 1.d0, U(1,shift+1), size(U,1), S, size(S,1), & - 0.d0, s_(shift+1,1), size(s_,1)) - enddo - -! ! Diagonalize S^2 -! ! --------------- -! -! call lapack_diag(s2,y,s_,size(s_,1),shift2) -! -! -! ! Rotate H in the basis of eigenfunctions of s2 -! ! --------------------------------------------- -! -! call dgemm('N','N',shift2,shift2,shift2, & -! 1.d0, h, size(h,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, h, size(h,1)) -! -! ! Damp interaction between different spin states -! ! ------------------------------------------------ -! -! do k=1,shift2 -! do l=1,shift2 -! if (dabs(s2(k) - s2(l)) > 1.d0) then -! h(k,l) = h(k,l)*(max(0.d0,1.d0 - dabs(s2(k) - s2(l)))) -! endif -! enddo -! enddo -! -! ! Rotate back H -! ! ------------- -! -! call dgemm('N','T',shift2,shift2,shift2, & -! 1.d0, h, size(h,1), y, size(y,1), & -! 0.d0, s_tmp, size(s_tmp,1)) -! -! call dgemm('N','N',shift2,shift2,shift2, & -! 1.d0, y, size(y,1), s_tmp, size(s_tmp,1), & -! 0.d0, h, size(h,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 - do k=1,shift2 - state_ok(k) = (dabs(s2(k)-expected_s2) < 0.6d0) - enddo - else - state_ok(k) = .True. - endif - - 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 - - if (state_following) then - - ! Compute overlap with U_in - ! ------------------------- - - integer :: order(N_st_diag) - double precision :: cmax - overlap = -1.d0 - do k=1,shift2 - do i=1,shift2 - overlap(k,i) = dabs(y(k,i)) - enddo - enddo - do k=1,N_st - cmax = -1.d0 - do i=1,shift2 - if (overlap(i,k) > cmax) then - cmax = overlap(i,k) - order(k) = i - endif - enddo - do i=1,shift2 - overlap(order(k),i) = -1.d0 - enddo - enddo - overlap = y - do k=1,N_st - l = order(k) - if (k /= l) then - y(1:shift2,k) = overlap(1:shift2,l) - endif - enddo - do k=1,N_st - overlap(k,1) = lambda(k) - overlap(k,2) = s2(k) - enddo - do k=1,N_st - l = order(k) - if (k /= l) then - lambda(k) = overlap(l,1) - s2(k) = overlap(l,2) - 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 - if (state_ok(k)) then - 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 - else - ! Randomize components with bad - do i=1,sze-2,2 - call random_number(r1) - call random_number(r2) - r1 = dsqrt(-2.d0*dlog(r1)) - r2 = dtwo_pi*r2 - U(i,shift2+k) = r1*dcos(r2) - U(i+1,shift2+k) = r1*dsin(r2) - enddo - do i=sze-2+1,sze - call random_number(r1) - call random_number(r2) - r1 = dsqrt(-2.d0*dlog(r1)) - r2 = dtwo_pi*r2 - U(i,shift2+k) = r1*dcos(r2) - enddo - endif - - 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 - - ! Re-contract to u_in - ! ----------- - - call dgemm('N','N', sze, N_st_diag, shift2, 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 - energies(k) = lambda(k) - 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) - - call munmap( & - (/ int(sze_8,8),int(N_st_diag*itermax,8) /), & - 8, fd(1), c_pointer(1)) - - call munmap( & - (/ int(sze_8,8),int(N_st_diag*itermax,8) /), & - 8, fd(2), c_pointer(2)) - - call munmap( & - (/ int(sze_8,8),int(N_st_diag*itermax,8) /), & - 8, fd(3), c_pointer(3)) - - deallocate ( & - residual_norm, & - c, overlap, & - h, & - y, s_, s_tmp, & - lambda & - ) -end - diff --git a/src/Davidson/diagonalize_CI.irp.f b/src/Davidson/diagonalize_CI.irp.f index e1b67438..3b2c9ed0 100644 --- a/src/Davidson/diagonalize_CI.irp.f +++ b/src/Davidson/diagonalize_CI.irp.f @@ -40,7 +40,6 @@ END_PROVIDER double precision, allocatable :: e_array(:) integer, allocatable :: iorder(:) - PROVIDE threshold_davidson ! Guess values for the "N_states" states of the CI_eigenvectors do j=1,min(N_states,N_det) do i=1,N_det diff --git a/src/Davidson/diagonalize_CI_mono.irp.f b/src/Davidson/diagonalize_CI_mono.irp.f new file mode 100644 index 00000000..1de9a211 --- /dev/null +++ b/src/Davidson/diagonalize_CI_mono.irp.f @@ -0,0 +1,86 @@ + 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,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,s2,N_det) + 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,s2,N_det) + 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/Davidson/diagonalize_restart_and_save_all_states.irp.f b/src/Davidson/diagonalize_restart_and_save_all_states.irp.f deleted file mode 100644 index 3bdc37c5..00000000 --- a/src/Davidson/diagonalize_restart_and_save_all_states.irp.f +++ /dev/null @@ -1,16 +0,0 @@ -program diag_and_save - implicit none - read_wf = .True. - touch read_wf - call routine -end - -subroutine routine - implicit none - call diagonalize_CI - print*,'N_det = ',N_det - call save_wavefunction_general(N_det,N_states_diag,psi_det_sorted,size(psi_coef_sorted,1),psi_coef_sorted) - - - -end diff --git a/src/Davidson/diagonalize_restart_and_save_lowest_state.irp.f b/src/Davidson/diagonalize_restart_and_save_lowest_state.irp.f deleted file mode 100644 index 11c98034..00000000 --- a/src/Davidson/diagonalize_restart_and_save_lowest_state.irp.f +++ /dev/null @@ -1,25 +0,0 @@ -program diag_and_save - implicit none - read_wf = .True. - touch read_wf - call routine -end - -subroutine routine - implicit none - print*,'N_det = ',N_det - call diagonalize_CI - integer :: igood_state - igood_state=1 - double precision, allocatable :: psi_coef_tmp(:) - allocate(psi_coef_tmp(n_det)) - integer :: i - do i = 1, N_det - psi_coef_tmp(i) = psi_coef(i,igood_state) - enddo - call save_wavefunction_general(N_det,1,psi_det,n_det,psi_coef_tmp) - deallocate(psi_coef_tmp) - - - -end diff --git a/src/Davidson/diagonalize_restart_and_save_one_state.irp.f b/src/Davidson/diagonalize_restart_and_save_one_state.irp.f deleted file mode 100644 index c5f4e59d..00000000 --- a/src/Davidson/diagonalize_restart_and_save_one_state.irp.f +++ /dev/null @@ -1,26 +0,0 @@ -program diag_and_save - implicit none - read_wf = .True. - touch read_wf - call routine -end - -subroutine routine - implicit none - print*,'N_det = ',N_det - call diagonalize_CI - write(*,*)'Which state would you like to save ?' - integer :: igood_state - read(5,*)igood_state - double precision, allocatable :: psi_coef_tmp(:) - allocate(psi_coef_tmp(n_det)) - integer :: i - do i = 1, N_det - psi_coef_tmp(i) = psi_coef(i,igood_state) - enddo - call save_wavefunction_general(N_det,1,psi_det,n_det,psi_coef_tmp) - deallocate(psi_coef_tmp) - - - -end diff --git a/src/Davidson/parameters.irp.f b/src/Davidson/parameters.irp.f index ae8babaa..82315495 100644 --- a/src/Davidson/parameters.irp.f +++ b/src/Davidson/parameters.irp.f @@ -1,3 +1,21 @@ +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 diff --git a/src/Davidson/print_H_matrix_restart.irp.f b/src/Davidson/print_H_matrix_restart.irp.f deleted file mode 100644 index 57fc3633..00000000 --- a/src/Davidson/print_H_matrix_restart.irp.f +++ /dev/null @@ -1,176 +0,0 @@ -program print_H_matrix_restart - implicit none - read_wf = .True. - touch read_wf - call routine - -end - -subroutine routine - use bitmasks - implicit none - integer :: i,j - integer, allocatable :: H_matrix_degree(:,:) - double precision, allocatable :: H_matrix_phase(:,:) - integer :: degree - integer(bit_kind), allocatable :: keys_tmp(:,:,:) - allocate(keys_tmp(N_int,2,N_det)) - do i = 1, N_det - print*,'' - call debug_det(psi_det(1,1,i),N_int) - do j = 1, N_int - keys_tmp(j,1,i) = psi_det(j,1,i) - keys_tmp(j,2,i) = psi_det(j,2,i) - enddo - enddo - if(N_det.ge.10000)then - print*,'Warning !!!' - print*,'Number of determinants is ',N_det - print*,'It means that the H matrix will be enormous !' - print*,'stoppping ..' - stop - endif - print*,'' - print*,'Determinants ' - do i = 1, N_det - enddo - allocate(H_matrix_degree(N_det,N_det),H_matrix_phase(N_det,N_det)) - integer :: exc(0:2,2,2) - double precision :: phase - do i = 1, N_det - do j = i, N_det - call get_excitation_degree(psi_det(1,1,i),psi_det(1,1,j),degree,N_int) - H_matrix_degree(i,j) = degree - H_matrix_degree(j,i) = degree - phase = 0.d0 - if(degree==1.or.degree==2)then - call get_excitation(psi_det(1,1,i),psi_det(1,1,j),exc,degree,phase,N_int) - endif - H_matrix_phase(i,j) = phase - H_matrix_phase(j,i) = phase - enddo - enddo - print*,'H matrix ' - double precision :: ref_h_matrix,s2 - ref_h_matrix = H_matrix_all_dets(1,1) - print*,'HF like determinant energy = ',ref_bitmask_energy+nuclear_repulsion - print*,'Ref element of H_matrix = ',ref_h_matrix+nuclear_repulsion - print*,'Printing the H matrix ...' - print*,'' - print*,'' -!do i = 1, N_det -! H_matrix_all_dets(i,i) -= ref_h_matrix -!enddo - - do i = 1, N_det - H_matrix_all_dets(i,i) += nuclear_repulsion - enddo - -!do i = 5,N_det -! H_matrix_all_dets(i,3) = 0.d0 -! H_matrix_all_dets(3,i) = 0.d0 -! H_matrix_all_dets(i,4) = 0.d0 -! H_matrix_all_dets(4,i) = 0.d0 -!enddo - - - - - - do i = 1, N_det - write(*,'(I3,X,A3,1000(F16.7))')i,' | ',H_matrix_all_dets(i,:) - enddo - - print*,'' - print*,'' - print*,'' - print*,'Printing the degree of excitations within the H matrix' - print*,'' - print*,'' - do i = 1, N_det - write(*,'(I3,X,A3,X,1000(I1,X))')i,' | ',H_matrix_degree(i,:) - enddo - - - print*,'' - print*,'' - print*,'Printing the phase of the Hamiltonian matrix elements ' - print*,'' - print*,'' - do i = 1, N_det - write(*,'(I3,X,A3,X,1000(F3.0,X))')i,' | ',H_matrix_phase(i,:) - enddo - print*,'' - - - double precision, allocatable :: eigenvectors(:,:), eigenvalues(:) - double precision, allocatable :: s2_eigvalues(:) - allocate (eigenvectors(size(H_matrix_all_dets,1),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 ' - 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,k_a_iv,k_b_iv - integer :: h1,p1,h2,p2 - h1 = 10 - p1 = 16 - h2 = 14 - p2 = 14 -!h1 = 1 -!p1 = 4 -!h2 = 2 -!p2 = 2 - 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(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 - h1 = 16 - p1 = 14 - h2 = 14 - p2 = 16 - 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(h1,h2,p1,p2,mo_integrals_map) - - h1 = 10 - p1 = 14 - h2 = 14 - p2 = 10 - 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(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 - double precision :: k_iv - - h1 = 10 - p1 = 16 - h2 = 16 - p2 = 10 - k_iv = get_mo_bielec_integral(h1,h2,p1,p2,mo_integrals_map) - print*,'k_iv = ',k_iv -end diff --git a/src/Davidson/tree_dependency.png b/src/Davidson/tree_dependency.png deleted file mode 100644 index e69de29b..00000000 diff --git a/src/Davidson/u0Hu0.irp.f b/src/Davidson/u0Hu0.irp.f index 117e704e..3787370a 100644 --- a/src/Davidson/u0Hu0.irp.f +++ b/src/Davidson/u0Hu0.irp.f @@ -88,12 +88,9 @@ subroutine H_u_0_nstates(v_0,u_0,H_jj,n,keys_tmp,Nint,N_st,sze_8) !$OMP DO SCHEDULE(dynamic) do sh=1,shortcut(0,1) - do sh2=1,shortcut(0,1) - exa = popcnt(xor(version(1,sh,1), version(1,sh2,1))) - if(exa > 2) then - cycle - end if - do ni=2,Nint + 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 @@ -102,27 +99,29 @@ subroutine H_u_0_nstates(v_0,u_0,H_jj,n,keys_tmp,Nint,N_st,sze_8) 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 - jloop: do j=shortcut(sh2,1),shortcut(sh2+1,1)-1 + do j=shortcut(sh2,1),endi org_j = sort_idx(j,1) - ext = exa + popcnt(xor(sorted_i(1), sorted(1,j,1))) - if(ext > 4) then - cycle jloop - endif - do ni=2,Nint + ext = exa + do ni=1,Nint ext = ext + popcnt(xor(sorted_i(ni), sorted(ni,j,1))) - if(ext > 4) then - cycle jloop - endif end do - 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) - enddo - enddo jloop + 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 @@ -132,19 +131,19 @@ subroutine H_u_0_nstates(v_0,u_0,H_jj,n,keys_tmp,Nint,N_st,sze_8) 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),shortcut(sh+1,2)-1 + do j=shortcut(sh,2),i-1 org_j = sort_idx(j,2) - ext = popcnt(xor(sorted(1,i,2), sorted(1,j,2))) - do ni=2,Nint + ext = 0 + do ni=1,Nint ext = ext + popcnt(xor(sorted(ni,i,2), sorted(ni,j,2))) end do - if(ext /= 4) then - cycle - endif - 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) - enddo + 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 @@ -178,7 +177,7 @@ BEGIN_PROVIDER [ double precision, psi_energy, (N_states) ] END_PROVIDER -subroutine H_S2_u_0_nstates_zmq(v_0,s_0,u_0,H_jj,S2_jj,n,keys_tmp,Nint,N_st,sze_8) +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 @@ -210,7 +209,7 @@ subroutine H_S2_u_0_nstates_zmq(v_0,s_0,u_0,H_jj,S2_jj,n,keys_tmp,Nint,N_st,sze_ integer, external :: align_double integer :: blockb, blockb2, istep - double precision :: ave_workload, workload, target_workload_inv + double precision :: ave_workload, workload integer(ZMQ_PTR) :: handler @@ -251,7 +250,6 @@ subroutine H_S2_u_0_nstates_zmq(v_0,s_0,u_0,H_jj,S2_jj,n,keys_tmp,Nint,N_st,sze_ 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 @@ -261,7 +259,7 @@ subroutine H_S2_u_0_nstates_zmq(v_0,s_0,u_0,H_jj,S2_jj,n,keys_tmp,Nint,N_st,sze_ workload += (shortcut(j+1,2) - shortcut(j, 2))**2 end do end do - istep = 1+ int(workload*target_workload_inv) + istep = 1+ int(0.5d0*workload/ave_workload) do blockb2=0, istep-1 call davidson_add_task(handler, sh, blockb2, istep) enddo @@ -281,235 +279,3 @@ end -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 - 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 :: 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 - integer :: blockb, blockb2, istep - double precision :: ave_workload, workload, target_workload_inv - - !DIR$ ATTRIBUTES ALIGN : $IRP_ALIGN :: vt, ut, st - - 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 - - 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,u_0,v_0,s_0,sorted,shortcut,sort_idx,version,N_st,N_st_8) - allocate(vt(N_st_8,n),st(N_st_8,n)) - Vt = 0.d0 - St = 0.d0 - - !$OMP DO - do i=1,n - do istate=1,N_st - ut(istate,i) = u_0(sort_idx(i,2),istate) - enddo - enddo - !$OMP END DO - - !$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),shortcut(sh+1,2)-1 - org_j = sort_idx(j,2) - ext = popcnt(xor(sorted(1,i,2), sorted(1,j,2))) - if (ext > 4) cycle - do ni=2,Nint - ext = ext + popcnt(xor(sorted(ni,i,2), sorted(ni,j,2))) - if (ext > 4) exit - 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,j) - st (istate,org_i) = st (istate,org_i) + s2*ut(istate,j) - enddo - end if - end do - end do - enddo - !$OMP END DO - - !$OMP DO - do i=1,n - do istate=1,N_st - ut(istate,i) = u_0(sort_idx(i,1),istate) - enddo - enddo - !$OMP END DO - - !$OMP DO SCHEDULE(dynamic) - do sh=1,shortcut(0,1) - do sh2=1,shortcut(0,1) - if (sh==sh2) cycle - - 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) - do ni=1,Nint - sorted_i(ni) = sorted(ni,i,1) - enddo - - do j=shortcut(sh2,1),shortcut(sh2+1,1)-1 - ext = exa + popcnt(xor(sorted_i(1), sorted(1,j,1))) - if (ext > 4) cycle - do ni=2,Nint - ext = ext + popcnt(xor(sorted_i(ni), sorted(ni,j,1))) - if (ext > 4) exit - end do - if(ext <= 4) then - org_j = sort_idx(j,1) - call i_h_j (keys_tmp(1,1,org_j),keys_tmp(1,1,org_i),nint,hij) - if (hij /= 0.d0) then - do istate=1,n_st - vt (istate,org_i) = vt (istate,org_i) + hij*ut(istate,j) - enddo - endif - if (ext /= 2) then - call get_s2(keys_tmp(1,1,org_j),keys_tmp(1,1,org_i),nint,s2) - if (s2 /= 0.d0) then - do istate=1,n_st - st (istate,org_i) = st (istate,org_i) + s2*ut(istate,j) - enddo - endif - endif - endif - enddo - - enddo - enddo - - exa = 0 - - do i=shortcut(sh,1),shortcut(sh+1,1)-1 - org_i = sort_idx(i,1) - do ni=1,Nint - sorted_i(ni) = sorted(ni,i,1) - enddo - - do j=shortcut(sh,1),i-1 - ext = exa + popcnt(xor(sorted_i(1), sorted(1,j,1))) - if (ext > 4) cycle - do ni=2,Nint - ext = ext + popcnt(xor(sorted_i(ni), sorted(ni,j,1))) - if (ext > 4) exit - end do - if(ext <= 4) then - org_j = sort_idx(j,1) - call i_h_j (keys_tmp(1,1,org_j),keys_tmp(1,1,org_i),nint,hij) - if (hij /= 0.d0) then - do istate=1,n_st - vt (istate,org_i) = vt (istate,org_i) + hij*ut(istate,j) - enddo - endif - if (ext /= 2) then - call get_s2(keys_tmp(1,1,org_j),keys_tmp(1,1,org_i),nint,s2) - if (s2 /= 0.d0) then - do istate=1,n_st - st (istate,org_i) = st (istate,org_i) + s2*ut(istate,j) - enddo - endif - endif - endif - enddo - - do j=i+1,shortcut(sh+1,1)-1 - if (i==j) cycle - ext = exa + popcnt(xor(sorted_i(1), sorted(1,j,1))) - if (ext > 4) cycle - do ni=2,Nint - ext = ext + popcnt(xor(sorted_i(ni), sorted(ni,j,1))) - if (ext > 4) exit - end do - if(ext <= 4) then - org_j = sort_idx(j,1) - call i_h_j (keys_tmp(1,1,org_j),keys_tmp(1,1,org_i),nint,hij) - if (hij /= 0.d0) then - do istate=1,n_st - vt (istate,org_i) = vt (istate,org_i) + hij*ut(istate,j) - enddo - endif - if (ext /= 2) then - call get_s2(keys_tmp(1,1,org_j),keys_tmp(1,1,org_i),nint,s2) - if (s2 /= 0.d0) then - do istate=1,n_st - st (istate,org_i) = st (istate,org_i) + s2*ut(istate,j) - enddo - endif - endif - endif - enddo - enddo - enddo - !$OMP END DO - - !$OMP CRITICAL (u0Hu0) - do istate=1,N_st - do i=1,n - 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 (u0Hu0) - - 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/src/Determinants/EZFIO.cfg b/src/Determinants/EZFIO.cfg index 0676649e..41e05bda 100644 --- a/src/Determinants/EZFIO.cfg +++ b/src/Determinants/EZFIO.cfg @@ -106,16 +106,3 @@ interface: ezfio,provider,ocaml doc: Energy that should be obtained when truncating the wave function (optional) type: Energy default: 0. - -[store_full_H_mat] -type: logical -doc: If True, the Davidson diagonalization is performed by storing the full H matrix up to n_det_max_stored. Be careful, it can cost a lot of memory but can also save a lot of CPU time -interface: ezfio,provider,ocaml -default: False - -[n_det_max_stored] -type: Det_number_max -doc: Maximum number of determinants for which the full H matrix is stored. Be careful, the memory requested scales as 10*n_det_max_stored**2. For instance, 90000 determinants represent a matrix of size 60 Gb. -interface: ezfio,provider,ocaml -default: 90000 - diff --git a/src/Determinants/H_apply.irp.f b/src/Determinants/H_apply.irp.f index 411fe703..b047efdc 100644 --- a/src/Determinants/H_apply.irp.f +++ b/src/Determinants/H_apply.irp.f @@ -214,19 +214,20 @@ subroutine remove_duplicates_in_psi_det(found_duplicates) duplicate(i) = .False. enddo - do i=1,N_det-1 + found_duplicates = .False. + i=0 + j=0 + do while (i N_det) then - exit - else - cycle - endif + cycle endif duplicate(j) = .True. do k=1,N_int @@ -243,29 +244,18 @@ subroutine remove_duplicates_in_psi_det(found_duplicates) enddo enddo - found_duplicates = .False. - do i=1,N_det - if (duplicate(i)) then - found_duplicates = .True. - exit - endif - enddo - if (found_duplicates) then + call write_bool(output_determinants,found_duplicates,'Found duplicate determinants') k=0 do i=1,N_det if (.not.duplicate(i)) then k += 1 psi_det(:,:,k) = psi_det_sorted_bit (:,:,i) psi_coef(k,:) = psi_coef_sorted_bit(i,:) - else - call debug_det(psi_det_sorted_bit(1,1,i),N_int) - stop 'duplicates in psi_det' endif enddo N_det = k - call write_bool(output_determinants,found_duplicates,'Found duplicate determinants') - SOFT_TOUCH N_det psi_det psi_coef + TOUCH N_det psi_det psi_coef endif deallocate (duplicate,bit_tmp) end @@ -313,6 +303,7 @@ 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,i_generator,N_st,task_id) use f77_zmq implicit none diff --git a/src/Determinants/H_apply.template.f b/src/Determinants/H_apply.template.f index 5f59fe84..69b15304 100644 --- a/src/Determinants/H_apply.template.f +++ b/src/Determinants/H_apply.template.f @@ -181,8 +181,6 @@ subroutine $subroutine_diexcOrg(key_in,key_mask,hole_1,particl_1,hole_2, particl logical :: is_a_1h logical :: is_a_1p logical :: is_a_2p - logical :: is_a_2h1p - logical :: is_a_2h logical :: b_cycle check_double_excitation = .True. iproc = iproc_in @@ -314,10 +312,6 @@ subroutine $subroutine_diexcOrg(key_in,key_mask,hole_1,particl_1,hole_2, particl $filter_only_1h2p_double $filter_only_2h2p_double $only_2p_double - $only_2h_double - $only_1h_double - $only_1p_double - $only_2h1p_double key_idx += 1 do k=1,N_int keys_out(k,1,key_idx) = key(k,1) @@ -369,10 +363,6 @@ subroutine $subroutine_diexcOrg(key_in,key_mask,hole_1,particl_1,hole_2, particl $filter_only_1h2p_double $filter_only_2h2p_double $only_2p_double - $only_2h_double - $only_1h_double - $only_1p_double - $only_2h1p_double key_idx += 1 do k=1,N_int keys_out(k,1,key_idx) = key(k,1) @@ -439,8 +429,6 @@ subroutine $subroutine_monoexc(key_in, hole_1,particl_1,fock_diag_tmp,i_generato integer(bit_kind) :: key_mask(N_int, 2) logical :: check_double_excitation - logical :: is_a_2h1p - logical :: is_a_2h logical :: is_a_1h1p logical :: is_a_1h2p logical :: is_a_1h @@ -516,10 +504,6 @@ subroutine $subroutine_monoexc(key_in, hole_1,particl_1,fock_diag_tmp,i_generato $filterparticle hole(k_a,ispin) = ibset(hole(k_a,ispin),l_a) $only_2p_single - $only_2h_single - $only_1h_single - $only_1p_single - $only_2h1p_single $filter1h $filter1p $filter2p diff --git a/src/Determinants/NEEDED_CHILDREN_MODULES b/src/Determinants/NEEDED_CHILDREN_MODULES index 8711010f..5505ce78 100644 --- a/src/Determinants/NEEDED_CHILDREN_MODULES +++ b/src/Determinants/NEEDED_CHILDREN_MODULES @@ -1 +1 @@ -Integrals_Monoelec Integrals_Bielec +Integrals_Monoelec Integrals_Bielec \ No newline at end of file diff --git a/src/Determinants/README.rst b/src/Determinants/README.rst index 9ad0f1a3..c6685945 100644 --- a/src/Determinants/README.rst +++ b/src/Determinants/README.rst @@ -15,31 +15,23 @@ 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_hole `_ - Undocumented - - -`apply_holes `_ +`apply_excitation `_ Undocumented @@ -47,24 +39,16 @@ Documentation Undocumented -`apply_particle `_ - Undocumented - - -`apply_particles `_ - Undocumented - - `bi_elec_ref_bitmask_energy `_ 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 @@ -74,15 +58,72 @@ Documentation determinant. F_00 is = E0. +`ci_eigenvectors `_ + Eigenvectors/values of the CI matrix + + +`ci_eigenvectors_mono `_ + Eigenvectors/values of the CI matrix + + +`ci_eigenvectors_s2 `_ + Eigenvectors/values of the CI matrix + + +`ci_eigenvectors_s2_mono `_ + Eigenvectors/values of the CI matrix + + +`ci_electronic_energy `_ + Eigenvectors/values of the CI matrix + + +`ci_electronic_energy_mono `_ + Eigenvectors/values of the CI matrix + + +`ci_energy `_ + N_states lowest eigenvalues of the CI matrix + + +`ci_sc2_eigenvectors `_ + Eigenvectors/values of the CI matrix + + +`ci_sc2_electronic_energy `_ + Eigenvectors/values of the CI matrix + + +`ci_sc2_energy `_ + N_states_diag lowest eigenvalues of the CI matrix + + `cisd `_ Undocumented -`connected_to_ref `_ +`cisd_sc2 `_ + CISD+SC2 method :: take off all the disconnected terms of a CISD (selected or not) + .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 + Initial guess vectors are not necessarily orthonormal + + +`connected_to_ref `_ Undocumented -`connected_to_ref_by_mono `_ +`connected_to_ref_by_mono `_ Undocumented @@ -95,11 +136,11 @@ Documentation Undocumented -`create_minilist `_ +`create_minilist `_ Undocumented -`create_minilist_find_previous `_ +`create_minilist_find_previous `_ Undocumented @@ -108,6 +149,62 @@ Documentation of alpha and beta determinants +`davidson_converged `_ + True if the Davidson algorithm is converged + + +`davidson_criterion `_ + Can be : [ energy | residual | both | wall_time | cpu_time | iterations ] + + +`davidson_diag `_ + 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 + + +`davidson_diag_hjj `_ + 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_iter_max `_ + Max number of Davidson iterations + + +`davidson_sze_max `_ + Max number of Davidson sizes + + `decode_exc `_ Decodes the exc arrays returned by get_excitation. h1,h2 : Holes @@ -116,14 +213,6 @@ Documentation degree : Degree of excitation -`decode_exc_int2 `_ - 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 - - `det_alpha_norm `_ Norm of the alpha and beta spin determinants in the wave function: .br @@ -136,11 +225,15 @@ Documentation ||Da||_i \sum_j C_{ij}**2 -`det_coef `_ +`det_coef `_ det_coef -`det_occ `_ +`det_inf `_ + Undocumented + + +`det_occ `_ det_occ @@ -152,29 +245,44 @@ Documentation Transform a determinant to an occupation pattern -`detcmp `_ - Undocumented - - -`deteq `_ - Undocumented - - -`diag_algorithm `_ +`diag_algorithm `_ 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_s2_betweenstates `_ - You enter with nstates vectors in u_0 that may be coupled by S^2 +`diagonalize_ci `_ + Replace the coefficients of the CI states by the coefficients of the + eigenstates of the CI matrix + + +`diagonalize_ci_mono `_ + Replace the coefficients of the CI states by the coefficients of the + eigenstates of the CI matrix + + +`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. @@ -241,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 @@ -251,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 @@ -263,22 +371,18 @@ Documentation to repeat the excitations -`flip_generators `_ - Undocumented +`first_guess `_ + Select all the determinants with the lowest energy as a starting point. `generate_all_alpha_beta_det_products `_ Create a wave function from all possible alpha x beta determinants -`get_double_excitation `_ +`get_double_excitation `_ Returns the two excitation operators between two doubly excited determinants and the phase -`get_double_excitation_phase `_ - Undocumented - - `get_excitation `_ Returns the excitation operators between two determinants and the phase @@ -287,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 @@ -303,23 +407,27 @@ 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 -`get_phase `_ - Returns the phase between key1 and key2 - - `get_s2 `_ Returns -`get_uj_s2_ui `_ +`get_s2_u0 `_ + Undocumented + + +`get_s2_u0_old `_ + 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) @@ -350,19 +458,27 @@ Documentation Undocumented -`i_h_j `_ +`h_u_0 `_ + Computes v_0 = H|u_0> + .br + n : number of determinants + .br + H_jj : array of + + +`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> @@ -371,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 @@ -392,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 @@ -406,17 +522,10 @@ Documentation to repeat the excitations -`i_h_psi_sec_ord `_ +`i_h_psi_sec_ord `_ for the various Nstates -`i_s2_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. - - `idx_cas `_ 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. @@ -428,15 +537,11 @@ Documentation idx_non_cas gives the indice of the determinant in psi_det. -`is_connected_to `_ +`is_connected_to `_ Undocumented -`is_connected_to_by_mono `_ - Undocumented - - -`is_generable_cassd `_ +`is_connected_to_by_mono `_ Undocumented @@ -452,7 +557,7 @@ Documentation Undocumented -`max_degree_exc `_ +`max_degree_exc `_ Maximum degree of excitation in the wf @@ -468,7 +573,7 @@ Documentation Undocumented -`n_det `_ +`n_det `_ Number of determinants in the wave function @@ -493,7 +598,7 @@ Documentation 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 @@ -525,6 +630,10 @@ Documentation Number of states to consider +`n_states_diag `_ + 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 @@ -587,15 +696,15 @@ Documentation 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 -`psi_average_norm_contrib `_ +`psi_average_norm_contrib `_ Contribution of determinants to the state-averaged density -`psi_average_norm_contrib_sorted `_ +`psi_average_norm_contrib_sorted `_ Wave function sorted by determinants contribution to the norm (state-averaged) @@ -647,7 +756,7 @@ Documentation function. -`psi_coef `_ +`psi_coef `_ The wave function coefficients. Initialized with Hartree-Fock if the EZFIO file is empty @@ -656,26 +765,26 @@ 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 -`psi_coef_sorted `_ +`psi_coef_sorted `_ Wave function sorted by determinants contribution to the norm (state-averaged) -`psi_coef_sorted_bit `_ +`psi_coef_sorted_bit `_ Determinants on which we apply for perturbation. They are sorted by determinants interpreted as integers. Useful to accelerate the search of a random determinant in the wave function. -`psi_det `_ +`psi_det `_ The wave function determinants. Initialized with Hartree-Fock if the EZFIO file is empty @@ -696,15 +805,15 @@ Documentation Unique beta determinants -`psi_det_size `_ +`psi_det_size `_ Size of the psi_det/psi_coef arrays -`psi_det_sorted `_ +`psi_det_sorted `_ Wave function sorted by determinants contribution to the norm (state-averaged) -`psi_det_sorted_bit `_ +`psi_det_sorted_bit `_ Determinants on which we apply for perturbation. They are sorted by determinants interpreted as integers. Useful to accelerate the search of a random determinant in the wave @@ -751,7 +860,7 @@ Documentation Undocumented -`read_dets `_ +`read_dets `_ Reads the determinants from the EZFIO file @@ -776,25 +885,11 @@ Documentation be set before calling this function. -`s2_eig `_ +`s2_eig `_ Force the wave function to be an eigenfunction of S^2 -`s2_u_0 `_ - Computes v_0 = S^2|u_0> - .br - n : number of determinants - .br - - -`s2_u_0_nstates `_ - Computes v_0 = S^2|u_0> - .br - n : number of determinants - .br - - -`s2_values `_ +`s2_values `_ array of the averaged values of the S^2 operator on the various states @@ -818,23 +913,23 @@ Documentation Save natural orbitals, obtained by diagonalization of the one-body density matrix in the MO basis -`save_ref_determinant `_ +`save_ref_determinant `_ Undocumented -`save_wavefunction `_ +`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 @@ -852,25 +947,49 @@ Documentation for a given couple of hole/particle excitations i. -`sort_dets_by_det_search_key `_ +`sort_dets_ab `_ + Uncodumented : TODO + + +`sort_dets_ab_v `_ + Uncodumented : TODO + + +`sort_dets_ba_v `_ + Uncodumented : TODO + + +`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 function. `spin_det_search_key `_ - Return an integer(8) corresponding to a determinant index for searching + Return an integer*8 corresponding to a determinant index for searching `state_average_weight `_ Weights in the state-average calculation of the density matrix -`target_energy `_ +`tamiser `_ + Uncodumented : TODO + + +`target_energy `_ Energy that should be obtained when truncating the wave function (optional) -`threshold_generators `_ +`threshold_convergence_sc2 `_ + convergence of the correlation energy of SC2 iterations + + +`threshold_davidson `_ + Thresholds of Davidson's algorithm + + +`threshold_generators `_ Thresholds on generators (fraction of the norm) @@ -878,8 +997,8 @@ Documentation Thresholds on selectors (fraction of the norm) -`u_0_s2_u_0 `_ - Computes e_0 = / +`u0_h_u_0 `_ + Computes e_0 = / .br n : number of determinants .br diff --git a/src/Determinants/create_excitations.irp.f b/src/Determinants/create_excitations.irp.f index 71301dbc..b7233beb 100644 --- a/src/Determinants/create_excitations.irp.f +++ b/src/Determinants/create_excitations.irp.f @@ -31,78 +31,10 @@ subroutine do_mono_excitation(key_in,i_hole,i_particle,ispin,i_ok) n_elec_tmp += popcnt(key_in(i,1)) + popcnt(key_in(i,2)) enddo if(n_elec_tmp .ne. elec_num)then - !print*, n_elec_tmp,elec_num - !call debug_det(key_in,N_int) i_ok = -1 endif end -subroutine do_spin_flip(key_in,i_flip,ispin,i_ok) - implicit none - BEGIN_DOC - ! flip the spin ispin in the orbital i_flip - ! on key_in - ! ispin = 1 == alpha - ! ispin = 2 == beta - ! i_ok = 1 == the flip is possible - ! i_ok = -1 == the flip is not possible - END_DOC - integer, intent(in) :: i_flip,ispin - integer(bit_kind), intent(inout) :: key_in(N_int,2) - integer, intent(out) :: i_ok - integer :: k,j,i - integer(bit_kind) :: key_tmp(N_int,2) - i_ok = -1 - key_tmp = 0_bit_kind - k = ishft(i_flip-1,-bit_kind_shift)+1 - j = i_flip-ishft(k-1,bit_kind_shift)-1 - key_tmp(k,1) = ibset(key_tmp(k,1),j) - integer :: other_spin(2) - other_spin(1) = 2 - other_spin(2) = 1 - if(popcnt(iand(key_tmp(k,1),key_in(k,ispin))) == 1 .and. popcnt(iand(key_tmp(k,1),key_in(k,other_spin(ispin)))) == 0 )then - ! There is a spin "ispin" in the orbital i_flip AND There is no electron of opposit spin in the same orbital "i_flip" - key_in(k,ispin) = ibclr(key_in(k,ispin),j) ! destroy the electron ispin in the orbital i_flip - key_in(k,other_spin(ispin)) = ibset(key_in(k,other_spin(ispin)),j) ! create an electron of spin other_spin in the same orbital - i_ok = 1 - else - return - endif - - - -end - -logical function is_spin_flip_possible(key_in,i_flip,ispin) - implicit none - BEGIN_DOC - ! returns .True. if the spin-flip of spin ispin in the orbital i_flip is possible - ! on key_in - END_DOC - integer, intent(in) :: i_flip,ispin - integer(bit_kind), intent(in) :: key_in(N_int,2) - integer :: k,j,i - integer(bit_kind) :: key_tmp(N_int,2) - is_spin_flip_possible = .False. - key_tmp = 0_bit_kind - k = ishft(i_flip-1,-bit_kind_shift)+1 - j = i_flip-ishft(k-1,bit_kind_shift)-1 - key_tmp(k,1) = ibset(key_tmp(k,1),j) - integer :: other_spin(2) - other_spin(1) = 2 - other_spin(2) = 1 - if(popcnt(iand(key_tmp(k,1),key_in(k,ispin))) == 1 .and. popcnt(iand(key_tmp(k,1),key_in(k,other_spin(ispin)))) == 0 )then - ! There is a spin "ispin" in the orbital i_flip AND There is no electron of opposit spin in the same orbital "i_flip" - is_spin_flip_possible = .True. - return - else - return - endif - - - -end - subroutine set_bit_to_integer(i_physical,key,Nint) use bitmasks implicit none @@ -113,16 +45,3 @@ subroutine set_bit_to_integer(i_physical,key,Nint) j = i_physical-ishft(k-1,bit_kind_shift)-1 key(k) = ibset(key(k),j) end - - -subroutine clear_bit_to_integer(i_physical,key,Nint) - use bitmasks - implicit none - integer, intent(in) :: i_physical,Nint - integer(bit_kind), intent(inout) :: key(Nint) - integer :: k,j,i - k = ishft(i_physical-1,-bit_kind_shift)+1 - j = i_physical-ishft(k-1,bit_kind_shift)-1 - key(k) = ibclr(key(k),j) -end - diff --git a/src/Determinants/density_matrix.irp.f b/src/Determinants/density_matrix.irp.f index 118bbdf7..62d09381 100644 --- a/src/Determinants/density_matrix.irp.f +++ b/src/Determinants/density_matrix.irp.f @@ -1,22 +1,5 @@ - BEGIN_PROVIDER [ double precision, one_body_dm_mo_alpha_average, (mo_tot_num_align,mo_tot_num) ] -&BEGIN_PROVIDER [ double precision, one_body_dm_mo_beta_average, (mo_tot_num_align,mo_tot_num) ] - implicit none - BEGIN_DOC - ! Alpha and beta one-body density matrix for each state - END_DOC - - integer :: i - - one_body_dm_mo_alpha_average = 0.d0 - one_body_dm_mo_beta_average = 0.d0 - do i = 1,N_states - one_body_dm_mo_alpha_average(:,:) += one_body_dm_mo_alpha(:,:,i) * state_average_weight(i) - one_body_dm_mo_beta_average(:,:) += one_body_dm_mo_beta(:,:,i) * state_average_weight(i) - enddo -END_PROVIDER - - BEGIN_PROVIDER [ double precision, one_body_dm_mo_alpha, (mo_tot_num_align,mo_tot_num,N_states) ] -&BEGIN_PROVIDER [ double precision, one_body_dm_mo_beta, (mo_tot_num_align,mo_tot_num,N_states) ] + BEGIN_PROVIDER [ double precision, one_body_dm_mo_alpha, (mo_tot_num_align,mo_tot_num) ] +&BEGIN_PROVIDER [ double precision, one_body_dm_mo_beta, (mo_tot_num_align,mo_tot_num) ] implicit none BEGIN_DOC ! Alpha and beta one-body density matrix for each state @@ -28,31 +11,36 @@ END_PROVIDER double precision :: phase integer :: h1,h2,p1,p2,s1,s2, degree integer :: exc(0:2,2,2),n_occ(2) - double precision, allocatable :: tmp_a(:,:,:), tmp_b(:,:,:) + double precision, allocatable :: tmp_a(:,:), tmp_b(:,:) + if(only_single_double_dm)then + print*,'ONLY DOUBLE DM' + one_body_dm_mo_alpha = one_body_single_double_dm_mo_alpha + one_body_dm_mo_beta = one_body_single_double_dm_mo_beta + else one_body_dm_mo_alpha = 0.d0 one_body_dm_mo_beta = 0.d0 !$OMP PARALLEL DEFAULT(NONE) & !$OMP PRIVATE(j,k,l,m,occ,ck, cl, ckl,phase,h1,h2,p1,p2,s1,s2, degree,exc, & !$OMP tmp_a, tmp_b, n_occ)& - !$OMP SHARED(psi_det,psi_coef,N_int,N_states,elec_alpha_num,& + !$OMP SHARED(psi_det,psi_coef,N_int,N_states,state_average_weight,elec_alpha_num,& !$OMP elec_beta_num,one_body_dm_mo_alpha,one_body_dm_mo_beta,N_det,mo_tot_num_align,& !$OMP mo_tot_num) - allocate(tmp_a(mo_tot_num_align,mo_tot_num,N_states), tmp_b(mo_tot_num_align,mo_tot_num,N_states) ) + allocate(tmp_a(mo_tot_num_align,mo_tot_num), tmp_b(mo_tot_num_align,mo_tot_num) ) tmp_a = 0.d0 tmp_b = 0.d0 !$OMP DO SCHEDULE(dynamic) do k=1,N_det call bitstring_to_list_ab(psi_det(1,1,k), occ, n_occ, N_int) do m=1,N_states - ck = psi_coef(k,m)*psi_coef(k,m) + ck = psi_coef(k,m)*psi_coef(k,m) * state_average_weight(m) do l=1,elec_alpha_num j = occ(l,1) - tmp_a(j,j,m) += ck + tmp_a(j,j) += ck enddo do l=1,elec_beta_num j = occ(l,2) - tmp_b(j,j,m) += ck + tmp_b(j,j) += ck enddo enddo do l=1,k-1 @@ -63,27 +51,28 @@ END_PROVIDER call get_mono_excitation(psi_det(1,1,k),psi_det(1,1,l),exc,phase,N_int) call decode_exc(exc,degree,h1,p1,h2,p2,s1,s2) do m=1,N_states - ckl = psi_coef(k,m) * psi_coef(l,m) * phase + ckl = psi_coef(k,m) * psi_coef(l,m) * phase * state_average_weight(m) if (s1==1) then - tmp_a(h1,p1,m) += ckl - tmp_a(p1,h1,m) += ckl + tmp_a(h1,p1) += ckl + tmp_a(p1,h1) += ckl else - tmp_b(h1,p1,m) += ckl - tmp_b(p1,h1,m) += ckl + tmp_b(h1,p1) += ckl + tmp_b(p1,h1) += ckl endif enddo enddo enddo !$OMP END DO NOWAIT !$OMP CRITICAL - one_body_dm_mo_alpha(:,:,:) = one_body_dm_mo_alpha(:,:,:) + tmp_a(:,:,:) + one_body_dm_mo_alpha = one_body_dm_mo_alpha + tmp_a !$OMP END CRITICAL !$OMP CRITICAL - one_body_dm_mo_beta(:,:,:) = one_body_dm_mo_beta(:,:,:) + tmp_b(:,:,:) + one_body_dm_mo_beta = one_body_dm_mo_beta + tmp_b !$OMP END CRITICAL deallocate(tmp_a,tmp_b) !$OMP END PARALLEL + endif END_PROVIDER BEGIN_PROVIDER [ double precision, one_body_single_double_dm_mo_alpha, (mo_tot_num_align,mo_tot_num) ] @@ -174,7 +163,7 @@ BEGIN_PROVIDER [ double precision, one_body_dm_mo, (mo_tot_num_align,mo_tot_num) BEGIN_DOC ! One-body density matrix END_DOC - one_body_dm_mo = one_body_dm_mo_alpha_average + one_body_dm_mo_beta_average + one_body_dm_mo = one_body_dm_mo_alpha + one_body_dm_mo_beta END_PROVIDER BEGIN_PROVIDER [ double precision, one_body_spin_density_mo, (mo_tot_num_align,mo_tot_num) ] @@ -182,7 +171,7 @@ BEGIN_PROVIDER [ double precision, one_body_spin_density_mo, (mo_tot_num_align,m BEGIN_DOC ! rho(alpha) - rho(beta) END_DOC - one_body_spin_density_mo = one_body_dm_mo_alpha_average - one_body_dm_mo_beta_average + one_body_spin_density_mo = one_body_dm_mo_alpha - one_body_dm_mo_beta END_PROVIDER subroutine set_natural_mos @@ -249,19 +238,17 @@ END_PROVIDER END_DOC implicit none integer :: i,j,k,l - double precision :: mo_alpha,mo_beta + double precision :: dm_mo - one_body_dm_ao_alpha = 0.d0 - one_body_dm_ao_beta = 0.d0 + one_body_spin_density_ao = 0.d0 do k = 1, ao_num do l = 1, ao_num do i = 1, mo_tot_num do j = 1, mo_tot_num - mo_alpha = one_body_dm_mo_alpha_average(j,i) - mo_beta = one_body_dm_mo_beta_average(j,i) + dm_mo = one_body_dm_mo_alpha(j,i) ! if(dabs(dm_mo).le.1.d-10)cycle - one_body_dm_ao_alpha(l,k) += mo_coef(k,i) * mo_coef(l,j) * mo_alpha - one_body_dm_ao_beta(l,k) += mo_coef(k,i) * mo_coef(l,j) * mo_beta + one_body_dm_ao_alpha(l,k) += mo_coef(k,i) * mo_coef(l,j) * dm_mo + one_body_dm_ao_beta(l,k) += mo_coef(k,i) * mo_coef(l,j) * dm_mo enddo enddo diff --git a/src/Determinants/determinants.irp.f b/src/Determinants/determinants.irp.f index bed3327d..39b0f58e 100644 --- a/src/Determinants/determinants.irp.f +++ b/src/Determinants/determinants.irp.f @@ -438,12 +438,8 @@ end do i=1,N_states psi_coef_min(i) = minval(psi_coef(:,i)) psi_coef_max(i) = maxval(psi_coef(:,i)) - abs_psi_coef_min(i) = minval( dabs(psi_coef(:,i)) ) - abs_psi_coef_max(i) = maxval( dabs(psi_coef(:,i)) ) - call write_double(6,psi_coef_max(i), 'Max coef') - call write_double(6,psi_coef_min(i), 'Min coef') - call write_double(6,abs_psi_coef_max(i), 'Max abs coef') - call write_double(6,abs_psi_coef_min(i), 'Min abs coef') + abs_psi_coef_min(i) = dabs(psi_coef_min(i)) + abs_psi_coef_max(i) = dabs(psi_coef_max(i)) enddo END_PROVIDER @@ -764,85 +760,37 @@ subroutine apply_excitation(det, exc, res, ok, Nint) ok = .false. degree = exc(0,1,1) + exc(0,1,2) -! call decode_exc(exc,degree,h1,p1,h2,p2,s1,s2) -! INLINE - 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 - case default - print *, degree - print *, "apply ex" - STOP - end select -! END INLINE - + 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 = ishft(h1-1,-bit_kind_shift) + 1 - pos = h1-1-ishft(ii-1,bit_kind_shift) - if(iand(det(ii, s1), ibset(0_bit_kind, pos)) == 0_8) return + 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 = ishft(p1-1,-bit_kind_shift) + 1 - pos = p1-1-ishft(ii-1,bit_kind_shift) + 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 = ishft(h2-1,-bit_kind_shift) + 1 - pos = h2-1-ishft(ii-1,bit_kind_shift) + 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 = ishft(p2-1,-bit_kind_shift) + 1 - pos = p2-1-ishft(ii-1,bit_kind_shift) + 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 @@ -861,14 +809,14 @@ subroutine apply_particles(det, s1, p1, s2, p2, res, ok, Nint) res = det if(p1 /= 0) then - ii = ishft(p1-1,-bit_kind_shift) + 1 - pos = p1-1-ishft(ii-1,bit_kind_shift) + 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 = ishft(p2-1,-bit_kind_shift) + 1 - pos = p2-1-ishft(ii-1,bit_kind_shift) + 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) @@ -890,14 +838,14 @@ subroutine apply_holes(det, s1, h1, s2, h2, res, ok, Nint) res = det if(h1 /= 0) then - ii = ishft(h1-1,-bit_kind_shift) + 1 - pos = h1-1-ishft(ii-1,bit_kind_shift) + 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 = ishft(h2-1,-bit_kind_shift) + 1 - pos = h2-1-ishft(ii-1,bit_kind_shift) + 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) @@ -917,8 +865,8 @@ subroutine apply_particle(det, s1, p1, res, ok, Nint) ok = .false. res = det - ii = ishft(p1-1,-bit_kind_shift) + 1 - pos = p1-1-ishft(ii-1,bit_kind_shift) + 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) @@ -939,8 +887,8 @@ subroutine apply_hole(det, s1, h1, res, ok, Nint) ok = .false. res = det - ii = ishft(h1-1,-bit_kind_shift) + 1 - pos = h1-1-ishft(ii-1,bit_kind_shift) + 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) diff --git a/src/Determinants/diagonalize_restart_and_save_two_states.irp.f b/src/Determinants/diagonalize_restart_and_save_two_states.irp.f deleted file mode 100644 index 97fed531..00000000 --- a/src/Determinants/diagonalize_restart_and_save_two_states.irp.f +++ /dev/null @@ -1,27 +0,0 @@ -program diag_and_save - implicit none - read_wf = .True. - touch read_wf - call routine -end - -subroutine routine - implicit none - integer :: igood_state_1,igood_state_2 - double precision, allocatable :: psi_coef_tmp(:,:) - integer :: i - print*,'N_det = ',N_det -!call diagonalize_CI - write(*,*)'Which couple of states would you like to save ?' - read(5,*)igood_state_1,igood_state_2 - allocate(psi_coef_tmp(n_det,2)) - do i = 1, N_det - psi_coef_tmp(i,1) = psi_coef(i,igood_state_1) - psi_coef_tmp(i,2) = psi_coef(i,igood_state_2) - enddo - call save_wavefunction_general(N_det,2,psi_det,n_det,psi_coef_tmp) - deallocate(psi_coef_tmp) - - - -end diff --git a/src/Determinants/mono_excitations.irp.f b/src/Determinants/mono_excitations.irp.f deleted file mode 100644 index 01af4c25..00000000 --- a/src/Determinants/mono_excitations.irp.f +++ /dev/null @@ -1,154 +0,0 @@ - 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 42bca8eb..af6390e2 100644 --- a/src/Determinants/occ_pattern.irp.f +++ b/src/Determinants/occ_pattern.irp.f @@ -36,7 +36,6 @@ subroutine occ_pattern_to_dets_size(o,sze,n_alpha,Nint) amax -= popcnt( o(k,2) ) enddo sze = int( min(binom_func(bmax, amax), 1.d8) ) - sze = sze*sze end @@ -52,8 +51,8 @@ subroutine occ_pattern_to_dets(o,d,sze,n_alpha,Nint) integer(bit_kind),intent(out) :: d(Nint,2,sze) integer :: i, k, nt, na, nd, amax - integer :: list_todo(2*n_alpha) - integer :: list_a(2*n_alpha) + integer :: list_todo(n_alpha) + integer :: list_a(n_alpha) amax = n_alpha do k=1,Nint @@ -69,25 +68,35 @@ subroutine occ_pattern_to_dets(o,d,sze,n_alpha,Nint) sze = nd - integer :: ne(2), l - l=0 do i=1,nd - ne(1) = 0 - ne(2) = 0 - l=l+1 ! Doubly occupied orbitals do k=1,Nint - d(k,1,l) = ior(d(k,1,i),o(k,2)) - d(k,2,l) = ior(d(k,2,i),o(k,2)) - ne(1) += popcnt(d(k,1,l)) - ne(2) += popcnt(d(k,2,l)) + d(k,1,i) = ior(d(k,1,i),o(k,2)) + d(k,2,i) = ior(d(k,2,i),o(k,2)) enddo - if ( (ne(1) /= elec_alpha_num).or.(ne(2) /= elec_beta_num) ) then - l = l-1 - endif enddo - sze = l +! !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) @@ -135,8 +144,8 @@ end implicit none BEGIN_DOC ! array of the occ_pattern present in the wf - ! psi_occ_pattern(:,1,j) = jth occ_pattern of the wave function : represent all the single occupations - ! psi_occ_pattern(:,2,j) = jth occ_pattern of the wave function : represent all the double occupations + ! psi_occ_pattern(:,1,j) = jth occ_pattern of the wave function : represent all the single occupation + ! psi_occ_pattern(:,2,j) = jth occ_pattern of the wave function : represent all the double occupation END_DOC integer :: i,j,k @@ -156,7 +165,7 @@ end logical,allocatable :: duplicate(:) - allocate ( iorder(N_det), duplicate(N_det), bit_tmp(N_det), tmp_array(N_int,2,N_det) ) + allocate ( iorder(N_det), duplicate(N_det), bit_tmp(N_det), tmp_array(N_int,2,psi_det_size) ) do i=1,N_det iorder(i) = i @@ -173,7 +182,12 @@ end duplicate(i) = .False. enddo - ! Find duplicates + i=1 + integer (bit_kind) :: occ_pattern_tmp + do i=1,N_det + duplicate(i) = .False. + enddo + do i=1,N_det-1 if (duplicate(i)) then cycle @@ -182,9 +196,6 @@ end do while (bit_tmp(j)==bit_tmp(i)) if (duplicate(j)) then j+=1 - if (j>N_det) then - exit - endif cycle endif duplicate(j) = .True. @@ -202,7 +213,6 @@ end enddo enddo - ! Copy filtered result N_occ_pattern=0 do i=1,N_det if (duplicate(i)) then @@ -215,30 +225,27 @@ end enddo enddo -!- Check -! do i=1,N_occ_pattern -! do j=i+1,N_occ_pattern -! duplicate(1) = .True. -! do k=1,N_int -! if (psi_occ_pattern(k,1,i) /= psi_occ_pattern(k,1,j)) then -! duplicate(1) = .False. -! exit -! endif -! if (psi_occ_pattern(k,2,i) /= psi_occ_pattern(k,2,j)) then -! duplicate(1) = .False. -! exit -! endif -! enddo -! if (duplicate(1)) then -! call debug_det(psi_occ_pattern(1,1,i),N_int) -! call debug_det(psi_occ_pattern(1,1,j),N_int) -! stop 'DUPLICATE' -! endif -! enddo -! 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 @@ -249,6 +256,27 @@ subroutine make_s2_eigenfunction integer :: N_det_new integer, parameter :: bufsze = 1000 logical, external :: is_in_wavefunction + return + +! !TODO DEBUG +! do i=1,N_det +! do j=i+1,N_det +! s = 0 +! do k=1,N_int +! if((psi_det(k,1,j) /= psi_det(k,1,i)).or. & +! (psi_det(k,2,j) /= psi_det(k,2,i))) then +! s=1 +! exit +! endif +! enddo +! if ( s == 0 ) then +! print *, 'Error0: det ', j, 'already in wf' +! call debug_det(psi_det(1,1,j),N_int) +! stop +! endif +! enddo +! enddo +! !TODO DEBUG allocate (d(N_int,2,1), det_buffer(N_int,2,bufsze) ) smax = 1 @@ -270,20 +298,6 @@ subroutine make_s2_eigenfunction det_buffer(k,1,N_det_new) = d(k,1,j) det_buffer(k,2,N_det_new) = d(k,2,j) enddo -! integer :: ne(2) -! ne(:) = 0 -! do k=1,N_int -! ne(1) += popcnt(d(k,1,j)) -! ne(2) += popcnt(d(k,2,j)) -! enddo -! if (ne(1) /= elec_alpha_num) then -! call debug_det(d(1,1,j),N_int) -! stop "ALPHA" -! endif -! if (ne(2) /= elec_beta_num) then -! call debug_det(d(1,1,j),N_int) -! stop "BETA" -! endif if (N_det_new == bufsze) then call fill_H_apply_buffer_no_selection(bufsze,det_buffer,N_int,0) N_det_new = 0 @@ -294,17 +308,33 @@ subroutine make_s2_eigenfunction if (N_det_new > 0) then call fill_H_apply_buffer_no_selection(N_det_new,det_buffer,N_int,0) -! call fill_H_apply_buffer_no_selection_first_order_coef(N_det_new,det_buffer,N_int,0) + call copy_H_apply_buffer_to_wf + SOFT_TOUCH N_det psi_coef psi_det endif deallocate(d,det_buffer) - call copy_H_apply_buffer_to_wf - SOFT_TOUCH N_det psi_coef psi_det - print *, 'Added determinants for S^2' -! logical :: found -! call remove_duplicates_in_psi_det(found) + +! !TODO DEBUG +! do i=1,N_det +! do j=i+1,N_det +! s = 0 +! do k=1,N_int +! if((psi_det(k,1,j) /= psi_det(k,1,i)).or. & +! (psi_det(k,2,j) /= psi_det(k,2,i))) then +! s=1 +! exit +! endif +! enddo +! if ( s == 0 ) then +! print *, 'Error : det ', j, 'already in wf at ', i +! call debug_det(psi_det(1,1,j),N_int) +! stop +! endif +! enddo +! enddo +! !TODO DEBUG + call write_int(output_determinants,N_det_new, 'Added determinants for S^2') end - diff --git a/src/Determinants/print_bitmask.irp.f b/src/Determinants/print_bitmask.irp.f deleted file mode 100644 index 2f1c8f73..00000000 --- a/src/Determinants/print_bitmask.irp.f +++ /dev/null @@ -1,11 +0,0 @@ -program print_bitmask - implicit none - print*,'core' - call debug_det(core_bitmask,N_int) - print*,'inact' - call debug_det(inact_bitmask,N_int) - print*,'virt' - call debug_det(virt_bitmask,N_int) - - -end diff --git a/src/Determinants/print_holes_particles.irp.f b/src/Determinants/print_holes_particles.irp.f deleted file mode 100644 index 601015f7..00000000 --- a/src/Determinants/print_holes_particles.irp.f +++ /dev/null @@ -1,36 +0,0 @@ -program pouet - implicit none - read_wf = .True. - touch read_wf - call routine -end - -subroutine routine - implicit none - integer :: i,j,number_of_holes,number_of_particles - integer :: n_h,n_p - do i = 1, N_det - n_h = number_of_holes(psi_det(1,1,i)) - n_p = number_of_particles(psi_det(1,1,i)) - if(n_h == 0 .and. n_p == 0)then - print*,'CAS' - else if(n_h == 1 .and. n_p ==0)then - print*,'1h' - else if(n_h == 0 .and. n_p ==1)then - print*,'1p' - else if(n_h == 1 .and. n_p ==1)then - print*,'1h1p' - else if(n_h == 2 .and. n_p ==1)then - print*,'2h1p' - else if(n_h == 1 .and. n_p ==2)then - print*,'1h2p' - else - print*,'PB !! ' - call debug_det(psi_det(1,1,i), N_int) - stop - endif - enddo - - - -end diff --git a/src/Determinants/print_wf.irp.f b/src/Determinants/print_wf.irp.f deleted file mode 100644 index af109e2d..00000000 --- a/src/Determinants/print_wf.irp.f +++ /dev/null @@ -1,71 +0,0 @@ -program printwf - implicit none - read_wf = .True. - touch read_wf - print*,'ref_bitmask_energy = ',ref_bitmask_energy - call routine - -end - -subroutine routine - implicit none - integer :: i - integer :: degree - double precision :: hij - integer :: exc(0:2,2,2) - double precision :: phase - integer :: h1,p1,h2,p2,s1,s2 - double precision :: get_mo_bielec_integral - double precision :: norm_mono_a,norm_mono_b - norm_mono_a = 0.d0 - norm_mono_b = 0.d0 - do i = 1, min(500,N_det) - print*,'' - print*,'i = ',i - call debug_det(psi_det(1,1,i),N_int) - call get_excitation_degree(psi_det(1,1,i),psi_det(1,1,1),degree,N_int) - print*,'degree = ',degree - if(degree == 0)then - print*,'Reference determinant ' - else - call i_H_j(psi_det(1,1,i),psi_det(1,1,1),N_int,hij) - call get_excitation(psi_det(1,1,1),psi_det(1,1,i),exc,degree,phase,N_int) - call decode_exc(exc,degree,h1,p1,h2,p2,s1,s2) - print*,'phase = ',phase - if(degree == 1)then - print*,'s1',s1 - print*,'h1,p1 = ',h1,p1 - if(s1 == 1)then - norm_mono_a += dabs(psi_coef(i,1)/psi_coef(1,1)) - else - norm_mono_b += dabs(psi_coef(i,1)/psi_coef(1,1)) - endif - 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 - print*,'hdouble = ',hdouble - print*,'hmono+hdouble = ',hmono+hdouble - print*,'hij = ',hij - else - print*,'s1',s1 - print*,'h1,p1 = ',h1,p1 - print*,'s2',s2 - print*,'h2,p2 = ',h2,p2 - print*,'< h | Ka| p > = ',get_mo_bielec_integral(h1,h2,p1,p2,mo_integrals_map) - endif - - print*,' = ',hij - endif - print*,'amplitude = ',psi_coef(i,1)/psi_coef(1,1) - - enddo - - - print*,'' - print*,'' - print*,'' - print*,'mono alpha = ',norm_mono_a - print*,'mono beta = ',norm_mono_b - -end diff --git a/src/Determinants/s2.irp.f b/src/Determinants/s2.irp.f index 7e62befb..c6bb8390 100644 --- a/src/Determinants/s2.irp.f +++ b/src/Determinants/s2.irp.f @@ -1,36 +1,36 @@ subroutine get_s2(key_i,key_j,Nint,s2) - implicit none - use bitmasks - BEGIN_DOC - ! Returns - END_DOC - integer, intent(in) :: Nint - integer(bit_kind), intent(in) :: key_i(Nint,2) - integer(bit_kind), intent(in) :: key_j(Nint,2) - double precision, intent(out) :: s2 - integer :: exc(0:2,2,2) - integer :: degree - double precision :: phase_spsm - integer :: nup, i - - s2 = 0.d0 - !$FORCEINLINE - call get_excitation_degree(key_i,key_j,degree,Nint) - select case (degree) - case(2) - call get_double_excitation(key_j,key_i,exc,phase_spsm,Nint) - if (exc(0,1,1) == 1) then ! Mono alpha + mono-beta - if ( (exc(1,1,1) == exc(1,2,2)).and.(exc(1,1,2) == exc(1,2,1)) ) then - s2 = -phase_spsm - endif - endif - case(0) + implicit none + use bitmasks + BEGIN_DOC +! Returns + END_DOC + integer, intent(in) :: Nint + integer(bit_kind), intent(in) :: key_i(Nint,2) + integer(bit_kind), intent(in) :: key_j(Nint,2) + double precision, intent(out) :: s2 + integer :: exc(0:2,2,2) + integer :: degree + double precision :: phase_spsm + integer :: nup, i + + s2 = 0.d0 + !$FORCEINLINE + call get_excitation_degree(key_i,key_j,degree,Nint) + select case (degree) + case(2) + call get_double_excitation(key_j,key_i,exc,phase_spsm,Nint) + if (exc(0,1,1) == 1) then ! Mono alpha + mono-beta + if ( (exc(1,1,1) == exc(1,2,2)).and.(exc(1,1,2) == exc(1,2,1)) ) then + s2 = -phase_spsm + endif + endif + case(0) nup = 0 do i=1,Nint nup += popcnt(iand(xor(key_i(i,1),key_i(i,2)),key_i(i,1))) enddo s2 = dble(nup) - end select + end select end BEGIN_PROVIDER [ double precision, S_z ] diff --git a/src/Determinants/save_only_singles.irp.f b/src/Determinants/save_only_singles.irp.f deleted file mode 100644 index ae68a52c..00000000 --- a/src/Determinants/save_only_singles.irp.f +++ /dev/null @@ -1,50 +0,0 @@ -program save_only_singles - implicit none - read_wf = .True. - touch read_wf - call routine -end - -subroutine routine - implicit none - integer :: i,j,k,l - use bitmasks - integer :: n_det_restart,degree - integer(bit_kind),allocatable :: psi_det_tmp(:,:,:) - double precision ,allocatable :: psi_coef_tmp(:,:),accu(:) - integer, allocatable :: index_restart(:) - allocate(index_restart(N_det)) - N_det_restart = 0 - do i = 1, N_det - call get_excitation_degree(psi_det(1,1,1),psi_det(1,1,i),degree,N_int) - if(degree == 0 .or. degree==1)then - N_det_restart +=1 - index_restart(N_det_restart) = i - cycle - endif - enddo - allocate (psi_det_tmp(N_int,2,N_det_restart),psi_coef_tmp(N_det_restart,N_states),accu(N_states)) - accu = 0.d0 - do i = 1, N_det_restart - do j = 1, N_int - psi_det_tmp(j,1,i) = psi_det(j,1,index_restart(i)) - psi_det_tmp(j,2,i) = psi_det(j,2,index_restart(i)) - enddo - do j = 1,N_states - psi_coef_tmp(i,j) = psi_coef(index_restart(i),j) - accu(j) += psi_coef_tmp(i,j) * psi_coef_tmp(i,j) - enddo - enddo - do j = 1, N_states - accu(j) = 1.d0/dsqrt(accu(j)) - enddo - do j = 1,N_states - do i = 1, N_det_restart - psi_coef_tmp(i,j) = psi_coef_tmp(i,j) * accu(j) - enddo - enddo - call save_wavefunction_general(N_det_restart,N_states,psi_det_tmp,N_det_restart,psi_coef_tmp) - - deallocate (psi_det_tmp,psi_coef_tmp,accu,index_restart) - -end diff --git a/src/Determinants/slater_rules.irp.f b/src/Determinants/slater_rules.irp.f index 789dc93c..7df6e79e 100644 --- a/src/Determinants/slater_rules.irp.f +++ b/src/Determinants/slater_rules.irp.f @@ -495,6 +495,8 @@ end + + subroutine i_H_j(key_i,key_j,Nint,hij) use bitmasks implicit none @@ -513,7 +515,7 @@ 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) - PROVIDE mo_bielec_integrals_in_map mo_integrals_map big_array_exchange_integrals + PROVIDE mo_bielec_integrals_in_map mo_integrals_map ASSERT (Nint > 0) ASSERT (Nint == N_int) @@ -525,23 +527,16 @@ subroutine i_H_j(key_i,key_j,Nint,hij) 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 - if(exc(1,1,1) == exc(1,2,2) )then - hij = phase * big_array_exchange_integrals(exc(1,1,1),exc(1,1,2),exc(1,2,1)) - else if (exc(1,2,1) ==exc(1,1,2))then - hij = phase * big_array_exchange_integrals(exc(1,2,1),exc(1,1,1),exc(1,2,2)) - else - 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) - endif + 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( & @@ -575,14 +570,27 @@ subroutine i_H_j(key_i,key_j,Nint,hij) ! Mono alpha m = exc(1,1,1) p = exc(1,2,1) - spin = 1 + do k = 1, elec_alpha_num + hij = hij + mo_bielec_integral_mipi_anti(occ(k,1),m,p) + enddo + do k = 1, elec_beta_num + hij = hij + mo_bielec_integral_mipi(occ(k,2),m,p) + enddo + else ! Mono beta m = exc(1,1,2) p = exc(1,2,2) - spin = 2 + + do k = 1, elec_alpha_num + hij = hij + mo_bielec_integral_mipi(occ(k,1),m,p) + enddo + do k = 1, elec_beta_num + hij = hij + mo_bielec_integral_mipi_anti(occ(k,2),m,p) + enddo + endif - call get_mono_excitation_from_fock(key_i,key_j,p,m,spin,phase,hij) + hij = phase*(hij + mo_mono_elec_integral(m,p)) case (0) hij = diag_H_mat_elem(key_i,Nint) @@ -609,8 +617,6 @@ subroutine i_H_j_phase_out(key_i,key_j,Nint,hij,phase,exc,degree) integer :: occ(Nint*bit_kind_size,2) double precision :: diag_H_mat_elem 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) @@ -662,59 +668,27 @@ subroutine i_H_j_phase_out(key_i,key_j,Nint,hij,phase,exc,degree) 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) 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 + hij = hij + mo_bielec_integral_mipi_anti(occ(k,1),m,p) 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 + hij = hij + mo_bielec_integral_mipi(occ(k,2),m,p) 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) - 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)) + hij = hij + mo_bielec_integral_mipi(occ(k,1),m,p) enddo do k = 1, elec_beta_num - hij = hij + mipi(occ(k,2)) - miip(occ(k,2)) + hij = hij + mo_bielec_integral_mipi_anti(occ(k,2),m,p) enddo endif @@ -745,8 +719,6 @@ subroutine i_H_j_verbose(key_i,key_j,Nint,hij,hmono,hdouble) 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) @@ -771,11 +743,8 @@ subroutine i_H_j_verbose(key_i,key_j,Nint,hij,hmono,hdouble) exc(1,1,2), & exc(1,2,1), & exc(1,2,2) ,mo_integrals_map) - print*, 'hij verbose ',hij * phase - print*, 'phase verbose',phase else if (exc(0,1,1) == 2) then ! Double alpha - print*,'phase hij = ',phase hij = phase*(get_mo_bielec_integral( & exc(1,1,1), & exc(2,1,1), & @@ -786,31 +755,8 @@ subroutine i_H_j_verbose(key_i,key_j,Nint,hij,hmono,hdouble) exc(2,1,1), & exc(2,2,1), & exc(1,2,1) ,mo_integrals_map) ) - print*,get_mo_bielec_integral( & - exc(1,1,1), & - exc(2,1,1), & - exc(1,2,1), & - exc(2,2,1) ,mo_integrals_map) - print*,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 - print*,'phase hij = ',phase - print*, get_mo_bielec_integral( & - exc(1,1,2), & - exc(2,1,2), & - exc(1,2,2), & - exc(2,2,2) ,mo_integrals_map ) - print*, get_mo_bielec_integral( & - exc(1,1,2), & - exc(2,1,2), & - exc(2,2,2), & - exc(1,2,2) ,mo_integrals_map) - hij = phase*(get_mo_bielec_integral( & exc(1,1,2), & exc(2,1,2), & @@ -826,59 +772,26 @@ subroutine i_H_j_verbose(key_i,key_j,Nint,hij,hmono,hdouble) 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) 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 + hdouble = hdouble + mo_bielec_integral_mipi_anti(occ(k,1),m,p) 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 - hdouble = hdouble + mipi(occ(k,1)) - miip(occ(k,1)) - enddo - do k = 1, elec_beta_num - hdouble = hdouble + mipi(occ(k,2)) + hdouble = hdouble + mo_bielec_integral_mipi(occ(k,2),m,p) enddo else ! Mono beta m = exc(1,1,2) p = exc(1,2,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 - hdouble = hdouble + mipi(occ(k,1)) + hdouble = hdouble + mo_bielec_integral_mipi(occ(k,1),m,p) enddo do k = 1, elec_beta_num - hdouble = hdouble + mipi(occ(k,2)) - miip(occ(k,2)) + hdouble = hdouble + mo_bielec_integral_mipi_anti(occ(k,2),m,p) enddo endif @@ -889,6 +802,8 @@ 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 @@ -1132,7 +1047,6 @@ subroutine i_H_psi_minilist(key,keys,idx_key,N_minilist,coef,Nint,Ndet,Ndet_max, end - subroutine i_H_psi_sec_ord(key,keys,coef,Nint,Ndet,Ndet_max,Nstate,i_H_psi_array,idx_interaction,interactions) use bitmasks implicit none @@ -1281,433 +1195,6 @@ subroutine i_H_psi_SC2_verbose(key,keys,coef,Nint,Ndet,Ndet_max,Nstate,i_H_psi_a print*,'------' end -subroutine get_excitation_degree_vector_mono(key1,key2,degree,Nint,sze,idx) - use bitmasks - implicit none - BEGIN_DOC - ! Applies get_excitation_degree to an array of determinants and return only the mono excitations - END_DOC - integer, intent(in) :: Nint, sze - integer(bit_kind), intent(in) :: key1(Nint,2,sze) - integer(bit_kind), intent(in) :: key2(Nint,2) - integer, intent(out) :: degree(sze) - integer, intent(out) :: idx(0:sze) - - integer :: i,l,d,m - - ASSERT (Nint > 0) - ASSERT (sze > 0) - - 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))) - if (d > 2) then - cycle - else - degree(l) = ishft(d,-1) - idx(l) = i - l = l+1 - endif - enddo - - 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))) + & - popcnt(xor( key1(2,1,i), key2(2,1))) + & - popcnt(xor( key1(2,2,i), key2(2,2))) - if (d > 2) then - cycle - else - degree(l) = ishft(d,-1) - idx(l) = i - l = l+1 - endif - enddo - - 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))) + & - popcnt(xor( key1(2,1,i), key2(2,1))) + & - popcnt(xor( key1(2,2,i), key2(2,2))) + & - popcnt(xor( key1(3,1,i), key2(3,1))) + & - popcnt(xor( key1(3,2,i), key2(3,2))) - if (d > 2) then - cycle - else - degree(l) = ishft(d,-1) - idx(l) = i - l = l+1 - endif - enddo - - 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))) - enddo - if (d > 2) then - cycle - else - degree(l) = ishft(d,-1) - idx(l) = i - l = l+1 - endif - enddo - - endif - idx(0) = l-1 -end - -subroutine get_excitation_degree_vector_mono_or_exchange(key1,key2,degree,Nint,sze,idx) - use bitmasks - implicit none - BEGIN_DOC - ! Applies get_excitation_degree to an array of determinants and return only the mono excitations - ! and the connections through exchange integrals - END_DOC - integer, intent(in) :: Nint, sze - integer(bit_kind), intent(in) :: key1(Nint,2,sze) - integer(bit_kind), intent(in) :: key2(Nint,2) - integer, intent(out) :: degree(sze) - integer, intent(out) :: idx(0:sze) - integer(bit_kind) :: key_tmp(Nint,2) - - integer :: i,l,d,m - integer :: exchange_1,exchange_2 - - ASSERT (Nint > 0) - ASSERT (sze > 0) - - 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))) - key_tmp(1,1) = xor(key1(1,1,i),key2(1,1)) - key_tmp(1,2) = xor(key1(1,2,i),key2(1,2)) - if(popcnt(key_tmp(1,1)) .gt.3 .or. popcnt(key_tmp(1,2)) .gt.3 )cycle !! no double excitations of same spin - if (d > 4)cycle - if (d ==4)then - if(popcnt(xor(key_tmp(1,1),key_tmp(1,2))) == 0)then - degree(l) = ishft(d,-1) - idx(l) = i - l = l+1 - else - cycle - endif -! pause - else - degree(l) = ishft(d,-1) - idx(l) = i - l = l+1 - endif - enddo - else - - print*, 'get_excitation_degree_vector_mono_or_exchange not yet implemented for N_int > 1 ...' - stop - - endif - idx(0) = l-1 -end - - - - -subroutine get_excitation_degree_vector_double_alpha_beta(key1,key2,degree,Nint,sze,idx) - use bitmasks - implicit none - BEGIN_DOC - ! Applies get_excitation_degree to an array of determinants and return only the mono excitations - ! and the connections through exchange integrals - END_DOC - integer, intent(in) :: Nint, sze - integer(bit_kind), intent(in) :: key1(Nint,2,sze) - integer(bit_kind), intent(in) :: key2(Nint,2) - integer, intent(out) :: degree(sze) - integer, intent(out) :: idx(0:sze) - integer(bit_kind) :: key_tmp(Nint,2) - - integer :: i,l,d,m - integer :: degree_alpha, degree_beta - - ASSERT (Nint > 0) - ASSERT (sze > 0) - - 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))) - if (d .ne.4)cycle - key_tmp(1,1) = xor(key1(1,1,i),key2(1,1)) - key_tmp(1,2) = xor(key1(1,2,i),key2(1,2)) - degree_alpha = popcnt(key_tmp(1,1)) - degree_beta = popcnt(key_tmp(1,2)) - if(degree_alpha .gt.3 .or. degree_beta .gt.3 )cycle !! no double excitations of same spin - degree(l) = ishft(d,-1) - idx(l) = i - l = l+1 - enddo - 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))) + & - popcnt(xor( key1(2,1,i), key2(2,1))) + & - popcnt(xor( key1(2,2,i), key2(2,2))) - if (d .ne.4)cycle - key_tmp(1,1) = xor(key1(1,1,i),key2(1,1)) - key_tmp(1,2) = xor(key1(1,2,i),key2(1,2)) - key_tmp(2,1) = xor(key1(2,1,i),key2(2,1)) - key_tmp(2,2) = xor(key1(2,2,i),key2(2,2)) - degree_alpha = popcnt(key_tmp(1,1)) + popcnt(key_tmp(2,1)) - degree_beta = popcnt(key_tmp(1,2)) + popcnt(key_tmp(2,2)) - if(degree_alpha .gt.3 .or. degree_beta .gt.3 )cycle !! no double excitations of same spin - degree(l) = ishft(d,-1) - idx(l) = i - l = l+1 - enddo - - 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))) + & - popcnt(xor( key1(2,1,i), key2(2,1))) + & - popcnt(xor( key1(2,2,i), key2(2,2))) + & - popcnt(xor( key1(3,1,i), key2(3,1))) + & - popcnt(xor( key1(3,2,i), key2(3,2))) - if (d .ne.4)cycle - key_tmp(1,1) = xor(key1(1,1,i),key2(1,1)) - key_tmp(1,2) = xor(key1(1,2,i),key2(1,2)) - key_tmp(2,1) = xor(key1(2,1,i),key2(2,1)) - key_tmp(2,2) = xor(key1(2,2,i),key2(2,2)) - key_tmp(3,1) = xor(key1(3,1,i),key2(3,1)) - key_tmp(3,2) = xor(key1(3,2,i),key2(3,2)) - degree_alpha = popcnt(key_tmp(1,1)) + popcnt(key_tmp(2,1)) + popcnt(key_tmp(3,1)) - degree_beta = popcnt(key_tmp(1,2)) + popcnt(key_tmp(2,2)) + popcnt(key_tmp(3,2)) - if(degree_alpha .gt.3 .or. degree_beta .gt.3 )cycle !! no double excitations of same spin - degree(l) = ishft(d,-1) - idx(l) = i - l = l+1 - enddo - - 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))) - key_tmp(m,1) = xor(key1(m,1,i),key2(m,1)) - key_tmp(m,2) = xor(key1(m,2,i),key2(m,2)) - degree_alpha = popcnt(key_tmp(m,1)) - degree_beta = popcnt(key_tmp(m,2)) - enddo - if(degree_alpha .gt.3 .or. degree_beta .gt.3 )cycle !! no double excitations of same spin - degree(l) = ishft(d,-1) - idx(l) = i - l = l+1 - enddo - - endif - idx(0) = l-1 -end - - -subroutine get_excitation_degree_vector_mono_or_exchange_verbose(key1,key2,degree,Nint,sze,idx) - use bitmasks - implicit none - BEGIN_DOC - ! Applies get_excitation_degree to an array of determinants and return only the mono excitations - ! and the connections through exchange integrals - END_DOC - integer, intent(in) :: Nint, sze - integer(bit_kind), intent(in) :: key1(Nint,2,sze) - integer(bit_kind), intent(in) :: key2(Nint,2) - integer, intent(out) :: degree(sze) - integer, intent(out) :: idx(0:sze) - - integer :: i,l,d,m - integer :: exchange_1,exchange_2 - - ASSERT (Nint > 0) - ASSERT (sze > 0) - - 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))) - exchange_1 = popcnt(xor(ior(key1(1,1,i),key1(1,2,i)),ior(key2(1,1),key2(1,2)))) - exchange_2 = popcnt(ior(xor(key1(1,1,i),key2(1,1)),xor(key1(1,2,i),key2(1,2)))) - if(i==99)then - integer(bit_kind) :: key_test(N_int,2) - key_test(1,2) = 0_bit_kind - call debug_det(key2,N_int) - key_test(1,1) = ior(key2(1,1),key2(1,2)) - call debug_det(key_test,N_int) - key_test(1,1) = ior(key1(1,1,i),key1(1,2,i)) - call debug_det(key1(1,1,i),N_int) - call debug_det(key_test,N_int) - key_test(1,1) = xor(ior(key1(1,1,i),key1(1,2,i)),ior(key2(1,1),key2(1,2))) - call debug_det(key_test,N_int) - print*, exchange_1 , exchange_2 - stop - endif - if (d > 4)cycle - if (d ==4)then - if(exchange_1 .eq. 0 ) then - degree(l) = ishft(d,-1) - idx(l) = i - l = l+1 - else if (exchange_1 .eq. 2 .and. exchange_2.eq.2)then - degree(l) = ishft(d,-1) - idx(l) = i - l = l+1 - else - cycle - endif -! pause - else - degree(l) = ishft(d,-1) - idx(l) = i - l = l+1 - endif - enddo - 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))) + & - popcnt(xor( key1(2,1,i), key2(2,1))) + & - popcnt(xor( key1(2,2,i), key2(2,2))) - exchange_1 = popcnt(xor(iand(key1(1,1,i),key1(1,2,i)),iand(key2(1,2),key2(1,2)))) + & - popcnt(xor(iand(key1(2,1,i),key1(2,2,i)),iand(key2(2,2),key2(2,2)))) - exchange_2 = popcnt(iand(xor(key1(1,1,i),key2(1,1)),xor(key1(1,2,i),key2(1,2)))) + & - popcnt(iand(xor(key1(2,1,i),key2(2,1)),xor(key1(2,2,i),key2(2,2)))) - if (d > 4)cycle - if (d ==4)then - if(exchange_1 .eq. 0 ) then - degree(l) = ishft(d,-1) - idx(l) = i - l = l+1 - else if (exchange_1 .eq. 2 .and. exchange_2.eq.2)then - degree(l) = ishft(d,-1) - idx(l) = i - l = l+1 - else - cycle - endif -! pause - else - degree(l) = ishft(d,-1) - idx(l) = i - l = l+1 - endif - enddo - - 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))) + & - popcnt(xor( key1(2,1,i), key2(2,1))) + & - popcnt(xor( key1(2,2,i), key2(2,2))) + & - popcnt(xor( key1(3,1,i), key2(3,1))) + & - popcnt(xor( key1(3,2,i), key2(3,2))) - exchange_1 = popcnt(xor(iand(key1(1,1,i),key1(1,2,i)),iand(key2(1,1),key2(1,2)))) + & - popcnt(xor(iand(key1(2,1,i),key1(2,2,i)),iand(key2(2,1),key2(2,2)))) + & - popcnt(xor(iand(key1(3,1,i),key1(3,2,i)),iand(key2(3,1),key2(3,2)))) - exchange_2 = popcnt(iand(xor(key1(1,1,i),key2(1,1)),xor(key1(1,2,i),key2(1,2)))) + & - popcnt(iand(xor(key1(2,1,i),key2(2,1)),xor(key1(2,2,i),key2(2,2)))) + & - popcnt(iand(xor(key1(3,1,i),key2(3,1)),xor(key1(3,2,i),key2(3,2)))) - if (d > 4)cycle - if (d ==4)then - if(exchange_1 .eq. 0 ) then - degree(l) = ishft(d,-1) - idx(l) = i - l = l+1 - else if (exchange_1 .eq. 2 .and. exchange_2.eq.2)then - degree(l) = ishft(d,-1) - idx(l) = i - l = l+1 - else - cycle - endif -! pause - else - degree(l) = ishft(d,-1) - idx(l) = i - l = l+1 - endif - enddo - - else - - !DIR$ LOOP COUNT (1000) - do i=1,sze - d = 0 - exchange_1 = 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))) - exchange_1 = popcnt(xor(iand(key1(m,1,i),key1(m,2,i)),iand(key2(m,1),key2(m,2)))) - exchange_2 = popcnt(iand(xor(key1(m,1,i),key2(m,1)),xor(key1(m,2,i),key2(m,2)))) - enddo - if (d > 4)cycle - if (d ==4)then - if(exchange_1 .eq. 0 ) then - degree(l) = ishft(d,-1) - idx(l) = i - l = l+1 - else if (exchange_1 .eq. 2 .and. exchange_2.eq.2)then - degree(l) = ishft(d,-1) - idx(l) = i - l = l+1 - else - cycle - endif -! pause - else - degree(l) = ishft(d,-1) - idx(l) = i - l = l+1 - endif - enddo - - endif - idx(0) = l-1 -end subroutine get_excitation_degree_vector(key1,key2,degree,Nint,sze,idx) @@ -2152,43 +1639,3 @@ subroutine get_phase(key1,key2,phase,Nint) call get_excitation(key1, key2, exc, degree, phase, Nint) end -subroutine H_u_0_stored(v_0,u_0,hmatrix,sze) - use bitmasks - implicit none - BEGIN_DOC - ! Computes v_0 = H|u_0> - ! - ! n : number of determinants - ! - ! uses the big_matrix_stored array - END_DOC - integer, intent(in) :: sze - double precision, intent(in) :: hmatrix(sze,sze) - double precision, intent(out) :: v_0(sze) - double precision, intent(in) :: u_0(sze) - v_0 = 0.d0 - call matrix_vector_product(u_0,v_0,hmatrix,sze,sze) - -end - -subroutine u_0_H_u_0_stored(e_0,u_0,hmatrix,sze) - use bitmasks - implicit none - BEGIN_DOC - ! Computes e_0 = - ! - ! n : number of determinants - ! - ! uses the big_matrix_stored array - END_DOC - integer, intent(in) :: sze - double precision, intent(in) :: hmatrix(sze,sze) - double precision, intent(out) :: e_0 - double precision, intent(in) :: u_0(sze) - double precision :: v_0(sze) - double precision :: u_dot_v - e_0 = 0.d0 - v_0 = 0.d0 - call matrix_vector_product(u_0,v_0,hmatrix,sze,sze) - e_0 = u_dot_v(v_0,u_0,sze) -end diff --git a/src/Determinants/truncate_wf.irp.f b/src/Determinants/truncate_wf.irp.f index aba16fa7..42340c71 100644 --- a/src/Determinants/truncate_wf.irp.f +++ b/src/Determinants/truncate_wf.irp.f @@ -1,11 +1,18 @@ -program s2_eig_restart - implicit none - read_wf = .True. - call routine -end -subroutine routine - implicit none - call make_s2_eigenfunction +program cisd + implicit none + integer :: i,k + + + double precision, allocatable :: pt2(:), norm_pert(:), H_pert_diag(:) + integer :: N_st, degree + N_det=10000 + do i=1,N_det + do k=1,N_int + psi_det(k,1,i) = psi_det_sorted(k,1,i) + psi_det(k,2,i) = psi_det_sorted(k,2,i) + enddo + psi_coef(i,:) = psi_coef_sorted(i,:) + enddo TOUCH psi_det psi_coef psi_det_sorted psi_coef_sorted psi_average_norm_contrib_sorted N_det call save_wavefunction end diff --git a/src/Determinants/two_body_dm_map.irp.f b/src/Determinants/two_body_dm_map.irp.f deleted file mode 100644 index aa8f630b..00000000 --- a/src/Determinants/two_body_dm_map.irp.f +++ /dev/null @@ -1,619 +0,0 @@ - -use map_module - -BEGIN_PROVIDER [ type(map_type), two_body_dm_ab_map ] - implicit none - BEGIN_DOC - ! Map of the two body density matrix elements for the alpha/beta elements - END_DOC - integer(key_kind) :: key_max - integer(map_size_kind) :: sze - use map_module - call bielec_integrals_index(mo_tot_num,mo_tot_num,mo_tot_num,mo_tot_num,key_max) - sze = key_max - call map_init(two_body_dm_ab_map,sze) - print*, 'two_body_dm_ab_map initialized' -END_PROVIDER - -subroutine insert_into_two_body_dm_ab_map(n_product,buffer_i, buffer_values, thr) - use map_module - implicit none - - BEGIN_DOC - ! Create new entry into two_body_dm_ab_map, or accumulate in an existing entry - END_DOC - - integer, intent(in) :: n_product - integer(key_kind), intent(inout) :: buffer_i(n_product) - real(integral_kind), intent(inout) :: buffer_values(n_product) - real(integral_kind), intent(in) :: thr - call map_update(two_body_dm_ab_map, buffer_i, buffer_values, n_product, thr) -end - -double precision function get_two_body_dm_ab_map_element(i,j,k,l,map) - use map_module - implicit none - BEGIN_DOC - ! Returns one value of the wo body density matrix \rho_{ijkl}^{\alpha \beta} defined as : - ! \rho_{ijkl}^{\alpha \beta } = <\Psi|a^{\dagger}_{i\alpha} a^{\dagger}_{j\beta} a_{k\beta} a_{l\alpha}|\Psi> - END_DOC - PROVIDE two_body_dm_ab_map - - integer, intent(in) :: i,j,k,l - integer(key_kind) :: idx - type(map_type), intent(inout) :: map - real(integral_kind) :: tmp - PROVIDE two_body_dm_in_map - !DIR$ FORCEINLINE - call bielec_integrals_index(i,j,k,l,idx) - !DIR$ FORCEINLINE - call map_get(two_body_dm_ab_map,idx,tmp) - get_two_body_dm_ab_map_element = dble(tmp) -end - -subroutine get_get_two_body_dm_ab_map_elements(j,k,l,sze,out_val,map) - use map_module - implicit none - BEGIN_DOC - ! Returns multiple elements of the \rho_{ijkl}^{\alpha \beta }, all - ! i for j,k,l fixed. - END_DOC - integer, intent(in) :: j,k,l, sze - double precision, intent(out) :: out_val(sze) - type(map_type), intent(inout) :: map - integer :: i - integer(key_kind) :: hash(sze) - real(integral_kind) :: tmp_val(sze) - PROVIDE two_body_dm_in_map - - do i=1,sze - !DIR$ FORCEINLINE - call bielec_integrals_index(i,j,k,l,hash(i)) - enddo - - if (key_kind == 8) then - call map_get_many(two_body_dm_ab_map, hash, out_val, sze) - else - call map_get_many(two_body_dm_ab_map, hash, tmp_val, sze) - ! Conversion to double precision - do i=1,sze - out_val(i) = dble(tmp_val(i)) - enddo - endif -end - -BEGIN_PROVIDER [ logical, two_body_dm_in_map ] - implicit none - - BEGIN_DOC - ! If True, the map of the two body density matrix alpha/beta is provided - END_DOC - - two_body_dm_in_map = .True. - call add_values_to_two_body_dm_map(full_ijkl_bitmask_4) -END_PROVIDER - -subroutine add_values_to_two_body_dm_map(mask_ijkl) - use bitmasks - use map_module - implicit none - - BEGIN_DOC - ! Adds values to the map of two_body_dm according to some bitmask - END_DOC - - integer(bit_kind), intent(in) :: mask_ijkl(N_int,4) - integer :: degree - - PROVIDE mo_coef psi_coef psi_det - - integer :: exc(0:2,2,2) - integer :: h1,h2,p1,p2,s1,s2 - double precision :: phase - double precision :: contrib - integer(key_kind),allocatable :: buffer_i(:) - double precision ,allocatable :: buffer_value(:) - integer :: size_buffer - integer :: n_elements - integer :: occ(N_int*bit_kind_size,2) - integer :: n_occ_ab(2) - integer :: i,j,k,l,m - - size_buffer = min(mo_tot_num*mo_tot_num*mo_tot_num,16000000) - - allocate(buffer_i(size_buffer),buffer_value(size_buffer)) - - n_elements = 0 - do i = 1, N_det ! i == |I> - call bitstring_to_list_ab(psi_det(1,1,i), occ, n_occ_ab, N_int) - do j = i+1, N_det ! j == 2)cycle - call get_excitation(psi_det(1,1,i),psi_det(1,1,j),exc,degree,phase,N_int) - call decode_exc(exc,degree,h1,p1,h2,p2,s1,s2) - if(degree==2)then ! case of the DOUBLE EXCITATIONS ************************************ - - if(s1==s2)cycle ! Only the alpha/beta two body density matrix - ! * c_I * c_J - if(h1>p1)cycle - if(h2>p2)cycle -! if(s1.ne.1)cycle - n_elements += 1 - contrib = psi_coef(i,1) * psi_coef(j,1) * phase - buffer_value(n_elements) = contrib - !DEC$ FORCEINLINE -! call mo_bielec_integrals_index(h1,p1,h2,p2,buffer_i(n_elements)) - call mo_bielec_integrals_index(h1,h2,p1,p2,buffer_i(n_elements)) -! if (n_elements == size_buffer) then -! call insert_into_two_body_dm_ab_map(n_elements,buffer_i,buffer_value,& -! real(mo_integrals_threshold,integral_kind)) -! n_elements = 0 -! endif - - else ! case of the SINGLE EXCITATIONS *************************************************** - cycle - -! if(s1==1)then ! Mono alpha : -! do k = 1, elec_beta_num -! m = occ(k,2) -! n_elements += 1 -! buffer_value(n_elements) = contrib -! ! * c_I * c_J -! call mo_bielec_integrals_index(h1,m,p1,m,buffer_i(n_elements)) -! if (n_elements == size_buffer) then -! call insert_into_two_body_dm_ab_map(n_elements,buffer_i,buffer_value,& -! real(mo_integrals_threshold,integral_kind)) -! n_elements = 0 -! endif -! enddo -! else ! Mono Beta : -! do k = 1, elec_alpha_num -! m = occ(k,1) -! n_elements += 1 -! buffer_value(n_elements) = contrib -! ! * c_I * c_J -! call mo_bielec_integrals_index(h1,m,p1,m,buffer_i(n_elements)) -! if (n_elements == size_buffer) then -! call insert_into_two_body_dm_ab_map(n_elements,buffer_i,buffer_value,& -! real(mo_integrals_threshold,integral_kind)) -! n_elements = 0 -! endif -! enddo -! endif - - endif - enddo - enddo - print*,'n_elements = ',n_elements - call insert_into_two_body_dm_ab_map(n_elements,buffer_i,buffer_value,& - real(mo_integrals_threshold,integral_kind)) - call map_unique(two_body_dm_ab_map) - - deallocate(buffer_i,buffer_value) - -end - - BEGIN_PROVIDER [double precision, two_body_dm_ab_diag_act, (n_act_orb, n_act_orb)] -&BEGIN_PROVIDER [double precision, two_body_dm_ab_diag_inact, (n_inact_orb_allocate, n_inact_orb_allocate)] -&BEGIN_PROVIDER [double precision, two_body_dm_ab_diag_core, (n_core_orb_allocate, n_core_orb_allocate)] -&BEGIN_PROVIDER [double precision, two_body_dm_ab_diag_all, (mo_tot_num, mo_tot_num)] -&BEGIN_PROVIDER [double precision, two_body_dm_diag_core_a_act_b, (n_core_orb_allocate,n_act_orb)] -&BEGIN_PROVIDER [double precision, two_body_dm_diag_core_b_act_a, (n_core_orb_allocate,n_act_orb)] -&BEGIN_PROVIDER [double precision, two_body_dm_diag_core_act, (n_core_orb_allocate,n_act_orb)] - implicit none - use bitmasks - integer :: i,j,k,l,m - integer :: occ(N_int*bit_kind_size,2) - integer :: n_occ_ab(2) - integer :: occ_act(N_int*bit_kind_size,2) - integer :: n_occ_ab_act(2) - integer :: occ_core(N_int*bit_kind_size,2) - integer :: n_occ_ab_core(2) - double precision :: contrib - BEGIN_DOC - ! two_body_dm_ab_diag_all(k,m) = <\Psi | n_(k\alpha) n_(m\beta) | \Psi> - ! two_body_dm_ab_diag_act(k,m) is restricted to the active orbitals : - ! orbital k = list_act(k) - ! two_body_dm_ab_diag_inact(k,m) is restricted to the inactive orbitals : - ! orbital k = list_inact(k) - ! two_body_dm_ab_diag_core(k,m) is restricted to the core orbitals : - ! orbital k = list_core(k) - ! two_body_dm_ab_diag_core_b_act_a(k,m) represents the core beta <-> active alpha part of the two body dm - ! orbital k = list_core(k) - ! orbital m = list_act(m) - ! two_body_dm_ab_diag_core_a_act_b(k,m) represents the core alpha <-> active beta part of the two body dm - ! orbital k = list_core(k) - ! orbital m = list_act(m) - ! two_body_dm_ab_diag_core_act(k,m) represents the core<->active part of the diagonal two body dm - ! when we traced on the spin - ! orbital k = list_core(k) - ! orbital m = list_act(m) - END_DOC - integer(bit_kind) :: key_tmp_core(N_int,2) - integer(bit_kind) :: key_tmp_act(N_int,2) - - two_body_dm_ab_diag_all = 0.d0 - two_body_dm_ab_diag_act = 0.d0 - two_body_dm_ab_diag_core = 0.d0 - two_body_dm_ab_diag_inact = 0.d0 - two_body_dm_diag_core_a_act_b = 0.d0 - two_body_dm_diag_core_b_act_a = 0.d0 - two_body_dm_diag_core_act = 0.d0 - do i = 1, N_det ! i == |I> - ! Full diagonal part of the two body dm - contrib = psi_coef(i,1)**2 - call bitstring_to_list_ab(psi_det(1,1,i), occ, n_occ_ab, N_int) - do j = 1, elec_beta_num - k = occ(j,2) - do l = 1, elec_alpha_num - m = occ(l,1) - two_body_dm_ab_diag_all(k,m) += 0.5d0 * contrib - two_body_dm_ab_diag_all(m,k) += 0.5d0 * contrib - enddo - enddo - - ! ACTIVE PART of the diagonal part of the two body dm - do j = 1, N_int - key_tmp_act(j,1) = psi_det(j,1,i) - key_tmp_act(j,2) = psi_det(j,2,i) - enddo - do j = 1, N_int - key_tmp_act(j,1) = iand(key_tmp_act(j,1),cas_bitmask(j,1,1)) - key_tmp_act(j,2) = iand(key_tmp_act(j,2),cas_bitmask(j,1,1)) - enddo - call bitstring_to_list_ab(key_tmp_act, occ_act, n_occ_ab_act, N_int) - do j = 1,n_occ_ab_act(2) - k = list_act_reverse(occ_act(j,2)) - do l = 1, n_occ_ab_act(1) - m = list_act_reverse(occ_act(l,1)) - two_body_dm_ab_diag_act(k,m) += 0.5d0 * contrib - two_body_dm_ab_diag_act(m,k) += 0.5d0 * contrib - enddo - enddo - - ! CORE PART of the diagonal part of the two body dm - do j = 1, N_int - key_tmp_core(j,1) = psi_det(j,1,i) - key_tmp_core(j,2) = psi_det(j,2,i) - enddo - do j = 1, N_int - key_tmp_core(j,1) = iand(key_tmp_core(j,1),core_bitmask(j,1)) - key_tmp_core(j,2) = iand(key_tmp_core(j,2),core_bitmask(j,1)) - enddo - call bitstring_to_list_ab(key_tmp_core, occ_core, n_occ_ab_core, N_int) - do j = 1,n_occ_ab_core(2) - k = list_core_reverse(occ_core(j,2)) - do l = 1, n_occ_ab_core(1) - m = list_core_reverse(occ_core(l,1)) - two_body_dm_ab_diag_core(k,m) += 0.5d0 * contrib - two_body_dm_ab_diag_core(m,k) += 0.5d0 * contrib - enddo - enddo - - ! ACT<->CORE PART - ! alpha electron in active space - do j = 1,n_occ_ab_act(1) - k = list_act_reverse(occ_act(j,1)) - ! beta electron in core space - do l = 1, n_occ_ab_core(2) - m = list_core_reverse(occ_core(l,2)) - ! The fact that you have 1 * contrib and not 0.5 * contrib - ! takes into account the following symmetry : - ! 0.5 * + 0.5 * - two_body_dm_diag_core_b_act_a(m,k) += contrib - enddo - enddo - ! beta electron in active space - do j = 1,n_occ_ab_act(2) - k = list_act_reverse(occ_act(j,2)) - ! alpha electron in core space - do l = 1, n_occ_ab_core(1) - m = list_core_reverse(occ_core(l,1)) - ! The fact that you have 1 * contrib and not 0.5 * contrib - ! takes into account the following symmetry : - ! 0.5 * + 0.5 * - two_body_dm_diag_core_a_act_b(m,k) += contrib - enddo - enddo - enddo - - do j = 1, n_core_orb - do l = 1, n_act_orb - two_body_dm_diag_core_act(j,l) = two_body_dm_diag_core_b_act_a(j,l) + two_body_dm_diag_core_a_act_b(j,l) - enddo - enddo -END_PROVIDER - - BEGIN_PROVIDER [double precision, two_body_dm_ab_big_array_act, (n_act_orb,n_act_orb,n_act_orb,n_act_orb)] -&BEGIN_PROVIDER [double precision, two_body_dm_ab_big_array_core_act, (n_core_orb_allocate,n_act_orb,n_act_orb)] - implicit none - use bitmasks - integer :: i,j,k,l,m - integer :: degree - PROVIDE mo_coef psi_coef psi_det - integer :: exc(0:2,2,2) - integer :: h1,h2,p1,p2,s1,s2 - double precision :: phase - double precision :: contrib - integer :: occ(N_int*bit_kind_size,2) - integer :: n_occ_ab(2) - integer :: occ_core(N_int*bit_kind_size,2) - integer :: n_occ_ab_core(2) - integer(bit_kind) :: key_tmp_i(N_int,2) - integer(bit_kind) :: key_tmp_i_core(N_int,2) - integer(bit_kind) :: key_tmp_j(N_int,2) - two_body_dm_ab_big_array_act = 0.d0 - two_body_dm_ab_big_array_core_act = 0.d0 - BEGIN_DOC -! two_body_dm_ab_big_array_act = Purely active part of the two body density matrix -! two_body_dm_ab_big_array_act_core takes only into account the single excitation -! within the active space that adds terms in the act <-> core two body dm -! two_body_dm_ab_big_array_act_core(i,j,k) = < a^\dagger_i n_k a_j > -! with i,j in the ACTIVE SPACE -! with k in the CORE SPACE -! -! The alpha-beta extra diagonal energy FOR WF DEFINED AS AN APPROXIMATION OF A CAS can be computed thanks to -! sum_{h1,p1,h2,p2} two_body_dm_ab_big_array_act(h1,p1,h2,p2) * (h1p1|h2p2) -! + sum_{h1,p1,h2,p2} two_body_dm_ab_big_array_core_act(h1,p1,h2,p2) * (h1p1|h2p2) - END_DOC - - do i = 1, N_det ! i == |I> - ! active part of psi_det(i) - do j = 1, N_int - key_tmp_i(j,1) = psi_det(j,1,i) - key_tmp_i(j,2) = psi_det(j,2,i) - key_tmp_i_core(j,1) = psi_det(j,1,i) - key_tmp_i_core(j,2) = psi_det(j,2,i) - enddo - do j = 1, N_int - key_tmp_i(j,1) = iand(key_tmp_i(j,1),cas_bitmask(j,1,1)) - key_tmp_i(j,2) = iand(key_tmp_i(j,2),cas_bitmask(j,1,1)) - enddo - do j = 1, N_int - key_tmp_i_core(j,1) = iand(key_tmp_i_core(j,1),core_bitmask(j,1)) - key_tmp_i_core(j,2) = iand(key_tmp_i_core(j,2),core_bitmask(j,1)) - enddo - call bitstring_to_list_ab(key_tmp_i_core, occ_core, n_occ_ab_core, N_int) - call bitstring_to_list_ab(key_tmp_i, occ, n_occ_ab, N_int) - do j = i+1, N_det ! j == 2)cycle - ! if it is the case, then compute the hamiltonian matrix element with the proper phase - call get_excitation(psi_det(1,1,i),psi_det(1,1,j),exc,degree,phase,N_int) - call decode_exc(exc,degree,h1,p1,h2,p2,s1,s2) - contrib = 0.5d0 * psi_coef(i,1) * psi_coef(j,1) * phase - if(degree==2)then ! case of the DOUBLE EXCITATIONS ************************************ - if(s1==s2)cycle ! Only the alpha/beta two body density matrix - ! * c_I * c_J - h1 = list_act_reverse(h1) - h2 = list_act_reverse(h2) - p1 = list_act_reverse(p1) - p2 = list_act_reverse(p2) - call insert_into_two_body_dm_big_array( two_body_dm_ab_big_array_act,n_act_orb,n_act_orb,n_act_orb,n_act_orb,contrib,h1,p1,h2,p2) - - else if(degree==1)then! case of the SINGLE EXCITATIONS *************************************************** - print*,'h1 = ',h1 - h1 = list_act_reverse(h1) - print*,'h1 = ',h1 - print*,'p1 = ',p1 - p1 = list_act_reverse(p1) - print*,'p1 = ',p1 - - if(s1==1)then ! Mono alpha : - ! purely active part of the extra diagonal two body dm - do k = 1, n_occ_ab(2) - m = list_act_reverse(occ(k,2)) - ! * c_I * c_J - call insert_into_two_body_dm_big_array( two_body_dm_ab_big_array_act,n_act_orb,n_act_orb,n_act_orb,n_act_orb,contrib,h1,p1,m,m) - enddo - - ! core <-> active part of the extra diagonal two body dm - do k = 1, n_occ_ab_core(2) - m = list_core_reverse(occ_core(k,2)) - ! * c_I * c_J - two_body_dm_ab_big_array_core_act(m,h1,p1) += 2.d0 * contrib - two_body_dm_ab_big_array_core_act(m,p1,h1) += 2.d0 * contrib - enddo - else ! Mono Beta : - ! purely active part of the extra diagonal two body dm - do k = 1, n_occ_ab(1) - m = list_act_reverse(occ(k,1)) - ! * c_I * c_J - call insert_into_two_body_dm_big_array(two_body_dm_ab_big_array_act,n_act_orb,n_act_orb,n_act_orb,n_act_orb,contrib,h1,p1,m,m) - enddo - - ! core <-> active part of the extra diagonal two body dm - do k = 1, n_occ_ab_core(1) - m = list_core_reverse(occ_core(k,1)) - ! * c_I * c_J - two_body_dm_ab_big_array_core_act(m,h1,p1) += 2.d0 * contrib - two_body_dm_ab_big_array_core_act(m,p1,h1) += 2.d0 * contrib - enddo - endif - - endif - enddo - enddo - print*,'Big array for density matrix provided !' - -END_PROVIDER - -subroutine insert_into_two_body_dm_big_array(big_array,dim1,dim2,dim3,dim4,contrib,h1,p1,h2,p2) - implicit none - integer, intent(in) :: h1,p1,h2,p2 - integer, intent(in) :: dim1,dim2,dim3,dim4 - double precision, intent(inout) :: big_array(dim1,dim2,dim3,dim4) - double precision :: contrib - ! Two spin symmetry - big_array(h1,p1,h2,p2) += contrib - big_array(h2,p2,h1,p1) += contrib - ! Hermicity : hole-particle symmetry - big_array(p1,h1,p2,h2) += contrib - big_array(p2,h2,p1,h1) += contrib - - -end - -double precision function compute_extra_diag_two_body_dm_ab(r1,r2) - implicit none - BEGIN_DOC -! compute the extra diagonal contribution to the alpha/bet two body density at r1, r2 - END_DOC - double precision :: r1(3), r2(3) - double precision :: compute_extra_diag_two_body_dm_ab_act,compute_extra_diag_two_body_dm_ab_core_act - compute_extra_diag_two_body_dm_ab = compute_extra_diag_two_body_dm_ab_act(r1,r2)+compute_extra_diag_two_body_dm_ab_core_act(r1,r2) -end - -double precision function compute_extra_diag_two_body_dm_ab_act(r1,r2) - implicit none - BEGIN_DOC -! compute the extra diagonal contribution to the two body density at r1, r2 -! involving ONLY THE ACTIVE PART, which means that the four index of the excitations -! involved in the two body density matrix are ACTIVE - END_DOC - PROVIDE n_act_orb - double precision, intent(in) :: r1(3),r2(3) - integer :: i,j,k,l - double precision :: mos_array_r1(n_act_orb),mos_array_r2(n_act_orb) - double precision :: contrib - double precision :: contrib_tmp -!print*,'n_act_orb = ',n_act_orb - compute_extra_diag_two_body_dm_ab_act = 0.d0 - call give_all_act_mos_at_r(r1,mos_array_r1) - call give_all_act_mos_at_r(r2,mos_array_r2) - do l = 1, n_act_orb ! p2 - do k = 1, n_act_orb ! h2 - do j = 1, n_act_orb ! p1 - do i = 1,n_act_orb ! h1 - contrib_tmp = mos_array_r1(i) * mos_array_r1(j) * mos_array_r2(k) * mos_array_r2(l) - compute_extra_diag_two_body_dm_ab_act += two_body_dm_ab_big_array_act(i,j,k,l) * contrib_tmp - enddo - enddo - enddo - enddo - -end - -double precision function compute_extra_diag_two_body_dm_ab_core_act(r1,r2) - implicit none - BEGIN_DOC -! compute the extra diagonal contribution to the two body density at r1, r2 -! involving ONLY THE ACTIVE PART, which means that the four index of the excitations -! involved in the two body density matrix are ACTIVE - END_DOC - double precision, intent(in) :: r1(3),r2(3) - integer :: i,j,k,l - double precision :: mos_array_act_r1(n_act_orb),mos_array_act_r2(n_act_orb) - double precision :: mos_array_core_r1(n_core_orb),mos_array_core_r2(n_core_orb) - double precision :: contrib_core_1,contrib_core_2 - double precision :: contrib_act_1,contrib_act_2 - double precision :: contrib_tmp - compute_extra_diag_two_body_dm_ab_core_act = 0.d0 - call give_all_act_mos_at_r(r1,mos_array_act_r1) - call give_all_act_mos_at_r(r2,mos_array_act_r2) - call give_all_core_mos_at_r(r1,mos_array_core_r1) - call give_all_core_mos_at_r(r2,mos_array_core_r2) - do i = 1, n_act_orb ! h1 - do j = 1, n_act_orb ! p1 - contrib_act_1 = mos_array_act_r1(i) * mos_array_act_r1(j) - contrib_act_2 = mos_array_act_r2(i) * mos_array_act_r2(j) - do k = 1,n_core_orb ! h2 - contrib_core_1 = mos_array_core_r1(k) * mos_array_core_r1(k) - contrib_core_2 = mos_array_core_r2(k) * mos_array_core_r2(k) - contrib_tmp = 0.5d0 * (contrib_act_1 * contrib_core_2 + contrib_act_2 * contrib_core_1) - compute_extra_diag_two_body_dm_ab_core_act += two_body_dm_ab_big_array_core_act(k,i,j) * contrib_tmp - enddo - enddo - enddo - -end - -double precision function compute_diag_two_body_dm_ab_core(r1,r2) - implicit none - double precision :: r1(3),r2(3) - integer :: i,j,k,l - double precision :: mos_array_r1(n_core_orb_allocate),mos_array_r2(n_core_orb_allocate) - double precision :: contrib,contrib_tmp - compute_diag_two_body_dm_ab_core = 0.d0 - call give_all_core_mos_at_r(r1,mos_array_r1) - call give_all_core_mos_at_r(r2,mos_array_r2) - do l = 1, n_core_orb ! - contrib = mos_array_r2(l)*mos_array_r2(l) -! if(dabs(contrib).lt.threshld_two_bod_dm)cycle - do k = 1, n_core_orb ! - contrib_tmp = contrib * mos_array_r1(k)*mos_array_r1(k) -! if(dabs(contrib).lt.threshld_two_bod_dm)cycle - compute_diag_two_body_dm_ab_core += two_body_dm_ab_diag_core(k,l) * contrib_tmp - enddo - enddo - -end - - -double precision function compute_diag_two_body_dm_ab_act(r1,r2) - implicit none - double precision :: r1(3),r2(3) - integer :: i,j,k,l - double precision :: mos_array_r1(n_act_orb),mos_array_r2(n_act_orb) - double precision :: contrib,contrib_tmp - compute_diag_two_body_dm_ab_act = 0.d0 - call give_all_act_mos_at_r(r1,mos_array_r1) - call give_all_act_mos_at_r(r2,mos_array_r2) - do l = 1, n_act_orb ! - contrib = mos_array_r2(l)*mos_array_r2(l) -! if(dabs(contrib).lt.threshld_two_bod_dm)cycle - do k = 1, n_act_orb ! - contrib_tmp = contrib * mos_array_r1(k)*mos_array_r1(k) -! if(dabs(contrib).lt.threshld_two_bod_dm)cycle - compute_diag_two_body_dm_ab_act += two_body_dm_ab_diag_act(k,l) * contrib_tmp - enddo - enddo -end - -double precision function compute_diag_two_body_dm_ab_core_act(r1,r2) - implicit none - double precision :: r1(3),r2(3) - integer :: i,j,k,l - double precision :: mos_array_core_r1(n_core_orb_allocate),mos_array_core_r2(n_core_orb_allocate) - double precision :: mos_array_act_r1(n_act_orb),mos_array_act_r2(n_act_orb) - double precision :: contrib_core_1,contrib_core_2 - double precision :: contrib_act_1,contrib_act_2 - double precision :: contrib_tmp - compute_diag_two_body_dm_ab_core_act = 0.d0 - call give_all_act_mos_at_r(r1,mos_array_act_r1) - call give_all_act_mos_at_r(r2,mos_array_act_r2) - call give_all_core_mos_at_r(r1,mos_array_core_r1) - call give_all_core_mos_at_r(r2,mos_array_core_r2) -! if(dabs(contrib).lt.threshld_two_bod_dm)cycle - do k = 1, n_act_orb ! - contrib_act_1 = mos_array_act_r1(k) * mos_array_act_r1(k) - contrib_act_2 = mos_array_act_r2(k) * mos_array_act_r2(k) - contrib_tmp = 0.5d0 * (contrib_act_1 * contrib_act_2 + contrib_act_2 * contrib_act_1) -! if(dabs(contrib).lt.threshld_two_bod_dm)cycle - do l = 1, n_core_orb ! - contrib_core_1 = mos_array_core_r1(l) * mos_array_core_r1(l) - contrib_core_2 = mos_array_core_r2(l) * mos_array_core_r2(l) - compute_diag_two_body_dm_ab_core_act += two_body_dm_diag_core_act(l,k) * contrib_tmp - enddo - enddo -end - -double precision function compute_diag_two_body_dm_ab(r1,r2) - implicit none - double precision,intent(in) :: r1(3),r2(3) - double precision :: compute_diag_two_body_dm_ab_act,compute_diag_two_body_dm_ab_core - double precision :: compute_diag_two_body_dm_ab_core_act - compute_diag_two_body_dm_ab = compute_diag_two_body_dm_ab_act(r1,r2)+compute_diag_two_body_dm_ab_core(r1,r2) & - + compute_diag_two_body_dm_ab_core_act(r1,r2) -end diff --git a/src/Determinants/utils.irp.f b/src/Determinants/utils.irp.f index dbd5a7ef..22faee83 100644 --- a/src/Determinants/utils.irp.f +++ b/src/Determinants/utils.irp.f @@ -1,17 +1,15 @@ BEGIN_PROVIDER [ double precision, H_matrix_all_dets,(N_det,N_det) ] - use bitmasks implicit none BEGIN_DOC ! H matrix on the basis of the slater determinants defined by psi_det END_DOC - integer :: i,j,k + integer :: i,j double precision :: hij - integer :: degree(N_det),idx(0:N_det) call i_H_j(psi_det(1,1,1),psi_det(1,1,1),N_int,hij) - !$OMP PARALLEL DO SCHEDULE(GUIDED) DEFAULT(NONE) PRIVATE(i,j,hij,degree,idx,k) & + !$OMP PARALLEL DO SCHEDULE(GUIDED) PRIVATE(i,j,hij) & !$OMP SHARED (N_det, psi_det, N_int,H_matrix_all_dets) do i =1,N_det - do j = i, N_det + do j =i,N_det call i_H_j(psi_det(1,1,i),psi_det(1,1,j),N_int,hij) H_matrix_all_dets(i,j) = hij H_matrix_all_dets(j,i) = hij @@ -20,4 +18,3 @@ BEGIN_PROVIDER [ double precision, H_matrix_all_dets,(N_det,N_det) ] !$OMP END PARALLEL DO END_PROVIDER - diff --git a/src/Electrons/README.rst b/src/Electrons/README.rst index 484617bb..d1c342b5 100644 --- a/src/Electrons/README.rst +++ b/src/Electrons/README.rst @@ -44,7 +44,7 @@ Documentation .. by the `update_README.py` script. -`elec_alpha_num `_ +`elec_alpha_num `_ Numbers of electrons alpha ("up") diff --git a/src/Ezfio_files/README.rst b/src/Ezfio_files/README.rst index ad87e7f5..6b494339 100644 --- a/src/Ezfio_files/README.rst +++ b/src/Ezfio_files/README.rst @@ -219,10 +219,6 @@ output_cas_sd Initial CPU and wall times when printing in the output files -output_davidson - Output file for Davidson - - output_determinants Output file for Determinants @@ -239,10 +235,6 @@ output_full_ci Output file for Full_CI -output_full_ci_zmq - Output file for Full_CI_ZMQ - - output_generators_cas Output file for Generators_CAS @@ -275,14 +267,14 @@ output_moguess Output file for MOGuess +output_mrcc_cassd + Output file for MRCC_CASSD + + output_mrcc_utils Output file for MRCC_Utils -output_mrcepa0 - Output file for mrcepa0 - - output_nuclei Output file for Nuclei diff --git a/src/Integrals_Bielec/EZFIO.cfg b/src/Integrals_Bielec/EZFIO.cfg index 4e7e494f..3834b121 100644 --- a/src/Integrals_Bielec/EZFIO.cfg +++ b/src/Integrals_Bielec/EZFIO.cfg @@ -5,27 +5,6 @@ interface: ezfio,provider,ocaml default: False ezfio_name: direct -[no_vvvv_integrals] -type: logical -doc: If True, computes all integrals except for the integrals having 4 virtual index -interface: ezfio,provider,ocaml -default: False -ezfio_name: no_vvvv_integrals - -[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 -interface: ezfio,provider,ocaml -default: False -ezfio_name: no_ivvv_integrals - -[no_vvv_integrals] -type: logical -doc: Can be switched on only if no_vvvv_integrals is True, then do not computes the integrals having 3 virtual orbitals -interface: ezfio,provider,ocaml -default: False -ezfio_name: no_vvv_integrals - [disk_access_mo_integrals] type: Disk_access doc: Read/Write MO integrals from/to disk [ Write | Read | None ] diff --git a/src/Integrals_Bielec/README.rst b/src/Integrals_Bielec/README.rst index f6644db4..98fbbb92 100644 --- a/src/Integrals_Bielec/README.rst +++ b/src/Integrals_Bielec/README.rst @@ -45,7 +45,7 @@ Documentation .. by the `update_README.py` script. -`add_integrals_to_map `_ +`add_integrals_to_map `_ Adds integrals to tha MO map according to some bitmask @@ -54,7 +54,7 @@ Documentation i(r1) j(r1) 1/r12 k(r2) l(r2) -`ao_bielec_integral_schwartz `_ +`ao_bielec_integral_schwartz `_ Needed to compute Schwartz inequalities @@ -68,7 +68,7 @@ Documentation 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 @@ -84,23 +84,11 @@ Documentation Computes a buffer of integrals. i is the ID of the current thread. -`ao_integrals_cache `_ - Cache of AO integrals for fast access - - -`ao_integrals_cache_max `_ - Min and max values of the AOs for which the integrals are in the cache - - -`ao_integrals_cache_min `_ - Min and max values of the AOs for which the integrals are in the cache - - `ao_integrals_map `_ AO integrals -`ao_integrals_threshold `_ +`ao_integrals_threshold `_ If || < ao_integrals_threshold then is zero @@ -120,11 +108,11 @@ Documentation Undocumented -`clear_ao_map `_ +`clear_ao_map `_ Frees the memory of the AO map -`clear_mo_map `_ +`clear_mo_map `_ Frees the memory of the MO map @@ -132,15 +120,15 @@ Documentation 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 -`disk_access_ao_integrals `_ +`disk_access_ao_integrals `_ Read/Write AO integrals from/to disk [ Write | Read | None ] -`disk_access_mo_integrals `_ +`disk_access_mo_integrals `_ Read/Write MO integrals from/to disk [ Write | Read | None ] @@ -148,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) @@ -178,156 +166,148 @@ 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 -`get_ao_bielec_integral `_ +`get_ao_bielec_integral `_ Gets one AO bi-electronic integral from the AO map -`get_ao_bielec_integrals `_ +`get_ao_bielec_integrals `_ Gets multiple AO bi-electronic integral from the AO map . All i are retrieved for j,k,l fixed. -`get_ao_bielec_integrals_non_zero `_ +`get_ao_bielec_integrals_non_zero `_ Gets multiple AO bi-electronic integral from the AO map . All non-zero i are retrieved for j,k,l fixed. -`get_ao_map_size `_ +`get_ao_map_size `_ 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_mipi `_ - and - . Indices are (i,m,p) - - -`mo_bielec_integral_mipi_anti `_ - and - . Indices are (i,m,p) - - -`mo_bielec_integral_schwartz `_ +`mo_bielec_integral_schwartz `_ Needed to compute Schwartz inequalities @@ -339,23 +319,11 @@ Documentation Computes an unique index for i,j,k,l integrals -`mo_integrals_cache `_ - Cache of MO integrals for fast access - - -`mo_integrals_cache_max `_ - Min and max values of the MOs for which the integrals are in the cache - - -`mo_integrals_cache_min `_ - Min and max values of the MOs for which the integrals are in the cache - - -`mo_integrals_map `_ +`mo_integrals_map `_ MO integrals -`mo_integrals_threshold `_ +`mo_integrals_threshold `_ If || < ao_integrals_threshold then is zero @@ -363,16 +331,20 @@ 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 `_ +`provide_all_mo_integrals `_ Undocumented +`pull_integrals `_ + How the collector pulls the computed integrals + + `push_integrals `_ Push integrals in the push socket diff --git a/src/Integrals_Bielec/ao_bi_integrals.irp.f b/src/Integrals_Bielec/ao_bi_integrals.irp.f index 68a7a050..9eadbf35 100644 --- a/src/Integrals_Bielec/ao_bi_integrals.irp.f +++ b/src/Integrals_Bielec/ao_bi_integrals.irp.f @@ -350,7 +350,6 @@ BEGIN_PROVIDER [ logical, ao_bielec_integrals_in_map ] integral = ao_bielec_integral(1,1,1,1) real :: map_mb - PROVIDE read_ao_integrals disk_access_ao_integrals if (read_ao_integrals) then print*,'Reading the AO integrals' call map_load_from_disk(trim(ezfio_filename)//'/work/ao_ints',ao_integrals_map) diff --git a/src/Integrals_Bielec/integrals_3_index.irp.f b/src/Integrals_Bielec/integrals_3_index.irp.f deleted file mode 100644 index 41037b34..00000000 --- a/src/Integrals_Bielec/integrals_3_index.irp.f +++ /dev/null @@ -1,22 +0,0 @@ - BEGIN_PROVIDER [double precision, big_array_coulomb_integrals, (mo_tot_num_align,mo_tot_num, mo_tot_num)] -&BEGIN_PROVIDER [double precision, big_array_exchange_integrals,(mo_tot_num_align,mo_tot_num, mo_tot_num)] - implicit none - integer :: i,j,k,l - double precision :: get_mo_bielec_integral - double precision :: integral - - do k = 1, mo_tot_num - do i = 1, mo_tot_num - do j = 1, mo_tot_num - l = j - integral = get_mo_bielec_integral(i,j,k,l,mo_integrals_map) - big_array_coulomb_integrals(j,i,k) = integral - l = j - integral = get_mo_bielec_integral(i,j,l,k,mo_integrals_map) - big_array_exchange_integrals(j,i,k) = integral - enddo - enddo - enddo - - -END_PROVIDER diff --git a/src/Integrals_Bielec/map_integrals.irp.f b/src/Integrals_Bielec/map_integrals.irp.f index 1f2a7a1b..b41a3177 100644 --- a/src/Integrals_Bielec/map_integrals.irp.f +++ b/src/Integrals_Bielec/map_integrals.irp.f @@ -152,7 +152,7 @@ BEGIN_PROVIDER [ double precision, ao_integrals_cache, (0:64*64*64*64) ] END_PROVIDER -double precision function get_ao_bielec_integral(i,j,k,l,map) result(result) +double precision function get_ao_bielec_integral(i,j,k,l,map) use map_module implicit none BEGIN_DOC @@ -179,16 +179,15 @@ double precision function get_ao_bielec_integral(i,j,k,l,map) result(result) call bielec_integrals_index(i,j,k,l,idx) !DIR$ FORCEINLINE call map_get(map,idx,tmp) - tmp = tmp + get_ao_bielec_integral = dble(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) + get_ao_bielec_integral = ao_integrals_cache(ii) endif endif - result = tmp end @@ -403,6 +402,25 @@ double precision function get_mo_bielec_integral(i,j,k,l,map) endif end +double precision function get_mo_bielec_integral_schwartz(i,j,k,l,map) + use map_module + implicit none + BEGIN_DOC + ! Returns one integral in the MO basis + END_DOC + integer, intent(in) :: i,j,k,l + type(map_type), intent(inout) :: map + double precision, external :: get_mo_bielec_integral + + PROVIDE mo_bielec_integrals_in_map mo_integrals_cache + if (mo_bielec_integral_schwartz(i,k)*mo_bielec_integral_schwartz(j,l) > mo_integrals_threshold) then + !DIR$ FORCEINLINE + get_mo_bielec_integral_schwartz = get_mo_bielec_integral(i,j,k,l,map) + else + get_mo_bielec_integral_schwartz = 0.d0 + endif +end + double precision function mo_bielec_integral(i,j,k,l) implicit none @@ -413,7 +431,6 @@ double precision function mo_bielec_integral(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 end @@ -503,73 +520,6 @@ subroutine get_mo_bielec_integrals_ij(k,l,sze,out_array,map) deallocate(pairs,hash,iorder,tmp_val) end -subroutine get_mo_bielec_integrals_coulomb_ii(k,l,sze,out_val,map) - use map_module - implicit none - BEGIN_DOC - ! Returns multiple integrals - ! k(1)i(2) 1/r12 l(1)i(2) :: out_val(i1) - ! for k,l fixed. - END_DOC - integer, intent(in) :: k,l, sze - double precision, intent(out) :: out_val(sze) - type(map_type), intent(inout) :: map - integer :: i - integer(key_kind) :: hash(sze) - real(integral_kind) :: tmp_val(sze) - PROVIDE mo_bielec_integrals_in_map - - integer :: kk - do i=1,sze - !DIR$ FORCEINLINE - call bielec_integrals_index(k,i,l,i,hash(i)) - enddo - - if (key_kind == 8) then - call map_get_many(map, hash, out_val, sze) - else - call map_get_many(map, hash, tmp_val, sze) - ! Conversion to double precision - do i=1,sze - out_val(i) = dble(tmp_val(i)) - enddo - endif -end - -subroutine get_mo_bielec_integrals_exch_ii(k,l,sze,out_val,map) - use map_module - implicit none - BEGIN_DOC - ! Returns multiple integrals - ! k(1)i(2) 1/r12 i(1)l(2) :: out_val(i1) - ! for k,l fixed. - END_DOC - integer, intent(in) :: k,l, sze - double precision, intent(out) :: out_val(sze) - type(map_type), intent(inout) :: map - integer :: i - integer(key_kind) :: hash(sze) - real(integral_kind) :: tmp_val(sze) - PROVIDE mo_bielec_integrals_in_map - - integer :: kk - do i=1,sze - !DIR$ FORCEINLINE - call bielec_integrals_index(k,i,i,l,hash(i)) - enddo - - if (key_kind == 8) then - call map_get_many(map, hash, out_val, sze) - else - call map_get_many(map, hash, tmp_val, sze) - ! Conversion to double precision - do i=1,sze - out_val(i) = dble(tmp_val(i)) - enddo - endif -end - - integer*8 function get_mo_map_size() implicit none BEGIN_DOC @@ -711,7 +661,7 @@ integer function load_$ao_integrals(filename) end -SUBST [ ao_integrals_map, ao_integrals, ao_num ] -ao_integrals_map ; ao_integrals ; ao_num ;; -mo_integrals_map ; mo_integrals ; mo_tot_num ;; +SUBST [ ao_integrals_map, ao_integrals, ao_num , get_ao_bielec_integral ] +ao_integrals_map ; ao_integrals ; ao_num ; get_ao_bielec_integral ;; +mo_integrals_map ; mo_integrals ; mo_tot_num ; get_mo_bielec_integral ;; END_TEMPLATE diff --git a/src/Integrals_Bielec/mo_bi_integrals.irp.f b/src/Integrals_Bielec/mo_bi_integrals.irp.f index b56f3518..e581b536 100644 --- a/src/Integrals_Bielec/mo_bi_integrals.irp.f +++ b/src/Integrals_Bielec/mo_bi_integrals.irp.f @@ -20,15 +20,12 @@ end BEGIN_PROVIDER [ logical, mo_bielec_integrals_in_map ] - use map_module implicit none - 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 print*,'Reading the MO integrals' @@ -37,138 +34,9 @@ BEGIN_PROVIDER [ logical, mo_bielec_integrals_in_map ] 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 - 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) - 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 - + call add_integrals_to_map(full_ijkl_bitmask_4) 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) - 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) -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) - 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) - -end - subroutine add_integrals_to_map(mask_ijkl) use bitmasks implicit none @@ -212,50 +80,6 @@ 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) - 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)) - enddo - if(j==0)then - 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)) - enddo - if(j==0)then - 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)) - enddo - if(j==0)then - 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)) - enddo - if(j==0)then - return - endif size_buffer = min(ao_num*ao_num*ao_num,16000000) print*, 'Providing the molecular integrals ' @@ -264,13 +88,11 @@ subroutine add_integrals_to_map(mask_ijkl) call wall_time(wall_1) call cpu_time(cpu_1) - 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) & !$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, & @@ -288,9 +110,14 @@ 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 @@ -413,14 +240,9 @@ subroutine add_integrals_to_map(mask_ijkl) exit endif bielec_tmp_1(i) = c*bielec_tmp_3(i,j0,k0) - ! i1+=1 enddo - do i0 = 1, n_i - i = list_ijkl(i0,1) - if(i> min(k,j1-i1+list_ijkl(1,1)-1))then - exit - endif + do i = 1, min(k,j1-i1) if (abs(bielec_tmp_1(i)) < mo_integrals_threshold) then cycle endif @@ -442,7 +264,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 @@ -450,12 +272,14 @@ subroutine add_integrals_to_map(mask_ijkl) !$OMP END DO NOWAIT deallocate (bielec_tmp_1,bielec_tmp_2,bielec_tmp_3) - 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) @@ -472,585 +296,15 @@ 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), ')' -end - - -subroutine add_integrals_to_map_three_indices(mask_ijk) - use bitmasks - implicit none - - BEGIN_DOC - ! Adds integrals to tha MO map according to some bitmask - END_DOC - - integer(bit_kind), intent(in) :: mask_ijk(N_int,3) - - integer :: i,j,k,l - integer :: i0,j0,k0,l0 - double precision :: c, cpu_1, cpu_2, wall_1, wall_2, wall_0 - - integer, allocatable :: list_ijkl(:,:) - integer :: n_i, n_j, n_k - integer :: m - integer, allocatable :: bielec_tmp_0_idx(:) - real(integral_kind), allocatable :: bielec_tmp_0(:,:) - double precision, allocatable :: bielec_tmp_1(:) - double precision, allocatable :: bielec_tmp_2(:,:) - double precision, allocatable :: bielec_tmp_3(:,:,:) - !DEC$ ATTRIBUTES ALIGN : 64 :: bielec_tmp_1, bielec_tmp_2, bielec_tmp_3 - - integer :: n_integrals - integer :: size_buffer - integer(key_kind),allocatable :: buffer_i(:) - real(integral_kind),allocatable :: buffer_value(:) - real :: map_mb - - integer :: i1,j1,k1,l1, ii1, kmax, thread_num - integer :: i2,i3,i4 - double precision,parameter :: thr_coef = 1.d-10 - - PROVIDE ao_bielec_integrals_in_map mo_coef - - !Get list of MOs for i,j,k and l - !------------------------------- - - allocate(list_ijkl(mo_tot_num,4)) - 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) - 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)) - enddo - if(j==0)then - return + 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 - 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)) - enddo - if(j==0)then - 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)) - enddo - if(j==0)then - 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 +& - ao_num+ao_num*ao_num+ size_buffer*3)/(1024*1024), 'MB / core' - - call wall_time(wall_1) - call cpu_time(cpu_1) - 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 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 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, & - !$OMP mo_coef_transp_is_built, list_ijkl, & - !$OMP mo_coef_is_built, wall_1, & - !$OMP mo_coef,mo_integrals_threshold,mo_integrals_map) - n_integrals = 0 - wall_0 = wall_1 - allocate(bielec_tmp_3(mo_tot_num_align, n_j, n_k), & - bielec_tmp_1(mo_tot_num_align), & - bielec_tmp_0(ao_num,ao_num), & - bielec_tmp_0_idx(ao_num), & - bielec_tmp_2(mo_tot_num_align, n_j), & - buffer_i(size_buffer), & - buffer_value(size_buffer) ) - - thread_num = 0 - !$ thread_num = omp_get_thread_num() - !$OMP DO SCHEDULE(guided) - do l1 = 1,ao_num - !DEC$ VECTOR ALIGNED - bielec_tmp_3 = 0.d0 - do k1 = 1,ao_num - !DEC$ VECTOR ALIGNED - bielec_tmp_2 = 0.d0 - do j1 = 1,ao_num - call get_ao_bielec_integrals(j1,k1,l1,ao_num,bielec_tmp_0(1,j1)) - enddo - do j1 = 1,ao_num - kmax = 0 - do i1 = 1,ao_num - c = bielec_tmp_0(i1,j1) - if (c == 0.d0) then - cycle - endif - kmax += 1 - bielec_tmp_0(kmax,j1) = c - bielec_tmp_0_idx(kmax) = i1 - enddo - - if (kmax==0) then - cycle - endif - - !DEC$ VECTOR ALIGNED - bielec_tmp_1 = 0.d0 - ii1=1 - do ii1 = 1,kmax-4,4 - i1 = bielec_tmp_0_idx(ii1) - i2 = bielec_tmp_0_idx(ii1+1) - i3 = bielec_tmp_0_idx(ii1+2) - i4 = bielec_tmp_0_idx(ii1+3) - do i = list_ijkl(1,1), list_ijkl(n_i,1) - bielec_tmp_1(i) = bielec_tmp_1(i) + & - mo_coef_transp(i,i1) * bielec_tmp_0(ii1,j1) + & - mo_coef_transp(i,i2) * bielec_tmp_0(ii1+1,j1) + & - mo_coef_transp(i,i3) * bielec_tmp_0(ii1+2,j1) + & - mo_coef_transp(i,i4) * bielec_tmp_0(ii1+3,j1) - enddo ! i - enddo ! ii1 - - i2 = ii1 - do ii1 = i2,kmax - i1 = bielec_tmp_0_idx(ii1) - do i = list_ijkl(1,1), list_ijkl(n_i,1) - bielec_tmp_1(i) = bielec_tmp_1(i) + mo_coef_transp(i,i1) * bielec_tmp_0(ii1,j1) - enddo ! i - enddo ! ii1 - c = 0.d0 - - do i = list_ijkl(1,1), list_ijkl(n_i,1) - c = max(c,abs(bielec_tmp_1(i))) - if (c>mo_integrals_threshold) exit - enddo - if ( c < mo_integrals_threshold ) then - cycle - endif - - do j0 = 1, n_j - j = list_ijkl(j0,2) - c = mo_coef_transp(j,j1) - if (abs(c) < thr_coef) then - cycle - endif - do i = list_ijkl(1,1), list_ijkl(n_i,1) - bielec_tmp_2(i,j0) = bielec_tmp_2(i,j0) + c * bielec_tmp_1(i) - enddo ! i - enddo ! j - enddo !j1 - if ( maxval(abs(bielec_tmp_2)) < mo_integrals_threshold ) then - cycle - endif - - - do k0 = 1, n_k - k = list_ijkl(k0,3) - c = mo_coef_transp(k,k1) - if (abs(c) < thr_coef) then - cycle - endif - - do j0 = 1, n_j - j = list_ijkl(j0,2) - do i = list_ijkl(1,1), k - bielec_tmp_3(i,j0,k0) = bielec_tmp_3(i,j0,k0) + c* bielec_tmp_2(i,j0) - enddo!i - enddo !j - - enddo !k - enddo !k1 - - - - do l0 = 1,n_j - l = list_ijkl(l0,2) - c = mo_coef_transp(l,l1) - 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 - enddo - enddo - - do l0 = 1,n_j - l = list_ijkl(l0,2) - c = mo_coef_transp(l,l1) - 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 - 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 ', & - wall_2-wall_1, 's', map_mb(mo_integrals_map) ,'MB' - endif - endif - enddo - !$OMP END DO NOWAIT - deallocate (bielec_tmp_1,bielec_tmp_2,bielec_tmp_3) - - 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 - call map_unique(mo_integrals_map) - - call wall_time(wall_2) - call cpu_time(cpu_2) - integer*8 :: get_mo_map_size, mo_map_size - mo_map_size = get_mo_map_size() - - deallocate(list_ijkl) - - - print*,'Molecular integrals provided:' - print*,' Size of MO map ', map_mb(mo_integrals_map) ,'MB' - print*,' Number of MO integrals: ', mo_map_size - 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), ')' - end -subroutine add_integrals_to_map_no_exit_34(mask_ijkl) - use bitmasks - implicit none - - BEGIN_DOC - ! Adds integrals to tha MO map according to some bitmask - END_DOC - - integer(bit_kind), intent(in) :: mask_ijkl(N_int,4) - - integer :: i,j,k,l - integer :: i0,j0,k0,l0 - double precision :: c, cpu_1, cpu_2, wall_1, wall_2, wall_0 - - integer, allocatable :: list_ijkl(:,:) - integer :: n_i, n_j, n_k, n_l - integer, allocatable :: bielec_tmp_0_idx(:) - real(integral_kind), allocatable :: bielec_tmp_0(:,:) - double precision, allocatable :: bielec_tmp_1(:) - double precision, allocatable :: bielec_tmp_2(:,:) - double precision, allocatable :: bielec_tmp_3(:,:,:) - !DEC$ ATTRIBUTES ALIGN : 64 :: bielec_tmp_1, bielec_tmp_2, bielec_tmp_3 - - integer :: n_integrals - integer :: size_buffer - integer(key_kind),allocatable :: buffer_i(:) - real(integral_kind),allocatable :: buffer_value(:) - real :: map_mb - - integer :: i1,j1,k1,l1, ii1, kmax, thread_num - integer :: i2,i3,i4 - double precision,parameter :: thr_coef = 1.d-10 - - PROVIDE ao_bielec_integrals_in_map mo_coef - - !Get list of MOs for i,j,k and l - !------------------------------- - - allocate(list_ijkl(mo_tot_num,4)) - call bitstring_to_list( mask_ijkl(1,1), list_ijkl(1,1), n_i, N_int ) - 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 ) - - 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 +& - ao_num+ao_num*ao_num+ size_buffer*3)/(1024*1024), 'MB / core' - - call wall_time(wall_1) - call cpu_time(cpu_1) - - !$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 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, & - !$OMP mo_coef_transp_is_built, list_ijkl, & - !$OMP mo_coef_is_built, wall_1, & - !$OMP mo_coef,mo_integrals_threshold,mo_integrals_map) - n_integrals = 0 - wall_0 = wall_1 - allocate(bielec_tmp_3(mo_tot_num_align, n_j, n_k), & - bielec_tmp_1(mo_tot_num_align), & - bielec_tmp_0(ao_num,ao_num), & - bielec_tmp_0_idx(ao_num), & - bielec_tmp_2(mo_tot_num_align, n_j), & - buffer_i(size_buffer), & - buffer_value(size_buffer) ) - - thread_num = 0 - !$ thread_num = omp_get_thread_num() - !$OMP DO SCHEDULE(guided) - do l1 = 1,ao_num - !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 - !DEC$ VECTOR ALIGNED - bielec_tmp_2 = 0.d0 - do j1 = 1,ao_num - call get_ao_bielec_integrals(j1,k1,l1,ao_num,bielec_tmp_0(1,j1)) - ! call compute_ao_bielec_integrals(j1,k1,l1,ao_num,bielec_tmp_0(1,j1)) - enddo - do j1 = 1,ao_num - kmax = 0 - do i1 = 1,ao_num - c = bielec_tmp_0(i1,j1) - if (c == 0.d0) then - cycle - endif - kmax += 1 - bielec_tmp_0(kmax,j1) = c - bielec_tmp_0_idx(kmax) = i1 - enddo - - if (kmax==0) then - cycle - endif - - !DEC$ VECTOR ALIGNED - bielec_tmp_1 = 0.d0 - ii1=1 - do ii1 = 1,kmax-4,4 - i1 = bielec_tmp_0_idx(ii1) - i2 = bielec_tmp_0_idx(ii1+1) - i3 = bielec_tmp_0_idx(ii1+2) - i4 = bielec_tmp_0_idx(ii1+3) - do i = list_ijkl(1,1), list_ijkl(n_i,1) - bielec_tmp_1(i) = bielec_tmp_1(i) + & - mo_coef_transp(i,i1) * bielec_tmp_0(ii1,j1) + & - mo_coef_transp(i,i2) * bielec_tmp_0(ii1+1,j1) + & - mo_coef_transp(i,i3) * bielec_tmp_0(ii1+2,j1) + & - mo_coef_transp(i,i4) * bielec_tmp_0(ii1+3,j1) - enddo ! i - enddo ! ii1 - - i2 = ii1 - do ii1 = i2,kmax - i1 = bielec_tmp_0_idx(ii1) - do i = list_ijkl(1,1), list_ijkl(n_i,1) - bielec_tmp_1(i) = bielec_tmp_1(i) + mo_coef_transp(i,i1) * bielec_tmp_0(ii1,j1) - enddo ! i - enddo ! ii1 - c = 0.d0 - - do i = list_ijkl(1,1), list_ijkl(n_i,1) - c = max(c,abs(bielec_tmp_1(i))) - if (c>mo_integrals_threshold) exit - enddo - if ( c < mo_integrals_threshold ) then - cycle - endif - - do j0 = 1, n_j - j = list_ijkl(j0,2) - c = mo_coef_transp(j,j1) - if (abs(c) < thr_coef) then - cycle - endif - do i = list_ijkl(1,1), list_ijkl(n_i,1) - bielec_tmp_2(i,j0) = bielec_tmp_2(i,j0) + c * bielec_tmp_1(i) - enddo ! i - enddo ! j - enddo !j1 - if ( maxval(abs(bielec_tmp_2)) < mo_integrals_threshold ) then - cycle - endif - - - do k0 = 1, n_k - k = list_ijkl(k0,3) - c = mo_coef_transp(k,k1) - if (abs(c) < thr_coef) then - cycle - endif - - do j0 = 1, n_j - j = list_ijkl(j0,2) - do i = list_ijkl(1,1), k - bielec_tmp_3(i,j0,k0) = bielec_tmp_3(i,j0,k0) + c* bielec_tmp_2(i,j0) - enddo!i - enddo !j - - enddo !k - enddo !k1 - - - - do l0 = 1,n_l - l = list_ijkl(l0,4) - c = mo_coef_transp(l,l1) - if (abs(c) < thr_coef) then - cycle - endif - j1 = ishft((l*l-l),-1) - do j0 = 1, n_j - j = list_ijkl(j0,2) - if (j > l) then - exit - endif - j1 += 1 - do k0 = 1, n_k - k = list_ijkl(k0,3) - i1 = ishft((k*k-k),-1) - bielec_tmp_1 = 0.d0 - 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 - 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) - !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 - 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 ', & - wall_2-wall_1, 's', map_mb(mo_integrals_map) ,'MB' - endif - endif - enddo - !$OMP END DO NOWAIT - deallocate (bielec_tmp_1,bielec_tmp_2,bielec_tmp_3) - - 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) - call cpu_time(cpu_2) - integer*8 :: get_mo_map_size, mo_map_size - mo_map_size = get_mo_map_size() - - deallocate(list_ijkl) - - - print*,'Molecular integrals provided:' - print*,' Size of MO map ', map_mb(mo_integrals_map) ,'MB' - print*,' Number of MO integrals: ', mo_map_size - 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), ')' - - -end @@ -1087,7 +341,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), & @@ -1130,9 +384,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 @@ -1185,155 +439,6 @@ end mo_bielec_integral_jj_anti_from_ao = mo_bielec_integral_jj_from_ao - mo_bielec_integral_jj_exchange_from_ao -END_PROVIDER - - BEGIN_PROVIDER [ double precision, mo_bielec_integral_vv_from_ao, (mo_tot_num_align,mo_tot_num) ] -&BEGIN_PROVIDER [ double precision, mo_bielec_integral_vv_exchange_from_ao, (mo_tot_num_align,mo_tot_num) ] -&BEGIN_PROVIDER [ double precision, mo_bielec_integral_vv_anti_from_ao, (mo_tot_num_align,mo_tot_num) ] - implicit none - BEGIN_DOC - ! mo_bielec_integral_vv_from_ao(i,j) = J_ij - ! mo_bielec_integral_vv_exchange_from_ao(i,j) = J_ij - ! mo_bielec_integral_vv_anti_from_ao(i,j) = J_ij - K_ij - ! but only for the virtual orbitals - END_DOC - - integer :: i,j,p,q,r,s - integer :: i0,j0 - double precision :: c - real(integral_kind) :: integral - integer :: n, pp - real(integral_kind), allocatable :: int_value(:) - integer, allocatable :: int_idx(:) - - double precision, allocatable :: iqrs(:,:), iqsr(:,:), iqis(:), iqri(:) - - if (.not.do_direct_integrals) then - PROVIDE ao_bielec_integrals_in_map mo_coef - endif - - mo_bielec_integral_vv_from_ao = 0.d0 - mo_bielec_integral_vv_exchange_from_ao = 0.d0 - - !DIR$ ATTRIBUTES ALIGN : $IRP_ALIGN :: iqrs, iqsr - - - !$OMP PARALLEL DEFAULT(NONE) & - !$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 REDUCTION(+:mo_bielec_integral_vv_from_ao,mo_bielec_integral_vv_exchange_from_ao) - - allocate( int_value(ao_num), int_idx(ao_num), & - iqrs(mo_tot_num_align,ao_num), iqis(mo_tot_num), iqri(mo_tot_num),& - iqsr(mo_tot_num_align,ao_num) ) - - !$OMP DO SCHEDULE (guided) - do s=1,ao_num - do q=1,ao_num - - do j=1,ao_num - !DIR$ VECTOR ALIGNED - do i0=1,n_virt_orb - i = list_virt(i0) - iqrs(i,j) = 0.d0 - iqsr(i,j) = 0.d0 - enddo - enddo - - if (do_direct_integrals) then - double precision :: ao_bielec_integral - do r=1,ao_num - call compute_ao_bielec_integrals(q,r,s,ao_num,int_value) - do p=1,ao_num - integral = int_value(p) - if (abs(integral) > ao_integrals_threshold) then - !DIR$ VECTOR ALIGNED - do i0=1,n_virt_orb - i = list_virt(i0) - iqrs(i,r) += mo_coef_transp(i,p) * integral - enddo - endif - enddo - call compute_ao_bielec_integrals(q,s,r,ao_num,int_value) - do p=1,ao_num - integral = int_value(p) - if (abs(integral) > ao_integrals_threshold) then - !DIR$ VECTOR ALIGNED - do i0=1,n_virt_orb - i =list_virt(i0) - iqsr(i,r) += mo_coef_transp(i,p) * integral - enddo - 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 - p = int_idx(pp) - integral = int_value(pp) - if (abs(integral) > ao_integrals_threshold) then - !DIR$ VECTOR ALIGNED - do i0=1,n_virt_orb - i =list_virt(i0) - iqrs(i,r) += mo_coef_transp(i,p) * integral - enddo - endif - enddo - call get_ao_bielec_integrals_non_zero(q,s,r,ao_num,int_value,int_idx,n) - do pp=1,n - p = int_idx(pp) - integral = int_value(pp) - if (abs(integral) > ao_integrals_threshold) then - !DIR$ VECTOR ALIGNED - do i0=1,n_virt_orb - i = list_virt(i0) - iqsr(i,r) += mo_coef_transp(i,p) * integral - enddo - endif - enddo - enddo - endif - iqis = 0.d0 - iqri = 0.d0 - do r=1,ao_num - !DIR$ VECTOR ALIGNED - do i0=1,n_virt_orb - i = list_virt(i0) - iqis(i) += mo_coef_transp(i,r) * iqrs(i,r) - iqri(i) += mo_coef_transp(i,r) * iqsr(i,r) - enddo - enddo - do i0=1,n_virt_orb - i= list_virt(i0) - !DIR$ VECTOR ALIGNED - do j0=1,n_virt_orb - j = list_virt(j0) - c = mo_coef_transp(j,q)*mo_coef_transp(j,s) - mo_bielec_integral_vv_from_ao(j,i) += c * iqis(i) - mo_bielec_integral_vv_exchange_from_ao(j,i) += c * iqri(i) - enddo - enddo - - enddo - enddo - !$OMP END DO NOWAIT - deallocate(iqrs,iqsr,int_value,int_idx) - !$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*, '**********' - - END_PROVIDER @@ -1351,14 +456,55 @@ END_PROVIDER double precision :: get_mo_bielec_integral PROVIDE mo_bielec_integrals_in_map + mo_bielec_integral_jj = 0.d0 mo_bielec_integral_jj_exchange = 0.d0 - 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) + enddo + enddo + +END_PROVIDER + + BEGIN_PROVIDER [ double precision, mo_bielec_integral_mipi, (mo_tot_num_align,mo_tot_num,mo_tot_num) ] +&BEGIN_PROVIDER [ double precision, mo_bielec_integral_mipi_anti, (mo_tot_num_align,mo_tot_num,mo_tot_num) ] + implicit none + BEGIN_DOC + ! and - . Indices are (i,m,p) + END_DOC + + integer :: m,i,p + double precision :: get_mo_bielec_integral + + PROVIDE mo_bielec_integrals_in_map + + mo_bielec_integral_mipi = 0.d0 + mo_bielec_integral_mipi_anti = 0.d0 + do p=1,mo_tot_num + do m=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_mipi(i,m,p) = get_mo_bielec_integral(m,i,p,i,mo_integrals_map) + mo_bielec_integral_mipi_anti(i,m,p) = mo_bielec_integral_mipi(i,m,p) - get_mo_bielec_integral(m,i,i,p,mo_integrals_map) + enddo + enddo + enddo + +END_PROVIDER + +BEGIN_PROVIDER [ double precision, mo_bielec_integral_schwartz,(mo_tot_num,mo_tot_num) ] + implicit none + BEGIN_DOC + ! Needed to compute Schwartz inequalities + END_DOC + + integer :: i,k + + do i=1,mo_tot_num + do k=1,mo_tot_num + mo_bielec_integral_schwartz(k,i) = dsqrt(mo_bielec_integral_jj(k,i)) enddo enddo @@ -1371,15 +517,15 @@ subroutine clear_mo_map ! Frees the memory of the MO map END_DOC call map_deinit(mo_integrals_map) - FREE mo_integrals_map mo_bielec_integral_jj mo_bielec_integral_jj_anti + FREE mo_integrals_map mo_bielec_integral_schwartz 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_schwartz 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_Monoelec/README.rst b/src/Integrals_Monoelec/README.rst index 7e926fd5..d92cea0a 100644 --- a/src/Integrals_Monoelec/README.rst +++ b/src/Integrals_Monoelec/README.rst @@ -102,7 +102,7 @@ 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 @@ -115,7 +115,7 @@ Documentation Local pseudo-potential -`ao_pseudo_integral_non_local `_ +`ao_pseudo_integral_non_local `_ Local pseudo-potential @@ -153,19 +153,19 @@ Documentation 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 @@ -200,7 +200,7 @@ Documentation interaction nuclear electron on the MO basis -`mo_nucl_elec_integral_per_atom `_ +`mo_nucl_elec_integral_per_atom `_ mo_nucl_elec_integral_per_atom(i,j,k) = - where Rk is the geometry of the kth atom @@ -227,7 +227,7 @@ Documentation array of the integrals of MO_i * z^2 MO_j -`nai_pol_mult `_ +`nai_pol_mult `_ Undocumented @@ -259,27 +259,27 @@ Documentation Undocumented -`pseudo_dz_k_transp `_ +`pseudo_dz_k_transp `_ Transposed arrays for pseudopotentials -`pseudo_dz_kl_transp `_ +`pseudo_dz_kl_transp `_ Transposed arrays for pseudopotentials -`pseudo_n_k_transp `_ +`pseudo_n_k_transp `_ Transposed arrays for pseudopotentials -`pseudo_n_kl_transp `_ +`pseudo_n_kl_transp `_ Transposed arrays for pseudopotentials -`pseudo_v_k_transp `_ +`pseudo_v_k_transp `_ Transposed arrays for pseudopotentials -`pseudo_v_kl_transp `_ +`pseudo_v_kl_transp `_ Transposed arrays for pseudopotentials @@ -299,23 +299,23 @@ Documentation 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 diff --git a/src/MO_Basis/mo_permutation.irp.f b/src/MO_Basis/mo_permutation.irp.f deleted file mode 100644 index 72f132d7..00000000 --- a/src/MO_Basis/mo_permutation.irp.f +++ /dev/null @@ -1,20 +0,0 @@ -program permut_mos - implicit none - integer :: mo1,mo2 - integer :: i,j,k,l - double precision :: mo_coef_tmp(ao_num_align,2) - print*,'Which MOs would you like to change ?' - read(5,*)mo1,mo2 - print*,'' - do i= 1,ao_num - mo_coef_tmp(i,1) = mo_coef(i,mo1) - mo_coef_tmp(i,2) = mo_coef(i,mo2) - enddo - do i = 1,ao_num - mo_coef(i,mo1) = mo_coef_tmp(i,2) - mo_coef(i,mo2) = mo_coef_tmp(i,1) - enddo - touch mo_coef - call save_mos - -end diff --git a/src/MO_Basis/print_aos.irp.f b/src/MO_Basis/print_aos.irp.f deleted file mode 100644 index f6b3bedf..00000000 --- a/src/MO_Basis/print_aos.irp.f +++ /dev/null @@ -1,53 +0,0 @@ -program pouet - implicit none - integer :: i,j,k - double precision :: r(3) - double precision, allocatable :: aos_array(:),mos_array(:),ao_ortho_array(:) - allocate(aos_array(ao_num),mos_array(mo_tot_num), ao_ortho_array(ao_num)) - integer :: nx,ny - double precision :: interval_x - double precision :: xmin,xmax - double precision :: dx - - double precision :: interval_y - double precision :: ymin,ymax - double precision :: dy - - double precision :: val_max - -!do i = 1, ao_num -! write(41,'(100(F16.10,X))'),ao_ortho_canonical_overlap(i,:) -!enddo - -!stop - - - xmin = nucl_coord(1,1)-6.d0 - xmax = nucl_coord(2,1)+6.d0 - interval_x = xmax - xmin -!interval_x = nucl_dist(1,3) - nx = 500 - dx = interval_x/dble(nx) -!dx = dabs(interval_x)/dble(nx) * 1.d0/sqrt(2.d0) - - r = 0.d0 - r(3) = xmin -!r(2) = nucl_coord(1,2) -!r(3) = nucl_coord(1,3) -!r(1) = nucl_coord(2,1) -!r(2) = 1.D0 -!r(3) = nucl_coord(2,3) - double precision :: dr(3) -!dr = 0.d0 -!dr(1) = -dx -!dr(3) = dx - do j = 1, nx+1 - call give_all_mos_at_r(r,mos_array) - write(37,'(100(F16.10,X))') r(3),mos_array(1)*mos_array(1) , mos_array(2)*mos_array(2), mos_array(1)*mos_array(2) - write(38,'(100(F16.10,X))') r(3),mos_array(1), mos_array(2), mos_array(1)*mos_array(2) -! write(38,'(100(F16.10,X))') r(3),mos_array(10), mos_array(2) - 0.029916d0 * mos_array(10),mos_array(2) + 0.029916d0 * mos_array(10) - r(3) += dx -! r += dr - enddo - deallocate(aos_array,mos_array, ao_ortho_array) -end diff --git a/src/MO_Basis/print_mo_in_space.irp.f b/src/MO_Basis/print_mo_in_space.irp.f deleted file mode 100644 index a5a324ed..00000000 --- a/src/MO_Basis/print_mo_in_space.irp.f +++ /dev/null @@ -1,50 +0,0 @@ -program pouet - implicit none - integer :: i,j,k - double precision :: r(3) - double precision, allocatable :: aos_array(:),mos_array(:),ao_ortho_array(:) - allocate(aos_array(ao_num),mos_array(mo_tot_num), ao_ortho_array(ao_num)) - integer :: nx,ny - double precision :: interval_x - double precision :: xmin,xmax - double precision :: dx - - double precision :: interval_y - double precision :: ymin,ymax - double precision :: dy - - double precision :: val_max - -!do i = 1, ao_num -! write(41,'(100(F16.10,X))'),ao_ortho_canonical_overlap(i,:) -!enddo - -!stop - - - xmin = -4.d0 - xmax = 4.d0 - interval_x = xmax - xmin - nx = 100 - dx = dabs(interval_x)/dble(nx) - - r = 0.d0 -!r(3) = xmin - r(1) = xmin - val_max = 0.d0 - do j = 1, nx -! call give_all_aos_at_r(r,aos_array) - call give_all_mos_at_r(r,mos_array) - write(36,'(100(F16.10,X))') r(1), mos_array(1), mos_array(2), mos_array(3), mos_array(17), mos_array(23) - !write(36,'(100(F16.10,X))') r(1), mos_array(1), mos_array(2), mos_array(4) - !write(37,'(100(F16.10,X))') r(1),mos_array(1) * mos_array(2), mos_array(4)*mos_array(2) -! if(val_max.le.aos_array(1) * aos_array(2) )then -! val_max = aos_array(1) * aos_array(2) -! endif - r(1) += dx -! r(3) += dx - enddo -!write(40,'(100(F16.10,X))')nucl_coord(1,2),nucl_coord(1,3),val_max * 1.5d0 -!write(41,'(100(F16.10,X))')nucl_coord(2,2),nucl_coord(2,3),val_max * 1.5d0 - deallocate(aos_array,mos_array, ao_ortho_array) -end diff --git a/src/MO_Basis/utils.irp.f b/src/MO_Basis/utils.irp.f index 0f338877..aa2feead 100644 --- a/src/MO_Basis/utils.irp.f +++ b/src/MO_Basis/utils.irp.f @@ -268,26 +268,3 @@ subroutine mo_sort_by_observable(observable,label) end -subroutine give_all_mos_at_r(r,mos_array) - implicit none - double precision, intent(in) :: r(3) - double precision, intent(out) :: mos_array(mo_tot_num) - call give_specific_mos_at_r(r,mos_array, mo_coef) -end - -subroutine give_specific_mos_at_r(r,mos_array, mo_coef_specific) - implicit none - double precision, intent(in) :: r(3) - double precision, intent(in) :: mo_coef_specific(ao_num_align, mo_tot_num) - double precision, intent(out) :: mos_array(mo_tot_num) - double precision :: aos_array(ao_num),accu - integer :: i,j - call give_all_aos_at_r(r,aos_array) - do i = 1, mo_tot_num - accu = 0.d0 - do j = 1, ao_num - accu += mo_coef_specific(j,i) * aos_array(j) - enddo - mos_array(i) = accu - enddo -end diff --git a/src/Nuclei/README.rst b/src/Nuclei/README.rst index 356b8e9e..bf7e6f52 100644 --- a/src/Nuclei/README.rst +++ b/src/Nuclei/README.rst @@ -38,7 +38,7 @@ Documentation Array of the name of element, sorted by nuclear charge (integer) -`nucl_charge `_ +`nucl_charge `_ Nuclear charges diff --git a/src/Nuclei/atomic_radii.irp.f b/src/Nuclei/atomic_radii.irp.f deleted file mode 100644 index 7b04a97b..00000000 --- a/src/Nuclei/atomic_radii.irp.f +++ /dev/null @@ -1,112 +0,0 @@ -BEGIN_PROVIDER [ double precision, slater_bragg_radii, (100)] - implicit none - BEGIN_DOC - ! atomic radii in Angstrom defined in table I of JCP 41, 3199 (1964) Slater - ! execpt for the Hydrogen atom where we took the value of Becke (1988, JCP) - END_DOC - - slater_bragg_radii = 0.d0 - - slater_bragg_radii(1) = 0.35d0 - slater_bragg_radii(2) = 0.35d0 - - slater_bragg_radii(3) = 1.45d0 - slater_bragg_radii(4) = 1.05d0 - - slater_bragg_radii(5) = 0.85d0 - slater_bragg_radii(6) = 0.70d0 - slater_bragg_radii(7) = 0.65d0 - slater_bragg_radii(8) = 0.60d0 - slater_bragg_radii(9) = 0.50d0 - slater_bragg_radii(10) = 0.45d0 - - slater_bragg_radii(11) = 1.80d0 - slater_bragg_radii(12) = 1.70d0 - - slater_bragg_radii(13) = 1.50d0 - slater_bragg_radii(14) = 1.25d0 - slater_bragg_radii(15) = 1.10d0 - slater_bragg_radii(16) = 1.00d0 - slater_bragg_radii(17) = 1.00d0 - slater_bragg_radii(18) = 1.00d0 - - slater_bragg_radii(19) = 2.20d0 - slater_bragg_radii(20) = 1.80d0 - - - slater_bragg_radii(21) = 1.60d0 - slater_bragg_radii(22) = 1.40d0 - slater_bragg_radii(23) = 1.34d0 - slater_bragg_radii(24) = 1.40d0 - slater_bragg_radii(25) = 1.40d0 - slater_bragg_radii(26) = 1.40d0 - slater_bragg_radii(27) = 1.35d0 - slater_bragg_radii(28) = 1.35d0 - slater_bragg_radii(29) = 1.35d0 - slater_bragg_radii(30) = 1.35d0 - - slater_bragg_radii(31) = 1.30d0 - slater_bragg_radii(32) = 1.25d0 - slater_bragg_radii(33) = 1.15d0 - slater_bragg_radii(34) = 1.15d0 - slater_bragg_radii(35) = 1.15d0 - slater_bragg_radii(36) = 1.15d0 - -END_PROVIDER - -BEGIN_PROVIDER [double precision, slater_bragg_radii_ua, (100)] - implicit none - integer :: i - do i = 1, 100 - slater_bragg_radii_ua(i) = slater_bragg_radii(i) * 1.889725989d0 - enddo -END_PROVIDER - -BEGIN_PROVIDER [double precision, slater_bragg_radii_per_atom, (nucl_num)] - implicit none - integer :: i - do i = 1, nucl_num - slater_bragg_radii_per_atom(i) = slater_bragg_radii(int(nucl_charge(i))) - enddo -END_PROVIDER - -BEGIN_PROVIDER [double precision, slater_bragg_radii_per_atom_ua, (nucl_num)] - implicit none - integer :: i - do i = 1, nucl_num - slater_bragg_radii_per_atom_ua(i) = slater_bragg_radii_ua(int(nucl_charge(i))) - enddo -END_PROVIDER - -BEGIN_PROVIDER [double precision, slater_bragg_type_inter_distance, (nucl_num, nucl_num)] - implicit none - integer :: i,j - double precision :: xhi_tmp,u_ij - slater_bragg_type_inter_distance = 0.d0 - do i = 1, nucl_num - do j = i+1, nucl_num - xhi_tmp = slater_bragg_radii_per_atom(i) / slater_bragg_radii_per_atom(j) - u_ij = (xhi_tmp - 1.d0 ) / (xhi_tmp +1.d0) - slater_bragg_type_inter_distance(i,j) = u_ij / (u_ij * u_ij - 1.d0) - enddo - enddo -END_PROVIDER - -BEGIN_PROVIDER [double precision, slater_bragg_type_inter_distance_ua, (nucl_num, nucl_num)] - implicit none - integer :: i,j - double precision :: xhi_tmp,u_ij - slater_bragg_type_inter_distance_ua = 0.d0 - do i = 1, nucl_num - do j = i+1, nucl_num - xhi_tmp = slater_bragg_radii_per_atom_ua(i) / slater_bragg_radii_per_atom_ua(j) - u_ij = (xhi_tmp - 1.d0 ) / (xhi_tmp +1.d0) - slater_bragg_type_inter_distance_ua(i,j) = u_ij / (u_ij * u_ij - 1.d0) - if(slater_bragg_type_inter_distance_ua(i,j).gt.0.5d0)then - slater_bragg_type_inter_distance_ua(i,j) = 0.5d0 - else if( slater_bragg_type_inter_distance_ua(i,j) .le.-0.5d0)then - slater_bragg_type_inter_distance_ua(i,j) = -0.5d0 - endif - enddo - enddo -END_PROVIDER diff --git a/src/Utils/LinearAlgebra.irp.f b/src/Utils/LinearAlgebra.irp.f index 44a15ddf..e44e8c2c 100644 --- a/src/Utils/LinearAlgebra.irp.f +++ b/src/Utils/LinearAlgebra.irp.f @@ -148,42 +148,17 @@ subroutine ortho_qr(A,LDA,m,n) 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=2*WORK(1) + 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_qr_unblocked(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 :: info - integer, allocatable :: jpvt(:) - double precision, allocatable :: tau(:), work(:) - - allocate (jpvt(n), tau(n), work(n)) - call dgeqr2( m, n, A, LDA, TAU, WORK, INFO ) - call dorg2r(m, n, n, A, LDA, tau, WORK, INFO) - deallocate(WORK,jpvt,tau) -end - subroutine ortho_lowdin(overlap,LDA,N,C,LDC,m) implicit none BEGIN_DOC @@ -469,12 +444,7 @@ subroutine lapack_diag(eigvalues,eigvectors,H,nmax,n) print *, irp_here, ': DSYEV: the ',-info,'-th argument had an illegal value' stop 2 else if( info > 0 ) then - write(*,*)'DSYEV Failed : ', info - do i=1,n - do j=1,n - print *, H(i,j) - enddo - enddo + write(*,*)'DSYEV Failed' stop 1 end if @@ -636,18 +606,3 @@ end -subroutine matrix_vector_product(u0,u1,matrix,sze,lda) - implicit none - BEGIN_DOC -! performs u1 += u0 * matrix - END_DOC - integer, intent(in) :: sze,lda - double precision, intent(in) :: u0(sze) - double precision, intent(inout) :: u1(sze) - double precision, intent(in) :: matrix(lda,sze) - integer :: i,j - integer :: incx,incy - incx = 1 - incy = 1 - call dsymv('U', sze, 1.d0, matrix, lda, u0, incx, 1.d0, u1, incy) -end diff --git a/src/Utils/README.rst b/src/Utils/README.rst index 902a5250..03ec80f5 100644 --- a/src/Utils/README.rst +++ b/src/Utils/README.rst @@ -28,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 @@ -55,19 +55,19 @@ Documentation Binomial coefficients -`dble_fact `_ +`dble_fact `_ Undocumented -`dble_fact_even `_ +`dble_fact_even `_ n!! -`dble_fact_odd `_ +`dble_fact_odd `_ n!! -`dble_logfact `_ +`dble_logfact `_ n!! @@ -93,10 +93,6 @@ Documentation contains the new order of the elements. -`dtranspose `_ - Transpose input matrix A into output matrix B - - `erf0 `_ Undocumented @@ -110,11 +106,11 @@ Documentation n! -`fact_inv `_ +`fact_inv `_ 1/n! -`find_rotation `_ +`find_rotation `_ Find A.C = B @@ -140,7 +136,7 @@ Documentation Undocumented -`get_pseudo_inverse `_ +`get_pseudo_inverse `_ Find C = A^-1 @@ -376,7 +372,7 @@ Documentation to be in integer*8 format -`inv_int `_ +`inv_int `_ 1/i @@ -412,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 @@ -423,7 +419,7 @@ Documentation .br -`lapack_diag_s2 `_ +`lapack_diag_s2 `_ Diagonalize matrix H .br H is untouched between input and ouptut @@ -434,7 +430,7 @@ Documentation .br -`lapack_diagd `_ +`lapack_diagd `_ Diagonalize matrix H .br H is untouched between input and ouptut @@ -445,7 +441,7 @@ Documentation .br -`lapack_partial_diag `_ +`lapack_partial_diag `_ Diagonalize matrix H .br H is untouched between input and ouptut @@ -456,33 +452,25 @@ Documentation .br -`logfact `_ +`logfact `_ n! -`lowercase `_ +`lowercase `_ Transform to lower case -`map_load_from_disk `_ - Undocumented - - -`map_save_to_disk `_ - Undocumented - - `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. -`nproc `_ +`nproc `_ Number of current OpenMP threads @@ -504,7 +492,7 @@ Documentation .br -`ortho_lowdin `_ +`ortho_lowdin `_ Compute C_new=C_old.S^-1/2 orthogonalization. .br overlap : overlap matrix @@ -522,19 +510,6 @@ Documentation .br -`ortho_qr `_ - Orthogonalization using Q.R factorization - .br - A : matrix to orthogonalize - .br - LDA : leftmost dimension of A - .br - n : Number of rows of A - .br - m : Number of columns of A - .br - - `overlap_a_b_c `_ Undocumented @@ -632,7 +607,7 @@ Documentation to be in integer*8 format -`set_zero_extra_diag `_ +`set_zero_extra_diag `_ Undocumented @@ -659,22 +634,18 @@ Documentation .br -`transpose `_ - Transpose input matrix A into output matrix B - - -`u_dot_u `_ +`u_dot_u `_ Compute -`u_dot_v `_ +`u_dot_v `_ Compute -`wall_time `_ +`wall_time `_ The equivalent of cpu_time, but for the wall time. -`write_git_log `_ +`write_git_log `_ Write the last git commit in file iunit. diff --git a/src/Utils/angular_integration.irp.f b/src/Utils/angular_integration.irp.f deleted file mode 100644 index 1efd4abc..00000000 --- a/src/Utils/angular_integration.irp.f +++ /dev/null @@ -1,2264 +0,0 @@ -BEGIN_PROVIDER [integer, degree_max_integration_lebedev] - BEGIN_DOC -! integrate correctly a polynom of order "degree_max_integration_lebedev" - ! needed for the angular integration according to LEBEDEV formulae - END_DOC - implicit none - degree_max_integration_lebedev= 15 - -END_PROVIDER - -BEGIN_PROVIDER [integer, n_points_integration_angular_lebedev] - BEGIN_DOC -! Number of points needed for the angular integral - END_DOC - implicit none - if (degree_max_integration_lebedev == 3)then - n_points_integration_angular_lebedev = 6 - else if (degree_max_integration_lebedev == 5)then - n_points_integration_angular_lebedev = 14 - else if (degree_max_integration_lebedev == 7)then - n_points_integration_angular_lebedev = 26 - else if (degree_max_integration_lebedev == 9)then - n_points_integration_angular_lebedev = 38 - else if (degree_max_integration_lebedev == 11)then - n_points_integration_angular_lebedev = 50 - else if (degree_max_integration_lebedev == 13)then - n_points_integration_angular_lebedev = 74 - else if (degree_max_integration_lebedev == 15)then - n_points_integration_angular_lebedev = 86 - else if (degree_max_integration_lebedev == 17)then - n_points_integration_angular_lebedev = 110 - else if (degree_max_integration_lebedev == 19)then - n_points_integration_angular_lebedev = 146 - else if (degree_max_integration_lebedev == 21)then - n_points_integration_angular_lebedev = 170 - endif - -END_PROVIDER - - BEGIN_PROVIDER [double precision, theta_angular_integration_lebedev, (n_points_integration_angular_lebedev)] -&BEGIN_PROVIDER [double precision, phi_angular_integration_lebedev, (n_points_integration_angular_lebedev)] -&BEGIN_PROVIDER [double precision, weights_angular_integration_lebedev, (n_points_integration_angular_lebedev)] - implicit none - BEGIN_DOC -! Theta phi values together with the weights values for the angular integration : -! integral [dphi,dtheta] f(x,y,z) = 4 * pi * sum (1 64) + do while (istep > 16) idx = ibegin + istep ! TODO : Cache misses if (cache_key < X(idx)) then @@ -670,8 +669,8 @@ subroutine search_key_big_interval(key,X,sze,idx,ibegin_in,iend_in) endif enddo idx = ibegin - if (min(iend_in,sze) > ibegin+64) then - iend = ibegin+64 + if (min(iend_in,sze) > ibegin+16) then + iend = ibegin+16 do while (cache_key > X(idx)) idx = idx+1 end do @@ -740,7 +739,7 @@ subroutine search_key_value_big_interval(key,value,X,Y,sze,idx,ibegin_in,iend_in istep = ishft(iend-ibegin,-1) idx = ibegin + istep - do while (istep > 64) + do while (istep > 16) idx = ibegin + istep if (cache_key < X(idx)) then iend = idx @@ -781,8 +780,8 @@ subroutine search_key_value_big_interval(key,value,X,Y,sze,idx,ibegin_in,iend_in enddo idx = ibegin value = Y(idx) - if (min(iend_in,sze) > ibegin+64) then - iend = ibegin+64 + if (min(iend_in,sze) > ibegin+16) then + iend = ibegin+16 do while (cache_key > X(idx)) idx = idx+1 value = Y(idx) diff --git a/src/ZMQ/README.rst b/src/ZMQ/README.rst index b73dc42d..187af23e 100644 --- a/src/ZMQ/README.rst +++ b/src/ZMQ/README.rst @@ -21,67 +21,59 @@ Documentation .. by the `update_README.py` script. -`add_task_to_taskserver `_ +`add_task_to_taskserver `_ Get a task from the task server -`connect_to_taskserver `_ +`connect_to_taskserver `_ Connect to the task server and obtain the worker ID -`disconnect_from_taskserver `_ +`disconnect_from_taskserver `_ Disconnect from the task server -`end_parallel_job `_ +`end_parallel_job `_ End a new parallel job with name 'name'. The slave tasks execute subroutine 'slave' -`end_zmq_pair_socket `_ +`end_zmq_pair_socket `_ Terminate socket on which the results are sent. -`end_zmq_pull_socket `_ +`end_zmq_pull_socket `_ Terminate socket on which the results are sent. -`end_zmq_push_socket `_ +`end_zmq_push_socket `_ Terminate socket on which the results are sent. -`end_zmq_sub_socket `_ - Terminate socket on which the results are sent. - - -`end_zmq_to_qp_run_socket `_ +`end_zmq_to_qp_run_socket `_ Terminate the socket from the application to qp_run -`get_task_from_taskserver `_ +`get_task_from_taskserver `_ Get a task from the task server -`new_parallel_job `_ +`new_parallel_job `_ Start a new parallel job with name 'name'. The slave tasks execute subroutine 'slave' -`new_zmq_pair_socket `_ +`new_zmq_pair_socket `_ Socket on which the collector and the main communicate -`new_zmq_pull_socket `_ +`new_zmq_pull_socket `_ Socket on which the results are sent. If thread is 1, use inproc -`new_zmq_push_socket `_ +`new_zmq_push_socket `_ Socket on which the results are sent. If thread is 1, use inproc -`new_zmq_sub_socket `_ - Socket to read the state published by the Task server - - -`new_zmq_to_qp_run_socket `_ +`new_zmq_to_qp_run_socket `_ Socket on which the qp_run process replies @@ -90,41 +82,29 @@ Documentation Example : tcp://130.120.229.139:12345 -`reset_zmq_addresses `_ - Socket which pulls the results (2) +`reset_zmq_addresses `_ + Undocumented -`switch_qp_run_to_master `_ +`switch_qp_run_to_master `_ Address of the master qp_run socket Example : tcp://130.120.229.139:12345 -`task_done_to_taskserver `_ +`task_done_to_taskserver `_ Get a task from the task server -`wait_for_next_state `_ - Undocumented - - -`wait_for_state `_ - Wait for the ZMQ state to be ready - - -`wait_for_states `_ - Wait for the ZMQ state to be ready - - `zmq_context `_ Context for the ZeroMQ library -`zmq_delete_task `_ +`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 `_ +`zmq_port `_ Return the value of the ZMQ port from the corresponding integer @@ -133,10 +113,6 @@ Documentation Example : tcp://130.120.229.139:12345 -`zmq_set_running `_ - Set the job to Running in QP-run - - `zmq_socket_pair_inproc_address `_ Socket which pulls the results (2) @@ -157,10 +133,6 @@ Documentation Socket which pulls the results (2) -`zmq_socket_sub_tcp_address `_ - Socket which pulls the results (2) - - -`zmq_state `_ +`zmq_state `_ Threads executing work through the ZeroMQ interface diff --git a/src/ZMQ/tree_dependency.png b/src/ZMQ/tree_dependency.png deleted file mode 100644 index e69de29b..00000000 diff --git a/tests/bats/cassd.bats b/tests/bats/cassd.bats index 2a8fabc2..a21b58ac 100644 --- a/tests/bats/cassd.bats +++ b/tests/bats/cassd.bats @@ -3,24 +3,15 @@ source $QP_ROOT/tests/bats/common.bats.sh @test "CAS_SD H2O cc-pVDZ" { - test_exe cassd_zmq || skip + test_exe cas_sd_selected || skip INPUT=h2o.ezfio - rm -rf work/h2o.ezfio/determinants/ qp_edit -c $INPUT ezfio set_file $INPUT - ezfio set perturbation do_pt2_end True - ezfio set determinants n_det_max 16384 + 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 cassd_zmq $INPUT - energy="$(ezfio get cas_sd_zmq energy_pt2)" - eq $energy -76.231084536315 5.E-5 - - ezfio set determinants n_det_max 2048 - ezfio set determinants read_wf True - ezfio set perturbation do_pt2_end True - qp_run cassd_zmq $INPUT - ezfio set determinants read_wf False - energy="$(ezfio get cas_sd_zmq energy)" - eq $energy -76.2300887947446 2.E-5 + qp_run cas_sd_selected $INPUT + energy="$(ezfio get cas_sd energy)" + eq $energy -76.22213389282479 1.E-5 } diff --git a/tests/bats/fci.bats b/tests/bats/fci.bats index 79ff91ab..174c8f61 100644 --- a/tests/bats/fci.bats +++ b/tests/bats/fci.bats @@ -20,7 +20,7 @@ function run_FCI() { function run_FCI_ZMQ() { thresh=5.e-5 - test_exe fci_zmq || skip + test_exe full_ci || skip qp_edit -c $1 ezfio set_file $1 ezfio set perturbation do_pt2_end True @@ -28,9 +28,9 @@ function run_FCI_ZMQ() { ezfio set davidson threshold_davidson 1.e-10 qp_run fci_zmq $1 - energy="$(ezfio get full_ci_zmq energy)" + energy="$(ezfio get full_ci energy)" eq $energy $3 $thresh - energy_pt2="$(ezfio get full_ci_zmq energy_pt2)" + energy_pt2="$(ezfio get full_ci energy_pt2)" eq $energy_pt2 $4 $thresh } diff --git a/tests/bats/mrcepa0.bats b/tests/bats/mrcepa0.bats index dc9e0bb4..8b56c606 100644 --- a/tests/bats/mrcepa0.bats +++ b/tests/bats/mrcepa0.bats @@ -15,8 +15,8 @@ source $QP_ROOT/tests/bats/common.bats.sh ezfio set mrcepa0 lambda_type 1 ezfio set mrcepa0 n_it_max_dressed_ci 3 qp_run $EXE $INPUT - energy="$(ezfio get mrcepa0 energy_pt2)" - eq $energy -76.23752746236 1.e-4 + energy="$(ezfio get mrcepa0 energy)" + eq $energy -76.22903276183061 1.e-4 } @test "MRCC H2O cc-pVDZ" { @@ -28,11 +28,12 @@ source $QP_ROOT/tests/bats/common.bats.sh 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_pt2)" - eq $energy -76.237469267705 2.e-4 + energy="$(ezfio get mrcepa0 energy)" + eq $energy -76.22899302846875 1.e-4 } @test "MRSC2 H2O cc-pVDZ" { @@ -44,11 +45,11 @@ source $QP_ROOT/tests/bats/common.bats.sh 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 lambda_type 0 ezfio set mrcepa0 n_it_max_dressed_ci 3 qp_run $EXE $INPUT - energy="$(ezfio get mrcepa0 energy_pt2)" - eq $energy -76.2347764009137 2.e-4 + energy="$(ezfio get mrcepa0 energy)" + eq $energy -76.22647345292708 1.e-4 } @test "MRCEPA0 H2O cc-pVDZ" { @@ -60,10 +61,10 @@ source $QP_ROOT/tests/bats/common.bats.sh 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 lambda_type 0 ezfio set mrcepa0 n_it_max_dressed_ci 3 qp_run $EXE $INPUT - energy="$(ezfio get mrcepa0 energy_pt2)" - eq $energy -76.2406942855164 2.e-4 + energy="$(ezfio get mrcepa0 energy)" + eq $energy -76.23199784430074 1.e-4 } diff --git a/tests/bats/pseudo.bats b/tests/bats/pseudo.bats index 4b374d76..8cccf229 100644 --- a/tests/bats/pseudo.bats +++ b/tests/bats/pseudo.bats @@ -23,7 +23,7 @@ function run_HF() { function run_FCI_ZMQ() { thresh=5.e-5 - test_exe fci_zmq|| skip + test_exe full_ci || skip qp_edit -c $1 ezfio set_file $1 ezfio set perturbation do_pt2_end True @@ -31,9 +31,9 @@ function run_FCI_ZMQ() { ezfio set davidson threshold_davidson 1.e-10 qp_run fci_zmq $1 - energy="$(ezfio get full_ci_zmq energy)" + energy="$(ezfio get full_ci energy)" eq $energy $3 $thresh - energy_pt2="$(ezfio get full_ci_zmq energy_pt2)" + energy_pt2="$(ezfio get full_ci energy_pt2)" eq $energy_pt2 $4 $thresh } @@ -48,6 +48,6 @@ function run_FCI_ZMQ() { @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 -17.0399584106077 -17.0400170044515 + run_FCI_ZMQ h2o_pseudo.ezfio 2000 -0.170399597228904E+02 -0.170400168816800E+02 } diff --git a/tests/run_tests.sh b/tests/run_tests.sh index 3ac452ad..1254de3b 100755 --- a/tests/run_tests.sh +++ b/tests/run_tests.sh @@ -11,8 +11,8 @@ mrcepa0.bats #foboci.bats -export QP_PREFIX="timeout -s 9 600" -#export QP_TASK_DEBUG=1 +export QP_PREFIX="timeout -s 9 300" +export QP_TASK_DEBUG=1 rm -rf work output