mirror of
https://github.com/QuantumPackage/qp2.git
synced 2024-09-27 20:11:13 +02:00
Compare commits
192 Commits
Author | SHA1 | Date | |
---|---|---|---|
|
cea311077c | ||
|
b2a928f022 | ||
|
1e2a8455d3 | ||
|
338f9ca2f8 | ||
|
5fee067556 | ||
|
ee40465648 | ||
|
1efe61efd0 | ||
|
1277f78d72 | ||
|
4a31254d6b | ||
|
f17b36c3e4 | ||
|
2845b1c8ea | ||
|
9ddd8f5e7d | ||
|
437846e4d2 | ||
|
9fa523fe66 | ||
|
e638a640f0 | ||
|
92f321e594 | ||
|
8c68369a3b | ||
|
2371bdf9a3 | ||
|
d0fe9aad4f | ||
|
a0eb1d34db | ||
|
380cbdcbb5 | ||
|
84531d8021 | ||
|
92294cf973 | ||
|
70cfbbd631 | ||
|
38337eb0dc | ||
|
13f685722d | ||
|
3ebad92f76 | ||
|
c79240962c | ||
|
8e615f6788 | ||
b3284c100e | |||
|
072067c4fa | ||
|
b547d97452 | ||
|
922eeb24c0 | ||
|
d504108a33 | ||
|
25181963f8 | ||
|
508fb9526d | ||
|
a3195ae08a | ||
|
82b6bccc37 | ||
|
d44a22f3d8 | ||
|
7be57b7a14 | ||
|
120e421239 | ||
|
01360efd84 | ||
|
b0bf0c79d6 | ||
|
f07bdee9cd | ||
|
8411167e90 | ||
|
c5726abb13 | ||
|
7145a7d916 | ||
|
8bfac5669a | ||
|
bb8d52fc69 | ||
|
046c71feca | ||
bc04139a54 | |||
df4c9431d0 | |||
717b35cf38 | |||
d19aee172c | |||
|
d6fb0f63fe | ||
|
5b214ac3c1 | ||
|
10fc3a6fc4 | ||
|
299243e2ce | ||
|
17b9b423a9 | ||
|
20d5bcd9d5 | ||
|
47d27186dc | ||
|
6b3593bf74 | ||
8594f26e45 | |||
cb0a9d2750 | |||
273200c829 | |||
|
9ea4377f07 | ||
|
102d930452 | ||
|
f869d347b8 | ||
|
5418ed0f1c | ||
|
7e3e2b9db9 | ||
|
f7a7ba2a3e | ||
|
01d6d5acbc | ||
|
338e793ed6 | ||
|
3982ee4479 | ||
|
dffd10375b | ||
|
ed5a9fa404 | ||
|
a2b662d795 | ||
|
7d55f314a4 | ||
|
6584bd46db | ||
|
c2e1301f27 | ||
|
953cf04616 | ||
|
315ad54dc7 | ||
|
7db223f6f3 | ||
|
0ba82990ff | ||
|
a59f1e9576 | ||
|
29670d4729 | ||
|
1fc25159a0 | ||
|
0e31cfee7f | ||
|
5ee3fc6e43 | ||
|
156be3b1bb | ||
|
6d12abf088 | ||
|
702ba79af8 | ||
|
bcf824cc18 | ||
|
1c838a30d6 | ||
|
5c66e4b99f | ||
|
c0ee3714e6 | ||
|
31e04c2ab6 | ||
|
ce87a62086 | ||
|
9843df68c4 | ||
|
83d8ba91a8 | ||
|
a81152ad7f | ||
|
727ab502c5 | ||
|
1c09b7dcbc | ||
|
b3390f2fa3 | ||
|
02c6539daa | ||
|
3c0ef34836 | ||
|
8794296f37 | ||
|
c847d63f2c | ||
|
07f09acd99 | ||
7e26342cfb | |||
|
2cffbdcc9d | ||
|
059efc649d | ||
|
0b22e78da1 | ||
|
d80fefe1ce | ||
|
4374145954 | ||
|
3ca3dc3061 | ||
|
8472e71df4 | ||
|
a28244e1d1 | ||
|
4ded39470b | ||
|
c4154c10ea | ||
|
85f4ca3121 | ||
|
f9ec0e9cff | ||
|
df2295206f | ||
|
a64be70911 | ||
|
b1e14142c6 | ||
|
f35c8f4f4c | ||
|
91a86c3b2f | ||
|
9ee697e567 | ||
|
b3445bfa3f | ||
|
0914a60d63 | ||
|
7287312b73 | ||
|
b39a7895f4 | ||
|
9b91e53119 | ||
|
f4de811310 | ||
|
8b33c2b4b5 | ||
|
a6a4e8ecac | ||
|
3f0f71be22 | ||
|
dd7b3131b8 | ||
|
5e83a2a853 | ||
|
0b0a7520af | ||
|
af74694cab | ||
|
559c17cfaa | ||
|
d7bc608820 | ||
|
5f37d50f23 | ||
|
aac2c60971 | ||
|
948b16d4c5 | ||
|
240c58c84f | ||
|
a632b6af56 | ||
|
0722e12882 | ||
|
cc840cdbc1 | ||
|
b0d27f8503 | ||
|
e64faf2845 | ||
|
4e5cae41d2 | ||
|
15f441819e | ||
|
40abfb368a | ||
|
c48654f550 | ||
|
17ac52d2d5 | ||
|
56cc1c6b40 | ||
|
1f353e6ca0 | ||
|
afdad3cdf9 | ||
|
8bfcfe8f21 | ||
|
a63ee551ef | ||
|
e805c52cab | ||
|
60ea669d06 | ||
|
aa23ecc6a6 | ||
|
1dc9c3ed0b | ||
|
92c2a3961e | ||
|
648e157db9 | ||
|
25d041379b | ||
|
73f24c3130 | ||
|
79b75a11f7 | ||
|
b950e40df4 | ||
|
2a386ffa41 | ||
|
b60262b062 | ||
|
99d6826b89 | ||
|
394b6ce404 | ||
|
5eb1c17614 | ||
|
a67497fba8 | ||
|
7dfc072150 | ||
|
c050f2859e | ||
|
3b63d807fc | ||
|
bcc23bf47f | ||
|
4e93390632 | ||
|
949ff3ce3a | ||
514b3172fc | |||
e53361ed97 | |||
|
f65b7c0ead | ||
15ab29206c | |||
ff209ff451 | |||
eb3a8a679c | |||
46d61b4117 | |||
6d064b9bf0 |
11
REPLACE
11
REPLACE
@ -1,5 +1,4 @@
|
||||
# This file contains all the renamings that occured between qp1 and qp2.
|
||||
#
|
||||
qp_name aa_operator_bielec -r aa_operator_two_e
|
||||
qp_name ac_operator_bielec -r ac_operator_two_e
|
||||
qp_name ao_bi_elec_integral_alpha -r ao_two_e_integral_alpha
|
||||
@ -127,7 +126,6 @@ qp_name H_S2_u_0_bielec_nstates_openmp_work_3 -r H_S2_u_0_two_e_nstates_openmp_w
|
||||
qp_name H_S2_u_0_bielec_nstates_openmp_work_4 -r H_S2_u_0_two_e_nstates_openmp_work_4
|
||||
qp_name H_S2_u_0_bielec_nstates_openmp_work_$N_int
|
||||
qp_name H_S2_u_0_bielec_nstates_openmp_work_$N_int -r "H_S2_u_0_two_e_nstates_openmp_work_$N_int"
|
||||
qp_name H_S2_u_0_bielec_nstates_openmp_work_$N_int #-r "H_S2_u_0_two_e_nstates_openmp_work_$N_int"
|
||||
qp_name H_S2_u_0_bielec_nstates_openmp_work -r H_S2_u_0_two_e_nstates_openmp_work
|
||||
qp_name H_S2_u_0_bielec_nstates_openmp_work_ -r H_S2_u_0_two_e_nstates_openmp_work_
|
||||
qp_name i_H_j_bielec -r i_H_j_two_e
|
||||
@ -223,6 +221,7 @@ qp_name potential_sr_xc_beta_ao_lda --rename=potential_xc_beta_ao_sr_lda
|
||||
qp_name potential_sr_xc_beta_ao_pbe --rename=potential_xc_beta_ao_sr_pbe
|
||||
qp_name potential_sr_xc_beta_ao_pbe --rename=potential_xc_beta_ao_sr_pbe
|
||||
qp_name psi_energy_bielec -r psi_energy_two_e
|
||||
qp_name read_ao_integrals_e_n -r read_ao_integrals_n_e
|
||||
qp_name read_ao_integrals --rename="read_ao_two_e_integrals"
|
||||
qp_name read_ao_integrals --rename=read_ao_two_e_integrals
|
||||
qp_name read_mo_integrals_erf -r read_mo_two_e_integrals_erf
|
||||
@ -240,3 +239,11 @@ qp_name write_ao_integrals --rename=write_ao_two_e_integrals
|
||||
qp_name write_mo_integrals_erf -r write_mo_two_e_integrals_erf
|
||||
qp_name write_mo_integrals --rename="write_mo_two_e_integrals"
|
||||
qp_name write_mo_integrals --rename=write_mo_two_e_integrals
|
||||
qp_name ao_ortho_canonical_coef_inv_complex -r ao_ortho_cano_coef_inv_cplx
|
||||
qp_name fock_operator_closed_shell_ref_bitmask -r fock_op_cshell_ref_bitmask
|
||||
qp_name fock_operator_closed_shell_ref_bitmask_complex -r fock_op_cshell_ref_bitmask_cplx
|
||||
qp_name ao_ortho_canonical_coef_inv -r ao_ortho_cano_coef_inv
|
||||
qp_name ao_ortho_cano_to_ao_complex -r ao_ortho_cano_to_ao_cplx
|
||||
qp_name ao_ortho_lowdin_nucl_elec_integrals_complex -r ao_ortho_lowdin_n_e_ints_cplx
|
||||
qp_name ao_ortho_canonical_nucl_elec_integrals_complex -r ao_ortho_cano_n_e_ints_cplx
|
||||
qp_name ao_ortho_canonical_nucl_elec_integrals -r ao_ortho_cano_n_e_ints
|
||||
|
44
configure
vendored
44
configure
vendored
@ -1,4 +1,4 @@
|
||||
#!/bin/bash
|
||||
#!/bin/bash
|
||||
#
|
||||
# Quantum Package configuration script
|
||||
#
|
||||
@ -45,7 +45,7 @@ Usage:
|
||||
|
||||
Options:
|
||||
-c, --config=<file> Define a COMPILATION configuration file,
|
||||
in "${QP_ROOT}/config/".
|
||||
in "${QP_ROOT}/config/".
|
||||
-h, --help Print the HELP message
|
||||
-i, --install=<package> INSTALL <package>. Use at your OWN RISK:
|
||||
no support will be provided for the installation of
|
||||
@ -73,7 +73,7 @@ function execute () {
|
||||
while read -r line; do
|
||||
echo " " $line
|
||||
_command+="${line} ;"
|
||||
done
|
||||
done
|
||||
sleep 1
|
||||
echo ""
|
||||
printf "\e[0;94m"
|
||||
@ -87,7 +87,7 @@ OCAML_PACKAGES="ocamlbuild cryptokit zmq sexplib ppx_sexp_conv ppx_deriving geto
|
||||
|
||||
while true ; do
|
||||
case "$1" in
|
||||
-c|--config)
|
||||
-c|--config)
|
||||
case "$2" in
|
||||
"") help ; break;;
|
||||
*) if [[ -f $2 ]] ; then
|
||||
@ -96,15 +96,15 @@ while true ; do
|
||||
error "error: configuration file $2 not found."
|
||||
exit 1
|
||||
fi
|
||||
esac
|
||||
esac
|
||||
shift 2;;
|
||||
-i|--install)
|
||||
case "$2" in
|
||||
"") help ; break;;
|
||||
*) PACKAGES="${PACKAGE} $2"
|
||||
esac
|
||||
esac
|
||||
shift 2;;
|
||||
-h|-help|--help)
|
||||
-h|-help|--help)
|
||||
help
|
||||
exit 0;;
|
||||
--) shift ; break ;;
|
||||
@ -183,7 +183,7 @@ EZFIO=$(find_dir "${QP_ROOT}"/external/ezfio)
|
||||
if [[ ${EZFIO} = $(not_found) ]] ; then
|
||||
execute << EOF
|
||||
cd "\${QP_ROOT}"/external
|
||||
tar --gunzip --extract --file ${EZFIO_TGZ}
|
||||
tar --gunzip --extract --file ${EZFIO_TGZ}
|
||||
rm -rf ezfio
|
||||
mv EZFIO ezfio
|
||||
EOF
|
||||
@ -237,7 +237,7 @@ EOF
|
||||
./configure --prefix=$QP_ROOT && make -j 8
|
||||
make install
|
||||
EOF
|
||||
|
||||
|
||||
elif [[ ${PACKAGE} = libcap ]] ; then
|
||||
|
||||
download ${LIBCAP_URL} "${QP_ROOT}"/external/libcap.tar.gz
|
||||
@ -272,7 +272,7 @@ EOF
|
||||
cd irpf90-*
|
||||
make
|
||||
EOF
|
||||
|
||||
|
||||
|
||||
elif [[ ${PACKAGE} = zeromq ]] ; then
|
||||
|
||||
@ -303,7 +303,7 @@ EOF
|
||||
cp f77_zmq_free.h "\${QP_ROOT}"/include
|
||||
EOF
|
||||
|
||||
|
||||
|
||||
elif [[ ${PACKAGE} = ocaml ]] ; then
|
||||
|
||||
download ${OCAML_URL} "${QP_ROOT}"/external/opam_installer.sh
|
||||
@ -316,7 +316,7 @@ EOF
|
||||
rm -rf ${HOME}/.opam
|
||||
fi
|
||||
export OPAMROOT=${HOME}/.opam
|
||||
cat << EOF | bash ${QP_ROOT}/external/opam_installer.sh --no-backup
|
||||
cat << EOF | bash ${QP_ROOT}/external/opam_installer.sh --no-backup
|
||||
${QP_ROOT}/bin
|
||||
|
||||
|
||||
@ -336,13 +336,13 @@ EOF
|
||||
# Conventional commands
|
||||
execute << EOF
|
||||
chmod +x "${QP_ROOT}"/external/opam_installer.sh
|
||||
"${QP_ROOT}"/external/opam_installer.sh --no-backup
|
||||
"${QP_ROOT}"/external/opam_installer.sh --no-backup
|
||||
EOF
|
||||
execute << EOF
|
||||
rm --force ${QP_ROOT}/bin/opam
|
||||
export OPAMROOT=${OPAMROOT:-${QP_ROOT}/external/opam}
|
||||
echo ${QP_ROOT}/bin \
|
||||
| sh ${QP_ROOT}/external/opam_installer.sh
|
||||
| sh ${QP_ROOT}/external/opam_installer.sh
|
||||
EOF
|
||||
rm ${QP_ROOT}/external/opam_installer.sh
|
||||
# source ${OPAMROOT}/opam-init/init.sh > /dev/null 2> /dev/null || true
|
||||
@ -355,7 +355,6 @@ EOF
|
||||
EOF
|
||||
fi
|
||||
|
||||
|
||||
elif [[ ${PACKAGE} = bse ]] ; then
|
||||
|
||||
download ${BSE_URL} "${QP_ROOT}"/external/bse.tar.gz
|
||||
@ -363,7 +362,6 @@ EOF
|
||||
cd "\${QP_ROOT}"/external
|
||||
tar --gunzip --extract --file bse.tar.gz
|
||||
pip install -e basis_set_exchange-*
|
||||
EOF
|
||||
elif [[ ${PACKAGE} = zlib ]] ; then
|
||||
|
||||
download ${ZLIB_URL} "${QP_ROOT}"/external/zlib.tar.gz
|
||||
@ -376,13 +374,13 @@ EOF
|
||||
make && make install
|
||||
EOF
|
||||
|
||||
|
||||
|
||||
elif [[ ${PACKAGE} = docopt ]] ; then
|
||||
|
||||
download ${DOCOPT_URL} "${QP_ROOT}"/external/docopt.tar.gz
|
||||
execute << EOF
|
||||
cd "\${QP_ROOT}"/external
|
||||
tar --gunzip --extract --file docopt.tar.gz
|
||||
tar --gunzip --extract --file docopt.tar.gz
|
||||
mv docopt-*/docopt.py "\${QP_ROOT}/external/Python"
|
||||
rm --recursive --force -- docopt-*/ docopt.tar.gz
|
||||
EOF
|
||||
@ -393,7 +391,7 @@ EOF
|
||||
download ${RESULTS_URL} "${QP_ROOT}"/external/resultsFile.tar.gz
|
||||
execute << EOF
|
||||
cd "\${QP_ROOT}"/external
|
||||
tar --gunzip --extract --file resultsFile.tar.gz
|
||||
tar --gunzip --extract --file resultsFile.tar.gz
|
||||
mv resultsFile-*/resultsFile "\${QP_ROOT}/external/Python/"
|
||||
rm --recursive --force resultsFile-* resultsFile.tar.gz
|
||||
EOF
|
||||
@ -403,7 +401,7 @@ EOF
|
||||
download ${BATS_URL} "${QP_ROOT}"/external/bats.tar.gz
|
||||
execute << EOF
|
||||
cd "\${QP_ROOT}"/external
|
||||
tar -zxf bats.tar.gz
|
||||
tar -zxf bats.tar.gz
|
||||
( cd bats-core-1.1.0/ ; ./install.sh \${QP_ROOT})
|
||||
rm --recursive --force -- bats-core-1.1.0 \ "\${QP_ROOT}"/external/bats.tar.gz
|
||||
EOF
|
||||
@ -515,15 +513,15 @@ fi
|
||||
|
||||
if [[ -f ${QP_ROOT}/build.ninja ]] ; then
|
||||
[[ -z ${TRAVIS} ]] && echo "You can now run ./bin/qpsh to enter in the QP shell mode :)"
|
||||
else
|
||||
else
|
||||
echo ""
|
||||
echo "${QP_ROOT}/build.ninja does not exist,"
|
||||
echo "you need to specify the COMPILATION configuration file."
|
||||
echo "See ./configure --help for more details."
|
||||
echo "See ./configure --help for more details."
|
||||
echo ""
|
||||
fi
|
||||
|
||||
exit 0
|
||||
|
||||
|
||||
|
||||
|
||||
|
@ -37,7 +37,9 @@ end = struct
|
||||
} [@@deriving sexp]
|
||||
;;
|
||||
|
||||
let get_default = Qpackage.get_ezfio_default "determinants";;
|
||||
let get_default = Qpackage.get_ezfio_default "determinants"
|
||||
|
||||
let is_complex = lazy (Ezfio.get_nuclei_is_complex () )
|
||||
|
||||
let read_n_int () =
|
||||
if not (Ezfio.has_determinants_n_int()) then
|
||||
@ -48,12 +50,12 @@ end = struct
|
||||
;
|
||||
Ezfio.get_determinants_n_int ()
|
||||
|> N_int_number.of_int
|
||||
;;
|
||||
|
||||
|
||||
let write_n_int n =
|
||||
N_int_number.to_int n
|
||||
|> Ezfio.set_determinants_n_int
|
||||
;;
|
||||
|
||||
|
||||
|
||||
let read_bit_kind () =
|
||||
@ -64,12 +66,12 @@ end = struct
|
||||
;
|
||||
Ezfio.get_determinants_bit_kind ()
|
||||
|> Bit_kind.of_int
|
||||
;;
|
||||
|
||||
|
||||
let write_bit_kind b =
|
||||
Bit_kind.to_int b
|
||||
|> Ezfio.set_determinants_bit_kind
|
||||
;;
|
||||
|
||||
|
||||
let read_n_det () =
|
||||
if not (Ezfio.has_determinants_n_det ()) then
|
||||
@ -77,7 +79,7 @@ end = struct
|
||||
;
|
||||
Ezfio.get_determinants_n_det ()
|
||||
|> Det_number.of_int
|
||||
;;
|
||||
|
||||
|
||||
let read_n_det_qp_edit () =
|
||||
if not (Ezfio.has_determinants_n_det_qp_edit ()) then
|
||||
@ -87,18 +89,18 @@ end = struct
|
||||
end;
|
||||
Ezfio.get_determinants_n_det_qp_edit ()
|
||||
|> Det_number.of_int
|
||||
;;
|
||||
|
||||
|
||||
let write_n_det n =
|
||||
Det_number.to_int n
|
||||
|> Ezfio.set_determinants_n_det
|
||||
;;
|
||||
|
||||
|
||||
let write_n_det_qp_edit n =
|
||||
let n_det = read_n_det () |> Det_number.to_int in
|
||||
min n_det (Det_number.to_int n)
|
||||
|> Ezfio.set_determinants_n_det_qp_edit
|
||||
;;
|
||||
|
||||
|
||||
let read_n_states () =
|
||||
if not (Ezfio.has_determinants_n_states ()) then
|
||||
@ -106,7 +108,7 @@ end = struct
|
||||
;
|
||||
Ezfio.get_determinants_n_states ()
|
||||
|> States_number.of_int
|
||||
;;
|
||||
|
||||
|
||||
let write_n_states n =
|
||||
let n_states =
|
||||
@ -130,7 +132,7 @@ end = struct
|
||||
Ezfio.ezfio_array_of_list ~rank:1 ~dim:[| n_states |] ~data
|
||||
|> Ezfio.set_determinants_state_average_weight
|
||||
end
|
||||
;;
|
||||
|
||||
|
||||
let write_state_average_weight data =
|
||||
let n_states =
|
||||
@ -143,7 +145,7 @@ end = struct
|
||||
in
|
||||
Ezfio.ezfio_array_of_list ~rank:1 ~dim:[| n_states |] ~data
|
||||
|> Ezfio.set_determinants_state_average_weight
|
||||
;;
|
||||
|
||||
|
||||
let read_state_average_weight () =
|
||||
let n_states =
|
||||
@ -171,7 +173,7 @@ end = struct
|
||||
|> Array.map Positive_float.of_float
|
||||
in
|
||||
(write_state_average_weight data; data)
|
||||
;;
|
||||
|
||||
|
||||
let read_expected_s2 () =
|
||||
if not (Ezfio.has_determinants_expected_s2 ()) then
|
||||
@ -186,12 +188,12 @@ end = struct
|
||||
;
|
||||
Ezfio.get_determinants_expected_s2 ()
|
||||
|> Positive_float.of_float
|
||||
;;
|
||||
|
||||
|
||||
let write_expected_s2 s2 =
|
||||
Positive_float.to_float s2
|
||||
|> Ezfio.set_determinants_expected_s2
|
||||
;;
|
||||
|
||||
|
||||
let read_psi_coef ~read_only () =
|
||||
if not (Ezfio.has_determinants_psi_coef ()) then
|
||||
@ -200,19 +202,36 @@ end = struct
|
||||
read_n_states ()
|
||||
|> States_number.to_int
|
||||
in
|
||||
Ezfio.ezfio_array_of_list ~rank:2 ~dim:[| 1 ; n_states |]
|
||||
~data:(List.init n_states (fun i -> if (i=0) then 1. else 0. ))
|
||||
(
|
||||
if Lazy.force is_complex then
|
||||
Ezfio.ezfio_array_of_list ~rank:2 ~dim:[| 1 ; n_states |]
|
||||
~data:(List.init (2*n_states) (fun i -> if (i=0) then 1. else 0. ))
|
||||
|> Ezfio.set_determinants_psi_coef
|
||||
else
|
||||
Ezfio.ezfio_array_of_list ~rank:3 ~dim:[| 2 ; 1 ; n_states |]
|
||||
~data:(List.init n_states (fun i -> if (i=0) then 1. else 0. ))
|
||||
|> Ezfio.set_determinants_psi_coef_complex
|
||||
)
|
||||
end;
|
||||
begin
|
||||
if read_only then
|
||||
Ezfio.get_determinants_psi_coef_qp_edit ()
|
||||
begin
|
||||
if Lazy.force is_complex then
|
||||
Ezfio.get_determinants_psi_coef_complex_qp_edit ()
|
||||
else
|
||||
Ezfio.get_determinants_psi_coef_qp_edit ()
|
||||
end
|
||||
else
|
||||
Ezfio.get_determinants_psi_coef ()
|
||||
begin
|
||||
if Lazy.force is_complex then
|
||||
Ezfio.get_determinants_psi_coef_complex ()
|
||||
else
|
||||
Ezfio.get_determinants_psi_coef ()
|
||||
end
|
||||
end
|
||||
|> Ezfio.flattened_ezfio
|
||||
|> Array.map Det_coef.of_float
|
||||
;;
|
||||
|
||||
|
||||
let write_psi_coef ~n_det ~n_states c =
|
||||
let n_det = Det_number.to_int n_det
|
||||
@ -222,12 +241,23 @@ end = struct
|
||||
and n_states =
|
||||
States_number.to_int n_states
|
||||
in
|
||||
let r =
|
||||
Ezfio.ezfio_array_of_list ~rank:2 ~dim:[| n_det ; n_states |] ~data:c
|
||||
in
|
||||
Ezfio.set_determinants_psi_coef r;
|
||||
Ezfio.set_determinants_psi_coef_qp_edit r
|
||||
;;
|
||||
if Lazy.force is_complex then
|
||||
begin
|
||||
let r =
|
||||
Ezfio.ezfio_array_of_list ~rank:3 ~dim:[| 2 ; n_det ; n_states |] ~data:c
|
||||
in
|
||||
Ezfio.set_determinants_psi_coef_complex r;
|
||||
Ezfio.set_determinants_psi_coef_complex_qp_edit r
|
||||
end
|
||||
else
|
||||
begin
|
||||
let r =
|
||||
Ezfio.ezfio_array_of_list ~rank:2 ~dim:[| n_det ; n_states |] ~data:c
|
||||
in
|
||||
Ezfio.set_determinants_psi_coef r;
|
||||
Ezfio.set_determinants_psi_coef_qp_edit r
|
||||
end
|
||||
|
||||
|
||||
|
||||
let read_psi_det ~read_only () =
|
||||
@ -276,7 +306,7 @@ end = struct
|
||||
|> Array.map (Determinant.of_int64_array
|
||||
~n_int:(N_int_number.of_int n_int)
|
||||
~alpha:n_alpha ~beta:n_beta )
|
||||
;;
|
||||
|
||||
|
||||
let write_psi_det ~n_int ~n_det d =
|
||||
let data = Array.to_list d
|
||||
@ -288,7 +318,7 @@ end = struct
|
||||
in
|
||||
Ezfio.set_determinants_psi_det r;
|
||||
Ezfio.set_determinants_psi_det_qp_edit r
|
||||
;;
|
||||
|
||||
|
||||
|
||||
let read ?(full=true) () =
|
||||
@ -316,7 +346,7 @@ end = struct
|
||||
else
|
||||
(* No molecular orbitals, so no determinants *)
|
||||
None
|
||||
;;
|
||||
|
||||
|
||||
let write ?(force=false)
|
||||
{ n_int ;
|
||||
@ -341,7 +371,7 @@ end = struct
|
||||
write_psi_det ~n_int:n_int ~n_det:n_det psi_det
|
||||
end;
|
||||
write_state_average_weight state_average_weight
|
||||
;;
|
||||
|
||||
|
||||
|
||||
let to_rst b =
|
||||
@ -557,10 +587,8 @@ psi_det = %s
|
||||
in
|
||||
|
||||
|
||||
|
||||
|
||||
Generic_input_of_rst.evaluate_sexp t_of_sexp s
|
||||
;;
|
||||
|
||||
|
||||
let update_ndet n_det_new =
|
||||
Printf.printf "Reducing n_det to %d\n" (Det_number.to_int n_det_new);
|
||||
@ -596,7 +624,7 @@ psi_det = %s
|
||||
{ det with n_det = (Det_number.of_int n_det_new) }
|
||||
in
|
||||
write ~force:true new_det
|
||||
;;
|
||||
|
||||
|
||||
let extract_state istate =
|
||||
Printf.printf "Extracting state %d\n" (States_number.to_int istate);
|
||||
@ -628,7 +656,7 @@ psi_det = %s
|
||||
{ det with n_states = (States_number.of_int 1) }
|
||||
in
|
||||
write ~force:true new_det
|
||||
;;
|
||||
|
||||
|
||||
let extract_states range =
|
||||
Printf.printf "Extracting states %s\n" (Range.to_string range);
|
||||
@ -673,7 +701,7 @@ psi_det = %s
|
||||
{ det with n_states = (States_number.of_int @@ List.length sorted_list) }
|
||||
in
|
||||
write ~force:true new_det
|
||||
;;
|
||||
|
||||
|
||||
end
|
||||
|
||||
|
@ -2,7 +2,6 @@ open Qptypes
|
||||
open Qputils
|
||||
open Sexplib.Std
|
||||
|
||||
|
||||
module Mo_basis : sig
|
||||
type t =
|
||||
{ mo_num : MO_number.t ;
|
||||
@ -26,8 +25,11 @@ end = struct
|
||||
mo_coef : (MO_coef.t array) array;
|
||||
ao_md5 : MD5.t;
|
||||
} [@@deriving sexp]
|
||||
|
||||
let get_default = Qpackage.get_ezfio_default "mo_basis"
|
||||
|
||||
let is_complex = lazy (Ezfio.get_nuclei_is_complex () )
|
||||
|
||||
let read_mo_label () =
|
||||
if not (Ezfio.has_mo_basis_mo_label ()) then
|
||||
Ezfio.set_mo_basis_mo_label "None"
|
||||
@ -37,11 +39,11 @@ end = struct
|
||||
|
||||
|
||||
let reorder b ordering =
|
||||
{ b with mo_coef =
|
||||
Array.map (fun mo ->
|
||||
Array.init (Array.length mo)
|
||||
(fun i -> mo.(ordering.(i)))
|
||||
) b.mo_coef
|
||||
{ b with
|
||||
mo_coef = Array.map (fun mo ->
|
||||
Array.init (Array.length mo)
|
||||
(fun i -> mo.(ordering.(i)))
|
||||
) b.mo_coef
|
||||
}
|
||||
|
||||
let read_ao_md5 () =
|
||||
@ -60,7 +62,10 @@ end = struct
|
||||
|> MD5.of_string
|
||||
in
|
||||
if (ao_md5 <> result) then
|
||||
failwith "The current MOs don't correspond to the current AOs.";
|
||||
begin
|
||||
Printf.eprintf ":%s:\n:%s:\n%!" (MD5.to_string ao_md5) (MD5.to_string result);
|
||||
failwith "The current MOs don't correspond to the current AOs."
|
||||
end;
|
||||
result
|
||||
|
||||
|
||||
@ -68,7 +73,7 @@ end = struct
|
||||
let elec_alpha_num =
|
||||
Ezfio.get_electrons_elec_alpha_num ()
|
||||
in
|
||||
let result =
|
||||
let result =
|
||||
Ezfio.get_mo_basis_mo_num ()
|
||||
in
|
||||
if result < elec_alpha_num then
|
||||
@ -111,15 +116,21 @@ end = struct
|
||||
|
||||
|
||||
let read_mo_coef () =
|
||||
let a = Ezfio.get_mo_basis_mo_coef ()
|
||||
|> Ezfio.flattened_ezfio
|
||||
|> Array.map MO_coef.of_float
|
||||
let a =
|
||||
(
|
||||
if Lazy.force is_complex then
|
||||
Ezfio.get_mo_basis_mo_coef_complex ()
|
||||
else
|
||||
Ezfio.get_mo_basis_mo_coef ()
|
||||
)
|
||||
|> Ezfio.flattened_ezfio
|
||||
|> Array.map MO_coef.of_float
|
||||
in
|
||||
let mo_num = read_mo_num () |> MO_number.to_int in
|
||||
let ao_num = (Array.length a)/mo_num in
|
||||
Array.init mo_num (fun j ->
|
||||
Array.sub a (j*ao_num) (ao_num)
|
||||
)
|
||||
Array.init mo_num (fun j ->
|
||||
Array.sub a (j*ao_num) (ao_num)
|
||||
)
|
||||
|
||||
|
||||
let read () =
|
||||
@ -236,7 +247,7 @@ mo_coef = %s
|
||||
(b.mo_occ |> Array.to_list |> List.map
|
||||
(MO_occ.to_string) |> String.concat ", " )
|
||||
(b.mo_coef |> Array.map
|
||||
(fun x-> Array.map MO_coef.to_string x |>
|
||||
(fun x-> Array.map MO_coef.to_string x |>
|
||||
Array.to_list |> String.concat "," ) |>
|
||||
Array.to_list |> String.concat "\n" )
|
||||
|
||||
@ -244,12 +255,12 @@ mo_coef = %s
|
||||
let write_mo_num n =
|
||||
MO_number.to_int n
|
||||
|> Ezfio.set_mo_basis_mo_num
|
||||
;;
|
||||
|
||||
|
||||
let write_mo_label a =
|
||||
MO_label.to_string a
|
||||
|> Ezfio.set_mo_basis_mo_label
|
||||
;;
|
||||
|
||||
|
||||
let write_mo_class a =
|
||||
let mo_num = Array.length a in
|
||||
@ -257,7 +268,7 @@ mo_coef = %s
|
||||
|> Array.to_list
|
||||
in Ezfio.ezfio_array_of_list ~rank:1 ~dim:[| mo_num |] ~data
|
||||
|> Ezfio.set_mo_basis_mo_class
|
||||
;;
|
||||
|
||||
|
||||
let write_mo_occ a =
|
||||
let mo_num = Array.length a in
|
||||
@ -265,26 +276,34 @@ mo_coef = %s
|
||||
|> Array.to_list
|
||||
in Ezfio.ezfio_array_of_list ~rank:1 ~dim:[| mo_num |] ~data
|
||||
|> Ezfio.set_mo_basis_mo_occ
|
||||
;;
|
||||
|
||||
|
||||
let write_md5 a =
|
||||
MD5.to_string a
|
||||
|> Ezfio.set_mo_basis_ao_md5
|
||||
;;
|
||||
|
||||
|
||||
let write_mo_coef a =
|
||||
let mo_num = Array.length a in
|
||||
let ao_num = Array.length a.(0) in
|
||||
let ao_num =
|
||||
let x = Array.length a.(0) in
|
||||
if Lazy.force is_complex then x/2 else x
|
||||
in
|
||||
let data =
|
||||
Array.map (fun mo -> Array.map MO_coef.to_float mo
|
||||
|> Array.to_list) a
|
||||
|> Array.to_list
|
||||
|> List.concat
|
||||
in Ezfio.ezfio_array_of_list ~rank:2 ~dim:[| ao_num ; mo_num |] ~data
|
||||
|> Ezfio.set_mo_basis_mo_coef
|
||||
;;
|
||||
in
|
||||
if Lazy.force is_complex then
|
||||
(Ezfio.ezfio_array_of_list ~rank:3 ~dim:[| 2 ; ao_num ; mo_num |] ~data
|
||||
|> Ezfio.set_mo_basis_mo_coef_complex )
|
||||
else
|
||||
(Ezfio.ezfio_array_of_list ~rank:2 ~dim:[| ao_num ; mo_num |] ~data
|
||||
|> Ezfio.set_mo_basis_mo_coef )
|
||||
|
||||
let write
|
||||
|
||||
let write
|
||||
{ mo_num : MO_number.t ;
|
||||
mo_label : MO_label.t;
|
||||
mo_class : MO_class.t array;
|
||||
@ -298,7 +317,7 @@ mo_coef = %s
|
||||
write_mo_occ mo_occ;
|
||||
write_mo_coef mo_coef;
|
||||
write_md5 ao_md5
|
||||
;;
|
||||
|
||||
|
||||
end
|
||||
|
||||
|
@ -166,6 +166,7 @@ let input_ezfio = "
|
||||
|
||||
|
||||
let untouched = "
|
||||
|
||||
module MO_guess : sig
|
||||
type t [@@deriving sexp]
|
||||
val to_string : t -> string
|
||||
|
@ -55,3 +55,9 @@ doc: If |true|, use |AOs| in Cartesian coordinates (6d,10f,...)
|
||||
interface: ezfio, provider
|
||||
default: false
|
||||
|
||||
[ao_num_per_kpt]
|
||||
type: integer
|
||||
doc: Number of |AOs| per kpt
|
||||
default: =(ao_basis.ao_num/nuclei.kpt_num)
|
||||
interface: ezfio
|
||||
|
||||
|
7
src/ao_basis/aos_cplx.irp.f
Normal file
7
src/ao_basis/aos_cplx.irp.f
Normal file
@ -0,0 +1,7 @@
|
||||
BEGIN_PROVIDER [ integer, ao_num_per_kpt ]
|
||||
implicit none
|
||||
BEGIN_DOC
|
||||
! number of aos per kpt.
|
||||
END_DOC
|
||||
ao_num_per_kpt = ao_num/kpt_num
|
||||
END_PROVIDER
|
@ -1,10 +1,22 @@
|
||||
[ao_integrals_e_n]
|
||||
[ao_integrals_n_e]
|
||||
type: double precision
|
||||
doc: Nucleus-electron integrals in |AO| basis set
|
||||
size: (ao_basis.ao_num,ao_basis.ao_num)
|
||||
interface: ezfio
|
||||
|
||||
[io_ao_integrals_e_n]
|
||||
[ao_integrals_n_e_complex]
|
||||
type: double precision
|
||||
doc: Complex nucleus-electron integrals in |AO| basis set
|
||||
size: (2,ao_basis.ao_num,ao_basis.ao_num)
|
||||
interface: ezfio
|
||||
|
||||
[ao_integrals_n_e_kpts]
|
||||
type: double precision
|
||||
doc: Complex nucleus-electron integrals in |AO| basis set
|
||||
size: (2,ao_basis.ao_num_per_kpt,ao_basis.ao_num_per_kpt,nuclei.kpt_num)
|
||||
interface: ezfio
|
||||
|
||||
[io_ao_integrals_n_e]
|
||||
type: Disk_access
|
||||
doc: Read/Write |AO| nucleus-electron attraction integrals from/to disk [ Write | Read | None ]
|
||||
interface: ezfio,provider,ocaml
|
||||
@ -17,6 +29,18 @@ doc: Kinetic energy integrals in |AO| basis set
|
||||
size: (ao_basis.ao_num,ao_basis.ao_num)
|
||||
interface: ezfio
|
||||
|
||||
[ao_integrals_kinetic_complex]
|
||||
type: double precision
|
||||
doc: Complex kinetic energy integrals in |AO| basis set
|
||||
size: (2,ao_basis.ao_num,ao_basis.ao_num)
|
||||
interface: ezfio
|
||||
|
||||
[ao_integrals_kinetic_kpts]
|
||||
type: double precision
|
||||
doc: Complex kinetic energy integrals in |AO| basis set
|
||||
size: (2,ao_basis.ao_num_per_kpt,ao_basis.ao_num_per_kpt,nuclei.kpt_num)
|
||||
interface: ezfio
|
||||
|
||||
[io_ao_integrals_kinetic]
|
||||
type: Disk_access
|
||||
doc: Read/Write |AO| kinetic integrals from/to disk [ Write | Read | None ]
|
||||
@ -30,6 +54,18 @@ doc: Pseudopotential integrals in |AO| basis set
|
||||
size: (ao_basis.ao_num,ao_basis.ao_num)
|
||||
interface: ezfio
|
||||
|
||||
[ao_integrals_pseudo_complex]
|
||||
type: double precision
|
||||
doc: Complex pseudopotential integrals in |AO| basis set
|
||||
size: (2,ao_basis.ao_num,ao_basis.ao_num)
|
||||
interface: ezfio
|
||||
|
||||
[ao_integrals_pseudo_kpts]
|
||||
type: double precision
|
||||
doc: Complex pseudopotential integrals in |AO| basis set
|
||||
size: (2,ao_basis.ao_num_per_kpt,ao_basis.ao_num_per_kpt,nuclei.kpt_num)
|
||||
interface: ezfio
|
||||
|
||||
[io_ao_integrals_pseudo]
|
||||
type: Disk_access
|
||||
doc: Read/Write |AO| pseudopotential integrals from/to disk [ Write | Read | None ]
|
||||
@ -43,6 +79,18 @@ doc: Overlap integrals in |AO| basis set
|
||||
size: (ao_basis.ao_num,ao_basis.ao_num)
|
||||
interface: ezfio
|
||||
|
||||
[ao_integrals_overlap_complex]
|
||||
type: double precision
|
||||
doc: Complex overlap integrals in |AO| basis set
|
||||
size: (2,ao_basis.ao_num,ao_basis.ao_num)
|
||||
interface: ezfio
|
||||
|
||||
[ao_integrals_overlap_kpts]
|
||||
type: double precision
|
||||
doc: Complex overlap integrals in |AO| basis set
|
||||
size: (2,ao_basis.ao_num_per_kpt,ao_basis.ao_num_per_kpt,nuclei.kpt_num)
|
||||
interface: ezfio
|
||||
|
||||
[io_ao_integrals_overlap]
|
||||
type: Disk_access
|
||||
doc: Read/Write |AO| overlap integrals from/to disk [ Write | Read | None ]
|
||||
@ -56,6 +104,18 @@ doc: Combined integrals in |AO| basis set
|
||||
size: (ao_basis.ao_num,ao_basis.ao_num)
|
||||
interface: ezfio
|
||||
|
||||
[ao_one_e_integrals_complex]
|
||||
type: double precision
|
||||
doc: Complex combined integrals in |AO| basis set
|
||||
size: (2,ao_basis.ao_num,ao_basis.ao_num)
|
||||
interface: ezfio
|
||||
|
||||
[ao_one_e_integrals_kpts]
|
||||
type: double precision
|
||||
doc: Complex combined integrals in |AO| basis set
|
||||
size: (2,ao_basis.ao_num_per_kpt,ao_basis.ao_num_per_kpt,nuclei.kpt_num)
|
||||
interface: ezfio
|
||||
|
||||
[io_ao_one_e_integrals]
|
||||
type: Disk_access
|
||||
doc: Read/Write |AO| one-electron integrals from/to disk [ Write | Read | None ]
|
||||
|
@ -5,7 +5,10 @@
|
||||
BEGIN_DOC
|
||||
! One-electron Hamiltonian in the |AO| basis.
|
||||
END_DOC
|
||||
|
||||
if (is_complex) then
|
||||
print*,"you shouldn't be here for complex",irp_here
|
||||
stop -1
|
||||
endif
|
||||
IF (read_ao_one_e_integrals) THEN
|
||||
call ezfio_get_ao_one_e_ints_ao_one_e_integrals(ao_one_e_integrals)
|
||||
ELSE
|
||||
@ -27,3 +30,85 @@
|
||||
|
||||
END_PROVIDER
|
||||
|
||||
!BEGIN_PROVIDER [ double precision, ao_one_e_integrals_imag,(ao_num,ao_num)]
|
||||
! implicit none
|
||||
! integer :: i,j,n,l
|
||||
! BEGIN_DOC
|
||||
! ! One-electron Hamiltonian in the |AO| basis.
|
||||
! END_DOC
|
||||
!
|
||||
! IF (read_ao_one_e_integrals) THEN
|
||||
! call ezfio_get_ao_one_e_ints_ao_one_e_integrals_imag(ao_one_e_integrals_imag)
|
||||
! ELSE
|
||||
! ao_one_e_integrals_imag = ao_integrals_n_e_imag + ao_kinetic_integrals_imag
|
||||
!
|
||||
! IF (DO_PSEUDO) THEN
|
||||
! ao_one_e_integrals_imag += ao_pseudo_integrals_imag
|
||||
! ENDIF
|
||||
! ENDIF
|
||||
!
|
||||
! IF (write_ao_one_e_integrals) THEN
|
||||
! call ezfio_set_ao_one_e_ints_ao_one_e_integrals_imag(ao_one_e_integrals_imag)
|
||||
! print *, 'AO one-e integrals written to disk'
|
||||
! ENDIF
|
||||
!
|
||||
!END_PROVIDER
|
||||
|
||||
BEGIN_PROVIDER [ complex*16, ao_one_e_integrals_complex,(ao_num,ao_num)]
|
||||
&BEGIN_PROVIDER [ double precision, ao_one_e_integrals_diag_complex,(ao_num)]
|
||||
implicit none
|
||||
integer :: i,j,n,l
|
||||
BEGIN_DOC
|
||||
! One-electron Hamiltonian in the |AO| basis.
|
||||
END_DOC
|
||||
|
||||
IF (read_ao_one_e_integrals) THEN
|
||||
call ezfio_get_ao_one_e_ints_ao_one_e_integrals_complex(ao_one_e_integrals_complex)
|
||||
ELSE
|
||||
ao_one_e_integrals_complex = ao_integrals_n_e_complex + ao_kinetic_integrals_complex
|
||||
|
||||
IF (DO_PSEUDO) THEN
|
||||
ao_one_e_integrals_complex += ao_pseudo_integrals_complex
|
||||
ENDIF
|
||||
ENDIF
|
||||
|
||||
DO j = 1, ao_num
|
||||
ao_one_e_integrals_diag_complex(j) = dble(ao_one_e_integrals_complex(j,j))
|
||||
ENDDO
|
||||
|
||||
IF (write_ao_one_e_integrals) THEN
|
||||
call ezfio_set_ao_one_e_ints_ao_one_e_integrals_complex(ao_one_e_integrals_complex)
|
||||
print *, 'AO one-e integrals written to disk'
|
||||
ENDIF
|
||||
END_PROVIDER
|
||||
|
||||
BEGIN_PROVIDER [ complex*16, ao_one_e_integrals_kpts,(ao_num_per_kpt,ao_num_per_kpt,kpt_num)]
|
||||
&BEGIN_PROVIDER [ double precision, ao_one_e_integrals_diag_kpts,(ao_num_per_kpt,kpt_num)]
|
||||
implicit none
|
||||
integer :: j,k
|
||||
BEGIN_DOC
|
||||
! One-electron Hamiltonian in the |AO| basis.
|
||||
END_DOC
|
||||
|
||||
if (read_ao_one_e_integrals) then
|
||||
call ezfio_get_ao_one_e_ints_ao_one_e_integrals_kpts(ao_one_e_integrals_kpts)
|
||||
else
|
||||
ao_one_e_integrals_kpts = ao_integrals_n_e_kpts + ao_kinetic_integrals_kpts
|
||||
|
||||
if (do_pseudo) then
|
||||
ao_one_e_integrals_kpts += ao_pseudo_integrals_kpts
|
||||
endif
|
||||
endif
|
||||
|
||||
do k = 1, kpt_num
|
||||
do j = 1, ao_num_per_kpt
|
||||
ao_one_e_integrals_diag_kpts(j,k) = dble(ao_one_e_integrals_kpts(j,j,k))
|
||||
enddo
|
||||
enddo
|
||||
|
||||
if (write_ao_one_e_integrals) then
|
||||
call ezfio_set_ao_one_e_ints_ao_one_e_integrals_kpts(ao_one_e_integrals_kpts)
|
||||
print *, 'AO one-e integrals written to disk'
|
||||
endif
|
||||
END_PROVIDER
|
||||
|
||||
|
@ -84,13 +84,13 @@ END_PROVIDER
|
||||
|
||||
|
||||
|
||||
BEGIN_PROVIDER [ double precision, ao_ortho_canonical_coef_inv, (ao_num,ao_num)]
|
||||
BEGIN_PROVIDER [ double precision, ao_ortho_cano_coef_inv, (ao_num,ao_num)]
|
||||
implicit none
|
||||
BEGIN_DOC
|
||||
! ao_ortho_canonical_coef^(-1)
|
||||
END_DOC
|
||||
call get_inverse(ao_ortho_canonical_coef,size(ao_ortho_canonical_coef,1),&
|
||||
ao_num, ao_ortho_canonical_coef_inv, size(ao_ortho_canonical_coef_inv,1))
|
||||
ao_num, ao_ortho_cano_coef_inv, size(ao_ortho_cano_coef_inv,1))
|
||||
END_PROVIDER
|
||||
|
||||
BEGIN_PROVIDER [ double precision, ao_ortho_canonical_coef, (ao_num,ao_num)]
|
121
src/ao_one_e_ints/ao_ortho_cano_cplx.irp.f
Normal file
121
src/ao_one_e_ints/ao_ortho_cano_cplx.irp.f
Normal file
@ -0,0 +1,121 @@
|
||||
!todo: add kpts
|
||||
BEGIN_PROVIDER [ complex*16, ao_cart_to_sphe_coef_complex, (ao_num,ao_cart_to_sphe_num) ]
|
||||
implicit none
|
||||
BEGIN_DOC
|
||||
! complex version of ao_cart_to_sphe_coef
|
||||
END_DOC
|
||||
call zlacp2('A',ao_num,ao_cart_to_sphe_num, &
|
||||
ao_cart_to_sphe_coef,size(ao_cart_to_sphe_coef,1), &
|
||||
ao_cart_to_sphe_coef_complex,size(ao_cart_to_sphe_coef_complex,1))
|
||||
END_PROVIDER
|
||||
|
||||
BEGIN_PROVIDER [ complex*16, ao_cart_to_sphe_overlap_complex, (ao_cart_to_sphe_num,ao_cart_to_sphe_num) ]
|
||||
implicit none
|
||||
BEGIN_DOC
|
||||
! AO overlap matrix in the spherical basis set
|
||||
END_DOC
|
||||
complex*16, allocatable :: S(:,:)
|
||||
allocate (S(ao_cart_to_sphe_num,ao_num))
|
||||
|
||||
call zgemm('T','N',ao_cart_to_sphe_num,ao_num,ao_num, (1.d0,0.d0), &
|
||||
ao_cart_to_sphe_coef_complex,size(ao_cart_to_sphe_coef_complex,1), &
|
||||
ao_overlap_complex,size(ao_overlap_complex,1), (0.d0,0.d0), &
|
||||
S, size(S,1))
|
||||
|
||||
call zgemm('N','N',ao_cart_to_sphe_num,ao_cart_to_sphe_num,ao_num, (1.d0,0.d0), &
|
||||
S, size(S,1), &
|
||||
ao_cart_to_sphe_coef_complex,size(ao_cart_to_sphe_coef_complex,1), (0.d0,0.d0), &
|
||||
ao_cart_to_sphe_overlap_complex,size(ao_cart_to_sphe_overlap_complex,1))
|
||||
|
||||
deallocate(S)
|
||||
|
||||
END_PROVIDER
|
||||
|
||||
|
||||
|
||||
|
||||
BEGIN_PROVIDER [ complex*16, ao_ortho_cano_coef_inv_cplx, (ao_num,ao_num)]
|
||||
implicit none
|
||||
BEGIN_DOC
|
||||
! ao_ortho_canonical_coef_complex^(-1)
|
||||
END_DOC
|
||||
call get_inverse_complex(ao_ortho_canonical_coef_complex,size(ao_ortho_canonical_coef_complex,1),&
|
||||
ao_num, ao_ortho_cano_coef_inv_cplx, size(ao_ortho_cano_coef_inv_cplx,1))
|
||||
END_PROVIDER
|
||||
|
||||
BEGIN_PROVIDER [ complex*16, ao_ortho_canonical_coef_complex, (ao_num,ao_num)]
|
||||
&BEGIN_PROVIDER [ integer, ao_ortho_canonical_num_complex ]
|
||||
implicit none
|
||||
BEGIN_DOC
|
||||
! TODO: ao_ortho_canonical_num_complex should be the same as the real version
|
||||
! maybe if the providers weren't linked we could avoid making a complex one?
|
||||
! matrix of the coefficients of the mos generated by the
|
||||
! orthonormalization by the S^{-1/2} canonical transformation of the aos
|
||||
! ao_ortho_canonical_coef(i,j) = coefficient of the ith ao on the jth ao_ortho_canonical orbital
|
||||
END_DOC
|
||||
integer :: i
|
||||
ao_ortho_canonical_coef_complex = (0.d0,0.d0)
|
||||
do i=1,ao_num
|
||||
ao_ortho_canonical_coef_complex(i,i) = (1.d0,0.d0)
|
||||
enddo
|
||||
|
||||
!call ortho_lowdin(ao_overlap,size(ao_overlap,1),ao_num,ao_ortho_canonical_coef,size(ao_ortho_canonical_coef,1),ao_num)
|
||||
!ao_ortho_canonical_num=ao_num
|
||||
!return
|
||||
|
||||
if (ao_cartesian) then
|
||||
|
||||
ao_ortho_canonical_num_complex = ao_num
|
||||
call ortho_canonical_complex(ao_overlap,size(ao_overlap,1), &
|
||||
ao_num,ao_ortho_canonical_coef_complex,size(ao_ortho_canonical_coef_complex,1), &
|
||||
ao_ortho_canonical_num_complex)
|
||||
|
||||
|
||||
else
|
||||
|
||||
complex*16, allocatable :: S(:,:)
|
||||
|
||||
allocate(S(ao_cart_to_sphe_num,ao_cart_to_sphe_num))
|
||||
S = (0.d0,0.d0)
|
||||
do i=1,ao_cart_to_sphe_num
|
||||
S(i,i) = (1.d0,0.d0)
|
||||
enddo
|
||||
|
||||
ao_ortho_canonical_num_complex = ao_cart_to_sphe_num
|
||||
call ortho_canonical_complex(ao_cart_to_sphe_overlap_complex, size(ao_cart_to_sphe_overlap_complex,1), &
|
||||
ao_cart_to_sphe_num, S, size(S,1), ao_ortho_canonical_num_complex)
|
||||
|
||||
call zgemm('N','N', ao_num, ao_ortho_canonical_num_complex, ao_cart_to_sphe_num, (1.d0,0.d0), &
|
||||
ao_cart_to_sphe_coef_complex, size(ao_cart_to_sphe_coef_complex,1), &
|
||||
S, size(S,1), &
|
||||
(0.d0,0.d0), ao_ortho_canonical_coef_complex, size(ao_ortho_canonical_coef_complex,1))
|
||||
|
||||
deallocate(S)
|
||||
endif
|
||||
END_PROVIDER
|
||||
|
||||
BEGIN_PROVIDER [complex*16, ao_ortho_canonical_overlap_complex, (ao_ortho_canonical_num_complex,ao_ortho_canonical_num_complex)]
|
||||
implicit none
|
||||
BEGIN_DOC
|
||||
! overlap matrix of the ao_ortho_canonical.
|
||||
! Expected to be the Identity
|
||||
END_DOC
|
||||
integer :: i,j,k,l
|
||||
complex*16 :: c
|
||||
do j=1, ao_ortho_canonical_num_complex
|
||||
do i=1, ao_ortho_canonical_num_complex
|
||||
ao_ortho_canonical_overlap_complex(i,j) = (0.d0,0.d0)
|
||||
enddo
|
||||
enddo
|
||||
do j=1, ao_ortho_canonical_num_complex
|
||||
do k=1, ao_num
|
||||
c = (0.d0,0.d0)
|
||||
do l=1, ao_num
|
||||
c += conjg(ao_ortho_canonical_coef_complex(l,j)) * ao_overlap_complex(l,k)
|
||||
enddo
|
||||
do i=1, ao_ortho_canonical_num_complex
|
||||
ao_ortho_canonical_overlap_complex(i,j) += ao_ortho_canonical_coef_complex(k,i) * c
|
||||
enddo
|
||||
enddo
|
||||
enddo
|
||||
END_PROVIDER
|
196
src/ao_one_e_ints/ao_ortho_cano_kpts.irp.f
Normal file
196
src/ao_one_e_ints/ao_ortho_cano_kpts.irp.f
Normal file
@ -0,0 +1,196 @@
|
||||
!todo: add kpts
|
||||
|
||||
BEGIN_PROVIDER [ complex*16, ao_cart_to_sphe_coef_kpts, (ao_num_per_kpt,ao_num_per_kpt)]
|
||||
&BEGIN_PROVIDER [ integer, ao_cart_to_sphe_num_per_kpt ]
|
||||
implicit none
|
||||
BEGIN_DOC
|
||||
! Coefficients to go from cartesian to spherical coordinates in the current
|
||||
! basis set
|
||||
END_DOC
|
||||
integer :: i
|
||||
integer, external :: ao_power_index
|
||||
integer :: ibegin,j,k
|
||||
integer :: prev
|
||||
prev = 0
|
||||
ao_cart_to_sphe_coef_kpts(:,:) = (0.d0,0.d0)
|
||||
! Assume order provided by ao_power_index
|
||||
i = 1
|
||||
ao_cart_to_sphe_num_per_kpt = 0
|
||||
do while (i <= ao_num_per_kpt)
|
||||
select case ( ao_l(i) )
|
||||
case (0)
|
||||
ao_cart_to_sphe_num_per_kpt += 1
|
||||
ao_cart_to_sphe_coef_kpts(i,ao_cart_to_sphe_num_per_kpt) = (1.d0,0.d0)
|
||||
i += 1
|
||||
BEGIN_TEMPLATE
|
||||
case ($SHELL)
|
||||
if (ao_power(i,1) == $SHELL) then
|
||||
do k=1,size(cart_to_sphe_$SHELL,2)
|
||||
do j=1,size(cart_to_sphe_$SHELL,1)
|
||||
ao_cart_to_sphe_coef_kpts(i+j-1,ao_cart_to_sphe_num_per_kpt+k) = dcmplx(cart_to_sphe_$SHELL(j,k),0.d0)
|
||||
enddo
|
||||
enddo
|
||||
i += size(cart_to_sphe_$SHELL,1)
|
||||
ao_cart_to_sphe_num_per_kpt += size(cart_to_sphe_$SHELL,2)
|
||||
endif
|
||||
SUBST [ SHELL ]
|
||||
1;;
|
||||
2;;
|
||||
3;;
|
||||
4;;
|
||||
5;;
|
||||
6;;
|
||||
7;;
|
||||
8;;
|
||||
9;;
|
||||
END_TEMPLATE
|
||||
case default
|
||||
stop 'Error in ao_cart_to_sphe_kpts : angular momentum too high'
|
||||
end select
|
||||
enddo
|
||||
|
||||
END_PROVIDER
|
||||
!BEGIN_PROVIDER [ integer, ao_cart_to_sphe_num_per_kpt ]
|
||||
! implicit none
|
||||
! ao_cart_to_sphe_num_per_kpt = ao_cart_to_sphe_num / kpt_num
|
||||
!END_PROVIDER
|
||||
!
|
||||
!BEGIN_PROVIDER [ complex*16, ao_cart_to_sphe_coef_kpts, (ao_num_per_kpt,ao_cart_to_sphe_num_per_kpt) ]
|
||||
! implicit none
|
||||
! BEGIN_DOC
|
||||
! ! complex version of ao_cart_to_sphe_coef for one k-point
|
||||
! END_DOC
|
||||
! call zlacp2('A',ao_num_per_kpt,ao_cart_to_sphe_num_per_kpt, &
|
||||
! ao_cart_to_sphe_coef,size(ao_cart_to_sphe_coef,1), &
|
||||
! ao_cart_to_sphe_coef_kpts,size(ao_cart_to_sphe_coef_kpts,1))
|
||||
!END_PROVIDER
|
||||
|
||||
BEGIN_PROVIDER [ complex*16, ao_cart_to_sphe_overlap_kpts, (ao_cart_to_sphe_num_per_kpt,ao_cart_to_sphe_num_per_kpt,kpt_num) ]
|
||||
implicit none
|
||||
BEGIN_DOC
|
||||
! AO overlap matrix in the spherical basis set
|
||||
END_DOC
|
||||
integer :: k
|
||||
complex*16, allocatable :: S(:,:)
|
||||
allocate (S(ao_cart_to_sphe_num_per_kpt,ao_num_per_kpt))
|
||||
|
||||
!todo: call with (:,:,k) vs (1,1,k)? is there a difference? does one create a temporary array?
|
||||
do k=1, kpt_num
|
||||
|
||||
call zgemm('T','N',ao_cart_to_sphe_num_per_kpt,ao_num_per_kpt,ao_num_per_kpt, (1.d0,0.d0), &
|
||||
ao_cart_to_sphe_coef_kpts,size(ao_cart_to_sphe_coef_kpts,1), &
|
||||
ao_overlap_kpts(:,:,k),size(ao_overlap_kpts,1), (0.d0,0.d0), &
|
||||
S, size(S,1))
|
||||
|
||||
call zgemm('N','N',ao_cart_to_sphe_num_per_kpt,ao_cart_to_sphe_num_per_kpt,ao_num_per_kpt, (1.d0,0.d0), &
|
||||
S, size(S,1), &
|
||||
ao_cart_to_sphe_coef_kpts,size(ao_cart_to_sphe_coef_kpts,1), (0.d0,0.d0), &
|
||||
ao_cart_to_sphe_overlap_kpts(:,:,k),size(ao_cart_to_sphe_overlap_kpts,1))
|
||||
enddo
|
||||
deallocate(S)
|
||||
|
||||
END_PROVIDER
|
||||
|
||||
|
||||
|
||||
|
||||
BEGIN_PROVIDER [ complex*16, ao_ortho_cano_coef_inv_kpts, (ao_num_per_kpt,ao_num_per_kpt, kpt_num)]
|
||||
implicit none
|
||||
BEGIN_DOC
|
||||
! ao_ortho_canonical_coef_complex^(-1)
|
||||
END_DOC
|
||||
integer :: k
|
||||
do k=1, kpt_num
|
||||
call get_inverse_complex(ao_ortho_canonical_coef_kpts,size(ao_ortho_canonical_coef_kpts,1),&
|
||||
ao_num_per_kpt, ao_ortho_cano_coef_inv_kpts, size(ao_ortho_cano_coef_inv_kpts,1))
|
||||
enddo
|
||||
END_PROVIDER
|
||||
|
||||
BEGIN_PROVIDER [ complex*16, ao_ortho_canonical_coef_kpts, (ao_num_per_kpt,ao_num_per_kpt,kpt_num)]
|
||||
&BEGIN_PROVIDER [ integer, ao_ortho_canonical_num_per_kpt, (kpt_num) ]
|
||||
&BEGIN_PROVIDER [ integer, ao_ortho_canonical_num_per_kpt_max ]
|
||||
implicit none
|
||||
BEGIN_DOC
|
||||
! TODO: ao_ortho_canonical_num_complex should be the same as the real version
|
||||
! maybe if the providers weren't linked we could avoid making a complex one?
|
||||
! matrix of the coefficients of the mos generated by the
|
||||
! orthonormalization by the S^{-1/2} canonical transformation of the aos
|
||||
! ao_ortho_canonical_coef(i,j) = coefficient of the ith ao on the jth ao_ortho_canonical orbital
|
||||
END_DOC
|
||||
integer :: i,k
|
||||
ao_ortho_canonical_coef_kpts = (0.d0,0.d0)
|
||||
do k=1,kpt_num
|
||||
do i=1,ao_num
|
||||
ao_ortho_canonical_coef_kpts(i,i,k) = (1.d0,0.d0)
|
||||
enddo
|
||||
enddo
|
||||
|
||||
!call ortho_lowdin(ao_overlap,size(ao_overlap,1),ao_num,ao_ortho_canonical_coef,size(ao_ortho_canonical_coef,1),ao_num)
|
||||
!ao_ortho_canonical_num=ao_num
|
||||
!return
|
||||
|
||||
if (ao_cartesian) then
|
||||
|
||||
ao_ortho_canonical_num_per_kpt = ao_num_per_kpt
|
||||
do k=1,kpt_num
|
||||
call ortho_canonical_complex(ao_overlap_kpts(:,:,k),size(ao_overlap_kpts,1), &
|
||||
ao_num_per_kpt,ao_ortho_canonical_coef_kpts(:,:,k),size(ao_ortho_canonical_coef_kpts,1), &
|
||||
ao_ortho_canonical_num_per_kpt(k))
|
||||
enddo
|
||||
|
||||
|
||||
else
|
||||
|
||||
complex*16, allocatable :: S(:,:)
|
||||
|
||||
allocate(S(ao_cart_to_sphe_num_per_kpt,ao_cart_to_sphe_num_per_kpt))
|
||||
do k=1,kpt_num
|
||||
S = (0.d0,0.d0)
|
||||
do i=1,ao_cart_to_sphe_num_per_kpt
|
||||
S(i,i) = (1.d0,0.d0)
|
||||
enddo
|
||||
|
||||
ao_ortho_canonical_num_per_kpt(k) = ao_cart_to_sphe_num_per_kpt
|
||||
call ortho_canonical_complex(ao_cart_to_sphe_overlap_kpts, size(ao_cart_to_sphe_overlap_kpts,1), &
|
||||
ao_cart_to_sphe_num_per_kpt, S, size(S,1), ao_ortho_canonical_num_per_kpt(k))
|
||||
|
||||
call zgemm('N','N', ao_num_per_kpt, ao_ortho_canonical_num_per_kpt(k), ao_cart_to_sphe_num_per_kpt, (1.d0,0.d0), &
|
||||
ao_cart_to_sphe_coef_kpts, size(ao_cart_to_sphe_coef_kpts,1), &
|
||||
S, size(S,1), &
|
||||
(0.d0,0.d0), ao_ortho_canonical_coef_kpts(:,:,k), size(ao_ortho_canonical_coef_kpts,1))
|
||||
enddo
|
||||
|
||||
deallocate(S)
|
||||
endif
|
||||
ao_ortho_canonical_num_per_kpt_max = maxval(ao_ortho_canonical_num_per_kpt)
|
||||
END_PROVIDER
|
||||
|
||||
BEGIN_PROVIDER [complex*16, ao_ortho_canonical_overlap_kpts, (ao_ortho_canonical_num_per_kpt_max,ao_ortho_canonical_num_per_kpt_max,kpt_num)]
|
||||
implicit none
|
||||
BEGIN_DOC
|
||||
! overlap matrix of the ao_ortho_canonical.
|
||||
! Expected to be the Identity
|
||||
END_DOC
|
||||
integer :: i,j,k,l,kk
|
||||
complex*16 :: c
|
||||
do k=1,kpt_num
|
||||
do j=1, ao_ortho_canonical_num_per_kpt_max
|
||||
do i=1, ao_ortho_canonical_num_per_kpt_max
|
||||
ao_ortho_canonical_overlap_kpts(i,j,k) = (0.d0,0.d0)
|
||||
enddo
|
||||
enddo
|
||||
enddo
|
||||
do kk=1,kpt_num
|
||||
do j=1, ao_ortho_canonical_num_per_kpt(kk)
|
||||
do k=1, ao_num_per_kpt
|
||||
c = (0.d0,0.d0)
|
||||
do l=1, ao_num_per_kpt
|
||||
c += conjg(ao_ortho_canonical_coef_kpts(l,j,kk)) * ao_overlap_kpts(l,k,kk)
|
||||
enddo
|
||||
do i=1, ao_ortho_canonical_num_per_kpt(kk)
|
||||
ao_ortho_canonical_overlap_kpts(i,j,kk) += ao_ortho_canonical_coef_kpts(k,i,kk) * c
|
||||
enddo
|
||||
enddo
|
||||
enddo
|
||||
enddo
|
||||
END_PROVIDER
|
@ -70,6 +70,59 @@
|
||||
|
||||
END_PROVIDER
|
||||
|
||||
!BEGIN_PROVIDER [ double precision, ao_overlap_imag, (ao_num, ao_num) ]
|
||||
! implicit none
|
||||
! BEGIN_DOC
|
||||
! ! Imaginary part of the overlap
|
||||
! END_DOC
|
||||
! if (read_ao_integrals_overlap) then
|
||||
! call ezfio_get_ao_one_e_ints_ao_integrals_overlap_imag(ao_overlap_imag(1:ao_num, 1:ao_num))
|
||||
! print *, 'AO overlap integrals read from disk'
|
||||
! else
|
||||
! ao_overlap_imag = 0.d0
|
||||
! endif
|
||||
! if (write_ao_integrals_overlap) then
|
||||
! call ezfio_set_ao_one_e_ints_ao_integrals_overlap_imag(ao_overlap_imag(1:ao_num, 1:ao_num))
|
||||
! print *, 'AO overlap integrals written to disk'
|
||||
! endif
|
||||
!END_PROVIDER
|
||||
|
||||
BEGIN_PROVIDER [ complex*16, ao_overlap_complex, (ao_num, ao_num) ]
|
||||
implicit none
|
||||
BEGIN_DOC
|
||||
! Overlap for complex AOs
|
||||
END_DOC
|
||||
if (read_ao_integrals_overlap) then
|
||||
call ezfio_get_ao_one_e_ints_ao_integrals_overlap_complex(ao_overlap_complex)
|
||||
print *, 'AO overlap integrals read from disk'
|
||||
else
|
||||
print*,'complex AO overlap ints must be provided',irp_here
|
||||
endif
|
||||
if (write_ao_integrals_overlap) then
|
||||
call ezfio_set_ao_one_e_ints_ao_integrals_overlap_complex(ao_overlap_complex)
|
||||
print *, 'AO overlap integrals written to disk'
|
||||
endif
|
||||
END_PROVIDER
|
||||
|
||||
BEGIN_PROVIDER [ complex*16, ao_overlap_kpts, (ao_num_per_kpt, ao_num_per_kpt, kpt_num) ]
|
||||
implicit none
|
||||
BEGIN_DOC
|
||||
! Overlap for complex AOs
|
||||
END_DOC
|
||||
if (read_ao_integrals_overlap) then
|
||||
call ezfio_get_ao_one_e_ints_ao_integrals_overlap_kpts(ao_overlap_kpts)
|
||||
print *, 'AO overlap integrals read from disk'
|
||||
else
|
||||
print*,'complex AO overlap ints must be provided',irp_here
|
||||
endif
|
||||
if (write_ao_integrals_overlap) then
|
||||
call ezfio_set_ao_one_e_ints_ao_integrals_overlap_kpts(ao_overlap_kpts)
|
||||
print *, 'AO overlap integrals written to disk'
|
||||
endif
|
||||
END_PROVIDER
|
||||
|
||||
|
||||
|
||||
|
||||
BEGIN_PROVIDER [ double precision, ao_overlap_abs,(ao_num,ao_num) ]
|
||||
implicit none
|
||||
@ -86,44 +139,57 @@ BEGIN_PROVIDER [ double precision, ao_overlap_abs,(ao_num,ao_num) ]
|
||||
double precision :: A_center(3), B_center(3)
|
||||
integer :: power_A(3), power_B(3)
|
||||
double precision :: lower_exp_val, dx
|
||||
dim1=100
|
||||
lower_exp_val = 40.d0
|
||||
!$OMP PARALLEL DO SCHEDULE(GUIDED) &
|
||||
!$OMP DEFAULT(NONE) &
|
||||
!$OMP PRIVATE(A_center,B_center,power_A,power_B,&
|
||||
!$OMP overlap_x,overlap_y, overlap_z, overlap, &
|
||||
!$OMP alpha, beta,i,j,dx) &
|
||||
!$OMP SHARED(nucl_coord,ao_power,ao_prim_num, &
|
||||
!$OMP ao_overlap_abs,ao_num,ao_coef_normalized_ordered_transp,ao_nucl, &
|
||||
!$OMP ao_expo_ordered_transp,dim1,lower_exp_val)
|
||||
do j=1,ao_num
|
||||
A_center(1) = nucl_coord( ao_nucl(j), 1 )
|
||||
A_center(2) = nucl_coord( ao_nucl(j), 2 )
|
||||
A_center(3) = nucl_coord( ao_nucl(j), 3 )
|
||||
power_A(1) = ao_power( j, 1 )
|
||||
power_A(2) = ao_power( j, 2 )
|
||||
power_A(3) = ao_power( j, 3 )
|
||||
do i= 1,ao_num
|
||||
ao_overlap_abs(i,j)= 0.d0
|
||||
B_center(1) = nucl_coord( ao_nucl(i), 1 )
|
||||
B_center(2) = nucl_coord( ao_nucl(i), 2 )
|
||||
B_center(3) = nucl_coord( ao_nucl(i), 3 )
|
||||
power_B(1) = ao_power( i, 1 )
|
||||
power_B(2) = ao_power( i, 2 )
|
||||
power_B(3) = ao_power( i, 3 )
|
||||
do n = 1,ao_prim_num(j)
|
||||
alpha = ao_expo_ordered_transp(n,j)
|
||||
do l = 1, ao_prim_num(i)
|
||||
beta = ao_expo_ordered_transp(l,i)
|
||||
call overlap_x_abs(A_center(1),B_center(1),alpha,beta,power_A(1),power_B(1),overlap_x,lower_exp_val,dx,dim1)
|
||||
call overlap_x_abs(A_center(2),B_center(2),alpha,beta,power_A(2),power_B(2),overlap_y,lower_exp_val,dx,dim1)
|
||||
call overlap_x_abs(A_center(3),B_center(3),alpha,beta,power_A(3),power_B(3),overlap_z,lower_exp_val,dx,dim1)
|
||||
ao_overlap_abs(i,j) += abs(ao_coef_normalized_ordered_transp(n,j) * ao_coef_normalized_ordered_transp(l,i)) * overlap_x * overlap_y * overlap_z
|
||||
enddo
|
||||
if (is_complex) then
|
||||
ao_overlap_abs = 0.d0
|
||||
integer :: k, ishift
|
||||
do k=1,kpt_num
|
||||
ishift = (k-1)*ao_num_per_kpt
|
||||
do j=1,ao_num_per_kpt
|
||||
do i= 1,ao_num_per_kpt
|
||||
ao_overlap_abs(ishift+i,ishift+j)= cdabs(ao_overlap_kpts(i,j,k))
|
||||
enddo
|
||||
enddo
|
||||
enddo
|
||||
enddo
|
||||
enddo
|
||||
!$OMP END PARALLEL DO
|
||||
else
|
||||
dim1=100
|
||||
lower_exp_val = 40.d0
|
||||
!$OMP PARALLEL DO SCHEDULE(GUIDED) &
|
||||
!$OMP DEFAULT(NONE) &
|
||||
!$OMP PRIVATE(A_center,B_center,power_A,power_B, &
|
||||
!$OMP overlap_x,overlap_y, overlap_z, overlap, &
|
||||
!$OMP alpha, beta,i,j,dx) &
|
||||
!$OMP SHARED(nucl_coord,ao_power,ao_prim_num, &
|
||||
!$OMP ao_overlap_abs,ao_num,ao_coef_normalized_ordered_transp,ao_nucl,&
|
||||
!$OMP ao_expo_ordered_transp,dim1,lower_exp_val)
|
||||
do j=1,ao_num
|
||||
A_center(1) = nucl_coord( ao_nucl(j), 1 )
|
||||
A_center(2) = nucl_coord( ao_nucl(j), 2 )
|
||||
A_center(3) = nucl_coord( ao_nucl(j), 3 )
|
||||
power_A(1) = ao_power( j, 1 )
|
||||
power_A(2) = ao_power( j, 2 )
|
||||
power_A(3) = ao_power( j, 3 )
|
||||
do i= 1,ao_num
|
||||
ao_overlap_abs(i,j)= 0.d0
|
||||
B_center(1) = nucl_coord( ao_nucl(i), 1 )
|
||||
B_center(2) = nucl_coord( ao_nucl(i), 2 )
|
||||
B_center(3) = nucl_coord( ao_nucl(i), 3 )
|
||||
power_B(1) = ao_power( i, 1 )
|
||||
power_B(2) = ao_power( i, 2 )
|
||||
power_B(3) = ao_power( i, 3 )
|
||||
do n = 1,ao_prim_num(j)
|
||||
alpha = ao_expo_ordered_transp(n,j)
|
||||
do l = 1, ao_prim_num(i)
|
||||
beta = ao_expo_ordered_transp(l,i)
|
||||
call overlap_x_abs(A_center(1),B_center(1),alpha,beta,power_A(1),power_B(1),overlap_x,lower_exp_val,dx,dim1)
|
||||
call overlap_x_abs(A_center(2),B_center(2),alpha,beta,power_A(2),power_B(2),overlap_y,lower_exp_val,dx,dim1)
|
||||
call overlap_x_abs(A_center(3),B_center(3),alpha,beta,power_A(3),power_B(3),overlap_z,lower_exp_val,dx,dim1)
|
||||
ao_overlap_abs(i,j) += abs(ao_coef_normalized_ordered_transp(n,j) * ao_coef_normalized_ordered_transp(l,i)) * overlap_x * overlap_y * overlap_z
|
||||
enddo
|
||||
enddo
|
||||
enddo
|
||||
enddo
|
||||
!$OMP END PARALLEL DO
|
||||
endif
|
||||
END_PROVIDER
|
||||
|
||||
BEGIN_PROVIDER [ double precision, S_inv,(ao_num,ao_num) ]
|
||||
@ -134,6 +200,27 @@ BEGIN_PROVIDER [ double precision, S_inv,(ao_num,ao_num) ]
|
||||
call get_pseudo_inverse(ao_overlap,size(ao_overlap,1),ao_num,ao_num,S_inv,size(S_inv,1))
|
||||
END_PROVIDER
|
||||
|
||||
BEGIN_PROVIDER [ complex*16, S_inv_complex,(ao_num,ao_num) ]
|
||||
implicit none
|
||||
BEGIN_DOC
|
||||
! Inverse of the overlap matrix
|
||||
END_DOC
|
||||
call get_pseudo_inverse_complex(ao_overlap_complex, &
|
||||
size(ao_overlap_complex,1),ao_num,ao_num,S_inv_complex,size(S_inv_complex,1))
|
||||
END_PROVIDER
|
||||
|
||||
BEGIN_PROVIDER [ complex*16, S_inv_kpts,(ao_num_per_kpt,ao_num_per_kpt,kpt_num) ]
|
||||
implicit none
|
||||
BEGIN_DOC
|
||||
! Inverse of the overlap matrix
|
||||
END_DOC
|
||||
integer :: k
|
||||
do k=1,kpt_num
|
||||
call get_pseudo_inverse_complex(ao_overlap_kpts(1,1,k), &
|
||||
size(ao_overlap_kpts,1),ao_num_per_kpt,ao_num_per_kpt,S_inv_kpts(1,1,k),size(S_inv_kpts,1))
|
||||
enddo
|
||||
END_PROVIDER
|
||||
|
||||
BEGIN_PROVIDER [ double precision, S_half_inv, (AO_num,AO_num) ]
|
||||
|
||||
BEGIN_DOC
|
||||
@ -192,6 +279,125 @@ BEGIN_PROVIDER [ double precision, S_half_inv, (AO_num,AO_num) ]
|
||||
|
||||
END_PROVIDER
|
||||
|
||||
BEGIN_PROVIDER [ complex*16, S_half_inv_complex, (AO_num,AO_num) ]
|
||||
|
||||
BEGIN_DOC
|
||||
! :math:`X = S^{-1/2}` obtained by SVD
|
||||
END_DOC
|
||||
|
||||
implicit none
|
||||
|
||||
integer :: num_linear_dependencies
|
||||
integer :: LDA, LDC
|
||||
double precision, allocatable :: D(:)
|
||||
complex*16, allocatable :: U(:,:),Vt(:,:)
|
||||
integer :: info, i, j, k
|
||||
double precision, parameter :: threshold_overlap_AO_eigenvalues = 1.d-6
|
||||
|
||||
LDA = size(AO_overlap_complex,1)
|
||||
LDC = size(S_half_inv_complex,1)
|
||||
|
||||
allocate( &
|
||||
U(LDC,AO_num), &
|
||||
Vt(LDA,AO_num), &
|
||||
D(AO_num))
|
||||
|
||||
call svd_complex( &
|
||||
ao_overlap_complex,LDA, &
|
||||
U,LDC, &
|
||||
D, &
|
||||
Vt,LDA, &
|
||||
AO_num,AO_num)
|
||||
|
||||
num_linear_dependencies = 0
|
||||
do i=1,AO_num
|
||||
print*,D(i)
|
||||
if(abs(D(i)) <= threshold_overlap_AO_eigenvalues) then
|
||||
D(i) = 0.d0
|
||||
num_linear_dependencies += 1
|
||||
else
|
||||
ASSERT (D(i) > 0.d0)
|
||||
D(i) = 1.d0/sqrt(D(i))
|
||||
endif
|
||||
do j=1,AO_num
|
||||
S_half_inv_complex(j,i) = 0.d0
|
||||
enddo
|
||||
enddo
|
||||
write(*,*) 'linear dependencies',num_linear_dependencies
|
||||
|
||||
do k=1,AO_num
|
||||
if(D(k) /= 0.d0) then
|
||||
do j=1,AO_num
|
||||
do i=1,AO_num
|
||||
S_half_inv_complex(i,j) = S_half_inv_complex(i,j) + U(i,k)*D(k)*Vt(k,j)
|
||||
enddo
|
||||
enddo
|
||||
endif
|
||||
enddo
|
||||
|
||||
|
||||
END_PROVIDER
|
||||
|
||||
BEGIN_PROVIDER [ complex*16, S_half_inv_kpts, (ao_num_per_kpt,ao_num_per_kpt,kpt_num) ]
|
||||
|
||||
BEGIN_DOC
|
||||
! :math:`X = S^{-1/2}` obtained by SVD
|
||||
END_DOC
|
||||
|
||||
implicit none
|
||||
|
||||
integer :: num_linear_dependencies
|
||||
integer :: LDA, LDC
|
||||
double precision, allocatable :: D(:)
|
||||
complex*16, allocatable :: U(:,:),Vt(:,:)
|
||||
integer :: info, i, j, k,kk
|
||||
double precision, parameter :: threshold_overlap_AO_eigenvalues = 1.d-6
|
||||
|
||||
LDA = size(ao_overlap_kpts,1)
|
||||
LDC = size(s_half_inv_kpts,1)
|
||||
|
||||
allocate( &
|
||||
U(LDC,ao_num_per_kpt), &
|
||||
Vt(LDA,ao_num_per_kpt), &
|
||||
D(ao_num_per_kpt))
|
||||
|
||||
do kk=1,kpt_num
|
||||
call svd_complex( &
|
||||
ao_overlap_kpts(1,1,kk),LDA, &
|
||||
U,LDC, &
|
||||
D, &
|
||||
Vt,LDA, &
|
||||
ao_num_per_kpt,ao_num_per_kpt)
|
||||
|
||||
num_linear_dependencies = 0
|
||||
do i=1,ao_num_per_kpt
|
||||
print*,D(i)
|
||||
if(abs(D(i)) <= threshold_overlap_AO_eigenvalues) then
|
||||
D(i) = 0.d0
|
||||
num_linear_dependencies += 1
|
||||
else
|
||||
ASSERT (D(i) > 0.d0)
|
||||
D(i) = 1.d0/sqrt(D(i))
|
||||
endif
|
||||
do j=1,ao_num_per_kpt
|
||||
S_half_inv_kpts(j,i,kk) = 0.d0
|
||||
enddo
|
||||
enddo
|
||||
write(*,*) 'linear dependencies, k: ',num_linear_dependencies,', ',kk
|
||||
|
||||
do k=1,ao_num_per_kpt
|
||||
if(D(k) /= 0.d0) then
|
||||
do j=1,ao_num_per_kpt
|
||||
do i=1,ao_num_per_kpt
|
||||
S_half_inv_kpts(i,j,kk) = S_half_inv_kpts(i,j,kk) + U(i,k)*D(k)*Vt(k,j)
|
||||
enddo
|
||||
enddo
|
||||
endif
|
||||
enddo
|
||||
enddo
|
||||
|
||||
END_PROVIDER
|
||||
|
||||
|
||||
BEGIN_PROVIDER [ double precision, S_half, (ao_num,ao_num) ]
|
||||
implicit none
|
||||
@ -227,3 +433,73 @@ BEGIN_PROVIDER [ double precision, S_half, (ao_num,ao_num) ]
|
||||
|
||||
END_PROVIDER
|
||||
|
||||
BEGIN_PROVIDER [ complex*16, S_half_complex, (ao_num,ao_num) ]
|
||||
implicit none
|
||||
BEGIN_DOC
|
||||
! :math:`S^{1/2}`
|
||||
END_DOC
|
||||
|
||||
integer :: i,j,k
|
||||
complex*16, allocatable :: U(:,:)
|
||||
complex*16, allocatable :: Vt(:,:)
|
||||
double precision, allocatable :: D(:)
|
||||
|
||||
allocate(U(ao_num,ao_num),Vt(ao_num,ao_num),D(ao_num))
|
||||
|
||||
call svd_complex(ao_overlap_complex,size(ao_overlap_complex,1),U,size(U,1),D,Vt,size(Vt,1),ao_num,ao_num)
|
||||
|
||||
do i=1,ao_num
|
||||
D(i) = dsqrt(D(i))
|
||||
do j=1,ao_num
|
||||
S_half_complex(j,i) = (0.d0,0.d0)
|
||||
enddo
|
||||
enddo
|
||||
|
||||
do k=1,ao_num
|
||||
do j=1,ao_num
|
||||
do i=1,ao_num
|
||||
S_half_complex(i,j) = S_half_complex(i,j) + U(i,k)*D(k)*Vt(k,j)
|
||||
enddo
|
||||
enddo
|
||||
enddo
|
||||
|
||||
deallocate(U,Vt,D)
|
||||
|
||||
END_PROVIDER
|
||||
|
||||
BEGIN_PROVIDER [ complex*16, S_half_kpts, (ao_num_per_kpt,ao_num_per_kpt,kpt_num) ]
|
||||
implicit none
|
||||
BEGIN_DOC
|
||||
! :math:`S^{1/2}`
|
||||
END_DOC
|
||||
|
||||
integer :: i,j,k,kk
|
||||
complex*16, allocatable :: U(:,:)
|
||||
complex*16, allocatable :: Vt(:,:)
|
||||
double precision, allocatable :: D(:)
|
||||
|
||||
allocate(U(ao_num_per_kpt,ao_num_per_kpt),Vt(ao_num_per_kpt,ao_num_per_kpt),D(ao_num_per_kpt))
|
||||
|
||||
do kk=1,kpt_num
|
||||
call svd_complex(ao_overlap_kpts(1,1,k),size(ao_overlap_kpts,1),U,size(U,1),D,Vt,size(Vt,1),ao_num_per_kpt,ao_num_per_kpt)
|
||||
|
||||
do i=1,ao_num_per_kpt
|
||||
D(i) = dsqrt(D(i))
|
||||
do j=1,ao_num_per_kpt
|
||||
S_half_kpts(j,i,kk) = (0.d0,0.d0)
|
||||
enddo
|
||||
enddo
|
||||
|
||||
do k=1,ao_num_per_kpt
|
||||
do j=1,ao_num_per_kpt
|
||||
do i=1,ao_num_per_kpt
|
||||
S_half_kpts(i,j,kk) = S_half_kpts(i,j,kk) + U(i,k)*D(k)*Vt(k,j)
|
||||
enddo
|
||||
enddo
|
||||
enddo
|
||||
enddo
|
||||
|
||||
deallocate(U,Vt,D)
|
||||
|
||||
END_PROVIDER
|
||||
|
||||
|
@ -149,3 +149,66 @@ BEGIN_PROVIDER [double precision, ao_kinetic_integrals, (ao_num,ao_num)]
|
||||
endif
|
||||
END_PROVIDER
|
||||
|
||||
!BEGIN_PROVIDER [double precision, ao_kinetic_integrals_imag, (ao_num,ao_num)]
|
||||
! implicit none
|
||||
! BEGIN_DOC
|
||||
! ! Kinetic energy integrals in the |AO| basis.
|
||||
! !
|
||||
! ! $\langle \chi_i |\hat{T}| \chi_j \rangle$
|
||||
! !
|
||||
! END_DOC
|
||||
! integer :: i,j,k,l
|
||||
!
|
||||
! if (read_ao_integrals_kinetic) then
|
||||
! call ezfio_get_ao_one_e_ints_ao_integrals_kinetic_imag(ao_kinetic_integrals_imag)
|
||||
! print *, 'AO kinetic integrals read from disk'
|
||||
! else
|
||||
! print *, irp_here, ': Not yet implemented'
|
||||
! endif
|
||||
! if (write_ao_integrals_kinetic) then
|
||||
! call ezfio_set_ao_one_e_ints_ao_integrals_kinetic_imag(ao_kinetic_integrals_imag)
|
||||
! print *, 'AO kinetic integrals written to disk'
|
||||
! endif
|
||||
!END_PROVIDER
|
||||
|
||||
BEGIN_PROVIDER [complex*16, ao_kinetic_integrals_complex, (ao_num,ao_num)]
|
||||
implicit none
|
||||
BEGIN_DOC
|
||||
! Kinetic energy integrals in the |AO| basis.
|
||||
!
|
||||
! $\langle \chi_i |\hat{T}| \chi_j \rangle$
|
||||
!
|
||||
END_DOC
|
||||
if (read_ao_integrals_kinetic) then
|
||||
call ezfio_get_ao_one_e_ints_ao_integrals_kinetic_complex(ao_kinetic_integrals_complex)
|
||||
print *, 'AO kinetic integrals read from disk'
|
||||
else
|
||||
print *, irp_here, ': Not yet implemented'
|
||||
stop -1
|
||||
endif
|
||||
if (write_ao_integrals_kinetic) then
|
||||
call ezfio_set_ao_one_e_ints_ao_integrals_kinetic_complex(ao_kinetic_integrals_complex)
|
||||
print *, 'AO kinetic integrals written to disk'
|
||||
endif
|
||||
END_PROVIDER
|
||||
|
||||
BEGIN_PROVIDER [complex*16, ao_kinetic_integrals_kpts, (ao_num_per_kpt,ao_num_per_kpt,kpt_num)]
|
||||
implicit none
|
||||
BEGIN_DOC
|
||||
! Kinetic energy integrals in the |AO| basis.
|
||||
!
|
||||
! $\langle \chi_i |\hat{T}| \chi_j \rangle$
|
||||
!
|
||||
END_DOC
|
||||
if (read_ao_integrals_kinetic) then
|
||||
call ezfio_get_ao_one_e_ints_ao_integrals_kinetic_kpts(ao_kinetic_integrals_kpts)
|
||||
print *, 'AO kinetic integrals read from disk'
|
||||
else
|
||||
print *, irp_here, ': Not yet implemented'
|
||||
stop -1
|
||||
endif
|
||||
if (write_ao_integrals_kinetic) then
|
||||
call ezfio_set_ao_one_e_ints_ao_integrals_kinetic_kpts(ao_kinetic_integrals_kpts)
|
||||
print *, 'AO kinetic integrals written to disk'
|
||||
endif
|
||||
END_PROVIDER
|
||||
|
@ -12,8 +12,8 @@ BEGIN_PROVIDER [ double precision, ao_integrals_n_e, (ao_num,ao_num)]
|
||||
integer :: i,j,k,l,n_pt_in,m
|
||||
double precision :: overlap_x,overlap_y,overlap_z,overlap,dx,NAI_pol_mult
|
||||
|
||||
if (read_ao_integrals_e_n) then
|
||||
call ezfio_get_ao_one_e_ints_ao_integrals_e_n(ao_integrals_n_e)
|
||||
if (read_ao_integrals_n_e) then
|
||||
call ezfio_get_ao_one_e_ints_ao_integrals_n_e(ao_integrals_n_e)
|
||||
print *, 'AO N-e integrals read from disk'
|
||||
else
|
||||
|
||||
@ -76,13 +76,69 @@ BEGIN_PROVIDER [ double precision, ao_integrals_n_e, (ao_num,ao_num)]
|
||||
!$OMP END DO
|
||||
!$OMP END PARALLEL
|
||||
endif
|
||||
if (write_ao_integrals_e_n) then
|
||||
call ezfio_set_ao_one_e_ints_ao_integrals_e_n(ao_integrals_n_e)
|
||||
if (write_ao_integrals_n_e) then
|
||||
call ezfio_set_ao_one_e_ints_ao_integrals_n_e(ao_integrals_n_e)
|
||||
print *, 'AO N-e integrals written to disk'
|
||||
endif
|
||||
|
||||
END_PROVIDER
|
||||
|
||||
!BEGIN_PROVIDER [ double precision, ao_integrals_n_e_imag, (ao_num,ao_num)]
|
||||
! BEGIN_DOC
|
||||
! ! Nucleus-electron interaction, in the |AO| basis set.
|
||||
! !
|
||||
! ! :math:`\langle \chi_i | -\sum_A \frac{1}{|r-R_A|} | \chi_j \rangle`
|
||||
! END_DOC
|
||||
! implicit none
|
||||
! double precision :: alpha, beta, gama, delta
|
||||
! integer :: num_A,num_B
|
||||
! double precision :: A_center(3),B_center(3),C_center(3)
|
||||
! integer :: power_A(3),power_B(3)
|
||||
! integer :: i,j,k,l,n_pt_in,m
|
||||
! double precision :: overlap_x,overlap_y,overlap_z,overlap,dx,NAI_pol_mult
|
||||
!
|
||||
! if (read_ao_integrals_n_e) then
|
||||
! call ezfio_get_ao_one_e_ints_ao_integrals_n_e_imag(ao_integrals_n_e_imag)
|
||||
! print *, 'AO N-e integrals read from disk'
|
||||
! else
|
||||
! print *, irp_here, ': Not yet implemented'
|
||||
! endif
|
||||
!END_PROVIDER
|
||||
|
||||
BEGIN_PROVIDER [complex*16, ao_integrals_n_e_complex, (ao_num,ao_num)]
|
||||
implicit none
|
||||
BEGIN_DOC
|
||||
! Nucleus-electron interaction, in the |AO| basis set.
|
||||
!
|
||||
! :math:`\langle \chi_i | -\sum_A \frac{1}{|r-R_A|} | \chi_j \rangle`
|
||||
END_DOC
|
||||
print*,'error: ',irp_here
|
||||
write(*,*) "test"
|
||||
ao_integrals_n_e_complex(999,999) = 0.d0
|
||||
call abort()
|
||||
if (read_ao_integrals_n_e) then
|
||||
call ezfio_get_ao_one_e_ints_ao_integrals_n_e_complex(ao_integrals_n_e_complex)
|
||||
print *, 'AO N-e integrals read from disk'
|
||||
else
|
||||
print *, irp_here, ': Not yet implemented'
|
||||
endif
|
||||
END_PROVIDER
|
||||
|
||||
BEGIN_PROVIDER [complex*16, ao_integrals_n_e_kpts, (ao_num_per_kpt,ao_num_per_kpt,kpt_num)]
|
||||
implicit none
|
||||
BEGIN_DOC
|
||||
! Nucleus-electron interaction, in the |AO| basis set.
|
||||
!
|
||||
! :math:`\langle \chi_i | -\sum_A \frac{1}{|r-R_A|} | \chi_j \rangle`
|
||||
END_DOC
|
||||
if (read_ao_integrals_n_e) then
|
||||
call ezfio_get_ao_one_e_ints_ao_integrals_n_e_kpts(ao_integrals_n_e_kpts)
|
||||
print *, 'AO N-e integrals read from disk'
|
||||
else
|
||||
print *, irp_here, ': Not yet implemented'
|
||||
endif
|
||||
END_PROVIDER
|
||||
|
||||
BEGIN_PROVIDER [ double precision, ao_integrals_n_e_per_atom, (ao_num,ao_num,nucl_num)]
|
||||
BEGIN_DOC
|
||||
! Nucleus-electron interaction in the |AO| basis set, per atom A.
|
||||
@ -166,7 +222,7 @@ double precision function NAI_pol_mult(A_center,B_center,power_A,power_B,alpha,b
|
||||
double precision :: P_center(3)
|
||||
double precision :: d(0:n_pt_in),pouet,coeff,rho,dist,const,pouet_2,p,p_inv,factor
|
||||
double precision :: I_n_special_exact,integrate_bourrin,I_n_bibi
|
||||
double precision :: V_e_n,const_factor,dist_integral,tmp
|
||||
double precision :: V_n_e,const_factor,dist_integral,tmp
|
||||
double precision :: accu,epsilo,rint
|
||||
integer :: n_pt_out,lmax
|
||||
include 'utils/constants.include.F'
|
||||
@ -178,7 +234,7 @@ double precision function NAI_pol_mult(A_center,B_center,power_A,power_B,alpha,b
|
||||
(A_center(3)/=C_center(3))) then
|
||||
continue
|
||||
else
|
||||
NAI_pol_mult = V_e_n(power_A(1),power_A(2),power_A(3), &
|
||||
NAI_pol_mult = V_n_e(power_A(1),power_A(2),power_A(3), &
|
||||
power_B(1),power_B(2),power_B(3),alpha,beta)
|
||||
return
|
||||
endif
|
||||
@ -476,7 +532,7 @@ recursive subroutine I_x2_pol_mult_one_e(c,R1x,R1xp,R2x,d,nd,dim)
|
||||
endif
|
||||
end
|
||||
|
||||
double precision function V_e_n(a_x,a_y,a_z,b_x,b_y,b_z,alpha,beta)
|
||||
double precision function V_n_e(a_x,a_y,a_z,b_x,b_y,b_z,alpha,beta)
|
||||
implicit none
|
||||
BEGIN_DOC
|
||||
! Primitve nuclear attraction between the two primitves centered on the same atom.
|
||||
@ -489,9 +545,9 @@ double precision function V_e_n(a_x,a_y,a_z,b_x,b_y,b_z,alpha,beta)
|
||||
double precision :: alpha,beta
|
||||
double precision :: V_r, V_phi, V_theta
|
||||
if(iand((a_x+b_x),1)==1.or.iand(a_y+b_y,1)==1.or.iand((a_z+b_z),1)==1)then
|
||||
V_e_n = 0.d0
|
||||
V_n_e = 0.d0
|
||||
else
|
||||
V_e_n = V_r(a_x+b_x+a_y+b_y+a_z+b_z+1,alpha+beta) &
|
||||
V_n_e = V_r(a_x+b_x+a_y+b_y+a_z+b_z+1,alpha+beta) &
|
||||
* V_phi(a_x+b_x,a_y+b_y) &
|
||||
* V_theta(a_z+b_z,a_x+b_x+a_y+b_y+1)
|
||||
endif
|
||||
|
@ -27,6 +27,59 @@ BEGIN_PROVIDER [ double precision, ao_pseudo_integrals, (ao_num,ao_num)]
|
||||
|
||||
END_PROVIDER
|
||||
|
||||
!BEGIN_PROVIDER [ double precision, ao_pseudo_integrals_imag, (ao_num, ao_num) ]
|
||||
! implicit none
|
||||
! BEGIN_DOC
|
||||
! ! Imaginary part of the pseudo_integrals
|
||||
! END_DOC
|
||||
! if (read_ao_integrals_pseudo) then
|
||||
! call ezfio_get_ao_one_e_ints_ao_integrals_pseudo_imag(ao_pseudo_integrals_imag(1:ao_num, 1:ao_num))
|
||||
! print *, 'AO pseudo_integrals integrals read from disk'
|
||||
! else
|
||||
! ao_pseudo_integrals_imag = 0.d0
|
||||
! endif
|
||||
! if (write_ao_integrals_pseudo) then
|
||||
! call ezfio_set_ao_one_e_ints_ao_integrals_pseudo_imag(ao_pseudo_integrals_imag(1:ao_num, 1:ao_num))
|
||||
! print *, 'AO pseudo_integrals integrals written to disk'
|
||||
! endif
|
||||
!END_PROVIDER
|
||||
|
||||
BEGIN_PROVIDER [ complex*16, ao_pseudo_integrals_complex, (ao_num, ao_num) ]
|
||||
implicit none
|
||||
BEGIN_DOC
|
||||
! Overlap for complex AOs
|
||||
END_DOC
|
||||
if (read_ao_integrals_pseudo) then
|
||||
call ezfio_get_ao_one_e_ints_ao_integrals_pseudo_complex(ao_pseudo_integrals_complex)
|
||||
print *, 'AO pseudo_integrals integrals read from disk'
|
||||
else
|
||||
print*,irp_here,'not implemented'
|
||||
stop -1
|
||||
endif
|
||||
if (write_ao_integrals_pseudo) then
|
||||
call ezfio_set_ao_one_e_ints_ao_integrals_pseudo_complex(ao_pseudo_integrals_complex)
|
||||
print *, 'AO pseudo_integrals integrals written to disk'
|
||||
endif
|
||||
END_PROVIDER
|
||||
|
||||
BEGIN_PROVIDER [ complex*16, ao_pseudo_integrals_kpts, (ao_num_per_kpt, ao_num_per_kpt, kpt_num) ]
|
||||
implicit none
|
||||
BEGIN_DOC
|
||||
! Overlap for complex AOs
|
||||
END_DOC
|
||||
if (read_ao_integrals_pseudo) then
|
||||
call ezfio_get_ao_one_e_ints_ao_integrals_pseudo_kpts(ao_pseudo_integrals_kpts)
|
||||
print *, 'AO pseudo_integrals integrals read from disk'
|
||||
else
|
||||
print*,irp_here,'not implemented'
|
||||
stop -1
|
||||
endif
|
||||
if (write_ao_integrals_pseudo) then
|
||||
call ezfio_set_ao_one_e_ints_ao_integrals_pseudo_kpts(ao_pseudo_integrals_kpts)
|
||||
print *, 'AO pseudo_integrals integrals written to disk'
|
||||
endif
|
||||
END_PROVIDER
|
||||
|
||||
BEGIN_PROVIDER [ double precision, ao_pseudo_integrals_local, (ao_num,ao_num)]
|
||||
implicit none
|
||||
BEGIN_DOC
|
||||
|
@ -18,3 +18,20 @@ interface: ezfio,provider,ocaml
|
||||
default: False
|
||||
ezfio_name: direct
|
||||
|
||||
[df_num]
|
||||
type: integer
|
||||
doc: Size of df basis
|
||||
interface: ezfio, provider
|
||||
|
||||
[io_df_ao_integrals]
|
||||
type: Disk_access
|
||||
doc: Read/Write df |AO| integrals from/to disk [ Write | Read | None ]
|
||||
interface: ezfio,provider,ocaml
|
||||
default: None
|
||||
|
||||
[df_ao_integrals_complex]
|
||||
type: double precision
|
||||
doc: Real part of the df integrals over AOs
|
||||
size: (2,ao_basis.ao_num_per_kpt,ao_basis.ao_num_per_kpt,ao_two_e_ints.df_num,nuclei.kpt_pair_num)
|
||||
interface: ezfio
|
||||
|
||||
|
233
src/ao_two_e_ints/df_ao_ints.irp.f
Normal file
233
src/ao_two_e_ints/df_ao_ints.irp.f
Normal file
@ -0,0 +1,233 @@
|
||||
BEGIN_PROVIDER [complex*16, df_ao_integrals_complex, (ao_num_per_kpt,ao_num_per_kpt,df_num,kpt_pair_num)]
|
||||
implicit none
|
||||
BEGIN_DOC
|
||||
! df AO integrals
|
||||
END_DOC
|
||||
integer :: i,j,k,l
|
||||
|
||||
if (read_df_ao_integrals) then
|
||||
call ezfio_get_ao_two_e_ints_df_ao_integrals_complex(df_ao_integrals_complex)
|
||||
print *, 'df AO integrals read from disk'
|
||||
else
|
||||
print*,'df ao integrals must be provided',irp_here
|
||||
stop -1
|
||||
endif
|
||||
|
||||
if (write_df_ao_integrals) then
|
||||
call ezfio_set_ao_two_e_ints_df_ao_integrals_complex(df_ao_integrals_complex)
|
||||
print *, 'df AO integrals written to disk'
|
||||
endif
|
||||
|
||||
END_PROVIDER
|
||||
|
||||
|
||||
subroutine ao_map_fill_from_df
|
||||
use map_module
|
||||
implicit none
|
||||
BEGIN_DOC
|
||||
! fill ao bielec integral map using 3-index df integrals
|
||||
END_DOC
|
||||
|
||||
integer :: i,k,j,l
|
||||
integer :: ki,kk,kj,kl
|
||||
integer :: ii,ik,ij,il
|
||||
integer :: kikk2,kjkl2,jl2,ik2
|
||||
integer :: i_ao,j_ao,i_df
|
||||
|
||||
complex*16,allocatable :: ints_ik(:,:,:), ints_jl(:,:,:), ints_ikjl(:,:,:,:)
|
||||
|
||||
complex*16 :: integral
|
||||
integer :: n_integrals_1, n_integrals_2
|
||||
integer :: size_buffer
|
||||
integer(key_kind),allocatable :: buffer_i_1(:), buffer_i_2(:)
|
||||
real(integral_kind),allocatable :: buffer_values_1(:), buffer_values_2(:)
|
||||
double precision :: tmp_re,tmp_im
|
||||
integer :: ao_num_kpt_2
|
||||
|
||||
double precision :: cpu_1, cpu_2, wall_1, wall_2, wall_0
|
||||
double precision :: map_mb
|
||||
|
||||
logical :: use_map1
|
||||
integer(keY_kind) :: idx_tmp
|
||||
double precision :: sign
|
||||
|
||||
ao_num_kpt_2 = ao_num_per_kpt * ao_num_per_kpt
|
||||
|
||||
size_buffer = min(ao_num_per_kpt*ao_num_per_kpt*ao_num_per_kpt,16000000)
|
||||
print*, 'Providing the ao_bielec integrals from 3-index df integrals'
|
||||
call write_time(6)
|
||||
! call ezfio_set_integrals_bielec_disk_access_mo_integrals('Write')
|
||||
! TOUCH read_mo_integrals read_ao_integrals write_mo_integrals write_ao_integrals
|
||||
|
||||
call wall_time(wall_1)
|
||||
call cpu_time(cpu_1)
|
||||
|
||||
allocate( ints_jl(ao_num_per_kpt,ao_num_per_kpt,df_num))
|
||||
|
||||
wall_0 = wall_1
|
||||
do kl=1, kpt_num
|
||||
do kj=1, kl
|
||||
call idx2_tri_int(kj,kl,kjkl2)
|
||||
if (kj < kl) then
|
||||
do i_ao=1,ao_num_per_kpt
|
||||
do j_ao=1,ao_num_per_kpt
|
||||
do i_df=1,df_num
|
||||
ints_jl(i_ao,j_ao,i_df) = dconjg(df_ao_integrals_complex(j_ao,i_ao,i_df,kjkl2))
|
||||
enddo
|
||||
enddo
|
||||
enddo
|
||||
else
|
||||
ints_jl = df_ao_integrals_complex(:,:,:,kjkl2)
|
||||
endif
|
||||
|
||||
!$OMP PARALLEL PRIVATE(i,k,j,l,ki,kk,ii,ik,ij,il,kikk2,jl2,ik2, &
|
||||
!$OMP ints_ik, ints_ikjl, i_ao, j_ao, i_df, &
|
||||
!$OMP n_integrals_1, buffer_i_1, buffer_values_1, &
|
||||
!$OMP n_integrals_2, buffer_i_2, buffer_values_2, &
|
||||
!$OMP idx_tmp, tmp_re, tmp_im, integral,sign,use_map1) &
|
||||
!$OMP DEFAULT(NONE) &
|
||||
!$OMP SHARED(size_buffer, kpt_num, df_num, ao_num_per_kpt, ao_num_kpt_2, &
|
||||
!$OMP kl,kj,kjkl2,ints_jl, &
|
||||
!$OMP kconserv, df_ao_integrals_complex, ao_integrals_threshold, ao_integrals_map, ao_integrals_map_2)
|
||||
|
||||
allocate( &
|
||||
ints_ik(ao_num_per_kpt,ao_num_per_kpt,df_num), &
|
||||
ints_ikjl(ao_num_per_kpt,ao_num_per_kpt,ao_num_per_kpt,ao_num_per_kpt), &
|
||||
buffer_i_1(size_buffer), &
|
||||
buffer_i_2(size_buffer), &
|
||||
buffer_values_1(size_buffer), &
|
||||
buffer_values_2(size_buffer) &
|
||||
)
|
||||
|
||||
!$OMP DO SCHEDULE(guided)
|
||||
do kk=1,kl
|
||||
ki=kconserv(kl,kk,kj)
|
||||
if (ki>kl) cycle
|
||||
! if ((kl == kj) .and. (ki > kk)) cycle
|
||||
call idx2_tri_int(ki,kk,kikk2)
|
||||
! if (kikk2 > kjkl2) cycle
|
||||
if (ki < kk) then
|
||||
do i_ao=1,ao_num_per_kpt
|
||||
do j_ao=1,ao_num_per_kpt
|
||||
do i_df=1,df_num
|
||||
ints_ik(i_ao,j_ao,i_df) = dconjg(df_ao_integrals_complex(j_ao,i_ao,i_df,kikk2))
|
||||
enddo
|
||||
enddo
|
||||
enddo
|
||||
! ints_ik = conjg(reshape(df_mo_integral_array(:,:,:,kikk2),(/mo_num_per_kpt,mo_num_per_kpt,df_num/),order=(/2,1,3/)))
|
||||
else
|
||||
ints_ik = df_ao_integrals_complex(:,:,:,kikk2)
|
||||
endif
|
||||
|
||||
call zgemm('N','T', ao_num_kpt_2, ao_num_kpt_2, df_num, &
|
||||
(1.d0,0.d0), ints_ik, ao_num_kpt_2, &
|
||||
ints_jl, ao_num_kpt_2, &
|
||||
(0.d0,0.d0), ints_ikjl, ao_num_kpt_2)
|
||||
|
||||
n_integrals_1=0
|
||||
n_integrals_2=0
|
||||
do il=1,ao_num_per_kpt
|
||||
l=il+(kl-1)*ao_num_per_kpt
|
||||
do ij=1,ao_num_per_kpt
|
||||
j=ij+(kj-1)*ao_num_per_kpt
|
||||
if (j>l) exit
|
||||
call idx2_tri_int(j,l,jl2)
|
||||
do ik=1,ao_num_per_kpt
|
||||
k=ik+(kk-1)*ao_num_per_kpt
|
||||
if (k>l) exit
|
||||
do ii=1,ao_num_per_kpt
|
||||
i=ii+(ki-1)*ao_num_per_kpt
|
||||
if ((j==l) .and. (i>k)) exit
|
||||
call idx2_tri_int(i,k,ik2)
|
||||
if (ik2 > jl2) exit
|
||||
integral = ints_ikjl(ii,ik,ij,il)
|
||||
! print*,i,k,j,l,real(integral),imag(integral)
|
||||
if (cdabs(integral) < ao_integrals_threshold) then
|
||||
cycle
|
||||
endif
|
||||
call ao_two_e_integral_complex_map_idx_sign(i,j,k,l,use_map1,idx_tmp,sign)
|
||||
tmp_re = dble(integral)
|
||||
tmp_im = dimag(integral)
|
||||
if (use_map1) then
|
||||
n_integrals_1 += 1
|
||||
buffer_i_1(n_integrals_1)=idx_tmp
|
||||
buffer_values_1(n_integrals_1)=tmp_re
|
||||
if (sign.ne.0.d0) then
|
||||
n_integrals_1 += 1
|
||||
buffer_i_1(n_integrals_1)=idx_tmp+1
|
||||
buffer_values_1(n_integrals_1)=tmp_im*sign
|
||||
endif
|
||||
if (n_integrals_1 >= size(buffer_i_1)-1) then
|
||||
call insert_into_ao_integrals_map(n_integrals_1,buffer_i_1,buffer_values_1)
|
||||
n_integrals_1 = 0
|
||||
endif
|
||||
else
|
||||
n_integrals_2 += 1
|
||||
buffer_i_2(n_integrals_2)=idx_tmp
|
||||
buffer_values_2(n_integrals_2)=tmp_re
|
||||
if (sign.ne.0.d0) then
|
||||
n_integrals_2 += 1
|
||||
buffer_i_2(n_integrals_2)=idx_tmp+1
|
||||
buffer_values_2(n_integrals_2)=tmp_im*sign
|
||||
endif
|
||||
if (n_integrals_2 >= size(buffer_i_2)-1) then
|
||||
call insert_into_ao_integrals_map_2(n_integrals_2,buffer_i_2,buffer_values_2)
|
||||
n_integrals_2 = 0
|
||||
endif
|
||||
endif
|
||||
|
||||
enddo !ii
|
||||
enddo !ik
|
||||
enddo !ij
|
||||
enddo !il
|
||||
|
||||
if (n_integrals_1 > 0) then
|
||||
call insert_into_ao_integrals_map(n_integrals_1,buffer_i_1,buffer_values_1)
|
||||
endif
|
||||
if (n_integrals_2 > 0) then
|
||||
call insert_into_ao_integrals_map_2(n_integrals_2,buffer_i_2,buffer_values_2)
|
||||
endif
|
||||
enddo !kk
|
||||
!$OMP END DO NOWAIT
|
||||
deallocate( &
|
||||
ints_ik, &
|
||||
ints_ikjl, &
|
||||
buffer_i_1, &
|
||||
buffer_i_2, &
|
||||
buffer_values_1, &
|
||||
buffer_values_2 &
|
||||
)
|
||||
!$OMP END PARALLEL
|
||||
enddo !kj
|
||||
call wall_time(wall_2)
|
||||
if (wall_2 - wall_0 > 1.d0) then
|
||||
wall_0 = wall_2
|
||||
print*, 100.*float(kl)/float(kpt_num), '% in ', &
|
||||
wall_2-wall_1,'s',map_mb(ao_integrals_map),'+',map_mb(ao_integrals_map_2),'MB'
|
||||
endif
|
||||
|
||||
enddo !kl
|
||||
deallocate( ints_jl )
|
||||
|
||||
call map_sort(ao_integrals_map)
|
||||
call map_unique(ao_integrals_map)
|
||||
call map_sort(ao_integrals_map_2)
|
||||
call map_unique(ao_integrals_map_2)
|
||||
!call map_save_to_disk(trim(ezfio_filename)//'/work/ao_ints_complex_1',ao_integrals_map)
|
||||
!call map_save_to_disk(trim(ezfio_filename)//'/work/ao_ints_complex_2',ao_integrals_map_2)
|
||||
!call ezfio_set_ao_two_e_ints_io_ao_two_e_integrals('Read')
|
||||
|
||||
call wall_time(wall_2)
|
||||
call cpu_time(cpu_2)
|
||||
|
||||
integer*8 :: get_ao_map_size, ao_map_size
|
||||
ao_map_size = get_ao_map_size()
|
||||
|
||||
print*,'AO integrals provided:'
|
||||
print*,' Size of AO map ', map_mb(ao_integrals_map),'+',map_mb(ao_integrals_map_2),'MB'
|
||||
print*,' Number of AO integrals: ', ao_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 ao_map_fill_from_df
|
||||
|
@ -4,6 +4,7 @@ use map_module
|
||||
!! ======
|
||||
|
||||
BEGIN_PROVIDER [ type(map_type), ao_integrals_map ]
|
||||
&BEGIN_PROVIDER [ type(map_type), ao_integrals_map_2 ]
|
||||
implicit none
|
||||
BEGIN_DOC
|
||||
! AO integrals
|
||||
@ -11,9 +12,17 @@ BEGIN_PROVIDER [ type(map_type), ao_integrals_map ]
|
||||
integer(key_kind) :: key_max
|
||||
integer(map_size_kind) :: sze
|
||||
call two_e_integrals_index(ao_num,ao_num,ao_num,ao_num,key_max)
|
||||
sze = key_max
|
||||
call map_init(ao_integrals_map,sze)
|
||||
print*, 'AO map initialized : ', sze
|
||||
if (is_complex) then
|
||||
sze = key_max*2
|
||||
call map_init(ao_integrals_map,sze)
|
||||
call map_init(ao_integrals_map_2,sze)
|
||||
print*, 'AO maps initialized (complex): ', 2*sze
|
||||
else
|
||||
sze = key_max
|
||||
call map_init(ao_integrals_map,sze)
|
||||
call map_init(ao_integrals_map_2,1_map_size_kind)
|
||||
print*, 'AO map initialized : ', sze
|
||||
endif
|
||||
END_PROVIDER
|
||||
|
||||
subroutine two_e_integrals_index(i,j,k,l,i1)
|
||||
@ -21,7 +30,7 @@ subroutine two_e_integrals_index(i,j,k,l,i1)
|
||||
implicit none
|
||||
BEGIN_DOC
|
||||
! Gives a unique index for i,j,k,l using permtuation symmetry.
|
||||
! i <-> k, j <-> l, and (i,k) <-> (j,l)
|
||||
! i <-> k, j <-> l, and (i,k) <-> (j,l)
|
||||
END_DOC
|
||||
integer, intent(in) :: i,j,k,l
|
||||
integer(key_kind), intent(out) :: i1
|
||||
@ -144,28 +153,30 @@ BEGIN_PROVIDER [ double precision, ao_integrals_cache, (0:64*64*64*64) ]
|
||||
END_DOC
|
||||
PROVIDE ao_two_e_integrals_in_map
|
||||
integer :: i,j,k,l,ii
|
||||
integer(key_kind) :: idx
|
||||
integer(key_kind) :: idx, idx2
|
||||
real(integral_kind) :: integral
|
||||
!$OMP PARALLEL DO PRIVATE (i,j,k,l,idx,ii,integral)
|
||||
do l=ao_integrals_cache_min,ao_integrals_cache_max
|
||||
do k=ao_integrals_cache_min,ao_integrals_cache_max
|
||||
do j=ao_integrals_cache_min,ao_integrals_cache_max
|
||||
do i=ao_integrals_cache_min,ao_integrals_cache_max
|
||||
!DIR$ FORCEINLINE
|
||||
call two_e_integrals_index(i,j,k,l,idx)
|
||||
!DIR$ FORCEINLINE
|
||||
call map_get(ao_integrals_map,idx,integral)
|
||||
ii = l-ao_integrals_cache_min
|
||||
ii = ior( shiftl(ii,6), k-ao_integrals_cache_min)
|
||||
ii = ior( shiftl(ii,6), j-ao_integrals_cache_min)
|
||||
ii = ior( shiftl(ii,6), i-ao_integrals_cache_min)
|
||||
ao_integrals_cache(ii) = integral
|
||||
enddo
|
||||
enddo
|
||||
enddo
|
||||
enddo
|
||||
!$OMP END PARALLEL DO
|
||||
real(integral_kind) :: tmp_re, tmp_im
|
||||
integer(key_kind) :: idx_re,idx_im
|
||||
|
||||
!$OMP PARALLEL DO PRIVATE (i,j,k,l,idx,ii,integral)
|
||||
do l=ao_integrals_cache_min,ao_integrals_cache_max
|
||||
do k=ao_integrals_cache_min,ao_integrals_cache_max
|
||||
do j=ao_integrals_cache_min,ao_integrals_cache_max
|
||||
do i=ao_integrals_cache_min,ao_integrals_cache_max
|
||||
!DIR$ FORCEINLINE
|
||||
call two_e_integrals_index(i,j,k,l,idx)
|
||||
!DIR$ FORCEINLINE
|
||||
call map_get(ao_integrals_map,idx,integral)
|
||||
ii = l-ao_integrals_cache_min
|
||||
ii = ior( shiftl(ii,6), k-ao_integrals_cache_min)
|
||||
ii = ior( shiftl(ii,6), j-ao_integrals_cache_min)
|
||||
ii = ior( shiftl(ii,6), i-ao_integrals_cache_min)
|
||||
ao_integrals_cache(ii) = integral
|
||||
enddo
|
||||
enddo
|
||||
enddo
|
||||
enddo
|
||||
!$OMP END PARALLEL DO
|
||||
END_PROVIDER
|
||||
|
||||
|
||||
@ -207,7 +218,6 @@ double precision function get_ao_two_e_integral(i,j,k,l,map) result(result)
|
||||
result = tmp
|
||||
end
|
||||
|
||||
|
||||
subroutine get_ao_two_e_integrals(j,k,l,sze,out_val)
|
||||
use map_module
|
||||
BEGIN_DOC
|
||||
@ -237,6 +247,8 @@ subroutine get_ao_two_e_integrals(j,k,l,sze,out_val)
|
||||
|
||||
end
|
||||
|
||||
|
||||
|
||||
subroutine get_ao_two_e_integrals_non_zero(j,k,l,sze,out_val,out_val_index,non_zero_int)
|
||||
use map_module
|
||||
implicit none
|
||||
@ -251,6 +263,10 @@ subroutine get_ao_two_e_integrals_non_zero(j,k,l,sze,out_val,out_val_index,non_z
|
||||
integer :: i
|
||||
integer(key_kind) :: hash
|
||||
double precision :: thresh,tmp
|
||||
if(is_complex) then
|
||||
print*,'not implemented for periodic:',irp_here
|
||||
stop -1
|
||||
endif
|
||||
PROVIDE ao_two_e_integrals_in_map
|
||||
thresh = ao_integrals_threshold
|
||||
|
||||
@ -295,6 +311,10 @@ subroutine get_ao_two_e_integrals_non_zero_jl(j,l,thresh,sze_max,sze,out_val,out
|
||||
integer(key_kind) :: hash
|
||||
double precision :: tmp
|
||||
|
||||
if(is_complex) then
|
||||
print*,'not implemented for periodic:',irp_here
|
||||
stop -1
|
||||
endif
|
||||
PROVIDE ao_two_e_integrals_in_map
|
||||
non_zero_int = 0
|
||||
if (ao_overlap_abs(j,l) < thresh) then
|
||||
@ -341,6 +361,10 @@ subroutine get_ao_two_e_integrals_non_zero_jl_from_list(j,l,thresh,list,n_list,s
|
||||
integer(key_kind) :: hash
|
||||
double precision :: tmp
|
||||
|
||||
if(is_complex) then
|
||||
print*,'not implemented for periodic:',irp_here
|
||||
stop -1
|
||||
endif
|
||||
PROVIDE ao_two_e_integrals_in_map
|
||||
non_zero_int = 0
|
||||
if (ao_overlap_abs(j,l) < thresh) then
|
||||
@ -379,7 +403,7 @@ function get_ao_map_size()
|
||||
BEGIN_DOC
|
||||
! Returns the number of elements in the AO map
|
||||
END_DOC
|
||||
get_ao_map_size = ao_integrals_map % n_elements
|
||||
get_ao_map_size = ao_integrals_map % n_elements + ao_integrals_map_2 % n_elements
|
||||
end
|
||||
|
||||
subroutine clear_ao_map
|
||||
@ -389,6 +413,9 @@ subroutine clear_ao_map
|
||||
END_DOC
|
||||
call map_deinit(ao_integrals_map)
|
||||
FREE ao_integrals_map
|
||||
call map_deinit(ao_integrals_map_2)
|
||||
FREE ao_integrals_map_2
|
||||
|
||||
end
|
||||
|
||||
|
||||
@ -407,81 +434,3 @@ subroutine insert_into_ao_integrals_map(n_integrals,buffer_i, buffer_values)
|
||||
end
|
||||
|
||||
|
||||
subroutine dump_ao_integrals(filename)
|
||||
use map_module
|
||||
implicit none
|
||||
BEGIN_DOC
|
||||
! Save to disk the |AO| integrals
|
||||
END_DOC
|
||||
character*(*), intent(in) :: filename
|
||||
integer(cache_key_kind), pointer :: key(:)
|
||||
real(integral_kind), pointer :: val(:)
|
||||
integer*8 :: i,j, n
|
||||
if (.not.mpi_master) then
|
||||
return
|
||||
endif
|
||||
call ezfio_set_work_empty(.False.)
|
||||
open(unit=66,file=filename,FORM='unformatted')
|
||||
write(66) integral_kind, key_kind
|
||||
write(66) ao_integrals_map%sorted, ao_integrals_map%map_size, &
|
||||
ao_integrals_map%n_elements
|
||||
do i=0_8,ao_integrals_map%map_size
|
||||
write(66) ao_integrals_map%map(i)%sorted, ao_integrals_map%map(i)%map_size,&
|
||||
ao_integrals_map%map(i)%n_elements
|
||||
enddo
|
||||
do i=0_8,ao_integrals_map%map_size
|
||||
key => ao_integrals_map%map(i)%key
|
||||
val => ao_integrals_map%map(i)%value
|
||||
n = ao_integrals_map%map(i)%n_elements
|
||||
write(66) (key(j), j=1,n), (val(j), j=1,n)
|
||||
enddo
|
||||
close(66)
|
||||
|
||||
end
|
||||
|
||||
|
||||
integer function load_ao_integrals(filename)
|
||||
implicit none
|
||||
BEGIN_DOC
|
||||
! Read from disk the |AO| integrals
|
||||
END_DOC
|
||||
character*(*), intent(in) :: filename
|
||||
integer*8 :: i
|
||||
integer(cache_key_kind), pointer :: key(:)
|
||||
real(integral_kind), pointer :: val(:)
|
||||
integer :: iknd, kknd
|
||||
integer*8 :: n, j
|
||||
load_ao_integrals = 1
|
||||
open(unit=66,file=filename,FORM='unformatted',STATUS='UNKNOWN')
|
||||
read(66,err=98,end=98) iknd, kknd
|
||||
if (iknd /= integral_kind) then
|
||||
print *, 'Wrong integrals kind in file :', iknd
|
||||
stop 1
|
||||
endif
|
||||
if (kknd /= key_kind) then
|
||||
print *, 'Wrong key kind in file :', kknd
|
||||
stop 1
|
||||
endif
|
||||
read(66,err=98,end=98) ao_integrals_map%sorted, ao_integrals_map%map_size,&
|
||||
ao_integrals_map%n_elements
|
||||
do i=0_8, ao_integrals_map%map_size
|
||||
read(66,err=99,end=99) ao_integrals_map%map(i)%sorted, &
|
||||
ao_integrals_map%map(i)%map_size, ao_integrals_map%map(i)%n_elements
|
||||
call cache_map_reallocate(ao_integrals_map%map(i),ao_integrals_map%map(i)%map_size)
|
||||
enddo
|
||||
do i=0_8, ao_integrals_map%map_size
|
||||
key => ao_integrals_map%map(i)%key
|
||||
val => ao_integrals_map%map(i)%value
|
||||
n = ao_integrals_map%map(i)%n_elements
|
||||
read(66,err=99,end=99) (key(j), j=1,n), (val(j), j=1,n)
|
||||
enddo
|
||||
call map_sort(ao_integrals_map)
|
||||
load_ao_integrals = 0
|
||||
return
|
||||
99 continue
|
||||
call map_deinit(ao_integrals_map)
|
||||
98 continue
|
||||
stop 'Problem reading ao_integrals_map file in work/'
|
||||
|
||||
end
|
||||
|
||||
|
564
src/ao_two_e_ints/map_integrals_cplx.irp.f
Normal file
564
src/ao_two_e_ints/map_integrals_cplx.irp.f
Normal file
@ -0,0 +1,564 @@
|
||||
use map_module
|
||||
|
||||
|
||||
subroutine idx2_tri_int(i,j,ij)
|
||||
implicit none
|
||||
integer, intent(in) :: i,j
|
||||
integer, intent(out) :: ij
|
||||
integer :: p,q
|
||||
p = max(i,j)
|
||||
q = min(i,j)
|
||||
ij = q+ishft(p*p-p,-1)
|
||||
end
|
||||
|
||||
subroutine idx2_tri_key(i,j,ij)
|
||||
use map_module
|
||||
implicit none
|
||||
integer, intent(in) :: i,j
|
||||
integer(key_kind), intent(out) :: ij
|
||||
integer(key_kind) :: p,q
|
||||
p = max(i,j)
|
||||
q = min(i,j)
|
||||
ij = q+ishft(p*p-p,-1)
|
||||
end
|
||||
subroutine two_e_integrals_index_complex(i,j,k,l,i1,p,q)
|
||||
use map_module
|
||||
implicit none
|
||||
BEGIN_DOC
|
||||
! Gives a unique index for i,j,k,l using permtuation symmetry.
|
||||
! i <-> k, j <-> l, and (i,k) <-> (j,l)
|
||||
END_DOC
|
||||
integer, intent(in) :: i,j,k,l
|
||||
integer(key_kind), intent(out) :: i1
|
||||
integer(key_kind) :: r,s,i2
|
||||
integer(key_kind),intent(out) :: p,q
|
||||
p = min(i,k)
|
||||
r = max(i,k)
|
||||
p = p+shiftr(r*r-r,1)
|
||||
q = min(j,l)
|
||||
s = max(j,l)
|
||||
q = q+shiftr(s*s-s,1)
|
||||
i1 = min(p,q)
|
||||
i2 = max(p,q)
|
||||
i1 = i1+shiftr(i2*i2-i2,1)
|
||||
end
|
||||
|
||||
|
||||
|
||||
subroutine two_e_integrals_index_reverse_complex_1(i,j,k,l,i1)
|
||||
use map_module
|
||||
implicit none
|
||||
BEGIN_DOC
|
||||
! Computes the 4 indices $i,j,k,l$ from a unique index $i_1$.
|
||||
! For 2 indices $i,j$ and $i \le j$, we have
|
||||
! $p = i(i-1)/2 + j$.
|
||||
! The key point is that because $j < i$,
|
||||
! $i(i-1)/2 < p \le i(i+1)/2$. So $i$ can be found by solving
|
||||
! $i^2 - i - 2p=0$. One obtains $i=1 + \sqrt{1+8p}/2$
|
||||
! and $j = p - i(i-1)/2$.
|
||||
! This rule is applied 3 times. First for the symmetry of the
|
||||
! pairs (i,k) and (j,l), and then for the symmetry within each pair.
|
||||
! always returns first set such that i<=k, j<=l, ik<=jl
|
||||
END_DOC
|
||||
integer, intent(out) :: i(4),j(4),k(4),l(4)
|
||||
integer(key_kind), intent(in) :: i1
|
||||
integer(key_kind) :: i2,i3
|
||||
i = 0
|
||||
i2 = ceiling(0.5d0*(dsqrt(dble(shiftl(i1,3)+1))-1.d0))
|
||||
l(1) = ceiling(0.5d0*(dsqrt(dble(shiftl(i2,3)+1))-1.d0))
|
||||
i3 = i1 - shiftr(i2*i2-i2,1)
|
||||
k(1) = ceiling(0.5d0*(dsqrt(dble(shiftl(i3,3)+1))-1.d0))
|
||||
j(1) = int(i2 - shiftr(l(1)*l(1)-l(1),1),4)
|
||||
i(1) = int(i3 - shiftr(k(1)*k(1)-k(1),1),4)
|
||||
|
||||
!ijkl a+ib
|
||||
i(2) = j(1) !jilk a+ib
|
||||
j(2) = i(1)
|
||||
k(2) = l(1)
|
||||
l(2) = k(1)
|
||||
|
||||
i(3) = k(1) !klij a-ib
|
||||
j(3) = l(1)
|
||||
k(3) = i(1)
|
||||
l(3) = j(1)
|
||||
|
||||
i(4) = l(1) !lkji a-ib
|
||||
j(4) = k(1)
|
||||
k(4) = j(1)
|
||||
l(4) = i(1)
|
||||
|
||||
integer :: ii, jj
|
||||
do ii=2,4
|
||||
do jj=1,ii-1
|
||||
if ( (i(ii) == i(jj)).and. &
|
||||
(j(ii) == j(jj)).and. &
|
||||
(k(ii) == k(jj)).and. &
|
||||
(l(ii) == l(jj)) ) then
|
||||
i(ii) = 0
|
||||
exit
|
||||
endif
|
||||
enddo
|
||||
enddo
|
||||
end
|
||||
|
||||
subroutine two_e_integrals_index_reverse_complex_2(i,j,k,l,i1)
|
||||
use map_module
|
||||
implicit none
|
||||
BEGIN_DOC
|
||||
! Computes the 4 indices $i,j,k,l$ from a unique index $i_1$.
|
||||
! For 2 indices $i,j$ and $i \le j$, we have
|
||||
! $p = i(i-1)/2 + j$.
|
||||
! The key point is that because $j < i$,
|
||||
! $i(i-1)/2 < p \le i(i+1)/2$. So $i$ can be found by solving
|
||||
! $i^2 - i - 2p=0$. One obtains $i=1 + \sqrt{1+8p}/2$
|
||||
! and $j = p - i(i-1)/2$.
|
||||
! This rule is applied 3 times. First for the symmetry of the
|
||||
! pairs (i,k) and (j,l), and then for the symmetry within each pair.
|
||||
! always returns first set such that k<=i, j<=l, ik<=jl
|
||||
END_DOC
|
||||
integer, intent(out) :: i(4),j(4),k(4),l(4)
|
||||
integer(key_kind), intent(in) :: i1
|
||||
integer(key_kind) :: i2,i3
|
||||
i = 0
|
||||
i2 = ceiling(0.5d0*(dsqrt(dble(shiftl(i1,3)+1))-1.d0))
|
||||
l(1) = ceiling(0.5d0*(dsqrt(dble(shiftl(i2,3)+1))-1.d0))
|
||||
i3 = i1 - shiftr(i2*i2-i2,1)
|
||||
i(1) = ceiling(0.5d0*(dsqrt(dble(shiftl(i3,3)+1))-1.d0))
|
||||
j(1) = int(i2 - shiftr(l(1)*l(1)-l(1),1),4)
|
||||
k(1) = int(i3 - shiftr(i(1)*i(1)-i(1),1),4)
|
||||
|
||||
!kjil a+ib
|
||||
i(2) = j(1) !jkli a+ib
|
||||
j(2) = i(1)
|
||||
k(2) = l(1)
|
||||
l(2) = k(1)
|
||||
|
||||
i(3) = k(1) !ilkj a-ib
|
||||
j(3) = l(1)
|
||||
k(3) = i(1)
|
||||
l(3) = j(1)
|
||||
|
||||
i(4) = l(1) !lijk a-ib
|
||||
j(4) = k(1)
|
||||
k(4) = j(1)
|
||||
l(4) = i(1)
|
||||
|
||||
integer :: ii, jj
|
||||
do ii=2,4
|
||||
do jj=1,ii-1
|
||||
if ( (i(ii) == i(jj)).and. &
|
||||
(j(ii) == j(jj)).and. &
|
||||
(k(ii) == k(jj)).and. &
|
||||
(l(ii) == l(jj)) ) then
|
||||
i(ii) = 0
|
||||
exit
|
||||
endif
|
||||
enddo
|
||||
enddo
|
||||
end
|
||||
|
||||
|
||||
BEGIN_PROVIDER [ complex*16, ao_integrals_cache_complex, (0:64*64*64*64) ]
|
||||
implicit none
|
||||
BEGIN_DOC
|
||||
! Cache of AO integrals for fast access
|
||||
END_DOC
|
||||
PROVIDE ao_two_e_integrals_in_map
|
||||
integer :: i,j,k,l,ii
|
||||
integer(key_kind) :: idx1, idx2
|
||||
real(integral_kind) :: tmp_re, tmp_im
|
||||
integer(key_kind) :: idx_re,idx_im
|
||||
complex(integral_kind) :: integral
|
||||
integer(key_kind) :: p,q,r,s,ik,jl
|
||||
logical :: ilek, jlel, iklejl
|
||||
complex*16 :: get_ao_two_e_integral_complex_simple
|
||||
|
||||
|
||||
!$OMP PARALLEL DO PRIVATE (ilek,jlel,p,q,r,s, ik,jl,iklejl, &
|
||||
!$OMP i,j,k,l,idx1,idx2,tmp_re,tmp_im,idx_re,idx_im,ii,integral)
|
||||
do l=ao_integrals_cache_min,ao_integrals_cache_max
|
||||
do k=ao_integrals_cache_min,ao_integrals_cache_max
|
||||
do j=ao_integrals_cache_min,ao_integrals_cache_max
|
||||
do i=ao_integrals_cache_min,ao_integrals_cache_max
|
||||
!DIR$ FORCEINLINE
|
||||
integral = get_ao_two_e_integral_complex_simple(i,j,k,l,&
|
||||
ao_integrals_map,ao_integrals_map_2)
|
||||
|
||||
ii = l-ao_integrals_cache_min
|
||||
ii = ior( shiftl(ii,6), k-ao_integrals_cache_min)
|
||||
ii = ior( shiftl(ii,6), j-ao_integrals_cache_min)
|
||||
ii = ior( shiftl(ii,6), i-ao_integrals_cache_min)
|
||||
ao_integrals_cache_complex(ii) = integral
|
||||
enddo
|
||||
enddo
|
||||
enddo
|
||||
enddo
|
||||
!$OMP END PARALLEL DO
|
||||
|
||||
END_PROVIDER
|
||||
|
||||
subroutine ao_two_e_integral_complex_map_idx_sign(i,j,k,l,use_map1,idx,sign)
|
||||
use map_module
|
||||
implicit none
|
||||
BEGIN_DOC
|
||||
! get position of periodic AO integral <ij|kl>
|
||||
! use_map1: true if integral is in first ao map, false if integral is in second ao map
|
||||
! idx: position of real part of integral in map (imag part is at idx+1)
|
||||
! sign: sign of imaginary part
|
||||
!
|
||||
!
|
||||
! for <ab|cd>, conditionals are [a<c, b<d, ac<bd]
|
||||
! last two rows are real (ab==cd)
|
||||
! +---------+---------+---------+---------+---------+---------+---------+---------+---------+
|
||||
! | NEW | <ij|kl> | <ji|lk> | <kl|ij> | <lk|ji> | <kj|il> | <jk|li> | <il|kj> | <li|jk> |
|
||||
! +---------+---------+---------+---------+---------+---------+---------+---------+---------+
|
||||
! | | m1 | m1* | m2 | m2* |
|
||||
! +---------+---------+---------+---------+---------+---------+---------+---------+---------+
|
||||
! | <ij|kl> | TTT | TTF | FFT | FFF | FTT | TFF | TFT | FTF |
|
||||
! | <ij|il> | 0TT | T0F | 0FT | F0F | | | | |
|
||||
! | <ij|kj> | T0T | 0TF | F0T | 0FF | | | | |
|
||||
! | <ii|jj> | TT0 | | FF0 | | FT0(r) | TF0(r) | | |
|
||||
! +---------+---------+---------+---------+---------+---------+---------+---------+---------+
|
||||
! | <ij|ij> | | | | | 00T(r) | 00F(r) | | |
|
||||
! | <ii|ii> | | | | | 000 | | | |
|
||||
! +---------+---------+---------+---------+---------+---------+---------+---------+---------+
|
||||
END_DOC
|
||||
integer, intent(in) :: i,j,k,l
|
||||
integer(key_kind), intent(out) :: idx
|
||||
logical, intent(out) :: use_map1
|
||||
double precision, intent(out) :: sign
|
||||
integer(key_kind) :: p,q,r,s,ik,jl,ij,kl
|
||||
!DIR$ FORCEINLINE
|
||||
call two_e_integrals_index_complex(i,j,k,l,idx,ik,jl)
|
||||
p = min(i,j)
|
||||
r = max(i,j)
|
||||
ij = p+shiftr(r*r-r,1)
|
||||
q = min(k,l)
|
||||
s = max(k,l)
|
||||
kl = q+shiftr(s*s-s,1)
|
||||
|
||||
idx = 2*idx-1
|
||||
|
||||
if (ij==kl) then !real, J -> map1, K -> map2
|
||||
sign=0.d0
|
||||
use_map1=.False.
|
||||
else
|
||||
if (ik.eq.jl) then
|
||||
if (i.lt.k) then !TT0
|
||||
sign=1.d0
|
||||
use_map1=.True.
|
||||
else !FF0
|
||||
sign=-1.d0
|
||||
use_map1=.True.
|
||||
endif
|
||||
else if (i.eq.k) then
|
||||
if (j.lt.l) then !0T*
|
||||
sign=1.d0
|
||||
use_map1=.True.
|
||||
else !0F*
|
||||
sign=-1.d0
|
||||
use_map1=.True.
|
||||
endif
|
||||
else if (j.eq.l) then
|
||||
if (i.lt.k) then
|
||||
sign=1.d0
|
||||
use_map1=.True.
|
||||
else
|
||||
sign=-1.d0
|
||||
use_map1=.True.
|
||||
endif
|
||||
else if ((i.lt.k).eqv.(j.lt.l)) then
|
||||
if (i.lt.k) then
|
||||
sign=1.d0
|
||||
use_map1=.True.
|
||||
else
|
||||
sign=-1.d0
|
||||
use_map1=.True.
|
||||
endif
|
||||
else
|
||||
if ((j.lt.l).eqv.(ik.lt.jl)) then
|
||||
sign=1.d0
|
||||
use_map1=.False.
|
||||
else
|
||||
sign=-1.d0
|
||||
use_map1=.False.
|
||||
endif
|
||||
endif
|
||||
endif
|
||||
end
|
||||
|
||||
complex*16 function get_ao_two_e_integral_complex_simple(i,j,k,l,map,map2) result(result)
|
||||
use map_module
|
||||
implicit none
|
||||
BEGIN_DOC
|
||||
! Gets one AO bi-electronic integral from the AO map
|
||||
END_DOC
|
||||
integer, intent(in) :: i,j,k,l
|
||||
integer(key_kind) :: idx1,idx2,idx
|
||||
real(integral_kind) :: tmp_re, tmp_im
|
||||
integer(key_kind) :: idx_re,idx_im
|
||||
type(map_type), intent(inout) :: map,map2
|
||||
integer :: ii
|
||||
complex(integral_kind) :: tmp
|
||||
integer(key_kind) :: p,q,r,s,ik,jl
|
||||
logical :: ilek, jlel, iklejl,use_map1
|
||||
double precision :: sign
|
||||
! a.le.c, b.le.d, tri(a,c).le.tri(b,d)
|
||||
PROVIDE ao_two_e_integrals_in_map
|
||||
call ao_two_e_integral_complex_map_idx_sign(i,j,k,l,use_map1,idx,sign)
|
||||
if (use_map1) then
|
||||
call map_get(map,idx,tmp_re)
|
||||
call map_get(map,idx+1,tmp_im)
|
||||
tmp_im *= sign
|
||||
else
|
||||
call map_get(map2,idx,tmp_re)
|
||||
if (sign/=0.d0) then
|
||||
call map_get(map2,idx+1,tmp_im)
|
||||
tmp_im *= sign
|
||||
else
|
||||
tmp_im=0.d0
|
||||
endif
|
||||
endif
|
||||
tmp = dcmplx(tmp_re,tmp_im)
|
||||
result = tmp
|
||||
end
|
||||
|
||||
|
||||
complex*16 function get_ao_two_e_integral_complex(i,j,k,l,map,map2) result(result)
|
||||
use map_module
|
||||
implicit none
|
||||
BEGIN_DOC
|
||||
! Gets one AO bi-electronic integral from the AO map
|
||||
END_DOC
|
||||
integer, intent(in) :: i,j,k,l
|
||||
integer(key_kind) :: idx1,idx2
|
||||
real(integral_kind) :: tmp_re, tmp_im
|
||||
integer(key_kind) :: idx_re,idx_im
|
||||
type(map_type), intent(inout) :: map,map2
|
||||
integer :: ii
|
||||
complex(integral_kind) :: tmp
|
||||
complex(integral_kind) :: get_ao_two_e_integral_complex_simple
|
||||
integer(key_kind) :: p,q,r,s,ik,jl
|
||||
logical :: ilek, jlel, iklejl
|
||||
! a.le.c, b.le.d, tri(a,c).le.tri(b,d)
|
||||
PROVIDE ao_two_e_integrals_in_map ao_integrals_cache_complex ao_integrals_cache_min
|
||||
!DIR$ FORCEINLINE
|
||||
! if (ao_overlap_abs(i,k)*ao_overlap_abs(j,l) < ao_integrals_threshold ) then
|
||||
! tmp = (0.d0,0.d0)
|
||||
! else if (ao_two_e_integral_schwartz(i,k)*ao_two_e_integral_schwartz(j,l) < ao_integrals_threshold) then
|
||||
! tmp = (0.d0,0.d0)
|
||||
! else
|
||||
if (.True.) then
|
||||
ii = l-ao_integrals_cache_min
|
||||
ii = ior(ii, k-ao_integrals_cache_min)
|
||||
ii = ior(ii, j-ao_integrals_cache_min)
|
||||
ii = ior(ii, i-ao_integrals_cache_min)
|
||||
if (iand(ii, -64) /= 0) then
|
||||
tmp = get_ao_two_e_integral_complex_simple(i,j,k,l,map,map2)
|
||||
else
|
||||
ii = l-ao_integrals_cache_min
|
||||
ii = ior( shiftl(ii,6), k-ao_integrals_cache_min)
|
||||
ii = ior( shiftl(ii,6), j-ao_integrals_cache_min)
|
||||
ii = ior( shiftl(ii,6), i-ao_integrals_cache_min)
|
||||
tmp = ao_integrals_cache_complex(ii)
|
||||
endif
|
||||
result = tmp
|
||||
endif
|
||||
end
|
||||
|
||||
|
||||
subroutine get_ao_two_e_integrals_complex(j,k,l,sze,out_val)
|
||||
use map_module
|
||||
BEGIN_DOC
|
||||
! Gets multiple AO bi-electronic integral from the AO map .
|
||||
! All i are retrieved for j,k,l fixed.
|
||||
! physicist convention : <ij|kl>
|
||||
END_DOC
|
||||
implicit none
|
||||
integer, intent(in) :: j,k,l, sze
|
||||
complex*16, intent(out) :: out_val(sze)
|
||||
|
||||
integer :: i
|
||||
integer(key_kind) :: hash
|
||||
double precision :: thresh
|
||||
PROVIDE ao_two_e_integrals_in_map ao_integrals_map
|
||||
thresh = ao_integrals_threshold
|
||||
|
||||
if (ao_overlap_abs(j,l) < thresh) then
|
||||
out_val = (0.d0,0.d0)
|
||||
return
|
||||
endif
|
||||
|
||||
complex*16 :: get_ao_two_e_integral_complex
|
||||
do i=1,sze
|
||||
out_val(i) = get_ao_two_e_integral_complex(i,j,k,l,ao_integrals_map,ao_integrals_map_2)
|
||||
enddo
|
||||
|
||||
end
|
||||
|
||||
subroutine get_ao_two_e_integrals_non_zero_complex(j,k,l,sze,out_val,out_val_index,non_zero_int)
|
||||
print*,'not implemented for periodic',irp_here
|
||||
stop -1
|
||||
! use map_module
|
||||
! implicit none
|
||||
! BEGIN_DOC
|
||||
! ! Gets multiple AO bi-electronic integral from the AO map .
|
||||
! ! All non-zero i are retrieved for j,k,l fixed.
|
||||
! END_DOC
|
||||
! integer, intent(in) :: j,k,l, sze
|
||||
! real(integral_kind), intent(out) :: out_val(sze)
|
||||
! integer, intent(out) :: out_val_index(sze),non_zero_int
|
||||
!
|
||||
! integer :: i
|
||||
! integer(key_kind) :: hash
|
||||
! double precision :: thresh,tmp
|
||||
! if(is_complex) then
|
||||
! print*,'not implemented for periodic:',irp_here
|
||||
! stop -1
|
||||
! endif
|
||||
! PROVIDE ao_two_e_integrals_in_map
|
||||
! thresh = ao_integrals_threshold
|
||||
!
|
||||
! non_zero_int = 0
|
||||
! if (ao_overlap_abs(j,l) < thresh) then
|
||||
! out_val = 0.d0
|
||||
! return
|
||||
! endif
|
||||
!
|
||||
! non_zero_int = 0
|
||||
! do i=1,sze
|
||||
! integer, external :: ao_l4
|
||||
! double precision, external :: ao_two_e_integral
|
||||
! !DIR$ FORCEINLINE
|
||||
! if (ao_two_e_integral_schwartz(i,k)*ao_two_e_integral_schwartz(j,l) < thresh) then
|
||||
! cycle
|
||||
! endif
|
||||
! call two_e_integrals_index(i,j,k,l,hash)
|
||||
! call map_get(ao_integrals_map, hash,tmp)
|
||||
! if (dabs(tmp) < thresh ) cycle
|
||||
! non_zero_int = non_zero_int+1
|
||||
! out_val_index(non_zero_int) = i
|
||||
! out_val(non_zero_int) = tmp
|
||||
! enddo
|
||||
|
||||
end
|
||||
|
||||
|
||||
subroutine get_ao_two_e_integrals_non_zero_jl_complex(j,l,thresh,sze_max,sze,out_val,out_val_index,non_zero_int)
|
||||
print*,'not implemented for periodic',irp_here
|
||||
stop -1
|
||||
! use map_module
|
||||
! implicit none
|
||||
! BEGIN_DOC
|
||||
! ! Gets multiple AO bi-electronic integral from the AO map .
|
||||
! ! All non-zero i are retrieved for j,k,l fixed.
|
||||
! END_DOC
|
||||
! double precision, intent(in) :: thresh
|
||||
! integer, intent(in) :: j,l, sze,sze_max
|
||||
! real(integral_kind), intent(out) :: out_val(sze_max)
|
||||
! integer, intent(out) :: out_val_index(2,sze_max),non_zero_int
|
||||
!
|
||||
! integer :: i,k
|
||||
! integer(key_kind) :: hash
|
||||
! double precision :: tmp
|
||||
!
|
||||
! if(is_complex) then
|
||||
! print*,'not implemented for periodic:',irp_here
|
||||
! stop -1
|
||||
! endif
|
||||
! PROVIDE ao_two_e_integrals_in_map
|
||||
! non_zero_int = 0
|
||||
! if (ao_overlap_abs(j,l) < thresh) then
|
||||
! out_val = 0.d0
|
||||
! return
|
||||
! endif
|
||||
!
|
||||
! non_zero_int = 0
|
||||
! do k = 1, sze
|
||||
! do i = 1, sze
|
||||
! integer, external :: ao_l4
|
||||
! double precision, external :: ao_two_e_integral
|
||||
! !DIR$ FORCEINLINE
|
||||
! if (ao_two_e_integral_schwartz(i,k)*ao_two_e_integral_schwartz(j,l) < thresh) then
|
||||
! cycle
|
||||
! endif
|
||||
! call two_e_integrals_index(i,j,k,l,hash)
|
||||
! call map_get(ao_integrals_map, hash,tmp)
|
||||
! if (dabs(tmp) < thresh ) cycle
|
||||
! non_zero_int = non_zero_int+1
|
||||
! out_val_index(1,non_zero_int) = i
|
||||
! out_val_index(2,non_zero_int) = k
|
||||
! out_val(non_zero_int) = tmp
|
||||
! enddo
|
||||
! enddo
|
||||
|
||||
end
|
||||
|
||||
|
||||
subroutine get_ao_two_e_integrals_non_zero_jl_from_list_complex(j,l,thresh,list,n_list,sze_max,out_val,out_val_index,non_zero_int)
|
||||
print*,'not implemented for periodic',irp_here
|
||||
stop -1
|
||||
! use map_module
|
||||
! implicit none
|
||||
! BEGIN_DOC
|
||||
! ! Gets multiple AO two-electron integrals from the AO map .
|
||||
! ! All non-zero i are retrieved for j,k,l fixed.
|
||||
! END_DOC
|
||||
! double precision, intent(in) :: thresh
|
||||
! integer, intent(in) :: sze_max
|
||||
! integer, intent(in) :: j,l, n_list,list(2,sze_max)
|
||||
! real(integral_kind), intent(out) :: out_val(sze_max)
|
||||
! integer, intent(out) :: out_val_index(2,sze_max),non_zero_int
|
||||
!
|
||||
! integer :: i,k
|
||||
! integer(key_kind) :: hash
|
||||
! double precision :: tmp
|
||||
!
|
||||
! if(is_complex) then
|
||||
! print*,'not implemented for periodic:',irp_here
|
||||
! stop -1
|
||||
! endif
|
||||
! PROVIDE ao_two_e_integrals_in_map
|
||||
! non_zero_int = 0
|
||||
! if (ao_overlap_abs(j,l) < thresh) then
|
||||
! out_val = 0.d0
|
||||
! return
|
||||
! endif
|
||||
!
|
||||
! non_zero_int = 0
|
||||
! integer :: kk
|
||||
! do kk = 1, n_list
|
||||
! k = list(1,kk)
|
||||
! i = list(2,kk)
|
||||
! integer, external :: ao_l4
|
||||
! double precision, external :: ao_two_e_integral
|
||||
! !DIR$ FORCEINLINE
|
||||
! if (ao_two_e_integral_schwartz(i,k)*ao_two_e_integral_schwartz(j,l) < thresh) then
|
||||
! cycle
|
||||
! endif
|
||||
! call two_e_integrals_index(i,j,k,l,hash)
|
||||
! call map_get(ao_integrals_map, hash,tmp)
|
||||
! if (dabs(tmp) < thresh ) cycle
|
||||
! non_zero_int = non_zero_int+1
|
||||
! out_val_index(1,non_zero_int) = i
|
||||
! out_val_index(2,non_zero_int) = k
|
||||
! out_val(non_zero_int) = tmp
|
||||
! enddo
|
||||
|
||||
end
|
||||
|
||||
subroutine insert_into_ao_integrals_map_2(n_integrals,buffer_i, buffer_values)
|
||||
use map_module
|
||||
implicit none
|
||||
BEGIN_DOC
|
||||
! Create new entry into AO map
|
||||
END_DOC
|
||||
|
||||
integer, intent(in) :: n_integrals
|
||||
integer(key_kind), intent(inout) :: buffer_i(n_integrals)
|
||||
real(integral_kind), intent(inout) :: buffer_values(n_integrals)
|
||||
|
||||
call map_append(ao_integrals_map_2, buffer_i, buffer_values, n_integrals)
|
||||
end
|
||||
|
||||
|
@ -348,77 +348,96 @@ BEGIN_PROVIDER [ logical, ao_two_e_integrals_in_map ]
|
||||
integer :: kk, m, j1, i1, lmax
|
||||
character*(64) :: fmt
|
||||
|
||||
integral = ao_two_e_integral(1,1,1,1)
|
||||
|
||||
double precision :: map_mb
|
||||
PROVIDE read_ao_two_e_integrals io_ao_two_e_integrals
|
||||
if (read_ao_two_e_integrals) then
|
||||
print*,'Reading the AO integrals'
|
||||
if (is_complex) then
|
||||
if (read_ao_two_e_integrals) then
|
||||
print*,'Reading the AO integrals (periodic)'
|
||||
call map_load_from_disk(trim(ezfio_filename)//'/work/ao_ints_complex_1',ao_integrals_map)
|
||||
call map_load_from_disk(trim(ezfio_filename)//'/work/ao_ints_complex_2',ao_integrals_map_2)
|
||||
print*, 'AO integrals provided (periodic)'
|
||||
ao_two_e_integrals_in_map = .True.
|
||||
return
|
||||
else if (read_df_ao_integrals) then
|
||||
call ao_map_fill_from_df
|
||||
print*, 'AO integrals provided from 3-index ao ints (periodic)'
|
||||
ao_two_e_integrals_in_map = .True.
|
||||
return
|
||||
else
|
||||
print*,'calculation of periodic AOs not implemented'
|
||||
stop -1
|
||||
endif
|
||||
|
||||
else
|
||||
if (read_ao_two_e_integrals) then
|
||||
print*,'Reading the AO integrals'
|
||||
call map_load_from_disk(trim(ezfio_filename)//'/work/ao_ints',ao_integrals_map)
|
||||
print*, 'AO integrals provided'
|
||||
ao_two_e_integrals_in_map = .True.
|
||||
return
|
||||
endif
|
||||
|
||||
print*, 'Providing the AO integrals'
|
||||
call wall_time(wall_0)
|
||||
call wall_time(wall_1)
|
||||
call cpu_time(cpu_1)
|
||||
|
||||
integer(ZMQ_PTR) :: zmq_to_qp_run_socket, zmq_socket_pull
|
||||
call new_parallel_job(zmq_to_qp_run_socket,zmq_socket_pull,'ao_integrals')
|
||||
|
||||
character(len=:), allocatable :: task
|
||||
allocate(character(len=ao_num*12) :: task)
|
||||
write(fmt,*) '(', ao_num, '(I5,X,I5,''|''))'
|
||||
do l=1,ao_num
|
||||
write(task,fmt) (i,l, i=1,l)
|
||||
integer, external :: add_task_to_taskserver
|
||||
if (add_task_to_taskserver(zmq_to_qp_run_socket,trim(task)) == -1) then
|
||||
stop 'Unable to add task to server'
|
||||
endif
|
||||
enddo
|
||||
deallocate(task)
|
||||
|
||||
integer, external :: zmq_set_running
|
||||
if (zmq_set_running(zmq_to_qp_run_socket) == -1) then
|
||||
print *, irp_here, ': Failed in zmq_set_running'
|
||||
endif
|
||||
|
||||
PROVIDE nproc
|
||||
!$OMP PARALLEL DEFAULT(shared) private(i) num_threads(nproc+1)
|
||||
i = omp_get_thread_num()
|
||||
if (i==0) then
|
||||
call ao_two_e_integrals_in_map_collector(zmq_socket_pull)
|
||||
else
|
||||
call ao_two_e_integrals_in_map_slave_inproc(i)
|
||||
|
||||
integral = ao_two_e_integral(1,1,1,1)
|
||||
print*, 'Providing the AO integrals'
|
||||
call wall_time(wall_0)
|
||||
call wall_time(wall_1)
|
||||
call cpu_time(cpu_1)
|
||||
|
||||
integer(ZMQ_PTR) :: zmq_to_qp_run_socket, zmq_socket_pull
|
||||
call new_parallel_job(zmq_to_qp_run_socket,zmq_socket_pull,'ao_integrals')
|
||||
|
||||
character(len=:), allocatable :: task
|
||||
allocate(character(len=ao_num*12) :: task)
|
||||
write(fmt,*) '(', ao_num, '(I5,X,I5,''|''))'
|
||||
do l=1,ao_num
|
||||
write(task,fmt) (i,l, i=1,l)
|
||||
integer, external :: add_task_to_taskserver
|
||||
if (add_task_to_taskserver(zmq_to_qp_run_socket,trim(task)) == -1) then
|
||||
stop 'Unable to add task to server'
|
||||
endif
|
||||
!$OMP END PARALLEL
|
||||
|
||||
call end_parallel_job(zmq_to_qp_run_socket, zmq_socket_pull, 'ao_integrals')
|
||||
|
||||
|
||||
print*, 'Sorting the map'
|
||||
call map_sort(ao_integrals_map)
|
||||
call cpu_time(cpu_2)
|
||||
call wall_time(wall_2)
|
||||
integer(map_size_kind) :: get_ao_map_size, ao_map_size
|
||||
ao_map_size = get_ao_map_size()
|
||||
|
||||
print*, 'AO integrals provided:'
|
||||
print*, ' Size of AO map : ', map_mb(ao_integrals_map) ,'MB'
|
||||
print*, ' Number of AO integrals :', ao_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+tiny(1.d0)), ' )'
|
||||
|
||||
ao_two_e_integrals_in_map = .True.
|
||||
|
||||
if (write_ao_two_e_integrals.and.mpi_master) then
|
||||
call ezfio_set_work_empty(.False.)
|
||||
call map_save_to_disk(trim(ezfio_filename)//'/work/ao_ints',ao_integrals_map)
|
||||
call ezfio_set_ao_two_e_ints_io_ao_two_e_integrals('Read')
|
||||
enddo
|
||||
deallocate(task)
|
||||
|
||||
integer, external :: zmq_set_running
|
||||
if (zmq_set_running(zmq_to_qp_run_socket) == -1) then
|
||||
print *, irp_here, ': Failed in zmq_set_running'
|
||||
endif
|
||||
|
||||
PROVIDE nproc
|
||||
!$OMP PARALLEL DEFAULT(shared) private(i) num_threads(nproc+1)
|
||||
i = omp_get_thread_num()
|
||||
if (i==0) then
|
||||
call ao_two_e_integrals_in_map_collector(zmq_socket_pull)
|
||||
else
|
||||
call ao_two_e_integrals_in_map_slave_inproc(i)
|
||||
endif
|
||||
!$OMP END PARALLEL
|
||||
|
||||
call end_parallel_job(zmq_to_qp_run_socket, zmq_socket_pull, 'ao_integrals')
|
||||
|
||||
|
||||
print*, 'Sorting the map'
|
||||
call map_sort(ao_integrals_map)
|
||||
call cpu_time(cpu_2)
|
||||
call wall_time(wall_2)
|
||||
integer(map_size_kind) :: get_ao_map_size, ao_map_size
|
||||
ao_map_size = get_ao_map_size()
|
||||
|
||||
print*, 'AO integrals provided:'
|
||||
print*, ' Size of AO map : ', map_mb(ao_integrals_map) ,'MB'
|
||||
print*, ' Number of AO integrals :', ao_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+tiny(1.d0)), ' )'
|
||||
|
||||
ao_two_e_integrals_in_map = .True.
|
||||
|
||||
if (write_ao_two_e_integrals.and.mpi_master) then
|
||||
call ezfio_set_work_empty(.False.)
|
||||
call map_save_to_disk(trim(ezfio_filename)//'/work/ao_ints',ao_integrals_map)
|
||||
call ezfio_set_ao_two_e_ints_io_ao_two_e_integrals('Read')
|
||||
endif
|
||||
endif
|
||||
|
||||
END_PROVIDER
|
||||
|
||||
BEGIN_PROVIDER [ double precision, ao_two_e_integral_schwartz,(ao_num,ao_num) ]
|
||||
|
@ -80,9 +80,23 @@ BEGIN_PROVIDER [ integer(bit_kind), HF_bitmask, (N_int,2)]
|
||||
integer :: occ(elec_alpha_num)
|
||||
|
||||
HF_bitmask = 0_bit_kind
|
||||
do i=1,elec_alpha_num
|
||||
occ(i) = i
|
||||
enddo
|
||||
if (is_complex) then
|
||||
integer :: kpt,korb
|
||||
kpt=1
|
||||
korb=1
|
||||
do i=1,elec_alpha_num
|
||||
occ(i) = korb + (kpt-1) * mo_num_per_kpt
|
||||
kpt += 1
|
||||
if (kpt > kpt_num) then
|
||||
kpt = 1
|
||||
korb += 1
|
||||
endif
|
||||
enddo
|
||||
else
|
||||
do i=1,elec_alpha_num
|
||||
occ(i) = i
|
||||
enddo
|
||||
endif
|
||||
call list_to_bitstring( HF_bitmask(1,1), occ, elec_alpha_num, N_int)
|
||||
! elec_alpha_num <= elec_beta_num, so occ is already OK.
|
||||
call list_to_bitstring( HF_bitmask(1,2), occ, elec_beta_num, N_int)
|
||||
@ -240,3 +254,252 @@ BEGIN_PROVIDER [integer(bit_kind), closed_shell_ref_bitmask, (N_int,2)]
|
||||
closed_shell_ref_bitmask(i,2) = ior(ref_bitmask(i,2),act_bitmask(i,2))
|
||||
enddo
|
||||
END_PROVIDER
|
||||
|
||||
!============================================!
|
||||
! !
|
||||
! kpts !
|
||||
! !
|
||||
!============================================!
|
||||
|
||||
!BEGIN_PROVIDER [ integer(bit_kind), full_ijkl_bitmask, (N_int) ]
|
||||
! implicit none
|
||||
! BEGIN_DOC
|
||||
! ! Bitmask to include all possible MOs
|
||||
! END_DOC
|
||||
!
|
||||
! integer :: i,j,k
|
||||
! k=0
|
||||
! do j=1,N_int
|
||||
! full_ijkl_bitmask(j) = 0_bit_kind
|
||||
! do i=0,bit_kind_size-1
|
||||
! k=k+1
|
||||
! if (mo_class(k) /= 'Deleted') then
|
||||
! full_ijkl_bitmask(j) = ibset(full_ijkl_bitmask(j),i)
|
||||
! endif
|
||||
! if (k == mo_num) exit
|
||||
! enddo
|
||||
! enddo
|
||||
!END_PROVIDER
|
||||
!
|
||||
!BEGIN_PROVIDER [ integer(bit_kind), full_ijkl_bitmask_4, (N_int,4) ]
|
||||
! implicit none
|
||||
! integer :: i
|
||||
! do i=1,N_int
|
||||
! full_ijkl_bitmask_4(i,1) = full_ijkl_bitmask(i)
|
||||
! full_ijkl_bitmask_4(i,2) = full_ijkl_bitmask(i)
|
||||
! full_ijkl_bitmask_4(i,3) = full_ijkl_bitmask(i)
|
||||
! full_ijkl_bitmask_4(i,4) = full_ijkl_bitmask(i)
|
||||
! enddo
|
||||
!END_PROVIDER
|
||||
!
|
||||
!BEGIN_PROVIDER [ integer(bit_kind), 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_kpts, (N_int,2,kpt_num)]
|
||||
implicit none
|
||||
BEGIN_DOC
|
||||
! Hartree Fock bit mask
|
||||
END_DOC
|
||||
integer :: i,k
|
||||
|
||||
hf_bitmask_kpts = 0_bit_kind
|
||||
do k=1,kpt_num
|
||||
do i=1,N_int
|
||||
hf_bitmask_kpts(i,1,k) = iand(hf_bitmask(i,1),kpts_bitmask(i,k))
|
||||
hf_bitmask_kpts(i,2,k) = iand(hf_bitmask(i,2),kpts_bitmask(i,k))
|
||||
enddo
|
||||
enddo
|
||||
END_PROVIDER
|
||||
|
||||
BEGIN_PROVIDER [ integer(bit_kind), ref_bitmask_kpts, (N_int,2,kpt_num)]
|
||||
implicit none
|
||||
BEGIN_DOC
|
||||
! Reference bit mask, used in Slater rules, chosen as Hartree-Fock bitmask
|
||||
END_DOC
|
||||
ref_bitmask_kpts = HF_bitmask_kpts
|
||||
END_PROVIDER
|
||||
|
||||
|
||||
|
||||
!BEGIN_PROVIDER [ integer(bit_kind), generators_bitmask, (N_int,2,6) ]
|
||||
! implicit none
|
||||
! BEGIN_DOC
|
||||
! ! Bitmasks for generator determinants.
|
||||
! ! (N_int, alpha/beta, hole/particle, generator).
|
||||
! !
|
||||
! ! 3rd index is :
|
||||
! !
|
||||
! ! * 1 : hole for single exc
|
||||
! !
|
||||
! ! * 2 : particle for single exc
|
||||
! !
|
||||
! ! * 3 : hole for 1st exc of double
|
||||
! !
|
||||
! ! * 4 : particle for 1st exc of double
|
||||
! !
|
||||
! ! * 5 : hole for 2nd exc of double
|
||||
! !
|
||||
! ! * 6 : particle for 2nd exc of double
|
||||
! !
|
||||
! END_DOC
|
||||
! logical :: exists
|
||||
! PROVIDE ezfio_filename full_ijkl_bitmask
|
||||
!
|
||||
! integer :: ispin, i
|
||||
! do ispin=1,2
|
||||
! do i=1,N_int
|
||||
! generators_bitmask(i,ispin,s_hole ) = reunion_of_inact_act_bitmask(i,ispin)
|
||||
! generators_bitmask(i,ispin,s_part ) = reunion_of_act_virt_bitmask(i,ispin)
|
||||
! generators_bitmask(i,ispin,d_hole1) = reunion_of_inact_act_bitmask(i,ispin)
|
||||
! generators_bitmask(i,ispin,d_part1) = reunion_of_act_virt_bitmask(i,ispin)
|
||||
! generators_bitmask(i,ispin,d_hole2) = reunion_of_inact_act_bitmask(i,ispin)
|
||||
! generators_bitmask(i,ispin,d_part2) = reunion_of_act_virt_bitmask(i,ispin)
|
||||
! enddo
|
||||
! enddo
|
||||
!
|
||||
!END_PROVIDER
|
||||
|
||||
BEGIN_PROVIDER [ integer(bit_kind), reunion_of_core_inact_bitmask_kpts, (N_int,2,kpt_num)]
|
||||
implicit none
|
||||
BEGIN_DOC
|
||||
! Reunion of the core and inactive and virtual bitmasks
|
||||
END_DOC
|
||||
integer :: i,k
|
||||
do k=1,kpt_num
|
||||
do i = 1, N_int
|
||||
reunion_of_core_inact_bitmask_kpts(i,1,k) = ior(core_bitmask_kpts(i,1,k),inact_bitmask_kpts(i,1,k))
|
||||
reunion_of_core_inact_bitmask_kpts(i,2,k) = ior(core_bitmask_kpts(i,2,k),inact_bitmask_kpts(i,2,k))
|
||||
enddo
|
||||
enddo
|
||||
END_PROVIDER
|
||||
|
||||
|
||||
BEGIN_PROVIDER [integer(bit_kind), reunion_of_inact_act_bitmask_kpts, (N_int,2,kpt_num)]
|
||||
implicit none
|
||||
BEGIN_DOC
|
||||
! Reunion of the inactive and active bitmasks
|
||||
END_DOC
|
||||
integer :: i,k
|
||||
|
||||
do k=1,kpt_num
|
||||
do i = 1, N_int
|
||||
reunion_of_inact_act_bitmask_kpts(i,1,k) = ior(inact_bitmask_kpts(i,1,k),act_bitmask_kpts(i,1,k))
|
||||
reunion_of_inact_act_bitmask_kpts(i,2,k) = ior(inact_bitmask_kpts(i,2,k),act_bitmask_kpts(i,2,k))
|
||||
enddo
|
||||
enddo
|
||||
END_PROVIDER
|
||||
|
||||
BEGIN_PROVIDER [integer(bit_kind), reunion_of_act_virt_bitmask_kpts, (N_int,2,kpt_num)]
|
||||
implicit none
|
||||
BEGIN_DOC
|
||||
! Reunion of the inactive and active bitmasks
|
||||
END_DOC
|
||||
integer :: i,k
|
||||
|
||||
do k=1,kpt_num
|
||||
do i = 1, N_int
|
||||
reunion_of_act_virt_bitmask_kpts(i,1,k) = ior(virt_bitmask_kpts(i,1,k),act_bitmask_kpts(i,1,k))
|
||||
reunion_of_act_virt_bitmask_kpts(i,2,k) = ior(virt_bitmask_kpts(i,2,k),act_bitmask_kpts(i,2,k))
|
||||
enddo
|
||||
enddo
|
||||
END_PROVIDER
|
||||
|
||||
|
||||
BEGIN_PROVIDER [integer(bit_kind), reunion_of_core_inact_act_bitmask_kpts, (N_int,2,kpt_num)]
|
||||
implicit none
|
||||
BEGIN_DOC
|
||||
! Reunion of the core, inactive and active bitmasks
|
||||
END_DOC
|
||||
integer :: i,k
|
||||
|
||||
do k=1,kpt_num
|
||||
do i = 1, N_int
|
||||
reunion_of_core_inact_act_bitmask_kpts(i,1,k) = ior(reunion_of_core_inact_bitmask_kpts(i,1,k),act_bitmask_kpts(i,1,k))
|
||||
reunion_of_core_inact_act_bitmask_kpts(i,2,k) = ior(reunion_of_core_inact_bitmask_kpts(i,2,k),act_bitmask_kpts(i,2,k))
|
||||
enddo
|
||||
enddo
|
||||
END_PROVIDER
|
||||
|
||||
|
||||
BEGIN_PROVIDER [ integer(bit_kind), reunion_of_bitmask_kpts, (N_int,2,kpt_num)]
|
||||
implicit none
|
||||
BEGIN_DOC
|
||||
! Reunion of the inactive, active and virtual bitmasks
|
||||
END_DOC
|
||||
integer :: i,k
|
||||
do k=1,kpt_num
|
||||
do i = 1, N_int
|
||||
reunion_of_bitmask_kpts(i,1,k) = ior(ior(act_bitmask_kpts(i,1,k),inact_bitmask_kpts(i,1,k)),virt_bitmask_kpts(i,1,k))
|
||||
reunion_of_bitmask_kpts(i,2,k) = ior(ior(act_bitmask_kpts(i,2,k),inact_bitmask_kpts(i,2,k)),virt_bitmask_kpts(i,2,k))
|
||||
enddo
|
||||
enddo
|
||||
END_PROVIDER
|
||||
|
||||
|
||||
BEGIN_PROVIDER [ integer(bit_kind), inact_virt_bitmask_kpts, (N_int,2,kpt_num)]
|
||||
&BEGIN_PROVIDER [ integer(bit_kind), core_inact_virt_bitmask_kpts, (N_int,2,kpt_num)]
|
||||
implicit none
|
||||
BEGIN_DOC
|
||||
! Reunion of the inactive and virtual bitmasks
|
||||
END_DOC
|
||||
integer :: i,k
|
||||
do k=1,kpt_num
|
||||
do i = 1, N_int
|
||||
inact_virt_bitmask_kpts(i,1,k) = ior(inact_bitmask_kpts(i,1,k),virt_bitmask_kpts(i,1,k))
|
||||
inact_virt_bitmask_kpts(i,2,k) = ior(inact_bitmask_kpts(i,2,k),virt_bitmask_kpts(i,2,k))
|
||||
core_inact_virt_bitmask_kpts(i,1,k) = ior(core_bitmask_kpts(i,1,k),inact_virt_bitmask_kpts(i,1,k))
|
||||
core_inact_virt_bitmask_kpts(i,2,k) = ior(core_bitmask_kpts(i,2,k),inact_virt_bitmask_kpts(i,2,k))
|
||||
enddo
|
||||
enddo
|
||||
END_PROVIDER
|
||||
|
||||
|
||||
BEGIN_PROVIDER [ integer(bit_kind), unpaired_alpha_electrons_kpts, (N_int,kpt_num)]
|
||||
implicit none
|
||||
BEGIN_DOC
|
||||
! Bitmask reprenting the unpaired alpha electrons in the HF_bitmask
|
||||
END_DOC
|
||||
integer :: i,k
|
||||
unpaired_alpha_electrons_kpts = 0_bit_kind
|
||||
do k = 1, kpt_num
|
||||
do i = 1, N_int
|
||||
unpaired_alpha_electrons_kpts(i,k) = xor(HF_bitmask_kpts(i,1,k),HF_bitmask_kpts(i,2,k))
|
||||
enddo
|
||||
enddo
|
||||
END_PROVIDER
|
||||
|
||||
BEGIN_PROVIDER [integer(bit_kind), closed_shell_ref_bitmask_kpts, (N_int,2,kpt_num)]
|
||||
implicit none
|
||||
integer :: i,k
|
||||
|
||||
closed_shell_ref_bitmask_kpts = 0_bit_kind
|
||||
do k=1,kpt_num
|
||||
do i = 1, N_int
|
||||
closed_shell_ref_bitmask_kpts(i,1,k) = ior(ref_bitmask_kpts(i,1,k),act_bitmask_kpts(i,1,k))
|
||||
closed_shell_ref_bitmask_kpts(i,2,k) = ior(ref_bitmask_kpts(i,2,k),act_bitmask_kpts(i,2,k))
|
||||
enddo
|
||||
enddo
|
||||
END_PROVIDER
|
||||
|
||||
|
@ -214,6 +214,37 @@ subroutine print_spindet(string,Nint)
|
||||
|
||||
end
|
||||
|
||||
subroutine debug_single_spindet(string,Nint)
|
||||
use bitmasks
|
||||
implicit none
|
||||
BEGIN_DOC
|
||||
! Subroutine to print the content of a determinant in '+-' notation and
|
||||
! hexadecimal representation.
|
||||
END_DOC
|
||||
integer, intent(in) :: Nint
|
||||
integer(bit_kind), intent(in) :: string(Nint)
|
||||
character*(2048) :: output(1)
|
||||
call bitstring_to_hexa( output(1), string(1), Nint )
|
||||
print *, trim(output(1))
|
||||
call print_single_spindet(string,Nint)
|
||||
|
||||
end
|
||||
|
||||
subroutine print_single_spindet(string,Nint)
|
||||
use bitmasks
|
||||
implicit none
|
||||
BEGIN_DOC
|
||||
! Subroutine to print the content of a determinant using the '+-' notation
|
||||
END_DOC
|
||||
integer, intent(in) :: Nint
|
||||
integer(bit_kind), intent(in) :: string(Nint)
|
||||
character*(2048) :: output(1)
|
||||
|
||||
call bitstring_to_str( output(1), string(1), Nint )
|
||||
print *, trim(output(1))
|
||||
|
||||
end
|
||||
|
||||
logical function is_integer_in_string(bite,string,Nint)
|
||||
use bitmasks
|
||||
implicit none
|
||||
|
@ -413,3 +413,514 @@ END_PROVIDER
|
||||
print *, list_inact_act(1:n_inact_act_orb)
|
||||
END_PROVIDER
|
||||
|
||||
!============================================!
|
||||
! !
|
||||
! kpts !
|
||||
! !
|
||||
!============================================!
|
||||
BEGIN_PROVIDER [ integer(bit_kind), kpts_bitmask , (N_int,kpt_num) ]
|
||||
implicit none
|
||||
BEGIN_DOC
|
||||
! Bitmask identifying each kpt
|
||||
END_DOC
|
||||
integer :: k,i,di
|
||||
integer :: tmp_mo_list(mo_num_per_kpt)
|
||||
kpts_bitmask = 0_bit_kind
|
||||
print*,'kpts bitmask'
|
||||
do k=1,kpt_num
|
||||
di=(k-1)*mo_num_per_kpt
|
||||
do i=1,mo_num_per_kpt
|
||||
tmp_mo_list(i) = i+di
|
||||
enddo
|
||||
call list_to_bitstring( kpts_bitmask(1,k), tmp_mo_list, mo_num_per_kpt, N_int)
|
||||
!debugging
|
||||
print*,'k = ',k
|
||||
call debug_single_spindet(kpts_bitmask(1,k),N_int)
|
||||
enddo
|
||||
END_PROVIDER
|
||||
|
||||
BEGIN_PROVIDER [ integer, n_core_orb_kpts, (kpt_num)]
|
||||
implicit none
|
||||
BEGIN_DOC
|
||||
! Number of core MOs
|
||||
END_DOC
|
||||
integer :: i,k,kshift
|
||||
|
||||
do k=1,kpt_num
|
||||
n_core_orb_kpts(k) = 0
|
||||
kshift = (1-k)*mo_num_per_kpt
|
||||
do i = 1, mo_num_per_kpt
|
||||
if(mo_class(i+kshift) == 'Core')then
|
||||
n_core_orb_kpts(k) += 1
|
||||
endif
|
||||
enddo
|
||||
enddo
|
||||
|
||||
! call write_int(6,n_core_orb, 'Number of core MOs')
|
||||
|
||||
END_PROVIDER
|
||||
|
||||
BEGIN_PROVIDER [ integer, n_inact_orb_kpts, (kpt_num)]
|
||||
implicit none
|
||||
BEGIN_DOC
|
||||
! Number of inactive MOs
|
||||
END_DOC
|
||||
integer :: i,k,kshift
|
||||
|
||||
do k=1,kpt_num
|
||||
n_inact_orb_kpts(k) = 0
|
||||
kshift = (1-k)*mo_num_per_kpt
|
||||
do i = 1, mo_num_per_kpt
|
||||
if(mo_class(i+kshift) == 'Inactive')then
|
||||
n_inact_orb_kpts(k) += 1
|
||||
endif
|
||||
enddo
|
||||
enddo
|
||||
|
||||
! call write_int(6,n_inact_orb, 'Number of inactive MOs')
|
||||
|
||||
END_PROVIDER
|
||||
|
||||
BEGIN_PROVIDER [ integer, n_act_orb_kpts, (kpt_num)]
|
||||
implicit none
|
||||
BEGIN_DOC
|
||||
! Number of active MOs
|
||||
END_DOC
|
||||
integer :: i,k,kshift
|
||||
|
||||
do k=1,kpt_num
|
||||
n_act_orb_kpts(k) = 0
|
||||
kshift = (1-k)*mo_num_per_kpt
|
||||
do i = 1, mo_num_per_kpt
|
||||
if(mo_class(i+kshift) == 'Active')then
|
||||
n_act_orb_kpts(k) += 1
|
||||
endif
|
||||
enddo
|
||||
enddo
|
||||
|
||||
! call write_int(6,n_act_orb, 'Number of active MOs')
|
||||
|
||||
END_PROVIDER
|
||||
|
||||
BEGIN_PROVIDER [ integer, n_virt_orb_kpts, (kpt_num)]
|
||||
implicit none
|
||||
BEGIN_DOC
|
||||
! Number of virtual MOs
|
||||
END_DOC
|
||||
integer :: i,k,kshift
|
||||
|
||||
do k=1,kpt_num
|
||||
n_virt_orb_kpts(k) = 0
|
||||
kshift = (1-k)*mo_num_per_kpt
|
||||
do i = 1, mo_num_per_kpt
|
||||
if(mo_class(i+kshift) == 'Virtual')then
|
||||
n_virt_orb_kpts(k) += 1
|
||||
endif
|
||||
enddo
|
||||
enddo
|
||||
|
||||
! call write_int(6,n_virt_orb, 'Number of virtual MOs')
|
||||
|
||||
END_PROVIDER
|
||||
|
||||
BEGIN_PROVIDER [ integer, n_del_orb_kpts, (kpt_num)]
|
||||
implicit none
|
||||
BEGIN_DOC
|
||||
! Number of deleted MOs
|
||||
END_DOC
|
||||
integer :: i,k,kshift
|
||||
|
||||
do k=1,kpt_num
|
||||
n_del_orb_kpts(k) = 0
|
||||
kshift = (1-k)*mo_num_per_kpt
|
||||
do i = 1, mo_num_per_kpt
|
||||
if(mo_class(i+kshift) == 'Deleted')then
|
||||
n_del_orb_kpts(k) += 1
|
||||
endif
|
||||
enddo
|
||||
enddo
|
||||
|
||||
! call write_int(6,n_del_orb, 'Number of deleted MOs')
|
||||
|
||||
END_PROVIDER
|
||||
|
||||
BEGIN_PROVIDER [ integer, n_core_inact_orb_kpts, (kpt_num) ]
|
||||
!todo: finish implementation for kpts (will need kpts_bitmask)
|
||||
implicit none
|
||||
BEGIN_DOC
|
||||
! n_core + n_inact
|
||||
END_DOC
|
||||
integer :: i,k
|
||||
do k=1,kpt_num
|
||||
n_core_inact_orb_kpts(k) = 0
|
||||
do i = 1, N_int
|
||||
n_core_inact_orb_kpts(k) += popcnt(iand(kpts_bitmask(i,k),reunion_of_core_inact_bitmask(i,1)))
|
||||
enddo
|
||||
enddo
|
||||
END_PROVIDER
|
||||
|
||||
BEGIN_PROVIDER [integer, n_inact_act_orb_kpts, (kpt_num) ]
|
||||
implicit none
|
||||
BEGIN_DOC
|
||||
! n_inact + n_act
|
||||
END_DOC
|
||||
integer :: k
|
||||
do k=1,kpt_num
|
||||
n_inact_act_orb_kpts(k) = (n_inact_orb_kpts(k)+n_act_orb_kpts(k))
|
||||
enddo
|
||||
END_PROVIDER
|
||||
|
||||
BEGIN_PROVIDER [integer, dim_list_core_orb_kpts]
|
||||
implicit none
|
||||
BEGIN_DOC
|
||||
! dimensions for the allocation of list_core.
|
||||
! it is at least 1
|
||||
END_DOC
|
||||
dim_list_core_orb_kpts = max(maxval(n_core_orb_kpts),1)
|
||||
END_PROVIDER
|
||||
|
||||
BEGIN_PROVIDER [integer, dim_list_inact_orb_kpts]
|
||||
implicit none
|
||||
BEGIN_DOC
|
||||
! dimensions for the allocation of list_inact.
|
||||
! it is at least 1
|
||||
END_DOC
|
||||
dim_list_inact_orb_kpts = max(maxval(n_inact_orb_kpts),1)
|
||||
END_PROVIDER
|
||||
|
||||
BEGIN_PROVIDER [integer, dim_list_core_inact_orb_kpts]
|
||||
implicit none
|
||||
BEGIN_DOC
|
||||
! dimensions for the allocation of list_core.
|
||||
! it is at least 1
|
||||
END_DOC
|
||||
dim_list_core_inact_orb_kpts = max(maxval(n_core_inact_orb_kpts),1)
|
||||
END_PROVIDER
|
||||
|
||||
BEGIN_PROVIDER [integer, dim_list_act_orb_kpts]
|
||||
implicit none
|
||||
BEGIN_DOC
|
||||
! dimensions for the allocation of list_act.
|
||||
! it is at least 1
|
||||
END_DOC
|
||||
dim_list_act_orb_kpts = max(maxval(n_act_orb_kpts),1)
|
||||
END_PROVIDER
|
||||
|
||||
BEGIN_PROVIDER [integer, dim_list_virt_orb_kpts]
|
||||
implicit none
|
||||
BEGIN_DOC
|
||||
! dimensions for the allocation of list_virt.
|
||||
! it is at least 1
|
||||
END_DOC
|
||||
dim_list_virt_orb_kpts = max(maxval(n_virt_orb_kpts),1)
|
||||
END_PROVIDER
|
||||
|
||||
BEGIN_PROVIDER [integer, dim_list_del_orb_kpts]
|
||||
implicit none
|
||||
BEGIN_DOC
|
||||
! dimensions for the allocation of list_del.
|
||||
! it is at least 1
|
||||
END_DOC
|
||||
dim_list_del_orb_kpts = max(maxval(n_del_orb_kpts),1)
|
||||
END_PROVIDER
|
||||
|
||||
BEGIN_PROVIDER [integer, dim_list_core_inact_act_orb_kpts]
|
||||
implicit none
|
||||
BEGIN_DOC
|
||||
! dimensions for the allocation of list_core_inact_act.
|
||||
! it is at least 1
|
||||
END_DOC
|
||||
dim_list_core_inact_act_orb_kpts = max(maxval(n_core_inact_act_orb_kpts),1)
|
||||
END_PROVIDER
|
||||
|
||||
BEGIN_PROVIDER [integer, dim_list_inact_act_orb_kpts]
|
||||
implicit none
|
||||
BEGIN_DOC
|
||||
! dimensions for the allocation of list_inact_act.
|
||||
! it is at least 1
|
||||
END_DOC
|
||||
dim_list_inact_act_orb_kpts = max(maxval(n_inact_act_orb_kpts),1)
|
||||
END_PROVIDER
|
||||
|
||||
BEGIN_PROVIDER [integer, n_core_inact_act_orb_kpts, (kpt_num) ]
|
||||
implicit none
|
||||
BEGIN_DOC
|
||||
! Number of core inactive and active MOs
|
||||
END_DOC
|
||||
integer :: k
|
||||
do k=1,kpt_num
|
||||
n_core_inact_act_orb_kpts(k) = (n_core_orb_kpts(k) + n_inact_orb_kpts(k) + n_act_orb_kpts(k))
|
||||
enddo
|
||||
END_PROVIDER
|
||||
|
||||
|
||||
|
||||
|
||||
BEGIN_PROVIDER [ integer(bit_kind), core_bitmask_kpts , (N_int,2,kpt_num) ]
|
||||
implicit none
|
||||
BEGIN_DOC
|
||||
! Bitmask identifying the core MOs
|
||||
END_DOC
|
||||
integer :: k,i
|
||||
core_bitmask_kpts = 0_bit_kind
|
||||
do k=1,kpt_num
|
||||
do i=1,N_int
|
||||
core_bitmask_kpts(i,1,k) = iand(core_bitmask(i,1),kpts_bitmask(i,k))
|
||||
core_bitmask_kpts(i,2,k) = iand(core_bitmask(i,2),kpts_bitmask(i,k))
|
||||
enddo
|
||||
enddo
|
||||
END_PROVIDER
|
||||
|
||||
BEGIN_PROVIDER [ integer(bit_kind), inact_bitmask_kpts , (N_int,2,kpt_num) ]
|
||||
implicit none
|
||||
BEGIN_DOC
|
||||
! Bitmask identifying the inactive MOs
|
||||
END_DOC
|
||||
integer :: k,i
|
||||
inact_bitmask_kpts = 0_bit_kind
|
||||
do k=1,kpt_num
|
||||
do i=1,N_int
|
||||
inact_bitmask_kpts(i,1,k) = iand(inact_bitmask(i,1),kpts_bitmask(i,k))
|
||||
inact_bitmask_kpts(i,2,k) = iand(inact_bitmask(i,2),kpts_bitmask(i,k))
|
||||
enddo
|
||||
enddo
|
||||
END_PROVIDER
|
||||
|
||||
BEGIN_PROVIDER [ integer(bit_kind), act_bitmask_kpts , (N_int,2,kpt_num) ]
|
||||
implicit none
|
||||
BEGIN_DOC
|
||||
! Bitmask identifying the active MOs
|
||||
END_DOC
|
||||
integer :: k,i
|
||||
act_bitmask_kpts = 0_bit_kind
|
||||
do k=1,kpt_num
|
||||
do i=1,N_int
|
||||
act_bitmask_kpts(i,1,k) = iand(act_bitmask(i,1),kpts_bitmask(i,k))
|
||||
act_bitmask_kpts(i,2,k) = iand(act_bitmask(i,2),kpts_bitmask(i,k))
|
||||
enddo
|
||||
enddo
|
||||
END_PROVIDER
|
||||
|
||||
BEGIN_PROVIDER [ integer(bit_kind), virt_bitmask_kpts , (N_int,2,kpt_num) ]
|
||||
implicit none
|
||||
BEGIN_DOC
|
||||
! Bitmask identifying the virtual MOs
|
||||
END_DOC
|
||||
integer :: k,i
|
||||
virt_bitmask_kpts = 0_bit_kind
|
||||
do k=1,kpt_num
|
||||
do i=1,N_int
|
||||
virt_bitmask_kpts(i,1,k) = iand(virt_bitmask(i,1),kpts_bitmask(i,k))
|
||||
virt_bitmask_kpts(i,2,k) = iand(virt_bitmask(i,2),kpts_bitmask(i,k))
|
||||
enddo
|
||||
enddo
|
||||
END_PROVIDER
|
||||
|
||||
BEGIN_PROVIDER [ integer(bit_kind), del_bitmask_kpts , (N_int,2,kpt_num) ]
|
||||
implicit none
|
||||
BEGIN_DOC
|
||||
! Bitmask identifying the deleted MOs
|
||||
END_DOC
|
||||
integer :: k,i
|
||||
del_bitmask_kpts = 0_bit_kind
|
||||
do k=1,kpt_num
|
||||
do i=1,N_int
|
||||
del_bitmask_kpts(i,1,k) = iand(del_bitmask(i,1),kpts_bitmask(i,k))
|
||||
del_bitmask_kpts(i,2,k) = iand(del_bitmask(i,2),kpts_bitmask(i,k))
|
||||
enddo
|
||||
enddo
|
||||
END_PROVIDER
|
||||
|
||||
BEGIN_PROVIDER [ integer, list_core_kpts , (dim_list_core_orb_kpts,kpt_num) ]
|
||||
&BEGIN_PROVIDER [ integer, list_core_kpts_reverse, (mo_num_per_kpt,kpt_num) ]
|
||||
implicit none
|
||||
BEGIN_DOC
|
||||
! List of MO indices which are in the core.
|
||||
END_DOC
|
||||
integer :: i, n,k,di
|
||||
list_core_kpts = 0
|
||||
list_core_kpts_reverse = 0
|
||||
|
||||
do k=1,kpt_num
|
||||
n=0
|
||||
di = (k-1)*mo_num_per_kpt
|
||||
do i = 1, mo_num_per_kpt
|
||||
if(mo_class(i+di) == 'Core')then
|
||||
n += 1
|
||||
list_core_kpts(n,k) = i
|
||||
list_core_kpts_reverse(i,k) = n
|
||||
endif
|
||||
enddo
|
||||
print *, 'Core MOs: ',k
|
||||
print *, list_core_kpts(1:n_core_orb_kpts(k),k)
|
||||
enddo
|
||||
|
||||
END_PROVIDER
|
||||
|
||||
BEGIN_PROVIDER [ integer, list_inact_kpts , (dim_list_inact_orb_kpts,kpt_num) ]
|
||||
&BEGIN_PROVIDER [ integer, list_inact_kpts_reverse, (mo_num_per_kpt,kpt_num) ]
|
||||
implicit none
|
||||
BEGIN_DOC
|
||||
! List of MO indices which are inactive.
|
||||
END_DOC
|
||||
integer :: i, n,k,di
|
||||
list_inact_kpts = 0
|
||||
list_inact_kpts_reverse = 0
|
||||
|
||||
do k=1,kpt_num
|
||||
n=0
|
||||
di = (k-1)*mo_num_per_kpt
|
||||
do i = 1, mo_num_per_kpt
|
||||
if(mo_class(i+di) == 'Inactive')then
|
||||
n += 1
|
||||
list_inact_kpts(n,k) = i
|
||||
list_inact_kpts_reverse(i,k) = n
|
||||
endif
|
||||
enddo
|
||||
print *, 'Inactive MOs: ',k
|
||||
print *, list_inact_kpts(1:n_inact_orb_kpts(k),k)
|
||||
enddo
|
||||
|
||||
END_PROVIDER
|
||||
|
||||
BEGIN_PROVIDER [ integer, list_virt_kpts , (dim_list_virt_orb_kpts,kpt_num) ]
|
||||
&BEGIN_PROVIDER [ integer, list_virt_kpts_reverse, (mo_num_per_kpt,kpt_num) ]
|
||||
implicit none
|
||||
BEGIN_DOC
|
||||
! List of MO indices which are virtual.
|
||||
END_DOC
|
||||
integer :: i, n,k,di
|
||||
list_virt_kpts = 0
|
||||
list_virt_kpts_reverse = 0
|
||||
|
||||
do k=1,kpt_num
|
||||
n=0
|
||||
di = (k-1)*mo_num_per_kpt
|
||||
do i = 1, mo_num_per_kpt
|
||||
if(mo_class(i+di) == 'Virtual')then
|
||||
n += 1
|
||||
list_virt_kpts(n,k) = i
|
||||
list_virt_kpts_reverse(i,k) = n
|
||||
endif
|
||||
enddo
|
||||
print *, 'Virtual MOs: ',k
|
||||
print *, list_virt_kpts(1:n_virt_orb_kpts(k),k)
|
||||
enddo
|
||||
|
||||
END_PROVIDER
|
||||
|
||||
BEGIN_PROVIDER [ integer, list_del_kpts , (dim_list_del_orb_kpts,kpt_num) ]
|
||||
&BEGIN_PROVIDER [ integer, list_del_kpts_reverse, (mo_num_per_kpt,kpt_num) ]
|
||||
implicit none
|
||||
BEGIN_DOC
|
||||
! List of MO indices which are deleted.
|
||||
END_DOC
|
||||
integer :: i, n,k,di
|
||||
list_del_kpts = 0
|
||||
list_del_kpts_reverse = 0
|
||||
|
||||
do k=1,kpt_num
|
||||
n=0
|
||||
di = (k-1)*mo_num_per_kpt
|
||||
do i = 1, mo_num_per_kpt
|
||||
if(mo_class(i+di) == 'Deleted')then
|
||||
n += 1
|
||||
list_del_kpts(n,k) = i
|
||||
list_del_kpts_reverse(i,k) = n
|
||||
endif
|
||||
enddo
|
||||
print *, 'Deleted MOs: ',k
|
||||
print *, list_del_kpts(1:n_del_orb_kpts(k),k)
|
||||
enddo
|
||||
|
||||
END_PROVIDER
|
||||
|
||||
BEGIN_PROVIDER [ integer, list_act_kpts , (dim_list_act_orb_kpts,kpt_num) ]
|
||||
&BEGIN_PROVIDER [ integer, list_act_kpts_reverse, (mo_num_per_kpt,kpt_num) ]
|
||||
implicit none
|
||||
BEGIN_DOC
|
||||
! List of MO indices which are active.
|
||||
END_DOC
|
||||
integer :: i, n,k,di
|
||||
list_act_kpts = 0
|
||||
list_act_kpts_reverse = 0
|
||||
|
||||
do k=1,kpt_num
|
||||
n=0
|
||||
di = (k-1)*mo_num_per_kpt
|
||||
do i = 1, mo_num_per_kpt
|
||||
if(mo_class(i+di) == 'Active')then
|
||||
n += 1
|
||||
list_act_kpts(n,k) = i
|
||||
list_act_kpts_reverse(i,k) = n
|
||||
endif
|
||||
enddo
|
||||
print *, 'Active MOs: ',k
|
||||
print *, list_act_kpts(1:n_act_orb_kpts(k),k)
|
||||
enddo
|
||||
|
||||
END_PROVIDER
|
||||
|
||||
!todo: finish below for kpts
|
||||
|
||||
BEGIN_PROVIDER [ integer, list_core_inact_kpts , (dim_list_core_inact_orb_kpts,kpt_num) ]
|
||||
&BEGIN_PROVIDER [ integer, list_core_inact_kpts_reverse, (mo_num_per_kpt,kpt_num) ]
|
||||
implicit none
|
||||
BEGIN_DOC
|
||||
! List of indices of the core and inactive MOs
|
||||
END_DOC
|
||||
integer :: i,itmp,k
|
||||
list_core_inact_kpts_reverse = 0
|
||||
do k=1,kpt_num
|
||||
!call bitstring_to_list(reunion_of_core_inact_bitmask(1,1), list_core_inact, itmp, N_int)
|
||||
call bitstring_to_list(reunion_of_core_inact_bitmask_kpts(1,1,k), list_core_inact_kpts(1,k), itmp, N_int)
|
||||
ASSERT (itmp == n_core_inact_orb_kpts(k))
|
||||
do i = 1, n_core_inact_orb_kpts(k)
|
||||
list_core_inact_kpts_reverse(list_core_inact_kpts(i,k),k) = i
|
||||
enddo
|
||||
print *, 'Core and Inactive MOs: ',k
|
||||
print *, list_core_inact_kpts(1:n_core_inact_orb_kpts(k),k)
|
||||
enddo
|
||||
END_PROVIDER
|
||||
|
||||
|
||||
BEGIN_PROVIDER [ integer, list_core_inact_act_kpts , (dim_list_core_inact_act_orb_kpts,kpt_num) ]
|
||||
&BEGIN_PROVIDER [ integer, list_core_inact_act_kpts_reverse, (mo_num_per_kpt,kpt_num) ]
|
||||
implicit none
|
||||
BEGIN_DOC
|
||||
! List of indices of the core inactive and active MOs
|
||||
END_DOC
|
||||
integer :: i,itmp,k
|
||||
list_core_inact_act_kpts_reverse = 0
|
||||
do k=1,kpt_num
|
||||
!call bitstring_to_list(reunion_of_core_inact_act_bitmask(1,1), list_core_inact_act, itmp, N_int)
|
||||
call bitstring_to_list(reunion_of_core_inact_act_bitmask_kpts(1,1,k), list_core_inact_act_kpts(1,k), itmp, N_int)
|
||||
ASSERT (itmp == n_core_inact_act_orb_kpts(k))
|
||||
do i = 1, n_core_inact_act_orb_kpts(k)
|
||||
list_core_inact_act_kpts_reverse(list_core_inact_act_kpts(i,k),k) = i
|
||||
enddo
|
||||
print *, 'Core, Inactive and Active MOs: ',k
|
||||
print *, list_core_inact_act_kpts(1:n_core_inact_act_orb_kpts(k),k)
|
||||
enddo
|
||||
END_PROVIDER
|
||||
|
||||
|
||||
BEGIN_PROVIDER [ integer, list_inact_act_kpts , (dim_list_inact_act_orb_kpts,kpt_num) ]
|
||||
&BEGIN_PROVIDER [ integer, list_inact_act_kpts_reverse, (mo_num_per_kpt,kpt_num) ]
|
||||
implicit none
|
||||
BEGIN_DOC
|
||||
! List of indices of the inactive and active MOs
|
||||
END_DOC
|
||||
integer :: i,itmp,k
|
||||
list_inact_act_kpts_reverse = 0
|
||||
do k=1,kpt_num
|
||||
call bitstring_to_list(reunion_of_inact_act_bitmask_kpts(1,1,k), list_inact_act_kpts(1,k), itmp, N_int)
|
||||
ASSERT (itmp == n_inact_act_orb_kpts(k))
|
||||
do i = 1, n_inact_act_orb_kpts(k)
|
||||
list_inact_act_kpts_reverse(list_inact_act_kpts(i,k),k) = i
|
||||
enddo
|
||||
print *, 'Inactive and Active MOs: ',k
|
||||
print *, list_inact_act_kpts(1:n_inact_act_orb_kpts(k),k)
|
||||
enddo
|
||||
END_PROVIDER
|
||||
|
||||
|
154
src/bitmask/track_orb.irp.f
Normal file
154
src/bitmask/track_orb.irp.f
Normal file
@ -0,0 +1,154 @@
|
||||
BEGIN_PROVIDER [ double precision, mo_coef_begin_iteration, (ao_num,mo_num) ]
|
||||
implicit none
|
||||
BEGIN_DOC
|
||||
! Void provider to store the coefficients of the |MO| basis at the beginning of the SCF iteration
|
||||
!
|
||||
! Useful to track some orbitals
|
||||
END_DOC
|
||||
END_PROVIDER
|
||||
|
||||
BEGIN_PROVIDER [ complex*16, mo_coef_begin_iteration_complex, (ao_num,mo_num) ]
|
||||
implicit none
|
||||
BEGIN_DOC
|
||||
! Void provider to store the coefficients of the |MO| basis at the beginning of the SCF iteration
|
||||
!
|
||||
! Useful to track some orbitals
|
||||
END_DOC
|
||||
END_PROVIDER
|
||||
|
||||
BEGIN_PROVIDER [ complex*16, mo_coef_begin_iteration_kpts, (ao_num_per_kpt,mo_num_per_kpt,kpt_num) ]
|
||||
implicit none
|
||||
BEGIN_DOC
|
||||
! Void provider to store the coefficients of the |MO| basis at the beginning of the SCF iteration
|
||||
!
|
||||
! Useful to track some orbitals
|
||||
END_DOC
|
||||
END_PROVIDER
|
||||
|
||||
subroutine initialize_mo_coef_begin_iteration
|
||||
implicit none
|
||||
BEGIN_DOC
|
||||
!
|
||||
! Initialize :c:data:`mo_coef_begin_iteration` to the current :c:data:`mo_coef`
|
||||
END_DOC
|
||||
if (is_complex) then
|
||||
!mo_coef_begin_iteration_complex = mo_coef_complex
|
||||
mo_coef_begin_iteration_kpts = mo_coef_kpts
|
||||
else
|
||||
mo_coef_begin_iteration = mo_coef
|
||||
endif
|
||||
end
|
||||
|
||||
subroutine reorder_core_orb
|
||||
implicit none
|
||||
BEGIN_DOC
|
||||
! TODO: test for complex
|
||||
! routines that takes the current :c:data:`mo_coef` and reorder the core orbitals (see :c:data:`list_core` and :c:data:`n_core_orb`) according to the overlap with :c:data:`mo_coef_begin_iteration`
|
||||
END_DOC
|
||||
integer :: i,j,iorb
|
||||
integer :: k,l
|
||||
integer, allocatable :: index_core_orb(:),iorder(:)
|
||||
double precision, allocatable :: accu(:)
|
||||
integer :: i1,i2
|
||||
if (is_complex) then
|
||||
complex*16, allocatable :: accu_c(:)
|
||||
!allocate(accu(mo_num),accu_c(mo_num),index_core_orb(n_core_orb),iorder(mo_num))
|
||||
!do i = 1, n_core_orb
|
||||
! iorb = list_core(i)
|
||||
! do j = 1, mo_num
|
||||
! accu(j) = 0.d0
|
||||
! accu_c(j) = (0.d0,0.d0)
|
||||
! iorder(j) = j
|
||||
! do k = 1, ao_num
|
||||
! do l = 1, ao_num
|
||||
! accu_c(j) += dconjg(mo_coef_begin_iteration_complex(k,iorb)) * &
|
||||
! mo_coef_complex(l,j) * ao_overlap_complex(k,l)
|
||||
! enddo
|
||||
! enddo
|
||||
! accu(j) = -cdabs(accu_c(j))
|
||||
! enddo
|
||||
! call dsort(accu,iorder,mo_num)
|
||||
! index_core_orb(i) = iorder(1)
|
||||
!enddo
|
||||
|
||||
!complex*16 :: x_c
|
||||
!do j = 1, n_core_orb
|
||||
! i1 = list_core(j)
|
||||
! i2 = index_core_orb(j)
|
||||
! do i=1,ao_num
|
||||
! x_c = mo_coef_complex(i,i1)
|
||||
! mo_coef_complex(i,i1) = mo_coef_complex(i,i2)
|
||||
! mo_coef_complex(i,i2) = x_c
|
||||
! enddo
|
||||
!enddo
|
||||
!!call loc_cele_routine
|
||||
|
||||
!deallocate(accu,accu_c,index_core_orb, iorder)
|
||||
allocate(accu(mo_num_per_kpt),accu_c(mo_num_per_kpt),index_core_orb(n_core_orb),iorder(mo_num_per_kpt))
|
||||
integer :: kk
|
||||
do kk=1,kpt_num
|
||||
do i = 1, n_core_orb_kpts(kk)
|
||||
iorb = list_core_kpts(i,kk)
|
||||
do j = 1, mo_num_per_kpt
|
||||
accu(j) = 0.d0
|
||||
accu_c(j) = (0.d0,0.d0)
|
||||
iorder(j) = j
|
||||
do k = 1, ao_num_per_kpt
|
||||
do l = 1, ao_num_per_kpt
|
||||
accu_c(j) += dconjg(mo_coef_begin_iteration_kpts(k,iorb,kk)) * &
|
||||
mo_coef_kpts(l,j,kk) * ao_overlap_kpts(k,l,kk)
|
||||
enddo
|
||||
enddo
|
||||
accu(j) = -cdabs(accu_c(j))
|
||||
enddo
|
||||
call dsort(accu,iorder,mo_num_per_kpt)
|
||||
index_core_orb(i) = iorder(1)
|
||||
enddo
|
||||
|
||||
complex*16 :: x_c
|
||||
do j = 1, n_core_orb
|
||||
i1 = list_core_kpts(j,kk)
|
||||
i2 = index_core_orb(j)
|
||||
do i=1,ao_num_per_kpt
|
||||
x_c = mo_coef_kpts(i,i1,kk)
|
||||
mo_coef_kpts(i,i1,kk) = mo_coef_kpts(i,i2,kk)
|
||||
mo_coef_kpts(i,i2,kk) = x_c
|
||||
enddo
|
||||
enddo
|
||||
!call loc_cele_routine
|
||||
enddo
|
||||
deallocate(accu,accu_c,index_core_orb, iorder)
|
||||
else
|
||||
allocate(accu(mo_num),index_core_orb(n_core_orb),iorder(mo_num))
|
||||
|
||||
do i = 1, n_core_orb
|
||||
iorb = list_core(i)
|
||||
do j = 1, mo_num
|
||||
accu(j) = 0.d0
|
||||
iorder(j) = j
|
||||
do k = 1, ao_num
|
||||
do l = 1, ao_num
|
||||
accu(j) += mo_coef_begin_iteration(k,iorb) * mo_coef(l,j) * ao_overlap(k,l)
|
||||
enddo
|
||||
enddo
|
||||
accu(j) = -dabs(accu(j))
|
||||
enddo
|
||||
call dsort(accu,iorder,mo_num)
|
||||
index_core_orb(i) = iorder(1)
|
||||
enddo
|
||||
|
||||
double precision :: x
|
||||
do j = 1, n_core_orb
|
||||
i1 = list_core(j)
|
||||
i2 = index_core_orb(j)
|
||||
do i=1,ao_num
|
||||
x = mo_coef(i,i1)
|
||||
mo_coef(i,i1) = mo_coef(i,i2)
|
||||
mo_coef(i,i2) = x
|
||||
enddo
|
||||
enddo
|
||||
!call loc_cele_routine
|
||||
|
||||
deallocate(accu,index_core_orb, iorder)
|
||||
endif
|
||||
end
|
@ -20,7 +20,7 @@ subroutine run_cipsi
|
||||
logical :: has
|
||||
double precision :: relative_error
|
||||
|
||||
PROVIDE H_apply_buffer_allocated
|
||||
PROVIDE h_apply_buffer_allocated
|
||||
|
||||
relative_error=PT2_relative_error
|
||||
|
||||
@ -33,7 +33,11 @@ subroutine run_cipsi
|
||||
if (s2_eig) then
|
||||
call make_s2_eigenfunction
|
||||
endif
|
||||
call diagonalize_CI
|
||||
if (is_complex) then
|
||||
call diagonalize_ci_complex
|
||||
else
|
||||
call diagonalize_CI
|
||||
endif
|
||||
call save_wavefunction
|
||||
|
||||
call ezfio_has_hartree_fock_energy(has)
|
||||
@ -45,13 +49,23 @@ subroutine run_cipsi
|
||||
|
||||
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
|
||||
if (is_complex) then
|
||||
psi_coef_complex = psi_coef_sorted_complex
|
||||
N_det = N_det_max
|
||||
soft_touch N_det psi_det psi_coef_complex
|
||||
else
|
||||
psi_coef = psi_coef_sorted
|
||||
N_det = N_det_max
|
||||
soft_touch N_det psi_det psi_coef
|
||||
endif
|
||||
if (s2_eig) then
|
||||
call make_s2_eigenfunction
|
||||
endif
|
||||
call diagonalize_CI
|
||||
if (is_complex) then
|
||||
call diagonalize_CI_complex
|
||||
else
|
||||
call diagonalize_CI
|
||||
endif
|
||||
call save_wavefunction
|
||||
endif
|
||||
|
||||
@ -80,8 +94,13 @@ subroutine run_cipsi
|
||||
norm = 0.d0
|
||||
threshold_generators = 1.d0
|
||||
SOFT_TOUCH threshold_generators
|
||||
call ZMQ_pt2(psi_energy_with_nucl_rep,pt2,relative_error,error, variance, &
|
||||
norm, 0) ! Stochastic PT2
|
||||
! if (is_complex) then
|
||||
! call zmq_pt2_complex(psi_energy_with_nucl_rep,pt2,relative_error,error, variance, &
|
||||
! norm, 0) ! Stochastic PT2
|
||||
! else
|
||||
call zmq_pt2(psi_energy_with_nucl_rep,pt2,relative_error,error, variance, &
|
||||
norm, 0) ! Stochastic PT2
|
||||
! endif
|
||||
threshold_generators = threshold_generators_save
|
||||
SOFT_TOUCH threshold_generators
|
||||
endif
|
||||
@ -108,13 +127,22 @@ subroutine run_cipsi
|
||||
n_det_before = N_det
|
||||
to_select = int(sqrt(dble(N_states))*dble(N_det)*selection_factor)
|
||||
to_select = max(N_states_diag, to_select)
|
||||
call ZMQ_selection(to_select, pt2, variance, norm)
|
||||
|
||||
PROVIDE psi_coef
|
||||
call zmq_selection(to_select, pt2, variance, norm)
|
||||
if (is_complex) then
|
||||
! call zmq_selection_complex(to_select, pt2, variance, norm)
|
||||
PROVIDE psi_coef_complex
|
||||
else
|
||||
! call zmq_selection(to_select, pt2, variance, norm)
|
||||
PROVIDE psi_coef
|
||||
endif
|
||||
PROVIDE psi_det
|
||||
PROVIDE psi_det_sorted
|
||||
|
||||
call diagonalize_CI
|
||||
if (is_complex) then
|
||||
call diagonalize_ci_complex
|
||||
else
|
||||
call diagonalize_CI
|
||||
endif
|
||||
call save_wavefunction
|
||||
call save_energy(psi_energy_with_nucl_rep, zeros)
|
||||
if (qp_stop()) exit
|
||||
@ -126,7 +154,11 @@ print *, (correlation_energy_ratio <= correlation_energy_ratio_max)
|
||||
|
||||
if (.not.qp_stop()) then
|
||||
if (N_det < N_det_max) then
|
||||
call diagonalize_CI
|
||||
if (is_complex) then
|
||||
call diagonalize_ci_complex
|
||||
else
|
||||
call diagonalize_CI
|
||||
endif
|
||||
call save_wavefunction
|
||||
call save_energy(psi_energy_with_nucl_rep, zeros)
|
||||
endif
|
||||
@ -137,8 +169,13 @@ print *, (correlation_energy_ratio <= correlation_energy_ratio_max)
|
||||
norm(:) = 0.d0
|
||||
threshold_generators = 1d0
|
||||
SOFT_TOUCH threshold_generators
|
||||
call ZMQ_pt2(psi_energy_with_nucl_rep, pt2,relative_error,error,variance, &
|
||||
norm,0) ! Stochastic PT2
|
||||
! if (is_complex) then
|
||||
! call zmq_pt2_complex(psi_energy_with_nucl_rep, pt2,relative_error,error,variance, &
|
||||
! norm,0) ! Stochastic PT2
|
||||
! else
|
||||
call ZMQ_pt2(psi_energy_with_nucl_rep, pt2,relative_error,error,variance, &
|
||||
norm,0) ! Stochastic PT2
|
||||
! endif
|
||||
SOFT_TOUCH threshold_generators
|
||||
endif
|
||||
print *, 'N_det = ', N_det
|
||||
|
@ -17,7 +17,11 @@ BEGIN_PROVIDER [ double precision, pt2_E0_denominator, (N_states) ]
|
||||
pt2_E0_denominator(1:N_states) = psi_energy(1:N_states)
|
||||
else if (h0_type == "HF") then
|
||||
do i=1,N_states
|
||||
j = maxloc(abs(psi_coef(:,i)),1)
|
||||
if (is_complex) then
|
||||
j = maxloc(cdabs(psi_coef_complex(:,i)),1)
|
||||
else
|
||||
j = maxloc(abs(psi_coef(:,i)),1)
|
||||
endif
|
||||
pt2_E0_denominator(i) = psi_det_hii(j)
|
||||
enddo
|
||||
else if (h0_type == "Barycentric") then
|
||||
|
@ -63,11 +63,19 @@ logical function testTeethBuilding(minF, N)
|
||||
|
||||
norm = 0.d0
|
||||
double precision :: norm
|
||||
do i=N_det_generators,1,-1
|
||||
tilde_w(i) = psi_coef_sorted_gen(i,pt2_stoch_istate) * &
|
||||
psi_coef_sorted_gen(i,pt2_stoch_istate)
|
||||
norm = norm + tilde_w(i)
|
||||
enddo
|
||||
if (is_complex) then
|
||||
do i=N_det_generators,1,-1
|
||||
tilde_w(i) = cdabs(psi_coef_sorted_gen_complex(i,pt2_stoch_istate) * &
|
||||
psi_coef_sorted_gen_complex(i,pt2_stoch_istate))
|
||||
norm = norm + tilde_w(i)
|
||||
enddo
|
||||
else
|
||||
do i=N_det_generators,1,-1
|
||||
tilde_w(i) = psi_coef_sorted_gen(i,pt2_stoch_istate) * &
|
||||
psi_coef_sorted_gen(i,pt2_stoch_istate)
|
||||
norm = norm + tilde_w(i)
|
||||
enddo
|
||||
endif
|
||||
|
||||
f = 1.d0/norm
|
||||
tilde_w(:) = tilde_w(:) * f
|
||||
@ -126,11 +134,19 @@ subroutine ZMQ_pt2(E, pt2,relative_error, error, variance, norm, N_in)
|
||||
integer(ZMQ_PTR), external :: new_zmq_to_qp_run_socket
|
||||
type(selection_buffer) :: b
|
||||
|
||||
PROVIDE psi_bilinear_matrix_columns_loc psi_det_alpha_unique psi_det_beta_unique
|
||||
PROVIDE psi_bilinear_matrix_rows psi_det_sorted_order psi_bilinear_matrix_order
|
||||
PROVIDE psi_bilinear_matrix_transp_rows_loc psi_bilinear_matrix_transp_columns
|
||||
PROVIDE psi_bilinear_matrix_transp_order psi_selectors_coef_transp psi_det_sorted
|
||||
PROVIDE psi_det_hii selection_weight pseudo_sym
|
||||
if (is_complex) then
|
||||
PROVIDE psi_bilinear_matrix_columns_loc psi_det_alpha_unique psi_det_beta_unique
|
||||
PROVIDE psi_bilinear_matrix_rows psi_det_sorted_order psi_bilinear_matrix_order
|
||||
PROVIDE psi_bilinear_matrix_transp_rows_loc psi_bilinear_matrix_transp_columns
|
||||
PROVIDE psi_bilinear_matrix_transp_order psi_selectors_coef_transp_complex psi_det_sorted
|
||||
PROVIDE psi_det_hii selection_weight pseudo_sym
|
||||
else
|
||||
PROVIDE psi_bilinear_matrix_columns_loc psi_det_alpha_unique psi_det_beta_unique
|
||||
PROVIDE psi_bilinear_matrix_rows psi_det_sorted_order psi_bilinear_matrix_order
|
||||
PROVIDE psi_bilinear_matrix_transp_rows_loc psi_bilinear_matrix_transp_columns
|
||||
PROVIDE psi_bilinear_matrix_transp_order psi_selectors_coef_transp psi_det_sorted
|
||||
PROVIDE psi_det_hii selection_weight pseudo_sym
|
||||
endif
|
||||
|
||||
if (h0_type == 'SOP') then
|
||||
PROVIDE psi_occ_pattern_hii det_to_occ_pattern
|
||||
@ -140,7 +156,7 @@ subroutine ZMQ_pt2(E, pt2,relative_error, error, variance, norm, N_in)
|
||||
pt2=0.d0
|
||||
variance=0.d0
|
||||
norm=0.d0
|
||||
call ZMQ_selection(N_in, pt2, variance, norm)
|
||||
call zmq_selection(N_in, pt2, variance, norm)
|
||||
error(:) = 0.d0
|
||||
else
|
||||
|
||||
@ -159,8 +175,16 @@ subroutine ZMQ_pt2(E, pt2,relative_error, error, variance, norm, N_in)
|
||||
state_average_weight(pt2_stoch_istate) = 1.d0
|
||||
TOUCH state_average_weight pt2_stoch_istate selection_weight
|
||||
|
||||
PROVIDE nproc pt2_F mo_two_e_integrals_in_map mo_one_e_integrals pt2_w
|
||||
PROVIDE psi_selectors pt2_u pt2_J pt2_R
|
||||
if (is_complex) then
|
||||
!todo: psi_selectors isn't linked to psi_selectors_coef anymore; should we provide both?
|
||||
!PROVIDE nproc pt2_F mo_two_e_integrals_in_map mo_one_e_integrals_complex pt2_w
|
||||
PROVIDE nproc pt2_F mo_two_e_integrals_in_map mo_one_e_integrals_kpts pt2_w
|
||||
PROVIDE psi_selectors pt2_u pt2_J pt2_R
|
||||
else
|
||||
PROVIDE nproc pt2_F mo_two_e_integrals_in_map mo_one_e_integrals pt2_w
|
||||
PROVIDE psi_selectors pt2_u pt2_J pt2_R
|
||||
endif
|
||||
|
||||
call new_parallel_job(zmq_to_qp_run_socket, zmq_socket_pull, 'pt2')
|
||||
|
||||
integer, external :: zmq_put_psi
|
||||
@ -272,6 +296,10 @@ subroutine ZMQ_pt2(E, pt2,relative_error, error, variance, norm, N_in)
|
||||
+ 2.0d0*(N_int*2*ii) & ! minilist, fullminilist
|
||||
+ 1.0d0*(N_states*mo_num*mo_num) & ! mat
|
||||
) / 1024.d0**3
|
||||
if (is_complex) then
|
||||
! mat is complex
|
||||
mem = mem + (nproc_target*8.d0*(N_states*mo_num* mo_num)) / 1024.d0**3
|
||||
endif
|
||||
|
||||
if (nproc_target == 0) then
|
||||
call check_mem(mem,irp_here)
|
||||
@ -751,10 +779,16 @@ END_PROVIDER
|
||||
allocate(tilde_w(N_det_generators), tilde_cW(0:N_det_generators))
|
||||
|
||||
tilde_cW(0) = 0d0
|
||||
|
||||
do i=1,N_det_generators
|
||||
tilde_w(i) = psi_coef_sorted_gen(i,pt2_stoch_istate)**2 !+ 1.d-20
|
||||
enddo
|
||||
|
||||
if (is_complex) then
|
||||
do i=1,N_det_generators
|
||||
tilde_w(i) = cdabs(psi_coef_sorted_gen_complex(i,pt2_stoch_istate))**2 !+ 1.d-20
|
||||
enddo
|
||||
else
|
||||
do i=1,N_det_generators
|
||||
tilde_w(i) = psi_coef_sorted_gen(i,pt2_stoch_istate)**2 !+ 1.d-20
|
||||
enddo
|
||||
endif
|
||||
|
||||
double precision :: norm
|
||||
norm = 0.d0
|
||||
@ -773,7 +807,7 @@ END_PROVIDER
|
||||
pt2_n_0(1) = 0
|
||||
do
|
||||
pt2_u_0 = tilde_cW(pt2_n_0(1))
|
||||
r = tilde_cW(pt2_n_0(1) + pt2_minDetInFirstTeeth)
|
||||
r = tilde_cW(pt2_n_0(1) + pt2_mindetinfirstteeth)
|
||||
pt2_W_T = (1d0 - pt2_u_0) / dble(pt2_N_teeth)
|
||||
if(pt2_W_T >= r - pt2_u_0) then
|
||||
exit
|
||||
@ -799,7 +833,7 @@ END_PROVIDER
|
||||
endif
|
||||
ASSERT(tooth_width > 0.d0)
|
||||
do i=pt2_n_0(t)+1, pt2_n_0(t+1)
|
||||
pt2_w(i) = tilde_w(i) * pt2_W_T / tooth_width
|
||||
pt2_w(i) = tilde_w(i) * pt2_w_t / tooth_width
|
||||
end do
|
||||
end do
|
||||
|
||||
@ -813,6 +847,3 @@ END_PROVIDER
|
||||
END_PROVIDER
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
@ -21,12 +21,17 @@ subroutine run_selection_slave(thread,iproc,energy)
|
||||
double precision :: pt2(N_states)
|
||||
double precision :: variance(N_states)
|
||||
double precision :: norm(N_states)
|
||||
|
||||
|
||||
!todo: check for providers that are now unlinked for real/complex
|
||||
PROVIDE psi_bilinear_matrix_columns_loc psi_det_alpha_unique psi_det_beta_unique
|
||||
PROVIDE psi_bilinear_matrix_rows psi_det_sorted_order psi_bilinear_matrix_order
|
||||
PROVIDE psi_bilinear_matrix_transp_rows_loc psi_bilinear_matrix_transp_columns
|
||||
PROVIDE psi_bilinear_matrix_transp_order N_int pt2_F pseudo_sym
|
||||
PROVIDE psi_selectors_coef_transp psi_det_sorted weight_selection
|
||||
if (is_complex) then
|
||||
PROVIDE psi_selectors_coef_transp_complex psi_det_sorted weight_selection
|
||||
else
|
||||
PROVIDE psi_selectors_coef_transp psi_det_sorted weight_selection
|
||||
endif
|
||||
|
||||
|
||||
zmq_to_qp_run_socket = new_zmq_to_qp_run_socket()
|
||||
|
File diff suppressed because it is too large
Load Diff
@ -14,10 +14,17 @@ subroutine run_slave_cipsi
|
||||
end
|
||||
|
||||
subroutine provide_everything
|
||||
PROVIDE H_apply_buffer_allocated mo_two_e_integrals_in_map psi_det_generators psi_coef_generators psi_det_sorted_bit psi_selectors n_det_generators n_states generators_bitmask zmq_context N_states_diag
|
||||
PROVIDE pt2_e0_denominator mo_num N_int ci_energy mpi_master zmq_state zmq_context
|
||||
PROVIDE psi_det psi_coef threshold_generators state_average_weight
|
||||
PROVIDE N_det_selectors pt2_stoch_istate N_det selection_weight pseudo_sym
|
||||
if (is_complex) then
|
||||
PROVIDE H_apply_buffer_allocated mo_two_e_integrals_in_map psi_det_generators psi_coef_generators_complex psi_det_sorted_bit psi_selectors n_det_generators n_states generators_bitmask zmq_context N_states_diag
|
||||
PROVIDE pt2_e0_denominator mo_num_per_kpt N_int ci_energy mpi_master zmq_state zmq_context
|
||||
PROVIDE psi_det psi_coef_complex threshold_generators state_average_weight
|
||||
PROVIDE N_det_selectors pt2_stoch_istate N_det selection_weight pseudo_sym
|
||||
else
|
||||
PROVIDE H_apply_buffer_allocated mo_two_e_integrals_in_map psi_det_generators psi_coef_generators psi_det_sorted_bit psi_selectors n_det_generators n_states generators_bitmask zmq_context N_states_diag
|
||||
PROVIDE pt2_e0_denominator mo_num N_int ci_energy mpi_master zmq_state zmq_context
|
||||
PROVIDE psi_det psi_coef threshold_generators state_average_weight
|
||||
PROVIDE N_det_selectors pt2_stoch_istate N_det selection_weight pseudo_sym
|
||||
endif
|
||||
end
|
||||
|
||||
subroutine run_slave_main
|
||||
@ -51,9 +58,15 @@ subroutine run_slave_main
|
||||
|
||||
zmq_to_qp_run_socket = new_zmq_to_qp_run_socket()
|
||||
|
||||
PROVIDE psi_det psi_coef threshold_generators state_average_weight mpi_master
|
||||
PROVIDE zmq_state N_det_selectors pt2_stoch_istate N_det pt2_e0_denominator
|
||||
PROVIDE N_det_generators N_states N_states_diag pt2_e0_denominator mpi_rank
|
||||
if (is_complex) then
|
||||
PROVIDE psi_det psi_coef_complex threshold_generators state_average_weight mpi_master
|
||||
PROVIDE zmq_state N_det_selectors pt2_stoch_istate N_det pt2_e0_denominator
|
||||
PROVIDE N_det_generators N_states N_states_diag pt2_e0_denominator mpi_rank
|
||||
else
|
||||
PROVIDE psi_det psi_coef threshold_generators state_average_weight mpi_master
|
||||
PROVIDE zmq_state N_det_selectors pt2_stoch_istate N_det pt2_e0_denominator
|
||||
PROVIDE N_det_generators N_states N_states_diag pt2_e0_denominator mpi_rank
|
||||
endif
|
||||
|
||||
IRP_IF MPI
|
||||
call MPI_BARRIER(MPI_COMM_WORLD, ierr)
|
||||
@ -268,6 +281,10 @@ subroutine run_slave_main
|
||||
+ 2.0d0*(N_int*2*ii) & ! minilist, fullminilist
|
||||
+ 1.0d0*(N_states*mo_num*mo_num) & ! mat
|
||||
) / 1024.d0**3
|
||||
if (is_complex) then
|
||||
! mat is complex
|
||||
mem = mem + (nproc_target * 8.d0 * (n_states*mo_num*mo_num)) / 1024.d0**3
|
||||
endif
|
||||
|
||||
if (nproc_target == 0) then
|
||||
call check_mem(mem,irp_here)
|
||||
|
@ -36,7 +36,11 @@ subroutine run_stochastic_cipsi
|
||||
if (s2_eig) then
|
||||
call make_s2_eigenfunction
|
||||
endif
|
||||
call diagonalize_CI
|
||||
if (is_complex) then
|
||||
call diagonalize_ci_complex
|
||||
else
|
||||
call diagonalize_ci
|
||||
endif
|
||||
call save_wavefunction
|
||||
|
||||
call ezfio_has_hartree_fock_energy(has)
|
||||
@ -48,13 +52,23 @@ subroutine run_stochastic_cipsi
|
||||
|
||||
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
|
||||
if (is_complex) then
|
||||
psi_coef_complex = psi_coef_sorted_complex
|
||||
N_det = N_det_max
|
||||
soft_touch N_det psi_det psi_coef_complex
|
||||
else
|
||||
psi_coef = psi_coef_sorted
|
||||
N_det = N_det_max
|
||||
soft_touch N_det psi_det psi_coef
|
||||
endif
|
||||
if (s2_eig) then
|
||||
call make_s2_eigenfunction
|
||||
endif
|
||||
call diagonalize_CI
|
||||
if (is_complex) then
|
||||
call diagonalize_ci_complex
|
||||
else
|
||||
call diagonalize_CI
|
||||
endif
|
||||
call save_wavefunction
|
||||
endif
|
||||
|
||||
@ -78,8 +92,13 @@ subroutine run_stochastic_cipsi
|
||||
pt2 = 0.d0
|
||||
variance = 0.d0
|
||||
norm = 0.d0
|
||||
call ZMQ_pt2(psi_energy_with_nucl_rep,pt2,relative_error,error, variance, &
|
||||
norm, to_select) ! Stochastic PT2 and selection
|
||||
! if (is_complex) then
|
||||
! call zmq_pt2_complex(psi_energy_with_nucl_rep,pt2,relative_error,error, variance, &
|
||||
! norm, to_select) ! Stochastic PT2 and selection
|
||||
! else
|
||||
call zmq_pt2(psi_energy_with_nucl_rep,pt2,relative_error,error, variance, &
|
||||
norm, to_select) ! Stochastic PT2 and selection
|
||||
! endif
|
||||
|
||||
do k=1,N_states
|
||||
rpt2(k) = pt2(k)/(1.d0 + norm(k))
|
||||
@ -91,6 +110,7 @@ subroutine run_stochastic_cipsi
|
||||
|
||||
call write_double(6,correlation_energy_ratio, 'Correlation ratio')
|
||||
call print_summary(psi_energy_with_nucl_rep,pt2,error,variance,norm,N_det,N_occ_pattern,N_states,psi_s2)
|
||||
!call print_debug_fci()
|
||||
|
||||
call save_energy(psi_energy_with_nucl_rep, rpt2)
|
||||
|
||||
@ -101,14 +121,22 @@ subroutine run_stochastic_cipsi
|
||||
if (qp_stop()) exit
|
||||
|
||||
! Add selected determinants
|
||||
call copy_H_apply_buffer_to_wf()
|
||||
call copy_h_apply_buffer_to_wf()
|
||||
! call save_wavefunction
|
||||
|
||||
PROVIDE psi_coef
|
||||
if (is_complex) then
|
||||
PROVIDE psi_coef_complex
|
||||
else
|
||||
PROVIDE psi_coef
|
||||
endif
|
||||
PROVIDE psi_det
|
||||
PROVIDE psi_det_sorted
|
||||
|
||||
call diagonalize_CI
|
||||
if (is_complex) then
|
||||
call diagonalize_ci_complex
|
||||
else
|
||||
call diagonalize_CI
|
||||
endif
|
||||
call save_wavefunction
|
||||
call save_energy(psi_energy_with_nucl_rep, zeros)
|
||||
if (qp_stop()) exit
|
||||
@ -116,7 +144,11 @@ subroutine run_stochastic_cipsi
|
||||
|
||||
if (.not.qp_stop()) then
|
||||
if (N_det < N_det_max) then
|
||||
call diagonalize_CI
|
||||
if (is_complex) then
|
||||
call diagonalize_ci_complex
|
||||
else
|
||||
call diagonalize_CI
|
||||
endif
|
||||
call save_wavefunction
|
||||
call save_energy(psi_energy_with_nucl_rep, zeros)
|
||||
endif
|
||||
@ -124,8 +156,13 @@ subroutine run_stochastic_cipsi
|
||||
pt2(:) = 0.d0
|
||||
variance(:) = 0.d0
|
||||
norm(:) = 0.d0
|
||||
call ZMQ_pt2(psi_energy_with_nucl_rep, pt2,relative_error,error,variance, &
|
||||
norm,0) ! Stochastic PT2
|
||||
! if (is_complex) then
|
||||
! call zmq_pt2_complex(psi_energy_with_nucl_rep, pt2,relative_error,error,variance, &
|
||||
! norm,0) ! Stochastic PT2
|
||||
! else
|
||||
call ZMQ_pt2(psi_energy_with_nucl_rep, pt2,relative_error,error,variance, &
|
||||
norm,0) ! Stochastic PT2
|
||||
! endif
|
||||
|
||||
do k=1,N_states
|
||||
rpt2(k) = pt2(k)/(1.d0 + norm(k))
|
||||
|
@ -17,6 +17,7 @@ subroutine ZMQ_selection(N_in, pt2, variance, norm)
|
||||
|
||||
N = max(N_in,1)
|
||||
if (.True.) then
|
||||
!todo: some providers have become unlinked for real/complex (det/coef); do these need to be provided?
|
||||
PROVIDE pt2_e0_denominator nproc
|
||||
PROVIDE psi_bilinear_matrix_columns_loc psi_det_alpha_unique psi_det_beta_unique
|
||||
PROVIDE psi_bilinear_matrix_rows psi_det_sorted_order psi_bilinear_matrix_order
|
||||
@ -105,9 +106,16 @@ subroutine ZMQ_selection(N_in, pt2, variance, norm)
|
||||
f(:) = 1.d0
|
||||
if (.not.do_pt2) then
|
||||
double precision :: f(N_states), u_dot_u
|
||||
do k=1,min(N_det,N_states)
|
||||
f(k) = 1.d0 / u_dot_u(psi_selectors_coef(1,k), N_det_selectors)
|
||||
enddo
|
||||
if (is_complex) then
|
||||
double precision :: u_dot_u_complex
|
||||
do k=1,min(N_det,N_states)
|
||||
f(k) = 1.d0 / u_dot_u_complex(psi_selectors_coef_complex(1,k), N_det_selectors)
|
||||
enddo
|
||||
else
|
||||
do k=1,min(N_det,N_states)
|
||||
f(k) = 1.d0 / u_dot_u(psi_selectors_coef(1,k), N_det_selectors)
|
||||
enddo
|
||||
endif
|
||||
endif
|
||||
|
||||
!$OMP PARALLEL DEFAULT(shared) SHARED(b, pt2, variance, norm) PRIVATE(i) NUM_THREADS(nproc_target+1)
|
||||
@ -224,3 +232,4 @@ subroutine selection_collector(zmq_socket_pull, b, N, pt2, variance, norm)
|
||||
call end_zmq_to_qp_run_socket(zmq_to_qp_run_socket)
|
||||
end subroutine
|
||||
|
||||
|
||||
|
@ -89,21 +89,97 @@ subroutine davidson_slave_work(zmq_to_qp_run_socket, zmq_socket_push, N_st, sze,
|
||||
character*(512) :: msg
|
||||
integer :: imin, imax, ishift, istep
|
||||
|
||||
integer, allocatable :: psi_det_read(:,:,:)
|
||||
double precision, allocatable :: v_t(:,:), s_t(:,:), u_t(:,:)
|
||||
|
||||
!DIR$ ATTRIBUTES ALIGN : $IRP_ALIGN :: u_t, v_t, s_t
|
||||
|
||||
! Get wave function (u_t)
|
||||
! -----------------------
|
||||
|
||||
integer :: rc, ni, nj
|
||||
integer*8 :: rc8
|
||||
integer :: N_states_read, N_det_read, psi_det_size_read
|
||||
integer :: N_det_selectors_read, N_det_generators_read
|
||||
|
||||
integer, external :: zmq_get_dvector
|
||||
integer, allocatable :: psi_det_read(:,:,:)
|
||||
logical :: sending
|
||||
integer, external :: get_task_from_taskserver
|
||||
integer, external :: task_done_to_taskserver
|
||||
integer :: k
|
||||
integer :: ierr
|
||||
|
||||
|
||||
! integer, external :: zmq_get_dvector
|
||||
integer, external :: zmq_get_dmatrix
|
||||
integer, external :: zmq_get_cdmatrix
|
||||
IRP_IF MPI
|
||||
include 'mpif.h'
|
||||
IRP_ENDIF
|
||||
|
||||
if (is_complex) then
|
||||
complex*16, allocatable :: v_tc(:,:), s_tc(:,:), u_tc(:,:)
|
||||
|
||||
!DIR$ ATTRIBUTES ALIGN : $IRP_ALIGN :: u_tc, v_tc, s_tc
|
||||
|
||||
|
||||
! Get wave function (u_tc)
|
||||
! -----------------------
|
||||
|
||||
PROVIDE psi_det_beta_unique psi_bilinear_matrix_order_transp_reverse psi_det_alpha_unique
|
||||
PROVIDE psi_bilinear_matrix_transp_values_complex psi_bilinear_matrix_values_complex psi_bilinear_matrix_columns_loc
|
||||
PROVIDE ref_bitmask_energy nproc
|
||||
PROVIDE mpi_initialized
|
||||
|
||||
allocate(u_tc(N_st,N_det))
|
||||
|
||||
!todo: resize for complex? (should be okay)
|
||||
! Warning : dimensions are modified for efficiency, It is OK since we get the
|
||||
! full matrix
|
||||
if (size(u_tc,kind=8) < 8388608_8) then
|
||||
ni = size(u_tc)
|
||||
nj = 1
|
||||
else
|
||||
ni = 8388608
|
||||
nj = int(size(u_tc,kind=8)/8388608_8,4) + 1
|
||||
endif
|
||||
|
||||
do while (zmq_get_cdmatrix(zmq_to_qp_run_socket, worker_id, 'u_tc', u_tc, ni, nj, size(u_tc,kind=8)) == -1)
|
||||
print *, 'mpi_rank, N_states_diag, N_det'
|
||||
print *, mpi_rank, N_states_diag, N_det
|
||||
stop 'u_tc'
|
||||
enddo
|
||||
|
||||
IRP_IF MPI
|
||||
! include 'mpif.h'
|
||||
call broadcast_chunks_complex_double(u_tc,size(u_tc,kind=8))
|
||||
IRP_ENDIF
|
||||
|
||||
! Run tasks
|
||||
! ---------
|
||||
|
||||
sending=.False.
|
||||
|
||||
allocate(v_tc(N_st,N_det), s_tc(N_st,N_det))
|
||||
do
|
||||
if (get_task_from_taskserver(zmq_to_qp_run_socket,worker_id, task_id, msg) == -1) then
|
||||
exit
|
||||
endif
|
||||
if(task_id == 0) exit
|
||||
read (msg,*) imin, imax, ishift, istep
|
||||
do k=imin,imax
|
||||
v_tc(:,k) = (0.d0,0.d0)
|
||||
s_tc(:,k) = (0.d0,0.d0)
|
||||
enddo
|
||||
call h_s2_u_0_nstates_openmp_work_complex(v_tc,s_tc,u_tc,N_st,N_det,imin,imax,ishift,istep)
|
||||
if (task_done_to_taskserver(zmq_to_qp_run_socket,worker_id,task_id) == -1) then
|
||||
print *, irp_here, 'Unable to send task_done'
|
||||
endif
|
||||
call davidson_push_results_async_recv(zmq_socket_push, sending)
|
||||
call davidson_push_results_async_send_complex(zmq_socket_push, v_tc, s_tc, imin, imax, task_id, sending)
|
||||
end do
|
||||
deallocate(u_tc,v_tc, s_tc)
|
||||
call davidson_push_results_async_recv(zmq_socket_push, sending)
|
||||
else
|
||||
double precision, allocatable :: v_t(:,:), s_t(:,:), u_t(:,:)
|
||||
|
||||
!DIR$ ATTRIBUTES ALIGN : $IRP_ALIGN :: u_t, v_t, s_t
|
||||
|
||||
|
||||
! Get wave function (u_t)
|
||||
! -----------------------
|
||||
|
||||
PROVIDE psi_det_beta_unique psi_bilinear_matrix_order_transp_reverse psi_det_alpha_unique
|
||||
PROVIDE psi_bilinear_matrix_transp_values psi_bilinear_matrix_values psi_bilinear_matrix_columns_loc
|
||||
@ -129,29 +205,22 @@ subroutine davidson_slave_work(zmq_to_qp_run_socket, zmq_socket_push, N_st, sze,
|
||||
enddo
|
||||
|
||||
IRP_IF MPI
|
||||
include 'mpif.h'
|
||||
integer :: ierr
|
||||
|
||||
!include 'mpif.h'
|
||||
call broadcast_chunks_double(u_t,size(u_t,kind=8))
|
||||
|
||||
IRP_ENDIF
|
||||
|
||||
! Run tasks
|
||||
! ---------
|
||||
|
||||
logical :: sending
|
||||
sending=.False.
|
||||
|
||||
allocate(v_t(N_st,N_det), s_t(N_st,N_det))
|
||||
do
|
||||
integer, external :: get_task_from_taskserver
|
||||
integer, external :: task_done_to_taskserver
|
||||
if (get_task_from_taskserver(zmq_to_qp_run_socket,worker_id, task_id, msg) == -1) then
|
||||
exit
|
||||
endif
|
||||
if(task_id == 0) exit
|
||||
read (msg,*) imin, imax, ishift, istep
|
||||
integer :: k
|
||||
do k=imin,imax
|
||||
v_t(:,k) = 0.d0
|
||||
s_t(:,k) = 0.d0
|
||||
@ -165,7 +234,7 @@ subroutine davidson_slave_work(zmq_to_qp_run_socket, zmq_socket_push, N_st, sze,
|
||||
end do
|
||||
deallocate(u_t,v_t, s_t)
|
||||
call davidson_push_results_async_recv(zmq_socket_push, sending)
|
||||
|
||||
endif
|
||||
end subroutine
|
||||
|
||||
|
||||
@ -533,6 +602,7 @@ subroutine H_S2_u_0_nstates_zmq(v_0,s_0,u_0,N_st,sze)
|
||||
end
|
||||
|
||||
|
||||
|
||||
BEGIN_PROVIDER [ integer, nthreads_davidson ]
|
||||
implicit none
|
||||
BEGIN_DOC
|
||||
@ -643,3 +713,360 @@ integer function zmq_get_N_states_diag(zmq_to_qp_run_socket, worker_id)
|
||||
IRP_ENDIF
|
||||
end
|
||||
|
||||
|
||||
!==============================================================================!
|
||||
! !
|
||||
! Complex !
|
||||
! !
|
||||
!==============================================================================!
|
||||
|
||||
subroutine davidson_push_results_complex(zmq_socket_push, v_t, s_t, imin, imax, task_id)
|
||||
use f77_zmq
|
||||
implicit none
|
||||
BEGIN_DOC
|
||||
! Push the results of $H | U \rangle$ from a worker to the master.
|
||||
END_DOC
|
||||
|
||||
integer(ZMQ_PTR) ,intent(in) :: zmq_socket_push
|
||||
integer ,intent(in) :: task_id, imin, imax
|
||||
complex*16 ,intent(in) :: v_t(N_states_diag,N_det)
|
||||
complex*16 ,intent(in) :: s_t(N_states_diag,N_det)
|
||||
integer :: rc, sz
|
||||
integer*8 :: rc8
|
||||
|
||||
sz = (imax-imin+1)*N_states_diag
|
||||
|
||||
rc = f77_zmq_send( zmq_socket_push, task_id, 4, ZMQ_SNDMORE)
|
||||
if(rc /= 4) stop 'davidson_push_results_complex failed to push task_id'
|
||||
|
||||
rc = f77_zmq_send( zmq_socket_push, imin, 4, ZMQ_SNDMORE)
|
||||
if(rc /= 4) stop 'davidson_push_results_complex failed to push imin'
|
||||
|
||||
rc = f77_zmq_send( zmq_socket_push, imax, 4, ZMQ_SNDMORE)
|
||||
if(rc /= 4) stop 'davidson_push_results_complex failed to push imax'
|
||||
|
||||
!todo: double sz for complex? (done)
|
||||
rc8 = f77_zmq_send8( zmq_socket_push, v_t(1,imin), 8_8*sz*2, ZMQ_SNDMORE)
|
||||
if(rc8 /= 8_8*sz*2) then
|
||||
print*,irp_here,' rc8 = ',rc8
|
||||
print*,irp_here,' sz = ',sz
|
||||
print*,'rc8 /= sz*8'
|
||||
stop 'davidson_push_results_complex failed to push vt'
|
||||
endif
|
||||
|
||||
!todo: double sz for complex? (done)
|
||||
rc8 = f77_zmq_send8( zmq_socket_push, s_t(1,imin), 8_8*sz*2, 0)
|
||||
if(rc8 /= 8_8*sz*2) stop 'davidson_push_results_complex failed to push st'
|
||||
|
||||
! Activate is zmq_socket_push is a REQ
|
||||
IRP_IF ZMQ_PUSH
|
||||
IRP_ELSE
|
||||
character*(2) :: ok
|
||||
rc = f77_zmq_recv( zmq_socket_push, ok, 2, 0)
|
||||
if ((rc /= 2).and.(ok(1:2)/='ok')) then
|
||||
print *, irp_here, ': f77_zmq_recv( zmq_socket_push, ok, 2, 0)'
|
||||
stop -1
|
||||
endif
|
||||
IRP_ENDIF
|
||||
|
||||
end subroutine
|
||||
|
||||
subroutine davidson_push_results_async_send_complex(zmq_socket_push, v_t, s_t, imin, imax, task_id,sending)
|
||||
use f77_zmq
|
||||
implicit none
|
||||
BEGIN_DOC
|
||||
! Push the results of $H | U \rangle$ from a worker to the master.
|
||||
END_DOC
|
||||
|
||||
integer(ZMQ_PTR) ,intent(in) :: zmq_socket_push
|
||||
integer ,intent(in) :: task_id, imin, imax
|
||||
complex*16 ,intent(in) :: v_t(N_states_diag,N_det)
|
||||
complex*16 ,intent(in) :: s_t(N_states_diag,N_det)
|
||||
logical ,intent(inout) :: sending
|
||||
integer :: rc, sz
|
||||
integer*8 :: rc8
|
||||
|
||||
if (sending) then
|
||||
print *, irp_here, ': sending=true'
|
||||
stop -1
|
||||
endif
|
||||
sending = .True.
|
||||
|
||||
sz = (imax-imin+1)*N_states_diag
|
||||
|
||||
rc = f77_zmq_send( zmq_socket_push, task_id, 4, ZMQ_SNDMORE)
|
||||
if(rc /= 4) stop 'davidson_push_results_async_send_complex failed to push task_id'
|
||||
|
||||
rc = f77_zmq_send( zmq_socket_push, imin, 4, ZMQ_SNDMORE)
|
||||
if(rc /= 4) stop 'davidson_push_results_async_send_complex failed to push imin'
|
||||
|
||||
rc = f77_zmq_send( zmq_socket_push, imax, 4, ZMQ_SNDMORE)
|
||||
if(rc /= 4) stop 'davidson_push_results_async_send_complex failed to push imax'
|
||||
|
||||
!todo: double sz for complex? (done)
|
||||
rc8 = f77_zmq_send8( zmq_socket_push, v_t(1,imin), 8_8*sz*2, ZMQ_SNDMORE)
|
||||
if(rc8 /= 8_8*sz*2) then
|
||||
print*,irp_here,' rc8 = ',rc8
|
||||
print*,irp_here,' sz = ',sz
|
||||
print*,'rc8 /= sz*8'
|
||||
stop 'davidson_push_results_async_send_complex failed to push vt'
|
||||
endif
|
||||
|
||||
!todo: double sz for complex? (done)
|
||||
rc8 = f77_zmq_send8( zmq_socket_push, s_t(1,imin), 8_8*sz*2, 0)
|
||||
if(rc8 /= 8_8*sz*2) stop 'davidson_push_results_async_send_complex failed to push st'
|
||||
|
||||
end subroutine
|
||||
|
||||
|
||||
subroutine davidson_pull_results_complex(zmq_socket_pull, v_t, s_t, imin, imax, task_id)
|
||||
use f77_zmq
|
||||
implicit none
|
||||
BEGIN_DOC
|
||||
! Pull the results of $H | U \rangle$ on the master.
|
||||
END_DOC
|
||||
|
||||
integer(ZMQ_PTR) ,intent(in) :: zmq_socket_pull
|
||||
integer ,intent(out) :: task_id, imin, imax
|
||||
complex*16 ,intent(out) :: v_t(N_states_diag,N_det)
|
||||
complex*16 ,intent(out) :: s_t(N_states_diag,N_det)
|
||||
|
||||
integer :: rc, sz
|
||||
integer*8 :: rc8
|
||||
|
||||
rc = f77_zmq_recv( zmq_socket_pull, task_id, 4, 0)
|
||||
if(rc /= 4) stop 'davidson_pull_results failed to pull task_id'
|
||||
|
||||
rc = f77_zmq_recv( zmq_socket_pull, imin, 4, 0)
|
||||
if(rc /= 4) stop 'davidson_pull_results failed to pull imin'
|
||||
|
||||
rc = f77_zmq_recv( zmq_socket_pull, imax, 4, 0)
|
||||
if(rc /= 4) stop 'davidson_pull_results failed to pull imax'
|
||||
|
||||
sz = (imax-imin+1)*N_states_diag
|
||||
|
||||
!todo: double sz for complex? (done)
|
||||
rc8 = f77_zmq_recv8( zmq_socket_pull, v_t(1,imin), 8_8*sz*2, 0)
|
||||
if(rc8 /= 8*sz*2) stop 'davidson_pull_results_complex failed to pull v_t'
|
||||
|
||||
!todo: double sz for complex? (done)
|
||||
rc8 = f77_zmq_recv8( zmq_socket_pull, s_t(1,imin), 8_8*sz*2, 0)
|
||||
if(rc8 /= 8*sz*2) stop 'davidson_pull_results_complex failed to pull s_t'
|
||||
|
||||
! Activate if zmq_socket_pull is a REP
|
||||
IRP_IF ZMQ_PUSH
|
||||
IRP_ELSE
|
||||
rc = f77_zmq_send( zmq_socket_pull, 'ok', 2, 0)
|
||||
if (rc /= 2) then
|
||||
print *, irp_here, ' : f77_zmq_send (zmq_socket_pull,...'
|
||||
stop -1
|
||||
endif
|
||||
IRP_ENDIF
|
||||
|
||||
end subroutine
|
||||
|
||||
|
||||
subroutine davidson_collector_complex(zmq_to_qp_run_socket, zmq_socket_pull, v0, s0, sze, N_st)
|
||||
use f77_zmq
|
||||
implicit none
|
||||
BEGIN_DOC
|
||||
! Routine collecting the results of the workers in Davidson's algorithm.
|
||||
END_DOC
|
||||
|
||||
integer(ZMQ_PTR), intent(in) :: zmq_socket_pull
|
||||
integer, intent(in) :: sze, N_st
|
||||
integer(ZMQ_PTR), intent(in) :: zmq_to_qp_run_socket
|
||||
|
||||
complex*16 ,intent(inout) :: v0(sze, N_st)
|
||||
complex*16 ,intent(inout) :: s0(sze, N_st)
|
||||
|
||||
integer :: more, task_id, imin, imax
|
||||
|
||||
complex*16, allocatable :: v_t(:,:), s_t(:,:)
|
||||
logical :: sending
|
||||
integer :: i,j
|
||||
integer, external :: zmq_delete_task_async_send
|
||||
integer, external :: zmq_delete_task_async_recv
|
||||
|
||||
allocate(v_t(N_st,N_det), s_t(N_st,N_det))
|
||||
v0 = (0.d0,0.d0)
|
||||
s0 = (0.d0,0.d0)
|
||||
more = 1
|
||||
sending = .False.
|
||||
do while (more == 1)
|
||||
call davidson_pull_results_complex(zmq_socket_pull, v_t, s_t, imin, imax, task_id)
|
||||
if (zmq_delete_task_async_send(zmq_to_qp_run_socket,task_id,sending) == -1) then
|
||||
stop 'davidson: Unable to delete task (send)'
|
||||
endif
|
||||
do j=1,N_st
|
||||
do i=imin,imax
|
||||
v0(i,j) = v0(i,j) + v_t(j,i)
|
||||
s0(i,j) = s0(i,j) + s_t(j,i)
|
||||
enddo
|
||||
enddo
|
||||
if (zmq_delete_task_async_recv(zmq_to_qp_run_socket,more,sending) == -1) then
|
||||
stop 'davidson: Unable to delete task (recv)'
|
||||
endif
|
||||
end do
|
||||
deallocate(v_t,s_t)
|
||||
|
||||
end subroutine
|
||||
|
||||
|
||||
|
||||
subroutine h_s2_u_0_nstates_zmq_complex(v_0,s_0,u_0,N_st,sze)
|
||||
!todo: maybe make separate zmq_put_psi_complex?
|
||||
!print*,irp_here,' not implemented for complex'
|
||||
!stop -1
|
||||
use omp_lib
|
||||
use bitmasks
|
||||
use f77_zmq
|
||||
implicit none
|
||||
BEGIN_DOC
|
||||
! Computes $v_0 = H | u_0\rangle$ and $s_0 = S^2 | u_0\rangle$
|
||||
!
|
||||
! n : number of determinants
|
||||
!
|
||||
! H_jj : array of $\langle j | H | j \rangle$
|
||||
!
|
||||
! S2_jj : array of $\langle j | S^2 | j \rangle$
|
||||
END_DOC
|
||||
integer, intent(in) :: N_st, sze
|
||||
complex*16, intent(out) :: v_0(sze,N_st), s_0(sze,N_st)
|
||||
complex*16, intent(inout) :: u_0(sze,N_st)
|
||||
integer :: i,j,k
|
||||
integer :: ithread
|
||||
complex*16, allocatable :: u_tc(:,:)
|
||||
!DIR$ ATTRIBUTES ALIGN : $IRP_ALIGN :: u_tc
|
||||
integer(ZMQ_PTR) :: zmq_to_qp_run_socket, zmq_socket_pull
|
||||
PROVIDE psi_det_beta_unique psi_bilinear_matrix_order_transp_reverse psi_det_alpha_unique
|
||||
PROVIDE psi_bilinear_matrix_transp_values_complex psi_bilinear_matrix_values_complex psi_bilinear_matrix_columns_loc
|
||||
PROVIDE ref_bitmask_energy nproc
|
||||
PROVIDE mpi_initialized
|
||||
|
||||
call new_parallel_job(zmq_to_qp_run_socket,zmq_socket_pull,'davidson')
|
||||
|
||||
! integer :: N_states_diag_save
|
||||
! N_states_diag_save = N_states_diag
|
||||
! N_states_diag = N_st
|
||||
if (zmq_put_N_states_diag(zmq_to_qp_run_socket, 1) == -1) then
|
||||
stop 'Unable to put N_states_diag on ZMQ server'
|
||||
endif
|
||||
|
||||
if (zmq_put_psi(zmq_to_qp_run_socket,1) == -1) then
|
||||
stop 'Unable to put psi on ZMQ server'
|
||||
endif
|
||||
energy = 0.d0
|
||||
if (zmq_put_dvector(zmq_to_qp_run_socket,1,'energy',energy,size(energy)) == -1) then
|
||||
stop 'Unable to put energy on ZMQ server'
|
||||
endif
|
||||
|
||||
|
||||
! Create tasks
|
||||
! ============
|
||||
|
||||
integer :: istep, imin, imax, ishift, ipos
|
||||
integer, external :: add_task_to_taskserver
|
||||
integer, parameter :: tasksize=10000
|
||||
character*(100000) :: task
|
||||
istep=1
|
||||
ishift=0
|
||||
imin=1
|
||||
|
||||
|
||||
ipos=1
|
||||
do imin=1,N_det,tasksize
|
||||
imax = min(N_det,imin-1+tasksize)
|
||||
do ishift=0,istep-1
|
||||
write(task(ipos:ipos+50),'(4(I11,1X),1X,1A)') imin, imax, ishift, istep, '|'
|
||||
ipos = ipos+50
|
||||
if (ipos > 100000-50) then
|
||||
if (add_task_to_taskserver(zmq_to_qp_run_socket,trim(task(1:ipos))) == -1) then
|
||||
stop 'Unable to add task'
|
||||
endif
|
||||
ipos=1
|
||||
endif
|
||||
enddo
|
||||
enddo
|
||||
|
||||
if (ipos > 1) then
|
||||
if (add_task_to_taskserver(zmq_to_qp_run_socket,trim(task(1:ipos))) == -1) then
|
||||
stop 'Unable to add task'
|
||||
endif
|
||||
ipos=1
|
||||
endif
|
||||
|
||||
allocate(u_tc(N_st,N_det))
|
||||
do k=1,N_st
|
||||
call cdset_order(u_0(1,k),psi_bilinear_matrix_order,N_det)
|
||||
enddo
|
||||
|
||||
call cdtranspose( &
|
||||
u_0, &
|
||||
size(u_0, 1), &
|
||||
u_tc, &
|
||||
size(u_tc, 1), &
|
||||
N_det, N_st)
|
||||
|
||||
|
||||
ASSERT (N_st == N_states_diag)
|
||||
ASSERT (sze >= N_det)
|
||||
|
||||
integer :: rc, ni, nj
|
||||
integer*8 :: rc8
|
||||
double precision :: energy(N_st)
|
||||
|
||||
integer, external :: zmq_put_dvector, zmq_put_psi, zmq_put_N_states_diag
|
||||
integer, external :: zmq_put_cdmatrix
|
||||
if (size(u_tc,kind=8) < 8388608_8) then
|
||||
ni = size(u_tc)
|
||||
nj = 1
|
||||
else
|
||||
ni = 8388608
|
||||
nj = int(size(u_tc,kind=8)/8388608_8,4) + 1
|
||||
endif
|
||||
! Warning : dimensions are modified for efficiency, It is OK since we get the
|
||||
! full matrix
|
||||
if (zmq_put_cdmatrix(zmq_to_qp_run_socket, 1, 'u_tc', u_tc, ni, nj, size(u_tc,kind=8)) == -1) then
|
||||
stop 'Unable to put u_tc on ZMQ server'
|
||||
endif
|
||||
|
||||
deallocate(u_tc)
|
||||
|
||||
integer, external :: zmq_set_running
|
||||
if (zmq_set_running(zmq_to_qp_run_socket) == -1) then
|
||||
print *, irp_here, ': Failed in zmq_set_running'
|
||||
endif
|
||||
|
||||
call omp_set_nested(.True.)
|
||||
!$OMP PARALLEL DEFAULT(shared) NUM_THREADS(2) PRIVATE(ithread)
|
||||
ithread = omp_get_thread_num()
|
||||
if (ithread == 0 ) then
|
||||
call davidson_collector_complex(zmq_to_qp_run_socket, zmq_socket_pull, v_0, s_0, N_det, N_st)
|
||||
else
|
||||
call davidson_slave_inproc(1)
|
||||
endif
|
||||
!$OMP END PARALLEL
|
||||
call end_parallel_job(zmq_to_qp_run_socket, zmq_socket_pull, 'davidson')
|
||||
|
||||
!$OMP PARALLEL
|
||||
!$OMP SINGLE
|
||||
do k=1,N_st
|
||||
!$OMP TASK DEFAULT(SHARED) FIRSTPRIVATE(k,N_det)
|
||||
call cdset_order(v_0(1,k),psi_bilinear_matrix_order_reverse,N_det)
|
||||
!$OMP END TASK
|
||||
!$OMP TASK DEFAULT(SHARED) FIRSTPRIVATE(k,N_det)
|
||||
call cdset_order(s_0(1,k),psi_bilinear_matrix_order_reverse,N_det)
|
||||
!$OMP END TASK
|
||||
!$OMP TASK DEFAULT(SHARED) FIRSTPRIVATE(k,N_det)
|
||||
call cdset_order(u_0(1,k),psi_bilinear_matrix_order_reverse,N_det)
|
||||
!$OMP END TASK
|
||||
enddo
|
||||
!$OMP END SINGLE
|
||||
!$OMP TASKWAIT
|
||||
!$OMP END PARALLEL
|
||||
|
||||
! N_states_diag = N_states_diag_save
|
||||
! SOFT_TOUCH N_states_diag
|
||||
end
|
||||
|
||||
|
@ -33,9 +33,16 @@ BEGIN_PROVIDER [ integer, dressed_column_idx, (N_states) ]
|
||||
integer :: i
|
||||
double precision :: tmp
|
||||
integer, external :: idamax
|
||||
if (is_complex) then
|
||||
do i=1,N_states
|
||||
!todo: check for complex
|
||||
dressed_column_idx(i) = idamax(N_det, cdabs(psi_coef_complex(1,i)), 1)
|
||||
enddo
|
||||
else
|
||||
do i=1,N_states
|
||||
dressed_column_idx(i) = idamax(N_det, psi_coef(1,i), 1)
|
||||
enddo
|
||||
endif
|
||||
END_PROVIDER
|
||||
|
||||
subroutine davidson_diag_hs2(dets_in,u_in,s2_out,dim_in,energies,sze,N_st,N_st_diag,Nint,dressing_state,converged)
|
||||
@ -721,7 +728,730 @@ end
|
||||
|
||||
|
||||
|
||||
!==============================================================================!
|
||||
! !
|
||||
! Complex !
|
||||
! !
|
||||
!==============================================================================!
|
||||
|
||||
subroutine davidson_diag_hs2_complex(dets_in,u_in,s2_out,dim_in,energies,sze,N_st,N_st_diag,Nint,dressing_state,converged)
|
||||
use bitmasks
|
||||
implicit none
|
||||
BEGIN_DOC
|
||||
! Davidson diagonalization.
|
||||
!
|
||||
! dets_in : bitmasks corresponding to determinants
|
||||
!
|
||||
! u_in : guess coefficients on the various states. Overwritten
|
||||
! on exit
|
||||
!
|
||||
! dim_in : leftmost dimension of u_in
|
||||
!
|
||||
! sze : Number of determinants
|
||||
!
|
||||
! N_st : Number of eigenstates
|
||||
!
|
||||
! 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)
|
||||
complex*16, intent(inout) :: u_in(dim_in,N_st_diag)
|
||||
double precision, intent(out) :: energies(N_st_diag), s2_out(N_st_diag)
|
||||
integer, intent(in) :: dressing_state
|
||||
logical, intent(out) :: converged
|
||||
double precision, allocatable :: H_jj(:)
|
||||
|
||||
double precision, external :: diag_H_mat_elem, diag_S_mat_elem
|
||||
integer :: i,k
|
||||
ASSERT (N_st > 0)
|
||||
ASSERT (sze > 0)
|
||||
ASSERT (Nint > 0)
|
||||
ASSERT (Nint == N_int)
|
||||
PROVIDE mo_two_e_integrals_in_map
|
||||
allocate(H_jj(sze))
|
||||
|
||||
H_jj(1) = diag_h_mat_elem(dets_in(1,1,1),Nint)
|
||||
!$OMP PARALLEL DEFAULT(NONE) &
|
||||
!$OMP SHARED(sze,H_jj, dets_in,Nint) &
|
||||
!$OMP PRIVATE(i)
|
||||
!$OMP DO SCHEDULE(static)
|
||||
do i=2,sze
|
||||
H_jj(i) = diag_H_mat_elem(dets_in(1,1,i),Nint)
|
||||
enddo
|
||||
!$OMP END DO
|
||||
!$OMP END PARALLEL
|
||||
|
||||
if (dressing_state > 0) then
|
||||
!todo: implement for complex
|
||||
print*,irp_here,' not implemented for complex if dressing_state > 0'
|
||||
stop -1
|
||||
do k=1,N_st
|
||||
do i=1,sze
|
||||
H_jj(i) += dble(u_in(i,k) * dressing_column_h(i,k))
|
||||
enddo
|
||||
enddo
|
||||
endif
|
||||
|
||||
call davidson_diag_hjj_sjj_complex(dets_in,u_in,H_jj,S2_out,energies,dim_in,sze,N_st,N_st_diag,Nint,dressing_state,converged)
|
||||
deallocate (H_jj)
|
||||
end
|
||||
|
||||
|
||||
subroutine davidson_diag_hjj_sjj_complex(dets_in,u_in,H_jj,s2_out,energies,dim_in,sze,N_st,N_st_diag_in,Nint,dressing_state,converged)
|
||||
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_out : Output : s^2
|
||||
!
|
||||
! 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_in : Number of states in which H is diagonalized. Assumed > sze
|
||||
!
|
||||
! Initial guess vectors are not necessarily orthonormal
|
||||
END_DOC
|
||||
integer, intent(in) :: dim_in, sze, N_st, N_st_diag_in, Nint
|
||||
integer(bit_kind), intent(in) :: dets_in(Nint,2,sze)
|
||||
double precision, intent(in) :: H_jj(sze)
|
||||
integer, intent(in) :: dressing_state
|
||||
double precision, intent(inout) :: s2_out(N_st_diag_in)
|
||||
complex*16, intent(inout) :: u_in(dim_in,N_st_diag_in)
|
||||
double precision, intent(out) :: energies(N_st_diag_in)
|
||||
|
||||
integer :: iter, N_st_diag
|
||||
integer :: i,j,k,l,m
|
||||
logical, intent(inout) :: converged
|
||||
|
||||
double precision, external :: u_dot_u_complex
|
||||
complex*16, external :: u_dot_v_complex
|
||||
|
||||
integer :: k_pairs, kl
|
||||
|
||||
integer :: iter2, itertot
|
||||
double precision, allocatable :: lambda(:), s2(:)
|
||||
complex*16, allocatable :: y(:,:), h(:,:), h_p(:,:)
|
||||
complex*8, allocatable :: y_s(:,:)
|
||||
complex*16, allocatable :: s_(:,:), s_tmp(:,:)
|
||||
double precision :: diag_h_mat_elem
|
||||
double precision, allocatable :: residual_norm(:)
|
||||
character*(16384) :: write_buffer
|
||||
double precision :: to_print(3,N_st)
|
||||
double precision :: cpu, wall
|
||||
integer :: shift, shift2, itermax, istate
|
||||
double precision :: r1, r2, alpha
|
||||
logical :: state_ok(N_st_diag_in*davidson_sze_max)
|
||||
integer :: nproc_target
|
||||
integer :: order(N_st_diag_in)
|
||||
double precision :: cmax
|
||||
double precision, allocatable :: overlap(:,:)
|
||||
complex*16, allocatable :: y_tmp(:,:)
|
||||
complex*16, allocatable :: S_d(:,:)
|
||||
complex*16, allocatable :: U(:,:)
|
||||
complex*16, pointer :: W(:,:)
|
||||
complex*8, pointer :: S(:,:)
|
||||
logical :: disk_based
|
||||
double precision :: energy_shift(N_st_diag_in*davidson_sze_max)
|
||||
|
||||
include 'constants.include.F'
|
||||
|
||||
N_st_diag = N_st_diag_in
|
||||
!DIR$ ATTRIBUTES ALIGN : $IRP_ALIGN :: U, W, S, y, y_s, S_d, h, lambda
|
||||
if (N_st_diag*3 > sze) then
|
||||
print *, 'error in Davidson :'
|
||||
print *, 'Increase n_det_max_full to ', N_st_diag*3
|
||||
stop -1
|
||||
endif
|
||||
|
||||
itermax = max(2,min(davidson_sze_max, sze/N_st_diag))+1
|
||||
itertot = 0
|
||||
|
||||
if (state_following) then
|
||||
allocate(overlap(N_st_diag*itermax, N_st_diag*itermax), &
|
||||
y_tmp(N_st_diag*itermax, N_st_diag*itermax))
|
||||
else
|
||||
allocate(overlap(1,1),y_tmp(1,1)) ! avoid 'if' for deallocate
|
||||
endif
|
||||
overlap = 0.d0
|
||||
y_tmp = (0.d0,0.d0)
|
||||
|
||||
!todo: provide psi_bilinear_matrix_values? (unlinked now)
|
||||
PROVIDE nuclear_repulsion expected_s2 psi_bilinear_matrix_order psi_bilinear_matrix_order_reverse threshold_davidson_pt2
|
||||
|
||||
call write_time(6)
|
||||
write(6,'(A)') ''
|
||||
write(6,'(A)') 'Davidson Diagonalization'
|
||||
write(6,'(A)') '------------------------'
|
||||
write(6,'(A)') ''
|
||||
|
||||
! Find max number of cores to fit in memory
|
||||
! -----------------------------------------
|
||||
|
||||
nproc_target = nproc
|
||||
double precision :: rss
|
||||
integer :: maxab
|
||||
maxab = max(N_det_alpha_unique, N_det_beta_unique)+1
|
||||
|
||||
m=1
|
||||
disk_based = .False.
|
||||
call resident_memory(rss)
|
||||
do
|
||||
!r1 = 8.d0 * &! bytes
|
||||
! ( dble(sze)*(N_st_diag*itermax) &! U
|
||||
! + 1.5d0*dble(sze*m)*(N_st_diag*itermax) &! W,S
|
||||
! + 1.d0*dble(sze)*(N_st_diag) &! S_d
|
||||
! + 4.5d0*(N_st_diag*itermax)**2 &! h,y,y_s,s_,s_tmp
|
||||
! + 2.d0*(N_st_diag*itermax) &! s2,lambda
|
||||
! + 1.d0*(N_st_diag) &! residual_norm
|
||||
! ! In H_S2_u_0_nstates_zmq
|
||||
! + 3.d0*(N_st_diag*N_det) &! u_t, v_t, s_t on collector
|
||||
! + 3.d0*(N_st_diag*N_det) &! u_t, v_t, s_t on slave
|
||||
! + 0.5d0*maxab &! idx0 in H_S2_u_0_nstates_openmp_work_*
|
||||
! + nproc_target * &! In OMP section
|
||||
! ( 1.d0*(N_int*maxab) &! buffer
|
||||
! + 3.5d0*(maxab) ) &! singles_a, singles_b, doubles, idx
|
||||
! ) / 1024.d0**3
|
||||
r1 = 8.d0 * &! bytes
|
||||
( 2*dble(sze)*(N_st_diag*itermax) &! U
|
||||
+ 2*1.5d0*dble(sze*m)*(N_st_diag*itermax) &! W,S
|
||||
+ 2*1.d0*dble(sze)*(N_st_diag) &! S_d
|
||||
+ 2*4.5d0*(N_st_diag*itermax)**2 &! h,y,y_s,s_,s_tmp
|
||||
+ 2.d0*(N_st_diag*itermax) &! s2,lambda
|
||||
+ 1.d0*(N_st_diag) &! residual_norm
|
||||
! In H_S2_u_0_nstates_zmq
|
||||
+ 2*3.d0*(N_st_diag*N_det) &! u_t, v_t, s_t on collector
|
||||
+ 2*3.d0*(N_st_diag*N_det) &! u_t, v_t, s_t on slave
|
||||
+ 0.5d0*maxab &! idx0 in H_S2_u_0_nstates_openmp_work_*
|
||||
+ nproc_target * &! In OMP section
|
||||
( 1.d0*(N_int*maxab) &! buffer
|
||||
+ 3.5d0*(maxab) ) &! singles_a, singles_b, doubles, idx
|
||||
) / 1024.d0**3
|
||||
|
||||
if (nproc_target == 0) then
|
||||
call check_mem(r1,irp_here)
|
||||
nproc_target = 1
|
||||
exit
|
||||
endif
|
||||
|
||||
if (r1+rss < qp_max_mem) then
|
||||
exit
|
||||
endif
|
||||
|
||||
if (itermax > 4) then
|
||||
itermax = itermax - 1
|
||||
else if (m==1.and.disk_based_davidson) then
|
||||
m=0
|
||||
disk_based = .True.
|
||||
itermax = 6
|
||||
else
|
||||
nproc_target = nproc_target - 1
|
||||
endif
|
||||
|
||||
enddo
|
||||
nthreads_davidson = nproc_target
|
||||
TOUCH nthreads_davidson
|
||||
call write_int(6,N_st,'Number of states')
|
||||
call write_int(6,N_st_diag,'Number of states in diagonalization')
|
||||
call write_int(6,sze,'Number of determinants')
|
||||
call write_int(6,nproc_target,'Number of threads for diagonalization')
|
||||
call write_double(6, r1, 'Memory(Gb)')
|
||||
if (disk_based) then
|
||||
print *, 'Using swap space to reduce RAM'
|
||||
endif
|
||||
|
||||
!---------------
|
||||
|
||||
write(6,'(A)') ''
|
||||
write_buffer = '====='
|
||||
do i=1,N_st
|
||||
write_buffer = trim(write_buffer)//' ================ =========== ==========='
|
||||
enddo
|
||||
write(6,'(A)') write_buffer(1:6+41*N_st)
|
||||
write_buffer = 'Iter'
|
||||
do i=1,N_st
|
||||
write_buffer = trim(write_buffer)//' Energy S^2 Residual '
|
||||
enddo
|
||||
write(6,'(A)') write_buffer(1:6+41*N_st)
|
||||
write_buffer = '====='
|
||||
do i=1,N_st
|
||||
write_buffer = trim(write_buffer)//' ================ =========== ==========='
|
||||
enddo
|
||||
write(6,'(A)') write_buffer(1:6+41*N_st)
|
||||
|
||||
!todo: already resized, but do we need to change c_f_pointer for complex?
|
||||
if (disk_based) then
|
||||
! Create memory-mapped files for W and S
|
||||
type(c_ptr) :: ptr_w, ptr_s
|
||||
integer :: fd_s, fd_w
|
||||
call mmap(trim(ezfio_work_dir)//'davidson_w', (/int(sze,8),int(N_st_diag*itermax,8)/),&
|
||||
8*2, fd_w, .False., ptr_w)
|
||||
call mmap(trim(ezfio_work_dir)//'davidson_s', (/int(sze,8),int(N_st_diag*itermax,8)/),&
|
||||
4*2, fd_s, .False., ptr_s)
|
||||
call c_f_pointer(ptr_w, w, (/sze,N_st_diag*itermax/))
|
||||
call c_f_pointer(ptr_s, s, (/sze,N_st_diag*itermax/))
|
||||
else
|
||||
allocate(W(sze,N_st_diag*itermax), S(sze,N_st_diag*itermax))
|
||||
endif
|
||||
|
||||
allocate( &
|
||||
! Large
|
||||
U(sze,N_st_diag*itermax), &
|
||||
S_d(sze,N_st_diag), &
|
||||
|
||||
! Small
|
||||
h(N_st_diag*itermax,N_st_diag*itermax), &
|
||||
h_p(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), &
|
||||
s2(N_st_diag*itermax), &
|
||||
y_s(N_st_diag*itermax,N_st_diag*itermax), &
|
||||
lambda(N_st_diag*itermax))
|
||||
|
||||
h = (0.d0,0.d0)
|
||||
U = (0.d0,0.d0)
|
||||
y = (0.d0,0.d0)
|
||||
s_ = (0.d0,0.d0)
|
||||
s_tmp = (0.d0,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.
|
||||
|
||||
do k=N_st+1,N_st_diag
|
||||
u_in(k,k) = (10.d0,0.d0)
|
||||
do i=1,sze
|
||||
call random_number(r1)
|
||||
call random_number(r2)
|
||||
r1 = dsqrt(-2.d0*dlog(r1))
|
||||
r2 = dtwo_pi*r2
|
||||
!todo: real or complex? rescale for complex? sqrt(2)?
|
||||
u_in(i,k) = dcmplx(r1*dcos(r2),0.d0)
|
||||
!u_in(i,k) = dcmplx(r1*dcos(r2),r1*dsin(r2))
|
||||
enddo
|
||||
enddo
|
||||
do k=1,N_st_diag
|
||||
call normalize_complex(u_in(1,k),sze)
|
||||
enddo
|
||||
|
||||
do k=1,N_st_diag
|
||||
do i=1,sze
|
||||
U(i,k) = u_in(i,k)
|
||||
enddo
|
||||
enddo
|
||||
|
||||
|
||||
do while (.not.converged)
|
||||
itertot = itertot+1
|
||||
if (itertot == 8) then
|
||||
exit
|
||||
endif
|
||||
|
||||
do iter=1,itermax-1
|
||||
|
||||
shift = N_st_diag*(iter-1)
|
||||
shift2 = N_st_diag*iter
|
||||
|
||||
if ((iter > 1).or.(itertot == 1)) then
|
||||
! Compute |W_k> = \sum_i |i><i|H|u_k>
|
||||
! -----------------------------------
|
||||
|
||||
if (disk_based) then
|
||||
call ortho_qr_unblocked_complex(U,size(U,1),sze,shift2)
|
||||
call ortho_qr_unblocked_complex(U,size(U,1),sze,shift2)
|
||||
else
|
||||
call ortho_qr_complex(U,size(U,1),sze,shift2)
|
||||
call ortho_qr_complex(U,size(U,1),sze,shift2)
|
||||
endif
|
||||
|
||||
! |W> = H|U>
|
||||
! |S_d> = S^2|U>
|
||||
if ((sze > 100000).and.distributed_davidson) then
|
||||
call h_s2_u_0_nstates_zmq_complex(W(1,shift+1),S_d,U(1,shift+1),N_st_diag,sze)
|
||||
else
|
||||
call h_s2_u_0_nstates_openmp_complex(W(1,shift+1),S_d,U(1,shift+1),N_st_diag,sze)
|
||||
endif
|
||||
S(1:sze,shift+1:shift+N_st_diag) = cmplx(S_d(1:sze,1:N_st_diag))
|
||||
else
|
||||
! Already computed in update below
|
||||
continue
|
||||
endif
|
||||
|
||||
if (dressing_state > 0) then
|
||||
!todo: implement for complex
|
||||
print*,irp_here,' not implemented for complex (dressed)'
|
||||
stop -1
|
||||
!
|
||||
! if (N_st == 1) then
|
||||
!
|
||||
! l = dressed_column_idx(1)
|
||||
! complex*16 :: f
|
||||
! !todo: check for complex
|
||||
! f = (1.0d0,0.d0)/psi_coef(l,1)
|
||||
! do istate=1,N_st_diag
|
||||
! do i=1,sze
|
||||
! !todo: conjugate?
|
||||
! W(i,shift+istate) += dressing_column_h_complex(i,1) *f * U(l,shift+istate)
|
||||
! W(l,shift+istate) += dressing_column_h_complex(i,1) *f * U(i,shift+istate)
|
||||
! S(i,shift+istate) += cmplx(dressing_column_s_complex(i,1) *f * U(l,shift+istate))
|
||||
! S(l,shift+istate) += cmplx(dressing_column_s_complex(i,1) *f * U(i,shift+istate))
|
||||
! enddo
|
||||
!
|
||||
! enddo
|
||||
!
|
||||
! else
|
||||
!
|
||||
! call dgemm('T','N', N_st, N_st_diag, sze, 1.d0, &
|
||||
! psi_coef, size(psi_coef,1), &
|
||||
! U(1,shift+1), size(U,1), 0.d0, s_tmp, size(s_tmp,1))
|
||||
!
|
||||
! call dgemm('N','N', sze, N_st_diag, N_st, 1.0d0, &
|
||||
! dressing_column_h, size(dressing_column_h,1), s_tmp, size(s_tmp,1), &
|
||||
! 1.d0, W(1,shift+1), size(W,1))
|
||||
!
|
||||
! call dgemm('N','N', sze, N_st_diag, N_st, 1.0d0, &
|
||||
! dressing_column_s, size(dressing_column_s,1), s_tmp, size(s_tmp,1), &
|
||||
! 1.d0, S_d, size(S_d,1))
|
||||
!
|
||||
!
|
||||
! call dgemm('T','N', N_st, N_st_diag, sze, 1.d0, &
|
||||
! dressing_column_h, size(dressing_column_h,1), &
|
||||
! U(1,shift+1), size(U,1), 0.d0, s_tmp, size(s_tmp,1))
|
||||
!
|
||||
! call dgemm('N','N', sze, N_st_diag, N_st, 1.0d0, &
|
||||
! psi_coef, size(psi_coef,1), s_tmp, size(s_tmp,1), &
|
||||
! 1.d0, W(1,shift+1), size(W,1))
|
||||
!
|
||||
! call dgemm('T','N', N_st, N_st_diag, sze, 1.d0, &
|
||||
! dressing_column_s, size(dressing_column_s,1), &
|
||||
! U(1,shift+1), size(U,1), 0.d0, s_tmp, size(s_tmp,1))
|
||||
!
|
||||
! call dgemm('N','N', sze, N_st_diag, N_st, 1.0d0, &
|
||||
! psi_coef, size(psi_coef,1), s_tmp, size(s_tmp,1), &
|
||||
! 1.d0, S_d, size(S_d,1))
|
||||
!
|
||||
! endif
|
||||
endif
|
||||
|
||||
! Compute s_kl = <u_k | S_l> = <u_k| S2 |u_l>
|
||||
! -------------------------------------------
|
||||
|
||||
!$OMP PARALLEL DO DEFAULT(SHARED) PRIVATE(i,j,k) COLLAPSE(2)
|
||||
do j=1,shift2
|
||||
do i=1,shift2
|
||||
s_(i,j) = (0.d0,0.d0)
|
||||
do k=1,sze
|
||||
s_(i,j) = s_(i,j) + dconjg(U(k,i)) * cmplx(S(k,j))
|
||||
enddo
|
||||
enddo
|
||||
enddo
|
||||
!$OMP END PARALLEL DO
|
||||
|
||||
! Compute h_kl = <u_k | W_l> = <u_k| H |u_l>
|
||||
! -------------------------------------------
|
||||
|
||||
!todo: why not size(h,1)?
|
||||
call zgemm('C','N', shift2, shift2, sze, &
|
||||
(1.d0,0.d0), U, size(U,1), W, size(W,1), &
|
||||
(0.d0,0.d0), h, size(h_p,1))
|
||||
|
||||
! Penalty method
|
||||
! --------------
|
||||
|
||||
if (s2_eig) then
|
||||
h_p = s_
|
||||
do k=1,shift2
|
||||
h_p(k,k) = h_p(k,k) + (S_z2_Sz - expected_s2)
|
||||
enddo
|
||||
if (only_expected_s2) then
|
||||
alpha = 0.1d0
|
||||
h_p = h + alpha*h_p
|
||||
else
|
||||
alpha = 0.0001d0
|
||||
h_p = h + alpha*h_p
|
||||
endif
|
||||
else
|
||||
h_p = h
|
||||
alpha = 0.d0
|
||||
endif
|
||||
|
||||
! Diagonalize h_p
|
||||
! ---------------
|
||||
|
||||
call lapack_diag_complex(lambda,y,h_p,size(h_p,1),shift2)
|
||||
|
||||
! Compute Energy for each eigenvector
|
||||
! -----------------------------------
|
||||
|
||||
call zgemm('N','N',shift2,shift2,shift2, &
|
||||
(1.d0,0.d0), h, size(h,1), y, size(y,1), &
|
||||
(0.d0,0.d0), s_tmp, size(s_tmp,1))
|
||||
|
||||
call zgemm('C','N',shift2,shift2,shift2, &
|
||||
(1.d0,0.d0), y, size(y,1), s_tmp, size(s_tmp,1), &
|
||||
(0.d0,0.d0), h, size(h,1))
|
||||
|
||||
do k=1,shift2
|
||||
lambda(k) = dble(h(k,k))
|
||||
enddo
|
||||
|
||||
! Compute S2 for each eigenvector
|
||||
! -------------------------------
|
||||
|
||||
call zgemm('N','N',shift2,shift2,shift2, &
|
||||
(1.d0,0.d0), s_, size(s_,1), y, size(y,1), &
|
||||
(0.d0,0.d0), s_tmp, size(s_tmp,1))
|
||||
|
||||
call zgemm('C','N',shift2,shift2,shift2, &
|
||||
(1.d0,0.d0), y, size(y,1), s_tmp, size(s_tmp,1), &
|
||||
(0.d0,0.d0), s_, size(s_,1))
|
||||
|
||||
do k=1,shift2
|
||||
s2(k) = dble(s_(k,k)) + S_z2_Sz
|
||||
enddo
|
||||
|
||||
if (only_expected_s2) 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 zswap(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
|
||||
|
||||
overlap = -1.d0
|
||||
do k=1,shift2
|
||||
do i=1,shift2
|
||||
overlap(k,i) = cdabs(y(k,i))
|
||||
enddo
|
||||
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
|
||||
y_tmp = y
|
||||
do k=1,N_st
|
||||
l = order(k)
|
||||
if (k /= l) then
|
||||
y(1:shift2,k) = y_tmp(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
|
||||
! --------------------------------------------------
|
||||
!todo: check for complex
|
||||
call zgemm('N','N', sze, N_st_diag, shift2, &
|
||||
(1.d0,0.d0), U, size(U,1), y, size(y,1), (0.d0,0.d0), U(1,shift2+1), size(U,1))
|
||||
call zgemm('N','N', sze, N_st_diag, shift2, &
|
||||
(1.d0,0.d0), W, size(W,1), y, size(y,1), (0.d0,0.d0), W(1,shift2+1), size(W,1))
|
||||
|
||||
y_s(:,:) = cmplx(y(:,:))
|
||||
call cgemm('N','N', sze, N_st_diag, shift2, &
|
||||
(1.e0,0.e0), S, size(S,1), y_s, size(y_s,1), (0.e0,0.e0), S(1,shift2+1), size(S,1))
|
||||
|
||||
! Compute residual vector and davidson step
|
||||
! -----------------------------------------
|
||||
|
||||
!$OMP PARALLEL DO DEFAULT(SHARED) PRIVATE(i,k)
|
||||
do k=1,N_st_diag
|
||||
do i=1,sze
|
||||
U(i,shift2+k) = &
|
||||
(lambda(k) * U(i,shift2+k) - W(i,shift2+k) ) &
|
||||
/max(H_jj(i) - lambda (k),1.d-2)
|
||||
enddo
|
||||
|
||||
if (k <= N_st) then
|
||||
residual_norm(k) = u_dot_u_complex(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
|
||||
!$OMP END PARALLEL DO
|
||||
|
||||
|
||||
if ((itertot>1).and.(iter == 1)) then
|
||||
!don't print
|
||||
continue
|
||||
else
|
||||
write(*,'(1X,I3,1X,100(1X,F16.10,1X,F11.6,1X,E11.3))') iter-1, to_print(1:3,1:N_st)
|
||||
endif
|
||||
|
||||
! Check convergence
|
||||
if (iter > 1) then
|
||||
converged = dabs(maxval(residual_norm(1:N_st))) < threshold_davidson_pt2
|
||||
endif
|
||||
|
||||
|
||||
do k=1,N_st
|
||||
if (residual_norm(k) > 1.e8) then
|
||||
print *, 'Davidson failed'
|
||||
stop -1
|
||||
endif
|
||||
enddo
|
||||
if (converged) then
|
||||
exit
|
||||
endif
|
||||
|
||||
logical, external :: qp_stop
|
||||
if (qp_stop()) then
|
||||
converged = .True.
|
||||
exit
|
||||
endif
|
||||
|
||||
|
||||
enddo
|
||||
|
||||
! Re-contract U and update S and W
|
||||
! --------------------------------
|
||||
|
||||
call cgemm('N','N', sze, N_st_diag, shift2, (1.e0,0.e0), &
|
||||
S, size(S,1), y_s, size(y_s,1), (0.e0,0.e0), S(1,shift2+1), size(S,1))
|
||||
do k=1,N_st_diag
|
||||
do i=1,sze
|
||||
S(i,k) = S(i,shift2+k)
|
||||
enddo
|
||||
enddo
|
||||
|
||||
call zgemm('N','N', sze, N_st_diag, shift2, (1.d0,0.d0), &
|
||||
W, size(W,1), y, size(y,1), (0.d0,0.d0), u_in, size(u_in,1))
|
||||
do k=1,N_st_diag
|
||||
do i=1,sze
|
||||
W(i,k) = u_in(i,k)
|
||||
enddo
|
||||
enddo
|
||||
|
||||
call zgemm('N','N', sze, N_st_diag, shift2, (1.d0,0.d0), &
|
||||
U, size(U,1), y, size(y,1), (0.d0,0.d0), u_in, size(u_in,1))
|
||||
do k=1,N_st_diag
|
||||
do i=1,sze
|
||||
U(i,k) = u_in(i,k)
|
||||
enddo
|
||||
enddo
|
||||
if (disk_based) then
|
||||
call ortho_qr_unblocked_complex(U,size(U,1),sze,N_st_diag)
|
||||
call ortho_qr_unblocked_complex(U,size(U,1),sze,N_st_diag)
|
||||
else
|
||||
call ortho_qr_complex(U,size(U,1),sze,N_st_diag)
|
||||
call ortho_qr_complex(U,size(U,1),sze,N_st_diag)
|
||||
endif
|
||||
do j=1,N_st_diag
|
||||
k=1
|
||||
do while ((k<sze).and.(U(k,j) == (0.d0,0.d0)))
|
||||
k = k+1
|
||||
enddo
|
||||
!if (U(k,j) * u_in(k,j) < 0.d0) then
|
||||
!todo: complex! maybe change criterion here?
|
||||
! if U is close to u_in, then arg(conjg(U)*u_in) will be near zero
|
||||
if (dble(dconjg(U(k,j)) * u_in(k,j)) < 0.d0) then
|
||||
do i=1,sze
|
||||
W(i,j) = -W(i,j)
|
||||
S(i,j) = -S(i,j)
|
||||
enddo
|
||||
endif
|
||||
enddo
|
||||
do j=1,N_st_diag
|
||||
do i=1,sze
|
||||
S_d(i,j) = cmplx(S(i,j))
|
||||
enddo
|
||||
enddo
|
||||
|
||||
enddo
|
||||
|
||||
do k=1,N_st_diag
|
||||
energies(k) = lambda(k)
|
||||
s2_out(k) = s2(k)
|
||||
enddo
|
||||
write_buffer = '======'
|
||||
do i=1,N_st
|
||||
write_buffer = trim(write_buffer)//' ================ =========== ==========='
|
||||
enddo
|
||||
write(6,'(A)') trim(write_buffer)
|
||||
write(6,'(A)') ''
|
||||
call write_time(6)
|
||||
|
||||
if (disk_based)then
|
||||
! Remove temp files
|
||||
integer, external :: getUnitAndOpen
|
||||
call munmap( (/int(sze,8),int(N_st_diag*itermax,8)/), 2*8, fd_w, ptr_w )
|
||||
fd_w = getUnitAndOpen(trim(ezfio_work_dir)//'davidson_w','r')
|
||||
close(fd_w,status='delete')
|
||||
call munmap( (/int(sze,8),int(N_st_diag*itermax,8)/), 2*4, fd_s, ptr_s )
|
||||
fd_s = getUnitAndOpen(trim(ezfio_work_dir)//'davidson_s','r')
|
||||
close(fd_s,status='delete')
|
||||
else
|
||||
deallocate(W,S)
|
||||
endif
|
||||
|
||||
deallocate ( &
|
||||
residual_norm, &
|
||||
U, overlap, y_tmp, &
|
||||
h, y_s, S_d, &
|
||||
y, s_, s_tmp, &
|
||||
lambda &
|
||||
)
|
||||
FREE nthreads_davidson
|
||||
end
|
||||
|
||||
|
||||
|
@ -20,8 +20,21 @@ BEGIN_PROVIDER [ double precision, CI_energy, (N_states_diag) ]
|
||||
END_PROVIDER
|
||||
|
||||
BEGIN_PROVIDER [ double precision, CI_electronic_energy, (N_states_diag) ]
|
||||
&BEGIN_PROVIDER [ double precision, CI_eigenvectors, (N_det,N_states_diag) ]
|
||||
&BEGIN_PROVIDER [ double precision, CI_s2, (N_states_diag) ]
|
||||
implicit none
|
||||
if (is_complex) then
|
||||
ci_s2(1:N_states_diag) = ci_s2_complex(1:N_states_diag)
|
||||
ci_electronic_energy(1:N_states_diag) = ci_electronic_energy_complex(1:N_states_diag)
|
||||
else
|
||||
ci_s2(1:N_states_diag) = ci_s2_real(1:N_states_diag)
|
||||
ci_electronic_energy(1:N_states_diag) = ci_electronic_energy_real(1:N_states_diag)
|
||||
endif
|
||||
END_PROVIDER
|
||||
|
||||
|
||||
BEGIN_PROVIDER [ double precision, CI_electronic_energy_real, (N_states_diag) ]
|
||||
&BEGIN_PROVIDER [ double precision, CI_eigenvectors, (N_det,N_states_diag) ]
|
||||
&BEGIN_PROVIDER [ double precision, CI_s2_real, (N_states_diag) ]
|
||||
BEGIN_DOC
|
||||
! Eigenvectors/values of the |CI| matrix
|
||||
END_DOC
|
||||
@ -57,8 +70,8 @@ END_PROVIDER
|
||||
|
||||
if (diag_algorithm == "Davidson") then
|
||||
|
||||
call davidson_diag_HS2(psi_det,CI_eigenvectors, CI_s2, &
|
||||
size(CI_eigenvectors,1),CI_electronic_energy, &
|
||||
call davidson_diag_HS2(psi_det,CI_eigenvectors, CI_s2_real, &
|
||||
size(CI_eigenvectors,1),CI_electronic_energy_real, &
|
||||
N_det,min(N_det,N_states),min(N_det,N_states_diag),N_int,0,converged)
|
||||
|
||||
integer :: N_states_diag_save
|
||||
@ -75,17 +88,17 @@ END_PROVIDER
|
||||
allocate (CI_eigenvectors_tmp (N_det,N_states_diag) )
|
||||
allocate (CI_s2_tmp (N_states_diag) )
|
||||
|
||||
CI_electronic_energy_tmp(1:N_states_diag_save) = CI_electronic_energy(1:N_states_diag_save)
|
||||
CI_electronic_energy_tmp(1:N_states_diag_save) = CI_electronic_energy_real(1:N_states_diag_save)
|
||||
CI_eigenvectors_tmp(1:N_det,1:N_states_diag_save) = CI_eigenvectors(1:N_det,1:N_states_diag_save)
|
||||
CI_s2_tmp(1:N_states_diag_save) = CI_s2(1:N_states_diag_save)
|
||||
CI_s2_tmp(1:N_states_diag_save) = CI_s2_real(1:N_states_diag_save)
|
||||
|
||||
call davidson_diag_HS2(psi_det,CI_eigenvectors_tmp, CI_s2_tmp, &
|
||||
size(CI_eigenvectors_tmp,1),CI_electronic_energy_tmp, &
|
||||
N_det,min(N_det,N_states),min(N_det,N_states_diag),N_int,0,converged)
|
||||
|
||||
CI_electronic_energy(1:N_states_diag_save) = CI_electronic_energy_tmp(1:N_states_diag_save)
|
||||
CI_electronic_energy_real(1:N_states_diag_save) = CI_electronic_energy_tmp(1:N_states_diag_save)
|
||||
CI_eigenvectors(1:N_det,1:N_states_diag_save) = CI_eigenvectors_tmp(1:N_det,1:N_states_diag_save)
|
||||
CI_s2(1:N_states_diag_save) = CI_s2_tmp(1:N_states_diag_save)
|
||||
CI_s2_real(1:N_states_diag_save) = CI_s2_tmp(1:N_states_diag_save)
|
||||
|
||||
deallocate (CI_electronic_energy_tmp)
|
||||
deallocate (CI_eigenvectors_tmp)
|
||||
@ -110,7 +123,7 @@ END_PROVIDER
|
||||
H_prime(j,j) = H_prime(j,j) + alpha*(S_z2_Sz - expected_s2)
|
||||
enddo
|
||||
call lapack_diag(eigenvalues,eigenvectors,H_prime,size(H_prime,1),N_det)
|
||||
CI_electronic_energy(:) = 0.d0
|
||||
CI_electronic_energy_real(:) = 0.d0
|
||||
i_state = 0
|
||||
allocate (s2_eigvalues(N_det))
|
||||
allocate(index_good_state_array(N_det),good_state_array(N_det))
|
||||
@ -141,8 +154,8 @@ END_PROVIDER
|
||||
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_s2(j) = s2_eigvalues(index_good_state_array(j))
|
||||
CI_electronic_energy_real(j) = eigenvalues(index_good_state_array(j))
|
||||
CI_s2_real(j) = s2_eigvalues(index_good_state_array(j))
|
||||
enddo
|
||||
i_other_state = 0
|
||||
do j = 1, N_det
|
||||
@ -154,8 +167,8 @@ END_PROVIDER
|
||||
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_s2(i_state+i_other_state) = s2_eigvalues(i_state+i_other_state)
|
||||
CI_electronic_energy_real(i_state+i_other_state) = eigenvalues(j)
|
||||
CI_s2_real(i_state+i_other_state) = s2_eigvalues(i_state+i_other_state)
|
||||
enddo
|
||||
|
||||
else
|
||||
@ -172,8 +185,8 @@ END_PROVIDER
|
||||
do i=1,N_det
|
||||
CI_eigenvectors(i,j) = eigenvectors(i,j)
|
||||
enddo
|
||||
CI_electronic_energy(j) = eigenvalues(j)
|
||||
CI_s2(j) = s2_eigvalues(j)
|
||||
CI_electronic_energy_real(j) = eigenvalues(j)
|
||||
CI_s2_real(j) = s2_eigvalues(j)
|
||||
enddo
|
||||
endif
|
||||
deallocate(index_good_state_array,good_state_array)
|
||||
@ -181,22 +194,22 @@ END_PROVIDER
|
||||
else
|
||||
call lapack_diag(eigenvalues,eigenvectors, &
|
||||
H_matrix_all_dets,size(H_matrix_all_dets,1),N_det)
|
||||
CI_electronic_energy(:) = 0.d0
|
||||
call u_0_S2_u_0(CI_s2,eigenvectors,N_det,psi_det,N_int,&
|
||||
CI_electronic_energy_real(:) = 0.d0
|
||||
call u_0_S2_u_0(CI_s2_real,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)
|
||||
CI_electronic_energy_real(j) = eigenvalues(j)
|
||||
enddo
|
||||
endif
|
||||
do k=1,N_states_diag
|
||||
CI_electronic_energy(k) = 0.d0
|
||||
CI_electronic_energy_real(k) = 0.d0
|
||||
do j=1,N_det
|
||||
do i=1,N_det
|
||||
CI_electronic_energy(k) += &
|
||||
CI_electronic_energy_real(k) += &
|
||||
CI_eigenvectors(i,k) * CI_eigenvectors(j,k) * &
|
||||
H_matrix_all_dets(i,j)
|
||||
enddo
|
||||
@ -207,6 +220,215 @@ END_PROVIDER
|
||||
|
||||
END_PROVIDER
|
||||
|
||||
BEGIN_PROVIDER [ double precision, CI_electronic_energy_complex, (N_states_diag) ]
|
||||
&BEGIN_PROVIDER [ complex*16, CI_eigenvectors_complex, (N_det,N_states_diag) ]
|
||||
&BEGIN_PROVIDER [ double precision, CI_s2_complex, (N_states_diag) ]
|
||||
BEGIN_DOC
|
||||
! Eigenvectors/values of the |CI| matrix
|
||||
END_DOC
|
||||
implicit none
|
||||
double precision :: ovrlp
|
||||
complex*16 :: u_dot_v_complex
|
||||
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 :: eigenvalues(:)
|
||||
complex*16, allocatable :: eigenvectors(:,:), H_prime(:,:)
|
||||
integer :: i_state
|
||||
double precision :: e_0
|
||||
integer :: i,j,k
|
||||
double precision, allocatable :: s2_eigvalues(:)
|
||||
double precision, allocatable :: e_array(:)
|
||||
integer, allocatable :: iorder(:)
|
||||
logical :: converged
|
||||
|
||||
PROVIDE threshold_davidson nthreads_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
|
||||
ci_eigenvectors_complex(i,j) = psi_coef_complex(i,j)
|
||||
enddo
|
||||
enddo
|
||||
|
||||
do j=min(N_states,N_det)+1,N_states_diag
|
||||
do i=1,N_det
|
||||
ci_eigenvectors_complex(i,j) = (0.d0,0.d0)
|
||||
enddo
|
||||
enddo
|
||||
|
||||
if (diag_algorithm == "Davidson") then
|
||||
|
||||
call davidson_diag_hs2_complex(psi_det,ci_eigenvectors_complex, ci_s2_complex, &
|
||||
size(ci_eigenvectors_complex,1),ci_electronic_energy_complex, &
|
||||
N_det,min(N_det,N_states),min(N_det,N_states_diag),N_int,0,converged)
|
||||
|
||||
integer :: N_states_diag_save
|
||||
N_states_diag_save = N_states_diag
|
||||
do while (.not.converged)
|
||||
double precision, allocatable :: ci_electronic_energy_tmp (:)
|
||||
complex*16, allocatable :: ci_eigenvectors_tmp (:,:)
|
||||
double precision, allocatable :: ci_s2_tmp (:)
|
||||
|
||||
N_states_diag *= 2
|
||||
TOUCH N_states_diag
|
||||
|
||||
allocate (ci_electronic_energy_tmp (N_states_diag) )
|
||||
allocate (ci_eigenvectors_tmp (N_det,N_states_diag) )
|
||||
allocate (ci_s2_tmp (N_states_diag) )
|
||||
|
||||
ci_electronic_energy_tmp(1:N_states_diag_save) = ci_electronic_energy_complex(1:N_states_diag_save)
|
||||
ci_eigenvectors_tmp(1:N_det,1:N_states_diag_save) = ci_eigenvectors_complex(1:N_det,1:N_states_diag_save)
|
||||
ci_s2_tmp(1:N_states_diag_save) = ci_s2_complex(1:N_states_diag_save)
|
||||
|
||||
call davidson_diag_hs2_complex(psi_det,ci_eigenvectors_tmp, ci_s2_tmp, &
|
||||
size(ci_eigenvectors_tmp,1),ci_electronic_energy_tmp, &
|
||||
N_det,min(N_det,N_states),min(N_det,N_states_diag),N_int,0,converged)
|
||||
|
||||
ci_electronic_energy_complex(1:N_states_diag_save) = ci_electronic_energy_tmp(1:N_states_diag_save)
|
||||
ci_eigenvectors_complex(1:N_det,1:N_states_diag_save) = ci_eigenvectors_tmp(1:N_det,1:N_states_diag_save)
|
||||
ci_s2_complex(1:N_states_diag_save) = ci_s2_tmp(1:N_states_diag_save)
|
||||
|
||||
deallocate (ci_electronic_energy_tmp)
|
||||
deallocate (ci_eigenvectors_tmp)
|
||||
deallocate (ci_s2_tmp)
|
||||
enddo
|
||||
if (N_states_diag > N_states_diag_save) then
|
||||
N_states_diag = N_states_diag_save
|
||||
TOUCH N_states_diag
|
||||
endif
|
||||
|
||||
else if (diag_algorithm == "Lapack") then
|
||||
|
||||
print *, 'Diagonalization of H using Lapack'
|
||||
allocate (eigenvectors(size(h_matrix_all_dets_complex,1),N_det))
|
||||
allocate (eigenvalues(N_det))
|
||||
if (s2_eig) then
|
||||
double precision, parameter :: alpha = 0.1d0
|
||||
allocate (H_prime(N_det,N_det) )
|
||||
H_prime(1:N_det,1:N_det) = h_matrix_all_dets_complex(1:N_det,1:N_det) + &
|
||||
alpha * s2_matrix_all_dets(1:N_det,1:N_det)
|
||||
do j=1,N_det
|
||||
H_prime(j,j) = H_prime(j,j) + alpha*(s_z2_sz - expected_s2)
|
||||
enddo
|
||||
call lapack_diag_complex(eigenvalues,eigenvectors,H_prime,size(H_prime,1),N_det)
|
||||
ci_electronic_energy_complex(:) = (0.d0,0.d0)
|
||||
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_complex(s2_eigvalues,eigenvectors,N_det,psi_det,N_int,&
|
||||
N_det,size(eigenvectors,1))
|
||||
if (only_expected_s2) then
|
||||
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
|
||||
else
|
||||
do j=1,N_det
|
||||
index_good_state_array(j) = j
|
||||
good_state_array(j) = .True.
|
||||
enddo
|
||||
endif
|
||||
if(i_state .ne.0)then
|
||||
! Fill the first "i_state" states that have a correct S^2 value
|
||||
do j = 1, i_state
|
||||
do i=1,N_det
|
||||
ci_eigenvectors_complex(i,j) = eigenvectors(i,index_good_state_array(j))
|
||||
enddo
|
||||
ci_electronic_energy_complex(j) = eigenvalues(index_good_state_array(j))
|
||||
ci_s2_complex(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_complex(i,i_state+i_other_state) = eigenvectors(i,j)
|
||||
enddo
|
||||
ci_electronic_energy_complex(i_state+i_other_state) = eigenvalues(j)
|
||||
ci_s2_complex(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_complex'
|
||||
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_complex(i,j) = eigenvectors(i,j)
|
||||
enddo
|
||||
ci_electronic_energy_complex(j) = eigenvalues(j)
|
||||
ci_s2_complex(j) = s2_eigvalues(j)
|
||||
enddo
|
||||
endif
|
||||
deallocate(index_good_state_array,good_state_array)
|
||||
deallocate(s2_eigvalues)
|
||||
else
|
||||
call lapack_diag_complex(eigenvalues,eigenvectors, &
|
||||
H_matrix_all_dets_complex,size(H_matrix_all_dets,1),N_det)
|
||||
ci_electronic_energy_complex(:) = 0.d0
|
||||
call u_0_S2_u_0_complex(ci_s2_complex,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_complex(i,j) = eigenvectors(i,j)
|
||||
enddo
|
||||
ci_electronic_energy_complex(j) = eigenvalues(j)
|
||||
enddo
|
||||
endif
|
||||
do k=1,N_states_diag
|
||||
ci_electronic_energy_complex(k) = 0.d0
|
||||
do j=1,N_det
|
||||
do i=1,N_det
|
||||
!todo: accumulate imag parts to test? (should sum to zero)
|
||||
ci_electronic_energy_complex(k) += &
|
||||
dble(dconjg(ci_eigenvectors_complex(i,k)) * ci_eigenvectors_complex(j,k) * &
|
||||
H_matrix_all_dets_complex(i,j))
|
||||
enddo
|
||||
enddo
|
||||
enddo
|
||||
deallocate(eigenvectors,eigenvalues)
|
||||
endif
|
||||
|
||||
END_PROVIDER
|
||||
|
||||
subroutine diagonalize_CI_complex
|
||||
implicit none
|
||||
BEGIN_DOC
|
||||
! Replace the coefficients of the |CI| states by the coefficients of the
|
||||
! eigenstates of the |CI| matrix.
|
||||
END_DOC
|
||||
integer :: i,j
|
||||
do j=1,N_states
|
||||
do i=1,N_det
|
||||
psi_coef_complex(i,j) = ci_eigenvectors_complex(i,j)
|
||||
enddo
|
||||
enddo
|
||||
psi_energy(1:N_states) = CI_electronic_energy(1:N_states)
|
||||
psi_s2(1:N_states) = CI_s2(1:N_states)
|
||||
!todo: touch ci_{s2,electronic_energy}?
|
||||
SOFT_TOUCH psi_coef_complex CI_electronic_energy_complex ci_energy CI_eigenvectors_complex CI_s2_complex psi_energy psi_s2
|
||||
end
|
||||
|
||||
subroutine diagonalize_CI
|
||||
implicit none
|
||||
BEGIN_DOC
|
||||
@ -222,5 +444,6 @@ subroutine diagonalize_CI
|
||||
psi_energy(1:N_states) = CI_electronic_energy(1:N_states)
|
||||
psi_s2(1:N_states) = CI_s2(1:N_states)
|
||||
|
||||
SOFT_TOUCH psi_coef CI_electronic_energy CI_energy CI_eigenvectors CI_s2 psi_energy psi_s2
|
||||
!todo: touch ci_{s2,electronic_energy}?
|
||||
SOFT_TOUCH psi_coef CI_electronic_energy_real ci_energy CI_eigenvectors CI_s2_real psi_energy psi_s2
|
||||
end
|
||||
|
@ -5,7 +5,8 @@ subroutine print_energy_components()
|
||||
END_DOC
|
||||
integer, save :: ifirst = 0
|
||||
double precision :: Vee, Ven, Vnn, Vecp, T, f
|
||||
integer :: i,j,k
|
||||
complex*16 :: fc
|
||||
integer :: i,j,k,kk
|
||||
|
||||
Vnn = nuclear_repulsion
|
||||
|
||||
@ -17,15 +18,32 @@ subroutine print_energy_components()
|
||||
Ven = 0.d0
|
||||
Vecp = 0.d0
|
||||
T = 0.d0
|
||||
|
||||
do j=1,mo_num
|
||||
do i=1,mo_num
|
||||
f = one_e_dm_mo_alpha(i,j,k) + one_e_dm_mo_beta(i,j,k)
|
||||
Ven = Ven + f * mo_integrals_n_e(i,j)
|
||||
Vecp = Vecp + f * mo_pseudo_integrals(i,j)
|
||||
T = T + f * mo_kinetic_integrals(i,j)
|
||||
|
||||
if (is_complex) then
|
||||
do kk=1,kpt_num
|
||||
do j=1,mo_num_per_kpt
|
||||
do i=1,mo_num_per_kpt
|
||||
!fc = one_e_dm_mo_alpha_complex(i,j,k) + one_e_dm_mo_beta_complex(i,j,k)
|
||||
!Ven = Ven + dble(fc * mo_integrals_n_e_complex(j,i))
|
||||
!Vecp = Vecp + dble(fc * mo_pseudo_integrals_complex(j,i))
|
||||
!T = T + dble(fc * mo_kinetic_integrals_complex(j,i))
|
||||
fc = one_e_dm_mo_alpha_kpts(i,j,kk,k) + one_e_dm_mo_beta_kpts(i,j,kk,k)
|
||||
Ven = Ven + dble(fc * mo_integrals_n_e_kpts(j,i,kk))
|
||||
Vecp = Vecp + dble(fc * mo_pseudo_integrals_kpts(j,i,kk))
|
||||
T = T + dble(fc * mo_kinetic_integrals_kpts(j,i,kk))
|
||||
enddo
|
||||
enddo
|
||||
enddo
|
||||
enddo
|
||||
else
|
||||
do j=1,mo_num
|
||||
do i=1,mo_num
|
||||
f = one_e_dm_mo_alpha(i,j,k) + one_e_dm_mo_beta(i,j,k)
|
||||
Ven = Ven + f * mo_integrals_n_e(i,j)
|
||||
Vecp = Vecp + f * mo_pseudo_integrals(i,j)
|
||||
T = T + f * mo_kinetic_integrals(i,j)
|
||||
enddo
|
||||
enddo
|
||||
endif
|
||||
Vee = psi_energy(k) - Ven - Vecp - T
|
||||
|
||||
if (ifirst == 0) then
|
||||
|
@ -5,8 +5,13 @@
|
||||
! psi_energy(i) = $\langle \Psi_i | H | \Psi_i \rangle$
|
||||
!
|
||||
! psi_s2(i) = $\langle \Psi_i | S^2 | \Psi_i \rangle$
|
||||
! real and complex
|
||||
END_DOC
|
||||
call u_0_H_u_0(psi_energy,psi_s2,psi_coef,N_det,psi_det,N_int,N_states,psi_det_size)
|
||||
if (is_complex) then
|
||||
call u_0_h_u_0_complex(psi_energy,psi_s2,psi_coef_complex,N_det,psi_det,N_int,N_states,psi_det_size)
|
||||
else
|
||||
call u_0_H_u_0(psi_energy,psi_s2,psi_coef,N_det,psi_det,N_int,N_states,psi_det_size)
|
||||
endif
|
||||
integer :: i
|
||||
do i=N_det+1,N_states
|
||||
psi_energy(i) = 0.d0
|
||||
@ -708,3 +713,702 @@ N_int;;
|
||||
END_TEMPLATE
|
||||
|
||||
|
||||
!==============================================================================!
|
||||
! !
|
||||
! Complex !
|
||||
! !
|
||||
!==============================================================================!
|
||||
|
||||
subroutine u_0_H_u_0_complex(e_0,s_0,u_0,n,keys_tmp,Nint,N_st,sze)
|
||||
!todo: check normalization for complex
|
||||
use bitmasks
|
||||
implicit none
|
||||
BEGIN_DOC
|
||||
! Computes $E_0 = \frac{\langle u_0 | H | u_0 \rangle}{\langle u_0 | u_0 \rangle}$
|
||||
!
|
||||
! and $S_0 = \frac{\langle u_0 | S^2 | u_0 \rangle}{\langle u_0 | u_0 \rangle}$
|
||||
!
|
||||
! n : number of determinants
|
||||
!
|
||||
END_DOC
|
||||
integer, intent(in) :: n,Nint, N_st, sze
|
||||
double precision, intent(out) :: e_0(N_st),s_0(N_st)
|
||||
complex*16, intent(inout) :: u_0(sze,N_st)
|
||||
integer(bit_kind),intent(in) :: keys_tmp(Nint,2,n)
|
||||
|
||||
complex*16, allocatable :: v_0(:,:), s_vec(:,:), u_1(:,:)
|
||||
double precision :: u_dot_u_complex,diag_H_mat_elem
|
||||
complex*16 :: u_dot_v_complex
|
||||
integer :: i,j, istate
|
||||
|
||||
if ((n > 100000).and.distributed_davidson) then
|
||||
allocate (v_0(n,N_states_diag),s_vec(n,N_states_diag), u_1(n,N_states_diag))
|
||||
u_1(:,:) = (0.d0,0.d0)
|
||||
u_1(1:n,1:N_st) = u_0(1:n,1:N_st)
|
||||
call h_s2_u_0_nstates_zmq_complex(v_0,s_vec,u_1,N_states_diag,n)
|
||||
else if (n < n_det_max_full) then
|
||||
allocate (v_0(n,N_st),s_vec(n,N_st), u_1(n,N_st))
|
||||
v_0(:,:) = (0.d0,0.d0)
|
||||
u_1(:,:) = (0.d0,0.d0)
|
||||
s_vec(:,:) = (0.d0,0.d0)
|
||||
u_1(1:n,1:N_st) = u_0(1:n,1:N_st)
|
||||
do istate = 1,N_st
|
||||
do j=1,n
|
||||
do i=1,n
|
||||
v_0(i,istate) = v_0(i,istate) + h_matrix_all_dets_complex(i,j) * u_0(j,istate)
|
||||
s_vec(i,istate) = s_vec(i,istate) + S2_matrix_all_dets(i,j) * u_0(j,istate)
|
||||
enddo
|
||||
enddo
|
||||
enddo
|
||||
else
|
||||
allocate (v_0(n,N_st),s_vec(n,N_st),u_1(n,N_st))
|
||||
u_1(:,:) = (0.d0,0.d0)
|
||||
u_1(1:n,1:N_st) = u_0(1:n,1:N_st)
|
||||
call h_s2_u_0_nstates_openmp_complex(v_0,s_vec,u_1,N_st,n)
|
||||
endif
|
||||
u_0(1:n,1:N_st) = u_1(1:n,1:N_st)
|
||||
deallocate(u_1)
|
||||
double precision :: norm
|
||||
!$OMP PARALLEL DO PRIVATE(i,norm) DEFAULT(SHARED)
|
||||
do i=1,N_st
|
||||
norm = u_dot_u_complex(u_0(1,i),n)
|
||||
if (norm /= 0.d0) then
|
||||
!todo: should these be normalized? is u_0 already normalized? (if so, where?)
|
||||
e_0(i) = dble(u_dot_v_complex(v_0(1,i),u_0(1,i),n))
|
||||
s_0(i) = dble(u_dot_v_complex(s_vec(1,i),u_0(1,i),n))
|
||||
else
|
||||
e_0(i) = 0.d0
|
||||
s_0(i) = 0.d0
|
||||
endif
|
||||
enddo
|
||||
!$OMP END PARALLEL DO
|
||||
deallocate (s_vec, v_0)
|
||||
end
|
||||
|
||||
|
||||
subroutine H_S2_u_0_nstates_openmp_complex(v_0,s_0,u_0,N_st,sze)
|
||||
use bitmasks
|
||||
implicit none
|
||||
BEGIN_DOC
|
||||
! Computes $v_0 = H | u_0\rangle$ and $s_0 = S^2 | u_0\rangle$.
|
||||
!
|
||||
! Assumes that the determinants are in psi_det
|
||||
!
|
||||
! istart, iend, ishift, istep are used in ZMQ parallelization.
|
||||
END_DOC
|
||||
integer, intent(in) :: N_st,sze
|
||||
complex*16, intent(inout) :: v_0(sze,N_st), s_0(sze,N_st), u_0(sze,N_st)
|
||||
integer :: k
|
||||
complex*16, allocatable :: u_t(:,:), v_t(:,:), s_t(:,:)
|
||||
!DIR$ ATTRIBUTES ALIGN : $IRP_ALIGN :: u_t
|
||||
allocate(u_t(N_st,N_det),v_t(N_st,N_det),s_t(N_st,N_det))
|
||||
|
||||
do k=1,N_st
|
||||
call cdset_order(u_0(1,k),psi_bilinear_matrix_order,N_det)
|
||||
enddo
|
||||
v_t = (0.d0,0.d0)
|
||||
s_t = (0.d0,0.d0)
|
||||
call cdtranspose( &
|
||||
u_0, &
|
||||
size(u_0, 1), &
|
||||
u_t, &
|
||||
size(u_t, 1), &
|
||||
N_det, N_st)
|
||||
|
||||
call h_s2_u_0_nstates_openmp_work_complex(v_t,s_t,u_t,N_st,sze,1,N_det,0,1)
|
||||
deallocate(u_t)
|
||||
|
||||
call cdtranspose( &
|
||||
v_t, &
|
||||
size(v_t, 1), &
|
||||
v_0, &
|
||||
size(v_0, 1), &
|
||||
N_st, N_det)
|
||||
call cdtranspose( &
|
||||
s_t, &
|
||||
size(s_t, 1), &
|
||||
s_0, &
|
||||
size(s_0, 1), &
|
||||
N_st, N_det)
|
||||
deallocate(v_t,s_t)
|
||||
|
||||
do k=1,N_st
|
||||
call cdset_order(v_0(1,k),psi_bilinear_matrix_order_reverse,N_det)
|
||||
call cdset_order(s_0(1,k),psi_bilinear_matrix_order_reverse,N_det)
|
||||
call cdset_order(u_0(1,k),psi_bilinear_matrix_order_reverse,N_det)
|
||||
enddo
|
||||
|
||||
end
|
||||
subroutine h_s2_u_0_nstates_openmp_work_complex(v_t,s_t,u_t,N_st,sze,istart,iend,ishift,istep)
|
||||
use bitmasks
|
||||
implicit none
|
||||
BEGIN_DOC
|
||||
! Computes $v_t = H | u_t\rangle$ and $s_t = S^2 | u_t\rangle$
|
||||
!
|
||||
! Default should be 1,N_det,0,1
|
||||
END_DOC
|
||||
integer, intent(in) :: N_st,sze,istart,iend,ishift,istep
|
||||
complex*16, intent(in) :: u_t(N_st,N_det)
|
||||
complex*16, intent(out) :: v_t(N_st,sze), s_t(N_st,sze)
|
||||
|
||||
|
||||
PROVIDE ref_bitmask_energy N_int
|
||||
|
||||
select case (N_int)
|
||||
case (1)
|
||||
call H_S2_u_0_nstates_openmp_work_complex_1(v_t,s_t,u_t,N_st,sze,istart,iend,ishift,istep)
|
||||
case (2)
|
||||
call H_S2_u_0_nstates_openmp_work_complex_2(v_t,s_t,u_t,N_st,sze,istart,iend,ishift,istep)
|
||||
case (3)
|
||||
call H_S2_u_0_nstates_openmp_work_complex_3(v_t,s_t,u_t,N_st,sze,istart,iend,ishift,istep)
|
||||
case (4)
|
||||
call H_S2_u_0_nstates_openmp_work_complex_4(v_t,s_t,u_t,N_st,sze,istart,iend,ishift,istep)
|
||||
case default
|
||||
call H_S2_u_0_nstates_openmp_work_complex_N_int(v_t,s_t,u_t,N_st,sze,istart,iend,ishift,istep)
|
||||
end select
|
||||
end
|
||||
|
||||
BEGIN_TEMPLATE
|
||||
|
||||
subroutine H_S2_u_0_nstates_openmp_work_complex_$N_int(v_t,s_t,u_t,N_st,sze,istart,iend,ishift,istep)
|
||||
use bitmasks
|
||||
implicit none
|
||||
BEGIN_DOC
|
||||
! Computes $v_t = H | u_t \\rangle$ and $s_t = S^2 | u_t\\rangle$
|
||||
!
|
||||
! Default should be 1,N_det,0,1
|
||||
END_DOC
|
||||
integer, intent(in) :: N_st,sze,istart,iend,ishift,istep
|
||||
complex*16, intent(in) :: u_t(N_st,N_det)
|
||||
complex*16, intent(out) :: v_t(N_st,sze), s_t(N_st,sze)
|
||||
|
||||
complex*16 :: hij, sij
|
||||
integer :: i,j,k,l,kk
|
||||
integer :: k_a, k_b, l_a, l_b, m_a, m_b
|
||||
integer :: istate
|
||||
integer :: krow, kcol, krow_b, kcol_b
|
||||
integer :: lrow, lcol
|
||||
integer :: mrow, mcol
|
||||
integer(bit_kind) :: spindet($N_int)
|
||||
integer(bit_kind) :: tmp_det($N_int,2)
|
||||
integer(bit_kind) :: tmp_det2($N_int,2)
|
||||
integer(bit_kind) :: tmp_det3($N_int,2)
|
||||
integer(bit_kind), allocatable :: buffer(:,:)
|
||||
integer :: n_doubles
|
||||
integer, allocatable :: doubles(:)
|
||||
integer, allocatable :: singles_a(:)
|
||||
integer, allocatable :: singles_b(:)
|
||||
integer, allocatable :: idx(:), idx0(:)
|
||||
integer :: maxab, n_singles_a, n_singles_b, kcol_prev
|
||||
integer*8 :: k8
|
||||
logical :: compute_singles
|
||||
integer*8 :: last_found, left, right, right_max
|
||||
double precision :: rss, mem, ratio
|
||||
complex*16, allocatable :: utl(:,:)
|
||||
integer, parameter :: block_size=128
|
||||
|
||||
! call resident_memory(rss)
|
||||
! mem = dble(singles_beta_csc_size) / 1024.d0**3
|
||||
!
|
||||
! compute_singles = (mem+rss > qp_max_mem)
|
||||
!
|
||||
! if (.not.compute_singles) then
|
||||
! provide singles_beta_csc
|
||||
! endif
|
||||
compute_singles=.True.
|
||||
|
||||
maxab = max(N_det_alpha_unique, N_det_beta_unique)+1
|
||||
allocate(idx0(maxab))
|
||||
|
||||
do i=1,maxab
|
||||
idx0(i) = i
|
||||
enddo
|
||||
|
||||
! Prepare the array of all alpha single excitations
|
||||
! -------------------------------------------------
|
||||
|
||||
PROVIDE N_int nthreads_davidson
|
||||
!$OMP PARALLEL DEFAULT(SHARED) NUM_THREADS(nthreads_davidson) &
|
||||
!$OMP SHARED(psi_bilinear_matrix_rows, N_det, &
|
||||
!$OMP psi_bilinear_matrix_columns, &
|
||||
!$OMP psi_det_alpha_unique, psi_det_beta_unique, &
|
||||
!$OMP n_det_alpha_unique, n_det_beta_unique, N_int, &
|
||||
!$OMP psi_bilinear_matrix_transp_rows, &
|
||||
!$OMP psi_bilinear_matrix_transp_columns, &
|
||||
!$OMP psi_bilinear_matrix_transp_order, N_st, &
|
||||
!$OMP psi_bilinear_matrix_order_transp_reverse, &
|
||||
!$OMP psi_bilinear_matrix_columns_loc, &
|
||||
!$OMP psi_bilinear_matrix_transp_rows_loc, &
|
||||
!$OMP istart, iend, istep, irp_here, v_t, s_t, &
|
||||
!$OMP ishift, idx0, u_t, maxab, compute_singles, &
|
||||
!$OMP singles_alpha_csc,singles_alpha_csc_idx, &
|
||||
!$OMP singles_beta_csc,singles_beta_csc_idx) &
|
||||
!$OMP PRIVATE(krow, kcol, tmp_det, spindet, k_a, k_b, i, &
|
||||
!$OMP lcol, lrow, l_a, l_b, utl, kk, &
|
||||
!$OMP buffer, doubles, n_doubles, &
|
||||
!$OMP tmp_det2, hij, sij, idx, l, kcol_prev, &
|
||||
!$OMP singles_a, n_singles_a, singles_b, ratio, &
|
||||
!$OMP n_singles_b, k8, last_found,left,right,right_max)
|
||||
|
||||
! Alpha/Beta double excitations
|
||||
! =============================
|
||||
|
||||
allocate( buffer($N_int,maxab), &
|
||||
singles_a(maxab), &
|
||||
singles_b(maxab), &
|
||||
doubles(maxab), &
|
||||
idx(maxab), utl(N_st,block_size))
|
||||
|
||||
kcol_prev=-1
|
||||
|
||||
ASSERT (iend <= N_det)
|
||||
ASSERT (istart > 0)
|
||||
ASSERT (istep > 0)
|
||||
|
||||
!$OMP DO SCHEDULE(guided,64)
|
||||
do k_a=istart+ishift,iend,istep
|
||||
|
||||
krow = psi_bilinear_matrix_rows(k_a)
|
||||
ASSERT (krow <= N_det_alpha_unique)
|
||||
|
||||
kcol = psi_bilinear_matrix_columns(k_a)
|
||||
ASSERT (kcol <= N_det_beta_unique)
|
||||
|
||||
tmp_det(1:$N_int,1) = psi_det_alpha_unique(1:$N_int, krow)
|
||||
|
||||
if (kcol /= kcol_prev) then
|
||||
tmp_det(1:$N_int,2) = psi_det_beta_unique (1:$N_int, kcol)
|
||||
if (compute_singles) then
|
||||
call get_all_spin_singles_$N_int( &
|
||||
psi_det_beta_unique, idx0, &
|
||||
tmp_det(1,2), N_det_beta_unique, &
|
||||
singles_b, n_singles_b)
|
||||
else
|
||||
n_singles_b = 0
|
||||
!DIR$ LOOP COUNT avg(1000)
|
||||
do k8=singles_beta_csc_idx(kcol),singles_beta_csc_idx(kcol+1)-1
|
||||
n_singles_b = n_singles_b+1
|
||||
singles_b(n_singles_b) = singles_beta_csc(k8)
|
||||
enddo
|
||||
endif
|
||||
endif
|
||||
kcol_prev = kcol
|
||||
|
||||
! Loop over singly excited beta columns
|
||||
! -------------------------------------
|
||||
|
||||
!DIR$ LOOP COUNT avg(1000)
|
||||
do i=1,n_singles_b
|
||||
lcol = singles_b(i)
|
||||
|
||||
tmp_det2(1:$N_int,2) = psi_det_beta_unique(1:$N_int, lcol)
|
||||
|
||||
!---
|
||||
! if (compute_singles) then
|
||||
|
||||
l_a = psi_bilinear_matrix_columns_loc(lcol)
|
||||
ASSERT (l_a <= N_det)
|
||||
|
||||
!DIR$ UNROLL(8)
|
||||
!DIR$ LOOP COUNT avg(50000)
|
||||
do j=1,psi_bilinear_matrix_columns_loc(lcol+1) - psi_bilinear_matrix_columns_loc(lcol)
|
||||
lrow = psi_bilinear_matrix_rows(l_a)
|
||||
ASSERT (lrow <= N_det_alpha_unique)
|
||||
|
||||
buffer(1:$N_int,j) = psi_det_alpha_unique(1:$N_int, lrow) ! hot spot
|
||||
|
||||
ASSERT (l_a <= N_det)
|
||||
idx(j) = l_a
|
||||
l_a = l_a+1
|
||||
enddo
|
||||
j = j-1
|
||||
|
||||
call get_all_spin_singles_$N_int( &
|
||||
buffer, idx, tmp_det(1,1), j, &
|
||||
singles_a, n_singles_a )
|
||||
|
||||
!-----
|
||||
! else
|
||||
!
|
||||
! ! Search for singles
|
||||
!
|
||||
!call cpu_time(time0)
|
||||
! ! Right boundary
|
||||
! l_a = psi_bilinear_matrix_columns_loc(lcol+1)-1
|
||||
! ASSERT (l_a <= N_det)
|
||||
! do j=1,psi_bilinear_matrix_columns_loc(lcol+1) - psi_bilinear_matrix_columns_loc(lcol)
|
||||
! lrow = psi_bilinear_matrix_rows(l_a)
|
||||
! ASSERT (lrow <= N_det_alpha_unique)
|
||||
!
|
||||
! left = singles_alpha_csc_idx(krow)
|
||||
! right_max = -1_8
|
||||
! right = singles_alpha_csc_idx(krow+1)
|
||||
! do while (right-left>0_8)
|
||||
! k8 = shiftr(right+left,1)
|
||||
! if (singles_alpha_csc(k8) > lrow) then
|
||||
! right = k8
|
||||
! else if (singles_alpha_csc(k8) < lrow) then
|
||||
! left = k8 + 1_8
|
||||
! else
|
||||
! right_max = k8+1_8
|
||||
! exit
|
||||
! endif
|
||||
! enddo
|
||||
! if (right_max > 0_8) exit
|
||||
! l_a = l_a-1
|
||||
! enddo
|
||||
! if (right_max < 0_8) right_max = singles_alpha_csc_idx(krow)
|
||||
!
|
||||
! ! Search
|
||||
! n_singles_a = 0
|
||||
! l_a = psi_bilinear_matrix_columns_loc(lcol)
|
||||
! ASSERT (l_a <= N_det)
|
||||
!
|
||||
! last_found = singles_alpha_csc_idx(krow)
|
||||
! do j=1,psi_bilinear_matrix_columns_loc(lcol+1) - psi_bilinear_matrix_columns_loc(lcol)
|
||||
! lrow = psi_bilinear_matrix_rows(l_a)
|
||||
! ASSERT (lrow <= N_det_alpha_unique)
|
||||
!
|
||||
! left = last_found
|
||||
! right = right_max
|
||||
! do while (right-left>0_8)
|
||||
! k8 = shiftr(right+left,1)
|
||||
! if (singles_alpha_csc(k8) > lrow) then
|
||||
! right = k8
|
||||
! else if (singles_alpha_csc(k8) < lrow) then
|
||||
! left = k8 + 1_8
|
||||
! else
|
||||
! n_singles_a += 1
|
||||
! singles_a(n_singles_a) = l_a
|
||||
! last_found = k8+1_8
|
||||
! exit
|
||||
! endif
|
||||
! enddo
|
||||
! l_a = l_a+1
|
||||
! enddo
|
||||
! j = j-1
|
||||
!
|
||||
! endif
|
||||
!-----
|
||||
|
||||
! Loop over alpha singles
|
||||
! -----------------------
|
||||
|
||||
!DIR$ LOOP COUNT avg(1000)
|
||||
do k = 1,n_singles_a,block_size
|
||||
! Prefetch u_t(:,l_a)
|
||||
do kk=0,block_size-1
|
||||
if (k+kk > n_singles_a) exit
|
||||
l_a = singles_a(k+kk)
|
||||
ASSERT (l_a <= N_det)
|
||||
|
||||
do l=1,N_st
|
||||
utl(l,kk+1) = u_t(l,l_a)
|
||||
enddo
|
||||
enddo
|
||||
|
||||
do kk=0,block_size-1
|
||||
if (k+kk > n_singles_a) exit
|
||||
l_a = singles_a(k+kk)
|
||||
lrow = psi_bilinear_matrix_rows(l_a)
|
||||
ASSERT (lrow <= N_det_alpha_unique)
|
||||
|
||||
tmp_det2(1:$N_int,1) = psi_det_alpha_unique(1:$N_int, lrow)
|
||||
!todo: check arg order conjg/noconjg (should be okay)
|
||||
call i_h_j_double_alpha_beta_complex(tmp_det,tmp_det2,$N_int,hij)
|
||||
call get_s2(tmp_det,tmp_det2,$N_int,sij)
|
||||
!DIR$ LOOP COUNT AVG(4)
|
||||
do l=1,N_st
|
||||
!todo: check arg order conjg/noconjg (should be okay)
|
||||
v_t(l,k_a) = v_t(l,k_a) + hij * utl(l,kk+1)
|
||||
s_t(l,k_a) = s_t(l,k_a) + sij * utl(l,kk+1)
|
||||
enddo
|
||||
enddo
|
||||
enddo
|
||||
|
||||
enddo
|
||||
|
||||
enddo
|
||||
!$OMP END DO
|
||||
|
||||
!$OMP DO SCHEDULE(guided,64)
|
||||
do k_a=istart+ishift,iend,istep
|
||||
|
||||
|
||||
! Single and double alpha excitations
|
||||
! ===================================
|
||||
|
||||
|
||||
! Initial determinant is at k_a in alpha-major representation
|
||||
! -----------------------------------------------------------------------
|
||||
|
||||
krow = psi_bilinear_matrix_rows(k_a)
|
||||
ASSERT (krow <= N_det_alpha_unique)
|
||||
|
||||
kcol = psi_bilinear_matrix_columns(k_a)
|
||||
ASSERT (kcol <= N_det_beta_unique)
|
||||
|
||||
tmp_det(1:$N_int,1) = psi_det_alpha_unique(1:$N_int, krow)
|
||||
tmp_det(1:$N_int,2) = psi_det_beta_unique (1:$N_int, kcol)
|
||||
|
||||
! Initial determinant is at k_b in beta-major representation
|
||||
! ----------------------------------------------------------------------
|
||||
|
||||
k_b = psi_bilinear_matrix_order_transp_reverse(k_a)
|
||||
ASSERT (k_b <= N_det)
|
||||
|
||||
spindet(1:$N_int) = tmp_det(1:$N_int,1)
|
||||
|
||||
! Loop inside the beta column to gather all the connected alphas
|
||||
lcol = psi_bilinear_matrix_columns(k_a)
|
||||
l_a = psi_bilinear_matrix_columns_loc(lcol)
|
||||
|
||||
!DIR$ LOOP COUNT avg(200000)
|
||||
do i=1,N_det_alpha_unique
|
||||
if (l_a > N_det) exit
|
||||
lcol = psi_bilinear_matrix_columns(l_a)
|
||||
if (lcol /= kcol) exit
|
||||
lrow = psi_bilinear_matrix_rows(l_a)
|
||||
ASSERT (lrow <= N_det_alpha_unique)
|
||||
|
||||
buffer(1:$N_int,i) = psi_det_alpha_unique(1:$N_int, lrow) ! Hot spot
|
||||
idx(i) = l_a
|
||||
l_a = l_a+1
|
||||
enddo
|
||||
i = i-1
|
||||
|
||||
call get_all_spin_singles_and_doubles_$N_int( &
|
||||
buffer, idx, spindet, i, &
|
||||
singles_a, doubles, n_singles_a, n_doubles )
|
||||
|
||||
! Compute Hij for all alpha singles
|
||||
! ----------------------------------
|
||||
|
||||
tmp_det2(1:$N_int,2) = psi_det_beta_unique (1:$N_int, kcol)
|
||||
!DIR$ LOOP COUNT avg(1000)
|
||||
do i=1,n_singles_a,block_size
|
||||
! Prefetch u_t(:,l_a)
|
||||
do kk=0,block_size-1
|
||||
if (i+kk > n_singles_a) exit
|
||||
l_a = singles_a(i+kk)
|
||||
ASSERT (l_a <= N_det)
|
||||
|
||||
do l=1,N_st
|
||||
utl(l,kk+1) = u_t(l,l_a)
|
||||
enddo
|
||||
enddo
|
||||
|
||||
do kk=0,block_size-1
|
||||
if (i+kk > n_singles_a) exit
|
||||
l_a = singles_a(i+kk)
|
||||
lrow = psi_bilinear_matrix_rows(l_a)
|
||||
ASSERT (lrow <= N_det_alpha_unique)
|
||||
|
||||
tmp_det2(1:$N_int,1) = psi_det_alpha_unique(1:$N_int, lrow)
|
||||
!todo: check arg order conjg/noconjg (should be okay)
|
||||
call i_h_j_single_spin_complex( tmp_det, tmp_det2, $N_int, 1, hij)
|
||||
|
||||
!DIR$ LOOP COUNT AVG(4)
|
||||
do l=1,N_st
|
||||
!todo: check arg order conjg/noconjg (should be okay)
|
||||
v_t(l,k_a) = v_t(l,k_a) + hij * utl(l,kk+1)
|
||||
! single => sij = 0
|
||||
enddo
|
||||
enddo
|
||||
enddo
|
||||
|
||||
|
||||
! Compute Hij for all alpha doubles
|
||||
! ----------------------------------
|
||||
|
||||
!DIR$ LOOP COUNT avg(50000)
|
||||
do i=1,n_doubles,block_size
|
||||
! Prefetch u_t(:,l_a)
|
||||
do kk=0,block_size-1
|
||||
if (i+kk > n_doubles) exit
|
||||
l_a = doubles(i+kk)
|
||||
ASSERT (l_a <= N_det)
|
||||
|
||||
do l=1,N_st
|
||||
utl(l,kk+1) = u_t(l,l_a)
|
||||
enddo
|
||||
enddo
|
||||
|
||||
do kk=0,block_size-1
|
||||
if (i+kk > n_doubles) exit
|
||||
l_a = doubles(i+kk)
|
||||
lrow = psi_bilinear_matrix_rows(l_a)
|
||||
ASSERT (lrow <= N_det_alpha_unique)
|
||||
|
||||
!todo: check arg order conjg/noconjg (should be okay)
|
||||
call i_h_j_double_spin_complex( tmp_det(1,1), psi_det_alpha_unique(1, lrow), $N_int, hij)
|
||||
!DIR$ LOOP COUNT AVG(4)
|
||||
do l=1,N_st
|
||||
!todo: check arg order conjg/noconjg (should be okay)
|
||||
v_t(l,k_a) = v_t(l,k_a) + hij * utl(l,kk+1)
|
||||
! same spin => sij = 0
|
||||
enddo
|
||||
enddo
|
||||
enddo
|
||||
|
||||
|
||||
! Single and double beta excitations
|
||||
! ==================================
|
||||
|
||||
|
||||
! Initial determinant is at k_a in alpha-major representation
|
||||
! -----------------------------------------------------------------------
|
||||
|
||||
krow = psi_bilinear_matrix_rows(k_a)
|
||||
kcol = psi_bilinear_matrix_columns(k_a)
|
||||
|
||||
tmp_det(1:$N_int,1) = psi_det_alpha_unique(1:$N_int, krow)
|
||||
tmp_det(1:$N_int,2) = psi_det_beta_unique (1:$N_int, kcol)
|
||||
|
||||
spindet(1:$N_int) = tmp_det(1:$N_int,2)
|
||||
|
||||
! Initial determinant is at k_b in beta-major representation
|
||||
! -----------------------------------------------------------------------
|
||||
|
||||
k_b = psi_bilinear_matrix_order_transp_reverse(k_a)
|
||||
ASSERT (k_b <= N_det)
|
||||
|
||||
! Loop inside the alpha row to gather all the connected betas
|
||||
lrow = psi_bilinear_matrix_transp_rows(k_b)
|
||||
l_b = psi_bilinear_matrix_transp_rows_loc(lrow)
|
||||
!DIR$ LOOP COUNT avg(200000)
|
||||
do i=1,N_det_beta_unique
|
||||
if (l_b > N_det) exit
|
||||
lrow = psi_bilinear_matrix_transp_rows(l_b)
|
||||
if (lrow /= krow) exit
|
||||
lcol = psi_bilinear_matrix_transp_columns(l_b)
|
||||
ASSERT (lcol <= N_det_beta_unique)
|
||||
|
||||
buffer(1:$N_int,i) = psi_det_beta_unique(1:$N_int, lcol)
|
||||
idx(i) = l_b
|
||||
l_b = l_b+1
|
||||
enddo
|
||||
i = i-1
|
||||
|
||||
call get_all_spin_singles_and_doubles_$N_int( &
|
||||
buffer, idx, spindet, i, &
|
||||
singles_b, doubles, n_singles_b, n_doubles )
|
||||
|
||||
! Compute Hij for all beta singles
|
||||
! ----------------------------------
|
||||
|
||||
tmp_det2(1:$N_int,1) = psi_det_alpha_unique(1:$N_int, krow)
|
||||
!DIR$ LOOP COUNT avg(1000)
|
||||
do i=1,n_singles_b,block_size
|
||||
do kk=0,block_size-1
|
||||
if (i+kk > n_singles_b) exit
|
||||
l_b = singles_b(i+kk)
|
||||
ASSERT (l_b <= N_det)
|
||||
|
||||
l_a = psi_bilinear_matrix_transp_order(l_b)
|
||||
ASSERT (l_a <= N_det)
|
||||
|
||||
do l=1,N_st
|
||||
utl(l,kk+1) = u_t(l,l_a)
|
||||
enddo
|
||||
enddo
|
||||
|
||||
do kk=0,block_size-1
|
||||
if (i+kk > n_singles_b) exit
|
||||
l_b = singles_b(i+kk)
|
||||
l_a = psi_bilinear_matrix_transp_order(l_b)
|
||||
lcol = psi_bilinear_matrix_transp_columns(l_b)
|
||||
ASSERT (lcol <= N_det_beta_unique)
|
||||
|
||||
tmp_det2(1:$N_int,2) = psi_det_beta_unique (1:$N_int, lcol)
|
||||
call i_h_j_single_spin_complex( tmp_det, tmp_det2, $N_int, 2, hij)
|
||||
!DIR$ LOOP COUNT AVG(4)
|
||||
do l=1,N_st
|
||||
!todo: check arg order conjg/noconjg (should be okay)
|
||||
v_t(l,k_a) = v_t(l,k_a) + hij * utl(l,kk+1)
|
||||
! single => sij = 0
|
||||
enddo
|
||||
enddo
|
||||
enddo
|
||||
|
||||
! Compute Hij for all beta doubles
|
||||
! ----------------------------------
|
||||
|
||||
!DIR$ LOOP COUNT avg(50000)
|
||||
do i=1,n_doubles,block_size
|
||||
do kk=0,block_size-1
|
||||
if (i+kk > n_doubles) exit
|
||||
l_b = doubles(i+kk)
|
||||
ASSERT (l_b <= N_det)
|
||||
l_a = psi_bilinear_matrix_transp_order(l_b)
|
||||
ASSERT (l_a <= N_det)
|
||||
|
||||
do l=1,N_st
|
||||
utl(l,kk+1) = u_t(l,l_a)
|
||||
enddo
|
||||
enddo
|
||||
|
||||
do kk=0,block_size-1
|
||||
if (i+kk > n_doubles) exit
|
||||
l_b = doubles(i+kk)
|
||||
l_a = psi_bilinear_matrix_transp_order(l_b)
|
||||
lcol = psi_bilinear_matrix_transp_columns(l_b)
|
||||
ASSERT (lcol <= N_det_beta_unique)
|
||||
|
||||
!todo: check arg order conjg/noconjg (should be okay)
|
||||
call i_h_j_double_spin_complex( tmp_det(1,2), psi_det_beta_unique(1, lcol), $N_int, hij)
|
||||
|
||||
!DIR$ LOOP COUNT AVG(4)
|
||||
do l=1,N_st
|
||||
!todo: check arg order conjg/noconjg (should be okay)
|
||||
v_t(l,k_a) = v_t(l,k_a) + hij * utl(l,kk+1)
|
||||
! same spin => sij = 0
|
||||
enddo
|
||||
enddo
|
||||
enddo
|
||||
|
||||
|
||||
! Diagonal contribution
|
||||
! =====================
|
||||
|
||||
|
||||
! Initial determinant is at k_a in alpha-major representation
|
||||
! -----------------------------------------------------------------------
|
||||
|
||||
krow = psi_bilinear_matrix_rows(k_a)
|
||||
ASSERT (krow <= N_det_alpha_unique)
|
||||
|
||||
kcol = psi_bilinear_matrix_columns(k_a)
|
||||
ASSERT (kcol <= N_det_beta_unique)
|
||||
|
||||
tmp_det(1:$N_int,1) = psi_det_alpha_unique(1:$N_int, krow)
|
||||
tmp_det(1:$N_int,2) = psi_det_beta_unique (1:$N_int, kcol)
|
||||
|
||||
double precision, external :: diag_H_mat_elem, diag_S_mat_elem
|
||||
|
||||
hij = dcmplx(diag_H_mat_elem(tmp_det,$N_int),0.d0)
|
||||
sij = dcmplx(diag_S_mat_elem(tmp_det,$N_int),0.d0)
|
||||
!DIR$ LOOP COUNT AVG(4)
|
||||
do l=1,N_st
|
||||
v_t(l,k_a) = v_t(l,k_a) + hij * u_t(l,k_a)
|
||||
s_t(l,k_a) = s_t(l,k_a) + sij * u_t(l,k_a)
|
||||
enddo
|
||||
|
||||
end do
|
||||
!$OMP END DO
|
||||
deallocate(buffer, singles_a, singles_b, doubles, idx, utl)
|
||||
!$OMP END PARALLEL
|
||||
|
||||
end
|
||||
|
||||
SUBST [ N_int ]
|
||||
|
||||
1;;
|
||||
2;;
|
||||
3;;
|
||||
4;;
|
||||
N_int;;
|
||||
|
||||
END_TEMPLATE
|
||||
|
||||
|
||||
|
@ -84,6 +84,12 @@ doc: Coefficients of the wave function
|
||||
type: double precision
|
||||
size: (determinants.n_det,determinants.n_states)
|
||||
|
||||
[psi_coef_complex]
|
||||
interface: ezfio
|
||||
doc: Coefficients of the wave function
|
||||
type: double precision
|
||||
size: (2,determinants.n_det,determinants.n_states)
|
||||
|
||||
[psi_det]
|
||||
interface: ezfio
|
||||
doc: Determinants of the variational space
|
||||
@ -96,6 +102,12 @@ doc: Coefficients of the wave function
|
||||
type: double precision
|
||||
size: (determinants.n_det_qp_edit,determinants.n_states)
|
||||
|
||||
[psi_coef_complex_qp_edit]
|
||||
interface: ezfio
|
||||
doc: Coefficients of the wave function
|
||||
type: double precision
|
||||
size: (2,determinants.n_det_qp_edit,determinants.n_states)
|
||||
|
||||
[psi_det_qp_edit]
|
||||
interface: ezfio
|
||||
doc: Determinants of the variational space
|
||||
|
@ -80,6 +80,33 @@ subroutine build_singly_excited_wavefunction(i_hole,i_particle,ispin,det_out,coe
|
||||
enddo
|
||||
end
|
||||
|
||||
subroutine build_singly_excited_wavefunction_complex(i_hole,i_particle,ispin,det_out,coef_out)
|
||||
implicit none
|
||||
BEGIN_DOC
|
||||
! Applies the single excitation operator : a^{dager}_(i_particle) a_(i_hole) of
|
||||
! spin = ispin to the current wave function (psi_det, psi_coef)
|
||||
END_DOC
|
||||
integer, intent(in) :: i_hole,i_particle,ispin
|
||||
integer(bit_kind), intent(out) :: det_out(N_int,2,N_det)
|
||||
complex*16, intent(out) :: coef_out(N_det,N_states)
|
||||
|
||||
integer :: k
|
||||
integer :: i_ok
|
||||
double precision :: phase
|
||||
do k=1,N_det
|
||||
coef_out(k,:) = psi_coef(k,:)
|
||||
det_out(:,:,k) = psi_det(:,:,k)
|
||||
call do_single_excitation(det_out(1,1,k),i_hole,i_particle,ispin,i_ok)
|
||||
if (i_ok == 1) then
|
||||
call get_phase(psi_det(1,1,k), det_out(1,1,k),phase,N_int)
|
||||
coef_out(k,:) = phase * coef_out(k,:)
|
||||
else
|
||||
coef_out(k,:) = (0.d0,0.d0)
|
||||
det_out(:,:,k) = psi_det(:,:,k)
|
||||
endif
|
||||
enddo
|
||||
end
|
||||
|
||||
logical function is_spin_flip_possible(key_in,i_flip,ispin)
|
||||
implicit none
|
||||
BEGIN_DOC
|
||||
|
@ -258,6 +258,20 @@ subroutine set_natural_mos
|
||||
|
||||
label = "Natural"
|
||||
integer :: i,j,iorb,jorb
|
||||
if (is_complex) then
|
||||
do i = 1, n_virt_orb
|
||||
iorb = list_virt(i)
|
||||
do j = 1, n_core_inact_act_orb
|
||||
jorb = list_core_inact_act(j)
|
||||
if(cdabs(one_e_dm_mo_complex(iorb,jorb)).ne. 0.d0)then
|
||||
print*,'AHAHAH'
|
||||
print*,iorb,jorb,one_e_dm_mo_complex(iorb,jorb)
|
||||
stop
|
||||
endif
|
||||
enddo
|
||||
enddo
|
||||
call mo_as_svd_vectors_of_mo_matrix_eig_complex(one_e_dm_mo_complex,size(one_e_dm_mo_complex,1),mo_num,mo_num,mo_occ,label)
|
||||
else
|
||||
do i = 1, n_virt_orb
|
||||
iorb = list_virt(i)
|
||||
do j = 1, n_core_inact_act_orb
|
||||
@ -270,6 +284,7 @@ subroutine set_natural_mos
|
||||
enddo
|
||||
enddo
|
||||
call mo_as_svd_vectors_of_mo_matrix_eig(one_e_dm_mo,size(one_e_dm_mo,1),mo_num,mo_num,mo_occ,label)
|
||||
endif
|
||||
soft_touch mo_occ
|
||||
|
||||
end
|
||||
@ -292,11 +307,19 @@ BEGIN_PROVIDER [ double precision, c0_weight, (N_states) ]
|
||||
if (N_states > 1) then
|
||||
integer :: i
|
||||
double precision :: c
|
||||
if (is_complex) then
|
||||
do i=1,N_states
|
||||
c0_weight(i) = 1.d-31
|
||||
c = maxval(cdabs(psi_coef_complex(:,i) * psi_coef_complex(:,i)))
|
||||
c0_weight(i) = 1.d0/(c+1.d-20)
|
||||
enddo
|
||||
else
|
||||
do i=1,N_states
|
||||
c0_weight(i) = 1.d-31
|
||||
c = maxval(psi_coef(:,i) * psi_coef(:,i))
|
||||
c0_weight(i) = 1.d0/(c+1.d-20)
|
||||
enddo
|
||||
endif
|
||||
c = 1.d0/minval(c0_weight(:))
|
||||
do i=1,N_states
|
||||
c0_weight(i) = c0_weight(i) * c
|
||||
@ -398,8 +421,23 @@ subroutine get_occupation_from_dets(istate,occupation)
|
||||
ASSERT (istate <= N_states)
|
||||
|
||||
occupation = 0.d0
|
||||
double precision, external :: u_dot_u
|
||||
|
||||
if (is_complex) then
|
||||
double precision, external :: u_dot_u_complex
|
||||
norm_2 = 1.d0/u_dot_u_complex(psi_coef_complex(1,istate),N_det)
|
||||
|
||||
do i=1,N_det
|
||||
c = cdabs(psi_coef_complex(i,istate)*psi_coef_complex(i,istate))*norm_2
|
||||
call bitstring_to_list_ab(psi_det(1,1,i), list, n_elements, N_int)
|
||||
do ispin=1,2
|
||||
do j=1,n_elements(ispin)
|
||||
ASSERT ( list(j,ispin) < mo_num )
|
||||
occupation( list(j,ispin) ) += c
|
||||
enddo
|
||||
enddo
|
||||
enddo
|
||||
else
|
||||
double precision, external :: u_dot_u
|
||||
norm_2 = 1.d0/u_dot_u(psi_coef(1,istate),N_det)
|
||||
|
||||
do i=1,N_det
|
||||
@ -412,5 +450,6 @@ subroutine get_occupation_from_dets(istate,occupation)
|
||||
enddo
|
||||
enddo
|
||||
enddo
|
||||
endif
|
||||
end
|
||||
|
||||
|
694
src/determinants/density_matrix_cplx.irp.f
Normal file
694
src/determinants/density_matrix_cplx.irp.f
Normal file
@ -0,0 +1,694 @@
|
||||
BEGIN_PROVIDER [ complex*16, one_e_dm_mo_alpha_average_complex, (mo_num,mo_num) ]
|
||||
&BEGIN_PROVIDER [ complex*16, one_e_dm_mo_beta_average_complex, (mo_num,mo_num) ]
|
||||
implicit none
|
||||
BEGIN_DOC
|
||||
! $\alpha$ and $\beta$ one-body density matrix for each state
|
||||
END_DOC
|
||||
integer :: i
|
||||
one_e_dm_mo_alpha_average_complex = (0.d0,0.d0)
|
||||
one_e_dm_mo_beta_average_complex = (0.d0,0.d0)
|
||||
do i = 1,N_states
|
||||
one_e_dm_mo_alpha_average_complex(:,:) += one_e_dm_mo_alpha_complex(:,:,i) * state_average_weight(i)
|
||||
one_e_dm_mo_beta_average_complex(:,:) += one_e_dm_mo_beta_complex(:,:,i) * state_average_weight(i)
|
||||
enddo
|
||||
END_PROVIDER
|
||||
|
||||
BEGIN_PROVIDER [ complex*16, one_e_dm_mo_diff_complex, (mo_num,mo_num,2:N_states) ]
|
||||
implicit none
|
||||
BEGIN_DOC
|
||||
! Difference of the one-body density matrix with respect to the ground state
|
||||
END_DOC
|
||||
integer :: i,j, istate
|
||||
|
||||
do istate=2,N_states
|
||||
do j=1,mo_num
|
||||
do i=1,mo_num
|
||||
one_e_dm_mo_diff_complex(i,j,istate) = &
|
||||
one_e_dm_mo_alpha_complex(i,j,istate) - one_e_dm_mo_alpha_complex(i,j,1) +&
|
||||
one_e_dm_mo_beta_complex (i,j,istate) - one_e_dm_mo_beta_complex (i,j,1)
|
||||
enddo
|
||||
enddo
|
||||
enddo
|
||||
|
||||
END_PROVIDER
|
||||
|
||||
|
||||
BEGIN_PROVIDER [ complex*16, one_e_dm_mo_spin_index_complex, (mo_num,mo_num,N_states,2) ]
|
||||
implicit none
|
||||
integer :: i,j,ispin,istate
|
||||
ispin = 1
|
||||
do istate = 1, N_states
|
||||
do j = 1, mo_num
|
||||
do i = 1, mo_num
|
||||
one_e_dm_mo_spin_index_complex(i,j,istate,ispin) = one_e_dm_mo_alpha_complex(i,j,istate)
|
||||
enddo
|
||||
enddo
|
||||
enddo
|
||||
|
||||
ispin = 2
|
||||
do istate = 1, N_states
|
||||
do j = 1, mo_num
|
||||
do i = 1, mo_num
|
||||
one_e_dm_mo_spin_index_complex(i,j,istate,ispin) = one_e_dm_mo_beta_complex(i,j,istate)
|
||||
enddo
|
||||
enddo
|
||||
enddo
|
||||
|
||||
END_PROVIDER
|
||||
|
||||
|
||||
BEGIN_PROVIDER [ complex*16, one_e_dm_dagger_mo_spin_index_complex, (mo_num,mo_num,N_states,2) ]
|
||||
print*,irp_here,' not implemented for complex'
|
||||
stop -1
|
||||
! implicit none
|
||||
! integer :: i,j,ispin,istate
|
||||
! ispin = 1
|
||||
! do istate = 1, N_states
|
||||
! do j = 1, mo_num
|
||||
! one_e_dm_dagger_mo_spin_index(j,j,istate,ispin) = 1 - one_e_dm_mo_alpha(j,j,istate)
|
||||
! do i = j+1, mo_num
|
||||
! one_e_dm_dagger_mo_spin_index(i,j,istate,ispin) = -one_e_dm_mo_alpha(i,j,istate)
|
||||
! one_e_dm_dagger_mo_spin_index(j,i,istate,ispin) = -one_e_dm_mo_alpha(i,j,istate)
|
||||
! enddo
|
||||
! enddo
|
||||
! enddo
|
||||
!
|
||||
! ispin = 2
|
||||
! do istate = 1, N_states
|
||||
! do j = 1, mo_num
|
||||
! one_e_dm_dagger_mo_spin_index(j,j,istate,ispin) = 1 - one_e_dm_mo_beta(j,j,istate)
|
||||
! do i = j+1, mo_num
|
||||
! one_e_dm_dagger_mo_spin_index(i,j,istate,ispin) = -one_e_dm_mo_beta(i,j,istate)
|
||||
! one_e_dm_dagger_mo_spin_index(j,i,istate,ispin) = -one_e_dm_mo_beta(i,j,istate)
|
||||
! enddo
|
||||
! enddo
|
||||
! enddo
|
||||
!
|
||||
END_PROVIDER
|
||||
|
||||
BEGIN_PROVIDER [ complex*16, one_e_dm_mo_alpha_complex, (mo_num,mo_num,N_states) ]
|
||||
&BEGIN_PROVIDER [ complex*16, one_e_dm_mo_beta_complex, (mo_num,mo_num,N_states) ]
|
||||
implicit none
|
||||
BEGIN_DOC
|
||||
! $\alpha$ and $\beta$ one-body density matrix for each state
|
||||
! $\gamma_{\mu\nu} = \langle\Psi|a_{\nu}^{\dagger}a_{\mu}|\Psi\rangle$
|
||||
! $\gamma_{\mu\nu} = \langle a_{\nu} \Psi|a_{\mu} \Psi\rangle$
|
||||
! $\gamma_{\mu\nu} = \sum_{IJ} c^*_J c_I \langle a_{\nu} I|a_{\mu} J\rangle$
|
||||
END_DOC
|
||||
|
||||
integer :: j,k,l,m,k_a,k_b
|
||||
integer :: occ(N_int*bit_kind_size,2)
|
||||
complex*16 :: ck, cl, ckl
|
||||
double precision :: phase
|
||||
integer :: h1,h2,p1,p2,s1,s2, degree
|
||||
integer(bit_kind) :: tmp_det(N_int,2), tmp_det2(N_int)
|
||||
integer :: exc(0:2,2),n_occ(2)
|
||||
complex*16, allocatable :: tmp_a(:,:,:), tmp_b(:,:,:)
|
||||
integer :: krow, kcol, lrow, lcol
|
||||
|
||||
PROVIDE psi_det psi_coef_complex
|
||||
|
||||
one_e_dm_mo_alpha_complex = (0.d0,0.d0)
|
||||
one_e_dm_mo_beta_complex = (0.d0,0.d0)
|
||||
!$OMP PARALLEL DEFAULT(NONE) &
|
||||
!$OMP PRIVATE(j,k,k_a,k_b,l,m,occ,ck, cl, ckl,phase,h1,h2,p1,p2,s1,s2, degree,exc,&
|
||||
!$OMP tmp_a, tmp_b, n_occ, krow, kcol, lrow, lcol, tmp_det, tmp_det2)&
|
||||
!$OMP SHARED(psi_det,psi_coef_complex,N_int,N_states,elec_alpha_num, &
|
||||
!$OMP elec_beta_num,one_e_dm_mo_alpha_complex,one_e_dm_mo_beta_complex,N_det,&
|
||||
!$OMP mo_num,psi_bilinear_matrix_rows,psi_bilinear_matrix_columns,&
|
||||
!$OMP psi_bilinear_matrix_transp_rows, psi_bilinear_matrix_transp_columns,&
|
||||
!$OMP psi_bilinear_matrix_order_reverse, psi_det_alpha_unique, psi_det_beta_unique,&
|
||||
!$OMP psi_bilinear_matrix_values_complex, psi_bilinear_matrix_transp_values_complex,&
|
||||
!$OMP N_det_alpha_unique,N_det_beta_unique,irp_here)
|
||||
allocate(tmp_a(mo_num,mo_num,N_states), tmp_b(mo_num,mo_num,N_states) )
|
||||
tmp_a = (0.d0,0.d0)
|
||||
!$OMP DO SCHEDULE(dynamic,64)
|
||||
do k_a=1,N_det
|
||||
krow = psi_bilinear_matrix_rows(k_a)
|
||||
ASSERT (krow <= N_det_alpha_unique)
|
||||
|
||||
kcol = psi_bilinear_matrix_columns(k_a)
|
||||
ASSERT (kcol <= N_det_beta_unique)
|
||||
|
||||
tmp_det(1:N_int,1) = psi_det_alpha_unique(1:N_int,krow)
|
||||
tmp_det(1:N_int,2) = psi_det_beta_unique (1:N_int,kcol)
|
||||
|
||||
! Diagonal part
|
||||
! -------------
|
||||
|
||||
call bitstring_to_list_ab(tmp_det, occ, n_occ, N_int)
|
||||
do m=1,N_states
|
||||
ck = cdabs(psi_bilinear_matrix_values_complex(k_a,m)*psi_bilinear_matrix_values_complex(k_a,m))
|
||||
do l=1,elec_alpha_num
|
||||
j = occ(l,1)
|
||||
tmp_a(j,j,m) += ck
|
||||
enddo
|
||||
enddo
|
||||
|
||||
if (k_a == N_det) cycle
|
||||
l = k_a+1
|
||||
lrow = psi_bilinear_matrix_rows(l)
|
||||
lcol = psi_bilinear_matrix_columns(l)
|
||||
! Fix beta determinant, loop over alphas
|
||||
do while ( lcol == kcol )
|
||||
tmp_det2(:) = psi_det_alpha_unique(:, lrow)
|
||||
call get_excitation_degree_spin(tmp_det(1,1),tmp_det2,degree,N_int)
|
||||
if (degree == 1) then
|
||||
exc = 0
|
||||
call get_single_excitation_spin(tmp_det(1,1),tmp_det2,exc,phase,N_int)
|
||||
call decode_exc_spin(exc,h1,p1,h2,p2)
|
||||
! h1 occ in k
|
||||
! p1 occ in l
|
||||
do m=1,N_states
|
||||
ckl = dconjg(psi_bilinear_matrix_values_complex(k_a,m))*psi_bilinear_matrix_values_complex(l,m) * phase
|
||||
tmp_a(h1,p1,m) += dconjg(ckl)
|
||||
tmp_a(p1,h1,m) += ckl
|
||||
enddo
|
||||
endif
|
||||
l = l+1
|
||||
if (l>N_det) exit
|
||||
lrow = psi_bilinear_matrix_rows(l)
|
||||
lcol = psi_bilinear_matrix_columns(l)
|
||||
enddo
|
||||
|
||||
enddo
|
||||
!$OMP END DO NOWAIT
|
||||
|
||||
!$OMP CRITICAL
|
||||
one_e_dm_mo_alpha_complex(:,:,:) = one_e_dm_mo_alpha_complex(:,:,:) + tmp_a(:,:,:)
|
||||
!$OMP END CRITICAL
|
||||
deallocate(tmp_a)
|
||||
|
||||
tmp_b = (0.d0,0.d0)
|
||||
!$OMP DO SCHEDULE(dynamic,64)
|
||||
do k_b=1,N_det
|
||||
krow = psi_bilinear_matrix_transp_rows(k_b)
|
||||
ASSERT (krow <= N_det_alpha_unique)
|
||||
|
||||
kcol = psi_bilinear_matrix_transp_columns(k_b)
|
||||
ASSERT (kcol <= N_det_beta_unique)
|
||||
|
||||
tmp_det(1:N_int,1) = psi_det_alpha_unique(1:N_int,krow)
|
||||
tmp_det(1:N_int,2) = psi_det_beta_unique (1:N_int,kcol)
|
||||
|
||||
! Diagonal part
|
||||
! -------------
|
||||
|
||||
call bitstring_to_list_ab(tmp_det, occ, n_occ, N_int)
|
||||
do m=1,N_states
|
||||
ck = cdabs(psi_bilinear_matrix_transp_values_complex(k_b,m)*psi_bilinear_matrix_transp_values_complex(k_b,m))
|
||||
do l=1,elec_beta_num
|
||||
j = occ(l,2)
|
||||
tmp_b(j,j,m) += ck
|
||||
enddo
|
||||
enddo
|
||||
|
||||
if (k_b == N_det) cycle
|
||||
l = k_b+1
|
||||
lrow = psi_bilinear_matrix_transp_rows(l)
|
||||
lcol = psi_bilinear_matrix_transp_columns(l)
|
||||
! Fix beta determinant, loop over alphas
|
||||
do while ( lrow == krow )
|
||||
tmp_det2(:) = psi_det_beta_unique(:, lcol)
|
||||
call get_excitation_degree_spin(tmp_det(1,2),tmp_det2,degree,N_int)
|
||||
if (degree == 1) then
|
||||
exc = 0
|
||||
call get_single_excitation_spin(tmp_det(1,2),tmp_det2,exc,phase,N_int)
|
||||
call decode_exc_spin(exc,h1,p1,h2,p2)
|
||||
do m=1,N_states
|
||||
ckl = dconjg(psi_bilinear_matrix_transp_values_complex(k_b,m))*psi_bilinear_matrix_transp_values_complex(l,m) * phase
|
||||
tmp_b(h1,p1,m) += dconjg(ckl)
|
||||
tmp_b(p1,h1,m) += ckl
|
||||
enddo
|
||||
endif
|
||||
l = l+1
|
||||
if (l>N_det) exit
|
||||
lrow = psi_bilinear_matrix_transp_rows(l)
|
||||
lcol = psi_bilinear_matrix_transp_columns(l)
|
||||
enddo
|
||||
|
||||
enddo
|
||||
!$OMP END DO NOWAIT
|
||||
!$OMP CRITICAL
|
||||
one_e_dm_mo_beta_complex(:,:,:) = one_e_dm_mo_beta_complex(:,:,:) + tmp_b(:,:,:)
|
||||
!$OMP END CRITICAL
|
||||
|
||||
deallocate(tmp_b)
|
||||
!$OMP END PARALLEL
|
||||
|
||||
END_PROVIDER
|
||||
|
||||
BEGIN_PROVIDER [ complex*16, one_e_dm_mo_complex, (mo_num,mo_num) ]
|
||||
implicit none
|
||||
BEGIN_DOC
|
||||
! One-body density matrix
|
||||
END_DOC
|
||||
one_e_dm_mo_complex = one_e_dm_mo_alpha_average_complex + one_e_dm_mo_beta_average_complex
|
||||
END_PROVIDER
|
||||
|
||||
BEGIN_PROVIDER [ complex*16, one_e_spin_density_mo_complex, (mo_num,mo_num) ]
|
||||
implicit none
|
||||
BEGIN_DOC
|
||||
! $\rho(\alpha) - \rho(\beta)$
|
||||
END_DOC
|
||||
one_e_spin_density_mo_complex = one_e_dm_mo_alpha_average_complex - one_e_dm_mo_beta_average_complex
|
||||
END_PROVIDER
|
||||
|
||||
|
||||
BEGIN_PROVIDER [ complex*16, one_e_spin_density_ao_complex, (ao_num,ao_num) ]
|
||||
BEGIN_DOC
|
||||
! One body spin density matrix on the |AO| basis : $\rho_{AO}(\alpha) - \rho_{AO}(\beta)$
|
||||
! todo: verify that this is correct for complex
|
||||
! equivalent to using mo_to_ao_no_overlap?
|
||||
END_DOC
|
||||
implicit none
|
||||
integer :: i,j,k,l
|
||||
complex*16 :: dm_mo
|
||||
|
||||
one_e_spin_density_ao_complex = (0.d0,0.d0)
|
||||
do k = 1, ao_num
|
||||
do l = 1, ao_num
|
||||
do i = 1, mo_num
|
||||
do j = 1, mo_num
|
||||
dm_mo = one_e_spin_density_mo_complex(j,i)
|
||||
! if(dabs(dm_mo).le.1.d-10)cycle
|
||||
one_e_spin_density_ao_complex(l,k) += dconjg(mo_coef_complex(k,i)) * mo_coef_complex(l,j) * dm_mo
|
||||
|
||||
enddo
|
||||
enddo
|
||||
enddo
|
||||
enddo
|
||||
|
||||
END_PROVIDER
|
||||
|
||||
BEGIN_PROVIDER [ complex*16, one_e_dm_ao_alpha_complex, (ao_num,ao_num) ]
|
||||
&BEGIN_PROVIDER [ complex*16, one_e_dm_ao_beta_complex, (ao_num,ao_num) ]
|
||||
BEGIN_DOC
|
||||
! One body density matrix on the |AO| basis : $\rho_{AO}(\alpha), \rho_{AO}(\beta)$.
|
||||
END_DOC
|
||||
implicit none
|
||||
integer :: i,j,k,l
|
||||
complex*16 :: mo_alpha,mo_beta
|
||||
|
||||
one_e_dm_ao_alpha_complex = (0.d0,0.d0)
|
||||
one_e_dm_ao_beta_complex = (0.d0,0.d0)
|
||||
do k = 1, ao_num
|
||||
do l = 1, ao_num
|
||||
do i = 1, mo_num
|
||||
do j = 1, mo_num
|
||||
mo_alpha = one_e_dm_mo_alpha_average_complex(j,i)
|
||||
mo_beta = one_e_dm_mo_beta_average_complex(j,i)
|
||||
! if(dabs(dm_mo).le.1.d-10)cycle
|
||||
one_e_dm_ao_alpha_complex(l,k) += dconjg(mo_coef_complex(k,i)) * mo_coef_complex(l,j) * mo_alpha
|
||||
one_e_dm_ao_beta_complex(l,k) += dconjg(mo_coef_complex(k,i)) * mo_coef_complex(l,j) * mo_beta
|
||||
enddo
|
||||
enddo
|
||||
enddo
|
||||
enddo
|
||||
|
||||
END_PROVIDER
|
||||
|
||||
|
||||
!============================================!
|
||||
! !
|
||||
! kpts !
|
||||
! !
|
||||
!============================================!
|
||||
|
||||
BEGIN_PROVIDER [ complex*16, one_e_dm_mo_alpha_average_kpts, (mo_num_per_kpt,mo_num_per_kpt,kpt_num) ]
|
||||
&BEGIN_PROVIDER [ complex*16, one_e_dm_mo_beta_average_kpts, (mo_num_per_kpt,mo_num_per_kpt,kpt_num) ]
|
||||
implicit none
|
||||
BEGIN_DOC
|
||||
! $\alpha$ and $\beta$ one-body density matrix for each state
|
||||
END_DOC
|
||||
integer :: i,k
|
||||
one_e_dm_mo_alpha_average_kpts = (0.d0,0.d0)
|
||||
one_e_dm_mo_beta_average_kpts = (0.d0,0.d0)
|
||||
do i = 1,N_states
|
||||
do k=1,kpt_num
|
||||
one_e_dm_mo_alpha_average_kpts(:,:,k) += one_e_dm_mo_alpha_kpts(:,:,k,i) * state_average_weight(i)
|
||||
one_e_dm_mo_beta_average_kpts(:,:,k) += one_e_dm_mo_beta_kpts(:,:,k,i) * state_average_weight(i)
|
||||
enddo
|
||||
enddo
|
||||
END_PROVIDER
|
||||
|
||||
BEGIN_PROVIDER [ complex*16, one_e_dm_mo_diff_kpts, (mo_num_per_kpt,mo_num_per_kpt,kpt_num,2:N_states) ]
|
||||
implicit none
|
||||
BEGIN_DOC
|
||||
! Difference of the one-body density matrix with respect to the ground state
|
||||
END_DOC
|
||||
integer :: i,j, istate,k
|
||||
|
||||
do istate=2,N_states
|
||||
do k=1,kpt_num
|
||||
do j=1,mo_num_per_kpt
|
||||
do i=1,mo_num_per_kpt
|
||||
one_e_dm_mo_diff_kpts(i,j,k,istate) = &
|
||||
one_e_dm_mo_alpha_kpts(i,j,k,istate) - one_e_dm_mo_alpha_kpts(i,j,k,1) +&
|
||||
one_e_dm_mo_beta_kpts (i,j,k,istate) - one_e_dm_mo_beta_kpts (i,j,k,1)
|
||||
enddo
|
||||
enddo
|
||||
enddo
|
||||
enddo
|
||||
|
||||
END_PROVIDER
|
||||
|
||||
|
||||
BEGIN_PROVIDER [ complex*16, one_e_dm_mo_spin_index_kpts, (mo_num_per_kpt,mo_num_per_kpt,kpt_num,N_states,2) ]
|
||||
implicit none
|
||||
integer :: i,j,k,ispin,istate
|
||||
ispin = 1
|
||||
do istate = 1, N_states
|
||||
do k=1,kpt_num
|
||||
do j = 1, mo_num_per_kpt
|
||||
do i = 1, mo_num_per_kpt
|
||||
one_e_dm_mo_spin_index_kpts(i,j,k,istate,ispin) = one_e_dm_mo_alpha_kpts(i,j,k,istate)
|
||||
enddo
|
||||
enddo
|
||||
enddo
|
||||
enddo
|
||||
|
||||
ispin = 2
|
||||
do istate = 1, N_states
|
||||
do k=1,kpt_num
|
||||
do j = 1, mo_num_per_kpt
|
||||
do i = 1, mo_num_per_kpt
|
||||
one_e_dm_mo_spin_index_kpts(i,j,k,istate,ispin) = one_e_dm_mo_beta_kpts(i,j,k,istate)
|
||||
enddo
|
||||
enddo
|
||||
enddo
|
||||
enddo
|
||||
|
||||
END_PROVIDER
|
||||
|
||||
|
||||
BEGIN_PROVIDER [ complex*16, one_e_dm_dagger_mo_spin_index_kpts, (mo_num_per_kpt,mo_num_per_kpt,kpt_num,N_states,2) ]
|
||||
print*,irp_here,' not implemented for kpts'
|
||||
stop -1
|
||||
! implicit none
|
||||
! integer :: i,j,ispin,istate
|
||||
! ispin = 1
|
||||
! do istate = 1, N_states
|
||||
! do j = 1, mo_num
|
||||
! one_e_dm_dagger_mo_spin_index(j,j,istate,ispin) = 1 - one_e_dm_mo_alpha(j,j,istate)
|
||||
! do i = j+1, mo_num
|
||||
! one_e_dm_dagger_mo_spin_index(i,j,istate,ispin) = -one_e_dm_mo_alpha(i,j,istate)
|
||||
! one_e_dm_dagger_mo_spin_index(j,i,istate,ispin) = -one_e_dm_mo_alpha(i,j,istate)
|
||||
! enddo
|
||||
! enddo
|
||||
! enddo
|
||||
!
|
||||
! ispin = 2
|
||||
! do istate = 1, N_states
|
||||
! do j = 1, mo_num
|
||||
! one_e_dm_dagger_mo_spin_index(j,j,istate,ispin) = 1 - one_e_dm_mo_beta(j,j,istate)
|
||||
! do i = j+1, mo_num
|
||||
! one_e_dm_dagger_mo_spin_index(i,j,istate,ispin) = -one_e_dm_mo_beta(i,j,istate)
|
||||
! one_e_dm_dagger_mo_spin_index(j,i,istate,ispin) = -one_e_dm_mo_beta(i,j,istate)
|
||||
! enddo
|
||||
! enddo
|
||||
! enddo
|
||||
!
|
||||
END_PROVIDER
|
||||
|
||||
BEGIN_PROVIDER [ complex*16, one_e_dm_mo_alpha_kpts, (mo_num_per_kpt,mo_num_per_kpt,kpt_num,N_states) ]
|
||||
&BEGIN_PROVIDER [ complex*16, one_e_dm_mo_beta_kpts, (mo_num_per_kpt,mo_num_per_kpt,kpt_num,N_states) ]
|
||||
implicit none
|
||||
BEGIN_DOC
|
||||
! $\alpha$ and $\beta$ one-body density matrix for each state
|
||||
! $\gamma_{\mu\nu} = \langle\Psi|a_{\nu}^{\dagger}a_{\mu}|\Psi\rangle$
|
||||
! $\gamma_{\mu\nu} = \langle a_{\nu} \Psi|a_{\mu} \Psi\rangle$
|
||||
! $\gamma_{\mu\nu} = \sum_{IJ} c^*_J c_I \langle a_{\nu} I|a_{\mu} J\rangle$
|
||||
END_DOC
|
||||
!todo: implement for kpts
|
||||
integer :: j,k,l,m,k_a,k_b
|
||||
integer :: occ(N_int*bit_kind_size,2)
|
||||
complex*16 :: ck, cl, ckl
|
||||
double precision :: phase
|
||||
integer :: h1,h2,p1,p2,s1,s2, degree
|
||||
integer :: ih1,ip1,kh1,kp1,kk,k_shft,ii
|
||||
integer(bit_kind) :: tmp_det(N_int,2), tmp_det2(N_int)
|
||||
integer(bit_kind) :: tmp_det_kpts(N_int,2)
|
||||
integer :: exc(0:2,2),n_occ(2)
|
||||
complex*16, allocatable :: tmp_a(:,:,:,:), tmp_b(:,:,:,:)
|
||||
integer :: krow, kcol, lrow, lcol
|
||||
|
||||
PROVIDE psi_det psi_coef_complex
|
||||
|
||||
one_e_dm_mo_alpha_kpts = (0.d0,0.d0)
|
||||
one_e_dm_mo_beta_kpts = (0.d0,0.d0)
|
||||
!$OMP PARALLEL DEFAULT(NONE) &
|
||||
!$OMP PRIVATE(j,k,k_a,k_b,l,m,occ,ck, cl, ckl,phase,h1,h2,p1,p2,s1,s2, degree,exc,&
|
||||
!$OMP tmp_a, tmp_b, n_occ, krow, kcol, lrow, lcol, tmp_det, tmp_det2,ih1,ip1,kh1,kp1,kk,&
|
||||
!$OMP tmp_det_kpts,k_shft,ii)&
|
||||
!$OMP SHARED(psi_det,psi_coef_complex,N_int,N_states,elec_alpha_num_kpts, &
|
||||
!$OMP elec_beta_num_kpts,one_e_dm_mo_alpha_kpts,one_e_dm_mo_beta_kpts,N_det,&
|
||||
!$OMP mo_num_per_kpt,psi_bilinear_matrix_rows,psi_bilinear_matrix_columns,&
|
||||
!$OMP psi_bilinear_matrix_transp_rows, psi_bilinear_matrix_transp_columns,&
|
||||
!$OMP psi_bilinear_matrix_order_reverse, psi_det_alpha_unique, psi_det_beta_unique,&
|
||||
!$OMP psi_bilinear_matrix_values_complex, psi_bilinear_matrix_transp_values_complex,&
|
||||
!$OMP N_det_alpha_unique,N_det_beta_unique,irp_here,kpt_num,kpts_bitmask)
|
||||
allocate(tmp_a(mo_num_per_kpt,mo_num_per_kpt,kpt_num,N_states), tmp_b(mo_num_per_kpt,mo_num_per_kpt,kpt_num,N_states) )
|
||||
tmp_a = (0.d0,0.d0)
|
||||
!$OMP DO SCHEDULE(dynamic,64)
|
||||
do k_a=1,N_det
|
||||
krow = psi_bilinear_matrix_rows(k_a)
|
||||
ASSERT (krow <= N_det_alpha_unique)
|
||||
|
||||
kcol = psi_bilinear_matrix_columns(k_a)
|
||||
ASSERT (kcol <= N_det_beta_unique)
|
||||
|
||||
tmp_det(1:N_int,1) = psi_det_alpha_unique(1:N_int,krow)
|
||||
tmp_det(1:N_int,2) = psi_det_beta_unique (1:N_int,kcol)
|
||||
|
||||
! Diagonal part
|
||||
! -------------
|
||||
|
||||
do kk=1,kpt_num
|
||||
k_shft = (kk-1)*mo_num_per_kpt
|
||||
do ii=1,N_int
|
||||
tmp_det_kpts(ii,1) = iand(tmp_det(ii,1),kpts_bitmask(ii,kk))
|
||||
tmp_det_kpts(ii,2) = iand(tmp_det(ii,2),kpts_bitmask(ii,kk))
|
||||
enddo
|
||||
call bitstring_to_list_ab(tmp_det_kpts, occ, n_occ, N_int)
|
||||
do m=1,N_states
|
||||
ck = cdabs(psi_bilinear_matrix_values_complex(k_a,m)*psi_bilinear_matrix_values_complex(k_a,m))
|
||||
!do l=1,elec_alpha_num_kpts(kk)
|
||||
do l=1,n_occ(1)
|
||||
j = occ(l,1) - k_shft
|
||||
tmp_a(j,j,kk,m) += ck
|
||||
enddo
|
||||
enddo
|
||||
enddo
|
||||
|
||||
if (k_a == N_det) cycle
|
||||
l = k_a+1
|
||||
lrow = psi_bilinear_matrix_rows(l)
|
||||
lcol = psi_bilinear_matrix_columns(l)
|
||||
! Fix beta determinant, loop over alphas
|
||||
do while ( lcol == kcol )
|
||||
tmp_det2(:) = psi_det_alpha_unique(:, lrow)
|
||||
call get_excitation_degree_spin(tmp_det(1,1),tmp_det2,degree,N_int)
|
||||
if (degree == 1) then
|
||||
exc = 0
|
||||
call get_single_excitation_spin(tmp_det(1,1),tmp_det2,exc,phase,N_int)
|
||||
call decode_exc_spin(exc,h1,p1,h2,p2)
|
||||
! h1 occ in k
|
||||
! p1 occ in l
|
||||
ih1 = mod(h1-1,mo_num_per_kpt)+1
|
||||
ip1 = mod(p1-1,mo_num_per_kpt)+1
|
||||
kh1 = (h1-1)/mo_num_per_kpt + 1
|
||||
kp1 = (p1-1)/mo_num_per_kpt + 1
|
||||
if (kh1.ne.kp1) then
|
||||
print *,'problem in: ',irp_here,'a'
|
||||
print *,' h1 = ',h1
|
||||
print *,' p1 = ',p1
|
||||
print *,'ih1 = ',ih1
|
||||
print *,'ip1 = ',ip1
|
||||
print *,'kh1 = ',kh1
|
||||
print *,'kp1 = ',kp1
|
||||
!call debug_det(tmp_det,N_int)
|
||||
call debug_single_spindet(tmp_det(1,1),N_int)
|
||||
call debug_single_spindet(tmp_det2,N_int)
|
||||
call debug_single_spindet(tmp_det(1,2),N_int)
|
||||
!call print_spindet(tmp_det2,N_int)
|
||||
stop -2
|
||||
endif
|
||||
do m=1,N_states
|
||||
ckl = dconjg(psi_bilinear_matrix_values_complex(k_a,m))*psi_bilinear_matrix_values_complex(l,m) * phase
|
||||
tmp_a(ih1,ip1,kh1,m) += dconjg(ckl)
|
||||
tmp_a(ip1,ih1,kh1,m) += ckl
|
||||
enddo
|
||||
endif
|
||||
l = l+1
|
||||
if (l>N_det) exit
|
||||
lrow = psi_bilinear_matrix_rows(l)
|
||||
lcol = psi_bilinear_matrix_columns(l)
|
||||
enddo
|
||||
|
||||
enddo
|
||||
!$OMP END DO NOWAIT
|
||||
|
||||
!$OMP CRITICAL
|
||||
one_e_dm_mo_alpha_kpts(:,:,:,:) = one_e_dm_mo_alpha_kpts(:,:,:,:) + tmp_a(:,:,:,:)
|
||||
!$OMP END CRITICAL
|
||||
deallocate(tmp_a)
|
||||
|
||||
tmp_b = (0.d0,0.d0)
|
||||
!$OMP DO SCHEDULE(dynamic,64)
|
||||
do k_b=1,N_det
|
||||
krow = psi_bilinear_matrix_transp_rows(k_b)
|
||||
ASSERT (krow <= N_det_alpha_unique)
|
||||
|
||||
kcol = psi_bilinear_matrix_transp_columns(k_b)
|
||||
ASSERT (kcol <= N_det_beta_unique)
|
||||
|
||||
tmp_det(1:N_int,1) = psi_det_alpha_unique(1:N_int,krow)
|
||||
tmp_det(1:N_int,2) = psi_det_beta_unique (1:N_int,kcol)
|
||||
|
||||
! Diagonal part
|
||||
! -------------
|
||||
|
||||
do kk=1,kpt_num
|
||||
k_shft = (kk-1)*mo_num_per_kpt
|
||||
do ii=1,N_int
|
||||
tmp_det_kpts(ii,1) = iand(tmp_det(ii,1),kpts_bitmask(ii,kk))
|
||||
tmp_det_kpts(ii,2) = iand(tmp_det(ii,2),kpts_bitmask(ii,kk))
|
||||
enddo
|
||||
call bitstring_to_list_ab(tmp_det_kpts, occ, n_occ, N_int)
|
||||
do m=1,N_states
|
||||
ck = cdabs(psi_bilinear_matrix_transp_values_complex(k_b,m)*psi_bilinear_matrix_transp_values_complex(k_b,m))
|
||||
do l=1,n_occ(2)
|
||||
j = occ(l,2) - k_shft
|
||||
tmp_b(j,j,kk,m) += ck
|
||||
enddo
|
||||
enddo
|
||||
enddo
|
||||
|
||||
if (k_b == N_det) cycle
|
||||
l = k_b+1
|
||||
lrow = psi_bilinear_matrix_transp_rows(l)
|
||||
lcol = psi_bilinear_matrix_transp_columns(l)
|
||||
! Fix beta determinant, loop over alphas
|
||||
do while ( lrow == krow )
|
||||
tmp_det2(:) = psi_det_beta_unique(:, lcol)
|
||||
call get_excitation_degree_spin(tmp_det(1,2),tmp_det2,degree,N_int)
|
||||
if (degree == 1) then
|
||||
exc = 0
|
||||
call get_single_excitation_spin(tmp_det(1,2),tmp_det2,exc,phase,N_int)
|
||||
call decode_exc_spin(exc,h1,p1,h2,p2)
|
||||
ih1 = mod(h1-1,mo_num_per_kpt)+1
|
||||
ip1 = mod(p1-1,mo_num_per_kpt)+1
|
||||
kh1 = (h1-1)/mo_num_per_kpt + 1
|
||||
kp1 = (p1-1)/mo_num_per_kpt + 1
|
||||
if (kh1.ne.kp1) then
|
||||
print *,'problem in: ',irp_here,'b'
|
||||
print *,' h1 = ',h1
|
||||
print *,' p1 = ',p1
|
||||
print *,'ih1 = ',ih1
|
||||
print *,'ip1 = ',ip1
|
||||
print *,'kh1 = ',kh1
|
||||
print *,'kp1 = ',kp1
|
||||
call debug_single_spindet(tmp_det(1,2),N_int)
|
||||
call debug_single_spindet(tmp_det2,N_int)
|
||||
call debug_single_spindet(tmp_det(1,1),N_int)
|
||||
stop -3
|
||||
endif
|
||||
do m=1,N_states
|
||||
ckl = dconjg(psi_bilinear_matrix_transp_values_complex(k_b,m))*psi_bilinear_matrix_transp_values_complex(l,m) * phase
|
||||
tmp_b(ih1,ip1,kh1,m) += dconjg(ckl)
|
||||
tmp_b(ip1,ih1,kh1,m) += ckl
|
||||
enddo
|
||||
endif
|
||||
l = l+1
|
||||
if (l>N_det) exit
|
||||
lrow = psi_bilinear_matrix_transp_rows(l)
|
||||
lcol = psi_bilinear_matrix_transp_columns(l)
|
||||
enddo
|
||||
|
||||
enddo
|
||||
!$OMP END DO NOWAIT
|
||||
!$OMP CRITICAL
|
||||
one_e_dm_mo_beta_kpts(:,:,:,:) = one_e_dm_mo_beta_kpts(:,:,:,:) + tmp_b(:,:,:,:)
|
||||
!$OMP END CRITICAL
|
||||
|
||||
deallocate(tmp_b)
|
||||
!$OMP END PARALLEL
|
||||
|
||||
END_PROVIDER
|
||||
|
||||
BEGIN_PROVIDER [ complex*16, one_e_dm_mo_kpts, (mo_num_per_kpt,mo_num_per_kpt,kpt_num) ]
|
||||
implicit none
|
||||
BEGIN_DOC
|
||||
! One-body density matrix
|
||||
END_DOC
|
||||
one_e_dm_mo_kpts = one_e_dm_mo_alpha_average_kpts + one_e_dm_mo_beta_average_kpts
|
||||
END_PROVIDER
|
||||
|
||||
BEGIN_PROVIDER [ complex*16, one_e_spin_density_mo_kpts, (mo_num_per_kpt,mo_num_per_kpt,kpt_num) ]
|
||||
implicit none
|
||||
BEGIN_DOC
|
||||
! $\rho(\alpha) - \rho(\beta)$
|
||||
END_DOC
|
||||
one_e_spin_density_mo_kpts = one_e_dm_mo_alpha_average_kpts - one_e_dm_mo_beta_average_kpts
|
||||
END_PROVIDER
|
||||
|
||||
|
||||
BEGIN_PROVIDER [ complex*16, one_e_spin_density_ao_kpts, (ao_num_per_kpt,ao_num_per_kpt,kpt_num) ]
|
||||
BEGIN_DOC
|
||||
! One body spin density matrix on the |AO| basis : $\rho_{AO}(\alpha) - \rho_{AO}(\beta)$
|
||||
! todo: verify that this is correct for complex
|
||||
! equivalent to using mo_to_ao_no_overlap?
|
||||
END_DOC
|
||||
implicit none
|
||||
integer :: i,j,k,l,kk
|
||||
complex*16 :: dm_mo
|
||||
|
||||
one_e_spin_density_ao_kpts = (0.d0,0.d0)
|
||||
do kk=1,kpt_num
|
||||
do k = 1, ao_num_per_kpt
|
||||
do l = 1, ao_num_per_kpt
|
||||
do i = 1, mo_num_per_kpt
|
||||
do j = 1, mo_num_per_kpt
|
||||
dm_mo = one_e_spin_density_mo_kpts(j,i,kk)
|
||||
! if(dabs(dm_mo).le.1.d-10)cycle
|
||||
one_e_spin_density_ao_kpts(l,k,kk) += dconjg(mo_coef_kpts(k,i,kk)) * mo_coef_kpts(l,j,kk) * dm_mo
|
||||
|
||||
enddo
|
||||
enddo
|
||||
enddo
|
||||
enddo
|
||||
enddo
|
||||
|
||||
END_PROVIDER
|
||||
|
||||
BEGIN_PROVIDER [ complex*16, one_e_dm_ao_alpha_kpts, (ao_num_per_kpt,ao_num_per_kpt,kpt_num) ]
|
||||
&BEGIN_PROVIDER [ complex*16, one_e_dm_ao_beta_kpts, (ao_num_per_kpt,ao_num_per_kpt,kpt_num) ]
|
||||
BEGIN_DOC
|
||||
! One body density matrix on the |AO| basis : $\rho_{AO}(\alpha), \rho_{AO}(\beta)$.
|
||||
END_DOC
|
||||
implicit none
|
||||
integer :: i,j,k,l,kk
|
||||
complex*16 :: mo_alpha,mo_beta
|
||||
|
||||
one_e_dm_ao_alpha_kpts = (0.d0,0.d0)
|
||||
one_e_dm_ao_beta_kpts = (0.d0,0.d0)
|
||||
do kk=1,kpt_num
|
||||
do k = 1, ao_num_per_kpt
|
||||
do l = 1, ao_num_per_kpt
|
||||
do i = 1, mo_num_per_kpt
|
||||
do j = 1, mo_num_per_kpt
|
||||
mo_alpha = one_e_dm_mo_alpha_average_kpts(j,i,kk)
|
||||
mo_beta = one_e_dm_mo_beta_average_kpts(j,i,kk)
|
||||
! if(dabs(dm_mo).le.1.d-10)cycle
|
||||
one_e_dm_ao_alpha_kpts(l,k,kk) += dconjg(mo_coef_kpts(k,i,kk)) * mo_coef_kpts(l,j,kk) * mo_alpha
|
||||
one_e_dm_ao_beta_kpts(l,k,kk) += dconjg(mo_coef_kpts(k,i,kk)) * mo_coef_kpts(l,j,kk) * mo_beta
|
||||
enddo
|
||||
enddo
|
||||
enddo
|
||||
enddo
|
||||
enddo
|
||||
|
||||
END_PROVIDER
|
||||
|
||||
|
@ -113,7 +113,12 @@ BEGIN_PROVIDER [ integer(bit_kind), psi_det, (N_int,2,psi_det_size) ]
|
||||
logical :: exists
|
||||
character*(64) :: label
|
||||
|
||||
PROVIDE read_wf N_det mo_label ezfio_filename HF_bitmask mo_coef
|
||||
PROVIDE read_wf N_det mo_label ezfio_filename HF_bitmask
|
||||
if (is_complex) then
|
||||
PROVIDE mo_coef_complex
|
||||
else
|
||||
PROVIDE mo_coef
|
||||
endif
|
||||
psi_det = 0_bit_kind
|
||||
if (mpi_master) then
|
||||
if (read_wf) then
|
||||
@ -244,12 +249,21 @@ BEGIN_PROVIDER [ double precision, psi_average_norm_contrib, (psi_det_size) ]
|
||||
double precision :: f
|
||||
|
||||
psi_average_norm_contrib(:) = 0.d0
|
||||
if (is_complex) then
|
||||
do k=1,N_states
|
||||
do i=1,N_det
|
||||
psi_average_norm_contrib(i) = psi_average_norm_contrib(i) + &
|
||||
cdabs(psi_coef_complex(i,k)*psi_coef_complex(i,k))*state_average_weight(k)
|
||||
enddo
|
||||
enddo
|
||||
else
|
||||
do k=1,N_states
|
||||
do i=1,N_det
|
||||
psi_average_norm_contrib(i) = psi_average_norm_contrib(i) + &
|
||||
psi_coef(i,k)*psi_coef(i,k)*state_average_weight(k)
|
||||
enddo
|
||||
enddo
|
||||
endif
|
||||
f = 1.d0/sum(psi_average_norm_contrib(1:N_det))
|
||||
do i=1,N_det
|
||||
psi_average_norm_contrib(i) = psi_average_norm_contrib(i)*f
|
||||
@ -266,7 +280,6 @@ END_PROVIDER
|
||||
|
||||
|
||||
BEGIN_PROVIDER [ integer(bit_kind), psi_det_sorted, (N_int,2,psi_det_size) ]
|
||||
&BEGIN_PROVIDER [ double precision, psi_coef_sorted, (psi_det_size,N_states) ]
|
||||
&BEGIN_PROVIDER [ double precision, psi_average_norm_contrib_sorted, (psi_det_size) ]
|
||||
&BEGIN_PROVIDER [ integer, psi_det_sorted_order, (psi_det_size) ]
|
||||
implicit none
|
||||
@ -288,9 +301,6 @@ END_PROVIDER
|
||||
psi_det_sorted(j,1,i) = psi_det(j,1,iorder(i))
|
||||
psi_det_sorted(j,2,i) = psi_det(j,2,iorder(i))
|
||||
enddo
|
||||
do k=1,N_states
|
||||
psi_coef_sorted(i,k) = psi_coef(iorder(i),k)
|
||||
enddo
|
||||
psi_average_norm_contrib_sorted(i) = -psi_average_norm_contrib_sorted(i)
|
||||
enddo
|
||||
do i=1,N_det
|
||||
@ -298,29 +308,74 @@ END_PROVIDER
|
||||
enddo
|
||||
|
||||
psi_det_sorted(:,:,N_det+1:psi_det_size) = 0_bit_kind
|
||||
psi_coef_sorted(N_det+1:psi_det_size,:) = 0.d0
|
||||
psi_average_norm_contrib_sorted(N_det+1:psi_det_size) = 0.d0
|
||||
psi_det_sorted_order(N_det+1:psi_det_size) = 0
|
||||
|
||||
deallocate(iorder)
|
||||
|
||||
END_PROVIDER
|
||||
BEGIN_PROVIDER [ double precision, psi_coef_sorted, (psi_det_size,N_states) ]
|
||||
implicit none
|
||||
integer :: i,j,k
|
||||
do i=1,N_det
|
||||
j=psi_det_sorted_order(i)
|
||||
do k=1,N_states
|
||||
psi_coef_sorted(j,k) = psi_coef(i,k)
|
||||
enddo
|
||||
enddo
|
||||
psi_coef_sorted(N_det+1:psi_det_size,:) = 0.d0
|
||||
END_PROVIDER
|
||||
|
||||
BEGIN_PROVIDER [ integer(bit_kind), psi_det_sorted_bit, (N_int,2,psi_det_size) ]
|
||||
&BEGIN_PROVIDER [ double precision, psi_coef_sorted_bit, (psi_det_size,N_states) ]
|
||||
implicit none
|
||||
BEGIN_DOC
|
||||
! Determinants on which we apply $\langle i|H|psi \rangle$ for perturbation.
|
||||
! They are sorted by determinants interpreted as integers. Useful
|
||||
! to accelerate the search of a random determinant in the wave
|
||||
! function.
|
||||
END_DOC
|
||||
&BEGIN_PROVIDER [ integer, psi_det_sorted_bit_order, (psi_det_size) ]
|
||||
implicit none
|
||||
integer :: i,j
|
||||
integer*8, allocatable :: bit_tmp(:)
|
||||
integer*8, external :: det_search_key
|
||||
|
||||
call sort_dets_by_det_search_key(N_det, psi_det, psi_coef, size(psi_coef,1), &
|
||||
psi_det_sorted_bit, psi_coef_sorted_bit, N_states)
|
||||
allocate(bit_tmp(N_det))
|
||||
|
||||
do i=1,N_det
|
||||
psi_det_sorted_bit_order(i) = i
|
||||
!$DIR FORCEINLINE
|
||||
bit_tmp(i) = det_search_key(psi_det(1,1,i),N_int)
|
||||
enddo
|
||||
call i8sort(bit_tmp,psi_det_sorted_bit_order,N_det)
|
||||
do i=1,N_det
|
||||
do j=1,N_int
|
||||
psi_det_sorted_bit(j,1,i) = psi_det(j,1,psi_det_sorted_bit_order(i))
|
||||
psi_det_sorted_bit(j,2,i) = psi_det(j,2,psi_det_sorted_bit_order(i))
|
||||
enddo
|
||||
enddo
|
||||
deallocate(bit_tmp)
|
||||
END_PROVIDER
|
||||
|
||||
BEGIN_PROVIDER [ double precision, psi_coef_sorted_bit, (psi_det_size,N_states) ]
|
||||
implicit none
|
||||
integer :: i,k
|
||||
do i=1,N_det
|
||||
do k=1,N_states
|
||||
psi_coef_sorted_bit(i,k) = psi_coef(psi_det_sorted_bit_order(i),k)
|
||||
enddo
|
||||
enddo
|
||||
END_PROVIDER
|
||||
|
||||
|
||||
! BEGIN_PROVIDER [ integer(bit_kind), psi_det_sorted_bit, (N_int,2,psi_det_size) ]
|
||||
!&BEGIN_PROVIDER [ double precision, psi_coef_sorted_bit, (psi_det_size,N_states) ]
|
||||
! implicit none
|
||||
! BEGIN_DOC
|
||||
! ! Determinants on which we apply $\langle i|H|psi \rangle$ for perturbation.
|
||||
! ! They are sorted by determinants interpreted as integers. Useful
|
||||
! ! to accelerate the search of a random determinant in the wave
|
||||
! ! function.
|
||||
! END_DOC
|
||||
!
|
||||
! call sort_dets_by_det_search_key(N_det, psi_det, psi_coef, size(psi_coef,1), &
|
||||
! psi_det_sorted_bit, psi_coef_sorted_bit, N_states)
|
||||
!
|
||||
!END_PROVIDER
|
||||
|
||||
subroutine sort_dets_by_det_search_key(Ndet, det_in, coef_in, sze, det_out, coef_out, N_st)
|
||||
use bitmasks
|
||||
implicit none
|
||||
@ -369,24 +424,46 @@ end
|
||||
|
||||
BEGIN_PROVIDER [ double precision, psi_coef_max, (N_states) ]
|
||||
&BEGIN_PROVIDER [ double precision, psi_coef_min, (N_states) ]
|
||||
&BEGIN_PROVIDER [ double precision, abs_psi_coef_max, (N_states) ]
|
||||
&BEGIN_PROVIDER [ double precision, abs_psi_coef_min, (N_states) ]
|
||||
implicit none
|
||||
BEGIN_DOC
|
||||
! Max and min values of the coefficients
|
||||
END_DOC
|
||||
integer :: i
|
||||
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')
|
||||
enddo
|
||||
implicit none
|
||||
BEGIN_DOC
|
||||
! Max and min values of the coefficients
|
||||
END_DOC
|
||||
integer :: i
|
||||
if (is_complex) then
|
||||
print*,irp_here,' not implemented for complex'
|
||||
stop -1
|
||||
endif
|
||||
do i=1,N_states
|
||||
psi_coef_min(i) = minval(psi_coef(:,i))
|
||||
psi_coef_max(i) = maxval(psi_coef(:,i))
|
||||
call write_double(6,psi_coef_max(i), 'Max coef')
|
||||
call write_double(6,psi_coef_min(i), 'Min coef')
|
||||
enddo
|
||||
END_PROVIDER
|
||||
|
||||
|
||||
BEGIN_PROVIDER [ double precision, abs_psi_coef_max, (N_states) ]
|
||||
&BEGIN_PROVIDER [ double precision, abs_psi_coef_min, (N_states) ]
|
||||
implicit none
|
||||
BEGIN_DOC
|
||||
! Max and min magnitudes of the coefficients
|
||||
END_DOC
|
||||
integer :: i
|
||||
if (is_complex) then
|
||||
do i=1,N_states
|
||||
abs_psi_coef_min(i) = minval( cdabs(psi_coef_complex(:,i)) )
|
||||
abs_psi_coef_max(i) = maxval( cdabs(psi_coef_complex(:,i)) )
|
||||
call write_double(6,abs_psi_coef_max(i), 'Max abs coef')
|
||||
call write_double(6,abs_psi_coef_min(i), 'Min abs coef')
|
||||
enddo
|
||||
else
|
||||
do i=1,N_states
|
||||
abs_psi_coef_min(i) = minval( dabs(psi_coef(:,i)) )
|
||||
abs_psi_coef_max(i) = maxval( dabs(psi_coef(:,i)) )
|
||||
call write_double(6,abs_psi_coef_max(i), 'Max abs coef')
|
||||
call write_double(6,abs_psi_coef_min(i), 'Min abs coef')
|
||||
enddo
|
||||
endif
|
||||
END_PROVIDER
|
||||
|
||||
|
||||
@ -442,10 +519,17 @@ end
|
||||
subroutine save_ref_determinant
|
||||
implicit none
|
||||
use bitmasks
|
||||
if (is_complex) then
|
||||
complex*16 :: buffer_c(1,N_states)
|
||||
buffer_c = (0.d0,0.d0)
|
||||
buffer_c(1,1) = (1.d0,0.d0)
|
||||
call save_wavefunction_general_complex(1,N_states,ref_bitmask,1,buffer_c)
|
||||
else
|
||||
double precision :: buffer(1,N_states)
|
||||
buffer = 0.d0
|
||||
buffer(1,1) = 1.d0
|
||||
call save_wavefunction_general(1,N_states,ref_bitmask,1,buffer)
|
||||
endif
|
||||
end
|
||||
|
||||
|
||||
@ -467,7 +551,12 @@ subroutine save_wavefunction_truncated(thr)
|
||||
endif
|
||||
enddo
|
||||
if (mpi_master) then
|
||||
if (is_complex) then
|
||||
call save_wavefunction_general_complex(N_det_save,min(N_states,N_det_save),&
|
||||
psi_det_sorted,size(psi_coef_sorted_complex,1),psi_coef_sorted_complex)
|
||||
else
|
||||
call save_wavefunction_general(N_det_save,min(N_states,N_det_save),psi_det_sorted,size(psi_coef_sorted,1),psi_coef_sorted)
|
||||
endif
|
||||
endif
|
||||
end
|
||||
|
||||
@ -485,7 +574,12 @@ subroutine save_wavefunction
|
||||
return
|
||||
endif
|
||||
if (mpi_master) then
|
||||
if (is_complex) then
|
||||
call save_wavefunction_general_complex(N_det,N_states,&
|
||||
psi_det_sorted,size(psi_coef_sorted_complex,1),psi_coef_sorted_complex)
|
||||
else
|
||||
call save_wavefunction_general(N_det,N_states,psi_det_sorted,size(psi_coef_sorted,1),psi_coef_sorted)
|
||||
endif
|
||||
endif
|
||||
end
|
||||
|
||||
@ -497,7 +591,12 @@ subroutine save_wavefunction_unsorted
|
||||
! Save the wave function into the |EZFIO| file
|
||||
END_DOC
|
||||
if (mpi_master) then
|
||||
if (is_complex) then
|
||||
call save_wavefunction_general_complex(N_det,min(N_states,N_det),&
|
||||
psi_det,size(psi_coef_complex,1),psi_coef_complex)
|
||||
else
|
||||
call save_wavefunction_general(N_det,min(N_states,N_det),psi_det,size(psi_coef,1),psi_coef)
|
||||
endif
|
||||
endif
|
||||
end
|
||||
|
||||
|
350
src/determinants/determinants_cplx.irp.f
Normal file
350
src/determinants/determinants_cplx.irp.f
Normal file
@ -0,0 +1,350 @@
|
||||
use bitmasks
|
||||
|
||||
|
||||
|
||||
|
||||
BEGIN_PROVIDER [ complex*16, psi_coef_complex, (psi_det_size,N_states) ]
|
||||
implicit none
|
||||
BEGIN_DOC
|
||||
! The wave function coefficients. Initialized with Hartree-Fock if the |EZFIO| file
|
||||
! is empty.
|
||||
END_DOC
|
||||
|
||||
integer :: i,k, N_int2
|
||||
logical :: exists
|
||||
character*(64) :: label
|
||||
|
||||
PROVIDE read_wf N_det mo_label ezfio_filename
|
||||
psi_coef_complex = (0.d0,0.d0)
|
||||
do i=1,min(N_states,psi_det_size)
|
||||
psi_coef_complex(i,i) = (1.d0,0.d0)
|
||||
enddo
|
||||
|
||||
if (mpi_master) then
|
||||
if (read_wf) then
|
||||
call ezfio_has_determinants_psi_coef_complex(exists)
|
||||
if (exists) then
|
||||
call ezfio_has_determinants_mo_label(exists)
|
||||
if (exists) then
|
||||
call ezfio_get_determinants_mo_label(label)
|
||||
exists = (label == mo_label)
|
||||
endif
|
||||
endif
|
||||
|
||||
if (exists) then
|
||||
|
||||
complex*16, allocatable :: psi_coef_read(:,:)
|
||||
allocate (psi_coef_read(N_det,N_states))
|
||||
print *, 'Read psi_coef_complex', N_det, N_states
|
||||
call ezfio_get_determinants_psi_coef_complex(psi_coef_read)
|
||||
do k=1,N_states
|
||||
do i=1,N_det
|
||||
psi_coef_complex(i,k) = psi_coef_read(i,k)
|
||||
enddo
|
||||
enddo
|
||||
deallocate(psi_coef_read)
|
||||
|
||||
endif
|
||||
endif
|
||||
endif
|
||||
IRP_IF MPI_DEBUG
|
||||
print *, irp_here, mpi_rank
|
||||
call MPI_BARRIER(MPI_COMM_WORLD, ierr)
|
||||
IRP_ENDIF
|
||||
IRP_IF MPI
|
||||
include 'mpif.h'
|
||||
integer :: ierr
|
||||
call MPI_BCAST( psi_coef_complex, size(psi_coef_complex), MPI_DOUBLE_COMPLEX, 0, MPI_COMM_WORLD, ierr)
|
||||
if (ierr /= MPI_SUCCESS) then
|
||||
stop 'Unable to read psi_coef_complex with MPI'
|
||||
endif
|
||||
IRP_ENDIF
|
||||
|
||||
|
||||
|
||||
END_PROVIDER
|
||||
|
||||
!==============================================================================!
|
||||
! !
|
||||
! Sorting providers !
|
||||
! !
|
||||
!==============================================================================!
|
||||
|
||||
BEGIN_PROVIDER [ complex*16, psi_coef_sorted_complex, (psi_det_size,N_states) ]
|
||||
implicit none
|
||||
integer :: i,j,k
|
||||
do i=1,N_det
|
||||
j=psi_det_sorted_order(i)
|
||||
do k=1,N_states
|
||||
psi_coef_sorted_complex(j,k) = psi_coef_complex(i,k)
|
||||
enddo
|
||||
enddo
|
||||
psi_coef_sorted_complex(N_det+1:psi_det_size,:) = (0.d0,0.d0)
|
||||
END_PROVIDER
|
||||
|
||||
!!TODO: implement for complex (new psi_det_sorted? reuse? combine complex provider with real?)
|
||||
! BEGIN_PROVIDER [ integer(bit_kind), psi_det_sorted_complex, (N_int,2,psi_det_size) ]
|
||||
!&BEGIN_PROVIDER [ complex*16, psi_coef_sorted_complex, (psi_det_size,N_states) ]
|
||||
!&BEGIN_PROVIDER [ double precision, psi_average_norm_contrib_sorted_complex, (psi_det_size) ]
|
||||
!&BEGIN_PROVIDER [ integer, psi_det_sorted_order_complex, (psi_det_size) ]
|
||||
! implicit none
|
||||
! BEGIN_DOC
|
||||
! ! Wave function sorted by determinants contribution to the norm (state-averaged)
|
||||
! !
|
||||
! ! psi_det_sorted_order(i) -> k : index in psi_det
|
||||
! END_DOC
|
||||
! integer :: i,j,k
|
||||
! integer, allocatable :: iorder(:)
|
||||
! allocate ( iorder(N_det) )
|
||||
! do i=1,N_det
|
||||
! psi_average_norm_contrib_sorted_complex(i) = -psi_average_norm_contrib(i)
|
||||
! iorder(i) = i
|
||||
! enddo
|
||||
! call dsort(psi_average_norm_contrib_sorted_complex,iorder,N_det)
|
||||
! do i=1,N_det
|
||||
! do j=1,N_int
|
||||
! psi_det_sorted_complex(j,1,i) = psi_det(j,1,iorder(i))
|
||||
! psi_det_sorted_complex(j,2,i) = psi_det(j,2,iorder(i))
|
||||
! enddo
|
||||
! do k=1,N_states
|
||||
! psi_coef_sorted_complex(i,k) = psi_coef_complex(iorder(i),k)
|
||||
! enddo
|
||||
! psi_average_norm_contrib_sorted_complex(i) = -psi_average_norm_contrib_sorted_complex(i)
|
||||
! enddo
|
||||
! do i=1,N_det
|
||||
! psi_det_sorted_order_complex(iorder(i)) = i
|
||||
! enddo
|
||||
!
|
||||
! psi_det_sorted_complex(:,:,N_det+1:psi_det_size) = 0_bit_kind
|
||||
! psi_coef_sorted_complex(N_det+1:psi_det_size,:) = (0.d0,0.d0)
|
||||
! psi_average_norm_contrib_sorted_complex(N_det+1:psi_det_size) = 0.d0
|
||||
! psi_det_sorted_order_complex(N_det+1:psi_det_size) = 0
|
||||
!
|
||||
! deallocate(iorder)
|
||||
!
|
||||
!END_PROVIDER
|
||||
|
||||
|
||||
BEGIN_PROVIDER [ complex*16, psi_coef_sorted_bit_complex, (psi_det_size,N_states) ]
|
||||
implicit none
|
||||
integer :: i,k
|
||||
do i=1,N_det
|
||||
do k=1,N_states
|
||||
psi_coef_sorted_bit_complex(i,k) = psi_coef_complex(psi_det_sorted_bit_order(i),k)
|
||||
enddo
|
||||
enddo
|
||||
END_PROVIDER
|
||||
|
||||
subroutine sort_dets_by_det_search_key_complex(Ndet, det_in, coef_in, sze, det_out, coef_out, N_st)
|
||||
use bitmasks
|
||||
implicit none
|
||||
integer, intent(in) :: Ndet, N_st, sze
|
||||
integer(bit_kind), intent(in) :: det_in (N_int,2,sze)
|
||||
complex*16 , intent(in) :: coef_in(sze,N_st)
|
||||
integer(bit_kind), intent(out) :: det_out (N_int,2,sze)
|
||||
complex*16 , intent(out) :: coef_out(sze,N_st)
|
||||
BEGIN_DOC
|
||||
! Determinants are sorted according to their :c:func:`det_search_key`.
|
||||
! Useful to accelerate the search of a random determinant in the wave
|
||||
! function.
|
||||
!
|
||||
! /!\ The first dimension of coef_out and coef_in need to be psi_det_size
|
||||
!
|
||||
END_DOC
|
||||
integer :: i,j,k
|
||||
integer, allocatable :: iorder(:)
|
||||
integer*8, allocatable :: bit_tmp(:)
|
||||
integer*8, external :: det_search_key
|
||||
|
||||
allocate ( iorder(Ndet), bit_tmp(Ndet) )
|
||||
|
||||
do i=1,Ndet
|
||||
iorder(i) = i
|
||||
!$DIR FORCEINLINE
|
||||
bit_tmp(i) = det_search_key(det_in(1,1,i),N_int)
|
||||
enddo
|
||||
call i8sort(bit_tmp,iorder,Ndet)
|
||||
!DIR$ IVDEP
|
||||
do i=1,Ndet
|
||||
do j=1,N_int
|
||||
det_out(j,1,i) = det_in(j,1,iorder(i))
|
||||
det_out(j,2,i) = det_in(j,2,iorder(i))
|
||||
enddo
|
||||
do k=1,N_st
|
||||
coef_out(i,k) = coef_in(iorder(i),k)
|
||||
enddo
|
||||
enddo
|
||||
|
||||
deallocate(iorder, bit_tmp)
|
||||
|
||||
end
|
||||
|
||||
|
||||
!==============================================================================!
|
||||
! !
|
||||
! Read/write routines !
|
||||
! !
|
||||
!==============================================================================!
|
||||
|
||||
|
||||
|
||||
subroutine save_wavefunction_general_complex(ndet,nstates,psidet,dim_psicoef,psicoef)
|
||||
implicit none
|
||||
BEGIN_DOC
|
||||
! Save the wave function into the |EZFIO| file
|
||||
END_DOC
|
||||
use bitmasks
|
||||
include 'constants.include.F'
|
||||
integer, intent(in) :: ndet,nstates,dim_psicoef
|
||||
integer(bit_kind), intent(in) :: psidet(N_int,2,ndet)
|
||||
complex*16, intent(in) :: psicoef(dim_psicoef,nstates)
|
||||
integer*8, allocatable :: psi_det_save(:,:,:)
|
||||
complex*16, allocatable :: psi_coef_save(:,:)
|
||||
|
||||
double precision :: accu_norm
|
||||
integer :: i,j,k, ndet_qp_edit
|
||||
|
||||
if (mpi_master) then
|
||||
ndet_qp_edit = min(ndet,N_det_qp_edit)
|
||||
|
||||
call ezfio_set_determinants_N_int(N_int)
|
||||
call ezfio_set_determinants_bit_kind(bit_kind)
|
||||
call ezfio_set_determinants_N_det(ndet)
|
||||
call ezfio_set_determinants_N_det_qp_edit(ndet_qp_edit)
|
||||
call ezfio_set_determinants_n_states(nstates)
|
||||
call ezfio_set_determinants_mo_label(mo_label)
|
||||
|
||||
allocate (psi_det_save(N_int,2,ndet))
|
||||
do i=1,ndet
|
||||
do j=1,2
|
||||
do k=1,N_int
|
||||
psi_det_save(k,j,i) = transfer(psidet(k,j,i),1_8)
|
||||
enddo
|
||||
enddo
|
||||
enddo
|
||||
call ezfio_set_determinants_psi_det(psi_det_save)
|
||||
call ezfio_set_determinants_psi_det_qp_edit(psi_det_save)
|
||||
deallocate (psi_det_save)
|
||||
|
||||
allocate (psi_coef_save(ndet,nstates))
|
||||
do k=1,nstates
|
||||
do i=1,ndet
|
||||
psi_coef_save(i,k) = psicoef(i,k)
|
||||
enddo
|
||||
call normalize_complex(psi_coef_save(1,k),ndet)
|
||||
enddo
|
||||
|
||||
call ezfio_set_determinants_psi_coef_complex(psi_coef_save)
|
||||
deallocate (psi_coef_save)
|
||||
|
||||
allocate (psi_coef_save(ndet_qp_edit,nstates))
|
||||
do k=1,nstates
|
||||
do i=1,ndet_qp_edit
|
||||
psi_coef_save(i,k) = psicoef(i,k)
|
||||
enddo
|
||||
call normalize_complex(psi_coef_save(1,k),ndet_qp_edit)
|
||||
enddo
|
||||
|
||||
call ezfio_set_determinants_psi_coef_complex_qp_edit(psi_coef_save)
|
||||
deallocate (psi_coef_save)
|
||||
|
||||
call write_int(6,ndet,'Saved determinants')
|
||||
endif
|
||||
end
|
||||
|
||||
|
||||
|
||||
subroutine save_wavefunction_specified_complex(ndet,nstates,psidet,psicoef,ndetsave,index_det_save)
|
||||
implicit none
|
||||
BEGIN_DOC
|
||||
! Save the wave function into the |EZFIO| file
|
||||
END_DOC
|
||||
use bitmasks
|
||||
integer, intent(in) :: ndet,nstates
|
||||
integer(bit_kind), intent(in) :: psidet(N_int,2,ndet)
|
||||
complex*16, intent(in) :: psicoef(ndet,nstates)
|
||||
integer, intent(in) :: index_det_save(ndet)
|
||||
integer, intent(in) :: ndetsave
|
||||
integer*8, allocatable :: psi_det_save(:,:,:)
|
||||
complex*16, allocatable :: psi_coef_save(:,:)
|
||||
integer*8 :: det_8(100)
|
||||
integer(bit_kind) :: det_bk((100*8)/bit_kind)
|
||||
integer :: N_int2
|
||||
equivalence (det_8, det_bk)
|
||||
|
||||
integer :: i,j,k, ndet_qp_edit
|
||||
|
||||
if (mpi_master) then
|
||||
ndet_qp_edit = min(ndetsave,N_det_qp_edit)
|
||||
call ezfio_set_determinants_N_int(N_int)
|
||||
call ezfio_set_determinants_bit_kind(bit_kind)
|
||||
call ezfio_set_determinants_N_det(ndetsave)
|
||||
call ezfio_set_determinants_N_det_qp_edit(ndet_qp_edit)
|
||||
call ezfio_set_determinants_n_states(nstates)
|
||||
call ezfio_set_determinants_mo_label(mo_label)
|
||||
|
||||
N_int2 = (N_int*bit_kind)/8
|
||||
allocate (psi_det_save(N_int2,2,ndetsave))
|
||||
do i=1,ndetsave
|
||||
do k=1,N_int
|
||||
det_bk(k) = psidet(k,1,index_det_save(i))
|
||||
enddo
|
||||
do k=1,N_int2
|
||||
psi_det_save(k,1,i) = det_8(k)
|
||||
enddo
|
||||
do k=1,N_int
|
||||
det_bk(k) = psidet(k,2,index_det_save(i))
|
||||
enddo
|
||||
do k=1,N_int2
|
||||
psi_det_save(k,2,i) = det_8(k)
|
||||
enddo
|
||||
enddo
|
||||
call ezfio_set_determinants_psi_det(psi_det_save)
|
||||
call ezfio_set_determinants_psi_det_qp_edit(psi_det_save)
|
||||
deallocate (psi_det_save)
|
||||
|
||||
allocate (psi_coef_save(ndetsave,nstates))
|
||||
double precision :: accu_norm(nstates)
|
||||
accu_norm = 0.d0
|
||||
do k=1,nstates
|
||||
do i=1,ndetsave
|
||||
accu_norm(k) = accu_norm(k) + cdabs(psicoef(index_det_save(i),k) * psicoef(index_det_save(i),k))
|
||||
psi_coef_save(i,k) = psicoef(index_det_save(i),k)
|
||||
enddo
|
||||
enddo
|
||||
do k = 1, nstates
|
||||
accu_norm(k) = 1.d0/dsqrt(accu_norm(k))
|
||||
enddo
|
||||
do k=1,nstates
|
||||
do i=1,ndetsave
|
||||
psi_coef_save(i,k) = psi_coef_save(i,k) * accu_norm(k)
|
||||
enddo
|
||||
enddo
|
||||
|
||||
call ezfio_set_determinants_psi_coef_complex(psi_coef_save)
|
||||
deallocate (psi_coef_save)
|
||||
|
||||
allocate (psi_coef_save(ndet_qp_edit,nstates))
|
||||
accu_norm = 0.d0
|
||||
do k=1,nstates
|
||||
do i=1,ndet_qp_edit
|
||||
accu_norm(k) = accu_norm(k) + cdabs(psicoef(index_det_save(i),k) * psicoef(index_det_save(i),k))
|
||||
psi_coef_save(i,k) = psicoef(index_det_save(i),k)
|
||||
enddo
|
||||
enddo
|
||||
do k = 1, nstates
|
||||
accu_norm(k) = 1.d0/dsqrt(accu_norm(k))
|
||||
enddo
|
||||
do k=1,nstates
|
||||
do i=1,ndet_qp_edit
|
||||
psi_coef_save(i,k) = psi_coef_save(i,k) * accu_norm(k)
|
||||
enddo
|
||||
enddo
|
||||
!TODO: should this be psi_coef_complex_qp_edit?
|
||||
call ezfio_set_determinants_psi_coef_complex(psi_coef_save)
|
||||
deallocate (psi_coef_save)
|
||||
|
||||
call write_int(6,ndet,'Saved determinants')
|
||||
endif
|
||||
end
|
||||
|
@ -21,11 +21,19 @@ BEGIN_PROVIDER [ double precision, barycentric_electronic_energy, (N_states) ]
|
||||
|
||||
barycentric_electronic_energy(:) = 0.d0
|
||||
|
||||
if (is_complex) then
|
||||
do istate=1,N_states
|
||||
do i=1,N_det
|
||||
barycentric_electronic_energy(istate) += cdabs(psi_coef_complex(i,istate)*psi_coef_complex(i,istate))*diagonal_H_matrix_on_psi_det(i)
|
||||
enddo
|
||||
enddo
|
||||
else
|
||||
do istate=1,N_states
|
||||
do i=1,N_det
|
||||
barycentric_electronic_energy(istate) += psi_coef(i,istate)*psi_coef(i,istate)*diagonal_H_matrix_on_psi_det(i)
|
||||
enddo
|
||||
enddo
|
||||
endif
|
||||
|
||||
END_PROVIDER
|
||||
|
||||
|
@ -29,12 +29,12 @@ subroutine build_fock_tmp(fock_diag_tmp,det_ref,Nint)
|
||||
call debug_det(det_ref,N_int)
|
||||
stop -1
|
||||
endif
|
||||
|
||||
|
||||
! Occupied MOs
|
||||
do ii=1,elec_alpha_num
|
||||
i = occ(ii,1)
|
||||
fock_diag_tmp(1,i) = fock_diag_tmp(1,i) + mo_one_e_integrals(i,i)
|
||||
E0 = E0 + mo_one_e_integrals(i,i)
|
||||
fock_diag_tmp(1,i) = fock_diag_tmp(1,i) + mo_one_e_integrals_diag(i)
|
||||
E0 = E0 + mo_one_e_integrals_diag(i)
|
||||
do jj=1,elec_alpha_num
|
||||
j = occ(jj,1)
|
||||
if (i==j) cycle
|
||||
@ -49,8 +49,8 @@ subroutine build_fock_tmp(fock_diag_tmp,det_ref,Nint)
|
||||
enddo
|
||||
do ii=1,elec_beta_num
|
||||
i = occ(ii,2)
|
||||
fock_diag_tmp(2,i) = fock_diag_tmp(2,i) + mo_one_e_integrals(i,i)
|
||||
E0 = E0 + mo_one_e_integrals(i,i)
|
||||
fock_diag_tmp(2,i) = fock_diag_tmp(2,i) + mo_one_e_integrals_diag(i)
|
||||
E0 = E0 + mo_one_e_integrals_diag(i)
|
||||
do jj=1,elec_beta_num
|
||||
j = occ(jj,2)
|
||||
if (i==j) cycle
|
||||
@ -66,7 +66,7 @@ subroutine build_fock_tmp(fock_diag_tmp,det_ref,Nint)
|
||||
! Virtual MOs
|
||||
do i=1,mo_num
|
||||
if (fock_diag_tmp(1,i) /= 0.d0) cycle
|
||||
fock_diag_tmp(1,i) = fock_diag_tmp(1,i) + mo_one_e_integrals(i,i)
|
||||
fock_diag_tmp(1,i) = fock_diag_tmp(1,i) + mo_one_e_integrals_diag(i)
|
||||
do jj=1,elec_alpha_num
|
||||
j = occ(jj,1)
|
||||
fock_diag_tmp(1,i) = fock_diag_tmp(1,i) + mo_two_e_integrals_jj_anti(i,j)
|
||||
@ -78,7 +78,7 @@ subroutine build_fock_tmp(fock_diag_tmp,det_ref,Nint)
|
||||
enddo
|
||||
do i=1,mo_num
|
||||
if (fock_diag_tmp(2,i) /= 0.d0) cycle
|
||||
fock_diag_tmp(2,i) = fock_diag_tmp(2,i) + mo_one_e_integrals(i,i)
|
||||
fock_diag_tmp(2,i) = fock_diag_tmp(2,i) + mo_one_e_integrals_diag(i)
|
||||
do jj=1,elec_beta_num
|
||||
j = occ(jj,2)
|
||||
fock_diag_tmp(2,i) = fock_diag_tmp(2,i) + mo_two_e_integrals_jj_anti(i,j)
|
||||
|
@ -6,6 +6,7 @@ type H_apply_buffer_type
|
||||
integer :: sze
|
||||
integer(bit_kind), pointer :: det(:,:,:)
|
||||
double precision , pointer :: coef(:,:)
|
||||
complex*16 , pointer :: coef_complex(:,:)
|
||||
double precision , pointer :: e2(:,:)
|
||||
end type H_apply_buffer_type
|
||||
|
||||
@ -26,17 +27,22 @@ type(H_apply_buffer_type), pointer :: H_apply_buffer(:)
|
||||
allocate(H_apply_buffer(0:nproc-1))
|
||||
iproc = 0
|
||||
!$OMP PARALLEL PRIVATE(iproc) DEFAULT(NONE) &
|
||||
!$OMP SHARED(H_apply_buffer,N_int,sze,N_states,H_apply_buffer_lock)
|
||||
!$OMP SHARED(H_apply_buffer,N_int,sze,N_states,H_apply_buffer_lock,is_complex)
|
||||
!$ iproc = omp_get_thread_num()
|
||||
H_apply_buffer(iproc)%N_det = 0
|
||||
H_apply_buffer(iproc)%sze = sze
|
||||
allocate ( &
|
||||
H_apply_buffer(iproc)%det(N_int,2,sze), &
|
||||
H_apply_buffer(iproc)%coef(sze,N_states), &
|
||||
H_apply_buffer(iproc)%e2(sze,N_states) &
|
||||
)
|
||||
if (is_complex) then
|
||||
allocate(H_apply_buffer(iproc)%coef_complex(sze,N_states))
|
||||
H_apply_buffer(iproc)%coef_complex = (0.d0,0.d0)
|
||||
else
|
||||
allocate(H_apply_buffer(iproc)%coef(sze,N_states))
|
||||
H_apply_buffer(iproc)%coef = 0.d0
|
||||
endif
|
||||
H_apply_buffer(iproc)%det = 0_bit_kind
|
||||
H_apply_buffer(iproc)%coef = 0.d0
|
||||
H_apply_buffer(iproc)%e2 = 0.d0
|
||||
call omp_init_lock(H_apply_buffer_lock(1,iproc))
|
||||
!$OMP END PARALLEL
|
||||
@ -59,6 +65,7 @@ subroutine resize_H_apply_buffer(new_size,iproc)
|
||||
integer, intent(in) :: new_size, iproc
|
||||
integer(bit_kind), pointer :: buffer_det(:,:,:)
|
||||
double precision, pointer :: buffer_coef(:,:)
|
||||
complex*16, pointer :: buffer_coef_complex(:,:)
|
||||
double precision, pointer :: buffer_e2(:,:)
|
||||
integer :: i,j,k
|
||||
integer :: Ndet
|
||||
@ -74,9 +81,14 @@ subroutine resize_H_apply_buffer(new_size,iproc)
|
||||
ASSERT (iproc < nproc)
|
||||
|
||||
allocate ( buffer_det(N_int,2,new_size), &
|
||||
buffer_coef(new_size,N_states), &
|
||||
buffer_e2(new_size,N_states) )
|
||||
buffer_coef = 0.d0
|
||||
if (is_complex) then
|
||||
allocate(buffer_coef_complex(new_size,N_states))
|
||||
buffer_coef_complex = (0.d0,0.d0)
|
||||
else
|
||||
allocate(buffer_coef(new_size,N_states))
|
||||
buffer_coef = 0.d0
|
||||
endif
|
||||
buffer_e2 = 0.d0
|
||||
do i=1,min(new_size,H_apply_buffer(iproc)%N_det)
|
||||
do k=1,N_int
|
||||
@ -89,6 +101,15 @@ subroutine resize_H_apply_buffer(new_size,iproc)
|
||||
deallocate(H_apply_buffer(iproc)%det)
|
||||
H_apply_buffer(iproc)%det => buffer_det
|
||||
|
||||
if (is_complex) then
|
||||
do k=1,N_states
|
||||
do i=1,min(new_size,H_apply_buffer(iproc)%N_det)
|
||||
buffer_coef_complex(i,k) = H_apply_buffer(iproc)%coef_complex(i,k)
|
||||
enddo
|
||||
enddo
|
||||
deallocate(H_apply_buffer(iproc)%coef_complex)
|
||||
H_apply_buffer(iproc)%coef_complex => buffer_coef_complex
|
||||
else
|
||||
do k=1,N_states
|
||||
do i=1,min(new_size,H_apply_buffer(iproc)%N_det)
|
||||
buffer_coef(i,k) = H_apply_buffer(iproc)%coef(i,k)
|
||||
@ -96,6 +117,7 @@ subroutine resize_H_apply_buffer(new_size,iproc)
|
||||
enddo
|
||||
deallocate(H_apply_buffer(iproc)%coef)
|
||||
H_apply_buffer(iproc)%coef => buffer_coef
|
||||
endif
|
||||
|
||||
do k=1,N_states
|
||||
do i=1,min(new_size,H_apply_buffer(iproc)%N_det)
|
||||
@ -119,6 +141,7 @@ subroutine copy_H_apply_buffer_to_wf
|
||||
END_DOC
|
||||
integer(bit_kind), allocatable :: buffer_det(:,:,:)
|
||||
double precision, allocatable :: buffer_coef(:,:)
|
||||
complex*16, allocatable :: buffer_coef_complex(:,:)
|
||||
integer :: i,j,k
|
||||
integer :: N_det_old
|
||||
|
||||
@ -128,7 +151,12 @@ subroutine copy_H_apply_buffer_to_wf
|
||||
ASSERT (N_int > 0)
|
||||
ASSERT (N_det > 0)
|
||||
|
||||
allocate ( buffer_det(N_int,2,N_det), buffer_coef(N_det,N_states) )
|
||||
allocate ( buffer_det(N_int,2,N_det))
|
||||
if (is_complex) then
|
||||
allocate(buffer_coef_complex(N_det,N_states))
|
||||
else
|
||||
allocate(buffer_coef(N_det,N_states))
|
||||
endif
|
||||
|
||||
! Backup determinants
|
||||
j=0
|
||||
@ -142,6 +170,17 @@ subroutine copy_H_apply_buffer_to_wf
|
||||
N_det_old = j
|
||||
|
||||
! Backup coefficients
|
||||
if (is_complex) then
|
||||
do k=1,N_states
|
||||
j=0
|
||||
do i=1,N_det
|
||||
if (pruned(i)) cycle ! Pruned determinants
|
||||
j += 1
|
||||
buffer_coef_complex(j,k) = psi_coef_complex(i,k)
|
||||
enddo
|
||||
ASSERT ( j == N_det_old )
|
||||
enddo
|
||||
else
|
||||
do k=1,N_states
|
||||
j=0
|
||||
do i=1,N_det
|
||||
@ -151,6 +190,7 @@ subroutine copy_H_apply_buffer_to_wf
|
||||
enddo
|
||||
ASSERT ( j == N_det_old )
|
||||
enddo
|
||||
endif
|
||||
|
||||
! Update N_det
|
||||
N_det = N_det_old
|
||||
@ -170,13 +210,56 @@ subroutine copy_H_apply_buffer_to_wf
|
||||
ASSERT (sum(popcnt(psi_det(:,1,i))) == elec_alpha_num)
|
||||
ASSERT (sum(popcnt(psi_det(:,2,i))) == elec_beta_num )
|
||||
enddo
|
||||
if (is_complex) then
|
||||
do k=1,N_states
|
||||
do i=1,N_det_old
|
||||
psi_coef_complex(i,k) = buffer_coef_complex(i,k)
|
||||
enddo
|
||||
enddo
|
||||
else
|
||||
do k=1,N_states
|
||||
do i=1,N_det_old
|
||||
psi_coef(i,k) = buffer_coef(i,k)
|
||||
enddo
|
||||
enddo
|
||||
endif
|
||||
|
||||
! Copy new buffers
|
||||
logical :: found_duplicates
|
||||
|
||||
if (is_complex) then
|
||||
!$OMP PARALLEL DEFAULT(SHARED) &
|
||||
!$OMP PRIVATE(j,k,i) FIRSTPRIVATE(N_det_old) &
|
||||
!$OMP SHARED(N_int,H_apply_buffer,psi_det,psi_coef_complex,N_states,psi_det_size)
|
||||
j=0
|
||||
!$ j=omp_get_thread_num()
|
||||
do k=0,j-1
|
||||
N_det_old += H_apply_buffer(k)%N_det
|
||||
enddo
|
||||
do i=1,H_apply_buffer(j)%N_det
|
||||
do k=1,N_int
|
||||
psi_det(k,1,i+N_det_old) = H_apply_buffer(j)%det(k,1,i)
|
||||
psi_det(k,2,i+N_det_old) = H_apply_buffer(j)%det(k,2,i)
|
||||
enddo
|
||||
ASSERT (sum(popcnt(psi_det(:,1,i+N_det_old))) == elec_alpha_num)
|
||||
ASSERT (sum(popcnt(psi_det(:,2,i+N_det_old))) == elec_beta_num )
|
||||
enddo
|
||||
do k=1,N_states
|
||||
do i=1,H_apply_buffer(j)%N_det
|
||||
psi_coef_complex(i+N_det_old,k) = H_apply_buffer(j)%coef_complex(i,k)
|
||||
enddo
|
||||
enddo
|
||||
!$OMP BARRIER
|
||||
H_apply_buffer(j)%N_det = 0
|
||||
!$OMP END PARALLEL
|
||||
SOFT_TOUCH N_det psi_det psi_coef_complex
|
||||
|
||||
call remove_duplicates_in_psi_det(found_duplicates)
|
||||
do k=1,N_states
|
||||
call normalize(psi_coef_complex(1,k),N_det)
|
||||
enddo
|
||||
SOFT_TOUCH N_det psi_det psi_coef_complex
|
||||
else
|
||||
|
||||
!$OMP PARALLEL DEFAULT(SHARED) &
|
||||
!$OMP PRIVATE(j,k,i) FIRSTPRIVATE(N_det_old) &
|
||||
@ -204,13 +287,13 @@ subroutine copy_H_apply_buffer_to_wf
|
||||
!$OMP END PARALLEL
|
||||
SOFT_TOUCH N_det psi_det psi_coef
|
||||
|
||||
logical :: found_duplicates
|
||||
call remove_duplicates_in_psi_det(found_duplicates)
|
||||
do k=1,N_states
|
||||
call normalize(psi_coef(1,k),N_det)
|
||||
enddo
|
||||
SOFT_TOUCH N_det psi_det psi_coef
|
||||
|
||||
endif
|
||||
end
|
||||
|
||||
subroutine remove_duplicates_in_psi_det(found_duplicates)
|
||||
@ -275,6 +358,29 @@ subroutine remove_duplicates_in_psi_det(found_duplicates)
|
||||
!$OMP END DO
|
||||
!$OMP END PARALLEL
|
||||
|
||||
if (is_complex) then
|
||||
if (found_duplicates) then
|
||||
k=0
|
||||
do i=1,N_det
|
||||
if (.not.duplicate(i)) then
|
||||
k += 1
|
||||
psi_det(:,:,k) = psi_det_sorted_bit (:,:,i)
|
||||
psi_coef_complex(k,:) = psi_coef_sorted_bit_complex(i,:)
|
||||
else
|
||||
if (sum(cdabs(psi_coef_sorted_bit_complex(i,:))) /= 0.d0 ) then
|
||||
psi_coef_complex(k,:) = psi_coef_sorted_bit_complex(i,:)
|
||||
endif
|
||||
endif
|
||||
enddo
|
||||
N_det = k
|
||||
psi_det_sorted_bit(:,:,1:N_det) = psi_det(:,:,1:N_det)
|
||||
psi_coef_sorted_bit_complex(1:N_det,:) = psi_coef_complex(1:N_det,:)
|
||||
TOUCH N_det psi_det psi_coef_complex psi_det_sorted_bit psi_coef_sorted_bit_complex c0_weight
|
||||
endif
|
||||
psi_det = psi_det_sorted
|
||||
psi_coef_complex = psi_coef_sorted_complex
|
||||
SOFT_TOUCH psi_det psi_coef_complex psi_det_sorted_bit psi_coef_sorted_bit_complex
|
||||
else
|
||||
if (found_duplicates) then
|
||||
k=0
|
||||
do i=1,N_det
|
||||
@ -296,6 +402,7 @@ subroutine remove_duplicates_in_psi_det(found_duplicates)
|
||||
psi_det = psi_det_sorted
|
||||
psi_coef = psi_coef_sorted
|
||||
SOFT_TOUCH psi_det psi_coef psi_det_sorted_bit psi_coef_sorted_bit
|
||||
endif
|
||||
deallocate (duplicate,bit_tmp)
|
||||
end
|
||||
|
||||
@ -329,11 +436,19 @@ subroutine fill_H_apply_buffer_no_selection(n_selected,det_buffer,Nint,iproc)
|
||||
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
|
||||
if (is_complex) then
|
||||
do j=1,N_states
|
||||
do i=1,N_selected
|
||||
H_apply_buffer(iproc)%coef_complex(i+H_apply_buffer(iproc)%N_det,j) = (0.d0,0.d0)
|
||||
enddo
|
||||
enddo
|
||||
else
|
||||
do j=1,N_states
|
||||
do i=1,N_selected
|
||||
H_apply_buffer(iproc)%coef(i+H_apply_buffer(iproc)%N_det,j) = 0.d0
|
||||
enddo
|
||||
enddo
|
||||
endif
|
||||
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)
|
||||
@ -341,4 +456,3 @@ subroutine fill_H_apply_buffer_no_selection(n_selected,det_buffer,Nint,iproc)
|
||||
enddo
|
||||
call omp_unset_lock(H_apply_buffer_lock(1,iproc))
|
||||
end
|
||||
|
||||
|
@ -17,8 +17,11 @@ subroutine $subroutine($params_main)
|
||||
double precision, allocatable :: fock_diag_tmp(:,:)
|
||||
|
||||
$initialization
|
||||
if (is_complex) then
|
||||
PROVIDE H_apply_buffer_allocated mo_two_e_integrals_in_map psi_det_generators psi_coef_generators_complex
|
||||
else
|
||||
PROVIDE H_apply_buffer_allocated mo_two_e_integrals_in_map psi_det_generators psi_coef_generators
|
||||
|
||||
endif
|
||||
|
||||
call wall_time(wall_0)
|
||||
|
||||
|
@ -401,12 +401,21 @@ BEGIN_PROVIDER [ double precision, weight_occ_pattern, (N_occ_pattern,N_states)
|
||||
END_DOC
|
||||
integer :: i,j,k
|
||||
weight_occ_pattern = 0.d0
|
||||
if (is_complex) then
|
||||
do i=1,N_det
|
||||
j = det_to_occ_pattern(i)
|
||||
do k=1,N_states
|
||||
weight_occ_pattern(j,k) += cdabs(psi_coef_complex(i,k) * psi_coef_complex(i,k))
|
||||
enddo
|
||||
enddo
|
||||
else
|
||||
do i=1,N_det
|
||||
j = det_to_occ_pattern(i)
|
||||
do k=1,N_states
|
||||
weight_occ_pattern(j,k) += psi_coef(i,k) * psi_coef(i,k)
|
||||
enddo
|
||||
enddo
|
||||
endif
|
||||
END_PROVIDER
|
||||
|
||||
BEGIN_PROVIDER [ double precision, weight_occ_pattern_average, (N_occ_pattern) ]
|
||||
@ -416,12 +425,21 @@ BEGIN_PROVIDER [ double precision, weight_occ_pattern_average, (N_occ_pattern) ]
|
||||
END_DOC
|
||||
integer :: i,j,k
|
||||
weight_occ_pattern_average(:) = 0.d0
|
||||
if (is_complex) then
|
||||
do i=1,N_det
|
||||
j = det_to_occ_pattern(i)
|
||||
do k=1,N_states
|
||||
weight_occ_pattern_average(j) += cdabs(psi_coef_complex(i,k) * psi_coef_complex(i,k)) * state_average_weight(k)
|
||||
enddo
|
||||
enddo
|
||||
else
|
||||
do i=1,N_det
|
||||
j = det_to_occ_pattern(i)
|
||||
do k=1,N_states
|
||||
weight_occ_pattern_average(j) += psi_coef(i,k) * psi_coef(i,k) * state_average_weight(k)
|
||||
enddo
|
||||
enddo
|
||||
endif
|
||||
END_PROVIDER
|
||||
|
||||
BEGIN_PROVIDER [ integer(bit_kind), psi_occ_pattern_sorted, (N_int,2,N_occ_pattern) ]
|
||||
@ -495,7 +513,7 @@ subroutine make_s2_eigenfunction
|
||||
N_det_new += 1
|
||||
det_buffer(:,:,N_det_new) = d(:,:,j)
|
||||
if (N_det_new == bufsze) then
|
||||
call fill_H_apply_buffer_no_selection(bufsze,det_buffer,N_int,ithread)
|
||||
call fill_h_apply_buffer_no_selection(bufsze,det_buffer,N_int,ithread)
|
||||
N_det_new = 0
|
||||
endif
|
||||
enddo
|
||||
@ -510,8 +528,12 @@ subroutine make_s2_eigenfunction
|
||||
!$OMP END PARALLEL
|
||||
|
||||
if (update) then
|
||||
call copy_H_apply_buffer_to_wf
|
||||
call copy_h_apply_buffer_to_wf
|
||||
if (is_complex) then
|
||||
TOUCH N_det psi_coef_complex psi_det psi_occ_pattern N_occ_pattern
|
||||
else
|
||||
TOUCH N_det psi_coef psi_det psi_occ_pattern N_occ_pattern
|
||||
endif
|
||||
endif
|
||||
call write_time(6)
|
||||
|
||||
|
@ -150,7 +150,20 @@ END_PROVIDER
|
||||
double precision :: hij,norm,u_dot_v
|
||||
psi_cas_energy = 0.d0
|
||||
|
||||
|
||||
if (is_complex) then
|
||||
complex*16 :: hij_c
|
||||
do k = 1, N_states
|
||||
norm = 0.d0
|
||||
do i = 1, N_det_cas_complex
|
||||
norm += cdabs(psi_cas_coef_complex(i,k) * psi_cas_coef_complex(i,k))
|
||||
do j = 1, N_det_cas_complex
|
||||
!TODO: accum imag parts to ensure that sum is zero?
|
||||
psi_cas_energy(k) += dble(dconjg(psi_cas_coef_complex(i,k)) * psi_cas_coef_complex(j,k) * H_matrix_cas_complex(i,j))
|
||||
enddo
|
||||
enddo
|
||||
psi_cas_energy(k) = psi_cas_energy(k) /norm
|
||||
enddo
|
||||
else
|
||||
do k = 1, N_states
|
||||
norm = 0.d0
|
||||
do i = 1, N_det_cas
|
||||
@ -161,6 +174,7 @@ END_PROVIDER
|
||||
enddo
|
||||
psi_cas_energy(k) = psi_cas_energy(k) /norm
|
||||
enddo
|
||||
endif
|
||||
|
||||
END_PROVIDER
|
||||
|
||||
|
145
src/determinants/psi_cas_cplx.irp.f
Normal file
145
src/determinants/psi_cas_cplx.irp.f
Normal file
@ -0,0 +1,145 @@
|
||||
use bitmasks
|
||||
|
||||
BEGIN_PROVIDER [ integer(bit_kind), psi_cas_complex, (N_int,2,psi_det_size) ]
|
||||
&BEGIN_PROVIDER [ complex*16, psi_cas_coef_complex, (psi_det_size,n_states) ]
|
||||
&BEGIN_PROVIDER [ integer, idx_cas_complex, (psi_det_size) ]
|
||||
&BEGIN_PROVIDER [ integer, N_det_cas_complex ]
|
||||
implicit none
|
||||
BEGIN_DOC
|
||||
! |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.
|
||||
END_DOC
|
||||
integer :: i, k, l
|
||||
logical :: good
|
||||
n_det_cas_complex = 0
|
||||
do i=1,N_det
|
||||
do l = 1, N_states
|
||||
psi_cas_coef_complex(i,l) = (0.d0,0.d0)
|
||||
enddo
|
||||
good = .True.
|
||||
do k=1,N_int
|
||||
good = good .and. ( &
|
||||
iand(not(act_bitmask(k,1)), psi_det(k,1,i)) == &
|
||||
iand(not(act_bitmask(k,1)), hf_bitmask(k,1)) ) .and. ( &
|
||||
iand(not(act_bitmask(k,2)), psi_det(k,2,i)) == &
|
||||
iand(not(act_bitmask(k,2)), hf_bitmask(k,2)) )
|
||||
enddo
|
||||
if (good) then
|
||||
exit
|
||||
endif
|
||||
if (good) then
|
||||
n_det_cas_complex = n_det_cas_complex+1
|
||||
do k=1,N_int
|
||||
psi_cas_complex(k,1,n_det_cas_complex) = psi_det(k,1,i)
|
||||
psi_cas_complex(k,2,n_det_cas_complex) = psi_det(k,2,i)
|
||||
enddo
|
||||
idx_cas(n_det_cas_complex) = i
|
||||
do k=1,N_states
|
||||
psi_cas_coef_complex(n_det_cas_complex,k) = psi_coef_complex(i,k)
|
||||
enddo
|
||||
endif
|
||||
enddo
|
||||
call write_int(6,n_det_cas_complex, 'Number of determinants in the CAS')
|
||||
|
||||
END_PROVIDER
|
||||
|
||||
|
||||
BEGIN_PROVIDER [ integer(bit_kind), psi_cas_sorted_bit_complex, (N_int,2,psi_det_size) ]
|
||||
&BEGIN_PROVIDER [ complex*16, psi_cas_coef_sorted_bit_complex, (psi_det_size,N_states) ]
|
||||
implicit none
|
||||
BEGIN_DOC
|
||||
! |CAS| determinants sorted to accelerate the search of a random determinant in the wave
|
||||
! function.
|
||||
END_DOC
|
||||
call sort_dets_by_det_search_key_complex(n_det_cas_complex, psi_cas_complex, psi_cas_coef_complex, size(psi_cas_coef_complex,1), &
|
||||
psi_cas_sorted_bit_complex, psi_cas_coef_sorted_bit_complex, N_states)
|
||||
|
||||
END_PROVIDER
|
||||
|
||||
|
||||
|
||||
BEGIN_PROVIDER [ integer(bit_kind), psi_non_cas_complex, (N_int,2,psi_det_size) ]
|
||||
&BEGIN_PROVIDER [ complex*16, psi_non_cas_coef_complex, (psi_det_size,n_states) ]
|
||||
&BEGIN_PROVIDER [ integer, idx_non_cas_complex, (psi_det_size) ]
|
||||
&BEGIN_PROVIDER [ integer, N_det_non_cas_complex ]
|
||||
implicit none
|
||||
BEGIN_DOC
|
||||
! Set of determinants which are not part of the |CAS|, defined from the application
|
||||
! of the |CAS| bitmask on the determinants.
|
||||
! idx_non_cas gives the indice of the determinant in psi_det.
|
||||
END_DOC
|
||||
integer :: i_non_cas,j,k
|
||||
integer :: degree
|
||||
logical :: in_cas
|
||||
i_non_cas =0
|
||||
do k=1,N_det
|
||||
in_cas = .False.
|
||||
do j=1,N_det_cas_complex
|
||||
call get_excitation_degree(psi_cas_complex(1,1,j), psi_det(1,1,k), degree, N_int)
|
||||
if (degree == 0) then
|
||||
in_cas = .True.
|
||||
exit
|
||||
endif
|
||||
enddo
|
||||
if (.not.in_cas) then
|
||||
double precision :: hij
|
||||
i_non_cas += 1
|
||||
do j=1,N_int
|
||||
psi_non_cas_complex(j,1,i_non_cas) = psi_det(j,1,k)
|
||||
psi_non_cas_complex(j,2,i_non_cas) = psi_det(j,2,k)
|
||||
enddo
|
||||
do j=1,N_states
|
||||
psi_non_cas_coef_complex(i_non_cas,j) = psi_coef_complex(k,j)
|
||||
enddo
|
||||
idx_non_cas_complex(i_non_cas) = k
|
||||
endif
|
||||
enddo
|
||||
N_det_non_cas_complex = i_non_cas
|
||||
END_PROVIDER
|
||||
|
||||
BEGIN_PROVIDER [ integer(bit_kind), psi_non_cas_sorted_bit_complex, (N_int,2,psi_det_size) ]
|
||||
&BEGIN_PROVIDER [ complex*16, psi_non_cas_coef_sorted_bit_complex, (psi_det_size,N_states) ]
|
||||
implicit none
|
||||
BEGIN_DOC
|
||||
! |CAS| determinants sorted to accelerate the search of a random determinant in the wave
|
||||
! function.
|
||||
END_DOC
|
||||
!TODO: should this be n_det_non_cas_complex?
|
||||
call sort_dets_by_det_search_key_complex(N_det_cas_complex, psi_non_cas_complex, psi_non_cas_coef_complex, size(psi_non_cas_coef_complex,1), &
|
||||
psi_non_cas_sorted_bit_complex, psi_non_cas_coef_sorted_bit_complex, N_states)
|
||||
|
||||
END_PROVIDER
|
||||
|
||||
|
||||
BEGIN_PROVIDER [complex*16, H_matrix_cas_complex, (N_det_cas_complex,N_det_cas_complex)]
|
||||
implicit none
|
||||
integer :: i,j
|
||||
complex*16 :: hij
|
||||
do i = 1, N_det_cas_complex
|
||||
do j = 1, N_det_cas_complex
|
||||
call i_h_j_complex(psi_cas_complex(1,1,i),psi_cas_complex(1,1,j),N_int,hij)
|
||||
H_matrix_cas_complex(i,j) = hij
|
||||
enddo
|
||||
enddo
|
||||
END_PROVIDER
|
||||
|
||||
BEGIN_PROVIDER [complex*16, psi_coef_cas_diagonalized_complex, (N_det_cas_complex,N_states)]
|
||||
&BEGIN_PROVIDER [double precision, psi_cas_energy_diagonalized_complex, (N_states)]
|
||||
implicit none
|
||||
integer :: i,j
|
||||
double precision, allocatable :: eigenvalues(:)
|
||||
complex*16, allocatable :: eigenvectors(:,:)
|
||||
allocate (eigenvectors(size(H_matrix_cas,1),N_det_cas))
|
||||
allocate (eigenvalues(N_det_cas))
|
||||
call lapack_diag_complex(eigenvalues,eigenvectors, &
|
||||
H_matrix_cas_complex,size(H_matrix_cas_complex,1),N_det_cas_complex)
|
||||
do i = 1, N_states
|
||||
psi_cas_energy_diagonalized_complex(i) = eigenvalues(i)
|
||||
do j = 1, N_det_cas_complex
|
||||
psi_coef_cas_diagonalized_complex(j,i) = eigenvectors(j,i)
|
||||
enddo
|
||||
enddo
|
||||
|
||||
|
||||
END_PROVIDER
|
||||
|
@ -9,7 +9,26 @@
|
||||
! computed using the :c:data:`one_e_dm_mo_alpha` +
|
||||
! :c:data:`one_e_dm_mo_beta` and :c:data:`mo_one_e_integrals`
|
||||
END_DOC
|
||||
double precision :: accu
|
||||
psi_energy_h_core = 0.d0
|
||||
if (is_complex) then
|
||||
do i = 1, N_states
|
||||
do j = 1, mo_num
|
||||
do k = 1, mo_num
|
||||
psi_energy_h_core(i) += dble(mo_one_e_integrals_complex(k,j) * &
|
||||
(one_e_dm_mo_alpha_complex(j,k,i) + one_e_dm_mo_beta_complex(j,k,i)))
|
||||
enddo
|
||||
enddo
|
||||
enddo
|
||||
do i = 1, N_states
|
||||
accu = 0.d0
|
||||
do j = 1, mo_num
|
||||
accu += dble(one_e_dm_mo_alpha_complex(j,j,i) + one_e_dm_mo_beta_complex(j,j,i))
|
||||
enddo
|
||||
accu = (elec_alpha_num + elec_beta_num ) / accu
|
||||
psi_energy_h_core(i) = psi_energy_h_core(i) * accu
|
||||
enddo
|
||||
else
|
||||
do i = 1, N_states
|
||||
do j = 1, mo_num
|
||||
do k = 1, mo_num
|
||||
@ -17,7 +36,6 @@
|
||||
enddo
|
||||
enddo
|
||||
enddo
|
||||
double precision :: accu
|
||||
do i = 1, N_states
|
||||
accu = 0.d0
|
||||
do j = 1, mo_num
|
||||
@ -26,4 +44,5 @@
|
||||
accu = (elec_alpha_num + elec_beta_num ) / accu
|
||||
psi_energy_h_core(i) = psi_energy_h_core(i) * accu
|
||||
enddo
|
||||
endif
|
||||
END_PROVIDER
|
||||
|
@ -27,15 +27,15 @@
|
||||
ref_bitmask_two_e_energy = 0.d0
|
||||
|
||||
do i = 1, elec_beta_num
|
||||
ref_bitmask_energy += mo_one_e_integrals(occ(i,1),occ(i,1)) + mo_one_e_integrals(occ(i,2),occ(i,2))
|
||||
ref_bitmask_kinetic_energy += mo_kinetic_integrals(occ(i,1),occ(i,1)) + mo_kinetic_integrals(occ(i,2),occ(i,2))
|
||||
ref_bitmask_n_e_energy += mo_integrals_n_e(occ(i,1),occ(i,1)) + mo_integrals_n_e(occ(i,2),occ(i,2))
|
||||
ref_bitmask_energy += mo_one_e_integrals_diag(occ(i,1)) + mo_one_e_integrals_diag(occ(i,2))
|
||||
ref_bitmask_kinetic_energy += mo_kinetic_integrals_diag(occ(i,1)) + mo_kinetic_integrals_diag(occ(i,2))
|
||||
ref_bitmask_n_e_energy += mo_integrals_n_e_diag(occ(i,1)) + mo_integrals_n_e_diag(occ(i,2))
|
||||
enddo
|
||||
|
||||
do i = elec_beta_num+1,elec_alpha_num
|
||||
ref_bitmask_energy += mo_one_e_integrals(occ(i,1),occ(i,1))
|
||||
ref_bitmask_kinetic_energy += mo_kinetic_integrals(occ(i,1),occ(i,1))
|
||||
ref_bitmask_n_e_energy += mo_integrals_n_e(occ(i,1),occ(i,1))
|
||||
ref_bitmask_energy += mo_one_e_integrals_diag(occ(i,1))
|
||||
ref_bitmask_kinetic_energy += mo_kinetic_integrals_diag(occ(i,1))
|
||||
ref_bitmask_n_e_energy += mo_integrals_n_e_diag(occ(i,1))
|
||||
enddo
|
||||
|
||||
do j= 1, elec_alpha_num
|
||||
|
@ -98,7 +98,11 @@ BEGIN_PROVIDER [ double precision, s2_values, (N_states) ]
|
||||
! array of the averaged values of the S^2 operator on the various states
|
||||
END_DOC
|
||||
integer :: i
|
||||
if (is_complex) then
|
||||
call u_0_S2_u_0_complex(s2_values,psi_coef_complex,n_det,psi_det,N_int,N_states,psi_det_size)
|
||||
else
|
||||
call u_0_S2_u_0(s2_values,psi_coef,n_det,psi_det,N_int,N_states,psi_det_size)
|
||||
endif
|
||||
|
||||
END_PROVIDER
|
||||
|
||||
|
288
src/determinants/s2_cplx.irp.f
Normal file
288
src/determinants/s2_cplx.irp.f
Normal file
@ -0,0 +1,288 @@
|
||||
subroutine u_0_S2_u_0_complex(e_0,u_0,n,keys_tmp,Nint,N_st,sze_8)
|
||||
use bitmasks
|
||||
implicit none
|
||||
BEGIN_DOC
|
||||
! Computes e_0 = <u_0|S2|u_0>/<u_0|u_0>
|
||||
!
|
||||
! n : number of determinants
|
||||
!
|
||||
END_DOC
|
||||
integer, intent(in) :: n,Nint, N_st, sze_8
|
||||
double precision, intent(out) :: e_0(N_st)
|
||||
complex*16, intent(in) :: u_0(sze_8,N_st)
|
||||
integer(bit_kind),intent(in) :: keys_tmp(Nint,2,n)
|
||||
|
||||
complex*16, allocatable :: v_0(:,:)
|
||||
double precision :: u_dot_u_complex
|
||||
complex*16 :: u_dot_v_complex
|
||||
integer :: i,j
|
||||
allocate (v_0(sze_8,N_st))
|
||||
|
||||
call s2_u_0_nstates_complex(v_0,u_0,n,keys_tmp,Nint,N_st,sze_8)
|
||||
do i=1,N_st
|
||||
e_0(i) = dble(u_dot_v_complex(u_0(1,i),v_0(1,i),n))/u_dot_u_complex(u_0(1,i),n) + S_z2_Sz
|
||||
enddo
|
||||
end
|
||||
|
||||
|
||||
|
||||
subroutine S2_u_0_complex(v_0,u_0,n,keys_tmp,Nint)
|
||||
use bitmasks
|
||||
implicit none
|
||||
BEGIN_DOC
|
||||
! Computes v_0 = S^2|u_0>
|
||||
!
|
||||
! n : number of determinants
|
||||
!
|
||||
END_DOC
|
||||
integer, intent(in) :: n,Nint
|
||||
complex*16, intent(out) :: v_0(n)
|
||||
complex*16, intent(in) :: u_0(n)
|
||||
integer(bit_kind),intent(in) :: keys_tmp(Nint,2,n)
|
||||
call s2_u_0_nstates_complex(v_0,u_0,n,keys_tmp,Nint,1,n)
|
||||
end
|
||||
|
||||
subroutine S2_u_0_nstates_complex(v_0,u_0,n,keys_tmp,Nint,N_st,sze_8)
|
||||
use bitmasks
|
||||
implicit none
|
||||
BEGIN_DOC
|
||||
! Computes v_0 = S^2|u_0>
|
||||
!
|
||||
! n : number of determinants
|
||||
!
|
||||
END_DOC
|
||||
integer, intent(in) :: N_st,n,Nint, sze_8
|
||||
complex*16, intent(out) :: v_0(sze_8,N_st)
|
||||
complex*16, intent(in) :: u_0(sze_8,N_st)
|
||||
integer(bit_kind),intent(in) :: keys_tmp(Nint,2,n)
|
||||
double precision :: s2_tmp
|
||||
complex*16, allocatable :: vt(:,:)
|
||||
integer :: i,j,k,l, jj,ii
|
||||
integer :: i0, j0
|
||||
|
||||
integer, allocatable :: shortcut(:,:), sort_idx(:,:)
|
||||
integer(bit_kind), allocatable :: sorted(:,:,:), version(:,:,:)
|
||||
integer(bit_kind) :: sorted_i(Nint)
|
||||
|
||||
integer :: sh, sh2, ni, exa, ext, org_i, org_j, endi, istate
|
||||
|
||||
|
||||
ASSERT (Nint > 0)
|
||||
ASSERT (Nint == N_int)
|
||||
ASSERT (n>0)
|
||||
PROVIDE ref_bitmask_energy
|
||||
|
||||
allocate (shortcut(0:n+1,2), sort_idx(n,2), sorted(Nint,n,2), version(Nint,n,2))
|
||||
v_0 = (0.d0,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,s2_tmp,j,k,jj,vt,ii,sh,sh2,ni,exa,ext,org_i,org_j,endi,sorted_i,istate)&
|
||||
!$OMP SHARED(n,u_0,keys_tmp,Nint,v_0,sorted,shortcut,sort_idx,version,N_st,sze_8)
|
||||
allocate(vt(sze_8,N_st))
|
||||
vt = (0.d0,0.d0)
|
||||
|
||||
do sh=1,shortcut(0,1)
|
||||
!$OMP DO SCHEDULE(static,1)
|
||||
do sh2=sh,shortcut(0,1)
|
||||
exa = 0
|
||||
do ni=1,Nint
|
||||
exa = exa + popcnt(xor(version(ni,sh,1), version(ni,sh2,1)))
|
||||
end do
|
||||
if(exa > 2) then
|
||||
cycle
|
||||
end if
|
||||
|
||||
do i=shortcut(sh,1),shortcut(sh+1,1)-1
|
||||
org_i = sort_idx(i,1)
|
||||
if(sh==sh2) then
|
||||
endi = i-1
|
||||
else
|
||||
endi = shortcut(sh2+1,1)-1
|
||||
end if
|
||||
do ni=1,Nint
|
||||
sorted_i(ni) = sorted(ni,i,1)
|
||||
enddo
|
||||
|
||||
do j=shortcut(sh2,1),endi
|
||||
org_j = sort_idx(j,1)
|
||||
ext = exa
|
||||
do ni=1,Nint
|
||||
ext = ext + popcnt(xor(sorted_i(ni), sorted(ni,j,1)))
|
||||
end do
|
||||
if(ext <= 4) then
|
||||
call get_s2(keys_tmp(1,1,org_i),keys_tmp(1,1,org_j),Nint,s2_tmp)
|
||||
do istate=1,N_st
|
||||
vt (org_i,istate) = vt (org_i,istate) + s2_tmp*u_0(org_j,istate)
|
||||
vt (org_j,istate) = vt (org_j,istate) + s2_tmp*u_0(org_i,istate)
|
||||
enddo
|
||||
endif
|
||||
enddo
|
||||
enddo
|
||||
enddo
|
||||
!$OMP END DO NOWAIT
|
||||
enddo
|
||||
|
||||
do sh=1,shortcut(0,2)
|
||||
!$OMP DO
|
||||
do i=shortcut(sh,2),shortcut(sh+1,2)-1
|
||||
org_i = sort_idx(i,2)
|
||||
do j=shortcut(sh,2),i-1
|
||||
org_j = sort_idx(j,2)
|
||||
ext = 0
|
||||
do ni=1,Nint
|
||||
ext = ext + popcnt(xor(sorted(ni,i,2), sorted(ni,j,2)))
|
||||
end do
|
||||
if(ext == 4) then
|
||||
call get_s2(keys_tmp(1,1,org_i),keys_tmp(1,1,org_j),Nint,s2_tmp)
|
||||
do istate=1,N_st
|
||||
vt (org_i,istate) = vt (org_i,istate) + s2_tmp*u_0(org_j,istate)
|
||||
vt (org_j,istate) = vt (org_j,istate) + s2_tmp*u_0(org_i,istate)
|
||||
enddo
|
||||
end if
|
||||
end do
|
||||
end do
|
||||
!$OMP END DO NOWAIT
|
||||
enddo
|
||||
!$OMP BARRIER
|
||||
|
||||
do istate=1,N_st
|
||||
do i=n,1,-1
|
||||
!$OMP ATOMIC
|
||||
v_0(i,istate) = v_0(i,istate) + vt(i,istate)
|
||||
enddo
|
||||
enddo
|
||||
|
||||
deallocate(vt)
|
||||
!$OMP END PARALLEL
|
||||
|
||||
do i=1,n
|
||||
call get_s2(keys_tmp(1,1,i),keys_tmp(1,1,i),Nint,s2_tmp)
|
||||
do istate=1,N_st
|
||||
v_0(i,istate) += s2_tmp * u_0(i,istate)
|
||||
enddo
|
||||
enddo
|
||||
|
||||
deallocate (shortcut, sort_idx, sorted, version)
|
||||
end
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
subroutine get_uJ_s2_uI_complex(psi_keys_tmp,psi_coefs_tmp,n,nmax_coefs,nmax_keys,s2,nstates)
|
||||
!todo: modify/implement for complex
|
||||
print*,irp_here,' not implemented for complex'
|
||||
stop -1
|
||||
! implicit none
|
||||
! use bitmasks
|
||||
! integer, intent(in) :: n,nmax_coefs,nmax_keys,nstates
|
||||
! integer(bit_kind), intent(in) :: psi_keys_tmp(N_int,2,nmax_keys)
|
||||
! complex*16, intent(in) :: psi_coefs_tmp(nmax_coefs,nstates)
|
||||
! complex*16, intent(out) :: s2(nstates,nstates)
|
||||
! double precision :: s2_tmp
|
||||
! complex*16 :: accu
|
||||
! integer :: i,j,l,jj,ll,kk
|
||||
! integer, allocatable :: idx(:)
|
||||
! BEGIN_DOC
|
||||
! ! returns the matrix elements of S^2 "s2(i,j)" between the "nstates" states
|
||||
! ! psi_coefs_tmp(:,i) and psi_coefs_tmp(:,j)
|
||||
! END_DOC
|
||||
! s2 = (0.d0,0.d0)
|
||||
! do ll = 1, nstates
|
||||
! do jj = 1, nstates
|
||||
! accu = (0.d0,0.d0)
|
||||
! !$OMP PARALLEL DEFAULT(NONE) &
|
||||
! !$OMP PRIVATE (i,j,kk,idx,s2_tmp) &
|
||||
! !$OMP SHARED (ll,jj,psi_keys_tmp,psi_coefs_tmp,N_int,n,nstates)&
|
||||
! !$OMP REDUCTION(+:accu)
|
||||
! allocate(idx(0:n))
|
||||
! !$OMP DO SCHEDULE(dynamic)
|
||||
! do i = n,1,-1 ! Better OMP scheduling
|
||||
! call get_s2(psi_keys_tmp(1,1,i),psi_keys_tmp(1,1,i),N_int,s2_tmp)
|
||||
! accu += dconjg(psi_coefs_tmp(i,ll)) * s2_tmp * psi_coefs_tmp(i,jj)
|
||||
! call filter_connected(psi_keys_tmp,psi_keys_tmp(1,1,i),N_int,i-1,idx)
|
||||
! do kk=1,idx(0)
|
||||
! j = idx(kk)
|
||||
! call get_s2(psi_keys_tmp(1,1,i),psi_keys_tmp(1,1,j),N_int,s2_tmp)
|
||||
! accu += dconjg(psi_coefs_tmp(i,ll)) * s2_tmp * psi_coefs_tmp(j,jj) + psi_coefs_tmp(i,jj) * s2_tmp * psi_coefs_tmp(j,ll)
|
||||
! enddo
|
||||
! enddo
|
||||
! !$OMP END DO
|
||||
! deallocate(idx)
|
||||
! !$OMP END PARALLEL
|
||||
! s2(ll,jj) += accu
|
||||
! enddo
|
||||
! enddo
|
||||
! do i = 1, nstates
|
||||
! do j =i+1,nstates
|
||||
! accu = 0.5d0 * (s2(i,j) + s2(j,i))
|
||||
! s2(i,j) = accu
|
||||
! s2(j,i) = accu
|
||||
! enddo
|
||||
! enddo
|
||||
end
|
||||
|
||||
|
||||
subroutine i_S2_psi_minilist_complex(key,keys,idx_key,N_minilist,coef,Nint,Ndet,Ndet_max,Nstate,i_S2_psi_array)
|
||||
!todo: modify/implement for complex
|
||||
print*,irp_here,' not implemented for complex'
|
||||
stop -1
|
||||
! use bitmasks
|
||||
! implicit none
|
||||
! integer, intent(in) :: Nint, Ndet,Ndet_max,Nstate,idx_key(Ndet), N_minilist
|
||||
! integer(bit_kind), intent(in) :: keys(Nint,2,Ndet)
|
||||
! integer(bit_kind), intent(in) :: key(Nint,2)
|
||||
! double precision, intent(in) :: coef(Ndet_max,Nstate)
|
||||
! double precision, intent(out) :: i_S2_psi_array(Nstate)
|
||||
!
|
||||
! integer :: i, ii,j, i_in_key, i_in_coef
|
||||
! double precision :: phase
|
||||
! integer :: exc(0:2,2,2)
|
||||
! double precision :: s2ij
|
||||
! integer :: idx(0:Ndet)
|
||||
! BEGIN_DOC
|
||||
!! Computes $\langle i|S^2|\Psi \rangle = \sum_J c_J \langle i|S^2|J \rangle$.
|
||||
!!
|
||||
!! Uses filter_connected_i_H_psi0 to get all the $|J\rangle$ to which $|i\rangle$
|
||||
!! is connected. The $|J\rangle$ are searched in short pre-computed lists.
|
||||
! END_DOC
|
||||
!
|
||||
! ASSERT (Nint > 0)
|
||||
! ASSERT (N_int == Nint)
|
||||
! ASSERT (Nstate > 0)
|
||||
! ASSERT (Ndet > 0)
|
||||
! ASSERT (Ndet_max >= Ndet)
|
||||
! i_S2_psi_array = 0.d0
|
||||
!
|
||||
! call filter_connected_i_H_psi0(keys,key,Nint,N_minilist,idx)
|
||||
! if (Nstate == 1) then
|
||||
!
|
||||
! do ii=1,idx(0)
|
||||
! i_in_key = idx(ii)
|
||||
! i_in_coef = idx_key(idx(ii))
|
||||
! !DIR$ FORCEINLINE
|
||||
! call get_s2(keys(1,1,i_in_key),key,Nint,s2ij)
|
||||
! ! TODO : Cache misses
|
||||
! i_S2_psi_array(1) = i_S2_psi_array(1) + coef(i_in_coef,1)*s2ij
|
||||
! enddo
|
||||
!
|
||||
! else
|
||||
!
|
||||
! do ii=1,idx(0)
|
||||
! i_in_key = idx(ii)
|
||||
! i_in_coef = idx_key(idx(ii))
|
||||
! !DIR$ FORCEINLINE
|
||||
! call get_s2(keys(1,1,i_in_key),key,Nint,s2ij)
|
||||
! do j = 1, Nstate
|
||||
! i_S2_psi_array(j) = i_S2_psi_array(j) + coef(i_in_coef,j)*s2ij
|
||||
! enddo
|
||||
! enddo
|
||||
!
|
||||
! endif
|
||||
!
|
||||
end
|
@ -133,4 +133,138 @@ BEGIN_PROVIDER [double precision, fock_wee_closed_shell, (mo_num, mo_num) ]
|
||||
|
||||
END_PROVIDER
|
||||
|
||||
subroutine single_excitation_wee_complex(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)
|
||||
complex*16, 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_wee_closed_shell_complex(h,p)
|
||||
! holes :: direct terms
|
||||
do i0 = 1, n_occ_ab_hole(1)
|
||||
i = occ_hole(i0,1)
|
||||
hij -= big_array_coulomb_integrals_complex(i,h,p) ! get_mo_two_e_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_complex(i,h,p) !get_mo_two_e_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_complex(i,h,p) ! get_mo_two_e_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_complex(i,h,p)!get_mo_two_e_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_complex(i,h,p) !get_mo_two_e_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_complex(i,h,p)!get_mo_two_e_integral_schwartz(h,i,i,p,mo_integrals_map)
|
||||
enddo
|
||||
hij = hij * phase
|
||||
|
||||
end
|
||||
|
||||
|
||||
BEGIN_PROVIDER [complex*16, fock_wee_closed_shell_complex, (mo_num, mo_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)
|
||||
complex*16 :: accu
|
||||
|
||||
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
|
||||
complex*16 :: array_coulomb(mo_num),array_exchange(mo_num)
|
||||
call bitstring_to_list_ab(key_virt, occ_virt, n_occ_ab_virt, N_int)
|
||||
! docc ---> virt single 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_two_e_integrals_coulomb_ii_complex(i,j,mo_num,array_coulomb,mo_integrals_map,mo_integrals_map_2)
|
||||
call get_mo_two_e_integrals_exch_ii_complex(i,j,mo_num,array_exchange,mo_integrals_map,mo_integrals_map_2)
|
||||
accu = (0.d0,0.d0)
|
||||
do k0 = 1, n_occ_ab(1)
|
||||
k = occ(k0,1)
|
||||
accu += 2.d0 * array_coulomb(k) - array_exchange(k)
|
||||
enddo
|
||||
fock_wee_closed_shell_complex(i,j) = accu
|
||||
fock_wee_closed_shell_complex(j,i) = dconjg(accu)
|
||||
enddo
|
||||
enddo
|
||||
|
||||
! virt ---> virt single 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_two_e_integrals_coulomb_ii_complex(i,j,mo_num,array_coulomb,mo_integrals_map,mo_integrals_map_2)
|
||||
call get_mo_two_e_integrals_exch_ii_complex(i,j,mo_num,array_exchange,mo_integrals_map,mo_integrals_map_2)
|
||||
accu = (0.d0,0.d0)
|
||||
do k0 = 1, n_occ_ab(1)
|
||||
k = occ(k0,1)
|
||||
accu += 2.d0 * array_coulomb(k) - array_exchange(k)
|
||||
enddo
|
||||
fock_wee_closed_shell_complex(i,j) = accu
|
||||
fock_wee_closed_shell_complex(j,i) = dconjg(accu)
|
||||
enddo
|
||||
enddo
|
||||
|
||||
! docc ---> docc single 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_two_e_integrals_coulomb_ii_complex(i,j,mo_num,array_coulomb,mo_integrals_map,mo_integrals_map_2)
|
||||
call get_mo_two_e_integrals_exch_ii_complex(i,j,mo_num,array_exchange,mo_integrals_map,mo_integrals_map_2)
|
||||
accu = (0.d0,0.d0)
|
||||
do k0 = 1, n_occ_ab(1)
|
||||
k = occ(k0,1)
|
||||
accu += 2.d0 * array_coulomb(k) - array_exchange(k)
|
||||
enddo
|
||||
fock_wee_closed_shell_complex(i,j) = accu
|
||||
fock_wee_closed_shell_complex(j,i) = dconjg(accu)
|
||||
enddo
|
||||
enddo
|
||||
|
||||
END_PROVIDER
|
||||
|
||||
|
||||
|
@ -1,7 +1,7 @@
|
||||
use bitmasks
|
||||
BEGIN_PROVIDER [integer(bit_kind), ref_closed_shell_bitmask, (N_int,2)]
|
||||
implicit none
|
||||
integer :: i,i0
|
||||
integer :: i,i0,k
|
||||
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)
|
||||
@ -10,16 +10,24 @@ BEGIN_PROVIDER [integer(bit_kind), ref_closed_shell_bitmask, (N_int,2)]
|
||||
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
|
||||
|
||||
|
||||
if (is_complex) then
|
||||
!todo: check this
|
||||
do k=1,kpt_num
|
||||
call bitstring_to_list_ab(ref_bitmask_kpts(1,1,k),occ,n_occ_ab,N_int)
|
||||
do i0=elec_beta_num_kpts(k)+1,elec_alpha_num_kpts(k)
|
||||
i=occ(i0,1)
|
||||
call clear_bit_to_integer(i,ref_closed_shell_bitmask(1,1),N_int)
|
||||
enddo
|
||||
enddo
|
||||
else
|
||||
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
|
||||
endif
|
||||
END_PROVIDER
|
||||
|
||||
|
||||
BEGIN_PROVIDER [double precision, fock_operator_closed_shell_ref_bitmask, (mo_num, mo_num) ]
|
||||
BEGIN_PROVIDER [double precision, fock_op_cshell_ref_bitmask, (mo_num, mo_num) ]
|
||||
implicit none
|
||||
integer :: i0,j0,i,j,k0,k
|
||||
integer :: n_occ_ab(2)
|
||||
@ -52,8 +60,8 @@ BEGIN_PROVIDER [double precision, fock_operator_closed_shell_ref_bitmask, (mo_nu
|
||||
k = occ(k0,1)
|
||||
accu += 2.d0 * array_coulomb(k) - array_exchange(k)
|
||||
enddo
|
||||
fock_operator_closed_shell_ref_bitmask(i,j) = accu + mo_one_e_integrals(i,j)
|
||||
fock_operator_closed_shell_ref_bitmask(j,i) = accu + mo_one_e_integrals(i,j)
|
||||
fock_op_cshell_ref_bitmask(i,j) = accu + mo_one_e_integrals(i,j)
|
||||
fock_op_cshell_ref_bitmask(j,i) = accu + mo_one_e_integrals(i,j)
|
||||
enddo
|
||||
enddo
|
||||
|
||||
@ -69,8 +77,8 @@ BEGIN_PROVIDER [double precision, fock_operator_closed_shell_ref_bitmask, (mo_nu
|
||||
k = occ(k0,1)
|
||||
accu += 2.d0 * array_coulomb(k) - array_exchange(k)
|
||||
enddo
|
||||
fock_operator_closed_shell_ref_bitmask(i,j) = accu+ mo_one_e_integrals(i,j)
|
||||
fock_operator_closed_shell_ref_bitmask(j,i) = accu+ mo_one_e_integrals(i,j)
|
||||
fock_op_cshell_ref_bitmask(i,j) = accu+ mo_one_e_integrals(i,j)
|
||||
fock_op_cshell_ref_bitmask(j,i) = accu+ mo_one_e_integrals(i,j)
|
||||
enddo
|
||||
enddo
|
||||
|
||||
@ -86,8 +94,8 @@ BEGIN_PROVIDER [double precision, fock_operator_closed_shell_ref_bitmask, (mo_nu
|
||||
k = occ(k0,1)
|
||||
accu += 2.d0 * array_coulomb(k) - array_exchange(k)
|
||||
enddo
|
||||
fock_operator_closed_shell_ref_bitmask(i,j) = accu+ mo_one_e_integrals(i,j)
|
||||
fock_operator_closed_shell_ref_bitmask(j,i) = accu+ mo_one_e_integrals(i,j)
|
||||
fock_op_cshell_ref_bitmask(i,j) = accu+ mo_one_e_integrals(i,j)
|
||||
fock_op_cshell_ref_bitmask(j,i) = accu+ mo_one_e_integrals(i,j)
|
||||
enddo
|
||||
enddo
|
||||
deallocate(array_coulomb,array_exchange)
|
||||
@ -123,7 +131,7 @@ subroutine get_single_excitation_from_fock(det_1,det_2,h,p,spin,phase,hij)
|
||||
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)
|
||||
hij = fock_op_cshell_ref_bitmask(h,p)
|
||||
! holes :: direct terms
|
||||
do i0 = 1, n_occ_ab_hole(1)
|
||||
i = occ_hole(i0,1)
|
||||
@ -159,3 +167,349 @@ subroutine get_single_excitation_from_fock(det_1,det_2,h,p,spin,phase,hij)
|
||||
|
||||
end
|
||||
|
||||
!============================================!
|
||||
! !
|
||||
! complex !
|
||||
! !
|
||||
!============================================!
|
||||
|
||||
BEGIN_PROVIDER [complex*16, fock_op_cshell_ref_bitmask_cplx, (mo_num, mo_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)
|
||||
complex*16 :: accu
|
||||
|
||||
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
|
||||
complex*16, allocatable :: array_coulomb(:),array_exchange(:)
|
||||
allocate (array_coulomb(mo_num),array_exchange(mo_num))
|
||||
call bitstring_to_list_ab(key_virt, occ_virt, n_occ_ab_virt, N_int)
|
||||
! docc ---> virt single 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)
|
||||
! <ia|ja>
|
||||
call get_mo_two_e_integrals_coulomb_ii_complex(i,j,mo_num,array_coulomb,mo_integrals_map,mo_integrals_map_2)
|
||||
! <ia|aj>
|
||||
call get_mo_two_e_integrals_exch_ii_complex(i,j,mo_num,array_exchange,mo_integrals_map,mo_integrals_map_2)
|
||||
accu = (0.d0,0.d0)
|
||||
do k0 = 1, n_occ_ab(1)
|
||||
k = occ(k0,1)
|
||||
accu += 2.d0 * array_coulomb(k) - array_exchange(k)
|
||||
enddo
|
||||
fock_op_cshell_ref_bitmask_cplx(i,j) = accu + mo_one_e_integrals_complex(i,j)
|
||||
!fock_op_cshell_ref_bitmask_cplx(j,i) = dconjg(accu) + mo_one_e_integrals_complex(j,i)
|
||||
fock_op_cshell_ref_bitmask_cplx(j,i) = dconjg(fock_op_cshell_ref_bitmask_cplx(i,j))
|
||||
enddo
|
||||
enddo
|
||||
|
||||
! virt ---> virt single 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_two_e_integrals_coulomb_ii_complex(i,j,mo_num,array_coulomb,mo_integrals_map,mo_integrals_map_2)
|
||||
call get_mo_two_e_integrals_exch_ii_complex(i,j,mo_num,array_exchange,mo_integrals_map,mo_integrals_map_2)
|
||||
accu = (0.d0,0.d0)
|
||||
do k0 = 1, n_occ_ab(1)
|
||||
k = occ(k0,1)
|
||||
accu += 2.d0 * array_coulomb(k) - array_exchange(k)
|
||||
enddo
|
||||
fock_op_cshell_ref_bitmask_cplx(i,j) = accu+ mo_one_e_integrals_complex(i,j)
|
||||
fock_op_cshell_ref_bitmask_cplx(j,i) = dconjg(accu)+ mo_one_e_integrals_complex(j,i)
|
||||
enddo
|
||||
enddo
|
||||
|
||||
! docc ---> docc single 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_two_e_integrals_coulomb_ii_complex(i,j,mo_num,array_coulomb,mo_integrals_map,mo_integrals_map_2)
|
||||
call get_mo_two_e_integrals_exch_ii_complex(i,j,mo_num,array_exchange,mo_integrals_map,mo_integrals_map_2)
|
||||
accu = (0.d0,0.d0)
|
||||
do k0 = 1, n_occ_ab(1)
|
||||
k = occ(k0,1)
|
||||
accu += 2.d0 * array_coulomb(k) - array_exchange(k)
|
||||
enddo
|
||||
fock_op_cshell_ref_bitmask_cplx(i,j) = accu+ mo_one_e_integrals_complex(i,j)
|
||||
fock_op_cshell_ref_bitmask_cplx(j,i) = dconjg(accu)+ mo_one_e_integrals_complex(j,i)
|
||||
enddo
|
||||
enddo
|
||||
deallocate(array_coulomb,array_exchange)
|
||||
|
||||
END_PROVIDER
|
||||
|
||||
subroutine get_single_excitation_from_fock_complex(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)
|
||||
complex*16, 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
|
||||
complex*16 :: buffer_c(mo_num),buffer_x(mo_num)
|
||||
do i=1, mo_num
|
||||
buffer_c(i) = big_array_coulomb_integrals_complex(i,h,p)
|
||||
buffer_x(i) = big_array_exchange_integrals_complex(i,h,p)
|
||||
enddo
|
||||
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_op_cshell_ref_bitmask_cplx(h,p)
|
||||
! holes :: direct terms
|
||||
do i0 = 1, n_occ_ab_hole(1)
|
||||
i = occ_hole(i0,1)
|
||||
hij -= buffer_c(i)
|
||||
enddo
|
||||
do i0 = 1, n_occ_ab_hole(2)
|
||||
i = occ_hole(i0,2)
|
||||
hij -= buffer_c(i)
|
||||
enddo
|
||||
|
||||
! holes :: exchange terms
|
||||
do i0 = 1, n_occ_ab_hole(spin)
|
||||
i = occ_hole(i0,spin)
|
||||
hij += buffer_x(i)
|
||||
enddo
|
||||
|
||||
! particles :: direct terms
|
||||
do i0 = 1, n_occ_ab_partcl(1)
|
||||
i = occ_partcl(i0,1)
|
||||
hij += buffer_c(i)
|
||||
enddo
|
||||
do i0 = 1, n_occ_ab_partcl(2)
|
||||
i = occ_partcl(i0,2)
|
||||
hij += buffer_c(i)
|
||||
enddo
|
||||
|
||||
! particles :: exchange terms
|
||||
do i0 = 1, n_occ_ab_partcl(spin)
|
||||
i = occ_partcl(i0,spin)
|
||||
hij -= buffer_x(i)
|
||||
enddo
|
||||
hij = hij * phase
|
||||
|
||||
end
|
||||
|
||||
!============================================!
|
||||
! !
|
||||
! kpts !
|
||||
! !
|
||||
!============================================!
|
||||
|
||||
BEGIN_PROVIDER [integer(bit_kind), ref_closed_shell_bitmask_kpts, (N_int,2,kpt_num)]
|
||||
implicit none
|
||||
integer :: i,k
|
||||
do k = 1, kpt_num
|
||||
do i = 1, N_int
|
||||
ref_closed_shell_bitmask_kpts(i,1,k) = iand(ref_closed_shell_bitmask(i,1),kpts_bitmask(i,k))
|
||||
ref_closed_shell_bitmask_kpts(i,2,k) = iand(ref_closed_shell_bitmask(i,2),kpts_bitmask(i,k))
|
||||
enddo
|
||||
enddo
|
||||
END_PROVIDER
|
||||
|
||||
BEGIN_PROVIDER [complex*16, fock_op_cshell_ref_bitmask_kpts, (mo_num_per_kpt, mo_num_per_kpt,kpt_num) ]
|
||||
implicit none
|
||||
integer :: i0,j0,i,j,k0,k,kblock,kvirt
|
||||
integer :: i_i, i_j, i_k, kocc
|
||||
integer :: n_occ_ab(2,kpt_num)
|
||||
integer :: occ(N_int*bit_kind_size,2,kpt_num)
|
||||
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)
|
||||
complex*16 :: accu
|
||||
complex*16, allocatable :: array_coulomb(:),array_exchange(:)
|
||||
|
||||
do kblock = 1,kpt_num
|
||||
call bitstring_to_list_ab(ref_closed_shell_bitmask_kpts(1,1,kblock), &
|
||||
occ(1,1,kblock), n_occ_ab(1,kblock), N_int)
|
||||
enddo
|
||||
allocate (array_coulomb(mo_num_per_kpt),array_exchange(mo_num_per_kpt))
|
||||
do kblock = 1,kpt_num
|
||||
! get virt orbs for this kpt
|
||||
do i = 1, N_int
|
||||
key_virt(i,1) = iand(full_ijkl_bitmask(i),kpts_bitmask(i,kblock))
|
||||
key_virt(i,2) = iand(full_ijkl_bitmask(i),kpts_bitmask(i,kblock))
|
||||
key_virt(i,1) = xor(key_virt(i,1),ref_closed_shell_bitmask_kpts(i,1,kblock))
|
||||
key_virt(i,2) = xor(key_virt(i,2),ref_closed_shell_bitmask_kpts(i,2,kblock))
|
||||
enddo
|
||||
call bitstring_to_list_ab(key_virt, occ_virt, n_occ_ab_virt, N_int)
|
||||
! docc ---> virt single excitations
|
||||
do i0 = 1, n_occ_ab(1,kblock)
|
||||
i=occ(i0,1,kblock)
|
||||
i_i = mod(i-1,mo_num_per_kpt)+1
|
||||
do j0 = 1, n_occ_ab_virt(1)
|
||||
j = occ_virt(j0,1)
|
||||
i_j = mod(j-1,mo_num_per_kpt)+1
|
||||
accu = (0.d0,0.d0)
|
||||
do kocc = 1,kpt_num
|
||||
! <ia|ja>
|
||||
array_coulomb(1:mo_num_per_kpt) = big_array_coulomb_integrals_kpts(1:mo_num_per_kpt,kocc,i_i,i_j,kblock)
|
||||
! <ia|aj>
|
||||
array_exchange(1:mo_num_per_kpt) = big_array_exchange_integrals_kpts(1:mo_num_per_kpt,kocc,i_i,i_j,kblock)
|
||||
do k0 = 1, n_occ_ab(1,kocc)
|
||||
k = occ(k0,1,kocc)
|
||||
i_k = mod(k-1,mo_num_per_kpt)+1
|
||||
accu += 2.d0 * array_coulomb(i_k) - array_exchange(i_k)
|
||||
enddo
|
||||
enddo
|
||||
fock_op_cshell_ref_bitmask_kpts(i_i,i_j,kblock) = accu + mo_one_e_integrals_kpts(i_i,i_j,kblock)
|
||||
!fock_op_cshell_ref_bitmask_cplx(j,i) = dconjg(accu) + mo_one_e_integrals_complex(j,i)
|
||||
fock_op_cshell_ref_bitmask_kpts(i_j,i_i,kblock) = dconjg(fock_op_cshell_ref_bitmask_kpts(i_i,i_j,kblock))
|
||||
enddo
|
||||
enddo
|
||||
|
||||
! virt ---> virt single excitations
|
||||
do i0 = 1, n_occ_ab_virt(1)
|
||||
i=occ_virt(i0,1)
|
||||
i_i = mod(i-1,mo_num_per_kpt)+1
|
||||
do j0 = 1, n_occ_ab_virt(1)
|
||||
j = occ_virt(j0,1)
|
||||
i_j = mod(j-1,mo_num_per_kpt)+1
|
||||
accu = (0.d0,0.d0)
|
||||
do kocc = 1,kpt_num
|
||||
array_coulomb(1:mo_num_per_kpt) = big_array_coulomb_integrals_kpts(1:mo_num_per_kpt,kocc,i_i,i_j,kblock)
|
||||
array_exchange(1:mo_num_per_kpt) = big_array_exchange_integrals_kpts(1:mo_num_per_kpt,kocc,i_i,i_j,kblock)
|
||||
do k0 = 1, n_occ_ab(1,kocc)
|
||||
k = occ(k0,1,kocc)
|
||||
i_k = mod(k-1,mo_num_per_kpt)+1
|
||||
accu += 2.d0 * array_coulomb(i_k) - array_exchange(i_k)
|
||||
enddo
|
||||
enddo
|
||||
fock_op_cshell_ref_bitmask_kpts(i_i,i_j,kblock) = accu + mo_one_e_integrals_kpts(i_i,i_j,kblock)
|
||||
fock_op_cshell_ref_bitmask_kpts(i_j,i_i,kblock) = dconjg(fock_op_cshell_ref_bitmask_kpts(i_i,i_j,kblock))
|
||||
enddo
|
||||
enddo
|
||||
|
||||
! docc ---> docc single excitations
|
||||
do i0 = 1, n_occ_ab(1,kblock)
|
||||
i=occ(i0,1,kblock)
|
||||
i_i = mod(i-1,mo_num_per_kpt)+1
|
||||
do j0 = 1, n_occ_ab(1,kblock)
|
||||
j = occ(j0,1,kblock)
|
||||
i_j = mod(j-1,mo_num_per_kpt)+1
|
||||
accu = (0.d0,0.d0)
|
||||
do kocc = 1,kpt_num
|
||||
array_coulomb(1:mo_num_per_kpt) = big_array_coulomb_integrals_kpts(1:mo_num_per_kpt,kocc,i_i,i_j,kblock)
|
||||
array_exchange(1:mo_num_per_kpt) = big_array_exchange_integrals_kpts(1:mo_num_per_kpt,kocc,i_i,i_j,kblock)
|
||||
do k0 = 1, n_occ_ab(1,kocc)
|
||||
k = occ(k0,1,kocc)
|
||||
i_k = mod(k-1,mo_num_per_kpt)+1
|
||||
accu += 2.d0 * array_coulomb(i_k) - array_exchange(i_k)
|
||||
enddo
|
||||
enddo
|
||||
fock_op_cshell_ref_bitmask_kpts(i_i,i_j,kblock) = accu + mo_one_e_integrals_kpts(i_i,i_j,kblock)
|
||||
fock_op_cshell_ref_bitmask_kpts(i_j,i_i,kblock) = dconjg(fock_op_cshell_ref_bitmask_kpts(i_i,i_j,kblock))
|
||||
enddo
|
||||
enddo
|
||||
enddo
|
||||
deallocate(array_coulomb,array_exchange)
|
||||
|
||||
END_PROVIDER
|
||||
|
||||
subroutine get_single_excitation_from_fock_kpts(det_1,det_2,ih,ip,spin,phase,hij)
|
||||
use bitmasks
|
||||
!called by i_h_j{,_s2,_single_spin}_complex
|
||||
! ih, ip are indices in total mo list (not per kpt)
|
||||
implicit none
|
||||
integer,intent(in) :: ih,ip,spin
|
||||
double precision, intent(in) :: phase
|
||||
integer(bit_kind), intent(in) :: det_1(N_int,2), det_2(N_int,2)
|
||||
complex*16, 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,h,p
|
||||
integer :: ki,khp
|
||||
complex*16 :: buffer_c(mo_num_per_kpt),buffer_x(mo_num_per_kpt)
|
||||
khp = (ip-1)/mo_num_per_kpt+1
|
||||
p = mod(ip-1,mo_num_per_kpt)+1
|
||||
h = mod(ih-1,mo_num_per_kpt)+1
|
||||
!todo: omp kpts
|
||||
do ki=1,kpt_num
|
||||
do i=1, mo_num_per_kpt
|
||||
!<hi|pi>
|
||||
buffer_c(i) = big_array_coulomb_integrals_kpts(i,ki,h,p,khp)
|
||||
!<hi|ip>
|
||||
buffer_x(i) = big_array_exchange_integrals_kpts(i,ki,h,p,khp)
|
||||
enddo
|
||||
do i = 1, N_int
|
||||
!holes in ref, not in det1
|
||||
!part in det1, not in ref
|
||||
differences(i,1) = iand(xor(det_1(i,1),ref_closed_shell_bitmask(i,1)),kpts_bitmask(i,ki))
|
||||
differences(i,2) = iand(xor(det_1(i,2),ref_closed_shell_bitmask(i,2)),kpts_bitmask(i,ki))
|
||||
!differences(i,1) = xor(det_1(i,1),ref_closed_shell_bitmask_kpts(i,1,ki))
|
||||
!differences(i,2) = xor(det_1(i,2),ref_closed_shell_bitmask_kpts(i,2,ki))
|
||||
hole(i,1) = iand(differences(i,1),ref_closed_shell_bitmask_kpts(i,1,ki))
|
||||
hole(i,2) = iand(differences(i,2),ref_closed_shell_bitmask_kpts(i,2,ki))
|
||||
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_op_cshell_ref_bitmask_kpts(h,p,khp)
|
||||
! holes :: direct terms
|
||||
do i0 = 1, n_occ_ab_hole(1)
|
||||
i = occ_hole(i0,1) - (ki-1)*mo_num_per_kpt
|
||||
hij -= buffer_c(i)
|
||||
enddo
|
||||
do i0 = 1, n_occ_ab_hole(2)
|
||||
i = occ_hole(i0,2) - (ki-1)*mo_num_per_kpt
|
||||
hij -= buffer_c(i)
|
||||
enddo
|
||||
|
||||
! holes :: exchange terms
|
||||
do i0 = 1, n_occ_ab_hole(spin)
|
||||
i = occ_hole(i0,spin) - (ki-1)*mo_num_per_kpt
|
||||
hij += buffer_x(i)
|
||||
enddo
|
||||
|
||||
! particles :: direct terms
|
||||
do i0 = 1, n_occ_ab_partcl(1)
|
||||
i = occ_partcl(i0,1) - (ki-1)*mo_num_per_kpt
|
||||
hij += buffer_c(i)
|
||||
enddo
|
||||
do i0 = 1, n_occ_ab_partcl(2)
|
||||
i = occ_partcl(i0,2) - (ki-1)*mo_num_per_kpt
|
||||
hij += buffer_c(i)
|
||||
enddo
|
||||
|
||||
! particles :: exchange terms
|
||||
do i0 = 1, n_occ_ab_partcl(spin)
|
||||
i = occ_partcl(i0,spin) - (ki-1)*mo_num_per_kpt
|
||||
hij -= buffer_x(i)
|
||||
enddo
|
||||
enddo
|
||||
hij = hij * phase
|
||||
|
||||
end
|
||||
|
||||
|
@ -1581,8 +1581,6 @@ subroutine get_excitation_degree_vector(key1,key2,degree,Nint,sze,idx)
|
||||
end
|
||||
|
||||
|
||||
|
||||
|
||||
double precision function diag_H_mat_elem_fock(det_ref,det_pert,fock_diag_tmp,Nint)
|
||||
use bitmasks
|
||||
implicit none
|
||||
@ -1745,7 +1743,7 @@ subroutine a_operator(iorb,ispin,key,hjj,Nint,na,nb)
|
||||
call bitstring_to_list_ab(key, occ, tmp, Nint)
|
||||
na = na-1
|
||||
|
||||
hjj = hjj - mo_one_e_integrals(iorb,iorb)
|
||||
hjj = hjj - mo_one_e_integrals_diag(iorb)
|
||||
|
||||
! Same spin
|
||||
do i=1,na
|
||||
@ -1803,7 +1801,7 @@ subroutine ac_operator(iorb,ispin,key,hjj,Nint,na,nb)
|
||||
key(k,ispin) = ibset(key(k,ispin),l)
|
||||
other_spin = iand(ispin,1)+1
|
||||
|
||||
hjj = hjj + mo_one_e_integrals(iorb,iorb)
|
||||
hjj = hjj + mo_one_e_integrals_diag(iorb)
|
||||
|
||||
! Same spin
|
||||
do i=1,na
|
||||
@ -2292,3 +2290,607 @@ subroutine connected_to_hf(key_i,yes_no)
|
||||
yes_no = .True.
|
||||
endif
|
||||
end
|
||||
|
||||
|
||||
!==============================================================================!
|
||||
! !
|
||||
! Complex !
|
||||
! !
|
||||
!==============================================================================!
|
||||
|
||||
|
||||
subroutine i_H_j_s2_complex(key_i,key_j,Nint,hij,s2)
|
||||
use bitmasks
|
||||
implicit none
|
||||
BEGIN_DOC
|
||||
! Returns $\langle i|H|j \rangle$ and $\langle i|S^2|j \rangle$
|
||||
! 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)
|
||||
complex*16, intent(out) :: hij
|
||||
double precision, intent(out) :: s2
|
||||
|
||||
integer :: exc(0:2,2,2)
|
||||
integer :: degree
|
||||
complex*16 :: get_two_e_integral_complex
|
||||
integer :: m,n,p,q
|
||||
integer :: i,j,k
|
||||
integer :: occ(Nint*bit_kind_size,2)
|
||||
double precision :: diag_h_mat_elem, phase
|
||||
integer :: n_occ_ab(2)
|
||||
PROVIDE mo_two_e_integrals_in_map mo_integrals_map big_array_exchange_integrals_complex
|
||||
|
||||
ASSERT (Nint > 0)
|
||||
ASSERT (Nint == N_int)
|
||||
ASSERT (sum(popcnt(key_i(:,1))) == elec_alpha_num)
|
||||
ASSERT (sum(popcnt(key_i(:,2))) == elec_beta_num)
|
||||
ASSERT (sum(popcnt(key_j(:,1))) == elec_alpha_num)
|
||||
ASSERT (sum(popcnt(key_j(:,2))) == elec_beta_num)
|
||||
|
||||
hij = (0.d0,0.d0)
|
||||
s2 = 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)
|
||||
! Single alpha, single beta
|
||||
if (exc(0,1,1) == 1) then
|
||||
if ( (exc(1,1,1) == exc(1,2,2)).and.(exc(1,1,2) == exc(1,2,1)) ) then
|
||||
s2 = -phase
|
||||
endif
|
||||
if(exc(1,1,1) == exc(1,2,2) )then
|
||||
hij = phase * big_array_exchange_integrals_complex(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_complex(exc(1,2,1),exc(1,1,1),exc(1,2,2))
|
||||
else
|
||||
hij = phase*get_two_e_integral_complex( &
|
||||
exc(1,1,1), &
|
||||
exc(1,1,2), &
|
||||
exc(1,2,1), &
|
||||
exc(1,2,2) ,mo_integrals_map,mo_integrals_map_2)
|
||||
endif
|
||||
! Double alpha
|
||||
else if (exc(0,1,1) == 2) then
|
||||
hij = phase*(get_two_e_integral_complex( &
|
||||
exc(1,1,1), &
|
||||
exc(2,1,1), &
|
||||
exc(1,2,1), &
|
||||
exc(2,2,1) ,mo_integrals_map,mo_integrals_map_2) - &
|
||||
get_two_e_integral_complex( &
|
||||
exc(1,1,1), &
|
||||
exc(2,1,1), &
|
||||
exc(2,2,1), &
|
||||
exc(1,2,1) ,mo_integrals_map,mo_integrals_map_2) )
|
||||
! Double beta
|
||||
else if (exc(0,1,2) == 2) then
|
||||
hij = phase*(get_two_e_integral_complex( &
|
||||
exc(1,1,2), &
|
||||
exc(2,1,2), &
|
||||
exc(1,2,2), &
|
||||
exc(2,2,2) ,mo_integrals_map,mo_integrals_map_2) - &
|
||||
get_two_e_integral_complex( &
|
||||
exc(1,1,2), &
|
||||
exc(2,1,2), &
|
||||
exc(2,2,2), &
|
||||
exc(1,2,2) ,mo_integrals_map,mo_integrals_map_2) )
|
||||
endif
|
||||
case (1)
|
||||
call get_single_excitation(key_i,key_j,exc,phase,Nint)
|
||||
!DIR$ FORCEINLINE
|
||||
call bitstring_to_list_ab(key_i, occ, n_occ_ab, Nint)
|
||||
! Single alpha
|
||||
if (exc(0,1,1) == 1) then
|
||||
m = exc(1,1,1)
|
||||
p = exc(1,2,1)
|
||||
spin = 1
|
||||
! Single beta
|
||||
else
|
||||
m = exc(1,1,2)
|
||||
p = exc(1,2,2)
|
||||
spin = 2
|
||||
endif
|
||||
call get_single_excitation_from_fock_complex(key_i,key_j,m,p,spin,phase,hij)
|
||||
|
||||
case (0)
|
||||
double precision, external :: diag_S_mat_elem
|
||||
s2 = diag_S_mat_elem(key_i,Nint)
|
||||
hij = dcmplx(diag_H_mat_elem(key_i,Nint),0.d0)
|
||||
end select
|
||||
end
|
||||
|
||||
|
||||
|
||||
subroutine i_H_j_complex(key_i,key_j,Nint,hij)
|
||||
use bitmasks
|
||||
implicit none
|
||||
BEGIN_DOC
|
||||
! Returns $\langle i|H|j \rangle$ 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)
|
||||
complex*16, intent(out) :: hij
|
||||
|
||||
integer :: exc(0:2,2,2)
|
||||
integer :: degree
|
||||
complex*16 :: get_two_e_integral_complex
|
||||
integer :: m,n,p,q
|
||||
integer :: i,j,k
|
||||
integer :: ih1,ih2,ip1,ip2,kh1,kh2,kp1,kp2
|
||||
integer :: occ(Nint*bit_kind_size,2)
|
||||
double precision :: diag_H_mat_elem, phase
|
||||
integer :: n_occ_ab(2)
|
||||
logical :: is_allowed
|
||||
PROVIDE mo_two_e_integrals_in_map mo_integrals_map big_array_exchange_integrals_complex
|
||||
|
||||
ASSERT (Nint > 0)
|
||||
ASSERT (Nint == N_int)
|
||||
ASSERT (sum(popcnt(key_i(:,1))) == elec_alpha_num)
|
||||
ASSERT (sum(popcnt(key_i(:,2))) == elec_beta_num)
|
||||
ASSERT (sum(popcnt(key_j(:,1))) == elec_alpha_num)
|
||||
ASSERT (sum(popcnt(key_j(:,2))) == elec_beta_num)
|
||||
|
||||
|
||||
hij = (0.d0,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
|
||||
call double_allowed_mo_kpts(exc(1,1,1),exc(1,1,2),exc(1,2,1),exc(1,2,2),is_allowed)
|
||||
if (.not.is_allowed) then
|
||||
hij = (0.d0,0.d0)
|
||||
return
|
||||
endif
|
||||
! Single alpha, single beta
|
||||
if(exc(1,1,1) == exc(1,2,2) )then
|
||||
ih1 = mod(exc(1,1,1)-1,mo_num_per_kpt)+1
|
||||
ih2 = mod(exc(1,1,2)-1,mo_num_per_kpt)+1
|
||||
kh1 = (exc(1,1,1)-1)/mo_num_per_kpt+1
|
||||
kh2 = (exc(1,1,2)-1)/mo_num_per_kpt+1
|
||||
ip1 = mod(exc(1,2,1)-1,mo_num_per_kpt)+1
|
||||
kp1 = (exc(1,2,1)-1)/mo_num_per_kpt+1
|
||||
if(kp1.ne.kh2) then
|
||||
print*,'problem with hij kpts: ',irp_here
|
||||
print*,is_allowed
|
||||
print*,exc(1,1,1),exc(1,1,2),exc(1,2,1),exc(1,2,2)
|
||||
print*,ih1,kh1,ih2,kh2,ip1,kp1
|
||||
stop -4
|
||||
endif
|
||||
hij = phase * big_array_exchange_integrals_kpts(ih1,kh1,ih2,ip1,kp1)
|
||||
!hij = phase * big_array_exchange_integrals_complex(exc(1,1,1),exc(1,1,2),exc(1,2,1))
|
||||
else if (exc(1,2,1) ==exc(1,1,2))then
|
||||
ih1 = mod(exc(1,1,1)-1,mo_num_per_kpt)+1
|
||||
kh1 = (exc(1,1,1)-1)/mo_num_per_kpt+1
|
||||
ip1 = mod(exc(1,2,1)-1,mo_num_per_kpt)+1
|
||||
kp1 = (exc(1,2,1)-1)/mo_num_per_kpt+1
|
||||
ip2 = mod(exc(1,2,2)-1,mo_num_per_kpt)+1
|
||||
kp2 = (exc(1,2,2)-1)/mo_num_per_kpt+1
|
||||
if(kp2.ne.kh1) then
|
||||
print*,'problem with hij kpts: ',irp_here
|
||||
print*,is_allowed
|
||||
print*,exc(1,1,1),exc(1,1,2),exc(1,2,1),exc(1,2,2)
|
||||
print*,ip1,kp1,ip2,kp2,ih1,kh1
|
||||
stop -5
|
||||
endif
|
||||
hij = phase * big_array_exchange_integrals_kpts(ip1,kp1,ih1,ip2,kp2)
|
||||
!hij = phase * big_array_exchange_integrals_complex(exc(1,2,1),exc(1,1,1),exc(1,2,2))
|
||||
else
|
||||
hij = phase*get_two_e_integral_complex( &
|
||||
exc(1,1,1), &
|
||||
exc(1,1,2), &
|
||||
exc(1,2,1), &
|
||||
exc(1,2,2) ,mo_integrals_map,mo_integrals_map_2)
|
||||
endif
|
||||
else if (exc(0,1,1) == 2) then
|
||||
call double_allowed_mo_kpts(exc(1,1,1),exc(2,1,1),exc(1,2,1),exc(2,2,1),is_allowed)
|
||||
if (.not.is_allowed) then
|
||||
hij = (0.d0,0.d0)
|
||||
return
|
||||
endif
|
||||
! Double alpha
|
||||
hij = phase*(get_two_e_integral_complex( &
|
||||
exc(1,1,1), &
|
||||
exc(2,1,1), &
|
||||
exc(1,2,1), &
|
||||
exc(2,2,1) ,mo_integrals_map,mo_integrals_map_2) - &
|
||||
get_two_e_integral_complex( &
|
||||
exc(1,1,1), &
|
||||
exc(2,1,1), &
|
||||
exc(2,2,1), &
|
||||
exc(1,2,1) ,mo_integrals_map,mo_integrals_map_2) )
|
||||
else if (exc(0,1,2) == 2) then
|
||||
call double_allowed_mo_kpts(exc(1,1,2),exc(2,1,2),exc(1,2,2),exc(2,2,2),is_allowed)
|
||||
if (.not.is_allowed) then
|
||||
hij = (0.d0,0.d0)
|
||||
return
|
||||
endif
|
||||
! Double beta
|
||||
hij = phase*(get_two_e_integral_complex( &
|
||||
exc(1,1,2), &
|
||||
exc(2,1,2), &
|
||||
exc(1,2,2), &
|
||||
exc(2,2,2) ,mo_integrals_map,mo_integrals_map_2) - &
|
||||
get_two_e_integral_complex( &
|
||||
exc(1,1,2), &
|
||||
exc(2,1,2), &
|
||||
exc(2,2,2), &
|
||||
exc(1,2,2) ,mo_integrals_map,mo_integrals_map_2) )
|
||||
endif
|
||||
case (1)
|
||||
call get_single_excitation(key_i,key_j,exc,phase,Nint)
|
||||
!DIR$ FORCEINLINE
|
||||
call bitstring_to_list_ab(key_i, occ, n_occ_ab, Nint)
|
||||
if (exc(0,1,1) == 1) then
|
||||
! Single alpha
|
||||
m = exc(1,1,1)
|
||||
p = exc(1,2,1)
|
||||
spin = 1
|
||||
else
|
||||
! Single beta
|
||||
m = exc(1,1,2)
|
||||
p = exc(1,2,2)
|
||||
spin = 2
|
||||
endif
|
||||
!if m,p not from same kpt, single not allowed
|
||||
if (int((m-1)/mo_num_per_kpt + 1).ne.int((p-1)/mo_num_per_kpt + 1)) then
|
||||
hij = (0.d0,0.d0)
|
||||
return
|
||||
endif
|
||||
!call get_single_excitation_from_fock_complex(key_i,key_j,m,p,spin,phase,hij)
|
||||
call get_single_excitation_from_fock_kpts(key_i,key_j,m,p,spin,phase,hij)
|
||||
|
||||
case (0)
|
||||
hij = dcmplx(diag_H_mat_elem(key_i,Nint),0.d0)
|
||||
end select
|
||||
end
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
subroutine i_H_j_verbose_complex(key_i,key_j,Nint,hij,hmono,hdouble,phase)
|
||||
use bitmasks
|
||||
implicit none
|
||||
BEGIN_DOC
|
||||
! Returns $\langle i|H|j \rangle$ 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)
|
||||
complex*16, intent(out) :: hij,hmono,hdouble
|
||||
double precision, intent(out) :: phase
|
||||
|
||||
integer :: exc(0:2,2,2)
|
||||
integer :: degree
|
||||
complex*16 :: get_two_e_integral_complex
|
||||
integer :: m,n,p,q
|
||||
integer :: i,j,k
|
||||
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)
|
||||
complex*16 :: mipi(Nint*bit_kind_size), miip(Nint*bit_kind_size)
|
||||
PROVIDE mo_two_e_integrals_in_map mo_integrals_map
|
||||
|
||||
ASSERT (Nint > 0)
|
||||
ASSERT (Nint == N_int)
|
||||
ASSERT (sum(popcnt(key_i(:,1))) == elec_alpha_num)
|
||||
ASSERT (sum(popcnt(key_i(:,2))) == elec_beta_num)
|
||||
ASSERT (sum(popcnt(key_j(:,1))) == elec_alpha_num)
|
||||
ASSERT (sum(popcnt(key_j(:,2))) == elec_beta_num)
|
||||
|
||||
hij = (0.d0,0.d0)
|
||||
hmono = (0.d0,0.d0)
|
||||
hdouble = (0.d0,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
|
||||
! Single alpha, single beta
|
||||
hij = phase*get_two_e_integral_complex( &
|
||||
exc(1,1,1), &
|
||||
exc(1,1,2), &
|
||||
exc(1,2,1), &
|
||||
exc(1,2,2) ,mo_integrals_map,mo_integrals_map_2)
|
||||
else if (exc(0,1,1) == 2) then
|
||||
! Double alpha
|
||||
hij = phase*(get_two_e_integral_complex( &
|
||||
exc(1,1,1), &
|
||||
exc(2,1,1), &
|
||||
exc(1,2,1), &
|
||||
exc(2,2,1) ,mo_integrals_map,mo_integrals_map_2) - &
|
||||
get_two_e_integral_complex( &
|
||||
exc(1,1,1), &
|
||||
exc(2,1,1), &
|
||||
exc(2,2,1), &
|
||||
exc(1,2,1) ,mo_integrals_map,mo_integrals_map_2) )
|
||||
|
||||
else if (exc(0,1,2) == 2) then
|
||||
! Double beta
|
||||
hij = phase*(get_two_e_integral_complex( &
|
||||
exc(1,1,2), &
|
||||
exc(2,1,2), &
|
||||
exc(1,2,2), &
|
||||
exc(2,2,2) ,mo_integrals_map,mo_integrals_map_2) - &
|
||||
get_two_e_integral_complex( &
|
||||
exc(1,1,2), &
|
||||
exc(2,1,2), &
|
||||
exc(2,2,2), &
|
||||
exc(1,2,2) ,mo_integrals_map,mo_integrals_map_2) )
|
||||
endif
|
||||
case (1)
|
||||
call get_single_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
|
||||
! Single 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_two_e_integral_complex(m,i,p,i,mo_integrals_map,mo_integrals_map_2)
|
||||
miip(i) = get_two_e_integral_complex(m,i,i,p,mo_integrals_map,mo_integrals_map_2)
|
||||
has_mipi(i) = .True.
|
||||
endif
|
||||
enddo
|
||||
do k = 1, elec_beta_num
|
||||
i = occ(k,2)
|
||||
if (.not.has_mipi(i)) then
|
||||
mipi(i) = get_two_e_integral_complex(m,i,p,i,mo_integrals_map,mo_integrals_map_2)
|
||||
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))
|
||||
enddo
|
||||
|
||||
else
|
||||
! Single 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_two_e_integral_complex(m,i,p,i,mo_integrals_map,mo_integrals_map_2)
|
||||
miip(i) = get_two_e_integral_complex(m,i,i,p,mo_integrals_map,mo_integrals_map_2)
|
||||
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_two_e_integral_complex(m,i,p,i,mo_integrals_map,mo_integrals_map_2)
|
||||
has_mipi(i) = .True.
|
||||
endif
|
||||
enddo
|
||||
|
||||
do k = 1, elec_alpha_num
|
||||
hdouble = hdouble + mipi(occ(k,1))
|
||||
enddo
|
||||
do k = 1, elec_beta_num
|
||||
hdouble = hdouble + mipi(occ(k,2)) - miip(occ(k,2))
|
||||
enddo
|
||||
|
||||
endif
|
||||
hmono = mo_one_e_integrals_complex(m,p)
|
||||
hij = phase*(hdouble + hmono)
|
||||
|
||||
case (0)
|
||||
phase = 1.d0
|
||||
hij = dcmplx(diag_H_mat_elem(key_i,Nint),0.d0)
|
||||
end select
|
||||
end
|
||||
|
||||
|
||||
subroutine i_H_psi_complex(key,keys,coef,Nint,Ndet,Ndet_max,Nstate,i_H_psi_array)
|
||||
use bitmasks
|
||||
implicit none
|
||||
BEGIN_DOC
|
||||
! Computes $\langle i|H|Psi \rangle = \sum_J c_J \langle i | H | J \rangle$.
|
||||
!
|
||||
! Uses filter_connected_i_H_psi0 to get all the $|J \rangle$ to which $|i \rangle$
|
||||
! is connected.
|
||||
! The i_H_psi_minilist is much faster but requires to build the
|
||||
! minilists.
|
||||
END_DOC
|
||||
integer, intent(in) :: Nint, Ndet,Ndet_max,Nstate
|
||||
integer(bit_kind), intent(in) :: keys(Nint,2,Ndet)
|
||||
integer(bit_kind), intent(in) :: key(Nint,2)
|
||||
complex*16, intent(in) :: coef(Ndet_max,Nstate)
|
||||
complex*16, intent(out) :: i_H_psi_array(Nstate)
|
||||
|
||||
integer :: i, ii,j
|
||||
double precision :: phase
|
||||
integer :: exc(0:2,2,2)
|
||||
complex*16 :: hij
|
||||
integer, allocatable :: idx(:)
|
||||
|
||||
ASSERT (Nint > 0)
|
||||
ASSERT (N_int == Nint)
|
||||
ASSERT (Nstate > 0)
|
||||
ASSERT (Ndet > 0)
|
||||
ASSERT (Ndet_max >= Ndet)
|
||||
allocate(idx(0:Ndet))
|
||||
|
||||
i_H_psi_array = (0.d0,0.d0)
|
||||
|
||||
call filter_connected_i_h_psi0(keys,key,Nint,Ndet,idx)
|
||||
if (Nstate == 1) then
|
||||
|
||||
do ii=1,idx(0)
|
||||
i = idx(ii)
|
||||
!DIR$ FORCEINLINE
|
||||
call i_h_j_complex(key,keys(1,1,i),Nint,hij)
|
||||
i_H_psi_array(1) = i_H_psi_array(1) + coef(i,1)*hij
|
||||
enddo
|
||||
|
||||
else
|
||||
|
||||
do ii=1,idx(0)
|
||||
i = idx(ii)
|
||||
!DIR$ FORCEINLINE
|
||||
call i_h_j_complex(key,keys(1,1,i),Nint,hij)
|
||||
do j = 1, Nstate
|
||||
i_H_psi_array(j) = i_H_psi_array(j) + coef(i,j)*hij
|
||||
enddo
|
||||
enddo
|
||||
|
||||
endif
|
||||
|
||||
end
|
||||
|
||||
|
||||
subroutine i_H_psi_minilist_complex(key,keys,idx_key,N_minilist,coef,Nint,Ndet,Ndet_max,Nstate,i_H_psi_array)
|
||||
use bitmasks
|
||||
implicit none
|
||||
integer, intent(in) :: Nint, Ndet,Ndet_max,Nstate,idx_key(Ndet), N_minilist
|
||||
integer(bit_kind), intent(in) :: keys(Nint,2,Ndet)
|
||||
integer(bit_kind), intent(in) :: key(Nint,2)
|
||||
complex*16, intent(in) :: coef(Ndet_max,Nstate)
|
||||
complex*16, intent(out) :: i_H_psi_array(Nstate)
|
||||
|
||||
integer :: i, ii,j, i_in_key, i_in_coef
|
||||
double precision :: phase
|
||||
integer :: exc(0:2,2,2)
|
||||
complex*16 :: hij
|
||||
integer, allocatable :: idx(:)
|
||||
BEGIN_DOC
|
||||
! Computes $\langle i|H|\Psi \rangle = \sum_J c_J \langle i|H|J\rangle$.
|
||||
!
|
||||
! Uses filter_connected_i_H_psi0 to get all the $|J \rangle$ to which $|i \rangle$
|
||||
! is connected. The $|J\rangle$ 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)
|
||||
allocate(idx(0:Ndet))
|
||||
i_H_psi_array = 0.d0
|
||||
|
||||
call filter_connected_i_h_psi0(keys,key,Nint,N_minilist,idx)
|
||||
if (Nstate == 1) then
|
||||
|
||||
do ii=1,idx(0)
|
||||
i_in_key = idx(ii)
|
||||
i_in_coef = idx_key(idx(ii))
|
||||
!DIR$ FORCEINLINE
|
||||
call i_h_j_complex(key,keys(1,1,i_in_key),Nint,hij)
|
||||
! TODO : Cache misses
|
||||
i_H_psi_array(1) = i_H_psi_array(1) + coef(i_in_coef,1)*hij
|
||||
enddo
|
||||
|
||||
else
|
||||
|
||||
do ii=1,idx(0)
|
||||
i_in_key = idx(ii)
|
||||
i_in_coef = idx_key(idx(ii))
|
||||
!DIR$ FORCEINLINE
|
||||
call i_h_j_complex(key,keys(1,1,i_in_key),Nint,hij)
|
||||
do j = 1, Nstate
|
||||
i_H_psi_array(j) = i_H_psi_array(j) + coef(i_in_coef,j)*hij
|
||||
enddo
|
||||
enddo
|
||||
|
||||
endif
|
||||
|
||||
end
|
||||
|
||||
|
||||
|
||||
subroutine i_H_j_single_spin_complex(key_i,key_j,Nint,spin,hij)
|
||||
use bitmasks
|
||||
implicit none
|
||||
BEGIN_DOC
|
||||
! Returns $\langle i|H|j \rangle$ where $i$ and $j$ are determinants differing by
|
||||
! a single excitation.
|
||||
END_DOC
|
||||
integer, intent(in) :: Nint, spin
|
||||
integer(bit_kind), intent(in) :: key_i(Nint,2), key_j(Nint,2)
|
||||
complex*16, intent(out) :: hij
|
||||
|
||||
integer :: exc(0:2,2)
|
||||
double precision :: phase
|
||||
|
||||
!PROVIDE big_array_exchange_integrals_complex mo_two_e_integrals_in_map
|
||||
PROVIDE big_array_exchange_integrals_kpts mo_two_e_integrals_in_map
|
||||
|
||||
call get_single_excitation_spin(key_i(1,spin),key_j(1,spin),exc,phase,Nint)
|
||||
!call get_single_excitation_from_fock_complex(key_i,key_j,exc(1,1),exc(1,2),spin,phase,hij)
|
||||
call get_single_excitation_from_fock_kpts(key_i,key_j,exc(1,1),exc(1,2),spin,phase,hij)
|
||||
end
|
||||
|
||||
subroutine i_H_j_double_spin_complex(key_i,key_j,Nint,hij)
|
||||
use bitmasks
|
||||
implicit none
|
||||
BEGIN_DOC
|
||||
! Returns $\langle i|H|j \rangle$ where $i$ and $j$ are determinants differing by
|
||||
! a same-spin double excitation.
|
||||
END_DOC
|
||||
integer, intent(in) :: Nint
|
||||
integer(bit_kind), intent(in) :: key_i(Nint), key_j(Nint)
|
||||
complex*16, intent(out) :: hij
|
||||
|
||||
integer :: exc(0:2,2)
|
||||
double precision :: phase
|
||||
complex*16, external :: get_two_e_integral_complex
|
||||
|
||||
PROVIDE big_array_exchange_integrals_complex mo_two_e_integrals_in_map
|
||||
call get_double_excitation_spin(key_i,key_j,exc,phase,Nint)
|
||||
hij = phase*(get_two_e_integral_complex( &
|
||||
exc(1,1), &
|
||||
exc(2,1), &
|
||||
exc(1,2), &
|
||||
exc(2,2), mo_integrals_map,mo_integrals_map_2) - &
|
||||
get_two_e_integral_complex( &
|
||||
exc(1,1), &
|
||||
exc(2,1), &
|
||||
exc(2,2), &
|
||||
exc(1,2), mo_integrals_map,mo_integrals_map_2) )
|
||||
end
|
||||
|
||||
subroutine i_H_j_double_alpha_beta_complex(key_i,key_j,Nint,hij)
|
||||
use bitmasks
|
||||
implicit none
|
||||
BEGIN_DOC
|
||||
! Returns $\langle i|H|j \rangle$ where $i$ and $j$ are determinants differing by
|
||||
! an opposite-spin double excitation.
|
||||
END_DOC
|
||||
integer, intent(in) :: Nint
|
||||
integer(bit_kind), intent(in) :: key_i(Nint,2), key_j(Nint,2)
|
||||
complex*16, intent(out) :: hij
|
||||
|
||||
integer :: exc(0:2,2,2)
|
||||
double precision :: phase, phase2
|
||||
complex*16, external :: get_two_e_integral_complex
|
||||
|
||||
PROVIDE big_array_exchange_integrals_complex mo_two_e_integrals_in_map
|
||||
|
||||
call get_single_excitation_spin(key_i(1,1),key_j(1,1),exc(0,1,1),phase,Nint)
|
||||
call get_single_excitation_spin(key_i(1,2),key_j(1,2),exc(0,1,2),phase2,Nint)
|
||||
phase = phase*phase2
|
||||
if (exc(1,1,1) == exc(1,2,2)) then
|
||||
hij = phase * big_array_exchange_integrals_complex(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_complex(exc(1,2,1),exc(1,1,1),exc(1,2,2))
|
||||
else
|
||||
hij = phase*get_two_e_integral_complex( &
|
||||
exc(1,1,1), &
|
||||
exc(1,1,2), &
|
||||
exc(1,2,1), &
|
||||
exc(1,2,2) ,mo_integrals_map,mo_integrals_map_2)
|
||||
endif
|
||||
end
|
||||
|
@ -225,7 +225,7 @@ double precision function diag_H_mat_elem_one_e(det_in,Nint)
|
||||
call bitstring_to_list_ab(det_in, occ_particle, tmp, Nint)
|
||||
do ispin = 1,2
|
||||
do i = 1, tmp(ispin)
|
||||
diag_H_mat_elem_one_e += mo_one_e_integrals(occ_particle(i,ispin),occ_particle(i,ispin))
|
||||
diag_H_mat_elem_one_e += mo_one_e_integrals_diag(occ_particle(i,ispin))
|
||||
enddo
|
||||
enddo
|
||||
|
||||
@ -361,3 +361,180 @@ subroutine i_H_j_two_e(key_i,key_j,Nint,hij)
|
||||
end select
|
||||
end
|
||||
|
||||
!==============================================================================!
|
||||
! !
|
||||
! Complex !
|
||||
! !
|
||||
!==============================================================================!
|
||||
|
||||
subroutine i_Wee_j_single_complex(key_i,key_j,Nint,spin,hij)
|
||||
use bitmasks
|
||||
implicit none
|
||||
BEGIN_DOC
|
||||
! Returns $\langle i|H|j \rangle$ where $i$ and $j$ are determinants differing by a
|
||||
! single excitation.
|
||||
END_DOC
|
||||
integer, intent(in) :: Nint, spin
|
||||
integer(bit_kind), intent(in) :: key_i(Nint,2), key_j(Nint,2)
|
||||
complex*16, intent(out) :: hij
|
||||
|
||||
integer :: exc(0:2,2)
|
||||
double precision :: phase
|
||||
|
||||
PROVIDE big_array_exchange_integrals_complex mo_two_e_integrals_in_map
|
||||
|
||||
call get_single_excitation_spin(key_i(1,spin),key_j(1,spin),exc,phase,Nint)
|
||||
call single_excitation_wee_complex(key_i,key_j,exc(1,1),exc(1,2),spin,phase,hij)
|
||||
end
|
||||
|
||||
|
||||
subroutine i_H_j_mono_spin_one_e_complex(key_i,key_j,Nint,spin,hij)
|
||||
use bitmasks
|
||||
implicit none
|
||||
BEGIN_DOC
|
||||
! Returns $\langle i|H|j \rangle$ where $i$ and $j$ are determinants differing by
|
||||
! a single excitation.
|
||||
END_DOC
|
||||
integer, intent(in) :: Nint, spin
|
||||
integer(bit_kind), intent(in) :: key_i(Nint,2), key_j(Nint,2)
|
||||
complex*16, intent(out) :: hij
|
||||
|
||||
integer :: exc(0:2,2)
|
||||
double precision :: phase
|
||||
|
||||
call get_single_excitation_spin(key_i(1,spin),key_j(1,spin),exc,phase,Nint)
|
||||
integer :: m,p
|
||||
m = exc(1,1)
|
||||
p = exc(1,2)
|
||||
hij = phase * mo_one_e_integrals_complex(m,p)
|
||||
end
|
||||
|
||||
subroutine i_H_j_one_e_complex(key_i,key_j,Nint,hij)
|
||||
use bitmasks
|
||||
implicit none
|
||||
BEGIN_DOC
|
||||
! Returns $\langle i|H|j \rangle$ 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)
|
||||
complex*16, intent(out) :: hij
|
||||
|
||||
integer :: degree,m,p
|
||||
double precision :: diag_h_mat_elem_one_e,phase
|
||||
integer :: exc(0:2,2,2)
|
||||
call get_excitation_degree(key_i,key_j,degree,Nint)
|
||||
hij = (0.d0,0.d0)
|
||||
if(degree>1)then
|
||||
return
|
||||
endif
|
||||
if(degree==0)then
|
||||
hij = dcmplx(diag_h_mat_elem_one_e(key_i,N_int),0.d0)
|
||||
else
|
||||
call get_single_excitation(key_i,key_j,exc,phase,Nint)
|
||||
if (exc(0,1,1) == 1) then
|
||||
! Mono alpha
|
||||
m = exc(1,1,1)
|
||||
p = exc(1,2,1)
|
||||
else
|
||||
! Mono beta
|
||||
m = exc(1,1,2)
|
||||
p = exc(1,2,2)
|
||||
endif
|
||||
hij = phase * mo_one_e_integrals_complex(m,p)
|
||||
endif
|
||||
|
||||
end
|
||||
|
||||
subroutine i_H_j_two_e_complex(key_i,key_j,Nint,hij)
|
||||
use bitmasks
|
||||
implicit none
|
||||
BEGIN_DOC
|
||||
! Returns $\langle i|H|j \rangle$ 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)
|
||||
complex*16, intent(out) :: hij
|
||||
|
||||
integer :: exc(0:2,2,2)
|
||||
integer :: degree
|
||||
complex*16 :: get_two_e_integral_complex
|
||||
integer :: m,n,p,q
|
||||
integer :: i,j,k
|
||||
integer :: occ(Nint*bit_kind_size,2)
|
||||
double precision :: diag_H_mat_elem, phase,phase_2
|
||||
integer :: n_occ_ab(2)
|
||||
PROVIDE mo_two_e_integrals_in_map mo_integrals_map big_array_exchange_integrals_complex ref_bitmask_two_e_energy
|
||||
|
||||
ASSERT (Nint > 0)
|
||||
ASSERT (Nint == N_int)
|
||||
ASSERT (sum(popcnt(key_i(:,1))) == elec_alpha_num)
|
||||
ASSERT (sum(popcnt(key_i(:,2))) == elec_beta_num)
|
||||
ASSERT (sum(popcnt(key_j(:,1))) == elec_alpha_num)
|
||||
ASSERT (sum(popcnt(key_j(:,2))) == elec_beta_num)
|
||||
|
||||
hij = (0.d0,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_complex(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_complex(exc(1,2,1),exc(1,1,1),exc(1,2,2))
|
||||
else
|
||||
hij = phase*get_two_e_integral_complex( &
|
||||
exc(1,1,1), &
|
||||
exc(1,1,2), &
|
||||
exc(1,2,1), &
|
||||
exc(1,2,2) ,mo_integrals_map,mo_integrals_map_2)
|
||||
endif
|
||||
else if (exc(0,1,1) == 2) then
|
||||
! Double alpha
|
||||
hij = phase*(get_two_e_integral_complex( &
|
||||
exc(1,1,1), &
|
||||
exc(2,1,1), &
|
||||
exc(1,2,1), &
|
||||
exc(2,2,1) ,mo_integrals_map,mo_integrals_map_2) - &
|
||||
get_two_e_integral_complex( &
|
||||
exc(1,1,1), &
|
||||
exc(2,1,1), &
|
||||
exc(2,2,1), &
|
||||
exc(1,2,1) ,mo_integrals_map,mo_integrals_map_2) )
|
||||
else if (exc(0,1,2) == 2) then
|
||||
! Double beta
|
||||
hij = phase*(get_two_e_integral_complex( &
|
||||
exc(1,1,2), &
|
||||
exc(2,1,2), &
|
||||
exc(1,2,2), &
|
||||
exc(2,2,2) ,mo_integrals_map,mo_integrals_map_2) - &
|
||||
get_two_e_integral_complex( &
|
||||
exc(1,1,2), &
|
||||
exc(2,1,2), &
|
||||
exc(2,2,2), &
|
||||
exc(1,2,2) ,mo_integrals_map,mo_integrals_map_2) )
|
||||
endif
|
||||
case (1)
|
||||
call get_single_excitation(key_i,key_j,exc,phase,Nint)
|
||||
!DIR$ FORCEINLINE
|
||||
call bitstring_to_list_ab(key_i, occ, n_occ_ab, Nint)
|
||||
if (exc(0,1,1) == 1) then
|
||||
! Mono alpha
|
||||
m = exc(1,1,1)
|
||||
p = exc(1,2,1)
|
||||
spin = 1
|
||||
else
|
||||
! Mono beta
|
||||
m = exc(1,1,2)
|
||||
p = exc(1,2,2)
|
||||
spin = 2
|
||||
endif
|
||||
call single_excitation_wee_complex(key_i,key_j,m,p,spin,phase,hij)
|
||||
case (0)
|
||||
double precision :: diag_wee_mat_elem
|
||||
hij = dcmplx(diag_wee_mat_elem(key_i,Nint),0.d0)
|
||||
end select
|
||||
end
|
||||
|
@ -10,6 +10,7 @@ spindeterminants
|
||||
psi_coef_matrix_rows integer (spindeterminants_n_det)
|
||||
psi_coef_matrix_columns integer (spindeterminants_n_det)
|
||||
psi_coef_matrix_values double precision (spindeterminants_n_det,spindeterminants_n_states)
|
||||
psi_coef_matrix_values_complex double precision (2,spindeterminants_n_det,spindeterminants_n_states)
|
||||
n_svd_coefs integer
|
||||
psi_svd_alpha double precision (spindeterminants_n_det_alpha,spindeterminants_n_svd_coefs,spindeterminants_n_states)
|
||||
psi_svd_beta double precision (spindeterminants_n_det_beta,spindeterminants_n_svd_coefs,spindeterminants_n_states)
|
||||
|
@ -307,8 +307,12 @@ integer function get_index_in_psi_det_beta_unique(key,Nint)
|
||||
|
||||
end
|
||||
|
||||
|
||||
subroutine write_spindeterminants
|
||||
!todo: modify for complex (not called anywhere?)
|
||||
if (is_complex) then
|
||||
print*,irp_here,' not implemented for complex'
|
||||
stop -1
|
||||
endif
|
||||
use bitmasks
|
||||
implicit none
|
||||
integer(8), allocatable :: tmpdet(:,:)
|
||||
@ -349,8 +353,12 @@ subroutine write_spindeterminants
|
||||
enddo
|
||||
call ezfio_set_spindeterminants_psi_det_beta(psi_det_beta_unique)
|
||||
deallocate(tmpdet)
|
||||
|
||||
|
||||
if (is_complex) then
|
||||
call ezfio_set_spindeterminants_psi_coef_matrix_values_complex(psi_bilinear_matrix_values_complex)
|
||||
else
|
||||
call ezfio_set_spindeterminants_psi_coef_matrix_values(psi_bilinear_matrix_values)
|
||||
endif
|
||||
call ezfio_set_spindeterminants_psi_coef_matrix_rows(psi_bilinear_matrix_rows)
|
||||
call ezfio_set_spindeterminants_psi_coef_matrix_columns(psi_bilinear_matrix_columns)
|
||||
|
||||
@ -370,6 +378,18 @@ end
|
||||
|
||||
det_alpha_norm = 0.d0
|
||||
det_beta_norm = 0.d0
|
||||
if (is_complex) then
|
||||
do k=1,N_det
|
||||
i = psi_bilinear_matrix_rows(k)
|
||||
j = psi_bilinear_matrix_columns(k)
|
||||
f = 0.d0
|
||||
do l=1,N_states
|
||||
f += cdabs(psi_bilinear_matrix_values_complex(k,l)*psi_bilinear_matrix_values_complex(k,l)) * state_average_weight(l)
|
||||
enddo
|
||||
det_alpha_norm(i) += f
|
||||
det_beta_norm(j) += f
|
||||
enddo
|
||||
else
|
||||
do k=1,N_det
|
||||
i = psi_bilinear_matrix_rows(k)
|
||||
j = psi_bilinear_matrix_columns(k)
|
||||
@ -380,6 +400,7 @@ end
|
||||
det_alpha_norm(i) += f
|
||||
det_beta_norm(j) += f
|
||||
enddo
|
||||
endif
|
||||
det_alpha_norm = det_alpha_norm
|
||||
det_beta_norm = det_beta_norm
|
||||
|
||||
@ -392,8 +413,37 @@ END_PROVIDER
|
||||
! !
|
||||
!==============================================================================!
|
||||
|
||||
BEGIN_PROVIDER [ double precision, psi_bilinear_matrix_values, (N_det,N_states) ]
|
||||
&BEGIN_PROVIDER [ integer, psi_bilinear_matrix_rows , (N_det) ]
|
||||
BEGIN_PROVIDER [ double precision, psi_bilinear_matrix_values, (N_det,N_states) ]
|
||||
use bitmasks
|
||||
PROVIDE psi_bilinear_matrix_rows
|
||||
integer :: k,l
|
||||
do k=1,N_det
|
||||
do l=1,N_states
|
||||
psi_bilinear_matrix_values(k,l) = psi_coef(k,l)
|
||||
enddo
|
||||
enddo
|
||||
do l=1,N_states
|
||||
call dset_order(psi_bilinear_matrix_values(1,l),psi_bilinear_matrix_order,N_det)
|
||||
enddo
|
||||
END_PROVIDER
|
||||
|
||||
BEGIN_PROVIDER [ complex*16, psi_bilinear_matrix_values_complex, (N_det,N_states) ]
|
||||
use bitmasks
|
||||
PROVIDE psi_bilinear_matrix_rows
|
||||
integer :: k,l
|
||||
do k=1,N_det
|
||||
do l=1,N_states
|
||||
psi_bilinear_matrix_values_complex(k,l) = psi_coef_complex(k,l)
|
||||
enddo
|
||||
enddo
|
||||
do l=1,N_states
|
||||
call cdset_order(psi_bilinear_matrix_values_complex(1,l),psi_bilinear_matrix_order,N_det)
|
||||
enddo
|
||||
END_PROVIDER
|
||||
|
||||
|
||||
|
||||
BEGIN_PROVIDER [ integer, psi_bilinear_matrix_rows , (N_det) ]
|
||||
&BEGIN_PROVIDER [ integer, psi_bilinear_matrix_columns, (N_det) ]
|
||||
&BEGIN_PROVIDER [ integer, psi_bilinear_matrix_order , (N_det) ]
|
||||
use bitmasks
|
||||
@ -408,10 +458,13 @@ END_PROVIDER
|
||||
END_DOC
|
||||
integer :: i,j,k, l
|
||||
integer(bit_kind) :: tmp_det(N_int,2)
|
||||
integer, external :: get_index_in_psi_det_sorted_bit
|
||||
! integer, external :: get_index_in_psi_det_sorted_bit
|
||||
|
||||
|
||||
PROVIDE psi_coef_sorted_bit
|
||||
if (is_complex) then
|
||||
PROVIDE psi_coef_sorted_bit_complex
|
||||
else
|
||||
PROVIDE psi_coef_sorted_bit
|
||||
endif
|
||||
|
||||
integer*8, allocatable :: to_sort(:)
|
||||
integer, external :: get_index_in_psi_det_alpha_unique
|
||||
@ -427,9 +480,6 @@ END_PROVIDER
|
||||
ASSERT (j>0)
|
||||
ASSERT (j<=N_det_beta_unique)
|
||||
|
||||
do l=1,N_states
|
||||
psi_bilinear_matrix_values(k,l) = psi_coef(k,l)
|
||||
enddo
|
||||
psi_bilinear_matrix_rows(k) = i
|
||||
psi_bilinear_matrix_columns(k) = j
|
||||
to_sort(k) = int(N_det_alpha_unique,8) * int(j-1,8) + int(i,8)
|
||||
@ -445,11 +495,6 @@ END_PROVIDER
|
||||
!$OMP SINGLE
|
||||
call iset_order(psi_bilinear_matrix_columns,psi_bilinear_matrix_order,N_det)
|
||||
!$OMP END SINGLE
|
||||
!$OMP DO
|
||||
do l=1,N_states
|
||||
call dset_order(psi_bilinear_matrix_values(1,l),psi_bilinear_matrix_order,N_det)
|
||||
enddo
|
||||
!$OMP END DO
|
||||
!$OMP END PARALLEL
|
||||
deallocate(to_sort)
|
||||
ASSERT (minval(psi_bilinear_matrix_rows) == 1)
|
||||
@ -514,8 +559,71 @@ BEGIN_PROVIDER [ integer, psi_bilinear_matrix_columns_loc, (N_det_beta_unique+1)
|
||||
|
||||
END_PROVIDER
|
||||
|
||||
BEGIN_PROVIDER [ double precision, psi_bilinear_matrix_transp_values, (N_det,N_states) ]
|
||||
&BEGIN_PROVIDER [ integer, psi_bilinear_matrix_transp_rows , (N_det) ]
|
||||
BEGIN_PROVIDER [ double precision, psi_bilinear_matrix_transp_values, (N_det,N_states) ]
|
||||
use bitmasks
|
||||
implicit none
|
||||
BEGIN_DOC
|
||||
! Transpose of :c:data:`psi_bilinear_matrix`
|
||||
!
|
||||
! $D_\beta^\dagger.C^\dagger.D_\alpha$
|
||||
!
|
||||
! Rows are $\alpha$ determinants and columns are $\beta$, but the matrix is stored in row major
|
||||
! format.
|
||||
END_DOC
|
||||
integer :: k,l
|
||||
|
||||
PROVIDE psi_bilinear_matrix_transp_rows
|
||||
|
||||
!$OMP PARALLEL DEFAULT(SHARED) PRIVATE(k,l)
|
||||
do l=1,N_states
|
||||
!$OMP DO
|
||||
do k=1,N_det
|
||||
psi_bilinear_matrix_transp_values (k,l) = psi_bilinear_matrix_values (k,l)
|
||||
enddo
|
||||
!$OMP ENDDO NOWAIT
|
||||
enddo
|
||||
!$OMP END PARALLEL
|
||||
!$OMP PARALLEL DO DEFAULT(SHARED) PRIVATE(l)
|
||||
do l=1,N_states
|
||||
call dset_order(psi_bilinear_matrix_transp_values(1,l),psi_bilinear_matrix_transp_order,N_det)
|
||||
enddo
|
||||
!$OMP END PARALLEL DO
|
||||
|
||||
END_PROVIDER
|
||||
|
||||
BEGIN_PROVIDER [ complex*16, psi_bilinear_matrix_transp_values_complex, (N_det,N_states) ]
|
||||
use bitmasks
|
||||
implicit none
|
||||
BEGIN_DOC
|
||||
! Transpose of :c:data:`psi_bilinear_matrix`
|
||||
!
|
||||
! $D_\beta^\dagger.C^\dagger.D_\alpha$
|
||||
!
|
||||
! Rows are $\alpha$ determinants and columns are $\beta$, but the matrix is stored in row major
|
||||
! format.
|
||||
END_DOC
|
||||
integer :: k,l
|
||||
|
||||
PROVIDE psi_bilinear_matrix_transp_rows
|
||||
|
||||
!$OMP PARALLEL DEFAULT(SHARED) PRIVATE(k,l)
|
||||
do l=1,N_states
|
||||
!$OMP DO
|
||||
do k=1,N_det
|
||||
psi_bilinear_matrix_transp_values_complex (k,l) = psi_bilinear_matrix_values_complex (k,l)
|
||||
enddo
|
||||
!$OMP ENDDO NOWAIT
|
||||
enddo
|
||||
!$OMP END PARALLEL
|
||||
!$OMP PARALLEL DO DEFAULT(SHARED) PRIVATE(l)
|
||||
do l=1,N_states
|
||||
call cdset_order(psi_bilinear_matrix_transp_values_complex(1,l),psi_bilinear_matrix_transp_order,N_det)
|
||||
enddo
|
||||
!$OMP END PARALLEL DO
|
||||
|
||||
END_PROVIDER
|
||||
|
||||
BEGIN_PROVIDER [ integer, psi_bilinear_matrix_transp_rows , (N_det) ]
|
||||
&BEGIN_PROVIDER [ integer, psi_bilinear_matrix_transp_columns, (N_det) ]
|
||||
&BEGIN_PROVIDER [ integer, psi_bilinear_matrix_transp_order , (N_det) ]
|
||||
use bitmasks
|
||||
@ -530,18 +638,15 @@ END_PROVIDER
|
||||
END_DOC
|
||||
integer :: i,j,k,l
|
||||
|
||||
PROVIDE psi_coef_sorted_bit
|
||||
if (is_complex) then
|
||||
PROVIDE psi_coef_sorted_bit_complex
|
||||
else
|
||||
PROVIDE psi_coef_sorted_bit
|
||||
endif
|
||||
|
||||
integer*8, allocatable :: to_sort(:)
|
||||
allocate(to_sort(N_det))
|
||||
!$OMP PARALLEL DEFAULT(SHARED) PRIVATE(i,j,k,l)
|
||||
do l=1,N_states
|
||||
!$OMP DO
|
||||
do k=1,N_det
|
||||
psi_bilinear_matrix_transp_values (k,l) = psi_bilinear_matrix_values (k,l)
|
||||
enddo
|
||||
!$OMP ENDDO NOWAIT
|
||||
enddo
|
||||
!$OMP DO
|
||||
do k=1,N_det
|
||||
psi_bilinear_matrix_transp_columns(k) = psi_bilinear_matrix_columns(k)
|
||||
@ -563,11 +668,6 @@ END_PROVIDER
|
||||
call i8radix_sort(to_sort, psi_bilinear_matrix_transp_order, N_det,-1)
|
||||
call iset_order(psi_bilinear_matrix_transp_rows,psi_bilinear_matrix_transp_order,N_det)
|
||||
call iset_order(psi_bilinear_matrix_transp_columns,psi_bilinear_matrix_transp_order,N_det)
|
||||
!$OMP PARALLEL DO DEFAULT(SHARED) PRIVATE(l)
|
||||
do l=1,N_states
|
||||
call dset_order(psi_bilinear_matrix_transp_values(1,l),psi_bilinear_matrix_transp_order,N_det)
|
||||
enddo
|
||||
!$OMP END PARALLEL DO
|
||||
deallocate(to_sort)
|
||||
ASSERT (minval(psi_bilinear_matrix_transp_columns) == 1)
|
||||
ASSERT (minval(psi_bilinear_matrix_transp_rows) == 1)
|
||||
@ -641,7 +741,30 @@ BEGIN_PROVIDER [ double precision, psi_bilinear_matrix, (N_det_alpha_unique,N_de
|
||||
enddo
|
||||
END_PROVIDER
|
||||
|
||||
BEGIN_PROVIDER [ complex*16, psi_bilinear_matrix_complex, (N_det_alpha_unique,N_det_beta_unique,N_states) ]
|
||||
implicit none
|
||||
BEGIN_DOC
|
||||
! Coefficient matrix if the wave function is expressed in a bilinear form :
|
||||
!
|
||||
! $D_\alpha^\dagger.C.D_\beta$
|
||||
END_DOC
|
||||
integer :: i,j,k,istate
|
||||
psi_bilinear_matrix_complex = (0.d0,0.d0)
|
||||
do k=1,N_det
|
||||
i = psi_bilinear_matrix_rows(k)
|
||||
j = psi_bilinear_matrix_columns(k)
|
||||
do istate=1,N_states
|
||||
psi_bilinear_matrix_complex(i,j,istate) = psi_bilinear_matrix_values_complex(k,istate)
|
||||
enddo
|
||||
enddo
|
||||
END_PROVIDER
|
||||
|
||||
subroutine create_wf_of_psi_bilinear_matrix(truncate)
|
||||
!todo: modify for complex (not called anywhere?)
|
||||
if (is_complex) then
|
||||
print*,irp_here,' not implemented for complex'
|
||||
stop -1
|
||||
endif
|
||||
use bitmasks
|
||||
implicit none
|
||||
BEGIN_DOC
|
||||
@ -713,6 +836,11 @@ subroutine create_wf_of_psi_bilinear_matrix(truncate)
|
||||
end
|
||||
|
||||
subroutine generate_all_alpha_beta_det_products
|
||||
!todo: modify for complex (only used by create_wf_of_psi_bilinear_matrix?)
|
||||
if (is_complex) then
|
||||
print*,irp_here,' not implemented for complex'
|
||||
stop -1
|
||||
endif
|
||||
implicit none
|
||||
BEGIN_DOC
|
||||
! Creates a wave function from all possible $\alpha \times \beta$ determinants
|
||||
@ -856,6 +984,11 @@ end
|
||||
|
||||
|
||||
subroutine copy_psi_bilinear_to_psi(psi, isize)
|
||||
!todo: modify for complex (not called anywhere?)
|
||||
if (is_complex) then
|
||||
print*,irp_here,' not implemented for complex'
|
||||
stop -1
|
||||
endif
|
||||
implicit none
|
||||
BEGIN_DOC
|
||||
! Overwrites :c:data:`psi_det` and :c:data:`psi_coef` with the wave function
|
||||
@ -1292,6 +1425,11 @@ END_TEMPLATE
|
||||
|
||||
|
||||
subroutine wf_of_psi_bilinear_matrix(truncate)
|
||||
!todo: modify for complex (not called anywhere?)
|
||||
if (is_complex) then
|
||||
print*,irp_here,' not implemented for complex'
|
||||
stop -1
|
||||
endif
|
||||
use bitmasks
|
||||
implicit none
|
||||
BEGIN_DOC
|
||||
|
@ -20,6 +20,28 @@ BEGIN_PROVIDER [ double precision, H_matrix_all_dets,(N_det,N_det) ]
|
||||
!$OMP END PARALLEL DO
|
||||
END_PROVIDER
|
||||
|
||||
BEGIN_PROVIDER [ complex*16, h_matrix_all_dets_complex,(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
|
||||
complex*16 :: hij
|
||||
integer :: degree(N_det),idx(0:N_det)
|
||||
call i_h_j_complex(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 SHARED (N_det, psi_det, N_int,h_matrix_all_dets_complex)
|
||||
do i =1,N_det
|
||||
do j = i, N_det
|
||||
call i_h_j_complex(psi_det(1,1,i),psi_det(1,1,j),N_int,hij)
|
||||
H_matrix_all_dets_complex(i,j) = hij
|
||||
H_matrix_all_dets_complex(j,i) = dconjg(hij)
|
||||
enddo
|
||||
enddo
|
||||
!$OMP END PARALLEL DO
|
||||
END_PROVIDER
|
||||
|
||||
|
||||
BEGIN_PROVIDER [ double precision, S2_matrix_all_dets,(N_det,N_det) ]
|
||||
use bitmasks
|
||||
|
@ -13,6 +13,7 @@ integer function zmq_put_psi(zmq_to_qp_run_socket,worker_id)
|
||||
integer, external :: zmq_put_psi_det_size
|
||||
integer*8, external :: zmq_put_psi_det
|
||||
integer*8, external :: zmq_put_psi_coef
|
||||
integer*8, external :: zmq_put_psi_coef_complex
|
||||
|
||||
zmq_put_psi = 0
|
||||
if (zmq_put_N_states(zmq_to_qp_run_socket, worker_id) == -1) then
|
||||
@ -31,11 +32,17 @@ integer function zmq_put_psi(zmq_to_qp_run_socket,worker_id)
|
||||
zmq_put_psi = -1
|
||||
return
|
||||
endif
|
||||
if (is_complex) then
|
||||
if (zmq_put_psi_coef_complex(zmq_to_qp_run_socket, worker_id) == -1) then
|
||||
zmq_put_psi = -1
|
||||
return
|
||||
endif
|
||||
else
|
||||
if (zmq_put_psi_coef(zmq_to_qp_run_socket, worker_id) == -1) then
|
||||
zmq_put_psi = -1
|
||||
return
|
||||
endif
|
||||
|
||||
endif
|
||||
end
|
||||
|
||||
|
||||
@ -54,6 +61,7 @@ integer function zmq_get_psi_notouch(zmq_to_qp_run_socket, worker_id)
|
||||
integer, external :: zmq_get_psi_det_size
|
||||
integer*8, external :: zmq_get_psi_det
|
||||
integer*8, external :: zmq_get_psi_coef
|
||||
integer*8, external :: zmq_get_psi_coef_complex
|
||||
|
||||
zmq_get_psi_notouch = 0
|
||||
|
||||
@ -75,19 +83,34 @@ integer function zmq_get_psi_notouch(zmq_to_qp_run_socket, worker_id)
|
||||
allocate(psi_det(N_int,2,psi_det_size))
|
||||
endif
|
||||
|
||||
if (is_complex) then
|
||||
if (size(psi_coef_complex,kind=8) /= psi_det_size*N_states) then
|
||||
deallocate(psi_coef_complex)
|
||||
allocate(psi_coef_complex(psi_det_size,N_states))
|
||||
endif
|
||||
else
|
||||
if (size(psi_coef,kind=8) /= psi_det_size*N_states) then
|
||||
deallocate(psi_coef)
|
||||
allocate(psi_coef(psi_det_size,N_states))
|
||||
endif
|
||||
endif
|
||||
|
||||
if (zmq_get_psi_det(zmq_to_qp_run_socket, worker_id) == -1_8) then
|
||||
zmq_get_psi_notouch = -1
|
||||
return
|
||||
endif
|
||||
|
||||
if (is_complex) then
|
||||
if (zmq_get_psi_coef_complex(zmq_to_qp_run_socket, worker_id) == -1_8) then
|
||||
zmq_get_psi_notouch = -1
|
||||
return
|
||||
endif
|
||||
else
|
||||
if (zmq_get_psi_coef(zmq_to_qp_run_socket, worker_id) == -1_8) then
|
||||
zmq_get_psi_notouch = -1
|
||||
return
|
||||
endif
|
||||
endif
|
||||
|
||||
end
|
||||
|
||||
@ -102,8 +125,11 @@ integer function zmq_get_psi(zmq_to_qp_run_socket, worker_id)
|
||||
integer, intent(in) :: worker_id
|
||||
integer, external :: zmq_get_psi_notouch
|
||||
zmq_get_psi = zmq_get_psi_notouch(zmq_to_qp_run_socket, worker_id)
|
||||
if (is_complex) then
|
||||
SOFT_TOUCH psi_det psi_coef_complex psi_det_size N_det N_states
|
||||
else
|
||||
SOFT_TOUCH psi_det psi_coef psi_det_size N_det N_states
|
||||
|
||||
endif
|
||||
end
|
||||
|
||||
|
||||
@ -146,12 +172,20 @@ integer function zmq_put_psi_bilinear(zmq_to_qp_run_socket,worker_id)
|
||||
zmq_put_psi_bilinear = -1
|
||||
return
|
||||
endif
|
||||
|
||||
|
||||
if (is_complex) then
|
||||
integer*8, external :: zmq_put_psi_bilinear_matrix_values_complex
|
||||
if (zmq_put_psi_bilinear_matrix_values_complex(zmq_to_qp_run_socket, worker_id) == -1) then
|
||||
zmq_put_psi_bilinear = -1
|
||||
return
|
||||
endif
|
||||
else
|
||||
integer*8, external :: zmq_put_psi_bilinear_matrix_values
|
||||
if (zmq_put_psi_bilinear_matrix_values(zmq_to_qp_run_socket, worker_id) == -1) then
|
||||
zmq_put_psi_bilinear = -1
|
||||
return
|
||||
endif
|
||||
endif
|
||||
|
||||
integer, external :: zmq_put_N_det_alpha_unique
|
||||
if (zmq_put_N_det_alpha_unique(zmq_to_qp_run_socket,worker_id) == -1) then
|
||||
@ -197,10 +231,17 @@ integer function zmq_get_psi_bilinear(zmq_to_qp_run_socket, worker_id)
|
||||
|
||||
zmq_get_psi_bilinear= 0
|
||||
|
||||
if (is_complex) then
|
||||
if (size(psi_bilinear_matrix_values_complex,kind=8) /= N_det*N_states) then
|
||||
deallocate(psi_bilinear_matrix_values_complex)
|
||||
allocate(psi_bilinear_matrix_values_complex(N_det,N_states))
|
||||
endif
|
||||
else
|
||||
if (size(psi_bilinear_matrix_values,kind=8) /= N_det*N_states) then
|
||||
deallocate(psi_bilinear_matrix_values)
|
||||
allocate(psi_bilinear_matrix_values(N_det,N_states))
|
||||
endif
|
||||
endif
|
||||
|
||||
if (size(psi_bilinear_matrix_rows,kind=8) /= N_det) then
|
||||
deallocate(psi_bilinear_matrix_rows)
|
||||
@ -216,12 +257,20 @@ integer function zmq_get_psi_bilinear(zmq_to_qp_run_socket, worker_id)
|
||||
deallocate(psi_bilinear_matrix_order)
|
||||
allocate(psi_bilinear_matrix_order(N_det))
|
||||
endif
|
||||
|
||||
|
||||
if (is_complex) then
|
||||
integer*8, external :: zmq_get_psi_bilinear_matrix_values_complex
|
||||
if (zmq_get_psi_bilinear_matrix_values_complex(zmq_to_qp_run_socket, worker_id) == -1_8) then
|
||||
zmq_get_psi_bilinear = -1
|
||||
return
|
||||
endif
|
||||
else
|
||||
integer*8, external :: zmq_get_psi_bilinear_matrix_values
|
||||
if (zmq_get_psi_bilinear_matrix_values(zmq_to_qp_run_socket, worker_id) == -1_8) then
|
||||
zmq_get_psi_bilinear = -1
|
||||
return
|
||||
endif
|
||||
endif
|
||||
|
||||
integer*8, external :: zmq_get_psi_bilinear_matrix_rows
|
||||
if (zmq_get_psi_bilinear_matrix_rows(zmq_to_qp_run_socket, worker_id) == -1_8) then
|
||||
@ -266,7 +315,11 @@ integer function zmq_get_psi_bilinear(zmq_to_qp_run_socket, worker_id)
|
||||
return
|
||||
endif
|
||||
|
||||
if (is_complex) then
|
||||
SOFT_TOUCH psi_bilinear_matrix_values_complex psi_bilinear_matrix_rows psi_bilinear_matrix_columns psi_bilinear_matrix_order psi_det psi_coef_complex psi_det_size N_det N_states psi_det_beta_unique psi_det_alpha_unique N_det_beta_unique N_det_alpha_unique
|
||||
else
|
||||
SOFT_TOUCH psi_bilinear_matrix_values psi_bilinear_matrix_rows psi_bilinear_matrix_columns psi_bilinear_matrix_order psi_det psi_coef psi_det_size N_det N_states psi_det_beta_unique psi_det_alpha_unique N_det_beta_unique N_det_alpha_unique
|
||||
endif
|
||||
|
||||
end
|
||||
|
||||
@ -563,6 +616,69 @@ psi_bilinear_matrix_values ;;
|
||||
|
||||
END_TEMPLATE
|
||||
|
||||
BEGIN_TEMPLATE
|
||||
|
||||
integer*8 function zmq_put_$X(zmq_to_qp_run_socket,worker_id)
|
||||
use f77_zmq
|
||||
implicit none
|
||||
BEGIN_DOC
|
||||
! Put $X on the qp_run scheduler
|
||||
END_DOC
|
||||
integer(ZMQ_PTR), intent(in) :: zmq_to_qp_run_socket
|
||||
integer, intent(in) :: worker_id
|
||||
integer*8 :: rc8
|
||||
character*(256) :: msg
|
||||
|
||||
zmq_put_$X = 0
|
||||
|
||||
integer*8 :: zmq_put_cdmatrix
|
||||
integer :: ni, nj
|
||||
|
||||
if (size($X,kind=8) <= 8388608_8) then
|
||||
ni = size($X,kind=4)
|
||||
nj = 1
|
||||
else
|
||||
ni = 8388608
|
||||
nj = int(size($X,kind=8)/8388608_8,4) + 1
|
||||
endif
|
||||
rc8 = zmq_put_cdmatrix(zmq_to_qp_run_socket, 1, '$X', $X, ni, nj, size($X,kind=8) )
|
||||
zmq_put_$X = rc8
|
||||
end
|
||||
|
||||
integer*8 function zmq_get_$X(zmq_to_qp_run_socket,worker_id)
|
||||
use f77_zmq
|
||||
implicit none
|
||||
BEGIN_DOC
|
||||
! get $X on the qp_run scheduler
|
||||
END_DOC
|
||||
integer(ZMQ_PTR), intent(in) :: zmq_to_qp_run_socket
|
||||
integer, intent(in) :: worker_id
|
||||
integer*8 :: rc8
|
||||
character*(256) :: msg
|
||||
|
||||
zmq_get_$X = 0_8
|
||||
|
||||
integer*8 :: zmq_get_cdmatrix
|
||||
integer :: ni, nj
|
||||
|
||||
if (size($X,kind=8) <= 8388608_8) then
|
||||
ni = size($X,kind=4)
|
||||
nj = 1
|
||||
else
|
||||
ni = 8388608
|
||||
nj = int(size($X,kind=8)/8388608_8,4) + 1
|
||||
endif
|
||||
rc8 = zmq_get_cdmatrix(zmq_to_qp_run_socket, 1, '$X', $X, ni, nj, size($X,kind=8) )
|
||||
zmq_get_$X = rc8
|
||||
end
|
||||
|
||||
SUBST [ X ]
|
||||
|
||||
psi_coef_complex ;;
|
||||
psi_bilinear_matrix_values_complex ;;
|
||||
|
||||
END_TEMPLATE
|
||||
|
||||
|
||||
!---------------------------------------------------------------------------
|
||||
|
||||
|
@ -37,7 +37,11 @@ program fci
|
||||
END_DOC
|
||||
|
||||
if (.not.is_zmq_slave) then
|
||||
PROVIDE psi_det psi_coef mo_two_e_integrals_in_map
|
||||
if (is_complex) then
|
||||
PROVIDE psi_det psi_coef_complex mo_two_e_integrals_in_map
|
||||
else
|
||||
PROVIDE psi_det psi_coef mo_two_e_integrals_in_map
|
||||
endif
|
||||
|
||||
if (do_pt2) then
|
||||
call run_stochastic_cipsi
|
||||
|
@ -82,3 +82,39 @@ BEGIN_PROVIDER [ double precision, select_max, (size_select_max) ]
|
||||
select_max = huge(1.d0)
|
||||
END_PROVIDER
|
||||
|
||||
|
||||
BEGIN_PROVIDER [ complex*16, psi_coef_generators_complex, (psi_det_size,N_states) ]
|
||||
&BEGIN_PROVIDER [ complex*16, psi_coef_sorted_gen_complex, (psi_det_size,N_states) ]
|
||||
implicit none
|
||||
BEGIN_DOC
|
||||
! For Single reference wave functions, the generator is the
|
||||
! Hartree-Fock determinant
|
||||
END_DOC
|
||||
integer :: i, k, l, m
|
||||
logical :: good
|
||||
integer, external :: number_of_holes,number_of_particles
|
||||
integer, allocatable :: nongen(:)
|
||||
integer :: inongen
|
||||
|
||||
allocate(nongen(N_det))
|
||||
|
||||
inongen = 0
|
||||
m=0
|
||||
do i=1,N_det
|
||||
good = ( number_of_holes(psi_det_sorted(1,1,i)) ==0).and.(number_of_particles(psi_det_sorted(1,1,i))==0 )
|
||||
if (good) then
|
||||
m = m+1
|
||||
psi_coef_generators_complex(m,:) = psi_coef_sorted_complex(i,:)
|
||||
else
|
||||
inongen += 1
|
||||
nongen(inongen) = i
|
||||
endif
|
||||
enddo
|
||||
ASSERT (m == N_det_generators)
|
||||
|
||||
psi_coef_sorted_gen_complex(:N_det_generators, :) = psi_coef_generators_complex(:N_det_generators, :)
|
||||
do i=1,inongen
|
||||
psi_coef_sorted_gen_complex(N_det_generators+i, :) = psi_coef_sorted_complex(nongen(i),:)
|
||||
end do
|
||||
END_PROVIDER
|
||||
|
||||
|
@ -22,20 +22,35 @@ BEGIN_PROVIDER [ integer, N_det_generators ]
|
||||
call write_int(6,N_det_generators,'Number of generators')
|
||||
END_PROVIDER
|
||||
|
||||
BEGIN_PROVIDER [ integer(bit_kind), psi_det_generators, (N_int,2,psi_det_size) ]
|
||||
&BEGIN_PROVIDER [ double precision, psi_coef_generators, (psi_det_size,N_states) ]
|
||||
BEGIN_PROVIDER [ integer(bit_kind), psi_det_generators, (N_int,2,psi_det_size) ]
|
||||
implicit none
|
||||
BEGIN_DOC
|
||||
! For Single reference wave functions, the generator is the
|
||||
! Hartree-Fock determinant
|
||||
END_DOC
|
||||
psi_det_generators(1:N_int,1:2,1:N_det) = psi_det_sorted(1:N_int,1:2,1:N_det)
|
||||
psi_coef_generators(1:N_det,1:N_states) = psi_coef_sorted(1:N_det,1:N_states)
|
||||
|
||||
END_PROVIDER
|
||||
|
||||
BEGIN_PROVIDER [ double precision, psi_coef_generators, (psi_det_size,N_states) ]
|
||||
implicit none
|
||||
BEGIN_DOC
|
||||
! For Single reference wave functions, the generator is the
|
||||
! Hartree-Fock determinant
|
||||
END_DOC
|
||||
psi_coef_generators(1:N_det,1:N_states) = psi_coef_sorted(1:N_det,1:N_states)
|
||||
END_PROVIDER
|
||||
|
||||
BEGIN_PROVIDER [ complex*16, psi_coef_generators_complex, (psi_det_size,N_states) ]
|
||||
implicit none
|
||||
BEGIN_DOC
|
||||
! For Single reference wave functions, the generator is the
|
||||
! Hartree-Fock determinant
|
||||
END_DOC
|
||||
psi_coef_generators_complex(1:N_det,1:N_states) = psi_coef_sorted_complex(1:N_det,1:N_states)
|
||||
END_PROVIDER
|
||||
|
||||
BEGIN_PROVIDER [ integer(bit_kind), psi_det_sorted_gen, (N_int,2,psi_det_size) ]
|
||||
&BEGIN_PROVIDER [ double precision, psi_coef_sorted_gen, (psi_det_size,N_states) ]
|
||||
&BEGIN_PROVIDER [ integer, psi_det_sorted_gen_order, (psi_det_size) ]
|
||||
|
||||
implicit none
|
||||
@ -44,10 +59,26 @@ END_PROVIDER
|
||||
! Hartree-Fock determinant
|
||||
END_DOC
|
||||
psi_det_sorted_gen = psi_det_sorted
|
||||
psi_coef_sorted_gen = psi_coef_sorted
|
||||
psi_det_sorted_gen_order = psi_det_sorted_order
|
||||
END_PROVIDER
|
||||
|
||||
BEGIN_PROVIDER [ double precision, psi_coef_sorted_gen, (psi_det_size,N_states) ]
|
||||
implicit none
|
||||
BEGIN_DOC
|
||||
! For Single reference wave functions, the generator is the
|
||||
! Hartree-Fock determinant
|
||||
END_DOC
|
||||
psi_coef_sorted_gen = psi_coef_sorted
|
||||
END_PROVIDER
|
||||
|
||||
BEGIN_PROVIDER [ complex*16, psi_coef_sorted_gen_complex, (psi_det_size,N_states) ]
|
||||
implicit none
|
||||
BEGIN_DOC
|
||||
! For Single reference wave functions, the generator is the
|
||||
! Hartree-Fock determinant
|
||||
END_DOC
|
||||
psi_coef_sorted_gen_complex = psi_coef_sorted_complex
|
||||
END_PROVIDER
|
||||
|
||||
BEGIN_PROVIDER [integer, degree_max_generators]
|
||||
implicit none
|
||||
|
@ -11,24 +11,52 @@ BEGIN_PROVIDER [double precision, extra_e_contrib_density]
|
||||
|
||||
END_PROVIDER
|
||||
|
||||
BEGIN_PROVIDER [ double precision, HF_energy]
|
||||
&BEGIN_PROVIDER [ double precision, HF_two_electron_energy]
|
||||
&BEGIN_PROVIDER [ double precision, HF_one_electron_energy]
|
||||
BEGIN_PROVIDER [ double precision, hf_energy]
|
||||
&BEGIN_PROVIDER [ double precision, hf_two_electron_energy]
|
||||
&BEGIN_PROVIDER [ double precision, hf_one_electron_energy]
|
||||
implicit none
|
||||
BEGIN_DOC
|
||||
! Hartree-Fock energy containing the nuclear repulsion, and its one- and two-body components.
|
||||
END_DOC
|
||||
integer :: i,j
|
||||
HF_energy = nuclear_repulsion
|
||||
HF_two_electron_energy = 0.d0
|
||||
HF_one_electron_energy = 0.d0
|
||||
do j=1,ao_num
|
||||
do i=1,ao_num
|
||||
HF_two_electron_energy += 0.5d0 * ( ao_two_e_integral_alpha(i,j) * SCF_density_matrix_ao_alpha(i,j) &
|
||||
+ao_two_e_integral_beta(i,j) * SCF_density_matrix_ao_beta(i,j) )
|
||||
HF_one_electron_energy += ao_one_e_integrals(i,j) * (SCF_density_matrix_ao_alpha(i,j) + SCF_density_matrix_ao_beta (i,j) )
|
||||
enddo
|
||||
enddo
|
||||
HF_energy += HF_two_electron_energy + HF_one_electron_energy
|
||||
integer :: i,j,k
|
||||
hf_energy = nuclear_repulsion
|
||||
hf_two_electron_energy = 0.d0
|
||||
hf_one_electron_energy = 0.d0
|
||||
if (is_complex) then
|
||||
complex*16 :: hf_1e_tmp, hf_2e_tmp
|
||||
hf_1e_tmp = (0.d0,0.d0)
|
||||
hf_2e_tmp = (0.d0,0.d0)
|
||||
do k=1,kpt_num
|
||||
do j=1,ao_num_per_kpt
|
||||
do i=1,ao_num_per_kpt
|
||||
hf_2e_tmp += 0.5d0 * ( ao_two_e_integral_alpha_kpts(i,j,k) * scf_density_matrix_ao_alpha_kpts(j,i,k) &
|
||||
+ao_two_e_integral_beta_kpts(i,j,k) * scf_density_matrix_ao_beta_kpts(j,i,k) )
|
||||
hf_1e_tmp += ao_one_e_integrals_kpts(i,j,k) * (scf_density_matrix_ao_alpha_kpts(j,i,k) &
|
||||
+ scf_density_matrix_ao_beta_kpts (j,i,k) )
|
||||
enddo
|
||||
enddo
|
||||
enddo
|
||||
if (dabs(dimag(hf_2e_tmp)).gt.1.d-10) then
|
||||
print*,'HF_2e energy should be real:',irp_here
|
||||
stop -1
|
||||
else
|
||||
hf_two_electron_energy = dble(hf_2e_tmp)
|
||||
endif
|
||||
if (dabs(dimag(hf_1e_tmp)).gt.1.d-10) then
|
||||
print*,'HF_1e energy should be real:',irp_here
|
||||
stop -1
|
||||
else
|
||||
hf_one_electron_energy = dble(hf_1e_tmp)
|
||||
endif
|
||||
else
|
||||
do j=1,ao_num
|
||||
do i=1,ao_num
|
||||
hf_two_electron_energy += 0.5d0 * ( ao_two_e_integral_alpha(i,j) * scf_density_matrix_ao_alpha(i,j) &
|
||||
+ao_two_e_integral_beta(i,j) * scf_density_matrix_ao_beta(i,j) )
|
||||
hf_one_electron_energy += ao_one_e_integrals(i,j) * (scf_density_matrix_ao_alpha(i,j) + scf_density_matrix_ao_beta (i,j) )
|
||||
enddo
|
||||
enddo
|
||||
endif
|
||||
hf_energy += hf_two_electron_energy + hf_one_electron_energy
|
||||
END_PROVIDER
|
||||
|
||||
|
19
src/hartree_fock/print_e_scf.irp.f
Normal file
19
src/hartree_fock/print_e_scf.irp.f
Normal file
@ -0,0 +1,19 @@
|
||||
program print_e_scf
|
||||
call run
|
||||
end
|
||||
|
||||
subroutine run
|
||||
|
||||
use bitmasks
|
||||
implicit none
|
||||
|
||||
call print_debug_scf_complex
|
||||
|
||||
print*,'hf 1e,2e,total energy'
|
||||
print*,hf_one_electron_energy
|
||||
print*,hf_two_electron_energy
|
||||
print*,hf_energy
|
||||
|
||||
end
|
||||
|
||||
|
@ -45,19 +45,43 @@ subroutine create_guess
|
||||
END_DOC
|
||||
logical :: exists
|
||||
PROVIDE ezfio_filename
|
||||
call ezfio_has_mo_basis_mo_coef(exists)
|
||||
if (is_complex) then
|
||||
! call ezfio_has_mo_basis_mo_coef_complex(exists)
|
||||
call ezfio_has_mo_basis_mo_coef_kpts(exists)
|
||||
else
|
||||
call ezfio_has_mo_basis_mo_coef(exists)
|
||||
endif
|
||||
if (.not.exists) then
|
||||
if (mo_guess_type == "HCore") then
|
||||
mo_coef = ao_ortho_lowdin_coef
|
||||
TOUCH mo_coef
|
||||
mo_label = 'Guess'
|
||||
call mo_as_eigvectors_of_mo_matrix(mo_one_e_integrals, &
|
||||
size(mo_one_e_integrals,1), &
|
||||
size(mo_one_e_integrals,2), &
|
||||
mo_label,1,.false.)
|
||||
SOFT_TOUCH mo_coef mo_label
|
||||
if (is_complex) then
|
||||
!mo_coef_complex = ao_ortho_lowdin_coef_complex
|
||||
mo_coef_kpts = ao_ortho_lowdin_coef_kpts
|
||||
TOUCH mo_coef_kpts
|
||||
mo_label = 'Guess'
|
||||
!call mo_as_eigvectors_of_mo_matrix_complex(mo_one_e_integrals_kpts, &
|
||||
call mo_as_eigvectors_of_mo_matrix_kpts(mo_one_e_integrals_kpts, &
|
||||
size(mo_one_e_integrals_kpts,1), &
|
||||
size(mo_one_e_integrals_kpts,2), &
|
||||
size(mo_one_e_integrals_kpts,3), &
|
||||
mo_label,1,.false.)
|
||||
SOFT_TOUCH mo_coef_kpts mo_label
|
||||
else
|
||||
mo_coef = ao_ortho_lowdin_coef
|
||||
TOUCH mo_coef
|
||||
mo_label = 'Guess'
|
||||
call mo_as_eigvectors_of_mo_matrix(mo_one_e_integrals, &
|
||||
size(mo_one_e_integrals,1), &
|
||||
size(mo_one_e_integrals,2), &
|
||||
mo_label,1,.false.)
|
||||
SOFT_TOUCH mo_coef mo_label
|
||||
endif
|
||||
else if (mo_guess_type == "Huckel") then
|
||||
call huckel_guess
|
||||
if (is_complex) then
|
||||
!call huckel_guess_complex
|
||||
call huckel_guess_kpts
|
||||
else
|
||||
call huckel_guess
|
||||
endif
|
||||
else
|
||||
print *, 'Unrecognized MO guess type : '//mo_guess_type
|
||||
stop 1
|
||||
@ -77,9 +101,17 @@ subroutine run
|
||||
integer :: i_it, i, j, k
|
||||
|
||||
mo_label = "Orthonormalized"
|
||||
|
||||
call Roothaan_Hall_SCF
|
||||
if (is_complex) then
|
||||
!call roothaan_hall_scf_complex
|
||||
call roothaan_hall_scf_kpts
|
||||
else
|
||||
call roothaan_hall_scf
|
||||
endif
|
||||
call ezfio_set_hartree_fock_energy(SCF_energy)
|
||||
print*,'hf 1e,2e,total energy'
|
||||
print*,hf_one_electron_energy
|
||||
print*,hf_two_electron_energy
|
||||
print*,hf_energy
|
||||
|
||||
end
|
||||
|
||||
|
@ -102,3 +102,15 @@ subroutine print_summary(e_,pt2_,error_,variance_,norm_,n_det_,n_occ_pattern_,n_
|
||||
|
||||
end subroutine
|
||||
|
||||
subroutine print_debug_fci
|
||||
implicit none
|
||||
integer :: i
|
||||
do i=1,n_det
|
||||
print'(2((F25.15),2X))',psi_coef_complex(i,1)
|
||||
call debug_det(psi_det(1,1,i),n_int)
|
||||
enddo
|
||||
print*,'hamiltonian'
|
||||
do i=1,n_det
|
||||
print '(1000(F25.15))',h_matrix_all_dets_complex(i,:)
|
||||
enddo
|
||||
end subroutine
|
||||
|
@ -9,6 +9,18 @@ doc: Coefficient of the i-th |AO| on the j-th |MO|
|
||||
interface: ezfio
|
||||
size: (ao_basis.ao_num,mo_basis.mo_num)
|
||||
|
||||
[mo_coef_complex]
|
||||
type: double precision
|
||||
doc: Complex MO coefficient of the i-th |AO| on the j-th |MO|
|
||||
interface: ezfio
|
||||
size: (2,ao_basis.ao_num,mo_basis.mo_num)
|
||||
|
||||
[mo_coef_kpts]
|
||||
type: double precision
|
||||
doc: Complex MO coefficient of the i-th |AO| on the j-th |MO|
|
||||
interface: ezfio
|
||||
size: (2,ao_basis.ao_num_per_kpt,mo_basis.mo_num_per_kpt,nuclei.kpt_num)
|
||||
|
||||
[mo_label]
|
||||
type: character*(64)
|
||||
doc: Label characterizing the MOS (Local, Canonical, Natural, *etc*)
|
||||
@ -20,6 +32,12 @@ doc: |MO| occupation numbers
|
||||
interface: ezfio
|
||||
size: (mo_basis.mo_num)
|
||||
|
||||
[mo_occ_kpts]
|
||||
type: double precision
|
||||
doc: |MO| occupation numbers
|
||||
interface: ezfio
|
||||
size: (mo_basis.mo_num_per_kpt,nuclei.kpt_num)
|
||||
|
||||
[mo_class]
|
||||
type: MO_class
|
||||
doc: [ Core | Inactive | Active | Virtual | Deleted ], as defined by :ref:`qp_set_mo_class`
|
||||
@ -31,3 +49,9 @@ type: character*(32)
|
||||
doc: MD5 checksum characterizing the |AO| basis set.
|
||||
interface: ezfio
|
||||
|
||||
[mo_num_per_kpt]
|
||||
type: integer
|
||||
doc: Number of |MOs| per kpt
|
||||
default: =(mo_basis.mo_num/nuclei.kpt_num)
|
||||
interface: ezfio
|
||||
|
||||
|
@ -1,3 +1,3 @@
|
||||
ao_basis
|
||||
ao_one_e_ints
|
||||
electrons
|
||||
ao_one_e_ints
|
||||
|
@ -101,7 +101,7 @@ BEGIN_PROVIDER [ double precision, mo_coef_in_ao_ortho_basis, (ao_num, mo_num) ]
|
||||
! $C^{-1}.C_{mo}$
|
||||
END_DOC
|
||||
call dgemm('N','N',ao_num,mo_num,ao_num,1.d0, &
|
||||
ao_ortho_canonical_coef_inv, size(ao_ortho_canonical_coef_inv,1),&
|
||||
ao_ortho_cano_coef_inv, size(ao_ortho_cano_coef_inv,1),&
|
||||
mo_coef, size(mo_coef,1), 0.d0, &
|
||||
mo_coef_in_ao_ortho_basis, size(mo_coef_in_ao_ortho_basis,1))
|
||||
|
||||
@ -242,28 +242,43 @@ subroutine mix_mo_jk(j,k)
|
||||
! by convention, the '+' |MO| is in the lowest index (min(j,k))
|
||||
! by convention, the '-' |MO| is in the highest index (max(j,k))
|
||||
END_DOC
|
||||
double precision :: array_tmp(ao_num,2),dsqrt_2
|
||||
if(j==k)then
|
||||
print*,'You want to mix two orbitals that are the same !'
|
||||
print*,'It does not make sense ... '
|
||||
print*,'Stopping ...'
|
||||
stop
|
||||
endif
|
||||
array_tmp = 0.d0
|
||||
double precision :: dsqrt_2
|
||||
dsqrt_2 = 1.d0/dsqrt(2.d0)
|
||||
do i = 1, ao_num
|
||||
array_tmp(i,1) = dsqrt_2 * (mo_coef(i,j) + mo_coef(i,k))
|
||||
array_tmp(i,2) = dsqrt_2 * (mo_coef(i,j) - mo_coef(i,k))
|
||||
enddo
|
||||
i_plus = min(j,k)
|
||||
i_minus = max(j,k)
|
||||
do i = 1, ao_num
|
||||
mo_coef(i,i_plus) = array_tmp(i,1)
|
||||
mo_coef(i,i_minus) = array_tmp(i,2)
|
||||
enddo
|
||||
if (is_complex) then
|
||||
complex*16 :: array_tmp_c(ao_num,2)
|
||||
array_tmp_c = (0.d0,0.d0)
|
||||
do i = 1, ao_num
|
||||
array_tmp_c(i,1) = dsqrt_2 * (mo_coef_complex(i,j) + mo_coef_complex(i,k))
|
||||
array_tmp_c(i,2) = dsqrt_2 * (mo_coef_complex(i,j) - mo_coef_complex(i,k))
|
||||
enddo
|
||||
do i = 1, ao_num
|
||||
mo_coef_complex(i,i_plus) = array_tmp_c(i,1)
|
||||
mo_coef_complex(i,i_minus) = array_tmp_c(i,2)
|
||||
enddo
|
||||
else
|
||||
double precision :: array_tmp(ao_num,2)
|
||||
array_tmp = 0.d0
|
||||
do i = 1, ao_num
|
||||
array_tmp(i,1) = dsqrt_2 * (mo_coef(i,j) + mo_coef(i,k))
|
||||
array_tmp(i,2) = dsqrt_2 * (mo_coef(i,j) - mo_coef(i,k))
|
||||
enddo
|
||||
do i = 1, ao_num
|
||||
mo_coef(i,i_plus) = array_tmp(i,1)
|
||||
mo_coef(i,i_minus) = array_tmp(i,2)
|
||||
enddo
|
||||
endif
|
||||
|
||||
end
|
||||
|
||||
|
||||
subroutine ao_ortho_cano_to_ao(A_ao,LDA_ao,A,LDA)
|
||||
implicit none
|
||||
BEGIN_DOC
|
||||
@ -280,13 +295,13 @@ subroutine ao_ortho_cano_to_ao(A_ao,LDA_ao,A,LDA)
|
||||
|
||||
call dgemm('T','N', ao_num, ao_num, ao_num, &
|
||||
1.d0, &
|
||||
ao_ortho_canonical_coef_inv, size(ao_ortho_canonical_coef_inv,1),&
|
||||
ao_ortho_cano_coef_inv, size(ao_ortho_cano_coef_inv,1),&
|
||||
A_ao,size(A_ao,1), &
|
||||
0.d0, T, size(T,1))
|
||||
|
||||
call dgemm('N','N', ao_num, ao_num, ao_num, 1.d0, &
|
||||
T, size(T,1), &
|
||||
ao_ortho_canonical_coef_inv,size(ao_ortho_canonical_coef_inv,1),&
|
||||
ao_ortho_cano_coef_inv,size(ao_ortho_cano_coef_inv,1),&
|
||||
0.d0, A, size(A,1))
|
||||
|
||||
deallocate(T)
|
||||
|
474
src/mo_basis/mos_cplx.irp.f
Normal file
474
src/mo_basis/mos_cplx.irp.f
Normal file
@ -0,0 +1,474 @@
|
||||
BEGIN_PROVIDER [ integer, mo_num_per_kpt ]
|
||||
implicit none
|
||||
BEGIN_DOC
|
||||
! number of mos per kpt.
|
||||
END_DOC
|
||||
mo_num_per_kpt = mo_num/kpt_num
|
||||
END_PROVIDER
|
||||
|
||||
BEGIN_PROVIDER [ complex*16, mo_coef_complex, (ao_num,mo_num) ]
|
||||
implicit none
|
||||
BEGIN_DOC
|
||||
! Molecular orbital coefficients on |AO| basis set
|
||||
!
|
||||
! mo_coef_imag(i,j) = coefficient of the i-th |AO| on the jth |MO|
|
||||
!
|
||||
! mo_label : Label characterizing the |MOs| (local, canonical, natural, etc)
|
||||
END_DOC
|
||||
integer :: i, j
|
||||
logical :: exists
|
||||
PROVIDE ezfio_filename
|
||||
|
||||
if (mpi_master) then
|
||||
! Coefs
|
||||
call ezfio_has_mo_basis_mo_coef_complex(exists)
|
||||
endif
|
||||
IRP_IF MPI_DEBUG
|
||||
print *, irp_here, mpi_rank
|
||||
call MPI_BARRIER(MPI_COMM_WORLD, ierr)
|
||||
IRP_ENDIF
|
||||
IRP_IF MPI
|
||||
include 'mpif.h'
|
||||
integer :: ierr
|
||||
call MPI_BCAST(exists, 1, MPI_LOGICAL, 0, MPI_COMM_WORLD, ierr)
|
||||
if (ierr /= MPI_SUCCESS) then
|
||||
stop 'Unable to read mo_coef_complex with MPI'
|
||||
endif
|
||||
IRP_ENDIF
|
||||
|
||||
if (exists) then
|
||||
if (mpi_master) then
|
||||
call ezfio_get_mo_basis_mo_coef_complex(mo_coef_complex)
|
||||
write(*,*) 'Read mo_coef_complex'
|
||||
endif
|
||||
IRP_IF MPI
|
||||
call MPI_BCAST( mo_coef_complex, mo_num*ao_num, MPI_DOUBLE_COMPLEX, 0, MPI_COMM_WORLD, ierr)
|
||||
if (ierr /= MPI_SUCCESS) then
|
||||
stop 'Unable to read mo_coef_complex with MPI'
|
||||
endif
|
||||
IRP_ENDIF
|
||||
else
|
||||
! Orthonormalized AO basis
|
||||
do i=1,mo_num
|
||||
do j=1,ao_num
|
||||
mo_coef_complex(j,i) = ao_ortho_canonical_coef_complex(j,i)
|
||||
enddo
|
||||
enddo
|
||||
endif
|
||||
END_PROVIDER
|
||||
|
||||
|
||||
BEGIN_PROVIDER [ complex*16, mo_coef_in_ao_ortho_basis_complex, (ao_num, mo_num) ]
|
||||
implicit none
|
||||
BEGIN_DOC
|
||||
! |MO| coefficients in orthogonalized |AO| basis
|
||||
!
|
||||
! $C^{-1}.C_{mo}$
|
||||
END_DOC
|
||||
call zgemm('N','N',ao_num,mo_num,ao_num,(1.d0,0.d0), &
|
||||
ao_ortho_cano_coef_inv_cplx, size(ao_ortho_cano_coef_inv_cplx,1),&
|
||||
mo_coef_complex, size(mo_coef_complex,1), (0.d0,0.d0), &
|
||||
mo_coef_in_ao_ortho_basis_complex, size(mo_coef_in_ao_ortho_basis_complex,1))
|
||||
|
||||
END_PROVIDER
|
||||
|
||||
BEGIN_PROVIDER [ complex*16, mo_coef_complex_kpts, (ao_num_per_kpt, mo_num_per_kpt, kpt_num) ]
|
||||
implicit none
|
||||
BEGIN_DOC
|
||||
! nonzero blocks of |MO| coefficients
|
||||
!
|
||||
END_DOC
|
||||
integer :: i,j,k, mo_shft, ao_shft
|
||||
mo_coef_complex_kpts = (0.d0,0.d0)
|
||||
|
||||
do k=1,kpt_num
|
||||
mo_shft = (k-1)*mo_num_per_kpt
|
||||
ao_shft = (k-1)*ao_num_per_kpt
|
||||
do i=1,mo_num_per_kpt
|
||||
do j=1,ao_num_per_kpt
|
||||
mo_coef_complex_kpts(j,i,k) = mo_coef_complex(j+ao_shft,i+mo_shft)
|
||||
enddo
|
||||
enddo
|
||||
enddo
|
||||
|
||||
END_PROVIDER
|
||||
|
||||
|
||||
BEGIN_PROVIDER [ complex*16, mo_coef_transp_complex, (mo_num,ao_num) ]
|
||||
&BEGIN_PROVIDER [ complex*16, mo_coef_transp_complex_conjg, (mo_num,ao_num) ]
|
||||
implicit none
|
||||
BEGIN_DOC
|
||||
! |MO| coefficients on |AO| basis set
|
||||
END_DOC
|
||||
integer :: i, j
|
||||
|
||||
do j=1,ao_num
|
||||
do i=1,mo_num
|
||||
mo_coef_transp_complex(i,j) = mo_coef_complex(j,i)
|
||||
mo_coef_transp_complex_conjg(i,j) = dconjg(mo_coef_complex(j,i))
|
||||
enddo
|
||||
enddo
|
||||
|
||||
END_PROVIDER
|
||||
|
||||
subroutine ao_to_mo_complex(A_ao,LDA_ao,A_mo,LDA_mo)
|
||||
implicit none
|
||||
BEGIN_DOC
|
||||
! Transform A from the AO basis to the MO basis
|
||||
! where A is complex in the AO basis
|
||||
!
|
||||
! C^\dagger.A_ao.C
|
||||
END_DOC
|
||||
integer, intent(in) :: LDA_ao,LDA_mo
|
||||
complex*16, intent(in) :: A_ao(LDA_ao,ao_num)
|
||||
complex*16, intent(out) :: A_mo(LDA_mo,mo_num)
|
||||
complex*16, allocatable :: T(:,:)
|
||||
|
||||
allocate ( T(ao_num,mo_num) )
|
||||
!DIR$ ATTRIBUTES ALIGN : $IRP_ALIGN :: T
|
||||
|
||||
call zgemm('N','N', ao_num, mo_num, ao_num, &
|
||||
(1.d0,0.d0), A_ao,LDA_ao, &
|
||||
mo_coef_complex, size(mo_coef_complex,1), &
|
||||
(0.d0,0.d0), T, size(T,1))
|
||||
|
||||
call zgemm('C','N', mo_num, mo_num, ao_num, &
|
||||
(1.d0,0.d0), mo_coef_complex,size(mo_coef_complex,1), &
|
||||
T, ao_num, &
|
||||
(0.d0,0.d0), A_mo, size(A_mo,1))
|
||||
|
||||
deallocate(T)
|
||||
end
|
||||
|
||||
subroutine ao_to_mo_noconjg_complex(A_ao,LDA_ao,A_mo,LDA_mo)
|
||||
implicit none
|
||||
BEGIN_DOC
|
||||
! Transform A from the AO basis to the MO basis
|
||||
! where A is complex in the AO basis
|
||||
!
|
||||
! C^T.A_ao.C
|
||||
! needed for 4idx tranform in four_idx_novvvv
|
||||
END_DOC
|
||||
integer, intent(in) :: LDA_ao,LDA_mo
|
||||
complex*16, intent(in) :: A_ao(LDA_ao,ao_num)
|
||||
complex*16, intent(out) :: A_mo(LDA_mo,mo_num)
|
||||
complex*16, allocatable :: T(:,:)
|
||||
|
||||
allocate ( T(ao_num,mo_num) )
|
||||
!DIR$ ATTRIBUTES ALIGN : $IRP_ALIGN :: T
|
||||
|
||||
call zgemm('N','N', ao_num, mo_num, ao_num, &
|
||||
(1.d0,0.d0), A_ao,LDA_ao, &
|
||||
mo_coef_complex, size(mo_coef_complex,1), &
|
||||
(0.d0,0.d0), T, size(T,1))
|
||||
|
||||
call zgemm('T','N', mo_num, mo_num, ao_num, &
|
||||
(1.d0,0.d0), mo_coef_complex,size(mo_coef_complex,1), &
|
||||
T, ao_num, &
|
||||
(0.d0,0.d0), A_mo, size(A_mo,1))
|
||||
|
||||
deallocate(T)
|
||||
end
|
||||
|
||||
|
||||
subroutine ao_ortho_cano_to_ao_cplx(A_ao,LDA_ao,A,LDA)
|
||||
implicit none
|
||||
BEGIN_DOC
|
||||
! Transform A from the |AO| basis to the orthogonal |AO| basis
|
||||
!
|
||||
! $C^{-1}.A_{ao}.C^{\dagger-1}$
|
||||
END_DOC
|
||||
integer, intent(in) :: LDA_ao,LDA
|
||||
complex*16, intent(in) :: A_ao(LDA_ao,*)
|
||||
complex*16, intent(out) :: A(LDA,*)
|
||||
complex*16, allocatable :: T(:,:)
|
||||
|
||||
allocate ( T(ao_num,ao_num) )
|
||||
|
||||
call zgemm('C','N', ao_num, ao_num, ao_num, &
|
||||
(1.d0,0.d0), &
|
||||
ao_ortho_cano_coef_inv_cplx, size(ao_ortho_cano_coef_inv_cplx,1),&
|
||||
A_ao,size(A_ao,1), &
|
||||
(0.d0,0.d0), T, size(T,1))
|
||||
|
||||
call zgemm('N','N', ao_num, ao_num, ao_num, (1.d0,0.d0), &
|
||||
T, size(T,1), &
|
||||
ao_ortho_cano_coef_inv_cplx,size(ao_ortho_cano_coef_inv_cplx,1),&
|
||||
(0.d0,0.d0), A, size(A,1))
|
||||
|
||||
deallocate(T)
|
||||
end
|
||||
|
||||
!============================================!
|
||||
! !
|
||||
! kpts !
|
||||
! !
|
||||
!============================================!
|
||||
|
||||
|
||||
BEGIN_PROVIDER [ complex*16, mo_coef_kpts, (ao_num_per_kpt, mo_num_per_kpt, kpt_num) ]
|
||||
implicit none
|
||||
BEGIN_DOC
|
||||
! Molecular orbital coefficients on |AO| basis set
|
||||
!
|
||||
! mo_coef_kpts(i,j,k) = coefficient of the i-th |AO| on the jth |MO| in kth kpt
|
||||
!
|
||||
! mo_label : Label characterizing the |MOs| (local, canonical, natural, etc)
|
||||
END_DOC
|
||||
integer :: i, j, k
|
||||
logical :: exists
|
||||
PROVIDE ezfio_filename
|
||||
|
||||
if (mpi_master) then
|
||||
! Coefs
|
||||
call ezfio_has_mo_basis_mo_coef_complex(exists)
|
||||
endif
|
||||
IRP_IF MPI_DEBUG
|
||||
print *, irp_here, mpi_rank
|
||||
call MPI_BARRIER(MPI_COMM_WORLD, ierr)
|
||||
IRP_ENDIF
|
||||
IRP_IF MPI
|
||||
include 'mpif.h'
|
||||
integer :: ierr
|
||||
call MPI_BCAST(exists, 1, MPI_LOGICAL, 0, MPI_COMM_WORLD, ierr)
|
||||
if (ierr /= MPI_SUCCESS) then
|
||||
stop 'Unable to read mo_coef_kpts with MPI'
|
||||
endif
|
||||
IRP_ENDIF
|
||||
|
||||
if (exists) then
|
||||
if (mpi_master) then
|
||||
call ezfio_get_mo_basis_mo_coef_kpts(mo_coef_kpts)
|
||||
write(*,*) 'Read mo_coef_kpts'
|
||||
endif
|
||||
IRP_IF MPI
|
||||
call MPI_BCAST( mo_coef_kpts, kpt_num*mo_num_per_kpt*ao_num_per_kpt, MPI_DOUBLE_COMPLEX, 0, MPI_COMM_WORLD, ierr)
|
||||
if (ierr /= MPI_SUCCESS) then
|
||||
stop 'Unable to read mo_coef_kpts with MPI'
|
||||
endif
|
||||
IRP_ENDIF
|
||||
else
|
||||
! Orthonormalized AO basis
|
||||
|
||||
do k=1,kpt_num
|
||||
do i=1,mo_num_per_kpt
|
||||
do j=1,ao_num_per_kpt
|
||||
mo_coef_kpts(j,i,k) = ao_ortho_canonical_coef_kpts(j,i,k)
|
||||
enddo
|
||||
enddo
|
||||
enddo
|
||||
endif
|
||||
END_PROVIDER
|
||||
|
||||
BEGIN_PROVIDER [ complex*16, mo_coef_in_ao_ortho_basis_kpts, (ao_num_per_kpt, mo_num_per_kpt, kpt_num) ]
|
||||
implicit none
|
||||
BEGIN_DOC
|
||||
! |MO| coefficients in orthogonalized |AO| basis
|
||||
!
|
||||
! $C^{-1}.C_{mo}$
|
||||
END_DOC
|
||||
integer :: k
|
||||
do k=1,kpt_num
|
||||
|
||||
call zgemm('N','N',ao_num_per_kpt,mo_num_per_kpt,ao_num_per_kpt,(1.d0,0.d0), &
|
||||
ao_ortho_cano_coef_inv_kpts(:,:,k), size(ao_ortho_cano_coef_inv_kpts,1),&
|
||||
mo_coef_kpts(:,:,k), size(mo_coef_kpts,1), (0.d0,0.d0), &
|
||||
mo_coef_in_ao_ortho_basis_kpts(:,:,k), size(mo_coef_in_ao_ortho_basis_kpts,1))
|
||||
enddo
|
||||
|
||||
END_PROVIDER
|
||||
|
||||
BEGIN_PROVIDER [ complex*16, mo_coef_transp_kpts, (mo_num_per_kpt,ao_num_per_kpt,kpt_num) ]
|
||||
&BEGIN_PROVIDER [ complex*16, mo_coef_transp_kpts_conjg, (mo_num_per_kpt,ao_num_per_kpt,kpt_num) ]
|
||||
implicit none
|
||||
BEGIN_DOC
|
||||
! |MO| coefficients on |AO| basis set
|
||||
END_DOC
|
||||
integer :: i, j, k
|
||||
|
||||
do k=1,kpt_num
|
||||
do j=1,ao_num_per_kpt
|
||||
do i=1,mo_num_per_kpt
|
||||
mo_coef_transp_kpts(i,j,k) = mo_coef_kpts(j,i,k)
|
||||
mo_coef_transp_kpts_conjg(i,j,k) = dconjg(mo_coef_kpts(j,i,k))
|
||||
enddo
|
||||
enddo
|
||||
enddo
|
||||
|
||||
END_PROVIDER
|
||||
|
||||
subroutine ao_to_mo_kpts(A_ao,LDA_ao,A_mo,LDA_mo)
|
||||
implicit none
|
||||
!todo: check this
|
||||
BEGIN_DOC
|
||||
! Transform A from the AO basis to the MO basis
|
||||
! where A is complex in the AO basis
|
||||
!
|
||||
! C^\dagger.A_ao.C
|
||||
END_DOC
|
||||
integer, intent(in) :: LDA_ao,LDA_mo
|
||||
complex*16, intent(in) :: A_ao(LDA_ao,ao_num_per_kpt,kpt_num)
|
||||
complex*16, intent(out) :: A_mo(LDA_mo,mo_num_per_kpt,kpt_num)
|
||||
complex*16, allocatable :: T(:,:)
|
||||
|
||||
allocate ( T(ao_num_per_kpt,mo_num_per_kpt) )
|
||||
!DIR$ ATTRIBUTES ALIGN : $IRP_ALIGN :: T
|
||||
integer :: k
|
||||
|
||||
do k=1,kpt_num
|
||||
call zgemm('N','N', ao_num_per_kpt, mo_num_per_kpt, ao_num_per_kpt, &
|
||||
(1.d0,0.d0), A_ao(:,:,k),LDA_ao, &
|
||||
mo_coef_kpts(:,:,k), size(mo_coef_kpts,1), &
|
||||
(0.d0,0.d0), T, size(T,1))
|
||||
|
||||
call zgemm('C','N', mo_num_per_kpt, mo_num_per_kpt, ao_num_per_kpt, &
|
||||
(1.d0,0.d0), mo_coef_kpts(:,:,k),size(mo_coef_kpts,1), &
|
||||
T, ao_num_per_kpt, &
|
||||
(0.d0,0.d0), A_mo(:,:,k), size(A_mo,1))
|
||||
enddo
|
||||
|
||||
deallocate(T)
|
||||
end
|
||||
|
||||
subroutine ao_to_mo_noconjg_kpts(A_ao,LDA_ao,A_mo,LDA_mo)
|
||||
implicit none
|
||||
BEGIN_DOC
|
||||
! Transform A from the AO basis to the MO basis
|
||||
! where A is complex in the AO basis
|
||||
!
|
||||
! C^T.A_ao.C
|
||||
! needed for 4idx tranform in four_idx_novvvv
|
||||
END_DOC
|
||||
integer, intent(in) :: LDA_ao,LDA_mo
|
||||
complex*16, intent(in) :: A_ao(LDA_ao,ao_num_per_kpt,kpt_num)
|
||||
complex*16, intent(out) :: A_mo(LDA_mo,mo_num_per_kpt,kpt_num)
|
||||
complex*16, allocatable :: T(:,:)
|
||||
|
||||
allocate ( T(ao_num_per_kpt,mo_num_per_kpt) )
|
||||
!DIR$ ATTRIBUTES ALIGN : $IRP_ALIGN :: T
|
||||
integer :: k
|
||||
do k=1,kpt_num
|
||||
call zgemm('N','N', ao_num_per_kpt, mo_num_per_kpt, ao_num_per_kpt, &
|
||||
(1.d0,0.d0), A_ao,LDA_ao, &
|
||||
mo_coef_kpts(:,:,k), size(mo_coef_kpts,1), &
|
||||
(0.d0,0.d0), T, size(T,1))
|
||||
|
||||
call zgemm('T','N', mo_num_per_kpt, mo_num_per_kpt, ao_num_per_kpt, &
|
||||
(1.d0,0.d0), mo_coef_kpts(:,:,k),size(mo_coef_kpts,1), &
|
||||
T, ao_num_per_kpt, &
|
||||
(0.d0,0.d0), A_mo(:,:,k), size(A_mo,1))
|
||||
enddo
|
||||
deallocate(T)
|
||||
end
|
||||
|
||||
|
||||
subroutine ao_ortho_cano_to_ao_kpts(A_ao,LDA_ao,A,LDA)
|
||||
implicit none
|
||||
!todo: check this; no longer using assumed-size arrays
|
||||
BEGIN_DOC
|
||||
! Transform A from the |AO| basis to the orthogonal |AO| basis
|
||||
!
|
||||
! $C^{-1}.A_{ao}.C^{\dagger-1}$
|
||||
END_DOC
|
||||
integer, intent(in) :: LDA_ao,LDA
|
||||
complex*16, intent(in) :: A_ao(LDA_ao,ao_num_per_kpt,kpt_num)
|
||||
complex*16, intent(out) :: A(LDA,ao_num_per_kpt,kpt_num)
|
||||
complex*16, allocatable :: T(:,:)
|
||||
|
||||
allocate ( T(ao_num_per_kpt,ao_num_per_kpt) )
|
||||
|
||||
integer :: k
|
||||
do k=1,kpt_num
|
||||
call zgemm('C','N', ao_num_per_kpt, ao_num_per_kpt, ao_num_per_kpt, &
|
||||
(1.d0,0.d0), &
|
||||
ao_ortho_cano_coef_inv_kpts(:,:,k), size(ao_ortho_cano_coef_inv_kpts,1),&
|
||||
A_ao(:,:,k),size(A_ao,1), &
|
||||
(0.d0,0.d0), T, size(T,1))
|
||||
|
||||
call zgemm('N','N', ao_num_per_kpt, ao_num_per_kpt, ao_num_per_kpt, (1.d0,0.d0), &
|
||||
T, size(T,1), &
|
||||
ao_ortho_cano_coef_inv_kpts(:,:,k),size(ao_ortho_cano_coef_inv_kpts,1),&
|
||||
(0.d0,0.d0), A(:,:,k), size(A,1))
|
||||
enddo
|
||||
|
||||
deallocate(T)
|
||||
end
|
||||
|
||||
|
||||
!============================================!
|
||||
! !
|
||||
! elec kpts !
|
||||
! !
|
||||
!============================================!
|
||||
|
||||
BEGIN_PROVIDER [ integer, elec_alpha_num_kpts, (kpt_num) ]
|
||||
&BEGIN_PROVIDER [ integer, elec_beta_num_kpts, (kpt_num) ]
|
||||
!todo: reorder? if not integer multiple, use some list of kpts to determine filling order
|
||||
implicit none
|
||||
|
||||
integer :: i,k,kpt
|
||||
|
||||
PROVIDE elec_alpha_num elec_beta_num
|
||||
|
||||
do k=1,kpt_num
|
||||
elec_alpha_num_kpts(k) = 0
|
||||
elec_beta_num_kpts(k) = 0
|
||||
enddo
|
||||
kpt=1
|
||||
do i=1,elec_beta_num
|
||||
elec_alpha_num_kpts(kpt) += 1
|
||||
elec_beta_num_kpts(kpt) += 1
|
||||
kpt += 1
|
||||
if (kpt > kpt_num) then
|
||||
kpt = 1
|
||||
endif
|
||||
enddo
|
||||
do i=elec_beta_num+1,elec_alpha_num
|
||||
elec_alpha_num_kpts(kpt) += 1
|
||||
kpt += 1
|
||||
if (kpt > kpt_num) then
|
||||
kpt = 1
|
||||
endif
|
||||
enddo
|
||||
|
||||
END_PROVIDER
|
||||
|
||||
BEGIN_PROVIDER [ double precision, mo_occ_kpts, (mo_num_per_kpt,kpt_num) ]
|
||||
implicit none
|
||||
BEGIN_DOC
|
||||
! |MO| occupation numbers
|
||||
END_DOC
|
||||
PROVIDE ezfio_filename elec_beta_num_kpts elec_alpha_num_kpts
|
||||
if (mpi_master) then
|
||||
logical :: exists
|
||||
call ezfio_has_mo_basis_mo_occ_kpts(exists)
|
||||
if (exists) then
|
||||
call ezfio_get_mo_basis_mo_occ_kpts(mo_occ_kpts)
|
||||
else
|
||||
mo_occ_kpts = 0.d0
|
||||
integer :: i,k
|
||||
do k=1,kpt_num
|
||||
do i=1,elec_beta_num_kpts(k)
|
||||
mo_occ_kpts(i,k) = 2.d0
|
||||
enddo
|
||||
do i=elec_beta_num_kpts(k)+1,elec_alpha_num_kpts(k)
|
||||
mo_occ_kpts(i,k) = 1.d0
|
||||
enddo
|
||||
enddo
|
||||
endif
|
||||
write(*,*) 'Read mo_occ_kpts'
|
||||
endif
|
||||
IRP_IF MPI_DEBUG
|
||||
print *, irp_here, mpi_rank
|
||||
call MPI_BARRIER(MPI_COMM_WORLD, ierr)
|
||||
IRP_ENDIF
|
||||
IRP_IF MPI
|
||||
include 'mpif.h'
|
||||
integer :: ierr
|
||||
call MPI_BCAST( mo_occ_kpts, mo_num_per_kpt*kpt_num, MPI_DOUBLE_PRECISION, 0, MPI_COMM_WORLD, ierr)
|
||||
if (ierr /= MPI_SUCCESS) then
|
||||
stop 'Unable to read mo_occ_kpts with MPI'
|
||||
endif
|
||||
IRP_ENDIF
|
||||
|
||||
END_PROVIDER
|
@ -1,62 +0,0 @@
|
||||
BEGIN_PROVIDER [ double precision, mo_coef_begin_iteration, (ao_num,mo_num) ]
|
||||
implicit none
|
||||
BEGIN_DOC
|
||||
! Void provider to store the coefficients of the |MO| basis at the beginning of the SCF iteration
|
||||
!
|
||||
! Usefull to track some orbitals
|
||||
END_DOC
|
||||
END_PROVIDER
|
||||
|
||||
subroutine initialize_mo_coef_begin_iteration
|
||||
implicit none
|
||||
BEGIN_DOC
|
||||
!
|
||||
! Initialize :c:data:`mo_coef_begin_iteration` to the current :c:data:`mo_coef`
|
||||
END_DOC
|
||||
mo_coef_begin_iteration = mo_coef
|
||||
end
|
||||
|
||||
subroutine reorder_core_orb
|
||||
implicit none
|
||||
BEGIN_DOC
|
||||
! routines that takes the current :c:data:`mo_coef` and reorder the core orbitals (see :c:data:`list_core` and :c:data:`n_core_orb`) according to the overlap with :c:data:`mo_coef_begin_iteration`
|
||||
END_DOC
|
||||
integer :: i,j,iorb
|
||||
integer :: k,l
|
||||
double precision, allocatable :: accu(:)
|
||||
integer, allocatable :: index_core_orb(:),iorder(:)
|
||||
double precision, allocatable :: mo_coef_tmp(:,:)
|
||||
allocate(accu(mo_num),index_core_orb(n_core_orb),iorder(mo_num))
|
||||
allocate(mo_coef_tmp(ao_num,mo_num))
|
||||
|
||||
do i = 1, n_core_orb
|
||||
iorb = list_core(i)
|
||||
do j = 1, mo_num
|
||||
accu(j) = 0.d0
|
||||
iorder(j) = j
|
||||
do k = 1, ao_num
|
||||
do l = 1, ao_num
|
||||
accu(j) += mo_coef_begin_iteration(k,iorb) * mo_coef(l,j) * ao_overlap(k,l)
|
||||
enddo
|
||||
enddo
|
||||
accu(j) = -dabs(accu(j))
|
||||
enddo
|
||||
call dsort(accu,iorder,mo_num)
|
||||
index_core_orb(i) = iorder(1)
|
||||
enddo
|
||||
|
||||
double precision :: x
|
||||
integer :: i1,i2
|
||||
do j = 1, n_core_orb
|
||||
i1 = list_core(j)
|
||||
i2 = index_core_orb(j)
|
||||
do i=1,ao_num
|
||||
x = mo_coef(i,i1)
|
||||
mo_coef(i,i1) = mo_coef(i,i2)
|
||||
mo_coef(i,i2) = x
|
||||
enddo
|
||||
enddo
|
||||
!call loc_cele_routine
|
||||
|
||||
deallocate(accu,index_core_orb, iorder)
|
||||
end
|
@ -1,23 +1,43 @@
|
||||
subroutine save_mos
|
||||
implicit none
|
||||
double precision, allocatable :: buffer(:,:)
|
||||
integer :: i,j
|
||||
|
||||
complex*16, allocatable :: buffer_c(:,:),buffer_k(:,:,:)
|
||||
integer :: i,j,k
|
||||
!TODO: change this for periodic?
|
||||
! save real/imag parts of mo_coef_complex
|
||||
! otherwise need to make sure mo_coef and mo_coef_imag
|
||||
! are updated whenever mo_coef_complex changes
|
||||
call system('$QP_ROOT/scripts/save_current_mos.sh '//trim(ezfio_filename))
|
||||
call ezfio_set_mo_basis_mo_num(mo_num)
|
||||
call ezfio_set_mo_basis_mo_label(mo_label)
|
||||
call ezfio_set_mo_basis_ao_md5(ao_md5)
|
||||
allocate ( buffer(ao_num,mo_num) )
|
||||
buffer = 0.d0
|
||||
do j = 1, mo_num
|
||||
do i = 1, ao_num
|
||||
buffer(i,j) = mo_coef(i,j)
|
||||
if (is_complex) then
|
||||
allocate ( buffer_c(ao_num,mo_num))
|
||||
allocate ( buffer_k(ao_num_per_kpt,mo_num_per_kpt,kpt_num))
|
||||
buffer_k = (0.d0,0.d0)
|
||||
do k=1,kpt_num
|
||||
do j = 1, mo_num_per_kpt
|
||||
do i = 1, ao_num_per_kpt
|
||||
buffer_k(i,j,k) = mo_coef_kpts(i,j,k)
|
||||
enddo
|
||||
enddo
|
||||
enddo
|
||||
enddo
|
||||
call ezfio_set_mo_basis_mo_coef(buffer)
|
||||
call ezfio_set_mo_basis_mo_occ(mo_occ)
|
||||
call ezfio_set_mo_basis_mo_coef_kpts(buffer_k)
|
||||
deallocate (buffer_k)
|
||||
call ezfio_set_mo_basis_mo_occ_kpts(mo_occ_kpts)
|
||||
else
|
||||
allocate ( buffer(ao_num,mo_num) )
|
||||
buffer = 0.d0
|
||||
do j = 1, mo_num
|
||||
do i = 1, ao_num
|
||||
buffer(i,j) = mo_coef(i,j)
|
||||
enddo
|
||||
enddo
|
||||
call ezfio_set_mo_basis_mo_coef(buffer)
|
||||
deallocate (buffer)
|
||||
call ezfio_set_mo_basis_mo_occ(mo_occ)
|
||||
endif
|
||||
call ezfio_set_mo_basis_mo_class(mo_class)
|
||||
deallocate (buffer)
|
||||
|
||||
end
|
||||
|
||||
@ -25,27 +45,41 @@ end
|
||||
subroutine save_mos_no_occ
|
||||
implicit none
|
||||
double precision, allocatable :: buffer(:,:)
|
||||
complex*16, allocatable :: buffer_c(:,:)
|
||||
integer :: i,j
|
||||
|
||||
call system('$QP_ROOT/scripts/save_current_mos.sh '//trim(ezfio_filename))
|
||||
!call ezfio_set_mo_basis_mo_num(mo_num)
|
||||
!call ezfio_set_mo_basis_mo_label(mo_label)
|
||||
!call ezfio_set_mo_basis_ao_md5(ao_md5)
|
||||
allocate ( buffer(ao_num,mo_num) )
|
||||
buffer = 0.d0
|
||||
do j = 1, mo_num
|
||||
do i = 1, ao_num
|
||||
buffer(i,j) = mo_coef(i,j)
|
||||
if (is_complex) then
|
||||
allocate ( buffer_c(ao_num,mo_num))
|
||||
buffer_c = (0.d0,0.d0)
|
||||
do j = 1, mo_num
|
||||
do i = 1, ao_num
|
||||
buffer_c(i,j) = mo_coef_complex(i,j)
|
||||
enddo
|
||||
enddo
|
||||
enddo
|
||||
call ezfio_set_mo_basis_mo_coef(buffer)
|
||||
deallocate (buffer)
|
||||
call ezfio_set_mo_basis_mo_coef_complex(buffer_c)
|
||||
deallocate (buffer_c)
|
||||
else
|
||||
allocate ( buffer(ao_num,mo_num) )
|
||||
buffer = 0.d0
|
||||
do j = 1, mo_num
|
||||
do i = 1, ao_num
|
||||
buffer(i,j) = mo_coef(i,j)
|
||||
enddo
|
||||
enddo
|
||||
call ezfio_set_mo_basis_mo_coef(buffer)
|
||||
deallocate (buffer)
|
||||
endif
|
||||
|
||||
end
|
||||
|
||||
subroutine save_mos_truncated(n)
|
||||
implicit none
|
||||
double precision, allocatable :: buffer(:,:)
|
||||
complex*16, allocatable :: buffer_c(:,:)
|
||||
integer :: i,j,n
|
||||
|
||||
call system('$QP_ROOT/scripts/save_current_mos.sh '//trim(ezfio_filename))
|
||||
@ -53,17 +87,29 @@ subroutine save_mos_truncated(n)
|
||||
call ezfio_set_mo_basis_mo_num(n)
|
||||
call ezfio_set_mo_basis_mo_label(mo_label)
|
||||
call ezfio_set_mo_basis_ao_md5(ao_md5)
|
||||
allocate ( buffer(ao_num,n) )
|
||||
buffer = 0.d0
|
||||
do j = 1, n
|
||||
do i = 1, ao_num
|
||||
buffer(i,j) = mo_coef(i,j)
|
||||
if (is_complex) then
|
||||
allocate ( buffer_c(ao_num,mo_num))
|
||||
buffer_c = (0.d0,0.d0)
|
||||
do j = 1, n
|
||||
do i = 1, ao_num
|
||||
buffer_c(i,j) = mo_coef_complex(i,j)
|
||||
enddo
|
||||
enddo
|
||||
enddo
|
||||
call ezfio_set_mo_basis_mo_coef(buffer)
|
||||
call ezfio_set_mo_basis_mo_coef_complex(buffer_c)
|
||||
deallocate (buffer_c)
|
||||
else
|
||||
allocate ( buffer(ao_num,n) )
|
||||
buffer = 0.d0
|
||||
do j = 1, n
|
||||
do i = 1, ao_num
|
||||
buffer(i,j) = mo_coef(i,j)
|
||||
enddo
|
||||
enddo
|
||||
call ezfio_set_mo_basis_mo_coef(buffer)
|
||||
deallocate (buffer)
|
||||
endif
|
||||
call ezfio_set_mo_basis_mo_occ(mo_occ)
|
||||
call ezfio_set_mo_basis_mo_class(mo_class)
|
||||
deallocate (buffer)
|
||||
|
||||
end
|
||||
|
||||
|
515
src/mo_basis/utils_cplx.irp.f
Normal file
515
src/mo_basis/utils_cplx.irp.f
Normal file
@ -0,0 +1,515 @@
|
||||
subroutine mo_as_eigvectors_of_mo_matrix_complex(matrix,n,m,label,sign,output)
|
||||
!TODO: test this
|
||||
implicit none
|
||||
integer,intent(in) :: n,m, sign
|
||||
character*(64), intent(in) :: label
|
||||
complex*16, intent(in) :: matrix(n,m)
|
||||
logical, intent(in) :: output
|
||||
|
||||
integer :: i,j
|
||||
double precision, allocatable :: eigvalues(:)
|
||||
complex*16, allocatable :: mo_coef_new(:,:), R(:,:), A(:,:)
|
||||
!DIR$ ATTRIBUTES ALIGN : $IRP_ALIGN :: mo_coef_new, R
|
||||
|
||||
call write_time(6)
|
||||
if (m /= mo_num) then
|
||||
print *, irp_here, ': Error : m/= mo_num'
|
||||
stop 1
|
||||
endif
|
||||
allocate(A(n,m),R(n,m),mo_coef_new(ao_num,m),eigvalues(m))
|
||||
if (sign == -1) then
|
||||
do j=1,m
|
||||
do i=1,n
|
||||
A(i,j) = -matrix(i,j)
|
||||
enddo
|
||||
enddo
|
||||
else
|
||||
do j=1,m
|
||||
do i=1,n
|
||||
A(i,j) = matrix(i,j)
|
||||
enddo
|
||||
enddo
|
||||
endif
|
||||
mo_coef_new = mo_coef_complex
|
||||
|
||||
call lapack_diag_complex(eigvalues,R,A,n,m)
|
||||
if (output) then
|
||||
write (6,'(A)') 'MOs are now **'//trim(label)//'**'
|
||||
write (6,'(A)') ''
|
||||
write (6,'(A)') 'Eigenvalues'
|
||||
write (6,'(A)') '-----------'
|
||||
write (6,'(A)') ''
|
||||
write (6,'(A)') '======== ================'
|
||||
endif
|
||||
if (sign == -1) then
|
||||
do i=1,m
|
||||
eigvalues(i) = -eigvalues(i)
|
||||
enddo
|
||||
endif
|
||||
if (output) then
|
||||
do i=1,m
|
||||
write (6,'(I8,1X,F16.10)') i,eigvalues(i)
|
||||
enddo
|
||||
write (6,'(A)') '======== ================'
|
||||
write (6,'(A)') ''
|
||||
!write (6,'(A)') 'Fock Matrix'
|
||||
!write (6,'(A)') '-----------'
|
||||
!do i=1,n
|
||||
! write(*,'(200(E24.15))') A(i,:)
|
||||
!enddo
|
||||
endif
|
||||
|
||||
call zgemm('N','N',ao_num,m,m,(1.d0,0.d0),mo_coef_new,size(mo_coef_new,1),R,size(R,1),(0.d0,0.d0),mo_coef_complex,size(mo_coef_complex,1))
|
||||
deallocate(A,mo_coef_new,R,eigvalues)
|
||||
call write_time(6)
|
||||
|
||||
mo_label = label
|
||||
end
|
||||
|
||||
subroutine mo_as_svd_vectors_of_mo_matrix_complex(matrix,lda,m,n,label)
|
||||
!TODO: test this
|
||||
implicit none
|
||||
integer,intent(in) :: lda,m,n
|
||||
character*(64), intent(in) :: label
|
||||
complex*16, intent(in) :: matrix(lda,n)
|
||||
|
||||
integer :: i,j
|
||||
double precision :: accu
|
||||
double precision, allocatable :: D(:)
|
||||
complex*16, allocatable :: mo_coef_new(:,:), U(:,:), A(:,:), Vt(:,:)
|
||||
!DIR$ ATTRIBUTES ALIGN : $IRP_ALIGN :: mo_coef_new, U, Vt, A
|
||||
|
||||
call write_time(6)
|
||||
if (m /= mo_num) then
|
||||
print *, irp_here, ': Error : m/= mo_num'
|
||||
stop 1
|
||||
endif
|
||||
|
||||
allocate(A(lda,n),U(lda,n),mo_coef_new(ao_num,m),D(m),Vt(lda,n))
|
||||
|
||||
do j=1,n
|
||||
do i=1,m
|
||||
A(i,j) = matrix(i,j)
|
||||
enddo
|
||||
enddo
|
||||
mo_coef_new = mo_coef_complex
|
||||
|
||||
call svd_complex(A,lda,U,lda,D,Vt,lda,m,n)
|
||||
|
||||
write (6,'(A)') 'MOs are now **'//trim(label)//'**'
|
||||
write (6,'(A)') ''
|
||||
write (6,'(A)') 'Eigenvalues'
|
||||
write (6,'(A)') '-----------'
|
||||
write (6,'(A)') ''
|
||||
write (6,'(A)') '======== ================ ================'
|
||||
write (6,'(A)') ' MO Eigenvalue Cumulative '
|
||||
write (6,'(A)') '======== ================ ================'
|
||||
|
||||
accu = 0.d0
|
||||
do i=1,m
|
||||
accu = accu + D(i)
|
||||
write (6,'(I8,1X,F16.10,1X,F16.10)') i,D(i), accu
|
||||
enddo
|
||||
write (6,'(A)') '======== ================ ================'
|
||||
write (6,'(A)') ''
|
||||
|
||||
call zgemm('N','N',ao_num,m,m,(1.d0,0.d0),mo_coef_new,size(mo_coef_new,1),U,size(U,1),(0.d0,0.d0),mo_coef_complex,size(mo_coef_complex,1))
|
||||
deallocate(A,mo_coef_new,U,Vt,D)
|
||||
call write_time(6)
|
||||
|
||||
mo_label = label
|
||||
end
|
||||
|
||||
|
||||
subroutine mo_as_svd_vectors_of_mo_matrix_eig_complex(matrix,lda,m,n,eig,label)
|
||||
!TODO: test this
|
||||
implicit none
|
||||
integer,intent(in) :: lda,m,n
|
||||
character*(64), intent(in) :: label
|
||||
complex*16, intent(in) :: matrix(lda,n)
|
||||
double precision, intent(out) :: eig(m)
|
||||
|
||||
integer :: i,j
|
||||
double precision :: accu
|
||||
double precision, allocatable :: D(:)
|
||||
complex*16, allocatable :: mo_coef_new(:,:), U(:,:), A(:,:), Vt(:,:), work(:)
|
||||
!DIR$ ATTRIBUTES ALIGN : $IRP_ALIGN :: mo_coef_new, U, Vt, A
|
||||
|
||||
call write_time(6)
|
||||
if (m /= mo_num) then
|
||||
print *, irp_here, ': Error : m/= mo_num'
|
||||
stop 1
|
||||
endif
|
||||
|
||||
allocate(A(lda,n),U(lda,n),mo_coef_new(ao_num,m),D(m),Vt(lda,n))
|
||||
|
||||
do j=1,n
|
||||
do i=1,m
|
||||
A(i,j) = matrix(i,j)
|
||||
enddo
|
||||
enddo
|
||||
mo_coef_new = mo_coef_complex
|
||||
|
||||
call svd_complex(A,lda,U,lda,D,Vt,lda,m,n)
|
||||
|
||||
write (6,'(A)') 'MOs are now **'//trim(label)//'**'
|
||||
write (6,'(A)') ''
|
||||
write (6,'(A)') 'Eigenvalues'
|
||||
write (6,'(A)') '-----------'
|
||||
write (6,'(A)') ''
|
||||
write (6,'(A)') '======== ================ ================'
|
||||
write (6,'(A)') ' MO Eigenvalue Cumulative '
|
||||
write (6,'(A)') '======== ================ ================'
|
||||
|
||||
accu = 0.d0
|
||||
do i=1,m
|
||||
accu = accu + D(i)
|
||||
write (6,'(I8,1X,F16.10,1X,F16.10)') i,D(i), accu
|
||||
enddo
|
||||
write (6,'(A)') '======== ================ ================'
|
||||
write (6,'(A)') ''
|
||||
|
||||
call zgemm('N','N',ao_num,m,m,(1.d0,0.d0),mo_coef_new,size(mo_coef_new,1),U,size(U,1),(0.d0,0.d0),mo_coef_complex,size(mo_coef_complex,1))
|
||||
|
||||
do i=1,m
|
||||
eig(i) = D(i)
|
||||
enddo
|
||||
|
||||
deallocate(A,mo_coef_new,U,Vt,D)
|
||||
call write_time(6)
|
||||
|
||||
mo_label = label
|
||||
|
||||
end
|
||||
|
||||
|
||||
subroutine mo_coef_new_as_svd_vectors_of_mo_matrix_eig_complex(matrix,lda,m,n,mo_coef_before,eig,mo_coef_new)
|
||||
implicit none
|
||||
BEGIN_DOC
|
||||
! You enter with matrix in the MO basis defined with the mo_coef_before.
|
||||
!
|
||||
! You SVD the matrix and set the eigenvectors as mo_coef_new ordered by increasing singular values
|
||||
END_DOC
|
||||
integer,intent(in) :: lda,m,n
|
||||
complex*16, intent(in) :: matrix(lda,n),mo_coef_before(ao_num,m)
|
||||
double precision, intent(out) :: eig(m)
|
||||
complex*16, intent(out) :: mo_coef_new(ao_num,m)
|
||||
|
||||
integer :: i,j
|
||||
double precision :: accu
|
||||
double precision, allocatable :: D(:)
|
||||
complex*16, allocatable :: mo_coef_tmp(:,:), U(:,:), A(:,:), Vt(:,:), work(:)
|
||||
!DIR$ ATTRIBUTES ALIGN : $IRP_ALIGN :: U, Vt, A
|
||||
|
||||
call write_time(6)
|
||||
if (m /= mo_num) then
|
||||
print *, irp_here, ': Error : m/= mo_num'
|
||||
stop 1
|
||||
endif
|
||||
|
||||
allocate(A(lda,n),U(lda,n),D(m),Vt(lda,n),mo_coef_tmp(ao_num,mo_num))
|
||||
|
||||
do j=1,n
|
||||
do i=1,m
|
||||
A(i,j) = matrix(i,j)
|
||||
enddo
|
||||
enddo
|
||||
mo_coef_tmp = mo_coef_before
|
||||
|
||||
call svd_complex(A,lda,U,lda,D,Vt,lda,m,n)
|
||||
|
||||
write (6,'(A)') ''
|
||||
write (6,'(A)') 'Eigenvalues'
|
||||
write (6,'(A)') '-----------'
|
||||
write (6,'(A)') ''
|
||||
write (6,'(A)') '======== ================ ================'
|
||||
write (6,'(A)') ' MO Eigenvalue Cumulative '
|
||||
write (6,'(A)') '======== ================ ================'
|
||||
|
||||
accu = 0.d0
|
||||
do i=1,m
|
||||
accu = accu + D(i)
|
||||
write (6,'(I8,1X,F16.10,1X,F16.10)') i,D(i), accu
|
||||
enddo
|
||||
write (6,'(A)') '======== ================ ================'
|
||||
write (6,'(A)') ''
|
||||
|
||||
call zgemm('N','N',ao_num,m,m,(1.d0,0.d0),mo_coef_tmp,size(mo_coef_new,1),U,size(U,1),(0.d0,0.d0),mo_coef_new,size(mo_coef_new,1))
|
||||
|
||||
do i=1,m
|
||||
eig(i) = D(i)
|
||||
enddo
|
||||
|
||||
deallocate(A,U,Vt,D,mo_coef_tmp)
|
||||
call write_time(6)
|
||||
|
||||
end
|
||||
|
||||
!============================================!
|
||||
! !
|
||||
! kpts !
|
||||
! !
|
||||
!============================================!
|
||||
|
||||
subroutine mo_as_eigvectors_of_mo_matrix_kpts(matrix,n,m,nk,label,sign,output)
|
||||
!TODO: test this
|
||||
implicit none
|
||||
integer,intent(in) :: n,m,nk, sign
|
||||
character*(64), intent(in) :: label
|
||||
complex*16, intent(in) :: matrix(n,m,nk)
|
||||
logical, intent(in) :: output
|
||||
|
||||
integer :: i,j,k
|
||||
double precision, allocatable :: eigvalues(:)
|
||||
complex*16, allocatable :: mo_coef_new(:,:), R(:,:), A(:,:)
|
||||
!DIR$ ATTRIBUTES ALIGN : $IRP_ALIGN :: mo_coef_new, R
|
||||
|
||||
call write_time(6)
|
||||
if (m /= mo_num_per_kpt) then
|
||||
print *, irp_here, ': Error : m/= mo_num_per_kpt'
|
||||
stop 1
|
||||
endif
|
||||
if (nk /= kpt_num) then
|
||||
print *, irp_here, ': Error : nk/= kpt_num'
|
||||
stop 1
|
||||
endif
|
||||
allocate(A(n,m),R(n,m),mo_coef_new(ao_num_per_kpt,m),eigvalues(m))
|
||||
do k=1,nk
|
||||
if (sign == -1) then
|
||||
do j=1,m
|
||||
do i=1,n
|
||||
A(i,j) = -matrix(i,j,k)
|
||||
enddo
|
||||
enddo
|
||||
else
|
||||
do j=1,m
|
||||
do i=1,n
|
||||
A(i,j) = matrix(i,j,k)
|
||||
enddo
|
||||
enddo
|
||||
endif
|
||||
mo_coef_new = mo_coef_kpts(:,:,k)
|
||||
|
||||
call lapack_diag_complex(eigvalues,R,A,n,m)
|
||||
if (sign == -1) then
|
||||
do i=1,m
|
||||
eigvalues(i) = -eigvalues(i)
|
||||
enddo
|
||||
endif
|
||||
if (output) then
|
||||
do i=1,m
|
||||
write (6,'(2(I8),1X,F16.10)') k,i,eigvalues(i)
|
||||
enddo
|
||||
write (6,'(A)') '======== ================'
|
||||
write (6,'(A)') ''
|
||||
!write (6,'(A)') 'Fock Matrix'
|
||||
!write (6,'(A)') '-----------'
|
||||
!do i=1,n
|
||||
! write(*,'(200(E24.15))') A(i,:)
|
||||
!enddo
|
||||
endif
|
||||
|
||||
call zgemm('N','N',ao_num_per_kpt,m,m,(1.d0,0.d0), &
|
||||
mo_coef_new,size(mo_coef_new,1),R,size(R,1),(0.d0,0.d0), &
|
||||
mo_coef_kpts(:,:,k),size(mo_coef_kpts,1))
|
||||
enddo
|
||||
deallocate(A,mo_coef_new,R,eigvalues)
|
||||
call write_time(6)
|
||||
|
||||
mo_label = label
|
||||
if (output) then
|
||||
write (6,'(A)') 'MOs are now **'//trim(label)//'**'
|
||||
write (6,'(A)') ''
|
||||
write (6,'(A)') 'Eigenvalues'
|
||||
write (6,'(A)') '-----------'
|
||||
write (6,'(A)') ''
|
||||
write (6,'(A)') '======== ================'
|
||||
endif
|
||||
end
|
||||
|
||||
subroutine mo_as_svd_vectors_of_mo_matrix_kpts(matrix,lda,m,n,label)
|
||||
!TODO: implement
|
||||
print *, irp_here, ' not implemented for kpts'
|
||||
stop 1
|
||||
implicit none
|
||||
integer,intent(in) :: lda,m,n
|
||||
character*(64), intent(in) :: label
|
||||
complex*16, intent(in) :: matrix(lda,n)
|
||||
|
||||
integer :: i,j
|
||||
double precision :: accu
|
||||
double precision, allocatable :: D(:)
|
||||
complex*16, allocatable :: mo_coef_new(:,:), U(:,:), A(:,:), Vt(:,:)
|
||||
!DIR$ ATTRIBUTES ALIGN : $IRP_ALIGN :: mo_coef_new, U, Vt, A
|
||||
|
||||
call write_time(6)
|
||||
if (m /= mo_num) then
|
||||
print *, irp_here, ': Error : m/= mo_num'
|
||||
stop 1
|
||||
endif
|
||||
|
||||
allocate(A(lda,n),U(lda,n),mo_coef_new(ao_num,m),D(m),Vt(lda,n))
|
||||
|
||||
do j=1,n
|
||||
do i=1,m
|
||||
A(i,j) = matrix(i,j)
|
||||
enddo
|
||||
enddo
|
||||
mo_coef_new = mo_coef_complex
|
||||
|
||||
call svd_complex(A,lda,U,lda,D,Vt,lda,m,n)
|
||||
|
||||
write (6,'(A)') 'MOs are now **'//trim(label)//'**'
|
||||
write (6,'(A)') ''
|
||||
write (6,'(A)') 'Eigenvalues'
|
||||
write (6,'(A)') '-----------'
|
||||
write (6,'(A)') ''
|
||||
write (6,'(A)') '======== ================ ================'
|
||||
write (6,'(A)') ' MO Eigenvalue Cumulative '
|
||||
write (6,'(A)') '======== ================ ================'
|
||||
|
||||
accu = 0.d0
|
||||
do i=1,m
|
||||
accu = accu + D(i)
|
||||
write (6,'(I8,1X,F16.10,1X,F16.10)') i,D(i), accu
|
||||
enddo
|
||||
write (6,'(A)') '======== ================ ================'
|
||||
write (6,'(A)') ''
|
||||
|
||||
call zgemm('N','N',ao_num,m,m,(1.d0,0.d0),mo_coef_new,size(mo_coef_new,1),U,size(U,1),(0.d0,0.d0),mo_coef_complex,size(mo_coef_complex,1))
|
||||
deallocate(A,mo_coef_new,U,Vt,D)
|
||||
call write_time(6)
|
||||
|
||||
mo_label = label
|
||||
end
|
||||
|
||||
|
||||
subroutine mo_as_svd_vectors_of_mo_matrix_eig_kpts(matrix,lda,m,n,eig,label)
|
||||
!TODO: implement
|
||||
print *, irp_here, ' not implemented for kpts'
|
||||
stop 1
|
||||
implicit none
|
||||
integer,intent(in) :: lda,m,n
|
||||
character*(64), intent(in) :: label
|
||||
complex*16, intent(in) :: matrix(lda,n)
|
||||
double precision, intent(out) :: eig(m)
|
||||
|
||||
integer :: i,j
|
||||
double precision :: accu
|
||||
double precision, allocatable :: D(:)
|
||||
complex*16, allocatable :: mo_coef_new(:,:), U(:,:), A(:,:), Vt(:,:), work(:)
|
||||
!DIR$ ATTRIBUTES ALIGN : $IRP_ALIGN :: mo_coef_new, U, Vt, A
|
||||
|
||||
call write_time(6)
|
||||
if (m /= mo_num) then
|
||||
print *, irp_here, ': Error : m/= mo_num'
|
||||
stop 1
|
||||
endif
|
||||
|
||||
allocate(A(lda,n),U(lda,n),mo_coef_new(ao_num,m),D(m),Vt(lda,n))
|
||||
|
||||
do j=1,n
|
||||
do i=1,m
|
||||
A(i,j) = matrix(i,j)
|
||||
enddo
|
||||
enddo
|
||||
mo_coef_new = mo_coef_complex
|
||||
|
||||
call svd_complex(A,lda,U,lda,D,Vt,lda,m,n)
|
||||
|
||||
write (6,'(A)') 'MOs are now **'//trim(label)//'**'
|
||||
write (6,'(A)') ''
|
||||
write (6,'(A)') 'Eigenvalues'
|
||||
write (6,'(A)') '-----------'
|
||||
write (6,'(A)') ''
|
||||
write (6,'(A)') '======== ================ ================'
|
||||
write (6,'(A)') ' MO Eigenvalue Cumulative '
|
||||
write (6,'(A)') '======== ================ ================'
|
||||
|
||||
accu = 0.d0
|
||||
do i=1,m
|
||||
accu = accu + D(i)
|
||||
write (6,'(I8,1X,F16.10,1X,F16.10)') i,D(i), accu
|
||||
enddo
|
||||
write (6,'(A)') '======== ================ ================'
|
||||
write (6,'(A)') ''
|
||||
|
||||
call zgemm('N','N',ao_num,m,m,(1.d0,0.d0),mo_coef_new,size(mo_coef_new,1),U,size(U,1),(0.d0,0.d0),mo_coef_complex,size(mo_coef_complex,1))
|
||||
|
||||
do i=1,m
|
||||
eig(i) = D(i)
|
||||
enddo
|
||||
|
||||
deallocate(A,mo_coef_new,U,Vt,D)
|
||||
call write_time(6)
|
||||
|
||||
mo_label = label
|
||||
|
||||
end
|
||||
|
||||
|
||||
subroutine mo_coef_new_as_svd_vectors_of_mo_matrix_eig_kpts(matrix,lda,m,n,mo_coef_before,eig,mo_coef_new)
|
||||
!TODO: implement
|
||||
print *, irp_here, ' not implemented for kpts'
|
||||
stop 1
|
||||
implicit none
|
||||
BEGIN_DOC
|
||||
! You enter with matrix in the MO basis defined with the mo_coef_before.
|
||||
!
|
||||
! You SVD the matrix and set the eigenvectors as mo_coef_new ordered by increasing singular values
|
||||
END_DOC
|
||||
integer,intent(in) :: lda,m,n
|
||||
complex*16, intent(in) :: matrix(lda,n),mo_coef_before(ao_num,m)
|
||||
double precision, intent(out) :: eig(m)
|
||||
complex*16, intent(out) :: mo_coef_new(ao_num,m)
|
||||
|
||||
integer :: i,j
|
||||
double precision :: accu
|
||||
double precision, allocatable :: D(:)
|
||||
complex*16, allocatable :: mo_coef_tmp(:,:), U(:,:), A(:,:), Vt(:,:), work(:)
|
||||
!DIR$ ATTRIBUTES ALIGN : $IRP_ALIGN :: U, Vt, A
|
||||
|
||||
call write_time(6)
|
||||
if (m /= mo_num) then
|
||||
print *, irp_here, ': Error : m/= mo_num'
|
||||
stop 1
|
||||
endif
|
||||
|
||||
allocate(A(lda,n),U(lda,n),D(m),Vt(lda,n),mo_coef_tmp(ao_num,mo_num))
|
||||
|
||||
do j=1,n
|
||||
do i=1,m
|
||||
A(i,j) = matrix(i,j)
|
||||
enddo
|
||||
enddo
|
||||
mo_coef_tmp = mo_coef_before
|
||||
|
||||
call svd_complex(A,lda,U,lda,D,Vt,lda,m,n)
|
||||
|
||||
write (6,'(A)') ''
|
||||
write (6,'(A)') 'Eigenvalues'
|
||||
write (6,'(A)') '-----------'
|
||||
write (6,'(A)') ''
|
||||
write (6,'(A)') '======== ================ ================'
|
||||
write (6,'(A)') ' MO Eigenvalue Cumulative '
|
||||
write (6,'(A)') '======== ================ ================'
|
||||
|
||||
accu = 0.d0
|
||||
do i=1,m
|
||||
accu = accu + D(i)
|
||||
write (6,'(I8,1X,F16.10,1X,F16.10)') i,D(i), accu
|
||||
enddo
|
||||
write (6,'(A)') '======== ================ ================'
|
||||
write (6,'(A)') ''
|
||||
|
||||
call zgemm('N','N',ao_num,m,m,(1.d0,0.d0),mo_coef_tmp,size(mo_coef_new,1),U,size(U,1),(0.d0,0.d0),mo_coef_new,size(mo_coef_new,1))
|
||||
|
||||
do i=1,m
|
||||
eig(i) = D(i)
|
||||
enddo
|
||||
|
||||
deallocate(A,U,Vt,D,mo_coef_tmp)
|
||||
call write_time(6)
|
||||
|
||||
end
|
||||
|
@ -5,9 +5,18 @@ subroutine hcore_guess
|
||||
implicit none
|
||||
character*(64) :: label
|
||||
label = "Guess"
|
||||
call mo_as_eigvectors_of_mo_matrix(mo_one_e_integrals, &
|
||||
size(mo_one_e_integrals,1), &
|
||||
size(mo_one_e_integrals,2),label,1,.false.)
|
||||
call save_mos
|
||||
SOFT_TOUCH mo_coef mo_label
|
||||
if (is_complex) then
|
||||
call mo_as_eigvectors_of_mo_matrix_complex(mo_one_e_integrals_complex, &
|
||||
size(mo_one_e_integrals_complex,1), &
|
||||
size(mo_one_e_integrals_complex,2),label,1,.false.)
|
||||
call save_mos
|
||||
SOFT_TOUCH mo_coef_complex mo_label
|
||||
|
||||
else
|
||||
call mo_as_eigvectors_of_mo_matrix(mo_one_e_integrals, &
|
||||
size(mo_one_e_integrals,1), &
|
||||
size(mo_one_e_integrals,2),label,1,.false.)
|
||||
call save_mos
|
||||
SOFT_TOUCH mo_coef mo_label
|
||||
endif
|
||||
end
|
||||
|
109
src/mo_guess/mo_ortho_lowdin_cplx.irp.f
Normal file
109
src/mo_guess/mo_ortho_lowdin_cplx.irp.f
Normal file
@ -0,0 +1,109 @@
|
||||
BEGIN_PROVIDER [complex*16, ao_ortho_lowdin_coef_complex, (ao_num,ao_num)]
|
||||
implicit none
|
||||
BEGIN_DOC
|
||||
! matrix of the coefficients of the mos generated by the
|
||||
! orthonormalization by the S^{-1/2} canonical transformation of the aos
|
||||
! ao_ortho_lowdin_coef(i,j) = coefficient of the ith ao on the jth ao_ortho_lowdin orbital
|
||||
END_DOC
|
||||
integer :: i,j,k,l
|
||||
complex*16, allocatable :: tmp_matrix(:,:)
|
||||
allocate (tmp_matrix(ao_num,ao_num))
|
||||
tmp_matrix(:,:) = (0.d0,0.d0)
|
||||
do j=1, ao_num
|
||||
tmp_matrix(j,j) = (1.d0,0.d0)
|
||||
enddo
|
||||
call ortho_lowdin_complex(ao_overlap_complex,ao_num,ao_num,tmp_matrix,ao_num,ao_num)
|
||||
do i=1, ao_num
|
||||
do j=1, ao_num
|
||||
ao_ortho_lowdin_coef_complex(j,i) = tmp_matrix(i,j)
|
||||
enddo
|
||||
enddo
|
||||
deallocate(tmp_matrix)
|
||||
END_PROVIDER
|
||||
|
||||
BEGIN_PROVIDER [complex*16, ao_ortho_lowdin_overlap_complex, (ao_num,ao_num)]
|
||||
implicit none
|
||||
BEGIN_DOC
|
||||
! overlap matrix of the ao_ortho_lowdin
|
||||
! supposed to be the Identity
|
||||
END_DOC
|
||||
integer :: i,j,k,l
|
||||
complex*16 :: c
|
||||
do j=1, ao_num
|
||||
do i=1, ao_num
|
||||
ao_ortho_lowdin_overlap_complex(i,j) = (0.d0,0.d0)
|
||||
enddo
|
||||
enddo
|
||||
do k=1, ao_num
|
||||
do j=1, ao_num
|
||||
c = (0.d0,0.d0)
|
||||
do l=1, ao_num
|
||||
c += dconjg(ao_ortho_lowdin_coef_complex(j,l)) * ao_overlap_complex(k,l)
|
||||
enddo
|
||||
do i=1, ao_num
|
||||
ao_ortho_lowdin_overlap_complex(i,j) += ao_ortho_lowdin_coef_complex(i,k) * c
|
||||
enddo
|
||||
enddo
|
||||
enddo
|
||||
END_PROVIDER
|
||||
|
||||
!============================================!
|
||||
! !
|
||||
! kpts !
|
||||
! !
|
||||
!============================================!
|
||||
|
||||
BEGIN_PROVIDER [complex*16, ao_ortho_lowdin_coef_kpts, (ao_num_per_kpt,ao_num_per_kpt,kpt_num)]
|
||||
implicit none
|
||||
BEGIN_DOC
|
||||
! matrix of the coefficients of the mos generated by the
|
||||
! orthonormalization by the S^{-1/2} canonical transformation of the aos
|
||||
! ao_ortho_lowdin_coef(i,j) = coefficient of the ith ao on the jth ao_ortho_lowdin orbital
|
||||
END_DOC
|
||||
integer :: i,j,k,l
|
||||
complex*16, allocatable :: tmp_matrix(:,:)
|
||||
allocate (tmp_matrix(ao_num,ao_num))
|
||||
do k=1,kpt_num
|
||||
tmp_matrix(:,:) = (0.d0,0.d0)
|
||||
do j=1, ao_num
|
||||
tmp_matrix(j,j) = (1.d0,0.d0)
|
||||
enddo
|
||||
call ortho_lowdin_complex(ao_overlap_kpts(:,:,k),ao_num_per_kpt,ao_num_per_kpt,tmp_matrix,ao_num_per_kpt,ao_num_per_kpt)
|
||||
do i=1, ao_num_per_kpt
|
||||
do j=1, ao_num_per_kpt
|
||||
ao_ortho_lowdin_coef_kpts(j,i,k) = tmp_matrix(i,j)
|
||||
enddo
|
||||
enddo
|
||||
enddo
|
||||
deallocate(tmp_matrix)
|
||||
END_PROVIDER
|
||||
|
||||
BEGIN_PROVIDER [complex*16, ao_ortho_lowdin_overlap_kpts, (ao_num_per_kpt,ao_num_per_kpt,kpt_num)]
|
||||
implicit none
|
||||
BEGIN_DOC
|
||||
! overlap matrix of the ao_ortho_lowdin
|
||||
! supposed to be the Identity
|
||||
END_DOC
|
||||
integer :: i,j,k,l,kk
|
||||
complex*16 :: c
|
||||
do kk=1,kpt_num
|
||||
do j=1, ao_num_per_kpt
|
||||
do i=1, ao_num_per_kpt
|
||||
ao_ortho_lowdin_overlap_kpts(i,j,kk) = (0.d0,0.d0)
|
||||
enddo
|
||||
enddo
|
||||
enddo
|
||||
do kk=1,kpt_num
|
||||
do k=1, ao_num_per_kpt
|
||||
do j=1, ao_num_per_kpt
|
||||
c = (0.d0,0.d0)
|
||||
do l=1, ao_num_per_kpt
|
||||
c += dconjg(ao_ortho_lowdin_coef_kpts(j,l,kk)) * ao_overlap_kpts(k,l,kk)
|
||||
enddo
|
||||
do i=1, ao_num_per_kpt
|
||||
ao_ortho_lowdin_overlap_kpts(i,j,kk) += ao_ortho_lowdin_coef_kpts(i,k,kk) * c
|
||||
enddo
|
||||
enddo
|
||||
enddo
|
||||
enddo
|
||||
END_PROVIDER
|
52
src/mo_guess/pot_mo_ortho_cano_ints.irp.f
Normal file
52
src/mo_guess/pot_mo_ortho_cano_ints.irp.f
Normal file
@ -0,0 +1,52 @@
|
||||
BEGIN_PROVIDER [double precision, ao_ortho_cano_n_e_ints, (mo_num,mo_num)]
|
||||
implicit none
|
||||
integer :: i1,j1,i,j
|
||||
double precision :: c_i1,c_j1
|
||||
|
||||
ao_ortho_cano_n_e_ints = 0.d0
|
||||
!$OMP PARALLEL DO DEFAULT(none) &
|
||||
!$OMP PRIVATE(i,j,i1,j1,c_j1,c_i1) &
|
||||
!$OMP SHARED(mo_num,ao_num,ao_ortho_canonical_coef, &
|
||||
!$OMP ao_ortho_cano_n_e_ints, ao_integrals_n_e)
|
||||
do i = 1, mo_num
|
||||
do j = 1, mo_num
|
||||
do i1 = 1,ao_num
|
||||
c_i1 = ao_ortho_canonical_coef(i1,i)
|
||||
do j1 = 1,ao_num
|
||||
c_j1 = c_i1*ao_ortho_canonical_coef(j1,j)
|
||||
ao_ortho_cano_n_e_ints(j,i) = ao_ortho_cano_n_e_ints(j,i) + &
|
||||
c_j1 * ao_integrals_n_e(j1,i1)
|
||||
enddo
|
||||
enddo
|
||||
enddo
|
||||
enddo
|
||||
!$OMP END PARALLEL DO
|
||||
END_PROVIDER
|
||||
|
||||
BEGIN_PROVIDER [complex*16, ao_ortho_cano_n_e_ints_cplx, (mo_num,mo_num)]
|
||||
!todo: kpts
|
||||
implicit none
|
||||
integer :: i1,j1,i,j
|
||||
complex*16 :: c_i1,c_j1
|
||||
|
||||
ao_ortho_cano_n_e_ints_cplx = (0.d0,0.d0)
|
||||
!$OMP PARALLEL DO DEFAULT(none) &
|
||||
!$OMP PRIVATE(i,j,i1,j1,c_j1,c_i1) &
|
||||
!$OMP SHARED(mo_num,ao_num,ao_ortho_canonical_coef_complex, &
|
||||
!$OMP ao_ortho_cano_n_e_ints_cplx, ao_integrals_n_e_complex)
|
||||
do i = 1, mo_num
|
||||
do j = 1, mo_num
|
||||
do i1 = 1,ao_num
|
||||
c_i1 = ao_ortho_canonical_coef_complex(i1,i)
|
||||
do j1 = 1,ao_num
|
||||
c_j1 = c_i1*dconjg(ao_ortho_canonical_coef_complex(j1,j))
|
||||
ao_ortho_cano_n_e_ints_cplx(j,i) = &
|
||||
ao_ortho_cano_n_e_ints_cplx(j,i) + &
|
||||
c_j1 * ao_integrals_n_e_complex(j1,i1)
|
||||
enddo
|
||||
enddo
|
||||
enddo
|
||||
enddo
|
||||
!$OMP END PARALLEL DO
|
||||
END_PROVIDER
|
||||
|
@ -1,25 +0,0 @@
|
||||
BEGIN_PROVIDER [double precision, ao_ortho_canonical_nucl_elec_integrals, (mo_num,mo_num)]
|
||||
implicit none
|
||||
integer :: i1,j1,i,j
|
||||
double precision :: c_i1,c_j1
|
||||
|
||||
ao_ortho_canonical_nucl_elec_integrals = 0.d0
|
||||
!$OMP PARALLEL DO DEFAULT(none) &
|
||||
!$OMP PRIVATE(i,j,i1,j1,c_j1,c_i1) &
|
||||
!$OMP SHARED(mo_num,ao_num,ao_ortho_canonical_coef, &
|
||||
!$OMP ao_ortho_canonical_nucl_elec_integrals, ao_integrals_n_e)
|
||||
do i = 1, mo_num
|
||||
do j = 1, mo_num
|
||||
do i1 = 1,ao_num
|
||||
c_i1 = ao_ortho_canonical_coef(i1,i)
|
||||
do j1 = 1,ao_num
|
||||
c_j1 = c_i1*ao_ortho_canonical_coef(j1,j)
|
||||
ao_ortho_canonical_nucl_elec_integrals(j,i) = ao_ortho_canonical_nucl_elec_integrals(j,i) + &
|
||||
c_j1 * ao_integrals_n_e(j1,i1)
|
||||
enddo
|
||||
enddo
|
||||
enddo
|
||||
enddo
|
||||
!$OMP END PARALLEL DO
|
||||
END_PROVIDER
|
||||
|
@ -23,3 +23,29 @@ BEGIN_PROVIDER [double precision, ao_ortho_lowdin_nucl_elec_integrals, (mo_num,m
|
||||
!$OMP END PARALLEL DO
|
||||
END_PROVIDER
|
||||
|
||||
BEGIN_PROVIDER [complex*16, ao_ortho_lowdin_n_e_ints_cplx, (mo_num,mo_num)]
|
||||
implicit none
|
||||
integer :: i1,j1,i,j
|
||||
complex*16 :: c_i1,c_j1
|
||||
|
||||
ao_ortho_lowdin_nucl_elec_integrals = (0.d0,0.d0)
|
||||
!$OMP PARALLEL DO DEFAULT(none) &
|
||||
!$OMP PRIVATE(i,j,i1,j1,c_j1,c_i1) &
|
||||
!$OMP SHARED(mo_num,ao_num,ao_ortho_lowdin_coef_complex, &
|
||||
!$OMP ao_ortho_lowdin_n_e_ints_cplx, ao_integrals_n_e_complex)
|
||||
do i = 1, mo_num
|
||||
do j = 1, mo_num
|
||||
do i1 = 1,ao_num
|
||||
c_i1 = ao_ortho_lowdin_coef_complex(i1,i)
|
||||
do j1 = 1,ao_num
|
||||
c_j1 = c_i1*dconjg(ao_ortho_lowdin_coef_complex(j1,j))
|
||||
ao_ortho_lowdin_n_e_ints_cplx(j,i) = &
|
||||
ao_ortho_lowdin_n_e_ints_cplx(j,i) + &
|
||||
c_j1 * ao_integrals_n_e_complex(j1,i1)
|
||||
enddo
|
||||
enddo
|
||||
enddo
|
||||
enddo
|
||||
!$OMP END PARALLEL DO
|
||||
END_PROVIDER
|
||||
|
||||
|
@ -4,6 +4,18 @@ doc: Nucleus-electron integrals in |MO| basis set
|
||||
size: (mo_basis.mo_num,mo_basis.mo_num)
|
||||
interface: ezfio
|
||||
|
||||
[mo_integrals_e_n_complex]
|
||||
type: double precision
|
||||
doc: Complex nucleus-electron integrals in |MO| basis set
|
||||
size: (2,mo_basis.mo_num,mo_basis.mo_num)
|
||||
interface: ezfio
|
||||
|
||||
[mo_integrals_e_n_kpts]
|
||||
type: double precision
|
||||
doc: Complex nucleus-electron integrals in |MO| basis set
|
||||
size: (2,mo_basis.mo_num_per_kpt,mo_basis.mo_num_per_kpt,nuclei.kpt_num)
|
||||
interface: ezfio
|
||||
|
||||
[io_mo_integrals_e_n]
|
||||
type: Disk_access
|
||||
doc: Read/Write |MO| electron-nucleus attraction integrals from/to disk [ Write | Read | None ]
|
||||
@ -17,12 +29,35 @@ doc: Kinetic energy integrals in |MO| basis set
|
||||
size: (mo_basis.mo_num,mo_basis.mo_num)
|
||||
interface: ezfio
|
||||
|
||||
[mo_integrals_kinetic_complex]
|
||||
type: double precision
|
||||
doc: Complex kinetic energy integrals in |MO| basis set
|
||||
size: (2,mo_basis.mo_num,mo_basis.mo_num)
|
||||
interface: ezfio
|
||||
|
||||
[mo_integrals_kinetic_kpts]
|
||||
type: double precision
|
||||
doc: Complex kinetic energy integrals in |MO| basis set
|
||||
size: (2,mo_basis.mo_num_per_kpt,mo_basis.mo_num_per_kpt,nuclei.kpt_num)
|
||||
interface: ezfio
|
||||
|
||||
[io_mo_integrals_kinetic]
|
||||
type: Disk_access
|
||||
doc: Read/Write |MO| one-electron kinetic integrals from/to disk [ Write | Read | None ]
|
||||
interface: ezfio,provider,ocaml
|
||||
default: None
|
||||
|
||||
[mo_integrals_overlap_kpts]
|
||||
type: double precision
|
||||
doc: Complex overlap integrals in |MO| basis set
|
||||
size: (2,mo_basis.mo_num_per_kpt,mo_basis.mo_num_per_kpt,nuclei.kpt_num)
|
||||
interface: ezfio
|
||||
|
||||
[io_mo_integrals_overlap]
|
||||
type: Disk_access
|
||||
doc: Read/Write |MO| one-electron overlap integrals from/to disk [ Write | Read | None ]
|
||||
interface: ezfio,provider,ocaml
|
||||
default: None
|
||||
|
||||
|
||||
[mo_integrals_pseudo]
|
||||
@ -31,18 +66,43 @@ doc: Pseudopotential integrals in |MO| basis set
|
||||
size: (mo_basis.mo_num,mo_basis.mo_num)
|
||||
interface: ezfio
|
||||
|
||||
[mo_integrals_pseudo_complex]
|
||||
type: double precision
|
||||
doc: Complex pseudopotential integrals in |MO| basis set
|
||||
size: (2,mo_basis.mo_num,mo_basis.mo_num)
|
||||
interface: ezfio
|
||||
|
||||
[mo_integrals_pseudo_kpts]
|
||||
type: double precision
|
||||
doc: Complex pseudopotential integrals in |MO| basis set
|
||||
size: (2,mo_basis.mo_num_per_kpt,mo_basis.mo_num_per_kpt,nuclei.kpt_num)
|
||||
interface: ezfio
|
||||
|
||||
[io_mo_integrals_pseudo]
|
||||
type: Disk_access
|
||||
doc: Read/Write |MO| pseudopotential integrals from/to disk [ Write | Read | None ]
|
||||
interface: ezfio,provider,ocaml
|
||||
default: None
|
||||
|
||||
|
||||
[mo_one_e_integrals]
|
||||
type: double precision
|
||||
doc: One-electron integrals in |MO| basis set
|
||||
size: (mo_basis.mo_num,mo_basis.mo_num)
|
||||
interface: ezfio
|
||||
|
||||
[mo_one_e_integrals_complex]
|
||||
type: double precision
|
||||
doc: Complex one-electron integrals in |MO| basis set
|
||||
size: (2,mo_basis.mo_num,mo_basis.mo_num)
|
||||
interface: ezfio
|
||||
|
||||
[mo_one_e_integrals_kpts]
|
||||
type: double precision
|
||||
doc: Complex one-electron integrals in |MO| basis set
|
||||
size: (2,mo_basis.mo_num_per_kpt,mo_basis.mo_num_per_kpt,nuclei.kpt_num)
|
||||
interface: ezfio
|
||||
|
||||
[io_mo_one_e_integrals]
|
||||
type: Disk_access
|
||||
doc: Read/Write |MO| one-electron integrals from/to disk [ Write | Read | None ]
|
||||
|
@ -63,4 +63,3 @@ BEGIN_PROVIDER [ double precision, S_mo_coef, (ao_num, mo_num) ]
|
||||
|
||||
END_PROVIDER
|
||||
|
||||
|
||||
|
146
src/mo_one_e_ints/ao_to_mo_cplx.irp.f
Normal file
146
src/mo_one_e_ints/ao_to_mo_cplx.irp.f
Normal file
@ -0,0 +1,146 @@
|
||||
subroutine mo_to_ao_complex(A_mo,LDA_mo,A_ao,LDA_ao)
|
||||
implicit none
|
||||
BEGIN_DOC
|
||||
! Transform A from the MO basis to the AO basis
|
||||
!
|
||||
! (S.C).A_mo.(S.C)t
|
||||
END_DOC
|
||||
integer, intent(in) :: LDA_ao,LDA_mo
|
||||
complex*16, intent(in) :: A_mo(LDA_mo,mo_num)
|
||||
complex*16, intent(out) :: A_ao(LDA_ao,ao_num)
|
||||
complex*16, allocatable :: T(:,:)
|
||||
|
||||
allocate ( T(mo_num,ao_num) )
|
||||
|
||||
call zgemm('N','C', mo_num, ao_num, mo_num, &
|
||||
(1.d0,0.d0), A_mo,size(A_mo,1), &
|
||||
S_mo_coef_complex, size(S_mo_coef_complex,1), &
|
||||
(0.d0,0.d0), T, size(T,1))
|
||||
|
||||
call zgemm('N','N', ao_num, ao_num, mo_num, &
|
||||
(1.d0,0.d0), S_mo_coef_complex, size(S_mo_coef_complex,1), &
|
||||
T, size(T,1), &
|
||||
(0.d0,0.d0), A_ao, size(A_ao,1))
|
||||
|
||||
deallocate(T)
|
||||
end
|
||||
|
||||
subroutine mo_to_ao_no_overlap_complex(A_mo,LDA_mo,A_ao,LDA_ao)
|
||||
implicit none
|
||||
BEGIN_DOC
|
||||
! Transform A from the MO basis to the S^-1 AO basis
|
||||
! Useful for density matrix
|
||||
END_DOC
|
||||
integer, intent(in) :: LDA_ao,LDA_mo
|
||||
complex*16, intent(in) :: A_mo(LDA_mo,mo_num)
|
||||
complex*16, intent(out) :: A_ao(LDA_ao,ao_num)
|
||||
complex*16, allocatable :: T(:,:)
|
||||
|
||||
allocate ( T(mo_num,ao_num) )
|
||||
!DIR$ ATTRIBUTES ALIGN : $IRP_ALIGN :: T
|
||||
|
||||
call zgemm('N','C', mo_num, ao_num, mo_num, &
|
||||
(1.d0,0.d0), A_mo,size(A_mo,1), &
|
||||
mo_coef_complex, size(mo_coef_complex,1), &
|
||||
(0.d0,0.d0), T, size(T,1))
|
||||
|
||||
call zgemm('N','N', ao_num, ao_num, mo_num, &
|
||||
(1.d0,0.d0), mo_coef_complex,size(mo_coef_complex,1), &
|
||||
T, size(T,1), &
|
||||
(0.d0,0.d0), A_ao, size(A_ao,1))
|
||||
|
||||
deallocate(T)
|
||||
end
|
||||
|
||||
BEGIN_PROVIDER [ complex*16, S_mo_coef_complex, (ao_num, mo_num) ]
|
||||
implicit none
|
||||
BEGIN_DOC
|
||||
! Product S.C where S is the overlap matrix in the AO basis and C the mo_coef matrix.
|
||||
END_DOC
|
||||
|
||||
call zgemm('N','N',ao_num, mo_num, ao_num, (1.d0,0.d0), &
|
||||
ao_overlap_complex, size(ao_overlap_complex,1), &
|
||||
mo_coef_complex, size(mo_coef_complex,1), &
|
||||
(0.d0,0.d0), &
|
||||
S_mo_coef_complex, size(S_mo_coef_complex,1))
|
||||
|
||||
END_PROVIDER
|
||||
|
||||
!============================================!
|
||||
! !
|
||||
! kpts !
|
||||
! !
|
||||
!============================================!
|
||||
|
||||
subroutine mo_to_ao_kpts(A_mo,LDA_mo,A_ao,LDA_ao)
|
||||
implicit none
|
||||
BEGIN_DOC
|
||||
! Transform A from the MO basis to the AO basis
|
||||
!
|
||||
! (S.C).A_mo.(S.C)t
|
||||
END_DOC
|
||||
integer, intent(in) :: LDA_ao,LDA_mo
|
||||
complex*16, intent(in) :: A_mo(LDA_mo,mo_num_per_kpt,kpt_num)
|
||||
complex*16, intent(out) :: A_ao(LDA_ao,ao_num_per_kpt,kpt_num)
|
||||
complex*16, allocatable :: T(:,:)
|
||||
|
||||
allocate ( T(mo_num_per_kpt,ao_num_per_kpt) )
|
||||
integer :: k
|
||||
do k=1,kpt_num
|
||||
call zgemm('N','C', mo_num_per_kpt, ao_num_per_kpt, mo_num_per_kpt, &
|
||||
(1.d0,0.d0), A_mo(:,:,k),size(A_mo,1), &
|
||||
S_mo_coef_kpts(:,:,k), size(S_mo_coef_kpts,1), &
|
||||
(0.d0,0.d0), T, size(T,1))
|
||||
|
||||
call zgemm('N','N', ao_num_per_kpt, ao_num_per_kpt, mo_num_per_kpt, &
|
||||
(1.d0,0.d0), S_mo_coef_kpts(:,:,k), size(S_mo_coef_kpts,1), &
|
||||
T, size(T,1), &
|
||||
(0.d0,0.d0), A_ao(:,:,k), size(A_ao,1))
|
||||
enddo
|
||||
deallocate(T)
|
||||
end
|
||||
|
||||
subroutine mo_to_ao_no_overlap_kpts(A_mo,LDA_mo,A_ao,LDA_ao)
|
||||
implicit none
|
||||
BEGIN_DOC
|
||||
! Transform A from the MO basis to the S^-1 AO basis
|
||||
! Useful for density matrix
|
||||
END_DOC
|
||||
integer, intent(in) :: LDA_ao,LDA_mo
|
||||
complex*16, intent(in) :: A_mo(LDA_mo,mo_num_per_kpt,kpt_num)
|
||||
complex*16, intent(out) :: A_ao(LDA_ao,ao_num_per_kpt,kpt_num)
|
||||
complex*16, allocatable :: T(:,:)
|
||||
|
||||
allocate ( T(mo_num_per_kpt,ao_num_per_kpt) )
|
||||
!DIR$ ATTRIBUTES ALIGN : $IRP_ALIGN :: T
|
||||
integer :: k
|
||||
do k=1,kpt_num
|
||||
call zgemm('N','C', mo_num_per_kpt, ao_num_per_kpt, mo_num_per_kpt, &
|
||||
(1.d0,0.d0), A_mo(:,:,k),size(A_mo,1), &
|
||||
mo_coef_kpts(:,:,k), size(mo_coef_kpts,1), &
|
||||
(0.d0,0.d0), T, size(T,1))
|
||||
|
||||
call zgemm('N','N', ao_num_per_kpt, ao_num_per_kpt, mo_num_per_kpt, &
|
||||
(1.d0,0.d0), mo_coef_kpts(:,:,k),size(mo_coef_kpts,1), &
|
||||
T, size(T,1), &
|
||||
(0.d0,0.d0), A_ao(:,:,k), size(A_ao,1))
|
||||
enddo
|
||||
deallocate(T)
|
||||
end
|
||||
|
||||
BEGIN_PROVIDER [ complex*16, S_mo_coef_kpts, (ao_num_per_kpt, mo_num_per_kpt, kpt_num) ]
|
||||
implicit none
|
||||
BEGIN_DOC
|
||||
! Product S.C where S is the overlap matrix in the AO basis and C the mo_coef matrix.
|
||||
END_DOC
|
||||
|
||||
integer :: k
|
||||
do k=1,kpt_num
|
||||
call zgemm('N','N',ao_num_per_kpt, mo_num_per_kpt, ao_num_per_kpt, (1.d0,0.d0), &
|
||||
ao_overlap_kpts(:,:,k), size(ao_overlap_kpts,1), &
|
||||
mo_coef_kpts(:,:,k), size(mo_coef_kpts,1), &
|
||||
(0.d0,0.d0), &
|
||||
S_mo_coef_kpts(:,:,k), size(S_mo_coef_kpts,1))
|
||||
enddo
|
||||
END_PROVIDER
|
||||
|
@ -22,3 +22,26 @@ BEGIN_PROVIDER [double precision, mo_kinetic_integrals, (mo_num,mo_num)]
|
||||
|
||||
END_PROVIDER
|
||||
|
||||
BEGIN_PROVIDER [ double precision, mo_kinetic_integrals_diag,(mo_num)]
|
||||
implicit none
|
||||
integer :: i
|
||||
BEGIN_DOC
|
||||
! diagonal elements of mo_kinetic_integrals or mo_kinetic_integrals_complex
|
||||
END_DOC
|
||||
|
||||
if (is_complex) then
|
||||
integer :: k,i_shft
|
||||
PROVIDE mo_kinetic_integrals_kpts
|
||||
do k=1,kpt_num
|
||||
i_shft = (k-1)*mo_num_per_kpt
|
||||
do i=1,mo_num_per_kpt
|
||||
mo_kinetic_integrals_diag(i+i_shft) = dble(mo_kinetic_integrals_kpts(i,i,k))
|
||||
enddo
|
||||
enddo
|
||||
else
|
||||
PROVIDE mo_kinetic_integrals
|
||||
do i=1,mo_num
|
||||
mo_kinetic_integrals_diag(i) = mo_kinetic_integrals(i,i)
|
||||
enddo
|
||||
endif
|
||||
END_PROVIDER
|
||||
|
60
src/mo_one_e_ints/kin_mo_ints_cplx.irp.f
Normal file
60
src/mo_one_e_ints/kin_mo_ints_cplx.irp.f
Normal file
@ -0,0 +1,60 @@
|
||||
BEGIN_PROVIDER [complex*16, mo_kinetic_integrals_complex, (mo_num,mo_num)]
|
||||
implicit none
|
||||
BEGIN_DOC
|
||||
! Kinetic energy integrals in the MO basis
|
||||
END_DOC
|
||||
integer :: i,j
|
||||
|
||||
print *, 'Providing MO kinetic integrals'
|
||||
if (read_mo_integrals_kinetic) then
|
||||
call ezfio_get_mo_one_e_ints_mo_integrals_kinetic_complex(mo_kinetic_integrals_complex)
|
||||
print *, 'MO kinetic integrals read from disk'
|
||||
else
|
||||
print *, 'Providing MO kinetic integrals from AO kinetic integrals'
|
||||
call ao_to_mo_complex( &
|
||||
ao_kinetic_integrals_complex, &
|
||||
size(ao_kinetic_integrals_complex,1), &
|
||||
mo_kinetic_integrals_complex, &
|
||||
size(mo_kinetic_integrals_complex,1) &
|
||||
)
|
||||
endif
|
||||
if (write_mo_integrals_kinetic) then
|
||||
call ezfio_set_mo_one_e_ints_mo_integrals_kinetic_complex(mo_kinetic_integrals_complex)
|
||||
print *, 'MO kinetic integrals written to disk'
|
||||
endif
|
||||
|
||||
END_PROVIDER
|
||||
|
||||
!============================================!
|
||||
! !
|
||||
! kpts !
|
||||
! !
|
||||
!============================================!
|
||||
|
||||
BEGIN_PROVIDER [complex*16, mo_kinetic_integrals_kpts, (mo_num_per_kpt,mo_num_per_kpt,kpt_num)]
|
||||
implicit none
|
||||
BEGIN_DOC
|
||||
! Kinetic energy integrals in the MO basis
|
||||
END_DOC
|
||||
integer :: i,j
|
||||
|
||||
print *, 'Providing MO kinetic integrals'
|
||||
if (read_mo_integrals_kinetic) then
|
||||
call ezfio_get_mo_one_e_ints_mo_integrals_kinetic_kpts(mo_kinetic_integrals_kpts)
|
||||
print *, 'MO kinetic integrals read from disk'
|
||||
else
|
||||
print *, 'Providing MO kinetic integrals from AO kinetic integrals'
|
||||
call ao_to_mo_kpts( &
|
||||
ao_kinetic_integrals_kpts, &
|
||||
size(ao_kinetic_integrals_kpts,1), &
|
||||
mo_kinetic_integrals_kpts, &
|
||||
size(mo_kinetic_integrals_kpts,1) &
|
||||
)
|
||||
endif
|
||||
if (write_mo_integrals_kinetic) then
|
||||
call ezfio_set_mo_one_e_ints_mo_integrals_kinetic_kpts(mo_kinetic_integrals_kpts)
|
||||
print *, 'MO kinetic integrals written to disk'
|
||||
endif
|
||||
|
||||
END_PROVIDER
|
||||
|
@ -24,3 +24,27 @@ BEGIN_PROVIDER [ double precision, mo_one_e_integrals,(mo_num,mo_num)]
|
||||
ENDIF
|
||||
|
||||
END_PROVIDER
|
||||
|
||||
BEGIN_PROVIDER [ double precision, mo_one_e_integrals_diag,(mo_num)]
|
||||
implicit none
|
||||
integer :: i
|
||||
BEGIN_DOC
|
||||
! diagonal elements of mo_one_e_integrals or mo_one_e_integrals_complex
|
||||
END_DOC
|
||||
|
||||
if (is_complex) then
|
||||
integer :: k,i_shft
|
||||
PROVIDE mo_one_e_integrals_kpts
|
||||
do k=1,kpt_num
|
||||
i_shft = (k-1)*mo_num_per_kpt
|
||||
do i=1,mo_num_per_kpt
|
||||
mo_one_e_integrals_diag(i+i_shft) = dble(mo_one_e_integrals_kpts(i,i,k))
|
||||
enddo
|
||||
enddo
|
||||
else
|
||||
PROVIDE mo_one_e_integrals
|
||||
do i=1,mo_num
|
||||
mo_one_e_integrals_diag(i) = mo_one_e_integrals(i,i)
|
||||
enddo
|
||||
endif
|
||||
END_PROVIDER
|
||||
|
61
src/mo_one_e_ints/mo_one_e_ints_cplx.irp.f
Normal file
61
src/mo_one_e_ints/mo_one_e_ints_cplx.irp.f
Normal file
@ -0,0 +1,61 @@
|
||||
BEGIN_PROVIDER [ complex*16, mo_one_e_integrals_complex,(mo_num,mo_num)]
|
||||
implicit none
|
||||
integer :: i,j,n,l
|
||||
BEGIN_DOC
|
||||
! array of the one-electron Hamiltonian on the |MO| basis :
|
||||
! sum of the kinetic and nuclear electronic potentials (and pseudo potential if needed)
|
||||
END_DOC
|
||||
print*,'Providing the one-electron integrals'
|
||||
|
||||
IF (read_mo_one_e_integrals) THEN
|
||||
call ezfio_get_mo_one_e_ints_mo_one_e_integrals_complex(mo_one_e_integrals_complex)
|
||||
ELSE
|
||||
mo_one_e_integrals_complex = mo_integrals_n_e_complex + mo_kinetic_integrals_complex
|
||||
|
||||
IF (do_pseudo) THEN
|
||||
mo_one_e_integrals_complex += mo_pseudo_integrals_complex
|
||||
ENDIF
|
||||
|
||||
ENDIF
|
||||
|
||||
IF (write_mo_one_e_integrals) THEN
|
||||
call ezfio_set_mo_one_e_ints_mo_one_e_integrals_complex(mo_one_e_integrals_complex)
|
||||
print *, 'MO one-e integrals written to disk'
|
||||
ENDIF
|
||||
print*,'Provided the one-electron integrals'
|
||||
|
||||
END_PROVIDER
|
||||
|
||||
!============================================!
|
||||
! !
|
||||
! kpts !
|
||||
! !
|
||||
!============================================!
|
||||
|
||||
BEGIN_PROVIDER [ complex*16, mo_one_e_integrals_kpts,(mo_num_per_kpt,mo_num_per_kpt,kpt_num)]
|
||||
implicit none
|
||||
integer :: i,j,n,l
|
||||
BEGIN_DOC
|
||||
! array of the one-electron Hamiltonian on the |MO| basis :
|
||||
! sum of the kinetic and nuclear electronic potentials (and pseudo potential if needed)
|
||||
END_DOC
|
||||
print*,'Providing the one-electron integrals'
|
||||
|
||||
IF (read_mo_one_e_integrals) THEN
|
||||
call ezfio_get_mo_one_e_ints_mo_one_e_integrals_kpts(mo_one_e_integrals_kpts)
|
||||
ELSE
|
||||
mo_one_e_integrals_kpts = mo_integrals_n_e_kpts + mo_kinetic_integrals_kpts
|
||||
|
||||
IF (do_pseudo) THEN
|
||||
mo_one_e_integrals_kpts += mo_pseudo_integrals_kpts
|
||||
ENDIF
|
||||
|
||||
ENDIF
|
||||
|
||||
IF (write_mo_one_e_integrals) THEN
|
||||
call ezfio_set_mo_one_e_ints_mo_one_e_integrals_kpts(mo_one_e_integrals_kpts)
|
||||
print *, 'MO one-e integrals written to disk'
|
||||
ENDIF
|
||||
print*,'Provided the one-electron integrals'
|
||||
|
||||
END_PROVIDER
|
@ -37,3 +37,94 @@ BEGIN_PROVIDER [ double precision, mo_overlap,(mo_num,mo_num) ]
|
||||
|
||||
END_PROVIDER
|
||||
|
||||
BEGIN_PROVIDER [ complex*16, mo_overlap_complex,(mo_num,mo_num) ]
|
||||
implicit none
|
||||
BEGIN_DOC
|
||||
! Provider to check that the MOs are indeed orthonormal.
|
||||
END_DOC
|
||||
integer :: i,j,n,l
|
||||
integer :: lmax
|
||||
|
||||
|
||||
lmax = (ao_num/4) * 4
|
||||
!$OMP PARALLEL DO SCHEDULE(STATIC) DEFAULT(NONE) &
|
||||
!$OMP PRIVATE(i,j,n,l) &
|
||||
!$OMP SHARED(mo_overlap_complex,mo_coef_complex,ao_overlap_complex, &
|
||||
!$OMP mo_num,ao_num,lmax)
|
||||
do j=1,mo_num
|
||||
do i= 1,mo_num
|
||||
mo_overlap_complex(i,j) = (0.d0,0.d0)
|
||||
do n = 1, lmax,4
|
||||
do l = 1, ao_num
|
||||
mo_overlap_complex(i,j) = mo_overlap_complex(i,j) + dconjg(mo_coef_complex(l,i)) * &
|
||||
( mo_coef_complex(n ,j) * ao_overlap_complex(l,n ) &
|
||||
+ mo_coef_complex(n+1,j) * ao_overlap_complex(l,n+1) &
|
||||
+ mo_coef_complex(n+2,j) * ao_overlap_complex(l,n+2) &
|
||||
+ mo_coef_complex(n+3,j) * ao_overlap_complex(l,n+3) )
|
||||
enddo
|
||||
enddo
|
||||
do n = lmax+1, ao_num
|
||||
do l = 1, ao_num
|
||||
mo_overlap_complex(i,j) = mo_overlap_complex(i,j) + mo_coef_complex(n,j) * dconjg(mo_coef_complex(l,i)) * ao_overlap_complex(l,n)
|
||||
enddo
|
||||
enddo
|
||||
enddo
|
||||
enddo
|
||||
!$OMP END PARALLEL DO
|
||||
|
||||
END_PROVIDER
|
||||
|
||||
BEGIN_PROVIDER [ complex*16, mo_overlap_kpts,(mo_num_per_kpt,mo_num_per_kpt,kpt_num) ]
|
||||
implicit none
|
||||
BEGIN_DOC
|
||||
! Provider to check that the MOs are indeed orthonormal.
|
||||
END_DOC
|
||||
integer :: i,j,n,l,k
|
||||
integer :: lmax
|
||||
|
||||
print *, 'Providing MO overlap integrals'
|
||||
if (read_mo_integrals_overlap) then
|
||||
call ezfio_get_mo_one_e_ints_mo_integrals_overlap_kpts(mo_overlap_kpts)
|
||||
print *, 'MO overlap integrals read from disk'
|
||||
else
|
||||
print *, 'Providing MO overlap integrals from AO overlap integrals'
|
||||
! call ao_to_mo_kpts( &
|
||||
! ao_kinetic_integrals_kpts, &
|
||||
! size(ao_kinetic_integrals_kpts,1), &
|
||||
! mo_kinetic_integrals_kpts, &
|
||||
! size(mo_kinetic_integrals_kpts,1) &
|
||||
! )
|
||||
!endif
|
||||
|
||||
|
||||
lmax = (ao_num_per_kpt/4) * 4
|
||||
!$OMP PARALLEL DO SCHEDULE(STATIC) DEFAULT(NONE) &
|
||||
!$OMP PRIVATE(i,j,n,l,k) &
|
||||
!$OMP SHARED(mo_overlap_kpts,mo_coef_kpts,ao_overlap_kpts, &
|
||||
!$OMP mo_num_per_kpt,ao_num_per_kpt,lmax,kpt_num)
|
||||
do k=1,kpt_num
|
||||
do j=1,mo_num_per_kpt
|
||||
do i= 1,mo_num_per_kpt
|
||||
mo_overlap_kpts(i,j,k) = (0.d0,0.d0)
|
||||
do n = 1, lmax,4
|
||||
do l = 1, ao_num_per_kpt
|
||||
mo_overlap_kpts(i,j,k) = mo_overlap_kpts(i,j,k) + dconjg(mo_coef_kpts(l,i,k)) * &
|
||||
( mo_coef_kpts(n ,j,k) * ao_overlap_kpts(l,n ,k) &
|
||||
+ mo_coef_kpts(n+1,j,k) * ao_overlap_kpts(l,n+1,k) &
|
||||
+ mo_coef_kpts(n+2,j,k) * ao_overlap_kpts(l,n+2,k) &
|
||||
+ mo_coef_kpts(n+3,j,k) * ao_overlap_kpts(l,n+3,k) )
|
||||
enddo
|
||||
enddo
|
||||
do n = lmax+1, ao_num_per_kpt
|
||||
do l = 1, ao_num_per_kpt
|
||||
mo_overlap_kpts(i,j,k) = mo_overlap_kpts(i,j,k) + mo_coef_kpts(n,j,k) * &
|
||||
dconjg(mo_coef_kpts(l,i,k)) * ao_overlap_kpts(l,n,k)
|
||||
enddo
|
||||
enddo
|
||||
enddo
|
||||
enddo
|
||||
enddo
|
||||
!$OMP END PARALLEL DO
|
||||
endif
|
||||
END_PROVIDER
|
||||
|
||||
|
@ -1,11 +1,21 @@
|
||||
subroutine orthonormalize_mos
|
||||
implicit none
|
||||
integer :: m,p,s
|
||||
m = size(mo_coef,1)
|
||||
p = size(mo_overlap,1)
|
||||
call ortho_lowdin(mo_overlap,p,mo_num,mo_coef,m,ao_num)
|
||||
mo_label = 'Orthonormalized'
|
||||
SOFT_TOUCH mo_coef mo_label
|
||||
integer :: m,p,s,k
|
||||
if (is_complex) then
|
||||
do k=1,kpt_num
|
||||
m = size(mo_coef_kpts,1)
|
||||
p = size(mo_overlap_kpts,1)
|
||||
call ortho_lowdin_complex(mo_overlap_kpts(1,1,k),p,mo_num_per_kpt,mo_coef_kpts(1,1,k),m,ao_num_per_kpt)
|
||||
enddo
|
||||
mo_label = 'Orthonormalized'
|
||||
SOFT_TOUCH mo_coef_kpts mo_label
|
||||
else
|
||||
m = size(mo_coef,1)
|
||||
p = size(mo_overlap,1)
|
||||
call ortho_lowdin(mo_overlap,p,mo_num,mo_coef,m,ao_num)
|
||||
mo_label = 'Orthonormalized'
|
||||
SOFT_TOUCH mo_coef mo_label
|
||||
endif
|
||||
end
|
||||
|
||||
|
||||
|
@ -44,3 +44,26 @@ BEGIN_PROVIDER [double precision, mo_integrals_n_e_per_atom, (mo_num,mo_num,nucl
|
||||
|
||||
END_PROVIDER
|
||||
|
||||
BEGIN_PROVIDER [ double precision, mo_integrals_n_e_diag,(mo_num)]
|
||||
implicit none
|
||||
integer :: i
|
||||
BEGIN_DOC
|
||||
! diagonal elements of mo_integrals_n_e or mo_integrals_n_e_complex
|
||||
END_DOC
|
||||
|
||||
if (is_complex) then
|
||||
integer :: k,i_shft
|
||||
PROVIDE mo_integrals_n_e_kpts
|
||||
do k=1,kpt_num
|
||||
i_shft = (k-1)*mo_num_per_kpt
|
||||
do i=1,mo_num_per_kpt
|
||||
mo_integrals_n_e_diag(i+i_shft) = dble(mo_integrals_n_e_kpts(i,i,k))
|
||||
enddo
|
||||
enddo
|
||||
else
|
||||
PROVIDE mo_integrals_n_e
|
||||
do i=1,mo_num
|
||||
mo_integrals_n_e_diag(i) = mo_integrals_n_e(i,i)
|
||||
enddo
|
||||
endif
|
||||
END_PROVIDER
|
||||
|
59
src/mo_one_e_ints/pot_mo_ints_cplx.irp.f
Normal file
59
src/mo_one_e_ints/pot_mo_ints_cplx.irp.f
Normal file
@ -0,0 +1,59 @@
|
||||
BEGIN_PROVIDER [complex*16, mo_integrals_n_e_complex, (mo_num,mo_num)]
|
||||
implicit none
|
||||
BEGIN_DOC
|
||||
! Kinetic energy integrals in the MO basis
|
||||
END_DOC
|
||||
integer :: i,j
|
||||
|
||||
print *, 'Providing MO N-e integrals'
|
||||
if (read_mo_integrals_e_n) then
|
||||
call ezfio_get_mo_one_e_ints_mo_integrals_e_n_complex(mo_integrals_n_e_complex)
|
||||
print *, 'MO N-e integrals read from disk'
|
||||
else
|
||||
print *, 'Providing MO N-e integrals from AO N-e integrals'
|
||||
call ao_to_mo_complex( &
|
||||
ao_integrals_n_e_complex, &
|
||||
size(ao_integrals_n_e_complex,1), &
|
||||
mo_integrals_n_e_complex, &
|
||||
size(mo_integrals_n_e_complex,1) &
|
||||
)
|
||||
endif
|
||||
if (write_mo_integrals_e_n) then
|
||||
call ezfio_set_mo_one_e_ints_mo_integrals_e_n_complex(mo_integrals_n_e_complex)
|
||||
print *, 'MO N-e integrals written to disk'
|
||||
endif
|
||||
|
||||
END_PROVIDER
|
||||
|
||||
!============================================!
|
||||
! !
|
||||
! kpts !
|
||||
! !
|
||||
!============================================!
|
||||
|
||||
BEGIN_PROVIDER [complex*16, mo_integrals_n_e_kpts, (mo_num_per_kpt,mo_num_per_kpt,kpt_num)]
|
||||
implicit none
|
||||
BEGIN_DOC
|
||||
! Kinetic energy integrals in the MO basis
|
||||
END_DOC
|
||||
integer :: i,j
|
||||
|
||||
print *, 'Providing MO N-e integrals'
|
||||
if (read_mo_integrals_e_n) then
|
||||
call ezfio_get_mo_one_e_ints_mo_integrals_e_n_kpts(mo_integrals_n_e_kpts)
|
||||
print *, 'MO N-e integrals read from disk'
|
||||
else
|
||||
print *, 'Providing MO N-e integrals from AO N-e integrals'
|
||||
call ao_to_mo_kpts( &
|
||||
ao_integrals_n_e_kpts, &
|
||||
size(ao_integrals_n_e_kpts,1), &
|
||||
mo_integrals_n_e_kpts, &
|
||||
size(mo_integrals_n_e_kpts,1) &
|
||||
)
|
||||
endif
|
||||
if (write_mo_integrals_e_n) then
|
||||
call ezfio_set_mo_one_e_ints_mo_integrals_e_n_kpts(mo_integrals_n_e_kpts)
|
||||
print *, 'MO N-e integrals written to disk'
|
||||
endif
|
||||
|
||||
END_PROVIDER
|
@ -25,4 +25,27 @@ BEGIN_PROVIDER [double precision, mo_pseudo_integrals, (mo_num,mo_num)]
|
||||
|
||||
END_PROVIDER
|
||||
|
||||
BEGIN_PROVIDER [ double precision, mo_pseudo_integrals_diag,(mo_num)]
|
||||
implicit none
|
||||
integer :: i
|
||||
BEGIN_DOC
|
||||
! diagonal elements of mo_pseudo_integrals or mo_pseudo_integrals_complex
|
||||
END_DOC
|
||||
|
||||
if (is_complex) then
|
||||
integer :: k,i_shft
|
||||
PROVIDE mo_pseudo_integrals_kpts
|
||||
do k=1,kpt_num
|
||||
i_shft = (k-1)*mo_num_per_kpt
|
||||
do i=1,mo_num_per_kpt
|
||||
mo_pseudo_integrals_diag(i+i_shft) = dble(mo_pseudo_integrals_kpts(i,i,k))
|
||||
enddo
|
||||
enddo
|
||||
else
|
||||
PROVIDE mo_pseudo_integrals
|
||||
do i=1,mo_num
|
||||
mo_pseudo_integrals_diag(i) = mo_pseudo_integrals(i,i)
|
||||
enddo
|
||||
endif
|
||||
END_PROVIDER
|
||||
|
||||
|
59
src/mo_one_e_ints/pot_mo_pseudo_ints_cplx.irp.f
Normal file
59
src/mo_one_e_ints/pot_mo_pseudo_ints_cplx.irp.f
Normal file
@ -0,0 +1,59 @@
|
||||
BEGIN_PROVIDER [complex*16, mo_pseudo_integrals_complex, (mo_num,mo_num)]
|
||||
implicit none
|
||||
BEGIN_DOC
|
||||
! Pseudopotential integrals in |MO| basis
|
||||
END_DOC
|
||||
integer :: i,j
|
||||
|
||||
if (read_mo_integrals_pseudo) then
|
||||
call ezfio_get_mo_one_e_ints_mo_integrals_pseudo_complex(mo_pseudo_integrals_complex)
|
||||
print *, 'MO pseudopotential integrals read from disk'
|
||||
else if (do_pseudo) then
|
||||
call ao_to_mo_complex( &
|
||||
ao_pseudo_integrals_complex, &
|
||||
size(ao_pseudo_integrals_complex,1), &
|
||||
mo_pseudo_integrals_complex, &
|
||||
size(mo_pseudo_integrals_complex,1) &
|
||||
)
|
||||
else
|
||||
mo_pseudo_integrals_complex = (0.d0,0.d0)
|
||||
endif
|
||||
if (write_mo_integrals_pseudo) then
|
||||
call ezfio_set_mo_one_e_ints_mo_integrals_pseudo_complex(mo_pseudo_integrals_complex)
|
||||
print *, 'MO pseudopotential integrals written to disk'
|
||||
endif
|
||||
|
||||
END_PROVIDER
|
||||
|
||||
!============================================!
|
||||
! !
|
||||
! kpts !
|
||||
! !
|
||||
!============================================!
|
||||
|
||||
BEGIN_PROVIDER [complex*16, mo_pseudo_integrals_kpts, (mo_num_per_kpt,mo_num_per_kpt,kpt_num)]
|
||||
implicit none
|
||||
BEGIN_DOC
|
||||
! Pseudopotential integrals in |MO| basis
|
||||
END_DOC
|
||||
integer :: i,j
|
||||
|
||||
if (read_mo_integrals_pseudo) then
|
||||
call ezfio_get_mo_one_e_ints_mo_integrals_pseudo_kpts(mo_pseudo_integrals_kpts)
|
||||
print *, 'MO pseudopotential integrals read from disk'
|
||||
else if (do_pseudo) then
|
||||
call ao_to_mo_kpts( &
|
||||
ao_pseudo_integrals_kpts, &
|
||||
size(ao_pseudo_integrals_kpts,1), &
|
||||
mo_pseudo_integrals_kpts, &
|
||||
size(mo_pseudo_integrals_kpts,1) &
|
||||
)
|
||||
else
|
||||
mo_pseudo_integrals_kpts = (0.d0,0.d0)
|
||||
endif
|
||||
if (write_mo_integrals_pseudo) then
|
||||
call ezfio_set_mo_one_e_ints_mo_integrals_pseudo_kpts(mo_pseudo_integrals_kpts)
|
||||
print *, 'MO pseudopotential integrals written to disk'
|
||||
endif
|
||||
|
||||
END_PROVIDER
|
@ -11,3 +11,15 @@ interface: ezfio,provider,ocaml
|
||||
default: 1.e-15
|
||||
ezfio_name: threshold_mo
|
||||
|
||||
[io_df_mo_integrals]
|
||||
type: Disk_access
|
||||
doc: Read/Write df |MO| integrals from/to disk [ Write | Read | None ]
|
||||
interface: ezfio,provider,ocaml
|
||||
default: None
|
||||
|
||||
[df_mo_integrals_complex]
|
||||
type: double precision
|
||||
doc: Complex df integrals over MOs
|
||||
size: (2,mo_basis.mo_num_per_kpt,mo_basis.mo_num_per_kpt,ao_two_e_ints.df_num,nuclei.kpt_pair_num)
|
||||
interface: ezfio
|
||||
|
||||
|
@ -7,7 +7,7 @@ BEGIN_PROVIDER [double precision, core_energy]
|
||||
core_energy = 0.d0
|
||||
do i = 1, n_core_orb
|
||||
j = list_core(i)
|
||||
core_energy += 2.d0 * mo_one_e_integrals(j,j) + mo_two_e_integrals_jj(j,j)
|
||||
core_energy += 2.d0 * mo_one_e_integrals_diag(j) + mo_two_e_integrals_jj(j,j)
|
||||
do k = i+1, n_core_orb
|
||||
l = list_core(k)
|
||||
core_energy += 2.d0 * (2.d0 * mo_two_e_integrals_jj(j,l) - mo_two_e_integrals_jj_exchange(j,l))
|
||||
@ -36,3 +36,25 @@ BEGIN_PROVIDER [double precision, core_fock_operator, (mo_num,mo_num)]
|
||||
enddo
|
||||
enddo
|
||||
END_PROVIDER
|
||||
|
||||
BEGIN_PROVIDER [complex*16, core_fock_operator_complex, (mo_num,mo_num)]
|
||||
implicit none
|
||||
integer :: i,j,k,l,m,n
|
||||
complex*16 :: get_two_e_integral_complex
|
||||
BEGIN_DOC
|
||||
! this is the contribution to the Fock operator from the core electrons
|
||||
END_DOC
|
||||
core_fock_operator_complex = (0.d0,0.d0)
|
||||
do i = 1, n_act_orb
|
||||
j = list_act(i)
|
||||
do k = 1, n_act_orb
|
||||
l = list_act(k)
|
||||
do m = 1, n_core_orb
|
||||
n = list_core(m)
|
||||
core_fock_operator_complex(j,l) += 2.d0 * &
|
||||
get_two_e_integral_complex(j,n,l,n,mo_integrals_map,mo_integrals_map_2) - &
|
||||
get_two_e_integral_complex(j,n,n,l,mo_integrals_map,mo_integrals_map_2)
|
||||
enddo
|
||||
enddo
|
||||
enddo
|
||||
END_PROVIDER
|
||||
|
295
src/mo_two_e_ints/df_mo_ints.irp.f
Normal file
295
src/mo_two_e_ints/df_mo_ints.irp.f
Normal file
@ -0,0 +1,295 @@
|
||||
BEGIN_PROVIDER [complex*16, df_mo_integrals_complex, (mo_num_per_kpt,mo_num_per_kpt,df_num,kpt_pair_num)]
|
||||
implicit none
|
||||
BEGIN_DOC
|
||||
! df MO integrals
|
||||
END_DOC
|
||||
integer :: i,j,k,l
|
||||
|
||||
if (read_df_mo_integrals) then
|
||||
call ezfio_get_mo_two_e_ints_df_mo_integrals_complex(df_mo_integrals_complex)
|
||||
print *, 'df MO integrals read from disk'
|
||||
else
|
||||
call df_mo_from_df_ao(df_mo_integrals_complex,df_ao_integrals_complex,mo_num_per_kpt,ao_num_per_kpt,df_num,kpt_pair_num)
|
||||
endif
|
||||
|
||||
if (write_df_mo_integrals) then
|
||||
call ezfio_set_mo_two_e_ints_df_mo_integrals_complex(df_mo_integrals_complex)
|
||||
print *, 'df MO integrals written to disk'
|
||||
endif
|
||||
|
||||
END_PROVIDER
|
||||
|
||||
subroutine mo_map_fill_from_df
|
||||
use map_module
|
||||
implicit none
|
||||
BEGIN_DOC
|
||||
! fill mo bielec integral map using 3-index df integrals
|
||||
END_DOC
|
||||
|
||||
integer :: i,k,j,l
|
||||
integer :: ki,kk,kj,kl
|
||||
integer :: ii,ik,ij,il
|
||||
integer :: kikk2,kjkl2,jl2,ik2
|
||||
integer :: i_mo,j_mo,i_df
|
||||
|
||||
complex*16,allocatable :: ints_ik(:,:,:), ints_jl(:,:,:), ints_ikjl(:,:,:,:)
|
||||
|
||||
complex*16 :: integral
|
||||
integer :: n_integrals_1, n_integrals_2
|
||||
integer :: size_buffer
|
||||
integer(key_kind),allocatable :: buffer_i_1(:), buffer_i_2(:)
|
||||
real(integral_kind),allocatable :: buffer_values_1(:), buffer_values_2(:)
|
||||
double precision :: tmp_re,tmp_im
|
||||
integer :: mo_num_kpt_2
|
||||
|
||||
double precision :: cpu_1, cpu_2, wall_1, wall_2, wall_0
|
||||
double precision :: map_mb
|
||||
|
||||
logical :: use_map1
|
||||
integer(keY_kind) :: idx_tmp
|
||||
double precision :: sign
|
||||
|
||||
mo_num_kpt_2 = mo_num_per_kpt * mo_num_per_kpt
|
||||
|
||||
size_buffer = min(mo_num_per_kpt*mo_num_per_kpt*mo_num_per_kpt,16000000)
|
||||
print*, 'Providing the mo_bielec integrals from 3-index df integrals'
|
||||
call write_time(6)
|
||||
! call ezfio_set_integrals_bielec_disk_access_mo_integrals('Write')
|
||||
! TOUCH read_mo_integrals read_ao_integrals write_mo_integrals write_ao_integrals
|
||||
|
||||
call wall_time(wall_1)
|
||||
call cpu_time(cpu_1)
|
||||
|
||||
allocate( ints_jl(mo_num_per_kpt,mo_num_per_kpt,df_num))
|
||||
|
||||
wall_0 = wall_1
|
||||
do kl=1, kpt_num
|
||||
do kj=1, kl
|
||||
call idx2_tri_int(kj,kl,kjkl2)
|
||||
if (kj < kl) then
|
||||
do i_mo=1,mo_num_per_kpt
|
||||
do j_mo=1,mo_num_per_kpt
|
||||
do i_df=1,df_num
|
||||
ints_jl(i_mo,j_mo,i_df) = dconjg(df_mo_integrals_complex(j_mo,i_mo,i_df,kjkl2))
|
||||
enddo
|
||||
enddo
|
||||
enddo
|
||||
else
|
||||
ints_jl = df_mo_integrals_complex(:,:,:,kjkl2)
|
||||
endif
|
||||
|
||||
!$OMP PARALLEL PRIVATE(i,k,j,l,ki,kk,ii,ik,ij,il,kikk2,jl2,ik2, &
|
||||
!$OMP ints_ik, ints_ikjl, i_mo, j_mo, i_df, &
|
||||
!$OMP n_integrals_1, buffer_i_1, buffer_values_1, &
|
||||
!$OMP n_integrals_2, buffer_i_2, buffer_values_2, &
|
||||
!$OMP idx_tmp, tmp_re, tmp_im, integral,sign,use_map1) &
|
||||
!$OMP DEFAULT(NONE) &
|
||||
!$OMP SHARED(size_buffer, kpt_num, df_num, mo_num_per_kpt, mo_num_kpt_2, &
|
||||
!$OMP kl,kj,kjkl2,ints_jl, &
|
||||
!$OMP kconserv, df_mo_integrals_complex, mo_integrals_threshold, mo_integrals_map, mo_integrals_map_2)
|
||||
|
||||
allocate( &
|
||||
ints_ik(mo_num_per_kpt,mo_num_per_kpt,df_num), &
|
||||
ints_ikjl(mo_num_per_kpt,mo_num_per_kpt,mo_num_per_kpt,mo_num_per_kpt), &
|
||||
buffer_i_1(size_buffer), &
|
||||
buffer_i_2(size_buffer), &
|
||||
buffer_values_1(size_buffer), &
|
||||
buffer_values_2(size_buffer) &
|
||||
)
|
||||
|
||||
!$OMP DO SCHEDULE(guided)
|
||||
do kk=1,kl
|
||||
ki=kconserv(kl,kk,kj)
|
||||
if (ki>kl) cycle
|
||||
! if ((kl == kj) .and. (ki > kk)) cycle
|
||||
call idx2_tri_int(ki,kk,kikk2)
|
||||
! if (kikk2 > kjkl2) cycle
|
||||
if (ki < kk) then
|
||||
do i_mo=1,mo_num_per_kpt
|
||||
do j_mo=1,mo_num_per_kpt
|
||||
do i_df=1,df_num
|
||||
ints_ik(i_mo,j_mo,i_df) = dconjg(df_mo_integrals_complex(j_mo,i_mo,i_df,kikk2))
|
||||
enddo
|
||||
enddo
|
||||
enddo
|
||||
! ints_ik = conjg(reshape(df_mo_integral_array(:,:,:,kikk2),(/mo_num_per_kpt,mo_num_per_kpt,df_num/),order=(/2,1,3/)))
|
||||
else
|
||||
ints_ik = df_mo_integrals_complex(:,:,:,kikk2)
|
||||
endif
|
||||
|
||||
call zgemm('N','T', mo_num_kpt_2, mo_num_kpt_2, df_num, &
|
||||
(1.d0,0.d0), ints_ik, mo_num_kpt_2, &
|
||||
ints_jl, mo_num_kpt_2, &
|
||||
(0.d0,0.d0), ints_ikjl, mo_num_kpt_2)
|
||||
|
||||
n_integrals_1=0
|
||||
n_integrals_2=0
|
||||
do il=1,mo_num_per_kpt
|
||||
l=il+(kl-1)*mo_num_per_kpt
|
||||
do ij=1,mo_num_per_kpt
|
||||
j=ij+(kj-1)*mo_num_per_kpt
|
||||
if (j>l) exit
|
||||
call idx2_tri_int(j,l,jl2)
|
||||
do ik=1,mo_num_per_kpt
|
||||
k=ik+(kk-1)*mo_num_per_kpt
|
||||
if (k>l) exit
|
||||
do ii=1,mo_num_per_kpt
|
||||
i=ii+(ki-1)*mo_num_per_kpt
|
||||
if ((j==l) .and. (i>k)) exit
|
||||
call idx2_tri_int(i,k,ik2)
|
||||
if (ik2 > jl2) exit
|
||||
integral = ints_ikjl(ii,ik,ij,il)
|
||||
! print*,i,k,j,l,real(integral),imag(integral)
|
||||
if (cdabs(integral) < mo_integrals_threshold) then
|
||||
cycle
|
||||
endif
|
||||
call ao_two_e_integral_complex_map_idx_sign(i,j,k,l,use_map1,idx_tmp,sign)
|
||||
tmp_re = dble(integral)
|
||||
tmp_im = dimag(integral)
|
||||
if (use_map1) then
|
||||
n_integrals_1 += 1
|
||||
buffer_i_1(n_integrals_1)=idx_tmp
|
||||
buffer_values_1(n_integrals_1)=tmp_re
|
||||
if (sign.ne.0.d0) then
|
||||
n_integrals_1 += 1
|
||||
buffer_i_1(n_integrals_1)=idx_tmp+1
|
||||
buffer_values_1(n_integrals_1)=tmp_im*sign
|
||||
endif
|
||||
if (n_integrals_1 >= size(buffer_i_1)-1) then
|
||||
call map_append(mo_integrals_map, buffer_i_1, buffer_values_1, n_integrals_1)
|
||||
!call insert_into_ao_integrals_map(n_integrals_1,buffer_i_1,buffer_values_1)
|
||||
n_integrals_1 = 0
|
||||
endif
|
||||
else
|
||||
n_integrals_2 += 1
|
||||
buffer_i_2(n_integrals_2)=idx_tmp
|
||||
buffer_values_2(n_integrals_2)=tmp_re
|
||||
if (sign.ne.0.d0) then
|
||||
n_integrals_2 += 1
|
||||
buffer_i_2(n_integrals_2)=idx_tmp+1
|
||||
buffer_values_2(n_integrals_2)=tmp_im*sign
|
||||
endif
|
||||
if (n_integrals_2 >= size(buffer_i_2)-1) then
|
||||
call map_append(mo_integrals_map_2, buffer_i_2, buffer_values_2, n_integrals_2)
|
||||
!call insert_into_ao_integrals_map_2(n_integrals_2,buffer_i_2,buffer_values_2)
|
||||
n_integrals_2 = 0
|
||||
endif
|
||||
endif
|
||||
|
||||
enddo !ii
|
||||
enddo !ik
|
||||
enddo !ij
|
||||
enddo !il
|
||||
|
||||
if (n_integrals_1 > 0) then
|
||||
call map_append(mo_integrals_map, buffer_i_1, buffer_values_1, n_integrals_1)
|
||||
!call insert_into_ao_integrals_map(n_integrals_1,buffer_i_1,buffer_values_1)
|
||||
endif
|
||||
if (n_integrals_2 > 0) then
|
||||
call map_append(mo_integrals_map_2, buffer_i_2, buffer_values_2, n_integrals_2)
|
||||
!call insert_into_ao_integrals_map_2(n_integrals_2,buffer_i_2,buffer_values_2)
|
||||
endif
|
||||
enddo !kk
|
||||
!$OMP END DO NOWAIT
|
||||
deallocate( &
|
||||
ints_ik, &
|
||||
ints_ikjl, &
|
||||
buffer_i_1, &
|
||||
buffer_i_2, &
|
||||
buffer_values_1, &
|
||||
buffer_values_2 &
|
||||
)
|
||||
!$OMP END PARALLEL
|
||||
enddo !kj
|
||||
call wall_time(wall_2)
|
||||
if (wall_2 - wall_0 > 1.d0) then
|
||||
wall_0 = wall_2
|
||||
print*, 100.*float(kl)/float(kpt_num), '% in ', &
|
||||
wall_2-wall_1,'s',map_mb(mo_integrals_map),'+',map_mb(mo_integrals_map_2),'MB'
|
||||
endif
|
||||
|
||||
enddo !kl
|
||||
deallocate( ints_jl )
|
||||
|
||||
call map_sort(mo_integrals_map)
|
||||
call map_unique(mo_integrals_map)
|
||||
call map_sort(mo_integrals_map_2)
|
||||
call map_unique(mo_integrals_map_2)
|
||||
!call map_save_to_disk(trim(ezfio_filename)//'/work/mo_ints_complex_1',mo_integrals_map)
|
||||
!call map_save_to_disk(trim(ezfio_filename)//'/work/mo_ints_complex_2',mo_integrals_map_2)
|
||||
!call ezfio_set_mo_two_e_ints_io_mo_two_e_integrals('Read')
|
||||
|
||||
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()
|
||||
|
||||
print*,'MO integrals provided:'
|
||||
print*,' Size of MO map ', map_mb(mo_integrals_map),'+',map_mb(mo_integrals_map_2),'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 mo_map_fill_from_df
|
||||
|
||||
subroutine df_mo_from_df_ao(df_mo,df_ao,n_mo,n_ao,n_df,n_k_pairs)
|
||||
use map_module
|
||||
implicit none
|
||||
BEGIN_DOC
|
||||
! create 3-idx mo ints from 3-idx ao ints
|
||||
END_DOC
|
||||
integer,intent(in) :: n_mo,n_ao,n_df,n_k_pairs
|
||||
complex*16,intent(out) :: df_mo(n_mo,n_mo,n_df,n_k_pairs)
|
||||
complex*16,intent(in) :: df_ao(n_ao,n_ao,n_df,n_k_pairs)
|
||||
integer :: kl,kj,kjkl2,mu,p,q
|
||||
complex*16,allocatable :: coef_l(:,:), coef_j(:,:), ints_jl(:,:), ints_tmp(:,:)
|
||||
double precision :: wall_1,wall_2,cpu_1,cpu_2
|
||||
|
||||
print*,'providing 3-index MO integrals from 3-index AO integrals'
|
||||
|
||||
call wall_time(wall_1)
|
||||
call cpu_time(cpu_1)
|
||||
allocate( &
|
||||
coef_l(n_ao,n_mo),&
|
||||
coef_j(n_ao,n_mo),&
|
||||
ints_jl(n_ao,n_ao),&
|
||||
ints_tmp(n_mo,n_ao)&
|
||||
)
|
||||
|
||||
do kl=1, kpt_num
|
||||
coef_l = mo_coef_complex_kpts(:,:,kl)
|
||||
do kj=1, kl
|
||||
coef_j = mo_coef_complex_kpts(:,:,kj)
|
||||
kjkl2 = kj+shiftr(kl*kl-kl,1)
|
||||
do mu=1, df_num
|
||||
ints_jl = df_ao(:,:,mu,kjkl2)
|
||||
call zgemm('C','N',n_mo,n_ao,n_ao, &
|
||||
(1.d0,0.d0), coef_l, n_ao, &
|
||||
ints_jl, n_ao, &
|
||||
(0.d0,0.d0), ints_tmp, n_mo)
|
||||
|
||||
call zgemm('N','N',n_mo,n_mo,n_ao, &
|
||||
(1.d0,0.d0), ints_tmp, n_mo, &
|
||||
coef_j, n_ao, &
|
||||
(0.d0,0.d0), df_mo(:,:,mu,kjkl2), n_mo)
|
||||
enddo
|
||||
enddo
|
||||
call wall_time(wall_2)
|
||||
print*,100.*float(kl*(kl+1))/(2.*n_k_pairs), '% in ', &
|
||||
wall_2-wall_1, 's'
|
||||
enddo
|
||||
|
||||
deallocate( &
|
||||
coef_l, &
|
||||
coef_j, &
|
||||
ints_jl, &
|
||||
ints_tmp &
|
||||
)
|
||||
call wall_time(wall_2)
|
||||
call cpu_time(cpu_2)
|
||||
print*,' 3-idx MO provided'
|
||||
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 df_mo_from_df_ao
|
247
src/mo_two_e_ints/four_idx_novvvv_cplx.irp.f
Normal file
247
src/mo_two_e_ints/four_idx_novvvv_cplx.irp.f
Normal file
@ -0,0 +1,247 @@
|
||||
BEGIN_PROVIDER [ complex*16, mo_coef_novirt_complex, (ao_num,n_core_inact_act_orb) ]
|
||||
implicit none
|
||||
BEGIN_DOC
|
||||
! MO coefficients without virtual MOs
|
||||
END_DOC
|
||||
integer :: j,jj
|
||||
|
||||
do j=1,n_core_inact_act_orb
|
||||
jj = list_core_inact_act(j)
|
||||
mo_coef_novirt_complex(:,j) = mo_coef_complex(:,jj)
|
||||
enddo
|
||||
|
||||
END_PROVIDER
|
||||
|
||||
subroutine ao_to_mo_novirt_complex(A_ao,LDA_ao,A_mo,LDA_mo)
|
||||
implicit none
|
||||
BEGIN_DOC
|
||||
! Transform A from the |AO| basis to the |MO| basis excluding virtuals
|
||||
!
|
||||
! $C^\dagger.A_{ao}.C$
|
||||
END_DOC
|
||||
integer, intent(in) :: LDA_ao,LDA_mo
|
||||
complex*16, intent(in) :: A_ao(LDA_ao,ao_num)
|
||||
complex*16, intent(out) :: A_mo(LDA_mo,n_core_inact_act_orb)
|
||||
complex*16, allocatable :: T(:,:)
|
||||
|
||||
allocate ( T(ao_num,n_core_inact_act_orb) )
|
||||
!DIR$ ATTRIBUTES ALIGN : $IRP_ALIGN :: T
|
||||
|
||||
call zgemm('N','N', ao_num, n_core_inact_act_orb, ao_num, &
|
||||
(1.d0,0.d0), A_ao,LDA_ao, &
|
||||
mo_coef_novirt_complex, size(mo_coef_novirt_complex,1), &
|
||||
(0.d0,0.d0), T, size(T,1))
|
||||
|
||||
call zgemm('C','N', n_core_inact_act_orb, n_core_inact_act_orb, ao_num,&
|
||||
(1.d0,0.d0), mo_coef_novirt_complex,size(mo_coef_novirt_complex,1), &
|
||||
T, ao_num, &
|
||||
(0.d0,0.d0), A_mo, size(A_mo,1))
|
||||
|
||||
deallocate(T)
|
||||
end
|
||||
|
||||
subroutine ao_to_mo_novirt_conjg_complex(A_ao,LDA_ao,A_mo,LDA_mo)
|
||||
implicit none
|
||||
BEGIN_DOC
|
||||
! Transform A from the |AO| basis to the |MO| basis excluding virtuals
|
||||
!
|
||||
! $C^\dagger.A_{ao}.C^*$
|
||||
! half-transformed ints as handled by four_idx_novvvv need to use this
|
||||
END_DOC
|
||||
integer, intent(in) :: LDA_ao,LDA_mo
|
||||
complex*16, intent(in) :: A_ao(LDA_ao,ao_num)
|
||||
complex*16, intent(out) :: A_mo(LDA_mo,n_core_inact_act_orb)
|
||||
complex*16, allocatable :: T(:,:)
|
||||
|
||||
allocate ( T(ao_num,n_core_inact_act_orb) )
|
||||
!DIR$ ATTRIBUTES ALIGN : $IRP_ALIGN :: T
|
||||
|
||||
call zgemm('N','N', ao_num, n_core_inact_act_orb, ao_num, &
|
||||
(1.d0,0.d0), A_ao,LDA_ao, &
|
||||
dconjg(mo_coef_novirt_complex), size(mo_coef_novirt_complex,1), &
|
||||
(0.d0,0.d0), T, size(T,1))
|
||||
|
||||
call zgemm('C','N', n_core_inact_act_orb, n_core_inact_act_orb, ao_num,&
|
||||
(1.d0,0.d0), mo_coef_novirt_complex,size(mo_coef_novirt_complex,1), &
|
||||
T, ao_num, &
|
||||
(0.d0,0.d0), A_mo, size(A_mo,1))
|
||||
|
||||
deallocate(T)
|
||||
end
|
||||
|
||||
|
||||
subroutine four_idx_novvvv_complex
|
||||
use map_module
|
||||
implicit none
|
||||
BEGIN_DOC
|
||||
! Retransform MO integrals for next CAS-SCF step
|
||||
END_DOC
|
||||
integer :: i,j,k,l,n_integrals1,n_integrals2
|
||||
logical :: use_map1
|
||||
complex*16, allocatable :: f(:,:,:), f2(:,:,:), d(:,:), T(:,:,:,:), T2(:,:,:,:)
|
||||
complex*16, external :: get_ao_two_e_integral_complex
|
||||
integer(key_kind), allocatable :: idx1(:),idx2(:)
|
||||
complex(integral_kind), allocatable :: values1(:),values2(:)
|
||||
double precision :: sign_tmp
|
||||
integer(key_kind) :: idx_tmp
|
||||
|
||||
integer :: p,q,r,s
|
||||
allocate( T(n_core_inact_act_orb,n_core_inact_act_orb,ao_num,ao_num) , &
|
||||
T2(n_core_inact_act_orb,n_core_inact_act_orb,ao_num,ao_num) )
|
||||
|
||||
!$OMP PARALLEL DEFAULT(NONE) &
|
||||
!$OMP SHARED(mo_num,ao_num,T,n_core_inact_act_orb, &
|
||||
!$OMP mo_integrals_threshold,mo_integrals_map, &
|
||||
!$OMP mo_integrals_map_2,ao_integrals_map_2, &
|
||||
!$OMP list_core_inact_act,T2,ao_integrals_map) &
|
||||
!$OMP PRIVATE(i,j,k,l,p,q,r,s,idx1,idx2,values1,values2,n_integrals1, &
|
||||
!$OMP n_integrals2,use_map1,idx_tmp,sign_tmp, &
|
||||
!$OMP f,f2,d)
|
||||
allocate(f(ao_num,ao_num,ao_num), f2(ao_num,ao_num,ao_num), d(mo_num,mo_num), &
|
||||
idx1(2*mo_num*mo_num), values1(2*mo_num*mo_num), &
|
||||
idx2(2*mo_num*mo_num), values2(2*mo_num*mo_num) )
|
||||
|
||||
! <aa|vv>
|
||||
!$OMP DO
|
||||
do s=1,ao_num
|
||||
do r=1,ao_num
|
||||
do q=1,ao_num
|
||||
do p=1,r
|
||||
f (p,q,r) = get_ao_two_e_integral_complex(p,q,r,s,ao_integrals_map,ao_integrals_map_2)
|
||||
f (r,q,p) = get_ao_two_e_integral_complex(r,q,p,s,ao_integrals_map,ao_integrals_map_2)
|
||||
enddo
|
||||
enddo
|
||||
enddo
|
||||
do r=1,ao_num
|
||||
do q=1,ao_num
|
||||
do p=1,ao_num
|
||||
f2(p,q,r) = f(p,r,q)
|
||||
enddo
|
||||
enddo
|
||||
enddo
|
||||
! f (p,q,r) = <pq|rs>
|
||||
! f2(p,q,r) = <pr|qs>
|
||||
|
||||
do r=1,ao_num
|
||||
call ao_to_mo_novirt_conjg_complex(f (1,1,r),size(f ,1),T (1,1,r,s),size(T,1))
|
||||
call ao_to_mo_novirt_complex(f2(1,1,r),size(f2,1),T2(1,1,r,s),size(T,1))
|
||||
enddo
|
||||
! T (i,j,p,q) = <ij|rs>
|
||||
! T2(i,j,p,q) = <ir|js>
|
||||
|
||||
enddo
|
||||
!$OMP END DO
|
||||
|
||||
!$OMP DO
|
||||
do j=1,n_core_inact_act_orb
|
||||
do i=1,n_core_inact_act_orb
|
||||
do s=1,ao_num
|
||||
do r=1,ao_num
|
||||
f (r,s,1) = T (i,j,r,s)
|
||||
f2(r,s,1) = T2(i,j,r,s)
|
||||
enddo
|
||||
enddo
|
||||
call ao_to_mo_noconjg_complex(f ,size(f ,1),d,size(d,1))
|
||||
n_integrals1 = 0
|
||||
n_integrals2 = 0
|
||||
do l=1,mo_num
|
||||
do k=1,mo_num
|
||||
call ao_two_e_integral_complex_map_idx_sign(list_core_inact_act(i),list_core_inact_act(j),k,l,use_map1,idx_tmp,sign_tmp)
|
||||
if (use_map1) then
|
||||
n_integrals1+=1
|
||||
values1(n_integrals1) = dble(d(k,l))
|
||||
idx1(n_integrals1) = idx_tmp
|
||||
if (sign_tmp /= 0.d0) then ! should always be true, but might change in the future
|
||||
n_integrals1+=1
|
||||
values1(n_integrals1) = sign_tmp*dimag(d(k,l))
|
||||
idx1(n_integrals1) = idx_tmp+1
|
||||
endif
|
||||
else
|
||||
n_integrals2+=1
|
||||
values2(n_integrals2) = dble(d(k,l))
|
||||
idx2(n_integrals2) = idx_tmp
|
||||
if (sign_tmp /= 0.d0) then
|
||||
n_integrals2+=1
|
||||
values2(n_integrals2) = sign_tmp*dimag(d(k,l))
|
||||
idx2(n_integrals2) = idx_tmp+1
|
||||
endif
|
||||
endif
|
||||
enddo
|
||||
enddo
|
||||
call map_append(mo_integrals_map, idx1, values1, n_integrals1)
|
||||
call map_append(mo_integrals_map_2, idx2, values2, n_integrals2)
|
||||
|
||||
call ao_to_mo(f2,size(f2,1),d,size(d,1))
|
||||
n_integrals1 = 0
|
||||
n_integrals2 = 0
|
||||
do l=1,mo_num
|
||||
do k=1,mo_num
|
||||
call ao_two_e_integral_complex_map_idx_sign(list_core_inact_act(i),k,list_core_inact_act(j),l,use_map1,idx_tmp,sign_tmp)
|
||||
if (use_map1) then
|
||||
n_integrals1+=1
|
||||
values1(n_integrals1) = dble(d(k,l))
|
||||
idx1(n_integrals1) = idx_tmp
|
||||
if (sign_tmp /= 0.d0) then ! should always be true, but might change in the future
|
||||
n_integrals1+=1
|
||||
values1(n_integrals1) = sign_tmp*dimag(d(k,l))
|
||||
idx1(n_integrals1) = idx_tmp+1
|
||||
endif
|
||||
else
|
||||
n_integrals2+=1
|
||||
values2(n_integrals2) = dble(d(k,l))
|
||||
idx2(n_integrals2) = idx_tmp
|
||||
if (sign_tmp /= 0.d0) then
|
||||
n_integrals2+=1
|
||||
values2(n_integrals2) = sign_tmp*dimag(d(k,l))
|
||||
idx2(n_integrals2) = idx_tmp+1
|
||||
endif
|
||||
endif
|
||||
enddo
|
||||
enddo
|
||||
call map_append(mo_integrals_map, idx1, values1, n_integrals1)
|
||||
call map_append(mo_integrals_map_2, idx2, values2, n_integrals2)
|
||||
enddo
|
||||
enddo
|
||||
!$OMP END DO
|
||||
deallocate(f,f2,d,idx1,idx2,values1,values2)
|
||||
|
||||
!$OMP END PARALLEL
|
||||
|
||||
deallocate(T,T2)
|
||||
|
||||
|
||||
call map_sort(mo_integrals_map)
|
||||
call map_unique(mo_integrals_map)
|
||||
call map_shrink(mo_integrals_map,real(mo_integrals_threshold,integral_kind))
|
||||
|
||||
call map_sort(mo_integrals_map_2)
|
||||
call map_unique(mo_integrals_map_2)
|
||||
call map_shrink(mo_integrals_map_2,real(mo_integrals_threshold,integral_kind))
|
||||
|
||||
end
|
||||
|
||||
subroutine four_idx_novvvv2_complex
|
||||
use bitmasks
|
||||
implicit none
|
||||
integer :: i
|
||||
integer(bit_kind) :: mask_ijkl(N_int,4)
|
||||
|
||||
print*, '<ix|ix>'
|
||||
do i = 1,N_int
|
||||
mask_ijkl(i,1) = core_inact_act_bitmask_4(i,1)
|
||||
mask_ijkl(i,2) = full_ijkl_bitmask_4(i,1)
|
||||
mask_ijkl(i,3) = core_inact_act_bitmask_4(i,1)
|
||||
mask_ijkl(i,4) = full_ijkl_bitmask_4(i,1)
|
||||
enddo
|
||||
call add_integrals_to_map_complex(mask_ijkl)
|
||||
|
||||
print*, '<ii|vv>'
|
||||
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_complex(mask_ijkl)
|
||||
|
||||
end
|
@ -25,3 +25,70 @@
|
||||
|
||||
END_PROVIDER
|
||||
|
||||
BEGIN_PROVIDER [complex*16, big_array_coulomb_integrals_complex, (mo_num,mo_num, mo_num)]
|
||||
&BEGIN_PROVIDER [complex*16, big_array_exchange_integrals_complex,(mo_num,mo_num, mo_num)]
|
||||
implicit none
|
||||
BEGIN_DOC
|
||||
! big_array_coulomb_integrals(j,i,k) = <ij|kj> = (ik|jj)
|
||||
! big_array_exchange_integrals(j,i,k) = <ij|jk> = (ij|jk)
|
||||
! for both of these, i and k must be from same kpt for integral to be nonzero
|
||||
! TODO: only loop over half, and assign two elements:
|
||||
! b_a_coul_int(j,i,k) = b_a_coul_int(j,k,i)*
|
||||
! b_a_exch_int(j,i,k) = b_a_exch_int(j,k,i)*
|
||||
END_DOC
|
||||
integer :: i,j,k,l
|
||||
complex*16 :: get_two_e_integral_complex
|
||||
complex*16 :: integral
|
||||
|
||||
do k = 1, mo_num
|
||||
do i = 1, mo_num
|
||||
do j = 1, mo_num
|
||||
l = j
|
||||
integral = get_two_e_integral_complex(i,j,k,l,mo_integrals_map,mo_integrals_map_2)
|
||||
big_array_coulomb_integrals_complex(j,i,k) = integral
|
||||
l = j
|
||||
integral = get_two_e_integral_complex(i,j,l,k,mo_integrals_map,mo_integrals_map_2)
|
||||
big_array_exchange_integrals_complex(j,i,k) = integral
|
||||
enddo
|
||||
enddo
|
||||
enddo
|
||||
|
||||
END_PROVIDER
|
||||
|
||||
BEGIN_PROVIDER [complex*16, big_array_coulomb_integrals_kpts, (mo_num_per_kpt,kpt_num,mo_num_per_kpt, mo_num_per_kpt,kpt_num)]
|
||||
&BEGIN_PROVIDER [complex*16, big_array_exchange_integrals_kpts,(mo_num_per_kpt,kpt_num,mo_num_per_kpt, mo_num_per_kpt,kpt_num)]
|
||||
implicit none
|
||||
BEGIN_DOC
|
||||
! big_array_coulomb_integrals(j,kj,i,k,ki) = <ij|kj> = (ik|jj)
|
||||
! big_array_exchange_integrals(j,kj,i,k,ki) = <ij|jk> = (ij|jk)
|
||||
! for both of these, i and k must be from same kpt for integral to be nonzero
|
||||
! TODO: only loop over half, and assign two elements:
|
||||
! b_a_coul_int(j,i,k) = b_a_coul_int(j,k,i)*
|
||||
! b_a_exch_int(j,i,k) = b_a_exch_int(j,k,i)*
|
||||
END_DOC
|
||||
integer :: i,j,k,l
|
||||
integer :: ki,kj,kk,kl
|
||||
complex*16 :: get_two_e_integral_kpts
|
||||
complex*16 :: integral
|
||||
|
||||
do ki = 1,kpt_num
|
||||
kk=ki
|
||||
do k = 1, mo_num_per_kpt
|
||||
do i = 1, mo_num_per_kpt
|
||||
do kj = 1,kpt_num
|
||||
kl=kj
|
||||
do j = 1, mo_num_per_kpt
|
||||
l = j
|
||||
integral = get_two_e_integral_kpts(i,j,k,l,ki,kj,kk,kl,mo_integrals_map,mo_integrals_map_2)
|
||||
big_array_coulomb_integrals_kpts(j,kj,i,k,ki) = integral
|
||||
l = j
|
||||
integral = get_two_e_integral_kpts(i,j,l,k,ki,kj,kl,kk,mo_integrals_map,mo_integrals_map_2)
|
||||
big_array_exchange_integrals_kpts(j,kj,i,k,ki) = integral
|
||||
enddo
|
||||
enddo
|
||||
enddo
|
||||
enddo
|
||||
enddo
|
||||
|
||||
END_PROVIDER
|
||||
|
||||
|
Some files were not shown because too many files have changed in this diff Show More
Loading…
Reference in New Issue
Block a user