diff --git a/bin/python b/bin/python new file mode 100755 index 00000000..c5b1d08f --- /dev/null +++ b/bin/python @@ -0,0 +1,4 @@ +#!/bin/bash + +exec python3 $@ + diff --git a/bin/qp_convert_output_to_ezfio b/bin/qp_convert_output_to_ezfio index 091423e4..0523b6a7 100755 --- a/bin/qp_convert_output_to_ezfio +++ b/bin/qp_convert_output_to_ezfio @@ -256,6 +256,7 @@ def write_ezfio(res, filename): MoTag = res.determinants_mo_type ezfio.set_mo_basis_mo_label('Orthonormalized') + ezfio.set_determinants_mo_label('Orthonormalized') MO_type = MoTag allMOs = res.mo_sets[MO_type] diff --git a/bin/qp_plugins b/bin/qp_plugins index c9158422..e53b08e9 100755 --- a/bin/qp_plugins +++ b/bin/qp_plugins @@ -127,6 +127,7 @@ def main(arguments): l_repository = list(d_tmp.keys()) if l_repository == []: l_result = [] + l_plugins = [] else: m_instance = ModuleHandler(l_repository) l_plugins = [module for module in m_instance.l_module] diff --git a/bin/qp_reset b/bin/qp_reset index d94ab24c..b144c4ce 100755 --- a/bin/qp_reset +++ b/bin/qp_reset @@ -97,6 +97,8 @@ if [[ $dets -eq 1 ]] ; then rm --force -- ${ezfio}/determinants/psi_{det,coef}.gz rm --force -- ${ezfio}/determinants/n_det_qp_edit rm --force -- ${ezfio}/determinants/psi_{det,coef}_qp_edit.gz + rm --force -- ${ezfio}/tc_bi_ortho/psi_{l,r}_coef_bi_ortho.gz + fi if [[ $mos -eq 1 ]] ; then diff --git a/bin/qpsh b/bin/qpsh index 1c511248..8db562bb 100755 --- a/bin/qpsh +++ b/bin/qpsh @@ -1,6 +1,7 @@ #!/bin/bash -export QP_ROOT=$(dirname "$(readlink -f "$0")")/.. +REALPATH=$( cd "$(dirname "$0")" ; pwd -P ) +export QP_ROOT=${REALPATH}/.. bash --init-file <(cat << EOF [[ -f /etc/bashrc ]] && source /etc/bashrc diff --git a/bin/zcat b/bin/zcat new file mode 100755 index 00000000..7ccecf07 --- /dev/null +++ b/bin/zcat @@ -0,0 +1,23 @@ +#!/bin/bash + +# On Darwin: try gzcat if available, otherwise use Python + +if [[ $(uname -s) = Darwin ]] ; then + which gzcat &> /dev/null + if [[ $? -eq 0 ]] ; then + exec gzcat $@ + else + + exec python3 << EOF +import sys +import gzip +with gzip.open("$1", "rt") as f: + print(f.read()) +EOF + fi +else + SCRIPTPATH="$( cd -- "$(dirname "$0")" >/dev/null 2>&1 ; pwd -P )" + command=$(which -a zcat | grep -v "$SCRIPTPATH/" | head -1) + exec $command $@ +fi + diff --git a/config/gfortran.cfg b/config/gfortran.cfg index 33ce48ba..41181c32 100644 --- a/config/gfortran.cfg +++ b/config/gfortran.cfg @@ -10,7 +10,7 @@ # # [COMMON] -FC : gfortran -g -ffree-line-length-none -I . -fPIC -march=native +FC : gfortran -g -ffree-line-length-none -I . -fPIC -march=native -std=legacy LAPACK_LIB : -lblas -llapack IRPF90 : irpf90 IRPF90_FLAGS : --ninja --align=32 --assert -DSET_NESTED diff --git a/config/gfortran_armpl.cfg b/config/gfortran_armpl.cfg index 370e396e..245cc8ea 100644 --- a/config/gfortran_armpl.cfg +++ b/config/gfortran_armpl.cfg @@ -13,7 +13,7 @@ # # [COMMON] -FC : gfortran -g -ffree-line-length-none -I . -fPIC -march=native +FC : gfortran -g -ffree-line-length-none -I . -fPIC -march=native -std=legacy LAPACK_LIB : -larmpl_lp64_mp IRPF90 : irpf90 IRPF90_FLAGS : --ninja --align=32 --assert -DSET_NESTED diff --git a/config/gfortran_avx.cfg b/config/gfortran_avx.cfg index 747dff67..5b51c640 100644 --- a/config/gfortran_avx.cfg +++ b/config/gfortran_avx.cfg @@ -10,7 +10,7 @@ # # [COMMON] -FC : gfortran -ffree-line-length-none -I . -mavx -g -fPIC +FC : gfortran -ffree-line-length-none -I . -mavx -g -fPIC -std=legacy LAPACK_LIB : -llapack -lblas IRPF90 : irpf90 IRPF90_FLAGS : --ninja --align=32 -DSET_NESTED diff --git a/config/gfortran_debug.cfg b/config/gfortran_debug.cfg index 51e5a500..f903142a 100644 --- a/config/gfortran_debug.cfg +++ b/config/gfortran_debug.cfg @@ -10,7 +10,7 @@ # # [COMMON] -FC : gfortran -g -ffree-line-length-none -I . -fPIC +FC : gfortran -g -ffree-line-length-none -I . -fPIC -std=legacy LAPACK_LIB : -lblas -llapack IRPF90 : irpf90 IRPF90_FLAGS : --ninja --align=32 --assert -DSET_NESTED diff --git a/config/gfortran_macos.cfg b/config/gfortran_macos.cfg new file mode 100644 index 00000000..4fffca29 --- /dev/null +++ b/config/gfortran_macos.cfg @@ -0,0 +1,62 @@ +# Common flags +############## +# +# -ffree-line-length-none : Needed for IRPF90 which produces long lines +# -lblas -llapack : Link with libblas and liblapack libraries provided by the system +# -I . : Include the curent directory (Mandatory) +# +# --ninja : Allow the utilisation of ninja. (Mandatory) +# --align=32 : Align all provided arrays on a 32-byte boundary +# +# +[COMMON] +FC : gfortran -ffree-line-length-none -I . -g -fPIC -std=legacy +LAPACK_LIB : -llapack -lblas +IRPF90 : irpf90 +IRPF90_FLAGS : --ninja --align=32 -DSET_NESTED -DMACOS + +# Global options +################ +# +# 1 : Activate +# 0 : Deactivate +# +[OPTION] +MODE : OPT ; [ OPT | PROFILE | DEBUG ] : Chooses the section below +CACHE : 0 ; Enable cache_compile.py +OPENMP : 1 ; Append OpenMP flags + +# Optimization flags +#################### +# +# -Ofast : Disregard strict standards compliance. Enables all -O3 optimizations. +# It also enables optimizations that are not valid +# for all standard-compliant programs. It turns on +# -ffast-math and the Fortran-specific +# -fno-protect-parens and -fstack-arrays. +[OPT] +FCFLAGS : -Ofast -march=native + +# Profiling flags +################# +# +[PROFILE] +FC : -p -g +FCFLAGS : -Ofast + +# Debugging flags +################# +# +# -fcheck=all : Checks uninitialized variables, array subscripts, etc... +# -g : Extra debugging information +# +[DEBUG] +FCFLAGS : -fcheck=all -g + +# OpenMP flags +################# +# +[OPENMP] +FC : -fopenmp +IRPF90_FLAGS : --openmp + diff --git a/config/gfortran_mpi.cfg b/config/gfortran_mpi.cfg index 1af3ca45..7cc88f1f 100644 --- a/config/gfortran_mpi.cfg +++ b/config/gfortran_mpi.cfg @@ -10,7 +10,7 @@ # # [COMMON] -FC : mpif90 -ffree-line-length-none -I . -g -fPIC +FC : mpif90 -ffree-line-length-none -I . -g -fPIC -std=legacy LAPACK_LIB : -lblas -llapack IRPF90 : irpf90 IRPF90_FLAGS : --ninja --align=32 -DMPI -DSET_NESTED diff --git a/config/gfortran_openblas.cfg b/config/gfortran_openblas.cfg index ab67d8c3..5db46fce 100644 --- a/config/gfortran_openblas.cfg +++ b/config/gfortran_openblas.cfg @@ -10,7 +10,7 @@ # # [COMMON] -FC : gfortran -g -ffree-line-length-none -I . -fPIC -march=native +FC : gfortran -g -ffree-line-length-none -I . -fPIC -march=native -std=legacy LAPACK_LIB : -lopenblas IRPF90 : irpf90 IRPF90_FLAGS : --ninja --align=32 --assert -DSET_NESTED diff --git a/configure b/configure index 893c7148..e211cfd7 100755 --- a/configure +++ b/configure @@ -19,7 +19,11 @@ git submodule init git submodule update # Update ARM or x86 dependencies -ARCHITECTURE=$(uname -m) +SYSTEM=$(uname -s) +if [[ $SYSTEM = "Linux" ]] ; then + SYSTEM="" +fi +ARCHITECTURE=$(uname -m)$SYSTEM cd ${QP_ROOT}/external/qp2-dependencies git checkout master git pull @@ -191,7 +195,7 @@ if [[ "${PACKAGES}.x" != ".x" ]] ; then fi if [[ ${PACKAGES} = all ]] ; then - PACKAGES="zlib ninja zeromq f77zmq gmp ocaml docopt resultsFile bats trexio qmckl" + PACKAGES="zlib ninja zeromq f77zmq gmp ocaml docopt resultsFile bats trexio" fi @@ -211,6 +215,7 @@ EOF execute << EOF cd "\${QP_ROOT}"/external wget https://github.com/TREX-CoE/trexio/releases/download/v${VERSION}/trexio-${VERSION}.tar.gz + rm -rf trexio-${VERSION} tar -zxf trexio-${VERSION}.tar.gz && rm trexio-${VERSION}.tar.gz cd trexio-${VERSION} ./configure --prefix=\${QP_ROOT} --without-hdf5 CFLAGS='-g' @@ -224,6 +229,7 @@ EOF execute << EOF cd "\${QP_ROOT}"/external wget https://github.com/TREX-CoE/trexio/releases/download/v${VERSION}/trexio-${VERSION}.tar.gz + rm -rf trexio-${VERSION} tar -zxf trexio-${VERSION}.tar.gz && rm trexio-${VERSION}.tar.gz cd trexio-${VERSION} ./configure --prefix=\${QP_ROOT} CFLAGS="-g" @@ -231,15 +237,28 @@ EOF EOF elif [[ ${PACKAGE} = qmckl ]] ; then - VERSION=0.5.3 + VERSION=0.5.4 execute << EOF cd "\${QP_ROOT}"/external wget https://github.com/TREX-CoE/qmckl/releases/download/v${VERSION}/qmckl-${VERSION}.tar.gz + rm -rf qmckl-${VERSION} tar -zxf qmckl-${VERSION}.tar.gz && rm qmckl-${VERSION}.tar.gz cd qmckl-${VERSION} ./configure --prefix=\${QP_ROOT} --enable-hpc --disable-doc CFLAGS='-g' make && make -j 4 check && make install EOF + elif [[ ${PACKAGE} = qmckl-intel ]] ; then + + VERSION=0.5.4 + execute << EOF + cd "\${QP_ROOT}"/external + wget https://github.com/TREX-CoE/qmckl/releases/download/v${VERSION}/qmckl-${VERSION}.tar.gz + rm -rf qmckl-${VERSION} + tar -zxf qmckl-${VERSION}.tar.gz && rm qmckl-${VERSION}.tar.gz + cd qmckl-${VERSION} + ./configure --prefix=\${QP_ROOT} --enable-hpc --disable-doc --with-icc --with-ifort CFLAGS='-g' + make && make -j 4 check && make install +EOF elif [[ ${PACKAGE} = gmp ]] ; then @@ -260,6 +279,7 @@ EOF cd "\${QP_ROOT}"/external tar --gunzip --extract --file qp2-dependencies/zeromq-4.2.5.tar.gz cd zeromq-* + [[ "${SYSTEM}" = "Darwin" ]] && ./autogen.sh ./configure --prefix="\$QP_ROOT" --without-libsodium --enable-libunwind=no make -j 8 make install @@ -378,15 +398,15 @@ fi TREXIO=$(find_lib -ltrexio) if [[ ${TREXIO} = $(not_found) ]] ; then - error "TREXIO (trexio,trexio-nohdf5) is not installed. If you don't have HDF5, use trexio-nohdf5" + error "TREXIO (trexio | trexio-nohdf5) is not installed. If you don't have HDF5, use trexio-nohdf5" fail fi -QMCKL=$(find_lib -lqmckl) -if [[ ${QMCKL} = $(not_found) ]] ; then - error "QMCkl (qmckl) is not installed." - fail -fi +#QMCKL=$(find_lib -lqmckl) +#if [[ ${QMCKL} = $(not_found) ]] ; then +# error "QMCkl (qmckl | qmckl-intel) is not installed." +# fail +#fi F77ZMQ=$(find_lib -lzmq -lf77zmq -lpthread) if [[ ${F77ZMQ} = $(not_found) ]] ; then diff --git a/etc/paths.rc b/etc/paths.rc index 84c2d12f..dc1741e8 100644 --- a/etc/paths.rc +++ b/etc/paths.rc @@ -32,7 +32,7 @@ export PYTHONPATH=$(qp_prepend_export "PYTHONPATH" "${QP_EZFIO}/Python":"${QP_PY export PATH=$(qp_prepend_export "PATH" "${QP_PYTHON}":"${QP_ROOT}"/bin:"${QP_ROOT}"/ocaml) -export LD_LIBRARY_PATH=$(qp_prepend_export "LD_LIBRARY_PATH" "${QP_ROOT}"/lib) +export LD_LIBRARY_PATH=$(qp_prepend_export "LD_LIBRARY_PATH" "${QP_ROOT}"/lib:"${QP_ROOT}"/lib64) export LIBRARY_PATH=$(qp_prepend_export "LIBRARY_PATH" "${QP_ROOT}"/lib:"${QP_ROOT}"/lib64) diff --git a/external/irpf90 b/external/irpf90 index 0007f72f..4ab1b175 160000 --- a/external/irpf90 +++ b/external/irpf90 @@ -1 +1 @@ -Subproject commit 0007f72f677fe7d61c5e1ed461882cb239517102 +Subproject commit 4ab1b175fc7ed0d96c1912f13dc53579b24157a6 diff --git a/ocaml/Input_determinants_by_hand.ml b/ocaml/Input_determinants_by_hand.ml index fb0aef7f..0cc47f63 100644 --- a/ocaml/Input_determinants_by_hand.ml +++ b/ocaml/Input_determinants_by_hand.ml @@ -13,6 +13,7 @@ module Determinants_by_hand : sig psi_coef : Det_coef.t array; psi_det : Determinant.t array; state_average_weight : Positive_float.t array; + mo_label : MO_label.t; } [@@deriving sexp] val read : ?full:bool -> unit -> t option val write : ?force:bool -> t -> unit @@ -34,11 +35,21 @@ end = struct psi_coef : Det_coef.t array; psi_det : Determinant.t array; state_average_weight : Positive_float.t array; + mo_label : MO_label.t; } [@@deriving sexp] ;; let get_default = Qpackage.get_ezfio_default "determinants";; + let read_mo_label () = + if not (Ezfio.has_determinants_mo_label ()) then + if Ezfio.has_mo_basis_mo_label () then ( + let label = Ezfio.get_mo_basis_mo_label () in + Ezfio.set_determinants_mo_label label) ; + Ezfio.get_determinants_mo_label () + |> MO_label.of_string + ;; + let read_n_int () = if not (Ezfio.has_determinants_n_int()) then Ezfio.get_mo_basis_mo_num () @@ -222,7 +233,7 @@ end = struct and n_states = States_number.to_int n_states in - let r = + let r = Ezfio.ezfio_array_of_list ~rank:2 ~dim:[| n_det ; n_states |] ~data:c in Ezfio.set_determinants_psi_coef r; @@ -283,19 +294,23 @@ end = struct |> Array.concat |> Array.to_list in - let r = + let r = Ezfio.ezfio_array_of_list ~rank:3 ~dim:[| N_int_number.to_int n_int ; 2 ; Det_number.to_int n_det |] ~data:data in Ezfio.set_determinants_psi_det r; Ezfio.set_determinants_psi_det_qp_edit r ;; + let write_mo_label a = + MO_label.to_string a + |> Ezfio.set_determinants_mo_label + let read ?(full=true) () = let n_det_qp_edit = read_n_det_qp_edit () in let n_det = read_n_det () in - let read_only = + let read_only = if full then false else n_det_qp_edit <> n_det in @@ -311,6 +326,7 @@ end = struct psi_det = read_psi_det ~read_only () ; n_states = read_n_states () ; state_average_weight = read_state_average_weight () ; + mo_label = read_mo_label () ; } with _ -> None else @@ -328,6 +344,7 @@ end = struct psi_det ; n_states ; state_average_weight ; + mo_label ; } = write_n_int n_int ; write_bit_kind bit_kind; @@ -340,7 +357,9 @@ end = struct write_psi_coef ~n_det:n_det ~n_states:n_states psi_coef ; write_psi_det ~n_int:n_int ~n_det:n_det psi_det end; - write_state_average_weight state_average_weight + write_state_average_weight state_average_weight ; + write_mo_label mo_label ; + () ;; @@ -439,7 +458,7 @@ psi_det = %s in (* Split into header and determinants data *) - let idx = + let idx = match String_ext.substr_index r ~pos:0 ~pattern:"\nDeterminants" with | Some x -> x | None -> assert false @@ -545,6 +564,8 @@ psi_det = %s let bitkind = Printf.sprintf "(bit_kind %d)" (Lazy.force Qpackage.bit_kind |> Bit_kind.to_int) + and mo_label = + Printf.sprintf "(mo_label %s)" (MO_label.to_string @@ read_mo_label ()) and n_int = Printf.sprintf "(n_int %d)" (N_int_number.get_max ()) and n_states = @@ -553,7 +574,7 @@ psi_det = %s Printf.sprintf "(n_det_qp_edit %d)" (Det_number.to_int @@ read_n_det_qp_edit ()) in let s = - String.concat "" [ header ; bitkind ; n_int ; n_states ; psi_coef ; psi_det ; n_det_qp_edit ] + String.concat "" [ header ; mo_label ; bitkind ; n_int ; n_states ; psi_coef ; psi_det ; n_det_qp_edit ] in diff --git a/ocaml/Zmatrix.ml b/ocaml/Zmatrix.ml index 9e6ab2f8..6427f734 100644 --- a/ocaml/Zmatrix.ml +++ b/ocaml/Zmatrix.ml @@ -58,17 +58,32 @@ let int_of_atom_id : atom_id -> int = fun x -> x let float_of_distance : float StringMap.t -> distance -> float = fun map -> function | Value x -> x - | Label s -> StringMap.find s map + | Label s -> begin + try StringMap.find s map with + | Not_found -> + Printf.sprintf "Zmatrix error: distance %s undefined" s + |> failwith + end let float_of_angle : float StringMap.t -> angle -> float = fun map -> function | Value x -> x - | Label s -> StringMap.find s map + | Label s -> begin + try StringMap.find s map with + | Not_found -> + Printf.sprintf "Zmatrix error: angle %s undefined" s + |> failwith + end let float_of_dihedral : float StringMap.t -> dihedral -> float = fun map -> function | Value x -> x - | Label s -> StringMap.find s map + | Label s -> begin + try StringMap.find s map with + | Not_found -> + Printf.sprintf "Zmatrix error: dihedral %s undefined" s + |> failwith + end type line = diff --git a/ocaml/qptypes_generator.ml b/ocaml/qptypes_generator.ml index a5ac22f2..32506650 100644 --- a/ocaml/qptypes_generator.ml +++ b/ocaml/qptypes_generator.ml @@ -154,8 +154,8 @@ let input_ezfio = " * N_int_number : int determinants_n_int - 1 : 30 - N_int > 30 + 1 : 128 + N_int > 128 * Det_number : int determinants_n_det diff --git a/plugins/.gitignore b/plugins/.gitignore index 241e560d..8b137891 100644 --- a/plugins/.gitignore +++ b/plugins/.gitignore @@ -1,2 +1 @@ -* diff --git a/src/ao_many_one_e_ints/NEED b/plugins/local/ao_many_one_e_ints/NEED similarity index 88% rename from src/ao_many_one_e_ints/NEED rename to plugins/local/ao_many_one_e_ints/NEED index c57219cd..6e16c74a 100644 --- a/src/ao_many_one_e_ints/NEED +++ b/plugins/local/ao_many_one_e_ints/NEED @@ -4,3 +4,4 @@ becke_numerical_grid mo_one_e_ints dft_utils_in_r tc_keywords +hamiltonian diff --git a/src/ao_many_one_e_ints/README.rst b/plugins/local/ao_many_one_e_ints/README.rst similarity index 100% rename from src/ao_many_one_e_ints/README.rst rename to plugins/local/ao_many_one_e_ints/README.rst diff --git a/src/ao_many_one_e_ints/ao_erf_gauss.irp.f b/plugins/local/ao_many_one_e_ints/ao_erf_gauss.irp.f similarity index 98% rename from src/ao_many_one_e_ints/ao_erf_gauss.irp.f rename to plugins/local/ao_many_one_e_ints/ao_erf_gauss.irp.f index 823536cc..46124c44 100644 --- a/src/ao_many_one_e_ints/ao_erf_gauss.irp.f +++ b/plugins/local/ao_many_one_e_ints/ao_erf_gauss.irp.f @@ -98,7 +98,7 @@ double precision function phi_j_erf_mu_r_phi(i, j, mu_in, C_center) enddo enddo -end function phi_j_erf_mu_r_phi +end ! --- @@ -201,7 +201,7 @@ subroutine erf_mu_gauss_ij_ao(i, j, mu, C_center, delta, gauss_ints) enddo enddo -end subroutine erf_mu_gauss_ij_ao +end ! --- @@ -266,7 +266,7 @@ subroutine NAI_pol_x_mult_erf_ao(i_ao, j_ao, mu_in, C_center, ints) enddo enddo -end subroutine NAI_pol_x_mult_erf_ao +end ! --- @@ -340,7 +340,7 @@ subroutine NAI_pol_x_mult_erf_ao_v0(i_ao, j_ao, mu_in, C_center, LD_C, ints, LD_ deallocate(integral) -end subroutine NAI_pol_x_mult_erf_ao_v0 +end ! --- @@ -420,7 +420,7 @@ subroutine NAI_pol_x_mult_erf_ao_v(i_ao, j_ao, mu_in, C_center, LD_C, ints, LD_i deallocate(integral) -end subroutine NAI_pol_x_mult_erf_ao_v +end ! --- @@ -479,7 +479,7 @@ double precision function NAI_pol_x_mult_erf_ao_x(i_ao, j_ao, mu_in, C_center) enddo enddo -end function NAI_pol_x_mult_erf_ao_x +end ! --- @@ -538,7 +538,7 @@ double precision function NAI_pol_x_mult_erf_ao_y(i_ao, j_ao, mu_in, C_center) enddo enddo -end function NAI_pol_x_mult_erf_ao_y +end ! --- @@ -597,7 +597,7 @@ double precision function NAI_pol_x_mult_erf_ao_z(i_ao, j_ao, mu_in, C_center) enddo enddo -end function NAI_pol_x_mult_erf_ao_z +end ! --- @@ -667,7 +667,7 @@ double precision function NAI_pol_x_mult_erf_ao_with1s_x(i_ao, j_ao, beta, B_cen enddo enddo -end function NAI_pol_x_mult_erf_ao_with1s_x +end ! --- @@ -737,7 +737,7 @@ double precision function NAI_pol_x_mult_erf_ao_with1s_y(i_ao, j_ao, beta, B_cen enddo enddo -end function NAI_pol_x_mult_erf_ao_with1s_y +end ! --- @@ -807,7 +807,7 @@ double precision function NAI_pol_x_mult_erf_ao_with1s_z(i_ao, j_ao, beta, B_cen enddo enddo -end function NAI_pol_x_mult_erf_ao_with1s_z +end ! --- @@ -880,7 +880,7 @@ subroutine NAI_pol_x_mult_erf_ao_with1s(i_ao, j_ao, beta, B_center, mu_in, C_cen enddo enddo -end subroutine NAI_pol_x_mult_erf_ao_with1s +end ! --- @@ -967,7 +967,7 @@ subroutine NAI_pol_x_mult_erf_ao_with1s_v0(i_ao, j_ao, beta, B_center, LD_B, mu_ deallocate(integral) -end subroutine NAI_pol_x_mult_erf_ao_with1s_v0 +end ! --- @@ -1057,7 +1057,7 @@ subroutine NAI_pol_x_mult_erf_ao_with1s_v(i_ao, j_ao, beta, B_center, LD_B, mu_i deallocate(integral) -end subroutine NAI_pol_x_mult_erf_ao_with1s_v +end ! --- @@ -1175,7 +1175,7 @@ subroutine NAI_pol_x2_mult_erf_ao_with1s(i_ao, j_ao, beta, B_center, mu_in, C_ce enddo enddo -end subroutine NAI_pol_x2_mult_erf_ao_with1s +end ! --- @@ -1241,7 +1241,7 @@ subroutine NAI_pol_x2_mult_erf_ao(i_ao, j_ao, mu_in, C_center, ints) enddo enddo -end subroutine NAI_pol_x2_mult_erf_ao +end ! --- @@ -1320,7 +1320,7 @@ subroutine NAI_pol_012_mult_erf_ao_with1s(i_ao, j_ao, beta, B_center, mu_in, C_c enddo enddo -end subroutine NAI_pol_012_mult_erf_ao_with1s +end ! --- @@ -1328,7 +1328,7 @@ subroutine NAI_pol_012_mult_erf_ao(i_ao, j_ao, mu_in, C_center, ints) BEGIN_DOC ! - ! Computes the following integral : + ! Computes the following integrals : ! ! int(1) = $\int_{-\infty}^{infty} dr x^0 * \chi_i(r) \chi_j(r) \frac{\erf(\mu | r - R_C | )}{ | r - R_C | }$. ! @@ -1395,7 +1395,7 @@ subroutine NAI_pol_012_mult_erf_ao(i_ao, j_ao, mu_in, C_center, ints) enddo enddo -end subroutine NAI_pol_012_mult_erf_ao +end ! --- diff --git a/src/ao_many_one_e_ints/ao_erf_gauss_grad.irp.f b/plugins/local/ao_many_one_e_ints/ao_erf_gauss_grad.irp.f similarity index 100% rename from src/ao_many_one_e_ints/ao_erf_gauss_grad.irp.f rename to plugins/local/ao_many_one_e_ints/ao_erf_gauss_grad.irp.f diff --git a/src/ao_many_one_e_ints/ao_gaus_gauss.irp.f b/plugins/local/ao_many_one_e_ints/ao_gaus_gauss.irp.f similarity index 83% rename from src/ao_many_one_e_ints/ao_gaus_gauss.irp.f rename to plugins/local/ao_many_one_e_ints/ao_gaus_gauss.irp.f index d2115d9e..1e4f340c 100644 --- a/src/ao_many_one_e_ints/ao_gaus_gauss.irp.f +++ b/plugins/local/ao_many_one_e_ints/ao_gaus_gauss.irp.f @@ -152,7 +152,7 @@ double precision function overlap_gauss_r12_ao(D_center, delta, i, j) enddo enddo -end function overlap_gauss_r12_ao +end ! -- @@ -199,7 +199,7 @@ double precision function overlap_abs_gauss_r12_ao(D_center, delta, i, j) enddo enddo -end function overlap_gauss_r12_ao +end ! -- @@ -257,7 +257,7 @@ subroutine overlap_gauss_r12_ao_v(D_center, LD_D, delta, i, j, resv, LD_resv, n_ deallocate(analytical_j) -end subroutine overlap_gauss_r12_ao_v +end ! --- @@ -327,7 +327,7 @@ double precision function overlap_gauss_r12_ao_with1s(B_center, beta, D_center, enddo enddo -end function overlap_gauss_r12_ao_with1s +end ! --- @@ -420,7 +420,86 @@ subroutine overlap_gauss_r12_ao_with1s_v(B_center, beta, D_center, LD_D, delta, deallocate(fact_g, G_center, analytical_j) -end subroutine overlap_gauss_r12_ao_with1s_v +end + +! --- + +subroutine overlap_gauss_r12_ao_012(D_center, delta, i, j, ints) + + BEGIN_DOC + ! + ! Computes the following integrals : + ! + ! ints(1) = $\int_{-\infty}^{infty} dr x^0 * \chi_i(r) \chi_j(r) e^{-\delta (r - D_center)^2} + ! + ! ints(2) = $\int_{-\infty}^{infty} dr x^1 * \chi_i(r) \chi_j(r) e^{-\delta (r - D_center)^2} + ! ints(3) = $\int_{-\infty}^{infty} dr y^1 * \chi_i(r) \chi_j(r) e^{-\delta (r - D_center)^2} + ! ints(4) = $\int_{-\infty}^{infty} dr z^1 * \chi_i(r) \chi_j(r) e^{-\delta (r - D_center)^2} + ! + ! ints(5) = $\int_{-\infty}^{infty} dr x^2 * \chi_i(r) \chi_j(r) e^{-\delta (r - D_center)^2} + ! ints(6) = $\int_{-\infty}^{infty} dr y^2 * \chi_i(r) \chi_j(r) e^{-\delta (r - D_center)^2} + ! ints(7) = $\int_{-\infty}^{infty} dr z^2 * \chi_i(r) \chi_j(r) e^{-\delta (r - D_center)^2} + ! + END_DOC + + include 'utils/constants.include.F' + + implicit none + + integer, intent(in) :: i, j + double precision, intent(in) :: delta, D_center(3) + double precision, intent(out) :: ints(7) + + integer :: k, l, m + integer :: power_A(3), power_B(3), power_A1(3), power_A2(3) + double precision :: A_center(3), B_center(3), alpha, beta, coef1, coef + double precision :: integral0, integral1, integral2 + + double precision, external :: overlap_gauss_r12 + + ints = 0.d0 + + if(ao_overlap_abs(j,i).lt.1.d-12) then + return + endif + + power_A(1:3) = ao_power(i,1:3) + power_B(1:3) = ao_power(j,1:3) + + A_center(1:3) = nucl_coord(ao_nucl(i),1:3) + B_center(1:3) = nucl_coord(ao_nucl(j),1:3) + + do l = 1, ao_prim_num(i) + alpha = ao_expo_ordered_transp (l,i) + coef1 = ao_coef_normalized_ordered_transp(l,i) + + do k = 1, ao_prim_num(j) + beta = ao_expo_ordered_transp(k,j) + coef = coef1 * ao_coef_normalized_ordered_transp(k,j) + + if(dabs(coef) .lt. 1d-12) cycle + + integral0 = overlap_gauss_r12(D_center, delta, A_center, B_center, power_A, power_B, alpha, beta) + + ints(1) += coef * integral0 + + do m = 1, 3 + power_A1 = power_A + power_A1(m) += 1 + integral1 = overlap_gauss_r12(D_center, delta, A_center, B_center, power_A1, power_B, alpha, beta) + ints(1+m) += coef * (integral1 + A_center(m)*integral0) + + power_A2 = power_A + power_A2(m) += 2 + integral2 = overlap_gauss_r12(D_center, delta, A_center, B_center, power_A2, power_B, alpha, beta) + ints(4+m) += coef * (integral2 + A_center(m) * (2.d0*integral1 + A_center(m)*integral0)) + enddo + + enddo ! k + enddo ! l + + return +end ! --- diff --git a/src/ao_many_one_e_ints/grad2_jmu_manu.irp.f b/plugins/local/ao_many_one_e_ints/grad2_jmu_manu.irp.f similarity index 68% rename from src/ao_many_one_e_ints/grad2_jmu_manu.irp.f rename to plugins/local/ao_many_one_e_ints/grad2_jmu_manu.irp.f index 14170ede..5879d83f 100644 --- a/src/ao_many_one_e_ints/grad2_jmu_manu.irp.f +++ b/plugins/local/ao_many_one_e_ints/grad2_jmu_manu.irp.f @@ -1,11 +1,11 @@ ! --- -BEGIN_PROVIDER [ double precision, int2_grad1u2_grad2u2_j1b2_test, (ao_num, ao_num, n_points_final_grid)] +BEGIN_PROVIDER [double precision, int2_grad1u2_grad2u2_env2_test, (ao_num, ao_num, n_points_final_grid)] BEGIN_DOC ! - ! -\frac{1}{4} x int dr2 phi_i(r2) phi_j(r2) 1s_j1b(r2)^2 [1 - erf(mu r12)]^2 + ! -\frac{1}{4} x int dr2 phi_i(r2) phi_j(r2) 1s_env(r2)^2 [1 - erf(mu r12)]^2 ! END_DOC @@ -15,30 +15,30 @@ BEGIN_PROVIDER [ double precision, int2_grad1u2_grad2u2_j1b2_test, (ao_num, ao_n double precision :: coef, beta, B_center(3) double precision :: tmp double precision :: wall0, wall1 - double precision :: int_gauss, dsqpi_3_2, int_j1b + double precision :: int_gauss, dsqpi_3_2, int_env double precision :: factor_ij_1s, beta_ij, center_ij_1s(3), sq_pi_3_2 double precision, allocatable :: int_fit_v(:) double precision, external :: overlap_gauss_r12_ao double precision, external :: overlap_gauss_r12_ao_with1s - print*, ' providing int2_grad1u2_grad2u2_j1b2_test ...' + print*, ' providing int2_grad1u2_grad2u2_env2_test ...' sq_pi_3_2 = (dacos(-1.d0))**(1.5d0) - provide mu_erf final_grid_points_transp j1b_pen List_comb_thr_b3_coef + provide mu_erf final_grid_points_transp List_comb_thr_b3_coef call wall_time(wall0) - int2_grad1u2_grad2u2_j1b2_test(:,:,:) = 0.d0 + int2_grad1u2_grad2u2_env2_test(:,:,:) = 0.d0 - !$OMP PARALLEL DEFAULT (NONE) & - !$OMP PRIVATE (ipoint, i, j, i_1s, i_fit, r, coef, beta, B_center, & - !$OMP coef_fit, expo_fit, int_fit_v, tmp,int_gauss,int_j1b,factor_ij_1s,beta_ij,center_ij_1s) & - !$OMP SHARED (n_points_final_grid, ao_num, final_grid_points,List_comb_thr_b3_size, & - !$OMP final_grid_points_transp, ng_fit_jast, & - !$OMP expo_gauss_1_erf_x_2, coef_gauss_1_erf_x_2, & - !$OMP List_comb_thr_b3_coef, List_comb_thr_b3_expo, & - !$OMP List_comb_thr_b3_cent, int2_grad1u2_grad2u2_j1b2_test, ao_abs_comb_b3_j1b, & - !$OMP ao_overlap_abs,sq_pi_3_2,thrsh_cycle_tc) + !$OMP PARALLEL DEFAULT (NONE) & + !$OMP PRIVATE (ipoint, i, j, i_1s, i_fit, r, coef, beta, B_center, & + !$OMP coef_fit, expo_fit, int_fit_v, tmp,int_gauss,int_env,factor_ij_1s,beta_ij,center_ij_1s) & + !$OMP SHARED (n_points_final_grid, ao_num, final_grid_points,List_comb_thr_b3_size, & + !$OMP final_grid_points_transp, ng_fit_jast, & + !$OMP expo_gauss_1_erf_x_2, coef_gauss_1_erf_x_2, & + !$OMP List_comb_thr_b3_coef, List_comb_thr_b3_expo, & + !$OMP List_comb_thr_b3_cent, int2_grad1u2_grad2u2_env2_test, ao_abs_comb_b3_env, & + !$OMP ao_overlap_abs,sq_pi_3_2,thrsh_cycle_tc) !$OMP DO SCHEDULE(dynamic) do ipoint = 1, n_points_final_grid r(1) = final_grid_points(1,ipoint) @@ -54,13 +54,13 @@ BEGIN_PROVIDER [ double precision, int2_grad1u2_grad2u2_j1b2_test, (ao_num, ao_n ! i_1s = 1 ! --- --- --- - int_j1b = ao_abs_comb_b3_j1b(1,j,i) + int_env = ao_abs_comb_b3_env(1,j,i) do i_fit = 1, ng_fit_jast expo_fit = expo_gauss_1_erf_x_2(i_fit) coef_fit = -0.25d0 * coef_gauss_1_erf_x_2(i_fit) -! if(dabs(coef_fit*int_j1b*sq_pi_3_2*(expo_fit)**(-1.5d0)).lt.thrsh_cycle_tc)cycle +! if(dabs(coef_fit*int_env*sq_pi_3_2*(expo_fit)**(-1.5d0)).lt.thrsh_cycle_tc)cycle int_gauss = overlap_gauss_r12_ao(r, expo_fit, i, j) - int2_grad1u2_grad2u2_j1b2_test(j,i,ipoint) += coef_fit * int_gauss + int2_grad1u2_grad2u2_env2_test(j,i,ipoint) += coef_fit * int_gauss enddo ! --- --- --- @@ -71,7 +71,7 @@ BEGIN_PROVIDER [ double precision, int2_grad1u2_grad2u2_j1b2_test, (ao_num, ao_n coef = List_comb_thr_b3_coef (i_1s,j,i) beta = List_comb_thr_b3_expo (i_1s,j,i) - int_j1b = ao_abs_comb_b3_j1b(i_1s,j,i) + int_env = ao_abs_comb_b3_env(i_1s,j,i) B_center(1) = List_comb_thr_b3_cent(1,i_1s,j,i) B_center(2) = List_comb_thr_b3_cent(2,i_1s,j,i) B_center(3) = List_comb_thr_b3_cent(3,i_1s,j,i) @@ -81,11 +81,11 @@ BEGIN_PROVIDER [ double precision, int2_grad1u2_grad2u2_j1b2_test, (ao_num, ao_n !DIR$ FORCEINLINE call gaussian_product(expo_fit,r,beta,B_center,factor_ij_1s,beta_ij,center_ij_1s) coef_fit = -0.25d0 * coef_gauss_1_erf_x_2(i_fit) * coef -! if(dabs(coef_fit*factor_ij_1s*int_j1b*sq_pi_3_2*(beta_ij)**(-1.5d0)).lt.thrsh_cycle_tc)cycle +! if(dabs(coef_fit*factor_ij_1s*int_env*sq_pi_3_2*(beta_ij)**(-1.5d0)).lt.thrsh_cycle_tc)cycle ! call overlap_gauss_r12_ao_with1s_v(B_center, beta, final_grid_points_transp, & ! expo_fit, i, j, int_fit_v, n_points_final_grid) int_gauss = overlap_gauss_r12_ao_with1s(B_center, beta, r, expo_fit, i, j) - int2_grad1u2_grad2u2_j1b2_test(j,i,ipoint) += coef_fit * int_gauss + int2_grad1u2_grad2u2_env2_test(j,i,ipoint) += coef_fit * int_gauss enddo enddo @@ -98,26 +98,26 @@ BEGIN_PROVIDER [ double precision, int2_grad1u2_grad2u2_j1b2_test, (ao_num, ao_n do ipoint = 1, n_points_final_grid do i = 1, ao_num do j = 1, i-1 - int2_grad1u2_grad2u2_j1b2_test(j,i,ipoint) = int2_grad1u2_grad2u2_j1b2_test(i,j,ipoint) + int2_grad1u2_grad2u2_env2_test(j,i,ipoint) = int2_grad1u2_grad2u2_env2_test(i,j,ipoint) enddo enddo enddo call wall_time(wall1) - print*, ' wall time for int2_grad1u2_grad2u2_j1b2_test', wall1 - wall0 + print*, ' wall time for int2_grad1u2_grad2u2_env2_test (min) = ', (wall1 - wall0) / 60.d0 END_PROVIDER ! --- -BEGIN_PROVIDER [ double precision, int2_grad1u2_grad2u2_j1b2_test_v, (ao_num, ao_num, n_points_final_grid)] -! -! BEGIN_DOC -! ! -! ! -\frac{1}{4} x int dr2 phi_i(r2) phi_j(r2) 1s_j1b(r2)^2 [1 - erf(mu r12)]^2 -! ! -! END_DOC -! +BEGIN_PROVIDER [double precision, int2_grad1u2_grad2u2_env2_test_v, (ao_num, ao_num, n_points_final_grid)] + + BEGIN_DOC + ! + ! -\frac{1}{4} x int dr2 phi_i(r2) phi_j(r2) 1s_env(r2)^2 [1 - erf(mu r12)]^2 + ! + END_DOC + implicit none integer :: i, j, ipoint, i_1s, i_fit double precision :: r(3), expo_fit, coef_fit @@ -128,24 +128,24 @@ BEGIN_PROVIDER [ double precision, int2_grad1u2_grad2u2_j1b2_test_v, (ao_num, ao double precision, allocatable :: int_fit_v(:),big_array(:,:,:) double precision, external :: overlap_gauss_r12_ao_with1s - print*, ' providing int2_grad1u2_grad2u2_j1b2_test_v ...' + print*, ' providing int2_grad1u2_grad2u2_env2_test_v ...' - provide mu_erf final_grid_points_transp j1b_pen + provide mu_erf final_grid_points_transp call wall_time(wall0) - double precision :: int_j1b + double precision :: int_env big_array(:,:,:) = 0.d0 allocate(big_array(n_points_final_grid,ao_num, ao_num)) !$OMP PARALLEL DEFAULT (NONE) & - !$OMP PRIVATE (ipoint, i, j, i_1s, i_fit, r, coef, beta, B_center,& - !$OMP coef_fit, expo_fit, int_fit_v, tmp,int_j1b) & - !$OMP SHARED (n_points_final_grid, ao_num, List_comb_thr_b3_size,& - !$OMP final_grid_points_transp, ng_fit_jast, & - !$OMP expo_gauss_1_erf_x_2, coef_gauss_1_erf_x_2, & - !$OMP List_comb_thr_b3_coef, List_comb_thr_b3_expo, & - !$OMP List_comb_thr_b3_cent, big_array,& - !$OMP ao_abs_comb_b3_j1b,ao_overlap_abs,thrsh_cycle_tc) -! + !$OMP PRIVATE (ipoint, i, j, i_1s, i_fit, r, coef, beta, B_center,& + !$OMP coef_fit, expo_fit, int_fit_v, tmp,int_env) & + !$OMP SHARED (n_points_final_grid, ao_num, List_comb_thr_b3_size,& + !$OMP final_grid_points_transp, ng_fit_jast, & + !$OMP expo_gauss_1_erf_x_2, coef_gauss_1_erf_x_2, & + !$OMP List_comb_thr_b3_coef, List_comb_thr_b3_expo, & + !$OMP List_comb_thr_b3_cent, big_array,& + !$OMP ao_abs_comb_b3_env,ao_overlap_abs,thrsh_cycle_tc) + ! allocate(int_fit_v(n_points_final_grid)) !$OMP DO SCHEDULE(dynamic) do i = 1, ao_num @@ -159,7 +159,7 @@ BEGIN_PROVIDER [ double precision, int2_grad1u2_grad2u2_j1b2_test_v, (ao_num, ao coef = List_comb_thr_b3_coef (i_1s,j,i) beta = List_comb_thr_b3_expo (i_1s,j,i) - int_j1b = ao_abs_comb_b3_j1b(i_1s,j,i) + int_env = ao_abs_comb_b3_env(i_1s,j,i) B_center(1) = List_comb_thr_b3_cent(1,i_1s,j,i) B_center(2) = List_comb_thr_b3_cent(2,i_1s,j,i) B_center(3) = List_comb_thr_b3_cent(3,i_1s,j,i) @@ -187,7 +187,7 @@ BEGIN_PROVIDER [ double precision, int2_grad1u2_grad2u2_j1b2_test_v, (ao_num, ao do i = 1, ao_num do j = i, ao_num do ipoint = 1, n_points_final_grid - int2_grad1u2_grad2u2_j1b2_test_v(j,i,ipoint) = big_array(ipoint,j,i) + int2_grad1u2_grad2u2_env2_test_v(j,i,ipoint) = big_array(ipoint,j,i) enddo enddo enddo @@ -195,23 +195,23 @@ BEGIN_PROVIDER [ double precision, int2_grad1u2_grad2u2_j1b2_test_v, (ao_num, ao do ipoint = 1, n_points_final_grid do i = 2, ao_num do j = 1, i-1 - int2_grad1u2_grad2u2_j1b2_test_v(j,i,ipoint) = big_array(ipoint,i,j) + int2_grad1u2_grad2u2_env2_test_v(j,i,ipoint) = big_array(ipoint,i,j) enddo enddo enddo call wall_time(wall1) - print*, ' wall time for int2_grad1u2_grad2u2_j1b2_test_v', wall1 - wall0 + print*, ' wall time for int2_grad1u2_grad2u2_env2_test_v (min) = ', (wall1 - wall0) / 60.d0 END_PROVIDER ! --- -BEGIN_PROVIDER [ double precision, int2_u2_j1b2_test, (ao_num, ao_num, n_points_final_grid)] +BEGIN_PROVIDER [double precision, int2_u2_env2_test, (ao_num, ao_num, n_points_final_grid)] BEGIN_DOC ! - ! int dr2 phi_i(r2) phi_j(r2) 1s_j1b(r2)^2 [u_12^mu]^2 + ! int dr2 phi_i(r2) phi_j(r2) 1s_env(r2)^2 [u_12^mu]^2 ! END_DOC @@ -219,29 +219,29 @@ BEGIN_PROVIDER [ double precision, int2_u2_j1b2_test, (ao_num, ao_num, n_points_ integer :: i, j, ipoint, i_1s, i_fit double precision :: r(3), int_fit, expo_fit, coef_fit double precision :: coef, beta, B_center(3), tmp - double precision :: wall0, wall1,int_j1b + double precision :: wall0, wall1,int_env double precision, external :: overlap_gauss_r12_ao double precision, external :: overlap_gauss_r12_ao_with1s double precision :: factor_ij_1s,beta_ij,center_ij_1s(3),sq_pi_3_2 - print*, ' providing int2_u2_j1b2_test ...' + print*, ' providing int2_u2_env2_test ...' sq_pi_3_2 = (dacos(-1.d0))**(1.5d0) - provide mu_erf final_grid_points j1b_pen + provide mu_erf final_grid_points call wall_time(wall0) - int2_u2_j1b2_test = 0.d0 + int2_u2_env2_test = 0.d0 !$OMP PARALLEL DEFAULT (NONE) & !$OMP PRIVATE (ipoint, i, j, i_1s, i_fit, r, coef, beta, B_center, & - !$OMP coef_fit, expo_fit, int_fit, tmp, int_j1b,factor_ij_1s,beta_ij,center_ij_1s) & + !$OMP coef_fit, expo_fit, int_fit, tmp, int_env,factor_ij_1s,beta_ij,center_ij_1s) & !$OMP SHARED (n_points_final_grid, ao_num, List_comb_thr_b3_size, & !$OMP final_grid_points, ng_fit_jast, & !$OMP expo_gauss_j_mu_x_2, coef_gauss_j_mu_x_2, & !$OMP List_comb_thr_b3_coef, List_comb_thr_b3_expo,sq_pi_3_2, & - !$OMP List_comb_thr_b3_cent, int2_u2_j1b2_test,ao_abs_comb_b3_j1b,thrsh_cycle_tc) + !$OMP List_comb_thr_b3_cent, int2_u2_env2_test,ao_abs_comb_b3_env,thrsh_cycle_tc) !$OMP DO do ipoint = 1, n_points_final_grid r(1) = final_grid_points(1,ipoint) @@ -257,12 +257,12 @@ BEGIN_PROVIDER [ double precision, int2_u2_j1b2_test, (ao_num, ao_num, n_points_ ! i_1s = 1 ! --- --- --- - int_j1b = ao_abs_comb_b3_j1b(1,j,i) - if(dabs(int_j1b).lt.thrsh_cycle_tc) cycle + int_env = ao_abs_comb_b3_env(1,j,i) + if(dabs(int_env).lt.thrsh_cycle_tc) cycle do i_fit = 1, ng_fit_jast expo_fit = expo_gauss_j_mu_x_2(i_fit) coef_fit = coef_gauss_j_mu_x_2(i_fit) -! if(dabs(coef_fit*int_j1b*sq_pi_3_2*(expo_fit)**(-1.5d0)).lt.thrsh_cycle_tc)cycle +! if(dabs(coef_fit*int_env*sq_pi_3_2*(expo_fit)**(-1.5d0)).lt.thrsh_cycle_tc)cycle int_fit = overlap_gauss_r12_ao(r, expo_fit, i, j) tmp += coef_fit * int_fit enddo @@ -275,8 +275,8 @@ BEGIN_PROVIDER [ double precision, int2_u2_j1b2_test, (ao_num, ao_num, n_points_ coef = List_comb_thr_b3_coef (i_1s,j,i) beta = List_comb_thr_b3_expo (i_1s,j,i) - int_j1b = ao_abs_comb_b3_j1b(i_1s,j,i) -! if(dabs(coef)*dabs(int_j1b).lt.thrsh_cycle_tc)cycle + int_env = ao_abs_comb_b3_env(i_1s,j,i) +! if(dabs(coef)*dabs(int_env).lt.thrsh_cycle_tc)cycle B_center(1) = List_comb_thr_b3_cent(1,i_1s,j,i) B_center(2) = List_comb_thr_b3_cent(2,i_1s,j,i) B_center(3) = List_comb_thr_b3_cent(3,i_1s,j,i) @@ -286,13 +286,13 @@ BEGIN_PROVIDER [ double precision, int2_u2_j1b2_test, (ao_num, ao_num, n_points_ coef_fit = coef_gauss_j_mu_x_2(i_fit) !DIR$ FORCEINLINE call gaussian_product(expo_fit,r,beta,B_center,factor_ij_1s,beta_ij,center_ij_1s) -! if(dabs(coef_fit*coef*factor_ij_1s*int_j1b*sq_pi_3_2*(beta_ij)**(-1.5d0)).lt.thrsh_cycle_tc)cycle +! if(dabs(coef_fit*coef*factor_ij_1s*int_env*sq_pi_3_2*(beta_ij)**(-1.5d0)).lt.thrsh_cycle_tc)cycle int_fit = overlap_gauss_r12_ao_with1s(B_center, beta, r, expo_fit, i, j) tmp += coef * coef_fit * int_fit enddo enddo - int2_u2_j1b2_test(j,i,ipoint) = tmp + int2_u2_env2_test(j,i,ipoint) = tmp enddo enddo enddo @@ -302,23 +302,23 @@ BEGIN_PROVIDER [ double precision, int2_u2_j1b2_test, (ao_num, ao_num, n_points_ do ipoint = 1, n_points_final_grid do i = 2, ao_num do j = 1, i-1 - int2_u2_j1b2_test(j,i,ipoint) = int2_u2_j1b2_test(i,j,ipoint) + int2_u2_env2_test(j,i,ipoint) = int2_u2_env2_test(i,j,ipoint) enddo enddo enddo call wall_time(wall1) - print*, ' wall time for int2_u2_j1b2_test', wall1 - wall0 + print*, ' wall time for int2_u2_env2_test (min) = ', (wall1 - wall0) / 60.d0 END_PROVIDER ! --- -BEGIN_PROVIDER [ double precision, int2_u_grad1u_x_j1b2_test, (ao_num, ao_num, n_points_final_grid, 3)] +BEGIN_PROVIDER [double precision, int2_u_grad1u_x_env2_test, (ao_num,ao_num,n_points_final_grid,3)] BEGIN_DOC ! - ! int dr2 phi_i(r2) phi_j(r2) 1s_j1b(r2)^2 u_12^mu [\grad_1 u_12^mu] r2 + ! int dr2 phi_i(r2) phi_j(r2) 1s_env(r2)^2 u_12^mu [\grad_1 u_12^mu] r2 ! END_DOC @@ -327,27 +327,27 @@ BEGIN_PROVIDER [ double precision, int2_u_grad1u_x_j1b2_test, (ao_num, ao_num, n double precision :: r(3), int_fit(3), expo_fit, coef_fit double precision :: coef, beta, B_center(3), dist double precision :: alpha_1s, alpha_1s_inv, centr_1s(3), expo_coef_1s, coef_tmp - double precision :: tmp_x, tmp_y, tmp_z, int_j1b + double precision :: tmp_x, tmp_y, tmp_z, int_env double precision :: wall0, wall1, sq_pi_3_2,sq_alpha - print*, ' providing int2_u_grad1u_x_j1b2_test ...' + print*, ' providing int2_u_grad1u_x_env2_test ...' sq_pi_3_2 = dacos(-1.D0)**(1.d0) - provide mu_erf final_grid_points j1b_pen + provide mu_erf final_grid_points call wall_time(wall0) - int2_u_grad1u_x_j1b2_test = 0.d0 + int2_u_grad1u_x_env2_test = 0.d0 !$OMP PARALLEL DEFAULT (NONE) & !$OMP PRIVATE (ipoint, i, j, i_1s, i_fit, r, coef, beta, B_center, & !$OMP coef_fit, expo_fit, int_fit, alpha_1s, dist, & !$OMP alpha_1s_inv, centr_1s, expo_coef_1s, coef_tmp, & - !$OMP tmp_x, tmp_y, tmp_z,int_j1b,sq_alpha) & + !$OMP tmp_x, tmp_y, tmp_z,int_env,sq_alpha) & !$OMP SHARED (n_points_final_grid, ao_num, List_comb_thr_b3_size, & !$OMP final_grid_points, ng_fit_jast, & !$OMP expo_gauss_j_mu_1_erf, coef_gauss_j_mu_1_erf, & !$OMP List_comb_thr_b3_coef, List_comb_thr_b3_expo, & - !$OMP List_comb_thr_b3_cent, int2_u_grad1u_x_j1b2_test,ao_abs_comb_b3_j1b,sq_pi_3_2,thrsh_cycle_tc) + !$OMP List_comb_thr_b3_cent, int2_u_grad1u_x_env2_test,ao_abs_comb_b3_env,sq_pi_3_2,thrsh_cycle_tc) !$OMP DO do ipoint = 1, n_points_final_grid @@ -365,8 +365,8 @@ BEGIN_PROVIDER [ double precision, int2_u_grad1u_x_j1b2_test, (ao_num, ao_num, n coef = List_comb_thr_b3_coef (i_1s,j,i) beta = List_comb_thr_b3_expo (i_1s,j,i) - int_j1b = ao_abs_comb_b3_j1b(i_1s,j,i) - if(dabs(coef)*dabs(int_j1b).lt.thrsh_cycle_tc)cycle + int_env = ao_abs_comb_b3_env(i_1s,j,i) + if(dabs(coef)*dabs(int_env).lt.thrsh_cycle_tc)cycle B_center(1) = List_comb_thr_b3_cent(1,i_1s,j,i) B_center(2) = List_comb_thr_b3_cent(2,i_1s,j,i) B_center(3) = List_comb_thr_b3_cent(3,i_1s,j,i) @@ -389,7 +389,7 @@ BEGIN_PROVIDER [ double precision, int2_u_grad1u_x_j1b2_test, (ao_num, ao_num, n expo_coef_1s = beta * expo_fit * alpha_1s_inv * dist coef_tmp = coef * coef_fit * dexp(-expo_coef_1s) sq_alpha = alpha_1s_inv * dsqrt(alpha_1s_inv) -! if(dabs(coef_tmp*int_j1b*sq_pi_3_2*sq_alpha) .lt. thrsh_cycle_tc) cycle +! if(dabs(coef_tmp*int_env*sq_pi_3_2*sq_alpha) .lt. thrsh_cycle_tc) cycle call NAI_pol_x_mult_erf_ao_with1s(i, j, alpha_1s, centr_1s, 1.d+9, r, int_fit) @@ -402,9 +402,9 @@ BEGIN_PROVIDER [ double precision, int2_u_grad1u_x_j1b2_test, (ao_num, ao_num, n enddo - int2_u_grad1u_x_j1b2_test(j,i,ipoint,1) = tmp_x - int2_u_grad1u_x_j1b2_test(j,i,ipoint,2) = tmp_y - int2_u_grad1u_x_j1b2_test(j,i,ipoint,3) = tmp_z + int2_u_grad1u_x_env2_test(j,i,ipoint,1) = tmp_x + int2_u_grad1u_x_env2_test(j,i,ipoint,2) = tmp_y + int2_u_grad1u_x_env2_test(j,i,ipoint,3) = tmp_z enddo enddo enddo @@ -414,24 +414,25 @@ BEGIN_PROVIDER [ double precision, int2_u_grad1u_x_j1b2_test, (ao_num, ao_num, n do ipoint = 1, n_points_final_grid do i = 2, ao_num do j = 1, i-1 - int2_u_grad1u_x_j1b2_test(j,i,ipoint,1) = int2_u_grad1u_x_j1b2_test(i,j,ipoint,1) - int2_u_grad1u_x_j1b2_test(j,i,ipoint,2) = int2_u_grad1u_x_j1b2_test(i,j,ipoint,2) - int2_u_grad1u_x_j1b2_test(j,i,ipoint,3) = int2_u_grad1u_x_j1b2_test(i,j,ipoint,3) + int2_u_grad1u_x_env2_test(j,i,ipoint,1) = int2_u_grad1u_x_env2_test(i,j,ipoint,1) + int2_u_grad1u_x_env2_test(j,i,ipoint,2) = int2_u_grad1u_x_env2_test(i,j,ipoint,2) + int2_u_grad1u_x_env2_test(j,i,ipoint,3) = int2_u_grad1u_x_env2_test(i,j,ipoint,3) enddo enddo enddo call wall_time(wall1) - print*, ' wall time for int2_u_grad1u_x_j1b2_test', wall1 - wall0 + print*, ' wall time for int2_u_grad1u_x_env2_test (min) = ', (wall1 - wall0) / 60.d0 END_PROVIDER +! --- -BEGIN_PROVIDER [ double precision, int2_u_grad1u_j1b2_test, (ao_num, ao_num, n_points_final_grid)] +BEGIN_PROVIDER [double precision, int2_u_grad1u_env2_test, (ao_num, ao_num, n_points_final_grid)] BEGIN_DOC ! - ! int dr2 phi_i(r2) phi_j(r2) 1s_j1b(r2)^2 u_12^mu [\grad_1 u_12^mu] + ! int dr2 phi_i(r2) phi_j(r2) 1s_env(r2)^2 u_12^mu [\grad_1 u_12^mu] ! END_DOC @@ -442,31 +443,31 @@ BEGIN_PROVIDER [ double precision, int2_u_grad1u_j1b2_test, (ao_num, ao_num, n_p double precision :: alpha_1s, alpha_1s_inv, centr_1s(3), expo_coef_1s, tmp double precision :: wall0, wall1 double precision, external :: NAI_pol_mult_erf_ao_with1s - double precision :: j12_mu_r12,int_j1b + double precision :: j12_mu_r12,int_env double precision :: sigma_ij,dist_ij_ipoint,dsqpi_3_2 double precision :: beta_ij,center_ij_1s(3),factor_ij_1s - print*, ' providing int2_u_grad1u_j1b2_test ...' + print*, ' providing int2_u_grad1u_env2_test ...' dsqpi_3_2 = (dacos(-1.d0))**(1.5d0) - provide mu_erf final_grid_points j1b_pen ao_overlap_abs List_comb_thr_b3_cent + provide mu_erf final_grid_points ao_overlap_abs List_comb_thr_b3_cent call wall_time(wall0) - int2_u_grad1u_j1b2_test = 0.d0 + int2_u_grad1u_env2_test = 0.d0 !$OMP PARALLEL DEFAULT (NONE) & !$OMP PRIVATE (ipoint, i, j, i_1s, i_fit, r, coef, beta, B_center, & !$OMP coef_fit, expo_fit, int_fit, tmp, alpha_1s, dist, & !$OMP beta_ij,center_ij_1s,factor_ij_1s, & - !$OMP int_j1b,alpha_1s_inv, centr_1s, expo_coef_1s, coef_tmp) & + !$OMP int_env,alpha_1s_inv, centr_1s, expo_coef_1s, coef_tmp) & !$OMP SHARED (n_points_final_grid, ao_num, List_comb_thr_b3_size, & !$OMP final_grid_points, ng_fit_jast, & !$OMP expo_gauss_j_mu_1_erf, coef_gauss_j_mu_1_erf, & !$OMP ao_prod_dist_grid, ao_prod_sigma, ao_overlap_abs_grid,ao_prod_center,dsqpi_3_2, & - !$OMP List_comb_thr_b3_coef, List_comb_thr_b3_expo, ao_abs_comb_b3_j1b, & - !$OMP List_comb_thr_b3_cent, int2_u_grad1u_j1b2_test,thrsh_cycle_tc) + !$OMP List_comb_thr_b3_coef, List_comb_thr_b3_expo, ao_abs_comb_b3_env, & + !$OMP List_comb_thr_b3_cent, int2_u_grad1u_env2_test,thrsh_cycle_tc) !$OMP DO do ipoint = 1, n_points_final_grid do i = 1, ao_num @@ -484,11 +485,9 @@ BEGIN_PROVIDER [ double precision, int2_u_grad1u_j1b2_test, (ao_num, ao_num, n_p ! i_1s = 1 ! --- --- --- - int_j1b = ao_abs_comb_b3_j1b(1,j,i) -! if(dabs(int_j1b).lt.thrsh_cycle_tc) cycle + int_env = ao_abs_comb_b3_env(1,j,i) do i_fit = 1, ng_fit_jast expo_fit = expo_gauss_j_mu_1_erf(i_fit) -! if(dabs(int_j1b)*dsqpi_3_2*expo_fit**(-1.5d0).lt.thrsh_cycle_tc) cycle coef_fit = coef_gauss_j_mu_1_erf(i_fit) int_fit = NAI_pol_mult_erf_ao_with1s(i, j, expo_fit, r, 1.d+9, r) tmp += coef_fit * int_fit @@ -502,8 +501,7 @@ BEGIN_PROVIDER [ double precision, int2_u_grad1u_j1b2_test, (ao_num, ao_num, n_p coef = List_comb_thr_b3_coef (i_1s,j,i) beta = List_comb_thr_b3_expo (i_1s,j,i) - int_j1b = ao_abs_comb_b3_j1b(i_1s,j,i) -! if(dabs(coef)*dabs(int_j1b).lt.thrsh_cycle_tc)cycle + int_env = ao_abs_comb_b3_env(i_1s,j,i) B_center(1) = List_comb_thr_b3_cent(1,i_1s,j,i) B_center(2) = List_comb_thr_b3_cent(2,i_1s,j,i) B_center(3) = List_comb_thr_b3_cent(3,i_1s,j,i) @@ -513,7 +511,6 @@ BEGIN_PROVIDER [ double precision, int2_u_grad1u_j1b2_test, (ao_num, ao_num, n_p do i_fit = 1, ng_fit_jast expo_fit = expo_gauss_j_mu_1_erf(i_fit) call gaussian_product(expo_fit,r,beta,B_center,factor_ij_1s,beta_ij,center_ij_1s) -! if(factor_ij_1s*dabs(coef*int_j1b)*dsqpi_3_2*beta_ij**(-1.5d0).lt.thrsh_cycle_tc)cycle coef_fit = coef_gauss_j_mu_1_erf(i_fit) alpha_1s = beta + expo_fit @@ -533,7 +530,7 @@ BEGIN_PROVIDER [ double precision, int2_u_grad1u_j1b2_test, (ao_num, ao_num, n_p enddo enddo - int2_u_grad1u_j1b2_test(j,i,ipoint) = tmp + int2_u_grad1u_env2_test(j,i,ipoint) = tmp enddo enddo enddo @@ -543,14 +540,15 @@ BEGIN_PROVIDER [ double precision, int2_u_grad1u_j1b2_test, (ao_num, ao_num, n_p do ipoint = 1, n_points_final_grid do i = 2, ao_num do j = 1, i-1 - int2_u_grad1u_j1b2_test(j,i,ipoint) = int2_u_grad1u_j1b2_test(i,j,ipoint) + int2_u_grad1u_env2_test(j,i,ipoint) = int2_u_grad1u_env2_test(i,j,ipoint) enddo enddo enddo call wall_time(wall1) - print*, ' wall time for int2_u_grad1u_j1b2_test', wall1 - wall0 + print*, ' wall time for int2_u_grad1u_env2_test (min) = ', (wall1 - wall0) / 60.d0 END_PROVIDER ! --- + diff --git a/src/ao_many_one_e_ints/grad2_jmu_modif.irp.f b/plugins/local/ao_many_one_e_ints/grad2_jmu_modif.irp.f similarity index 70% rename from src/ao_many_one_e_ints/grad2_jmu_modif.irp.f rename to plugins/local/ao_many_one_e_ints/grad2_jmu_modif.irp.f index fda2db82..bdcaac9d 100644 --- a/src/ao_many_one_e_ints/grad2_jmu_modif.irp.f +++ b/plugins/local/ao_many_one_e_ints/grad2_jmu_modif.irp.f @@ -6,7 +6,7 @@ BEGIN_PROVIDER [ double precision, int2_grad1u2_grad2u2, (ao_num, ao_num, n_poin BEGIN_DOC ! - ! -\frac{1}{4} x int dr2 phi_i(r2) phi_j(r2) [1 - erf(mu r12)]^2 + ! \frac{1}{4} x int dr2 phi_i(r2) phi_j(r2) [1 - erf(mu r12)]^2 ! END_DOC @@ -21,7 +21,8 @@ BEGIN_PROVIDER [ double precision, int2_grad1u2_grad2u2, (ao_num, ao_num, n_poin print*, ' providing int2_grad1u2_grad2u2 ...' call wall_time(wall0) - provide mu_erf final_grid_points j1b_pen + provide mu_erf + provide final_grid_points int2_grad1u2_grad2u2 = 0.d0 @@ -44,7 +45,7 @@ BEGIN_PROVIDER [ double precision, int2_grad1u2_grad2u2, (ao_num, ao_num, n_poin expo_fit = expo_gauss_1_erf_x_2(i_fit) coef_fit = coef_gauss_1_erf_x_2(i_fit) - tmp += -0.25d0 * coef_fit * overlap_gauss_r12_ao(r, expo_fit, i, j) + tmp += 0.25d0 * coef_fit * overlap_gauss_r12_ao(r, expo_fit, i, j) enddo int2_grad1u2_grad2u2(j,i,ipoint) = tmp @@ -63,17 +64,17 @@ BEGIN_PROVIDER [ double precision, int2_grad1u2_grad2u2, (ao_num, ao_num, n_poin enddo call wall_time(wall1) - print*, ' wall time for int2_grad1u2_grad2u2 =', wall1 - wall0 + print*, ' wall time for int2_grad1u2_grad2u2 (min) = ', (wall1 - wall0) / 60.d0 END_PROVIDER ! --- -BEGIN_PROVIDER [ double precision, int2_grad1u2_grad2u2_j1b2, (ao_num, ao_num, n_points_final_grid)] +BEGIN_PROVIDER [double precision, int2_grad1u2_grad2u2_env2, (ao_num, ao_num, n_points_final_grid)] BEGIN_DOC ! - ! -\frac{1}{4} x int dr2 phi_i(r2) phi_j(r2) 1s_j1b(r2)^2 [1 - erf(mu r12)]^2 + ! -\frac{1}{4} x int dr2 phi_i(r2) phi_j(r2) 1s_env(r2)^2 [1 - erf(mu r12)]^2 ! END_DOC @@ -87,21 +88,22 @@ BEGIN_PROVIDER [ double precision, int2_grad1u2_grad2u2_j1b2, (ao_num, ao_num, n double precision, external :: overlap_gauss_r12_ao double precision, external :: overlap_gauss_r12_ao_with1s - print*, ' providing int2_grad1u2_grad2u2_j1b2 ...' + print*, ' providing int2_grad1u2_grad2u2_env2 ...' call wall_time(wall0) - provide mu_erf final_grid_points j1b_pen + provide mu_erf + provide final_grid_points - int2_grad1u2_grad2u2_j1b2 = 0.d0 + int2_grad1u2_grad2u2_env2 = 0.d0 - !$OMP PARALLEL DEFAULT (NONE) & - !$OMP PRIVATE (ipoint, i, j, i_1s, i_fit, r, coef, beta, B_center, & - !$OMP coef_fit, expo_fit, int_fit, tmp) & - !$OMP SHARED (n_points_final_grid, ao_num, List_all_comb_b3_size, & - !$OMP final_grid_points, ng_fit_jast, & - !$OMP expo_gauss_1_erf_x_2, coef_gauss_1_erf_x_2, & - !$OMP List_all_comb_b3_coef, List_all_comb_b3_expo, & - !$OMP List_all_comb_b3_cent, int2_grad1u2_grad2u2_j1b2) + !$OMP PARALLEL DEFAULT (NONE) & + !$OMP PRIVATE (ipoint, i, j, i_1s, i_fit, r, coef, beta, B_center, & + !$OMP coef_fit, expo_fit, int_fit, tmp) & + !$OMP SHARED (n_points_final_grid, ao_num, List_env1s_square_size, & + !$OMP final_grid_points, ng_fit_jast, & + !$OMP expo_gauss_1_erf_x_2, coef_gauss_1_erf_x_2, & + !$OMP List_env1s_square_coef, List_env1s_square_expo, & + !$OMP List_env1s_square_cent, int2_grad1u2_grad2u2_env2) !$OMP DO do ipoint = 1, n_points_final_grid r(1) = final_grid_points(1,ipoint) @@ -125,14 +127,14 @@ BEGIN_PROVIDER [ double precision, int2_grad1u2_grad2u2_j1b2, (ao_num, ao_num, n ! --- - do i_1s = 2, List_all_comb_b3_size + do i_1s = 2, List_env1s_square_size - coef = List_all_comb_b3_coef (i_1s) + coef = List_env1s_square_coef (i_1s) if(dabs(coef) .lt. 1d-15) cycle ! beta = 0.0 - beta = List_all_comb_b3_expo (i_1s) - B_center(1) = List_all_comb_b3_cent(1,i_1s) - B_center(2) = List_all_comb_b3_cent(2,i_1s) - B_center(3) = List_all_comb_b3_cent(3,i_1s) + beta = List_env1s_square_expo (i_1s) + B_center(1) = List_env1s_square_cent(1,i_1s) + B_center(2) = List_env1s_square_cent(2,i_1s) + B_center(3) = List_env1s_square_cent(3,i_1s) int_fit = overlap_gauss_r12_ao_with1s(B_center, beta, r, expo_fit, i, j) @@ -143,7 +145,7 @@ BEGIN_PROVIDER [ double precision, int2_grad1u2_grad2u2_j1b2, (ao_num, ao_num, n enddo - int2_grad1u2_grad2u2_j1b2(j,i,ipoint) = tmp + int2_grad1u2_grad2u2_env2(j,i,ipoint) = tmp enddo enddo enddo @@ -153,23 +155,23 @@ BEGIN_PROVIDER [ double precision, int2_grad1u2_grad2u2_j1b2, (ao_num, ao_num, n do ipoint = 1, n_points_final_grid do i = 2, ao_num do j = 1, i-1 - int2_grad1u2_grad2u2_j1b2(j,i,ipoint) = int2_grad1u2_grad2u2_j1b2(i,j,ipoint) + int2_grad1u2_grad2u2_env2(j,i,ipoint) = int2_grad1u2_grad2u2_env2(i,j,ipoint) enddo enddo enddo call wall_time(wall1) - print*, ' wall time for int2_grad1u2_grad2u2_j1b2 =', wall1 - wall0 + print*, ' wall time for int2_grad1u2_grad2u2_env2 (min) =', (wall1 - wall0) / 60.d0 END_PROVIDER ! --- -BEGIN_PROVIDER [double precision, int2_u2_j1b2, (ao_num, ao_num, n_points_final_grid)] +BEGIN_PROVIDER [double precision, int2_u2_env2, (ao_num, ao_num, n_points_final_grid)] BEGIN_DOC ! - ! int dr2 phi_i(r2) phi_j(r2) 1s_j1b(r2)^2 [u_12^mu]^2 + ! int dr2 phi_i(r2) phi_j(r2) 1s_env(r2)^2 [u_12^mu]^2 ! END_DOC @@ -182,21 +184,22 @@ BEGIN_PROVIDER [double precision, int2_u2_j1b2, (ao_num, ao_num, n_points_final_ double precision, external :: overlap_gauss_r12_ao double precision, external :: overlap_gauss_r12_ao_with1s - print*, ' providing int2_u2_j1b2 ...' + print*, ' providing int2_u2_env2 ...' call wall_time(wall0) - provide mu_erf final_grid_points j1b_pen + provide mu_erf + provide final_grid_points - int2_u2_j1b2 = 0.d0 + int2_u2_env2 = 0.d0 - !$OMP PARALLEL DEFAULT (NONE) & - !$OMP PRIVATE (ipoint, i, j, i_1s, i_fit, r, coef, beta, B_center, & - !$OMP coef_fit, expo_fit, int_fit, tmp) & - !$OMP SHARED (n_points_final_grid, ao_num, List_all_comb_b3_size, & - !$OMP final_grid_points, ng_fit_jast, & - !$OMP expo_gauss_j_mu_x_2, coef_gauss_j_mu_x_2, & - !$OMP List_all_comb_b3_coef, List_all_comb_b3_expo, & - !$OMP List_all_comb_b3_cent, int2_u2_j1b2) + !$OMP PARALLEL DEFAULT (NONE) & + !$OMP PRIVATE (ipoint, i, j, i_1s, i_fit, r, coef, beta, B_center, & + !$OMP coef_fit, expo_fit, int_fit, tmp) & + !$OMP SHARED (n_points_final_grid, ao_num, List_env1s_square_size, & + !$OMP final_grid_points, ng_fit_jast, & + !$OMP expo_gauss_j_mu_x_2, coef_gauss_j_mu_x_2, & + !$OMP List_env1s_square_coef, List_env1s_square_expo, & + !$OMP List_env1s_square_cent, int2_u2_env2) !$OMP DO do ipoint = 1, n_points_final_grid r(1) = final_grid_points(1,ipoint) @@ -220,14 +223,14 @@ BEGIN_PROVIDER [double precision, int2_u2_j1b2, (ao_num, ao_num, n_points_final_ ! --- - do i_1s = 2, List_all_comb_b3_size + do i_1s = 2, List_env1s_square_size - coef = List_all_comb_b3_coef (i_1s) + coef = List_env1s_square_coef (i_1s) if(dabs(coef) .lt. 1d-15) cycle ! beta = 0.0 - beta = List_all_comb_b3_expo (i_1s) - B_center(1) = List_all_comb_b3_cent(1,i_1s) - B_center(2) = List_all_comb_b3_cent(2,i_1s) - B_center(3) = List_all_comb_b3_cent(3,i_1s) + beta = List_env1s_square_expo (i_1s) + B_center(1) = List_env1s_square_cent(1,i_1s) + B_center(2) = List_env1s_square_cent(2,i_1s) + B_center(3) = List_env1s_square_cent(3,i_1s) int_fit = overlap_gauss_r12_ao_with1s(B_center, beta, r, expo_fit, i, j) @@ -238,7 +241,7 @@ BEGIN_PROVIDER [double precision, int2_u2_j1b2, (ao_num, ao_num, n_points_final_ enddo - int2_u2_j1b2(j,i,ipoint) = tmp + int2_u2_env2(j,i,ipoint) = tmp enddo enddo enddo @@ -248,23 +251,23 @@ BEGIN_PROVIDER [double precision, int2_u2_j1b2, (ao_num, ao_num, n_points_final_ do ipoint = 1, n_points_final_grid do i = 2, ao_num do j = 1, i-1 - int2_u2_j1b2(j,i,ipoint) = int2_u2_j1b2(i,j,ipoint) + int2_u2_env2(j,i,ipoint) = int2_u2_env2(i,j,ipoint) enddo enddo enddo call wall_time(wall1) - print*, ' wall time for int2_u2_j1b2', wall1 - wall0 + print*, ' wall time for int2_u2_env2 (min) = ', (wall1 - wall0) / 60.d0 END_PROVIDER ! --- -BEGIN_PROVIDER [ double precision, int2_u_grad1u_x_j1b2, (ao_num, ao_num, n_points_final_grid, 3)] +BEGIN_PROVIDER [double precision, int2_u_grad1u_x_env2, (ao_num, ao_num, n_points_final_grid, 3)] BEGIN_DOC ! - ! int dr2 phi_i(r2) phi_j(r2) 1s_j1b(r2)^2 u_12^mu [\grad_1 u_12^mu] r2 + ! int dr2 phi_i(r2) phi_j(r2) 1s_env(r2)^2 u_12^mu [\grad_1 u_12^mu] r2 ! END_DOC @@ -276,23 +279,24 @@ BEGIN_PROVIDER [ double precision, int2_u_grad1u_x_j1b2, (ao_num, ao_num, n_poin double precision :: tmp_x, tmp_y, tmp_z double precision :: wall0, wall1 - print*, ' providing int2_u_grad1u_x_j1b2 ...' + print*, ' providing int2_u_grad1u_x_env2 ...' call wall_time(wall0) - provide mu_erf final_grid_points j1b_pen + provide mu_erf + provide final_grid_points - int2_u_grad1u_x_j1b2 = 0.d0 + int2_u_grad1u_x_env2 = 0.d0 - !$OMP PARALLEL DEFAULT (NONE) & - !$OMP PRIVATE (ipoint, i, j, i_1s, i_fit, r, coef, beta, B_center, & - !$OMP coef_fit, expo_fit, int_fit, alpha_1s, dist, & - !$OMP alpha_1s_inv, centr_1s, expo_coef_1s, coef_tmp, & - !$OMP tmp_x, tmp_y, tmp_z) & - !$OMP SHARED (n_points_final_grid, ao_num, List_all_comb_b3_size, & - !$OMP final_grid_points, ng_fit_jast, & - !$OMP expo_gauss_j_mu_1_erf, coef_gauss_j_mu_1_erf, & - !$OMP List_all_comb_b3_coef, List_all_comb_b3_expo, & - !$OMP List_all_comb_b3_cent, int2_u_grad1u_x_j1b2) + !$OMP PARALLEL DEFAULT (NONE) & + !$OMP PRIVATE (ipoint, i, j, i_1s, i_fit, r, coef, beta, B_center, & + !$OMP coef_fit, expo_fit, int_fit, alpha_1s, dist, & + !$OMP alpha_1s_inv, centr_1s, expo_coef_1s, coef_tmp, & + !$OMP tmp_x, tmp_y, tmp_z) & + !$OMP SHARED (n_points_final_grid, ao_num, List_env1s_square_size, & + !$OMP final_grid_points, ng_fit_jast, & + !$OMP expo_gauss_j_mu_1_erf, coef_gauss_j_mu_1_erf, & + !$OMP List_env1s_square_coef, List_env1s_square_expo, & + !$OMP List_env1s_square_cent, int2_u_grad1u_x_env2) !$OMP DO do ipoint = 1, n_points_final_grid @@ -321,14 +325,14 @@ BEGIN_PROVIDER [ double precision, int2_u_grad1u_x_j1b2, (ao_num, ao_num, n_poin ! --- - do i_1s = 2, List_all_comb_b3_size + do i_1s = 2, List_env1s_square_size - coef = List_all_comb_b3_coef (i_1s) + coef = List_env1s_square_coef (i_1s) if(dabs(coef) .lt. 1d-15) cycle ! beta = 0.0 - beta = List_all_comb_b3_expo (i_1s) - B_center(1) = List_all_comb_b3_cent(1,i_1s) - B_center(2) = List_all_comb_b3_cent(2,i_1s) - B_center(3) = List_all_comb_b3_cent(3,i_1s) + beta = List_env1s_square_expo (i_1s) + B_center(1) = List_env1s_square_cent(1,i_1s) + B_center(2) = List_env1s_square_cent(2,i_1s) + B_center(3) = List_env1s_square_cent(3,i_1s) dist = (B_center(1) - r(1)) * (B_center(1) - r(1)) & + (B_center(2) - r(2)) * (B_center(2) - r(2)) & + (B_center(3) - r(3)) * (B_center(3) - r(3)) @@ -355,9 +359,9 @@ BEGIN_PROVIDER [ double precision, int2_u_grad1u_x_j1b2, (ao_num, ao_num, n_poin enddo - int2_u_grad1u_x_j1b2(j,i,ipoint,1) = tmp_x - int2_u_grad1u_x_j1b2(j,i,ipoint,2) = tmp_y - int2_u_grad1u_x_j1b2(j,i,ipoint,3) = tmp_z + int2_u_grad1u_x_env2(j,i,ipoint,1) = tmp_x + int2_u_grad1u_x_env2(j,i,ipoint,2) = tmp_y + int2_u_grad1u_x_env2(j,i,ipoint,3) = tmp_z enddo enddo enddo @@ -367,25 +371,25 @@ BEGIN_PROVIDER [ double precision, int2_u_grad1u_x_j1b2, (ao_num, ao_num, n_poin do ipoint = 1, n_points_final_grid do i = 2, ao_num do j = 1, i-1 - int2_u_grad1u_x_j1b2(j,i,ipoint,1) = int2_u_grad1u_x_j1b2(i,j,ipoint,1) - int2_u_grad1u_x_j1b2(j,i,ipoint,2) = int2_u_grad1u_x_j1b2(i,j,ipoint,2) - int2_u_grad1u_x_j1b2(j,i,ipoint,3) = int2_u_grad1u_x_j1b2(i,j,ipoint,3) + int2_u_grad1u_x_env2(j,i,ipoint,1) = int2_u_grad1u_x_env2(i,j,ipoint,1) + int2_u_grad1u_x_env2(j,i,ipoint,2) = int2_u_grad1u_x_env2(i,j,ipoint,2) + int2_u_grad1u_x_env2(j,i,ipoint,3) = int2_u_grad1u_x_env2(i,j,ipoint,3) enddo enddo enddo call wall_time(wall1) - print*, ' wall time for int2_u_grad1u_x_j1b2 = ', wall1 - wall0 + print*, ' wall time for int2_u_grad1u_x_env2 (min) = ', (wall1 - wall0) / 60.d0 END_PROVIDER ! --- -BEGIN_PROVIDER [ double precision, int2_u_grad1u_j1b2, (ao_num, ao_num, n_points_final_grid)] +BEGIN_PROVIDER [ double precision, int2_u_grad1u_env2, (ao_num, ao_num, n_points_final_grid)] BEGIN_DOC ! - ! int dr2 phi_i(r2) phi_j(r2) 1s_j1b(r2)^2 u_12^mu [\grad_1 u_12^mu] + ! int dr2 phi_i(r2) phi_j(r2) 1s_env(r2)^2 u_12^mu [\grad_1 u_12^mu] ! END_DOC @@ -397,22 +401,23 @@ BEGIN_PROVIDER [ double precision, int2_u_grad1u_j1b2, (ao_num, ao_num, n_points double precision :: wall0, wall1 double precision, external :: NAI_pol_mult_erf_ao_with1s - print*, ' providing int2_u_grad1u_j1b2 ...' + print*, ' providing int2_u_grad1u_env2 ...' call wall_time(wall0) - provide mu_erf final_grid_points j1b_pen + provide mu_erf + provide final_grid_points - int2_u_grad1u_j1b2 = 0.d0 + int2_u_grad1u_env2 = 0.d0 - !$OMP PARALLEL DEFAULT (NONE) & - !$OMP PRIVATE (ipoint, i, j, i_1s, i_fit, r, coef, beta, B_center, & - !$OMP coef_fit, expo_fit, int_fit, tmp, alpha_1s, dist, & - !$OMP alpha_1s_inv, centr_1s, expo_coef_1s, coef_tmp) & - !$OMP SHARED (n_points_final_grid, ao_num, List_all_comb_b3_size, & - !$OMP final_grid_points, ng_fit_jast, & - !$OMP expo_gauss_j_mu_1_erf, coef_gauss_j_mu_1_erf, & - !$OMP List_all_comb_b3_coef, List_all_comb_b3_expo, & - !$OMP List_all_comb_b3_cent, int2_u_grad1u_j1b2) + !$OMP PARALLEL DEFAULT (NONE) & + !$OMP PRIVATE (ipoint, i, j, i_1s, i_fit, r, coef, beta, B_center, & + !$OMP coef_fit, expo_fit, int_fit, tmp, alpha_1s, dist, & + !$OMP alpha_1s_inv, centr_1s, expo_coef_1s, coef_tmp) & + !$OMP SHARED (n_points_final_grid, ao_num, List_env1s_square_size, & + !$OMP final_grid_points, ng_fit_jast, & + !$OMP expo_gauss_j_mu_1_erf, coef_gauss_j_mu_1_erf, & + !$OMP List_env1s_square_coef, List_env1s_square_expo, & + !$OMP List_env1s_square_cent, int2_u_grad1u_env2) !$OMP DO do ipoint = 1, n_points_final_grid do i = 1, ao_num @@ -436,14 +441,14 @@ BEGIN_PROVIDER [ double precision, int2_u_grad1u_j1b2, (ao_num, ao_num, n_points ! --- - do i_1s = 2, List_all_comb_b3_size + do i_1s = 2, List_env1s_square_size - coef = List_all_comb_b3_coef (i_1s) + coef = List_env1s_square_coef (i_1s) if(dabs(coef) .lt. 1d-15) cycle ! beta = 0.0 - beta = List_all_comb_b3_expo (i_1s) - B_center(1) = List_all_comb_b3_cent(1,i_1s) - B_center(2) = List_all_comb_b3_cent(2,i_1s) - B_center(3) = List_all_comb_b3_cent(3,i_1s) + beta = List_env1s_square_expo (i_1s) + B_center(1) = List_env1s_square_cent(1,i_1s) + B_center(2) = List_env1s_square_cent(2,i_1s) + B_center(3) = List_env1s_square_cent(3,i_1s) dist = (B_center(1) - r(1)) * (B_center(1) - r(1)) & + (B_center(2) - r(2)) * (B_center(2) - r(2)) & + (B_center(3) - r(3)) * (B_center(3) - r(3)) @@ -468,7 +473,7 @@ BEGIN_PROVIDER [ double precision, int2_u_grad1u_j1b2, (ao_num, ao_num, n_points enddo - int2_u_grad1u_j1b2(j,i,ipoint) = tmp + int2_u_grad1u_env2(j,i,ipoint) = tmp enddo enddo enddo @@ -478,13 +483,13 @@ BEGIN_PROVIDER [ double precision, int2_u_grad1u_j1b2, (ao_num, ao_num, n_points do ipoint = 1, n_points_final_grid do i = 2, ao_num do j = 1, i-1 - int2_u_grad1u_j1b2(j,i,ipoint) = int2_u_grad1u_j1b2(i,j,ipoint) + int2_u_grad1u_env2(j,i,ipoint) = int2_u_grad1u_env2(i,j,ipoint) enddo enddo enddo call wall_time(wall1) - print*, ' wall time for int2_u_grad1u_j1b2', wall1 - wall0 + print*, ' wall time for int2_u_grad1u_env2 (min) = ', (wall1 - wall0) / 60.d0 END_PROVIDER diff --git a/src/ao_many_one_e_ints/grad_lapl_jmu_manu.irp.f b/plugins/local/ao_many_one_e_ints/grad_lapl_jmu_manu.irp.f similarity index 74% rename from src/ao_many_one_e_ints/grad_lapl_jmu_manu.irp.f rename to plugins/local/ao_many_one_e_ints/grad_lapl_jmu_manu.irp.f index 66a2b961..6c163df6 100644 --- a/src/ao_many_one_e_ints/grad_lapl_jmu_manu.irp.f +++ b/plugins/local/ao_many_one_e_ints/grad_lapl_jmu_manu.irp.f @@ -1,11 +1,11 @@ ! --- -BEGIN_PROVIDER [ double precision, v_ij_erf_rk_cst_mu_j1b_test, (ao_num, ao_num, n_points_final_grid)] +BEGIN_PROVIDER [double precision, v_ij_erf_rk_cst_mu_env_test, (ao_num, ao_num, n_points_final_grid)] BEGIN_DOC ! - ! int dr phi_i(r) phi_j(r) 1s_j1b(r) (erf(mu(R) |r - R| - 1) / |r - R| + ! int dr phi_i(r) phi_j(r) 1s_env(r) (erf(mu(R) |r - R| - 1) / |r - R| ! END_DOC @@ -13,24 +13,23 @@ BEGIN_PROVIDER [ double precision, v_ij_erf_rk_cst_mu_j1b_test, (ao_num, ao_num, integer :: i, j, ipoint, i_1s double precision :: r(3), int_mu, int_coulomb double precision :: coef, beta, B_center(3) - double precision :: tmp,int_j1b + double precision :: tmp,int_env double precision :: wall0, wall1 double precision, external :: NAI_pol_mult_erf_ao_with1s double precision :: sigma_ij,dist_ij_ipoint,dsqpi_3_2 - print*, ' providing v_ij_erf_rk_cst_mu_j1b_test ...' + print*, ' providing v_ij_erf_rk_cst_mu_env_test ...' dsqpi_3_2 = (dacos(-1.d0))**(1.5d0) - provide mu_erf final_grid_points j1b_pen call wall_time(wall0) - v_ij_erf_rk_cst_mu_j1b_test = 0.d0 + v_ij_erf_rk_cst_mu_env_test = 0.d0 !$OMP PARALLEL DEFAULT (NONE) & - !$OMP PRIVATE (ipoint, i, j, i_1s, r, coef, beta, B_center, int_mu, int_coulomb, tmp, int_j1b)& + !$OMP PRIVATE (ipoint, i, j, i_1s, r, coef, beta, B_center, int_mu, int_coulomb, tmp, int_env)& !$OMP SHARED (n_points_final_grid, ao_num, List_comb_thr_b2_size, final_grid_points, & - !$OMP List_comb_thr_b2_coef, List_comb_thr_b2_expo, List_comb_thr_b2_cent,ao_abs_comb_b2_j1b, & - !$OMP v_ij_erf_rk_cst_mu_j1b_test, mu_erf, & + !$OMP List_comb_thr_b2_coef, List_comb_thr_b2_expo, List_comb_thr_b2_cent,ao_abs_comb_b2_env, & + !$OMP v_ij_erf_rk_cst_mu_env_test, mu_erf, & !$OMP ao_overlap_abs_grid,ao_prod_center,ao_prod_sigma,dsqpi_3_2,thrsh_cycle_tc) !$OMP DO !do ipoint = 1, 10 @@ -48,8 +47,8 @@ BEGIN_PROVIDER [ double precision, v_ij_erf_rk_cst_mu_j1b_test, (ao_num, ao_num, coef = List_comb_thr_b2_coef (i_1s,j,i) beta = List_comb_thr_b2_expo (i_1s,j,i) - int_j1b = ao_abs_comb_b2_j1b(i_1s,j,i) -! if(dabs(coef)*dabs(int_j1b).lt.thrsh_cycle_tc)cycle + int_env = ao_abs_comb_b2_env(i_1s,j,i) +! if(dabs(coef)*dabs(int_env).lt.thrsh_cycle_tc)cycle B_center(1) = List_comb_thr_b2_cent(1,i_1s,j,i) B_center(2) = List_comb_thr_b2_cent(2,i_1s,j,i) B_center(3) = List_comb_thr_b2_cent(3,i_1s,j,i) @@ -60,7 +59,7 @@ BEGIN_PROVIDER [ double precision, v_ij_erf_rk_cst_mu_j1b_test, (ao_num, ao_num, tmp += coef * (int_mu - int_coulomb) enddo - v_ij_erf_rk_cst_mu_j1b_test(j,i,ipoint) = tmp + v_ij_erf_rk_cst_mu_env_test(j,i,ipoint) = tmp enddo enddo enddo @@ -70,22 +69,22 @@ BEGIN_PROVIDER [ double precision, v_ij_erf_rk_cst_mu_j1b_test, (ao_num, ao_num, do ipoint = 1, n_points_final_grid do i = 2, ao_num do j = 1, i-1 - v_ij_erf_rk_cst_mu_j1b_test(j,i,ipoint) = v_ij_erf_rk_cst_mu_j1b_test(i,j,ipoint) + v_ij_erf_rk_cst_mu_env_test(j,i,ipoint) = v_ij_erf_rk_cst_mu_env_test(i,j,ipoint) enddo enddo enddo call wall_time(wall1) - print*, ' wall time for v_ij_erf_rk_cst_mu_j1b_test', wall1 - wall0 + print*, ' wall time for v_ij_erf_rk_cst_mu_env_test (min) = ', (wall1 - wall0) / 60.d0 END_PROVIDER ! --- -BEGIN_PROVIDER [ double precision, x_v_ij_erf_rk_cst_mu_j1b_test, (ao_num, ao_num, n_points_final_grid, 3)] +BEGIN_PROVIDER [double precision, x_v_ij_erf_rk_cst_mu_env_test, (ao_num, ao_num, n_points_final_grid, 3)] BEGIN_DOC - ! int dr x phi_i(r) phi_j(r) 1s_j1b(r) (erf(mu(R) |r - R|) - 1)/|r - R| + ! int dr x phi_i(r) phi_j(r) 1s_env(r) (erf(mu(R) |r - R|) - 1)/|r - R| END_DOC implicit none @@ -93,23 +92,23 @@ BEGIN_PROVIDER [ double precision, x_v_ij_erf_rk_cst_mu_j1b_test, (ao_num, ao_nu double precision :: coef, beta, B_center(3), r(3), ints(3), ints_coulomb(3) double precision :: tmp_x, tmp_y, tmp_z double precision :: wall0, wall1 - double precision :: sigma_ij,dist_ij_ipoint,dsqpi_3_2,int_j1b,factor_ij_1s,beta_ij,center_ij_1s + double precision :: sigma_ij,dist_ij_ipoint,dsqpi_3_2,int_env,factor_ij_1s,beta_ij,center_ij_1s - print*, ' providing x_v_ij_erf_rk_cst_mu_j1b_test ...' + print*, ' providing x_v_ij_erf_rk_cst_mu_env_test ...' dsqpi_3_2 = (dacos(-1.d0))**(1.5d0) provide expo_erfc_mu_gauss ao_prod_sigma ao_prod_center call wall_time(wall0) - x_v_ij_erf_rk_cst_mu_j1b_test = 0.d0 + x_v_ij_erf_rk_cst_mu_env_test = 0.d0 !$OMP PARALLEL DEFAULT (NONE) & !$OMP PRIVATE (ipoint, i, j, i_1s, r, coef, beta, B_center, ints, ints_coulomb, & - !$OMP int_j1b, tmp_x, tmp_y, tmp_z,factor_ij_1s,beta_ij,center_ij_1s) & + !$OMP int_env, tmp_x, tmp_y, tmp_z,factor_ij_1s,beta_ij,center_ij_1s) & !$OMP SHARED (n_points_final_grid, ao_num, List_comb_thr_b2_size, final_grid_points,& !$OMP List_comb_thr_b2_coef, List_comb_thr_b2_expo, List_comb_thr_b2_cent, & - !$OMP x_v_ij_erf_rk_cst_mu_j1b_test, mu_erf,ao_abs_comb_b2_j1b, & + !$OMP x_v_ij_erf_rk_cst_mu_env_test, mu_erf,ao_abs_comb_b2_env, & !$OMP ao_overlap_abs_grid,ao_prod_center,ao_prod_sigma,thrsh_cycle_tc) ! !$OMP ao_overlap_abs_grid,ao_prod_center,ao_prod_sigma,dsqpi_3_2,expo_erfc_mu_gauss) !$OMP DO @@ -129,8 +128,8 @@ BEGIN_PROVIDER [ double precision, x_v_ij_erf_rk_cst_mu_j1b_test, (ao_num, ao_nu coef = List_comb_thr_b2_coef (i_1s,j,i) beta = List_comb_thr_b2_expo (i_1s,j,i) - int_j1b = ao_abs_comb_b2_j1b(i_1s,j,i) - ! if(dabs(coef)*dabs(int_j1b).lt.thrsh_cycle_tc)cycle + int_env = ao_abs_comb_b2_env(i_1s,j,i) + ! if(dabs(coef)*dabs(int_env).lt.thrsh_cycle_tc)cycle B_center(1) = List_comb_thr_b2_cent(1,i_1s,j,i) B_center(2) = List_comb_thr_b2_cent(2,i_1s,j,i) B_center(3) = List_comb_thr_b2_cent(3,i_1s,j,i) @@ -143,9 +142,9 @@ BEGIN_PROVIDER [ double precision, x_v_ij_erf_rk_cst_mu_j1b_test, (ao_num, ao_nu tmp_z += coef * (ints(3) - ints_coulomb(3)) enddo - x_v_ij_erf_rk_cst_mu_j1b_test(j,i,ipoint,1) = tmp_x - x_v_ij_erf_rk_cst_mu_j1b_test(j,i,ipoint,2) = tmp_y - x_v_ij_erf_rk_cst_mu_j1b_test(j,i,ipoint,3) = tmp_z + x_v_ij_erf_rk_cst_mu_env_test(j,i,ipoint,1) = tmp_x + x_v_ij_erf_rk_cst_mu_env_test(j,i,ipoint,2) = tmp_y + x_v_ij_erf_rk_cst_mu_env_test(j,i,ipoint,3) = tmp_z enddo enddo enddo @@ -155,26 +154,26 @@ BEGIN_PROVIDER [ double precision, x_v_ij_erf_rk_cst_mu_j1b_test, (ao_num, ao_nu do ipoint = 1, n_points_final_grid do i = 2, ao_num do j = 1, i-1 - x_v_ij_erf_rk_cst_mu_j1b_test(j,i,ipoint,1) = x_v_ij_erf_rk_cst_mu_j1b_test(i,j,ipoint,1) - x_v_ij_erf_rk_cst_mu_j1b_test(j,i,ipoint,2) = x_v_ij_erf_rk_cst_mu_j1b_test(i,j,ipoint,2) - x_v_ij_erf_rk_cst_mu_j1b_test(j,i,ipoint,3) = x_v_ij_erf_rk_cst_mu_j1b_test(i,j,ipoint,3) + x_v_ij_erf_rk_cst_mu_env_test(j,i,ipoint,1) = x_v_ij_erf_rk_cst_mu_env_test(i,j,ipoint,1) + x_v_ij_erf_rk_cst_mu_env_test(j,i,ipoint,2) = x_v_ij_erf_rk_cst_mu_env_test(i,j,ipoint,2) + x_v_ij_erf_rk_cst_mu_env_test(j,i,ipoint,3) = x_v_ij_erf_rk_cst_mu_env_test(i,j,ipoint,3) enddo enddo enddo call wall_time(wall1) - print*, ' wall time for x_v_ij_erf_rk_cst_mu_j1b_test', wall1 - wall0 + print*, ' wall time for x_v_ij_erf_rk_cst_mu_env_test (min) = ', (wall1 - wall0) / 60.d0 END_PROVIDER ! --- ! TODO analytically -BEGIN_PROVIDER [ double precision, v_ij_u_cst_mu_j1b_test, (ao_num, ao_num, n_points_final_grid)] +BEGIN_PROVIDER [double precision, v_ij_u_cst_mu_env_test, (ao_num, ao_num, n_points_final_grid)] BEGIN_DOC ! - ! int dr2 phi_i(r2) phi_j(r2) 1s_j1b(r2) u(mu, r12) + ! int dr2 phi_i(r2) phi_j(r2) 1s_env(r2) u(mu, r12) ! END_DOC @@ -185,29 +184,28 @@ BEGIN_PROVIDER [ double precision, v_ij_u_cst_mu_j1b_test, (ao_num, ao_num, n_po double precision :: tmp double precision :: wall0, wall1 double precision :: beta_ij_u, factor_ij_1s_u, center_ij_1s_u(3), coeftot - double precision :: sigma_ij, dist_ij_ipoint, dsqpi_3_2, int_j1b + double precision :: sigma_ij, dist_ij_ipoint, dsqpi_3_2, int_env double precision, external :: overlap_gauss_r12_ao double precision, external :: overlap_gauss_r12_ao_with1s - print*, ' providing v_ij_u_cst_mu_j1b_test ...' + print*, ' providing v_ij_u_cst_mu_env_test ...' dsqpi_3_2 = (dacos(-1.d0))**(1.5d0) - provide mu_erf final_grid_points j1b_pen call wall_time(wall0) - v_ij_u_cst_mu_j1b_test = 0.d0 + v_ij_u_cst_mu_env_test = 0.d0 !$OMP PARALLEL DEFAULT (NONE) & !$OMP PRIVATE (ipoint, i, j, i_1s, i_fit, r, coef, beta, B_center, & !$OMP beta_ij_u, factor_ij_1s_u, center_ij_1s_u, & - !$OMP coef_fit, expo_fit, int_fit, tmp,coeftot,int_j1b) & + !$OMP coef_fit, expo_fit, int_fit, tmp,coeftot,int_env) & !$OMP SHARED (n_points_final_grid, ao_num, & !$OMP final_grid_points, ng_fit_jast, & !$OMP expo_gauss_j_mu_x, coef_gauss_j_mu_x, & !$OMP List_comb_thr_b2_coef, List_comb_thr_b2_expo,List_comb_thr_b2_size, & - !$OMP List_comb_thr_b2_cent, v_ij_u_cst_mu_j1b_test,ao_abs_comb_b2_j1b, & + !$OMP List_comb_thr_b2_cent, v_ij_u_cst_mu_env_test,ao_abs_comb_b2_env, & !$OMP ao_overlap_abs_grid,ao_prod_center,ao_prod_sigma,dsqpi_3_2,thrsh_cycle_tc) !$OMP DO do ipoint = 1, n_points_final_grid @@ -225,8 +223,8 @@ BEGIN_PROVIDER [ double precision, v_ij_u_cst_mu_j1b_test, (ao_num, ao_num, n_po ! i_1s = 1 ! --- --- --- - int_j1b = ao_abs_comb_b2_j1b(1,j,i) - ! if(dabs(int_j1b).lt.thrsh_cycle_tc) cycle + int_env = ao_abs_comb_b2_env(1,j,i) + ! if(dabs(int_env).lt.thrsh_cycle_tc) cycle do i_fit = 1, ng_fit_jast expo_fit = expo_gauss_j_mu_x(i_fit) coef_fit = coef_gauss_j_mu_x(i_fit) @@ -242,8 +240,8 @@ BEGIN_PROVIDER [ double precision, v_ij_u_cst_mu_j1b_test, (ao_num, ao_num, n_po do i_1s = 2, List_comb_thr_b2_size(j,i) coef = List_comb_thr_b2_coef (i_1s,j,i) beta = List_comb_thr_b2_expo (i_1s,j,i) - int_j1b = ao_abs_comb_b2_j1b(i_1s,j,i) -! if(dabs(coef)*dabs(int_j1b).lt.thrsh_cycle_tc)cycle + int_env = ao_abs_comb_b2_env(i_1s,j,i) +! if(dabs(coef)*dabs(int_env).lt.thrsh_cycle_tc)cycle B_center(1) = List_comb_thr_b2_cent(1,i_1s,j,i) B_center(2) = List_comb_thr_b2_cent(2,i_1s,j,i) B_center(3) = List_comb_thr_b2_cent(3,i_1s,j,i) @@ -259,7 +257,7 @@ BEGIN_PROVIDER [ double precision, v_ij_u_cst_mu_j1b_test, (ao_num, ao_num, n_po enddo enddo - v_ij_u_cst_mu_j1b_test(j,i,ipoint) = tmp + v_ij_u_cst_mu_env_test(j,i,ipoint) = tmp enddo enddo enddo @@ -269,23 +267,23 @@ BEGIN_PROVIDER [ double precision, v_ij_u_cst_mu_j1b_test, (ao_num, ao_num, n_po do ipoint = 1, n_points_final_grid do i = 2, ao_num do j = 1, i-1 - v_ij_u_cst_mu_j1b_test(j,i,ipoint) = v_ij_u_cst_mu_j1b_test(i,j,ipoint) + v_ij_u_cst_mu_env_test(j,i,ipoint) = v_ij_u_cst_mu_env_test(i,j,ipoint) enddo enddo enddo call wall_time(wall1) - print*, ' wall time for v_ij_u_cst_mu_j1b_test', wall1 - wall0 + print*, ' wall time for v_ij_u_cst_mu_env_test (min) = ', (wall1 - wall0) / 60.d0 END_PROVIDER ! --- -BEGIN_PROVIDER [ double precision, v_ij_u_cst_mu_j1b_ng_1_test, (ao_num, ao_num, n_points_final_grid)] +BEGIN_PROVIDER [double precision, v_ij_u_cst_mu_env_ng_1_test, (ao_num, ao_num, n_points_final_grid)] BEGIN_DOC ! - ! int dr2 phi_i(r2) phi_j(r2) 1s_j1b(r2) u(mu, r12) with u(mu,r12) \approx 1/2 mu e^{-2.5 * mu (r12)^2} + ! int dr2 phi_i(r2) phi_j(r2) 1s_env(r2) u(mu, r12) with u(mu,r12) \approx 1/2 mu e^{-2.5 * mu (r12)^2} ! END_DOC @@ -296,27 +294,26 @@ BEGIN_PROVIDER [ double precision, v_ij_u_cst_mu_j1b_ng_1_test, (ao_num, ao_num, double precision :: tmp double precision :: wall0, wall1 double precision :: beta_ij_u, factor_ij_1s_u, center_ij_1s_u(3), coeftot - double precision :: sigma_ij, dist_ij_ipoint, dsqpi_3_2, int_j1b + double precision :: sigma_ij, dist_ij_ipoint, dsqpi_3_2, int_env double precision, external :: overlap_gauss_r12_ao double precision, external :: overlap_gauss_r12_ao_with1s dsqpi_3_2 = (dacos(-1.d0))**(1.5d0) - provide mu_erf final_grid_points j1b_pen call wall_time(wall0) - v_ij_u_cst_mu_j1b_ng_1_test = 0.d0 + v_ij_u_cst_mu_env_ng_1_test = 0.d0 !$OMP PARALLEL DEFAULT (NONE) & !$OMP PRIVATE (ipoint, i, j, i_1s, r, coef, beta, B_center, & !$OMP beta_ij_u, factor_ij_1s_u, center_ij_1s_u, & - !$OMP coef_fit, expo_fit, int_fit, tmp,coeftot,int_j1b) & + !$OMP coef_fit, expo_fit, int_fit, tmp,coeftot,int_env) & !$OMP SHARED (n_points_final_grid, ao_num, & !$OMP final_grid_points, expo_good_j_mu_1gauss,coef_good_j_mu_1gauss, & !$OMP expo_gauss_j_mu_x, coef_gauss_j_mu_x, & !$OMP List_comb_thr_b2_coef, List_comb_thr_b2_expo,List_comb_thr_b2_size, & - !$OMP List_comb_thr_b2_cent, v_ij_u_cst_mu_j1b_ng_1_test,ao_abs_comb_b2_j1b, & + !$OMP List_comb_thr_b2_cent, v_ij_u_cst_mu_env_ng_1_test,ao_abs_comb_b2_env, & !$OMP ao_overlap_abs_grid,ao_prod_center,ao_prod_sigma,dsqpi_3_2,thrsh_cycle_tc) !$OMP DO do ipoint = 1, n_points_final_grid @@ -334,8 +331,8 @@ BEGIN_PROVIDER [ double precision, v_ij_u_cst_mu_j1b_ng_1_test, (ao_num, ao_num, ! i_1s = 1 ! --- --- --- - int_j1b = ao_abs_comb_b2_j1b(1,j,i) -! if(dabs(int_j1b).lt.thrsh_cycle_tc) cycle + int_env = ao_abs_comb_b2_env(1,j,i) +! if(dabs(int_env).lt.thrsh_cycle_tc) cycle expo_fit = expo_good_j_mu_1gauss int_fit = overlap_gauss_r12_ao(r, expo_fit, i, j) tmp += int_fit @@ -347,8 +344,8 @@ BEGIN_PROVIDER [ double precision, v_ij_u_cst_mu_j1b_ng_1_test, (ao_num, ao_num, do i_1s = 2, List_comb_thr_b2_size(j,i) coef = List_comb_thr_b2_coef (i_1s,j,i) beta = List_comb_thr_b2_expo (i_1s,j,i) - int_j1b = ao_abs_comb_b2_j1b(i_1s,j,i) -! if(dabs(coef)*dabs(int_j1b).lt.thrsh_cycle_tc)cycle + int_env = ao_abs_comb_b2_env(i_1s,j,i) +! if(dabs(coef)*dabs(int_env).lt.thrsh_cycle_tc)cycle B_center(1) = List_comb_thr_b2_cent(1,i_1s,j,i) B_center(2) = List_comb_thr_b2_cent(2,i_1s,j,i) B_center(3) = List_comb_thr_b2_cent(3,i_1s,j,i) @@ -364,7 +361,7 @@ BEGIN_PROVIDER [ double precision, v_ij_u_cst_mu_j1b_ng_1_test, (ao_num, ao_num, ! enddo enddo - v_ij_u_cst_mu_j1b_ng_1_test(j,i,ipoint) = tmp + v_ij_u_cst_mu_env_ng_1_test(j,i,ipoint) = tmp enddo enddo enddo @@ -374,13 +371,13 @@ BEGIN_PROVIDER [ double precision, v_ij_u_cst_mu_j1b_ng_1_test, (ao_num, ao_num, do ipoint = 1, n_points_final_grid do i = 2, ao_num do j = 1, i-1 - v_ij_u_cst_mu_j1b_ng_1_test(j,i,ipoint) = v_ij_u_cst_mu_j1b_ng_1_test(i,j,ipoint) + v_ij_u_cst_mu_env_ng_1_test(j,i,ipoint) = v_ij_u_cst_mu_env_ng_1_test(i,j,ipoint) enddo enddo enddo call wall_time(wall1) - print*, ' wall time for v_ij_u_cst_mu_j1b_ng_1_test', wall1 - wall0 + print*, ' wall time for v_ij_u_cst_mu_env_ng_1_test (min) = ', (wall1 - wall0) / 60.d0 END_PROVIDER diff --git a/src/ao_many_one_e_ints/grad_lapl_jmu_modif.irp.f b/plugins/local/ao_many_one_e_ints/grad_lapl_jmu_modif.irp.f similarity index 65% rename from src/ao_many_one_e_ints/grad_lapl_jmu_modif.irp.f rename to plugins/local/ao_many_one_e_ints/grad_lapl_jmu_modif.irp.f index 24b33eb5..00e2d5fc 100644 --- a/src/ao_many_one_e_ints/grad_lapl_jmu_modif.irp.f +++ b/plugins/local/ao_many_one_e_ints/grad_lapl_jmu_modif.irp.f @@ -1,11 +1,11 @@ ! --- -BEGIN_PROVIDER [ double precision, v_ij_erf_rk_cst_mu_j1b, (ao_num, ao_num, n_points_final_grid)] +BEGIN_PROVIDER [double precision, v_ij_erf_rk_cst_mu_env, (ao_num, ao_num, n_points_final_grid)] BEGIN_DOC ! - ! int dr phi_i(r) phi_j(r) 1s_j1b(r) (erf(mu(R) |r - R| - 1) / |r - R| + ! int dr phi_i(r) phi_j(r) 1s_env(r) (erf(mu(R) |r - R| - 1) / |r - R| ! END_DOC @@ -17,18 +17,20 @@ BEGIN_PROVIDER [ double precision, v_ij_erf_rk_cst_mu_j1b, (ao_num, ao_num, n_po double precision :: wall0, wall1 double precision, external :: NAI_pol_mult_erf_ao_with1s - print *, ' providing v_ij_erf_rk_cst_mu_j1b ...' + PROVIDE mu_erf + PROVIDE final_grid_points + PROVIDE env_expo + + print *, ' providing v_ij_erf_rk_cst_mu_env ...' call wall_time(wall0) - provide mu_erf final_grid_points j1b_pen - - v_ij_erf_rk_cst_mu_j1b = 0.d0 + v_ij_erf_rk_cst_mu_env = 0.d0 !$OMP PARALLEL DEFAULT (NONE) & !$OMP PRIVATE (ipoint, i, j, i_1s, r, coef, beta, B_center, int_mu, int_coulomb, tmp) & - !$OMP SHARED (n_points_final_grid, ao_num, List_all_comb_b2_size, final_grid_points, & - !$OMP List_all_comb_b2_coef, List_all_comb_b2_expo, List_all_comb_b2_cent, & - !$OMP v_ij_erf_rk_cst_mu_j1b, mu_erf) + !$OMP SHARED (n_points_final_grid, ao_num, List_env1s_size, final_grid_points, & + !$OMP List_env1s_coef, List_env1s_expo, List_env1s_cent, & + !$OMP v_ij_erf_rk_cst_mu_env, mu_erf) !$OMP DO !do ipoint = 1, 10 do ipoint = 1, n_points_final_grid @@ -43,28 +45,27 @@ BEGIN_PROVIDER [ double precision, v_ij_erf_rk_cst_mu_j1b, (ao_num, ao_num, n_po ! --- - coef = List_all_comb_b2_coef (1) - beta = List_all_comb_b2_expo (1) - B_center(1) = List_all_comb_b2_cent(1,1) - B_center(2) = List_all_comb_b2_cent(2,1) - B_center(3) = List_all_comb_b2_cent(3,1) + coef = List_env1s_coef (1) + beta = List_env1s_expo (1) + B_center(1) = List_env1s_cent(1,1) + B_center(2) = List_env1s_cent(2,1) + B_center(3) = List_env1s_cent(3,1) int_mu = NAI_pol_mult_erf_ao_with1s(i, j, beta, B_center, mu_erf, r) int_coulomb = NAI_pol_mult_erf_ao_with1s(i, j, beta, B_center, 1.d+9, r) -! if(dabs(coef)*dabs(int_mu - int_coulomb) .lt. 1d-12) cycle tmp += coef * (int_mu - int_coulomb) ! --- - do i_1s = 2, List_all_comb_b2_size + do i_1s = 2, List_env1s_size - coef = List_all_comb_b2_coef (i_1s) + coef = List_env1s_coef (i_1s) if(dabs(coef) .lt. 1d-15) cycle ! beta = 0.0 - beta = List_all_comb_b2_expo (i_1s) - B_center(1) = List_all_comb_b2_cent(1,i_1s) - B_center(2) = List_all_comb_b2_cent(2,i_1s) - B_center(3) = List_all_comb_b2_cent(3,i_1s) + beta = List_env1s_expo (i_1s) + B_center(1) = List_env1s_cent(1,i_1s) + B_center(2) = List_env1s_cent(2,i_1s) + B_center(3) = List_env1s_cent(3,i_1s) int_mu = NAI_pol_mult_erf_ao_with1s(i, j, beta, B_center, mu_erf, r) int_coulomb = NAI_pol_mult_erf_ao_with1s(i, j, beta, B_center, 1.d+9, r) @@ -74,7 +75,7 @@ BEGIN_PROVIDER [ double precision, v_ij_erf_rk_cst_mu_j1b, (ao_num, ao_num, n_po ! --- - v_ij_erf_rk_cst_mu_j1b(j,i,ipoint) = tmp + v_ij_erf_rk_cst_mu_env(j,i,ipoint) = tmp enddo enddo enddo @@ -84,22 +85,22 @@ BEGIN_PROVIDER [ double precision, v_ij_erf_rk_cst_mu_j1b, (ao_num, ao_num, n_po do ipoint = 1, n_points_final_grid do i = 2, ao_num do j = 1, i-1 - v_ij_erf_rk_cst_mu_j1b(j,i,ipoint) = v_ij_erf_rk_cst_mu_j1b(i,j,ipoint) + v_ij_erf_rk_cst_mu_env(j,i,ipoint) = v_ij_erf_rk_cst_mu_env(i,j,ipoint) enddo enddo enddo call wall_time(wall1) - print*, ' wall time for v_ij_erf_rk_cst_mu_j1b', wall1 - wall0 + print*, ' wall time for v_ij_erf_rk_cst_mu_env (min) = ', (wall1 - wall0) / 60.d0 END_PROVIDER ! --- -BEGIN_PROVIDER [ double precision, x_v_ij_erf_rk_cst_mu_j1b, (ao_num, ao_num, n_points_final_grid, 3)] +BEGIN_PROVIDER [double precision, x_v_ij_erf_rk_cst_mu_env, (ao_num, ao_num, n_points_final_grid, 3)] BEGIN_DOC - ! int dr x phi_i(r) phi_j(r) 1s_j1b(r) (erf(mu(R) |r - R|) - 1)/|r - R| + ! int dr x phi_i(r) phi_j(r) 1s_env(r) (erf(mu(R) |r - R|) - 1)/|r - R| END_DOC implicit none @@ -108,17 +109,17 @@ BEGIN_PROVIDER [ double precision, x_v_ij_erf_rk_cst_mu_j1b, (ao_num, ao_num, n_ double precision :: tmp_x, tmp_y, tmp_z double precision :: wall0, wall1 - print*, ' providing x_v_ij_erf_rk_cst_mu_j1b ...' + print*, ' providing x_v_ij_erf_rk_cst_mu_env ...' call wall_time(wall0) - x_v_ij_erf_rk_cst_mu_j1b = 0.d0 + x_v_ij_erf_rk_cst_mu_env = 0.d0 !$OMP PARALLEL DEFAULT (NONE) & !$OMP PRIVATE (ipoint, i, j, i_1s, r, coef, beta, B_center, ints, ints_coulomb, & !$OMP tmp_x, tmp_y, tmp_z) & - !$OMP SHARED (n_points_final_grid, ao_num, List_all_comb_b2_size, final_grid_points,& - !$OMP List_all_comb_b2_coef, List_all_comb_b2_expo, List_all_comb_b2_cent, & - !$OMP x_v_ij_erf_rk_cst_mu_j1b, mu_erf) + !$OMP SHARED (n_points_final_grid, ao_num, List_env1s_size, final_grid_points,& + !$OMP List_env1s_coef, List_env1s_expo, List_env1s_cent, & + !$OMP x_v_ij_erf_rk_cst_mu_env, mu_erf) !$OMP DO !do ipoint = 1, 10 do ipoint = 1, n_points_final_grid @@ -135,11 +136,11 @@ BEGIN_PROVIDER [ double precision, x_v_ij_erf_rk_cst_mu_j1b, (ao_num, ao_num, n_ ! --- - coef = List_all_comb_b2_coef (1) - beta = List_all_comb_b2_expo (1) - B_center(1) = List_all_comb_b2_cent(1,1) - B_center(2) = List_all_comb_b2_cent(2,1) - B_center(3) = List_all_comb_b2_cent(3,1) + coef = List_env1s_coef (1) + beta = List_env1s_expo (1) + B_center(1) = List_env1s_cent(1,1) + B_center(2) = List_env1s_cent(2,1) + B_center(3) = List_env1s_cent(3,1) call NAI_pol_x_mult_erf_ao_with1s(i, j, beta, B_center, mu_erf, r, ints ) call NAI_pol_x_mult_erf_ao_with1s(i, j, beta, B_center, 1.d+9, r, ints_coulomb) @@ -152,14 +153,14 @@ BEGIN_PROVIDER [ double precision, x_v_ij_erf_rk_cst_mu_j1b, (ao_num, ao_num, n_ ! --- - do i_1s = 2, List_all_comb_b2_size + do i_1s = 2, List_env1s_size - coef = List_all_comb_b2_coef (i_1s) + coef = List_env1s_coef (i_1s) if(dabs(coef) .lt. 1d-15) cycle ! beta = 0.0 - beta = List_all_comb_b2_expo (i_1s) - B_center(1) = List_all_comb_b2_cent(1,i_1s) - B_center(2) = List_all_comb_b2_cent(2,i_1s) - B_center(3) = List_all_comb_b2_cent(3,i_1s) + beta = List_env1s_expo (i_1s) + B_center(1) = List_env1s_cent(1,i_1s) + B_center(2) = List_env1s_cent(2,i_1s) + B_center(3) = List_env1s_cent(3,i_1s) call NAI_pol_x_mult_erf_ao_with1s(i, j, beta, B_center, mu_erf, r, ints ) call NAI_pol_x_mult_erf_ao_with1s(i, j, beta, B_center, 1.d+9, r, ints_coulomb) @@ -171,9 +172,9 @@ BEGIN_PROVIDER [ double precision, x_v_ij_erf_rk_cst_mu_j1b, (ao_num, ao_num, n_ ! --- - x_v_ij_erf_rk_cst_mu_j1b(j,i,ipoint,1) = tmp_x - x_v_ij_erf_rk_cst_mu_j1b(j,i,ipoint,2) = tmp_y - x_v_ij_erf_rk_cst_mu_j1b(j,i,ipoint,3) = tmp_z + x_v_ij_erf_rk_cst_mu_env(j,i,ipoint,1) = tmp_x + x_v_ij_erf_rk_cst_mu_env(j,i,ipoint,2) = tmp_y + x_v_ij_erf_rk_cst_mu_env(j,i,ipoint,3) = tmp_z enddo enddo enddo @@ -183,25 +184,25 @@ BEGIN_PROVIDER [ double precision, x_v_ij_erf_rk_cst_mu_j1b, (ao_num, ao_num, n_ do ipoint = 1, n_points_final_grid do i = 2, ao_num do j = 1, i-1 - x_v_ij_erf_rk_cst_mu_j1b(j,i,ipoint,1) = x_v_ij_erf_rk_cst_mu_j1b(i,j,ipoint,1) - x_v_ij_erf_rk_cst_mu_j1b(j,i,ipoint,2) = x_v_ij_erf_rk_cst_mu_j1b(i,j,ipoint,2) - x_v_ij_erf_rk_cst_mu_j1b(j,i,ipoint,3) = x_v_ij_erf_rk_cst_mu_j1b(i,j,ipoint,3) + x_v_ij_erf_rk_cst_mu_env(j,i,ipoint,1) = x_v_ij_erf_rk_cst_mu_env(i,j,ipoint,1) + x_v_ij_erf_rk_cst_mu_env(j,i,ipoint,2) = x_v_ij_erf_rk_cst_mu_env(i,j,ipoint,2) + x_v_ij_erf_rk_cst_mu_env(j,i,ipoint,3) = x_v_ij_erf_rk_cst_mu_env(i,j,ipoint,3) enddo enddo enddo call wall_time(wall1) - print*, ' wall time for x_v_ij_erf_rk_cst_mu_j1b =', wall1 - wall0 + print*, ' wall time for x_v_ij_erf_rk_cst_mu_env (min) =', (wall1 - wall0) / 60.d0 END_PROVIDER ! --- -BEGIN_PROVIDER [ double precision, v_ij_u_cst_mu_j1b_fit, (ao_num, ao_num, n_points_final_grid)] +BEGIN_PROVIDER [double precision, v_ij_u_cst_mu_env_fit, (ao_num, ao_num, n_points_final_grid)] BEGIN_DOC ! - ! int dr2 phi_i(r2) phi_j(r2) 1s_j1b(r2) u(mu, r12) + ! int dr2 phi_i(r2) phi_j(r2) 1s_env(r2) u(mu, r12) ! END_DOC @@ -214,23 +215,23 @@ BEGIN_PROVIDER [ double precision, v_ij_u_cst_mu_j1b_fit, (ao_num, ao_num, n_poi double precision, external :: overlap_gauss_r12_ao_with1s - print*, ' providing v_ij_u_cst_mu_j1b_fit ...' + print*, ' providing v_ij_u_cst_mu_env_fit ...' call wall_time(wall0) - provide mu_erf final_grid_points j1b_pen + provide mu_erf final_grid_points env_expo PROVIDE ng_fit_jast expo_gauss_j_mu_x coef_gauss_j_mu_x - PROVIDE List_all_comb_b2_size List_all_comb_b2_coef List_all_comb_b2_expo List_all_comb_b2_cent + PROVIDE List_env1s_size List_env1s_coef List_env1s_expo List_env1s_cent - v_ij_u_cst_mu_j1b_fit = 0.d0 + v_ij_u_cst_mu_env_fit = 0.d0 !$OMP PARALLEL DEFAULT (NONE) & !$OMP PRIVATE (ipoint, i, j, i_1s, i_fit, r, coef, beta, B_center, & !$OMP coef_fit, expo_fit, int_fit, tmp) & - !$OMP SHARED (n_points_final_grid, ao_num, List_all_comb_b2_size, & + !$OMP SHARED (n_points_final_grid, ao_num, List_env1s_size, & !$OMP final_grid_points, ng_fit_jast, & !$OMP expo_gauss_j_mu_x, coef_gauss_j_mu_x, & - !$OMP List_all_comb_b2_coef, List_all_comb_b2_expo, & - !$OMP List_all_comb_b2_cent, v_ij_u_cst_mu_j1b_fit) + !$OMP List_env1s_coef, List_env1s_expo, & + !$OMP List_env1s_cent, v_ij_u_cst_mu_env_fit) !$OMP DO do ipoint = 1, n_points_final_grid r(1) = final_grid_points(1,ipoint) @@ -247,11 +248,11 @@ BEGIN_PROVIDER [ double precision, v_ij_u_cst_mu_j1b_fit, (ao_num, ao_num, n_poi ! --- - coef = List_all_comb_b2_coef (1) - beta = List_all_comb_b2_expo (1) - B_center(1) = List_all_comb_b2_cent(1,1) - B_center(2) = List_all_comb_b2_cent(2,1) - B_center(3) = List_all_comb_b2_cent(3,1) + coef = List_env1s_coef (1) + beta = List_env1s_expo (1) + B_center(1) = List_env1s_cent(1,1) + B_center(2) = List_env1s_cent(2,1) + B_center(3) = List_env1s_cent(3,1) int_fit = overlap_gauss_r12_ao_with1s(B_center, beta, r, expo_fit, i, j) @@ -259,14 +260,14 @@ BEGIN_PROVIDER [ double precision, v_ij_u_cst_mu_j1b_fit, (ao_num, ao_num, n_poi ! --- - do i_1s = 2, List_all_comb_b2_size + do i_1s = 2, List_env1s_size - coef = List_all_comb_b2_coef (i_1s) + coef = List_env1s_coef (i_1s) if(dabs(coef) .lt. 1d-15) cycle ! beta = 0.0 - beta = List_all_comb_b2_expo (i_1s) - B_center(1) = List_all_comb_b2_cent(1,i_1s) - B_center(2) = List_all_comb_b2_cent(2,i_1s) - B_center(3) = List_all_comb_b2_cent(3,i_1s) + beta = List_env1s_expo (i_1s) + B_center(1) = List_env1s_cent(1,i_1s) + B_center(2) = List_env1s_cent(2,i_1s) + B_center(3) = List_env1s_cent(3,i_1s) int_fit = overlap_gauss_r12_ao_with1s(B_center, beta, r, expo_fit, i, j) @@ -277,7 +278,7 @@ BEGIN_PROVIDER [ double precision, v_ij_u_cst_mu_j1b_fit, (ao_num, ao_num, n_poi enddo - v_ij_u_cst_mu_j1b_fit(j,i,ipoint) = tmp + v_ij_u_cst_mu_env_fit(j,i,ipoint) = tmp enddo enddo enddo @@ -287,23 +288,23 @@ BEGIN_PROVIDER [ double precision, v_ij_u_cst_mu_j1b_fit, (ao_num, ao_num, n_poi do ipoint = 1, n_points_final_grid do i = 2, ao_num do j = 1, i-1 - v_ij_u_cst_mu_j1b_fit(j,i,ipoint) = v_ij_u_cst_mu_j1b_fit(i,j,ipoint) + v_ij_u_cst_mu_env_fit(j,i,ipoint) = v_ij_u_cst_mu_env_fit(i,j,ipoint) enddo enddo enddo call wall_time(wall1) - print*, ' wall time for v_ij_u_cst_mu_j1b_fit', wall1 - wall0 + print*, ' wall time for v_ij_u_cst_mu_env_fit (min) = ', (wall1 - wall0) / 60.d0 END_PROVIDER ! --- -BEGIN_PROVIDER [double precision, v_ij_u_cst_mu_j1b_an_old, (ao_num, ao_num, n_points_final_grid)] +BEGIN_PROVIDER [double precision, v_ij_u_cst_mu_env_an_old, (ao_num, ao_num, n_points_final_grid)] BEGIN_DOC ! - ! int dr2 phi_i(r2) phi_j(r2) 1s_j1b(r2) u(mu, r12) + ! int dr2 phi_i(r2) phi_j(r2) 1s_env(r2) u(mu, r12) ! END_DOC @@ -322,24 +323,24 @@ BEGIN_PROVIDER [double precision, v_ij_u_cst_mu_j1b_an_old, (ao_num, ao_num, n_p double precision, external :: overlap_gauss_r12_ao_with1s double precision, external :: NAI_pol_mult_erf_ao_with1s - print*, ' providing v_ij_u_cst_mu_j1b_an_old ...' + print*, ' providing v_ij_u_cst_mu_env_an_old ...' call wall_time(wall0) - provide mu_erf final_grid_points j1b_pen - PROVIDE List_all_comb_b2_size List_all_comb_b2_coef List_all_comb_b2_expo List_all_comb_b2_cent + provide mu_erf final_grid_points env_expo + PROVIDE List_env1s_size List_env1s_coef List_env1s_expo List_env1s_cent ct = inv_sq_pi_2 / mu_erf - v_ij_u_cst_mu_j1b_an_old = 0.d0 + v_ij_u_cst_mu_env_an_old = 0.d0 !$OMP PARALLEL DEFAULT (NONE) & !$OMP PRIVATE (ipoint, i, j, i_1s, r, coef, beta, B_center, & !$OMP r1_2, tmp, int_c1, int_e1, int_o, int_c2, & !$OMP int_e2, int_c3, int_e3) & - !$OMP SHARED (n_points_final_grid, ao_num, List_all_comb_b2_size, & + !$OMP SHARED (n_points_final_grid, ao_num, List_env1s_size, & !$OMP final_grid_points, mu_erf, ct, & - !$OMP List_all_comb_b2_coef, List_all_comb_b2_expo, & - !$OMP List_all_comb_b2_cent, v_ij_u_cst_mu_j1b_an_old) + !$OMP List_env1s_coef, List_env1s_expo, & + !$OMP List_env1s_cent, v_ij_u_cst_mu_env_an_old) !$OMP DO do ipoint = 1, n_points_final_grid @@ -353,11 +354,11 @@ BEGIN_PROVIDER [double precision, v_ij_u_cst_mu_j1b_an_old, (ao_num, ao_num, n_p ! --- - coef = List_all_comb_b2_coef (1) - beta = List_all_comb_b2_expo (1) - B_center(1) = List_all_comb_b2_cent(1,1) - B_center(2) = List_all_comb_b2_cent(2,1) - B_center(3) = List_all_comb_b2_cent(3,1) + coef = List_env1s_coef (1) + beta = List_env1s_expo (1) + B_center(1) = List_env1s_cent(1,1) + B_center(2) = List_env1s_cent(2,1) + B_center(3) = List_env1s_cent(3,1) int_c1 = NAI_pol_mult_erf_ao_with1s(i, j, beta, B_center, 1.d+9, r) int_e1 = NAI_pol_mult_erf_ao_with1s(i, j, beta, B_center, mu_erf, r) @@ -379,14 +380,14 @@ BEGIN_PROVIDER [double precision, v_ij_u_cst_mu_j1b_an_old, (ao_num, ao_num, n_p ! --- - do i_1s = 2, List_all_comb_b2_size + do i_1s = 2, List_env1s_size - coef = List_all_comb_b2_coef (i_1s) + coef = List_env1s_coef (i_1s) if(dabs(coef) .lt. 1d-15) cycle ! beta = 0.0 - beta = List_all_comb_b2_expo (i_1s) - B_center(1) = List_all_comb_b2_cent(1,i_1s) - B_center(2) = List_all_comb_b2_cent(2,i_1s) - B_center(3) = List_all_comb_b2_cent(3,i_1s) + beta = List_env1s_expo (i_1s) + B_center(1) = List_env1s_cent(1,i_1s) + B_center(2) = List_env1s_cent(2,i_1s) + B_center(3) = List_env1s_cent(3,i_1s) int_c1 = NAI_pol_mult_erf_ao_with1s(i, j, beta, B_center, 1.d+9, r) int_e1 = NAI_pol_mult_erf_ao_with1s(i, j, beta, B_center, mu_erf, r) @@ -410,7 +411,7 @@ BEGIN_PROVIDER [double precision, v_ij_u_cst_mu_j1b_an_old, (ao_num, ao_num, n_p ! --- - v_ij_u_cst_mu_j1b_an_old(j,i,ipoint) = tmp + v_ij_u_cst_mu_env_an_old(j,i,ipoint) = tmp enddo enddo enddo @@ -420,23 +421,23 @@ BEGIN_PROVIDER [double precision, v_ij_u_cst_mu_j1b_an_old, (ao_num, ao_num, n_p do ipoint = 1, n_points_final_grid do i = 2, ao_num do j = 1, i-1 - v_ij_u_cst_mu_j1b_an_old(j,i,ipoint) = v_ij_u_cst_mu_j1b_an_old(i,j,ipoint) + v_ij_u_cst_mu_env_an_old(j,i,ipoint) = v_ij_u_cst_mu_env_an_old(i,j,ipoint) enddo enddo enddo call wall_time(wall1) - print*, ' wall time for v_ij_u_cst_mu_j1b_an_old', wall1 - wall0 + print*, ' wall time for v_ij_u_cst_mu_env_an_old (min) = ', (wall1 - wall0) / 60.d0 END_PROVIDER ! --- -BEGIN_PROVIDER [double precision, v_ij_u_cst_mu_j1b_an, (ao_num, ao_num, n_points_final_grid)] +BEGIN_PROVIDER [double precision, v_ij_u_cst_mu_env_an, (ao_num, ao_num, n_points_final_grid)] BEGIN_DOC ! - ! int dr2 phi_i(r2) phi_j(r2) 1s_j1b(r2) u(mu, r12) + ! int dr2 phi_i(r2) phi_j(r2) 1s_env(r2) u(mu, r12) ! END_DOC @@ -454,23 +455,23 @@ BEGIN_PROVIDER [double precision, v_ij_u_cst_mu_j1b_an, (ao_num, ao_num, n_point double precision, external :: overlap_gauss_r12_ao_with1s double precision, external :: NAI_pol_mult_erf_ao_with1s - print*, ' providing v_ij_u_cst_mu_j1b_an ...' + print*, ' providing v_ij_u_cst_mu_env_an ...' call wall_time(wall0) - provide mu_erf final_grid_points j1b_pen - PROVIDE List_all_comb_b2_size List_all_comb_b2_coef List_all_comb_b2_expo List_all_comb_b2_cent + provide mu_erf final_grid_points env_expo + PROVIDE List_env1s_size List_env1s_coef List_env1s_expo List_env1s_cent ct = inv_sq_pi_2 / mu_erf - v_ij_u_cst_mu_j1b_an = 0.d0 + v_ij_u_cst_mu_env_an = 0.d0 !$OMP PARALLEL DEFAULT (NONE) & !$OMP PRIVATE (ipoint, i, j, i_1s, r, coef, beta, B_center, & !$OMP r1_2, tmp, int_c, int_e, int_o) & - !$OMP SHARED (n_points_final_grid, ao_num, List_all_comb_b2_size, & + !$OMP SHARED (n_points_final_grid, ao_num, List_env1s_size, & !$OMP final_grid_points, mu_erf, ct, & - !$OMP List_all_comb_b2_coef, List_all_comb_b2_expo, & - !$OMP List_all_comb_b2_cent, v_ij_u_cst_mu_j1b_an) + !$OMP List_env1s_coef, List_env1s_expo, & + !$OMP List_env1s_cent, v_ij_u_cst_mu_env_an) !$OMP DO do ipoint = 1, n_points_final_grid @@ -484,11 +485,11 @@ BEGIN_PROVIDER [double precision, v_ij_u_cst_mu_j1b_an, (ao_num, ao_num, n_point ! --- - coef = List_all_comb_b2_coef (1) - beta = List_all_comb_b2_expo (1) - B_center(1) = List_all_comb_b2_cent(1,1) - B_center(2) = List_all_comb_b2_cent(2,1) - B_center(3) = List_all_comb_b2_cent(3,1) + coef = List_env1s_coef (1) + beta = List_env1s_expo (1) + B_center(1) = List_env1s_cent(1,1) + B_center(2) = List_env1s_cent(2,1) + B_center(3) = List_env1s_cent(3,1) call NAI_pol_012_mult_erf_ao_with1s(i, j, beta, B_center, 1.d+9, r, int_c) call NAI_pol_012_mult_erf_ao_with1s(i, j, beta, B_center, mu_erf, r, int_e) @@ -504,14 +505,14 @@ BEGIN_PROVIDER [double precision, v_ij_u_cst_mu_j1b_an, (ao_num, ao_num, n_point ! --- - do i_1s = 2, List_all_comb_b2_size + do i_1s = 2, List_env1s_size - coef = List_all_comb_b2_coef (i_1s) + coef = List_env1s_coef (i_1s) if(dabs(coef) .lt. 1d-15) cycle ! beta = 0.0 - beta = List_all_comb_b2_expo (i_1s) - B_center(1) = List_all_comb_b2_cent(1,i_1s) - B_center(2) = List_all_comb_b2_cent(2,i_1s) - B_center(3) = List_all_comb_b2_cent(3,i_1s) + beta = List_env1s_expo (i_1s) + B_center(1) = List_env1s_cent(1,i_1s) + B_center(2) = List_env1s_cent(2,i_1s) + B_center(3) = List_env1s_cent(3,i_1s) call NAI_pol_012_mult_erf_ao_with1s(i, j, beta, B_center, 1.d+9, r, int_c) call NAI_pol_012_mult_erf_ao_with1s(i, j, beta, B_center, mu_erf, r, int_e) @@ -529,7 +530,7 @@ BEGIN_PROVIDER [double precision, v_ij_u_cst_mu_j1b_an, (ao_num, ao_num, n_point ! --- - v_ij_u_cst_mu_j1b_an(j,i,ipoint) = tmp + v_ij_u_cst_mu_env_an(j,i,ipoint) = tmp enddo enddo enddo @@ -539,13 +540,13 @@ BEGIN_PROVIDER [double precision, v_ij_u_cst_mu_j1b_an, (ao_num, ao_num, n_point do ipoint = 1, n_points_final_grid do i = 2, ao_num do j = 1, i-1 - v_ij_u_cst_mu_j1b_an(j,i,ipoint) = v_ij_u_cst_mu_j1b_an(i,j,ipoint) + v_ij_u_cst_mu_env_an(j,i,ipoint) = v_ij_u_cst_mu_env_an(i,j,ipoint) enddo enddo enddo call wall_time(wall1) - print*, ' wall time for v_ij_u_cst_mu_j1b_an', wall1 - wall0 + print*, ' wall time for v_ij_u_cst_mu_env_an (min) = ', (wall1 - wall0) / 60.d0 END_PROVIDER diff --git a/src/ao_many_one_e_ints/grad_related_ints.irp.f b/plugins/local/ao_many_one_e_ints/grad_related_ints.irp.f similarity index 100% rename from src/ao_many_one_e_ints/grad_related_ints.irp.f rename to plugins/local/ao_many_one_e_ints/grad_related_ints.irp.f diff --git a/plugins/local/ao_many_one_e_ints/lin_fc_rsdft.irp.f b/plugins/local/ao_many_one_e_ints/lin_fc_rsdft.irp.f new file mode 100644 index 00000000..3483872b --- /dev/null +++ b/plugins/local/ao_many_one_e_ints/lin_fc_rsdft.irp.f @@ -0,0 +1,574 @@ + +! --- + + BEGIN_PROVIDER [double precision, Ir2_Mu_long_Du_0, (ao_num, ao_num, n_points_final_grid)] +&BEGIN_PROVIDER [double precision, Ir2_Mu_long_Du_x, (ao_num, ao_num, n_points_final_grid)] +&BEGIN_PROVIDER [double precision, Ir2_Mu_long_Du_y, (ao_num, ao_num, n_points_final_grid)] +&BEGIN_PROVIDER [double precision, Ir2_Mu_long_Du_z, (ao_num, ao_num, n_points_final_grid)] +&BEGIN_PROVIDER [double precision, Ir2_Mu_long_Du_2, (ao_num, ao_num, n_points_final_grid)] + + BEGIN_DOC + ! + ! Ir2_Mu_long_Du_0 = int dr2 phi_i(r2) phi_j(r2) fc_env(r2) [(1 - erf(mu r_12) / r_12] + ! + ! Ir2_Mu_long_Du_x = int dr2 phi_i(r2) phi_j(r2) fc_env(r2) [(1 - erf(mu r_12) / r_12] * x2 + ! Ir2_Mu_long_Du_y = int dr2 phi_i(r2) phi_j(r2) fc_env(r2) [(1 - erf(mu r_12) / r_12] * y2 + ! Ir2_Mu_long_Du_z = int dr2 phi_i(r2) phi_j(r2) fc_env(r2) [(1 - erf(mu r_12) / r_12] * z2 + ! + ! Ir2_Mu_long_Du_2 = int dr2 phi_i(r2) phi_j(r2) fc_env(r2) [(1 - erf(mu r_12) / r_12] * r2^2 + ! + END_DOC + + implicit none + + integer :: i, j, ipoint, i_1s + double precision :: r(3), int_clb(7), int_erf(7) + double precision :: c_1s, e_1s, R_1s(3) + double precision :: tmp_Du_0, tmp_Du_x, tmp_Du_y, tmp_Du_z, tmp_Du_2 + double precision :: wall0, wall1 + + PROVIDE mu_erf + PROVIDE final_grid_points + PROVIDE List_env1s_size List_env1s_expo List_env1s_coef List_env1s_cent + + + print *, ' providing Ir2_Mu_long_Du ...' + call wall_time(wall0) + + !$OMP PARALLEL DEFAULT (NONE) & + !$OMP PRIVATE (ipoint, i, j, i_1s, r, c_1s, e_1s, R_1s, int_erf, int_clb, & + !$OMP tmp_Du_0, tmp_Du_x, tmp_Du_y, tmp_Du_z, tmp_Du_2) & + !$OMP SHARED (n_points_final_grid, ao_num, final_grid_points, mu_erf, & + !$OMP List_env1s_size, List_env1s_expo, & + !$OMP List_env1s_coef, List_env1s_cent, & + !$OMP Ir2_Mu_long_Du_0, Ir2_Mu_long_Du_x, & + !$OMP Ir2_Mu_long_Du_y, Ir2_Mu_long_Du_z, & + !$OMP Ir2_Mu_long_Du_2) + !$OMP DO + do ipoint = 1, n_points_final_grid + + r(1) = final_grid_points(1,ipoint) + r(2) = final_grid_points(2,ipoint) + r(3) = final_grid_points(3,ipoint) + + do i = 1, ao_num + do j = i, ao_num + + call NAI_pol_012_mult_erf_ao(i, j, 1.d+9, r, int_clb) + call NAI_pol_012_mult_erf_ao(i, j, mu_erf, r, int_erf) + + tmp_Du_0 = int_clb(1) - int_erf(1) + tmp_Du_x = int_clb(2) - int_erf(2) + tmp_Du_y = int_clb(3) - int_erf(3) + tmp_Du_z = int_clb(4) - int_erf(4) + tmp_Du_2 = int_clb(5) + int_clb(6) + int_clb(7) - int_erf(5) - int_erf(6) - int_erf(7) + + do i_1s = 2, List_env1s_size + + e_1s = List_env1s_expo(i_1s) + c_1s = List_env1s_coef(i_1s) + R_1s(1) = List_env1s_cent(1,i_1s) + R_1s(2) = List_env1s_cent(2,i_1s) + R_1s(3) = List_env1s_cent(3,i_1s) + + call NAI_pol_012_mult_erf_ao_with1s(i, j, e_1s, R_1s, 1.d+9, r, int_clb) + call NAI_pol_012_mult_erf_ao_with1s(i, j, e_1s, R_1s, mu_erf, r, int_erf) + + tmp_Du_0 = tmp_Du_0 + c_1s * (int_clb(1) - int_erf(1)) + tmp_Du_x = tmp_Du_x + c_1s * (int_clb(2) - int_erf(2)) + tmp_Du_y = tmp_Du_y + c_1s * (int_clb(3) - int_erf(3)) + tmp_Du_z = tmp_Du_z + c_1s * (int_clb(4) - int_erf(4)) + tmp_Du_2 = tmp_Du_2 + c_1s * (int_clb(5) + int_clb(6) + int_clb(7) - int_erf(5) - int_erf(6) - int_erf(7)) + enddo + + Ir2_Mu_long_Du_0(j,i,ipoint) = tmp_Du_0 + Ir2_Mu_long_Du_x(j,i,ipoint) = tmp_Du_x + Ir2_Mu_long_Du_y(j,i,ipoint) = tmp_Du_y + Ir2_Mu_long_Du_z(j,i,ipoint) = tmp_Du_z + Ir2_Mu_long_Du_2(j,i,ipoint) = tmp_Du_2 + enddo + enddo + enddo + !$OMP END DO + !$OMP END PARALLEL + + do ipoint = 1, n_points_final_grid + do i = 2, ao_num + do j = 1, i-1 + Ir2_Mu_long_Du_0(j,i,ipoint) = Ir2_Mu_long_Du_0(i,j,ipoint) + Ir2_Mu_long_Du_x(j,i,ipoint) = Ir2_Mu_long_Du_x(i,j,ipoint) + Ir2_Mu_long_Du_y(j,i,ipoint) = Ir2_Mu_long_Du_y(i,j,ipoint) + Ir2_Mu_long_Du_z(j,i,ipoint) = Ir2_Mu_long_Du_z(i,j,ipoint) + Ir2_Mu_long_Du_2(j,i,ipoint) = Ir2_Mu_long_Du_2(i,j,ipoint) + enddo + enddo + enddo + + call wall_time(wall1) + print*, ' wall time for Ir2_Mu_long_Du (min) = ', (wall1 - wall0) / 60.d0 + +END_PROVIDER + +! --- + +BEGIN_PROVIDER [double precision, Ir2_Mu_gauss_Du, (ao_num, ao_num, n_points_final_grid)] + + BEGIN_DOC + ! + ! Ir2_Mu_gauss_Du = int dr2 phi_i(r2) phi_j(r2) fc_env(r2) e^{-(mu r_12)^2} + ! + END_DOC + + implicit none + + integer :: i, j, ipoint, i_1s + double precision :: r(3) + double precision :: coef, beta, B_center(3) + double precision :: tmp_Du + double precision :: mu_sq, dx, dy, dz, tmp_arg, rmu_sq(3) + double precision :: e_1s, c_1s, R_1s(3) + double precision :: wall0, wall1 + + double precision, external :: overlap_gauss_r12_ao + + PROVIDE mu_erf + PROVIDE final_grid_points + PROVIDE List_env1s_size List_env1s_expo List_env1s_coef List_env1s_cent + + + print *, ' providing Ir2_Mu_gauss_Du ...' + call wall_time(wall0) + + mu_sq = mu_erf * mu_erf + + !$OMP PARALLEL DEFAULT (NONE) & + !$OMP PRIVATE (ipoint, i, j, i_1s, dx, dy, dz, r, tmp_arg, coef, & + !$OMP rmu_sq, e_1s, c_1s, R_1s, beta, B_center, tmp_Du) & + !$OMP SHARED (n_points_final_grid, ao_num, final_grid_points, mu_sq, & + !$OMP List_env1s_size, List_env1s_expo, & + !$OMP List_env1s_coef, List_env1s_cent, & + !$OMP Ir2_Mu_gauss_Du) + !$OMP DO + do ipoint = 1, n_points_final_grid + + r(1) = final_grid_points(1,ipoint) + r(2) = final_grid_points(2,ipoint) + r(3) = final_grid_points(3,ipoint) + + rmu_sq(1) = mu_sq * r(1) + rmu_sq(2) = mu_sq * r(2) + rmu_sq(3) = mu_sq * r(3) + + do i = 1, ao_num + do j = i, ao_num + + tmp_Du = overlap_gauss_r12_ao(r, mu_sq, j, i) + + do i_1s = 2, List_env1s_size + + e_1s = List_env1s_expo(i_1s) + c_1s = List_env1s_coef(i_1s) + R_1s(1) = List_env1s_cent(1,i_1s) + R_1s(2) = List_env1s_cent(2,i_1s) + R_1s(3) = List_env1s_cent(3,i_1s) + + dx = r(1) - R_1s(1) + dy = r(2) - R_1s(2) + dz = r(3) - R_1s(3) + + beta = mu_sq + e_1s + tmp_arg = mu_sq * e_1s * (dx*dx + dy*dy + dz*dz) / beta + coef = c_1s * dexp(-tmp_arg) + B_center(1) = (rmu_sq(1) + e_1s * R_1s(1)) / beta + B_center(2) = (rmu_sq(2) + e_1s * R_1s(2)) / beta + B_center(3) = (rmu_sq(3) + e_1s * R_1s(3)) / beta + + tmp_Du += coef * overlap_gauss_r12_ao(B_center, beta, j, i) + enddo + + Ir2_Mu_gauss_Du(j,i,ipoint) = tmp_Du + enddo + enddo + enddo + !$OMP END DO + !$OMP END PARALLEL + + do ipoint = 1, n_points_final_grid + do i = 2, ao_num + do j = 1, i-1 + + Ir2_Mu_gauss_Du(j,i,ipoint) = Ir2_Mu_gauss_Du(i,j,ipoint) + enddo + enddo + enddo + + call wall_time(wall1) + print*, ' wall time for Ir2_Mu_gauss_Du (min) = ', (wall1 - wall0) / 60.d0 + +END_PROVIDER + +! --- + + BEGIN_PROVIDER [double precision, Ir2_Mu_long_Du2_0, (ao_num, ao_num, n_points_final_grid)] +&BEGIN_PROVIDER [double precision, Ir2_Mu_long_Du2_x, (ao_num, ao_num, n_points_final_grid)] +&BEGIN_PROVIDER [double precision, Ir2_Mu_long_Du2_y, (ao_num, ao_num, n_points_final_grid)] +&BEGIN_PROVIDER [double precision, Ir2_Mu_long_Du2_z, (ao_num, ao_num, n_points_final_grid)] +&BEGIN_PROVIDER [double precision, Ir2_Mu_long_Du2_2, (ao_num, ao_num, n_points_final_grid)] + + BEGIN_DOC + ! + ! Ir2_Mu_long_Du2_0 = int dr2 phi_i(r2) phi_j(r2) [fc_env(r2)]^2 [(1 - erf(mu r_12) / r_12] + ! + ! Ir2_Mu_long_Du2_x = int dr2 phi_i(r2) phi_j(r2) [fc_env(r2)]^2 [(1 - erf(mu r_12) / r_12] * x2 + ! Ir2_Mu_long_Du2_y = int dr2 phi_i(r2) phi_j(r2) [fc_env(r2)]^2 [(1 - erf(mu r_12) / r_12] * y2 + ! Ir2_Mu_long_Du2_z = int dr2 phi_i(r2) phi_j(r2) [fc_env(r2)]^2 [(1 - erf(mu r_12) / r_12] * z2 + ! + ! Ir2_Mu_long_Du2_2 = int dr2 phi_i(r2) phi_j(r2) [fc_env(r2)]^2 [(1 - erf(mu r_12) / r_12] * r2^2 + ! + END_DOC + + implicit none + + integer :: i, j, ipoint, i_1s + double precision :: r(3), int_clb(7), int_erf(7) + double precision :: coef, beta, B_center(3) + double precision :: tmp_Du2_0, tmp_Du2_x, tmp_Du2_y, tmp_Du2_z, tmp_Du2_2 + double precision :: mu_sq, tmp_arg, dx, dy, dz, rmu_sq(3) + double precision :: e_1s, c_1s, R_1s(3) + double precision :: wall0, wall1 + + + PROVIDE mu_erf + PROVIDE final_grid_points + PROVIDE List_env1s_square_size List_env1s_square_expo List_env1s_square_coef List_env1s_square_cent + + print *, ' providing Ir2_Mu_long_Du2 ...' + call wall_time(wall0) + + mu_sq = mu_erf * mu_erf + + !$OMP PARALLEL DEFAULT (NONE) & + !$OMP PRIVATE (ipoint, i, j, i_1s, r, rmu_sq, dx, dy, dz, & + !$OMP e_1s, c_1s, R_1s, tmp_arg, coef, beta, B_center, & + !$OMP int_erf, int_clb, & + !$OMP tmp_Du2_0, tmp_Du2_x, tmp_Du2_y, tmp_Du2_z, tmp_Du2_2) & + !$OMP SHARED (n_points_final_grid, ao_num, final_grid_points, mu_sq, & + !$OMP mu_erf, List_env1s_square_size, List_env1s_square_expo, & + !$OMP List_env1s_square_coef, List_env1s_square_cent, & + !$OMP Ir2_Mu_long_Du2_0, Ir2_Mu_long_Du2_x, & + !$OMP Ir2_Mu_long_Du2_y, Ir2_Mu_long_Du2_z, & + !$OMP Ir2_Mu_long_Du2_2) + !$OMP DO + do ipoint = 1, n_points_final_grid + + r(1) = final_grid_points(1,ipoint) + r(2) = final_grid_points(2,ipoint) + r(3) = final_grid_points(3,ipoint) + + rmu_sq(1) = mu_sq * r(1) + rmu_sq(2) = mu_sq * r(2) + rmu_sq(3) = mu_sq * r(3) + + do i = 1, ao_num + do j = i, ao_num + + call NAI_pol_012_mult_erf_ao_with1s(i, j, mu_sq, r, 1.d+9, r, int_clb) + call NAI_pol_012_mult_erf_ao_with1s(i, j, mu_sq, r, mu_erf, r, int_erf) + + tmp_Du2_0 = int_clb(1) - int_erf(1) + tmp_Du2_x = int_clb(2) - int_erf(2) + tmp_Du2_y = int_clb(3) - int_erf(3) + tmp_Du2_z = int_clb(4) - int_erf(4) + tmp_Du2_2 = int_clb(5) + int_clb(6) + int_clb(7) - int_erf(5) - int_erf(6) - int_erf(7) + + do i_1s = 2, List_env1s_square_size + + e_1s = List_env1s_square_expo(i_1s) + c_1s = List_env1s_square_coef(i_1s) + R_1s(1) = List_env1s_square_cent(1,i_1s) + R_1s(2) = List_env1s_square_cent(2,i_1s) + R_1s(3) = List_env1s_square_cent(3,i_1s) + + dx = r(1) - R_1s(1) + dy = r(2) - R_1s(2) + dz = r(3) - R_1s(3) + + beta = mu_sq + e_1s + tmp_arg = mu_sq * e_1s * (dx*dx + dy*dy + dz*dz) / beta + coef = c_1s * dexp(-tmp_arg) + B_center(1) = (rmu_sq(1) + e_1s * R_1s(1)) / beta + B_center(2) = (rmu_sq(2) + e_1s * R_1s(2)) / beta + B_center(3) = (rmu_sq(3) + e_1s * R_1s(3)) / beta + + call NAI_pol_012_mult_erf_ao_with1s(i, j, beta, B_center, 1.d+9, r, int_clb) + call NAI_pol_012_mult_erf_ao_with1s(i, j, beta, B_center, mu_erf, r, int_erf) + + tmp_Du2_0 = tmp_Du2_0 + coef * (int_clb(1) - int_erf(1)) + tmp_Du2_x = tmp_Du2_x + coef * (int_clb(2) - int_erf(2)) + tmp_Du2_y = tmp_Du2_y + coef * (int_clb(3) - int_erf(3)) + tmp_Du2_z = tmp_Du2_z + coef * (int_clb(4) - int_erf(4)) + tmp_Du2_2 = tmp_Du2_2 + coef * (int_clb(5) + int_clb(6) + int_clb(7) - int_erf(5) - int_erf(6) - int_erf(7)) + enddo + + Ir2_Mu_long_Du2_0(j,i,ipoint) = tmp_Du2_0 + Ir2_Mu_long_Du2_x(j,i,ipoint) = tmp_Du2_x + Ir2_Mu_long_Du2_y(j,i,ipoint) = tmp_Du2_y + Ir2_Mu_long_Du2_z(j,i,ipoint) = tmp_Du2_z + Ir2_Mu_long_Du2_2(j,i,ipoint) = tmp_Du2_2 + enddo + enddo + enddo + !$OMP END DO + !$OMP END PARALLEL + + do ipoint = 1, n_points_final_grid + do i = 2, ao_num + do j = 1, i-1 + Ir2_Mu_long_Du2_0(j,i,ipoint) = Ir2_Mu_long_Du2_0(i,j,ipoint) + Ir2_Mu_long_Du2_x(j,i,ipoint) = Ir2_Mu_long_Du2_x(i,j,ipoint) + Ir2_Mu_long_Du2_y(j,i,ipoint) = Ir2_Mu_long_Du2_y(i,j,ipoint) + Ir2_Mu_long_Du2_z(j,i,ipoint) = Ir2_Mu_long_Du2_z(i,j,ipoint) + Ir2_Mu_long_Du2_2(j,i,ipoint) = Ir2_Mu_long_Du2_2(i,j,ipoint) + enddo + enddo + enddo + + call wall_time(wall1) + print*, ' wall time for Ir2_Mu_long_Du2 (min) = ', (wall1 - wall0) / 60.d0 + +END_PROVIDER + +! --- + +BEGIN_PROVIDER [double precision, Ir2_Mu_gauss_Du2, (ao_num, ao_num, n_points_final_grid)] + + BEGIN_DOC + ! + ! Ir2_Mu_gauss_Du2 = int dr2 phi_i(r2) phi_j(r2) [fc_env(r2)]^2 e^{-(mu r_12)^2} + ! + END_DOC + + implicit none + + integer :: i, j, ipoint, i_1s + double precision :: r(3) + double precision :: coef, beta, B_center(3) + double precision :: tmp_Du2 + double precision :: mu_sq, dx, dy, dz, tmp_arg, rmu_sq(3) + double precision :: e_1s, c_1s, R_1s(3) + double precision :: wall0, wall1 + + double precision, external :: overlap_gauss_r12_ao + + PROVIDE mu_erf + PROVIDE final_grid_points + PROVIDE List_env1s_square_size List_env1s_square_expo List_env1s_square_coef List_env1s_square_cent + + + print *, ' providing Ir2_Mu_gauss_Du2 ...' + call wall_time(wall0) + + mu_sq = 2.d0 * mu_erf * mu_erf + + !$OMP PARALLEL DEFAULT (NONE) & + !$OMP PRIVATE (ipoint, i, j, i_1s, dx, dy, dz, r, tmp_arg, coef, & + !$OMP rmu_sq, e_1s, c_1s, R_1s, beta, B_center, tmp_Du2) & + !$OMP SHARED (n_points_final_grid, ao_num, final_grid_points, mu_sq, & + !$OMP List_env1s_square_size, List_env1s_square_expo, & + !$OMP List_env1s_square_coef, List_env1s_square_cent, & + !$OMP Ir2_Mu_gauss_Du2) + !$OMP DO + do ipoint = 1, n_points_final_grid + + r(1) = final_grid_points(1,ipoint) + r(2) = final_grid_points(2,ipoint) + r(3) = final_grid_points(3,ipoint) + + rmu_sq(1) = mu_sq * r(1) + rmu_sq(2) = mu_sq * r(2) + rmu_sq(3) = mu_sq * r(3) + + do i = 1, ao_num + do j = i, ao_num + + tmp_Du2 = overlap_gauss_r12_ao(r, mu_sq, j, i) + + do i_1s = 2, List_env1s_square_size + + e_1s = List_env1s_square_expo(i_1s) + c_1s = List_env1s_square_coef(i_1s) + R_1s(1) = List_env1s_square_cent(1,i_1s) + R_1s(2) = List_env1s_square_cent(2,i_1s) + R_1s(3) = List_env1s_square_cent(3,i_1s) + + dx = r(1) - R_1s(1) + dy = r(2) - R_1s(2) + dz = r(3) - R_1s(3) + + beta = mu_sq + e_1s + tmp_arg = mu_sq * e_1s * (dx*dx + dy*dy + dz*dz) / beta + coef = c_1s * dexp(-tmp_arg) + B_center(1) = (rmu_sq(1) + e_1s * R_1s(1)) / beta + B_center(2) = (rmu_sq(2) + e_1s * R_1s(2)) / beta + B_center(3) = (rmu_sq(3) + e_1s * R_1s(3)) / beta + + tmp_Du2 += coef * overlap_gauss_r12_ao(B_center, beta, j, i) + enddo + + Ir2_Mu_gauss_Du2(j,i,ipoint) = tmp_Du2 + enddo + enddo + enddo + !$OMP END DO + !$OMP END PARALLEL + + do ipoint = 1, n_points_final_grid + do i = 2, ao_num + do j = 1, i-1 + + Ir2_Mu_gauss_Du2(j,i,ipoint) = Ir2_Mu_gauss_Du2(i,j,ipoint) + enddo + enddo + enddo + + call wall_time(wall1) + print*, ' wall time for Ir2_Mu_gauss_Du2 (min) = ', (wall1 - wall0) / 60.d0 + +END_PROVIDER + +! --- + + BEGIN_PROVIDER [double precision, Ir2_Mu_short_Du2_0, (ao_num, ao_num, n_points_final_grid)] +&BEGIN_PROVIDER [double precision, Ir2_Mu_short_Du2_x, (ao_num, ao_num, n_points_final_grid)] +&BEGIN_PROVIDER [double precision, Ir2_Mu_short_Du2_y, (ao_num, ao_num, n_points_final_grid)] +&BEGIN_PROVIDER [double precision, Ir2_Mu_short_Du2_z, (ao_num, ao_num, n_points_final_grid)] +&BEGIN_PROVIDER [double precision, Ir2_Mu_short_Du2_2, (ao_num, ao_num, n_points_final_grid)] + + BEGIN_DOC + ! + ! Ir2_Mu_short_Du2_0 = int dr2 phi_i(r2) phi_j(r2) [fc_env(r2)]^2 [(1 - erf(mu r_12)]^2 + ! + ! Ir2_Mu_short_Du2_x = int dr2 phi_i(r2) phi_j(r2) [fc_env(r2)]^2 [(1 - erf(mu r_12)]^2 * x2 + ! Ir2_Mu_short_Du2_y = int dr2 phi_i(r2) phi_j(r2) [fc_env(r2)]^2 [(1 - erf(mu r_12)]^2 * y2 + ! Ir2_Mu_short_Du2_z = int dr2 phi_i(r2) phi_j(r2) [fc_env(r2)]^2 [(1 - erf(mu r_12)]^2 * z2 + ! + ! Ir2_Mu_short_Du2_2 = int dr2 phi_i(r2) phi_j(r2) [fc_env(r2)]^2 [(1 - erf(mu r_12)]^2 * r2^2 + ! + END_DOC + + implicit none + + integer :: i, j, ipoint, i_1s, i_fit + double precision :: r(3), ints(7) + double precision :: coef, beta, B_center(3) + double precision :: tmp_Du2_0, tmp_Du2_x, tmp_Du2_y, tmp_Du2_z, tmp_Du2_2 + double precision :: tmp_arg, dx, dy, dz + double precision :: expo_fit, coef_fit, e_1s, c_1s, R_1s(3) + double precision :: wall0, wall1 + + PROVIDE final_grid_points + PROVIDE List_env1s_square_size List_env1s_square_expo List_env1s_square_coef List_env1s_square_cent + PROVIDE ng_fit_jast expo_gauss_1_erf_x_2 coef_gauss_1_erf_x_2 + + print *, ' providing Ir2_Mu_short_Du2 ...' + call wall_time(wall0) + + !$OMP PARALLEL DEFAULT (NONE) & + !$OMP PRIVATE (ipoint, i, j, i_1s, i_fit, r, dx, dy, dz, & + !$OMP expo_fit, coef_fit, e_1s, c_1s, R_1s, & + !$OMP tmp_arg, coef, beta, B_center, ints, & + !$OMP tmp_Du2_0, tmp_Du2_x, tmp_Du2_y, tmp_Du2_z, tmp_Du2_2) & + !$OMP SHARED (n_points_final_grid, ao_num, final_grid_points, & + !$OMP ng_fit_jast, expo_gauss_1_erf_x_2, coef_gauss_1_erf_x_2, & + !$OMP List_env1s_square_size, List_env1s_square_expo, & + !$OMP List_env1s_square_coef, List_env1s_square_cent, & + !$OMP Ir2_Mu_short_Du2_0, Ir2_Mu_short_Du2_x, & + !$OMP Ir2_Mu_short_Du2_y, Ir2_Mu_short_Du2_z, & + !$OMP Ir2_Mu_short_Du2_2) + !$OMP DO + do ipoint = 1, n_points_final_grid + + r(1) = final_grid_points(1,ipoint) + r(2) = final_grid_points(2,ipoint) + r(3) = final_grid_points(3,ipoint) + + do i = 1, ao_num + do j = i, ao_num + + tmp_Du2_0 = 0.d0 + tmp_Du2_x = 0.d0 + tmp_Du2_y = 0.d0 + tmp_Du2_z = 0.d0 + tmp_Du2_2 = 0.d0 + do i_fit = 1, ng_fit_jast + + expo_fit = expo_gauss_1_erf_x_2(i_fit) + coef_fit = coef_gauss_1_erf_x_2(i_fit) + + call overlap_gauss_r12_ao_012(r, expo_fit, i, j, ints) + + tmp_Du2_0 += coef_fit * ints(1) + tmp_Du2_x += coef_fit * ints(2) + tmp_Du2_y += coef_fit * ints(3) + tmp_Du2_z += coef_fit * ints(4) + tmp_Du2_2 += coef_fit * (ints(5) + ints(6) + ints(7)) + + do i_1s = 2, List_env1s_square_size + + e_1s = List_env1s_square_expo(i_1s) + c_1s = List_env1s_square_coef(i_1s) + R_1s(1) = List_env1s_square_cent(1,i_1s) + R_1s(2) = List_env1s_square_cent(2,i_1s) + R_1s(3) = List_env1s_square_cent(3,i_1s) + + dx = r(1) - R_1s(1) + dy = r(2) - R_1s(2) + dz = r(3) - R_1s(3) + + beta = expo_fit + e_1s + tmp_arg = expo_fit * e_1s * (dx*dx + dy*dy + dz*dz) / beta + coef = coef_fit * c_1s * dexp(-tmp_arg) + B_center(1) = (expo_fit * r(1) + e_1s * R_1s(1)) / beta + B_center(2) = (expo_fit * r(2) + e_1s * R_1s(2)) / beta + B_center(3) = (expo_fit * r(3) + e_1s * R_1s(3)) / beta + + call overlap_gauss_r12_ao_012(B_center, beta, i, j, ints) + + tmp_Du2_0 += coef * ints(1) + tmp_Du2_x += coef * ints(2) + tmp_Du2_y += coef * ints(3) + tmp_Du2_z += coef * ints(4) + tmp_Du2_2 += coef * (ints(5) + ints(6) + ints(7)) + enddo ! i_1s + enddo ! i_fit + + Ir2_Mu_short_Du2_0(j,i,ipoint) = tmp_Du2_0 + Ir2_Mu_short_Du2_x(j,i,ipoint) = tmp_Du2_x + Ir2_Mu_short_Du2_y(j,i,ipoint) = tmp_Du2_y + Ir2_Mu_short_Du2_z(j,i,ipoint) = tmp_Du2_z + Ir2_Mu_short_Du2_2(j,i,ipoint) = tmp_Du2_2 + enddo ! j + enddo ! i + enddo ! ipoint + !$OMP END DO + !$OMP END PARALLEL + + do ipoint = 1, n_points_final_grid + do i = 2, ao_num + do j = 1, i-1 + Ir2_Mu_short_Du2_0(j,i,ipoint) = Ir2_Mu_short_Du2_0(i,j,ipoint) + Ir2_Mu_short_Du2_x(j,i,ipoint) = Ir2_Mu_short_Du2_x(i,j,ipoint) + Ir2_Mu_short_Du2_y(j,i,ipoint) = Ir2_Mu_short_Du2_y(i,j,ipoint) + Ir2_Mu_short_Du2_z(j,i,ipoint) = Ir2_Mu_short_Du2_z(i,j,ipoint) + Ir2_Mu_short_Du2_2(j,i,ipoint) = Ir2_Mu_short_Du2_2(i,j,ipoint) + enddo + enddo + enddo + + call wall_time(wall1) + print*, ' wall time for Ir2_Mu_short_Du2 (min) = ', (wall1 - wall0) / 60.d0 + +END_PROVIDER + +! --- + diff --git a/src/ao_many_one_e_ints/list_grid.irp.f b/plugins/local/ao_many_one_e_ints/list_grid.irp.f similarity index 100% rename from src/ao_many_one_e_ints/list_grid.irp.f rename to plugins/local/ao_many_one_e_ints/list_grid.irp.f diff --git a/plugins/local/ao_many_one_e_ints/listj1b_sorted.irp.f b/plugins/local/ao_many_one_e_ints/listj1b_sorted.irp.f new file mode 100644 index 00000000..ad57739b --- /dev/null +++ b/plugins/local/ao_many_one_e_ints/listj1b_sorted.irp.f @@ -0,0 +1,197 @@ + +! --- + + BEGIN_PROVIDER [integer, List_comb_thr_b2_size, (ao_num, ao_num)] +&BEGIN_PROVIDER [integer, max_List_comb_thr_b2_size] + + implicit none + integer :: i_1s, i, j, ipoint + integer :: list(ao_num) + double precision :: coef,beta,center(3),int_env + double precision :: r(3),weight,dist + + List_comb_thr_b2_size = 0 + print*,'List_env1s_size = ',List_env1s_size + + do i = 1, ao_num + do j = i, ao_num + do i_1s = 1, List_env1s_size + coef = List_env1s_coef(i_1s) + if(dabs(coef).lt.thrsh_cycle_tc) cycle + beta = List_env1s_expo(i_1s) + beta = max(beta,1.d-12) + center(1:3) = List_env1s_cent(1:3,i_1s) + int_env = 0.d0 + do ipoint = 1, n_points_extra_final_grid + r(1:3) = final_grid_points_extra(1:3,ipoint) + weight = final_weight_at_r_vector_extra(ipoint) + dist = ( center(1) - r(1) )*( center(1) - r(1) ) + dist += ( center(2) - r(2) )*( center(2) - r(2) ) + dist += ( center(3) - r(3) )*( center(3) - r(3) ) + int_env += dabs(aos_in_r_array_extra_transp(ipoint,i) * aos_in_r_array_extra_transp(ipoint,j))*dexp(-beta*dist) * weight + enddo + if(dabs(coef)*dabs(int_env).gt.thrsh_cycle_tc)then + List_comb_thr_b2_size(j,i) += 1 + endif + enddo + enddo + enddo + + do i = 1, ao_num + do j = 1, i-1 + List_comb_thr_b2_size(j,i) = List_comb_thr_b2_size(i,j) + enddo + enddo + do i = 1, ao_num + list(i) = maxval(List_comb_thr_b2_size(:,i)) + enddo + + max_List_comb_thr_b2_size = maxval(list) + print*, ' max_List_comb_thr_b2_size = ',max_List_comb_thr_b2_size + +END_PROVIDER + +! --- + + BEGIN_PROVIDER [ double precision, List_comb_thr_b2_coef, ( max_List_comb_thr_b2_size,ao_num,ao_num)] +&BEGIN_PROVIDER [ double precision, List_comb_thr_b2_expo, ( max_List_comb_thr_b2_size,ao_num,ao_num)] +&BEGIN_PROVIDER [ double precision, List_comb_thr_b2_cent, (3,max_List_comb_thr_b2_size,ao_num,ao_num)] +&BEGIN_PROVIDER [ double precision, ao_abs_comb_b2_env , ( max_List_comb_thr_b2_size,ao_num,ao_num)] + + implicit none + integer :: i_1s,i,j,ipoint,icount + double precision :: coef,beta,center(3),int_env + double precision :: r(3),weight,dist + + ao_abs_comb_b2_env = 10000000.d0 + do i = 1, ao_num + do j = i, ao_num + icount = 0 + do i_1s = 1, List_env1s_size + coef = List_env1s_coef (i_1s) + if(dabs(coef).lt.thrsh_cycle_tc)cycle + beta = List_env1s_expo (i_1s) + center(1:3) = List_env1s_cent(1:3,i_1s) + int_env = 0.d0 + do ipoint = 1, n_points_extra_final_grid + r(1:3) = final_grid_points_extra(1:3,ipoint) + weight = final_weight_at_r_vector_extra(ipoint) + dist = ( center(1) - r(1) )*( center(1) - r(1) ) + dist += ( center(2) - r(2) )*( center(2) - r(2) ) + dist += ( center(3) - r(3) )*( center(3) - r(3) ) + int_env += dabs(aos_in_r_array_extra_transp(ipoint,i) * aos_in_r_array_extra_transp(ipoint,j))*dexp(-beta*dist) * weight + enddo + if(dabs(coef)*dabs(int_env).gt.thrsh_cycle_tc)then + icount += 1 + List_comb_thr_b2_coef(icount,j,i) = coef + List_comb_thr_b2_expo(icount,j,i) = beta + List_comb_thr_b2_cent(1:3,icount,j,i) = center(1:3) + ao_abs_comb_b2_env(icount,j,i) = int_env + endif + enddo + enddo + enddo + + do i = 1, ao_num + do j = 1, i-1 + do icount = 1, List_comb_thr_b2_size(j,i) + List_comb_thr_b2_coef(icount,j,i) = List_comb_thr_b2_coef(icount,i,j) + List_comb_thr_b2_expo(icount,j,i) = List_comb_thr_b2_expo(icount,i,j) + List_comb_thr_b2_cent(1:3,icount,j,i) = List_comb_thr_b2_cent(1:3,icount,i,j) + enddo + enddo + enddo + +END_PROVIDER + +! --- + + BEGIN_PROVIDER [integer, List_comb_thr_b3_size, (ao_num,ao_num)] +&BEGIN_PROVIDER [integer, max_List_comb_thr_b3_size] + + implicit none + integer :: i_1s,i,j,ipoint + integer :: list(ao_num) + double precision :: coef,beta,center(3),int_env + double precision :: r(3),weight,dist + + List_comb_thr_b3_size = 0 + print*,'List_env1s_square_size = ',List_env1s_square_size + do i = 1, ao_num + do j = 1, ao_num + do i_1s = 1, List_env1s_square_size + coef = List_env1s_square_coef (i_1s) + beta = List_env1s_square_expo (i_1s) + center(1:3) = List_env1s_square_cent(1:3,i_1s) + if(dabs(coef).lt.thrsh_cycle_tc)cycle + int_env = 0.d0 + do ipoint = 1, n_points_extra_final_grid + r(1:3) = final_grid_points_extra(1:3,ipoint) + weight = final_weight_at_r_vector_extra(ipoint) + dist = ( center(1) - r(1) )*( center(1) - r(1) ) + dist += ( center(2) - r(2) )*( center(2) - r(2) ) + dist += ( center(3) - r(3) )*( center(3) - r(3) ) + int_env += dabs(aos_in_r_array_extra_transp(ipoint,i) * aos_in_r_array_extra_transp(ipoint,j))*dexp(-beta*dist) * weight + enddo + if(dabs(coef)*dabs(int_env).gt.thrsh_cycle_tc) then + List_comb_thr_b3_size(j,i) += 1 + endif + enddo + enddo + enddo + + do i = 1, ao_num + list(i) = maxval(List_comb_thr_b3_size(:,i)) + enddo + + max_List_comb_thr_b3_size = maxval(list) + print*, ' max_List_comb_thr_b3_size = ',max_List_comb_thr_b3_size + +END_PROVIDER + +! --- + + BEGIN_PROVIDER [double precision, List_comb_thr_b3_coef, ( max_List_comb_thr_b3_size,ao_num,ao_num)] +&BEGIN_PROVIDER [double precision, List_comb_thr_b3_expo, ( max_List_comb_thr_b3_size,ao_num,ao_num)] +&BEGIN_PROVIDER [double precision, List_comb_thr_b3_cent, (3, max_List_comb_thr_b3_size,ao_num,ao_num)] +&BEGIN_PROVIDER [double precision, ao_abs_comb_b3_env , ( max_List_comb_thr_b3_size,ao_num,ao_num)] + + implicit none + integer :: i_1s,i,j,ipoint,icount + double precision :: coef,beta,center(3),int_env + double precision :: r(3),weight,dist + + ao_abs_comb_b3_env = 10000000.d0 + do i = 1, ao_num + do j = 1, ao_num + icount = 0 + do i_1s = 1, List_env1s_square_size + coef = List_env1s_square_coef (i_1s) + beta = List_env1s_square_expo (i_1s) + beta = max(beta,1.d-12) + center(1:3) = List_env1s_square_cent(1:3,i_1s) + if(dabs(coef).lt.thrsh_cycle_tc)cycle + int_env = 0.d0 + do ipoint = 1, n_points_extra_final_grid + r(1:3) = final_grid_points_extra(1:3,ipoint) + weight = final_weight_at_r_vector_extra(ipoint) + dist = ( center(1) - r(1) )*( center(1) - r(1) ) + dist += ( center(2) - r(2) )*( center(2) - r(2) ) + dist += ( center(3) - r(3) )*( center(3) - r(3) ) + int_env += dabs(aos_in_r_array_extra_transp(ipoint,i) * aos_in_r_array_extra_transp(ipoint,j))*dexp(-beta*dist) * weight + enddo + if(dabs(coef)*dabs(int_env).gt.thrsh_cycle_tc)then + icount += 1 + List_comb_thr_b3_coef(icount,j,i) = coef + List_comb_thr_b3_expo(icount,j,i) = beta + List_comb_thr_b3_cent(1:3,icount,j,i) = center(1:3) + ao_abs_comb_b3_env(icount,j,i) = int_env + endif + enddo + enddo + enddo + +END_PROVIDER + +! --- + diff --git a/src/ao_many_one_e_ints/prim_int_erf_gauss.irp.f b/plugins/local/ao_many_one_e_ints/prim_int_erf_gauss.irp.f similarity index 100% rename from src/ao_many_one_e_ints/prim_int_erf_gauss.irp.f rename to plugins/local/ao_many_one_e_ints/prim_int_erf_gauss.irp.f diff --git a/src/ao_many_one_e_ints/prim_int_gauss_gauss.irp.f b/plugins/local/ao_many_one_e_ints/prim_int_gauss_gauss.irp.f similarity index 99% rename from src/ao_many_one_e_ints/prim_int_gauss_gauss.irp.f rename to plugins/local/ao_many_one_e_ints/prim_int_gauss_gauss.irp.f index 54c2d95b..0eaad715 100644 --- a/src/ao_many_one_e_ints/prim_int_gauss_gauss.irp.f +++ b/plugins/local/ao_many_one_e_ints/prim_int_gauss_gauss.irp.f @@ -200,7 +200,7 @@ subroutine overlap_gauss_r12_v(D_center, LD_D, delta, A_center, B_center, power_ deallocate(A_new, A_center_new, fact_a_new, iorder_a_new, overlap) -end subroutine overlap_gauss_r12_v +end !--- diff --git a/src/ao_many_one_e_ints/stg_gauss_int.irp.f b/plugins/local/ao_many_one_e_ints/stg_gauss_int.irp.f similarity index 100% rename from src/ao_many_one_e_ints/stg_gauss_int.irp.f rename to plugins/local/ao_many_one_e_ints/stg_gauss_int.irp.f diff --git a/src/ao_many_one_e_ints/taylor_exp.irp.f b/plugins/local/ao_many_one_e_ints/taylor_exp.irp.f similarity index 100% rename from src/ao_many_one_e_ints/taylor_exp.irp.f rename to plugins/local/ao_many_one_e_ints/taylor_exp.irp.f diff --git a/src/ao_many_one_e_ints/xyz_grad_xyz_ao_pol.irp.f b/plugins/local/ao_many_one_e_ints/xyz_grad_xyz_ao_pol.irp.f similarity index 100% rename from src/ao_many_one_e_ints/xyz_grad_xyz_ao_pol.irp.f rename to plugins/local/ao_many_one_e_ints/xyz_grad_xyz_ao_pol.irp.f diff --git a/src/ao_tc_eff_map/NEED b/plugins/local/ao_tc_eff_map/NEED similarity index 63% rename from src/ao_tc_eff_map/NEED rename to plugins/local/ao_tc_eff_map/NEED index d9edb325..b12b0999 100644 --- a/src/ao_tc_eff_map/NEED +++ b/plugins/local/ao_tc_eff_map/NEED @@ -1,5 +1,7 @@ -ao_two_e_erf_ints +ao_two_e_ints mo_one_e_ints ao_many_one_e_ints dft_utils_in_r tc_keywords +hamiltonian +jastrow diff --git a/src/ao_tc_eff_map/README.rst b/plugins/local/ao_tc_eff_map/README.rst similarity index 100% rename from src/ao_tc_eff_map/README.rst rename to plugins/local/ao_tc_eff_map/README.rst diff --git a/src/ao_tc_eff_map/compute_ints_eff_pot.irp.f b/plugins/local/ao_tc_eff_map/compute_ints_eff_pot.irp.f similarity index 82% rename from src/ao_tc_eff_map/compute_ints_eff_pot.irp.f rename to plugins/local/ao_tc_eff_map/compute_ints_eff_pot.irp.f index 963a49a6..8097cbc2 100644 --- a/src/ao_tc_eff_map/compute_ints_eff_pot.irp.f +++ b/plugins/local/ao_tc_eff_map/compute_ints_eff_pot.irp.f @@ -23,10 +23,9 @@ subroutine compute_ao_tc_sym_two_e_pot_jl(j, l, n_integrals, buffer_i, buffer_va logical, external :: ao_two_e_integral_zero double precision :: ao_tc_sym_two_e_pot, ao_two_e_integral_erf - double precision :: j1b_gauss_2e_j1, j1b_gauss_2e_j2 + double precision :: env_gauss_2e_j1, env_gauss_2e_j2 - PROVIDE j1b_type thr = ao_integrals_threshold @@ -53,14 +52,6 @@ subroutine compute_ao_tc_sym_two_e_pot_jl(j, l, n_integrals, buffer_i, buffer_va integral_erf = ao_two_e_integral_erf(i, k, j, l) integral = integral_erf + integral_pot - !if( j1b_type .eq. 1 ) then - ! !print *, ' j1b type 1 is added' - ! integral = integral + j1b_gauss_2e_j1(i, k, j, l) - !elseif( j1b_type .eq. 2 ) then - ! !print *, ' j1b type 2 is added' - ! integral = integral + j1b_gauss_2e_j2(i, k, j, l) - !endif - if(abs(integral) < thr) then cycle endif diff --git a/src/ao_tc_eff_map/integrals_eff_pot_in_map_slave.irp.f b/plugins/local/ao_tc_eff_map/integrals_eff_pot_in_map_slave.irp.f similarity index 100% rename from src/ao_tc_eff_map/integrals_eff_pot_in_map_slave.irp.f rename to plugins/local/ao_tc_eff_map/integrals_eff_pot_in_map_slave.irp.f diff --git a/src/ao_tc_eff_map/map_integrals_eff_pot.irp.f b/plugins/local/ao_tc_eff_map/map_integrals_eff_pot.irp.f similarity index 100% rename from src/ao_tc_eff_map/map_integrals_eff_pot.irp.f rename to plugins/local/ao_tc_eff_map/map_integrals_eff_pot.irp.f diff --git a/src/ao_tc_eff_map/one_e_1bgauss_grad2.irp.f b/plugins/local/ao_tc_eff_map/one_e_1bgauss_grad2.irp.f similarity index 65% rename from src/ao_tc_eff_map/one_e_1bgauss_grad2.irp.f rename to plugins/local/ao_tc_eff_map/one_e_1bgauss_grad2.irp.f index 50c396de..bcd2a9a5 100644 --- a/src/ao_tc_eff_map/one_e_1bgauss_grad2.irp.f +++ b/plugins/local/ao_tc_eff_map/one_e_1bgauss_grad2.irp.f @@ -1,10 +1,10 @@ ! --- -BEGIN_PROVIDER [ double precision, j1b_gauss_hermII, (ao_num,ao_num)] +BEGIN_PROVIDER [double precision, env_gauss_hermII, (ao_num,ao_num)] BEGIN_DOC ! - ! :math:`\langle \chi_A | -0.5 \grad \tau_{1b} \cdot \grad \tau_{1b} | \chi_B \rangle` + ! :math:`\langle \chi_A | -0.5 \grad \tau_{env} \cdot \grad \tau_{env} | \chi_B \rangle` ! END_DOC @@ -22,8 +22,6 @@ BEGIN_PROVIDER [ double precision, j1b_gauss_hermII, (ao_num,ao_num)] double precision :: int_gauss_4G - PROVIDE j1b_type j1b_pen j1b_coeff - ! -------------------------------------------------------------------------------- ! -- Dummy call to provide everything dim1 = 100 @@ -38,10 +36,7 @@ BEGIN_PROVIDER [ double precision, j1b_gauss_hermII, (ao_num,ao_num)] ! -------------------------------------------------------------------------------- - j1b_gauss_hermII(1:ao_num,1:ao_num) = 0.d0 - - if(j1b_type .eq. 1) then - ! \tau_1b = \sum_iA -[1 - exp(-alpha_A r_iA^2)] + env_gauss_hermII(1:ao_num,1:ao_num) = 0.d0 !$OMP PARALLEL & !$OMP DEFAULT (NONE) & @@ -51,113 +46,51 @@ BEGIN_PROVIDER [ double precision, j1b_gauss_hermII, (ao_num,ao_num)] !$OMP SHARED (ao_num, ao_prim_num, ao_expo_ordered_transp, & !$OMP ao_power, ao_nucl, nucl_coord, & !$OMP ao_coef_normalized_ordered_transp, & - !$OMP nucl_num, j1b_pen, j1b_gauss_hermII) + !$OMP nucl_num, env_expo, env_gauss_hermII) !$OMP DO SCHEDULE (dynamic) - do j = 1, ao_num - num_A = ao_nucl(j) - power_A(1:3) = ao_power(j,1:3) - A_center(1:3) = nucl_coord(num_A,1:3) - - do i = 1, ao_num - num_B = ao_nucl(i) - power_B(1:3) = ao_power(i,1:3) - B_center(1:3) = nucl_coord(num_B,1:3) - - do l = 1, ao_prim_num(j) - alpha = ao_expo_ordered_transp(l,j) - - do m = 1, ao_prim_num(i) - beta = ao_expo_ordered_transp(m,i) - - c = 0.d0 - do k1 = 1, nucl_num - gama1 = j1b_pen(k1) - C_center1(1:3) = nucl_coord(k1,1:3) - - do k2 = 1, nucl_num - gama2 = j1b_pen(k2) - C_center2(1:3) = nucl_coord(k2,1:3) - - ! < XA | exp[-gama1 r_C1^2 -gama2 r_C2^2] r_C1 \cdot r_C2 | XB > - c1 = int_gauss_4G( A_center, B_center, C_center1, C_center2 & - , power_A, power_B, alpha, beta, gama1, gama2 ) - - c = c - 2.d0 * gama1 * gama2 * c1 - enddo + do j = 1, ao_num + num_A = ao_nucl(j) + power_A(1:3) = ao_power(j,1:3) + A_center(1:3) = nucl_coord(num_A,1:3) + + do i = 1, ao_num + num_B = ao_nucl(i) + power_B(1:3) = ao_power(i,1:3) + B_center(1:3) = nucl_coord(num_B,1:3) + + do l = 1, ao_prim_num(j) + alpha = ao_expo_ordered_transp(l,j) + + do m = 1, ao_prim_num(i) + beta = ao_expo_ordered_transp(m,i) + + c = 0.d0 + do k1 = 1, nucl_num + gama1 = env_expo(k1) + C_center1(1:3) = nucl_coord(k1,1:3) + + do k2 = 1, nucl_num + gama2 = env_expo(k2) + C_center2(1:3) = nucl_coord(k2,1:3) + + ! < XA | exp[-gama1 r_C1^2 -gama2 r_C2^2] r_C1 \cdot r_C2 | XB > + c1 = int_gauss_4G( A_center, B_center, C_center1, C_center2 & + , power_A, power_B, alpha, beta, gama1, gama2 ) + + c = c - 2.d0 * gama1 * gama2 * c1 enddo - - j1b_gauss_hermII(i,j) = j1b_gauss_hermII(i,j) & - + ao_coef_normalized_ordered_transp(l,j) & - * ao_coef_normalized_ordered_transp(m,i) * c enddo + + env_gauss_hermII(i,j) = env_gauss_hermII(i,j) & + + ao_coef_normalized_ordered_transp(l,j) & + * ao_coef_normalized_ordered_transp(m,i) * c enddo enddo enddo + enddo !$OMP END DO !$OMP END PARALLEL - elseif(j1b_type .eq. 2) then - ! \tau_1b = \sum_iA [c_A exp(-alpha_A r_iA^2)] - - !$OMP PARALLEL & - !$OMP DEFAULT (NONE) & - !$OMP PRIVATE (i, j, k1, k2, l, m, alpha, beta, gama1, gama2, & - !$OMP A_center, B_center, C_center1, C_center2, & - !$OMP power_A, power_B, num_A, num_B, c1, c, & - !$OMP coef1, coef2) & - !$OMP SHARED (ao_num, ao_prim_num, ao_expo_ordered_transp, & - !$OMP ao_power, ao_nucl, nucl_coord, & - !$OMP ao_coef_normalized_ordered_transp, & - !$OMP nucl_num, j1b_pen, j1b_gauss_hermII, & - !$OMP j1b_coeff) - !$OMP DO SCHEDULE (dynamic) - do j = 1, ao_num - num_A = ao_nucl(j) - power_A(1:3) = ao_power(j,1:3) - A_center(1:3) = nucl_coord(num_A,1:3) - - do i = 1, ao_num - num_B = ao_nucl(i) - power_B(1:3) = ao_power(i,1:3) - B_center(1:3) = nucl_coord(num_B,1:3) - - do l = 1, ao_prim_num(j) - alpha = ao_expo_ordered_transp(l,j) - - do m = 1, ao_prim_num(i) - beta = ao_expo_ordered_transp(m,i) - - c = 0.d0 - do k1 = 1, nucl_num - gama1 = j1b_pen (k1) - coef1 = j1b_coeff(k1) - C_center1(1:3) = nucl_coord(k1,1:3) - - do k2 = 1, nucl_num - gama2 = j1b_pen (k2) - coef2 = j1b_coeff(k2) - C_center2(1:3) = nucl_coord(k2,1:3) - - ! < XA | exp[-gama1 r_C1^2 -gama2 r_C2^2] r_C1 \cdot r_C2 | XB > - c1 = int_gauss_4G( A_center, B_center, C_center1, C_center2 & - , power_A, power_B, alpha, beta, gama1, gama2 ) - - c = c - 2.d0 * gama1 * gama2 * coef1 * coef2 * c1 - enddo - enddo - - j1b_gauss_hermII(i,j) = j1b_gauss_hermII(i,j) & - + ao_coef_normalized_ordered_transp(l,j) & - * ao_coef_normalized_ordered_transp(m,i) * c - enddo - enddo - enddo - enddo - !$OMP END DO - !$OMP END PARALLEL - - endif - END_PROVIDER diff --git a/src/ao_tc_eff_map/one_e_1bgauss_lap.irp.f b/plugins/local/ao_tc_eff_map/one_e_1bgauss_lap.irp.f similarity index 62% rename from src/ao_tc_eff_map/one_e_1bgauss_lap.irp.f rename to plugins/local/ao_tc_eff_map/one_e_1bgauss_lap.irp.f index 0a0b7610..6c9365c9 100644 --- a/src/ao_tc_eff_map/one_e_1bgauss_lap.irp.f +++ b/plugins/local/ao_tc_eff_map/one_e_1bgauss_lap.irp.f @@ -1,10 +1,10 @@ ! --- -BEGIN_PROVIDER [ double precision, j1b_gauss_hermI, (ao_num,ao_num)] +BEGIN_PROVIDER [double precision, env_gauss_hermI, (ao_num,ao_num)] BEGIN_DOC ! - ! :math:`\langle \chi_A | -0.5 \Delta \tau_{1b} | \chi_B \rangle` + ! :math:`\langle \chi_A | -0.5 \Delta \tau_{env} | \chi_B \rangle` ! END_DOC @@ -22,8 +22,6 @@ BEGIN_PROVIDER [ double precision, j1b_gauss_hermI, (ao_num,ao_num)] double precision :: int_gauss_r0, int_gauss_r2 - PROVIDE j1b_type j1b_pen j1b_coeff - ! -------------------------------------------------------------------------------- ! -- Dummy call to provide everything dim1 = 100 @@ -37,10 +35,7 @@ BEGIN_PROVIDER [ double precision, j1b_gauss_hermI, (ao_num,ao_num)] , overlap_y, d_a_2, overlap_z, overlap, dim1 ) ! -------------------------------------------------------------------------------- - j1b_gauss_hermI(1:ao_num,1:ao_num) = 0.d0 - - if(j1b_type .eq. 1) then - ! \tau_1b = \sum_iA -[1 - exp(-alpha_A r_iA^2)] + env_gauss_hermI(1:ao_num,1:ao_num) = 0.d0 !$OMP PARALLEL & !$OMP DEFAULT (NONE) & @@ -50,109 +45,50 @@ BEGIN_PROVIDER [ double precision, j1b_gauss_hermI, (ao_num,ao_num)] !$OMP SHARED (ao_num, ao_prim_num, ao_expo_ordered_transp, & !$OMP ao_power, ao_nucl, nucl_coord, & !$OMP ao_coef_normalized_ordered_transp, & - !$OMP nucl_num, j1b_pen, j1b_gauss_hermI) + !$OMP nucl_num, env_expo, env_gauss_hermI) !$OMP DO SCHEDULE (dynamic) - do j = 1, ao_num - num_A = ao_nucl(j) - power_A(1:3) = ao_power(j,1:3) - A_center(1:3) = nucl_coord(num_A,1:3) - - do i = 1, ao_num - num_B = ao_nucl(i) - power_B(1:3) = ao_power(i,1:3) - B_center(1:3) = nucl_coord(num_B,1:3) - - do l = 1, ao_prim_num(j) - alpha = ao_expo_ordered_transp(l,j) - - do m = 1, ao_prim_num(i) - beta = ao_expo_ordered_transp(m,i) - - c = 0.d0 - do k = 1, nucl_num - gama = j1b_pen(k) - C_center(1:3) = nucl_coord(k,1:3) - - ! < XA | exp[-gama r_C^2] | XB > - c1 = int_gauss_r0( A_center, B_center, C_center & - , power_A, power_B, alpha, beta, gama ) - - ! < XA | r_A^2 exp[-gama r_C^2] | XB > - c2 = int_gauss_r2( A_center, B_center, C_center & - , power_A, power_B, alpha, beta, gama ) - - c = c + 3.d0 * gama * c1 - 2.d0 * gama * gama * c2 - enddo - - j1b_gauss_hermI(i,j) = j1b_gauss_hermI(i,j) & - + ao_coef_normalized_ordered_transp(l,j) & - * ao_coef_normalized_ordered_transp(m,i) * c + do j = 1, ao_num + num_A = ao_nucl(j) + power_A(1:3) = ao_power(j,1:3) + A_center(1:3) = nucl_coord(num_A,1:3) + + do i = 1, ao_num + num_B = ao_nucl(i) + power_B(1:3) = ao_power(i,1:3) + B_center(1:3) = nucl_coord(num_B,1:3) + + do l = 1, ao_prim_num(j) + alpha = ao_expo_ordered_transp(l,j) + + do m = 1, ao_prim_num(i) + beta = ao_expo_ordered_transp(m,i) + + c = 0.d0 + do k = 1, nucl_num + gama = env_expo(k) + C_center(1:3) = nucl_coord(k,1:3) + + ! < XA | exp[-gama r_C^2] | XB > + c1 = int_gauss_r0( A_center, B_center, C_center & + , power_A, power_B, alpha, beta, gama ) + + ! < XA | r_A^2 exp[-gama r_C^2] | XB > + c2 = int_gauss_r2( A_center, B_center, C_center & + , power_A, power_B, alpha, beta, gama ) + + c = c + 3.d0 * gama * c1 - 2.d0 * gama * gama * c2 enddo + + env_gauss_hermI(i,j) = env_gauss_hermI(i,j) & + + ao_coef_normalized_ordered_transp(l,j) & + * ao_coef_normalized_ordered_transp(m,i) * c enddo enddo enddo + enddo !$OMP END DO !$OMP END PARALLEL - elseif(j1b_type .eq. 2) then - ! \tau_1b = \sum_iA [c_A exp(-alpha_A r_iA^2)] - - !$OMP PARALLEL & - !$OMP DEFAULT (NONE) & - !$OMP PRIVATE (i, j, k, l, m, alpha, beta, gama, coef, & - !$OMP A_center, B_center, C_center, power_A, power_B, & - !$OMP num_A, num_B, c1, c2, c) & - !$OMP SHARED (ao_num, ao_prim_num, ao_expo_ordered_transp, & - !$OMP ao_power, ao_nucl, nucl_coord, & - !$OMP ao_coef_normalized_ordered_transp, & - !$OMP nucl_num, j1b_pen, j1b_gauss_hermI, & - !$OMP j1b_coeff) - !$OMP DO SCHEDULE (dynamic) - do j = 1, ao_num - num_A = ao_nucl(j) - power_A(1:3) = ao_power(j,1:3) - A_center(1:3) = nucl_coord(num_A,1:3) - - do i = 1, ao_num - num_B = ao_nucl(i) - power_B(1:3) = ao_power(i,1:3) - B_center(1:3) = nucl_coord(num_B,1:3) - - do l = 1, ao_prim_num(j) - alpha = ao_expo_ordered_transp(l,j) - - do m = 1, ao_prim_num(i) - beta = ao_expo_ordered_transp(m,i) - - c = 0.d0 - do k = 1, nucl_num - gama = j1b_pen (k) - coef = j1b_coeff(k) - C_center(1:3) = nucl_coord(k,1:3) - - ! < XA | exp[-gama r_C^2] | XB > - c1 = int_gauss_r0( A_center, B_center, C_center & - , power_A, power_B, alpha, beta, gama ) - - ! < XA | r_A^2 exp[-gama r_C^2] | XB > - c2 = int_gauss_r2( A_center, B_center, C_center & - , power_A, power_B, alpha, beta, gama ) - - c = c + 3.d0 * gama * coef * c1 - 2.d0 * gama * gama * coef * c2 - enddo - - j1b_gauss_hermI(i,j) = j1b_gauss_hermI(i,j) & - + ao_coef_normalized_ordered_transp(l,j) & - * ao_coef_normalized_ordered_transp(m,i) * c - enddo - enddo - enddo - enddo - !$OMP END DO - !$OMP END PARALLEL - - endif - END_PROVIDER diff --git a/src/ao_tc_eff_map/one_e_1bgauss_nonherm.irp.f b/plugins/local/ao_tc_eff_map/one_e_1bgauss_nonherm.irp.f similarity index 71% rename from src/ao_tc_eff_map/one_e_1bgauss_nonherm.irp.f rename to plugins/local/ao_tc_eff_map/one_e_1bgauss_nonherm.irp.f index bd881d32..0ff23716 100644 --- a/src/ao_tc_eff_map/one_e_1bgauss_nonherm.irp.f +++ b/plugins/local/ao_tc_eff_map/one_e_1bgauss_nonherm.irp.f @@ -1,10 +1,11 @@ + ! --- -BEGIN_PROVIDER [ double precision, j1b_gauss_nonherm, (ao_num,ao_num)] +BEGIN_PROVIDER [double precision, env_gauss_nonherm, (ao_num,ao_num)] BEGIN_DOC ! - ! j1b_gauss_nonherm(i,j) = \langle \chi_j | - grad \tau_{1b} \cdot grad | \chi_i \rangle + ! env_gauss_nonherm(i,j) = \langle \chi_j | - grad \tau_{env} \cdot grad | \chi_i \rangle ! END_DOC @@ -22,8 +23,6 @@ BEGIN_PROVIDER [ double precision, j1b_gauss_nonherm, (ao_num,ao_num)] double precision :: int_gauss_deriv - PROVIDE j1b_type j1b_pen j1b_coeff - ! -------------------------------------------------------------------------------- ! -- Dummy call to provide everything dim1 = 100 @@ -38,10 +37,8 @@ BEGIN_PROVIDER [ double precision, j1b_gauss_nonherm, (ao_num,ao_num)] ! -------------------------------------------------------------------------------- - j1b_gauss_nonherm(1:ao_num,1:ao_num) = 0.d0 + env_gauss_nonherm(1:ao_num,1:ao_num) = 0.d0 - if(j1b_type .eq. 1) then - ! \tau_1b = \sum_iA -[1 - exp(-alpha_A r_iA^2)] !$OMP PARALLEL & !$OMP DEFAULT (NONE) & @@ -51,101 +48,46 @@ BEGIN_PROVIDER [ double precision, j1b_gauss_nonherm, (ao_num,ao_num)] !$OMP SHARED (ao_num, ao_prim_num, ao_expo_ordered_transp, & !$OMP ao_power, ao_nucl, nucl_coord, & !$OMP ao_coef_normalized_ordered_transp, & - !$OMP nucl_num, j1b_pen, j1b_gauss_nonherm) + !$OMP nucl_num, env_expo, env_gauss_nonherm) !$OMP DO SCHEDULE (dynamic) - do j = 1, ao_num - num_A = ao_nucl(j) - power_A(1:3) = ao_power(j,1:3) - A_center(1:3) = nucl_coord(num_A,1:3) - - do i = 1, ao_num - num_B = ao_nucl(i) - power_B(1:3) = ao_power(i,1:3) - B_center(1:3) = nucl_coord(num_B,1:3) - - do l = 1, ao_prim_num(j) - alpha = ao_expo_ordered_transp(l,j) - - do m = 1, ao_prim_num(i) - beta = ao_expo_ordered_transp(m,i) - - c = 0.d0 - do k = 1, nucl_num - gama = j1b_pen(k) - C_center(1:3) = nucl_coord(k,1:3) - - ! \langle \chi_A | exp[-gama r_C^2] r_C \cdot grad | \chi_B \rangle - c1 = int_gauss_deriv( A_center, B_center, C_center & - , power_A, power_B, alpha, beta, gama ) - - c = c + 2.d0 * gama * c1 - enddo - - j1b_gauss_nonherm(i,j) = j1b_gauss_nonherm(i,j) & - + ao_coef_normalized_ordered_transp(l,j) & - * ao_coef_normalized_ordered_transp(m,i) * c + do j = 1, ao_num + num_A = ao_nucl(j) + power_A(1:3) = ao_power(j,1:3) + A_center(1:3) = nucl_coord(num_A,1:3) + + do i = 1, ao_num + num_B = ao_nucl(i) + power_B(1:3) = ao_power(i,1:3) + B_center(1:3) = nucl_coord(num_B,1:3) + + do l = 1, ao_prim_num(j) + alpha = ao_expo_ordered_transp(l,j) + + do m = 1, ao_prim_num(i) + beta = ao_expo_ordered_transp(m,i) + + c = 0.d0 + do k = 1, nucl_num + gama = env_expo(k) + C_center(1:3) = nucl_coord(k,1:3) + + ! \langle \chi_A | exp[-gama r_C^2] r_C \cdot grad | \chi_B \rangle + c1 = int_gauss_deriv( A_center, B_center, C_center & + , power_A, power_B, alpha, beta, gama ) + + c = c + 2.d0 * gama * c1 enddo + + env_gauss_nonherm(i,j) = env_gauss_nonherm(i,j) & + + ao_coef_normalized_ordered_transp(l,j) & + * ao_coef_normalized_ordered_transp(m,i) * c enddo enddo enddo + enddo !$OMP END DO !$OMP END PARALLEL - elseif(j1b_type .eq. 2) then - ! \tau_1b = \sum_iA [c_A exp(-alpha_A r_iA^2)] - - !$OMP PARALLEL & - !$OMP DEFAULT (NONE) & - !$OMP PRIVATE (i, j, k, l, m, alpha, beta, gama, coef, & - !$OMP A_center, B_center, C_center, power_A, power_B, & - !$OMP num_A, num_B, c1, c) & - !$OMP SHARED (ao_num, ao_prim_num, ao_expo_ordered_transp, & - !$OMP ao_power, ao_nucl, nucl_coord, & - !$OMP ao_coef_normalized_ordered_transp, & - !$OMP nucl_num, j1b_pen, j1b_gauss_nonherm, & - !$OMP j1b_coeff) - !$OMP DO SCHEDULE (dynamic) - do j = 1, ao_num - num_A = ao_nucl(j) - power_A(1:3) = ao_power(j,1:3) - A_center(1:3) = nucl_coord(num_A,1:3) - - do i = 1, ao_num - num_B = ao_nucl(i) - power_B(1:3) = ao_power(i,1:3) - B_center(1:3) = nucl_coord(num_B,1:3) - - do l = 1, ao_prim_num(j) - alpha = ao_expo_ordered_transp(l,j) - - do m = 1, ao_prim_num(i) - beta = ao_expo_ordered_transp(m,i) - - c = 0.d0 - do k = 1, nucl_num - gama = j1b_pen (k) - coef = j1b_coeff(k) - C_center(1:3) = nucl_coord(k,1:3) - - ! \langle \chi_A | exp[-gama r_C^2] r_C \cdot grad | \chi_B \rangle - c1 = int_gauss_deriv( A_center, B_center, C_center & - , power_A, power_B, alpha, beta, gama ) - - c = c + 2.d0 * gama * coef * c1 - enddo - - j1b_gauss_nonherm(i,j) = j1b_gauss_nonherm(i,j) & - + ao_coef_normalized_ordered_transp(l,j) & - * ao_coef_normalized_ordered_transp(m,i) * c - enddo - enddo - enddo - enddo - !$OMP END DO - !$OMP END PARALLEL - - endif - END_PROVIDER diff --git a/src/ao_tc_eff_map/providers_ao_eff_pot.irp.f b/plugins/local/ao_tc_eff_map/providers_ao_eff_pot.irp.f similarity index 96% rename from src/ao_tc_eff_map/providers_ao_eff_pot.irp.f rename to plugins/local/ao_tc_eff_map/providers_ao_eff_pot.irp.f index 055bf323..1c454e40 100644 --- a/src/ao_tc_eff_map/providers_ao_eff_pot.irp.f +++ b/plugins/local/ao_tc_eff_map/providers_ao_eff_pot.irp.f @@ -22,9 +22,6 @@ BEGIN_PROVIDER [ logical, ao_tc_sym_two_e_pot_in_map ] integer :: kk, m, j1, i1, lmax character*(64) :: fmt - !double precision :: j1b_gauss_coul_debug - !integral = j1b_gauss_coul_debug(1,1,1,1) - integral = ao_tc_sym_two_e_pot(1,1,1,1) double precision :: map_mb diff --git a/src/ao_tc_eff_map/two_e_1bgauss_j1.irp.f b/plugins/local/ao_tc_eff_map/two_e_1bgauss_j1.irp.f similarity index 98% rename from src/ao_tc_eff_map/two_e_1bgauss_j1.irp.f rename to plugins/local/ao_tc_eff_map/two_e_1bgauss_j1.irp.f index c36ee9b4..572406e2 100644 --- a/src/ao_tc_eff_map/two_e_1bgauss_j1.irp.f +++ b/plugins/local/ao_tc_eff_map/two_e_1bgauss_j1.irp.f @@ -1,6 +1,6 @@ ! --- -double precision function j1b_gauss_2e_j1(i, j, k, l) +double precision function env_gauss_2e_j1(i, j, k, l) BEGIN_DOC ! @@ -36,10 +36,10 @@ double precision function j1b_gauss_2e_j1(i, j, k, l) double precision :: I_center(3), J_center(3), K_center(3), L_center(3) double precision :: ff, gg, cx, cy, cz - double precision :: j1b_gauss_2e_j1_schwartz + double precision :: env_gauss_2e_j1_schwartz if( ao_prim_num(i) * ao_prim_num(j) * ao_prim_num(k) * ao_prim_num(l) > 1024 ) then - j1b_gauss_2e_j1 = j1b_gauss_2e_j1_schwartz(i, j, k, l) + env_gauss_2e_j1 = env_gauss_2e_j1_schwartz(i, j, k, l) return endif @@ -59,7 +59,7 @@ double precision function j1b_gauss_2e_j1(i, j, k, l) L_center(p) = nucl_coord(num_l,p) enddo - j1b_gauss_2e_j1 = 0.d0 + env_gauss_2e_j1 = 0.d0 do p = 1, ao_prim_num(i) coef1 = ao_coef_normalized_ordered_transp(p, i) @@ -89,18 +89,18 @@ double precision function j1b_gauss_2e_j1(i, j, k, l) , P1_center, P1_new, pp1, fact_p1, p1_inv, iorder_p & , Q1_center, Q1_new, qq1, fact_q1, q1_inv, iorder_q ) - j1b_gauss_2e_j1 = j1b_gauss_2e_j1 + coef4 * ( cx + cy + cz ) + env_gauss_2e_j1 = env_gauss_2e_j1 + coef4 * ( cx + cy + cz ) enddo ! s enddo ! r enddo ! q enddo ! p return -end function j1b_gauss_2e_j1 +end ! --- -double precision function j1b_gauss_2e_j1_schwartz(i, j, k, l) +double precision function env_gauss_2e_j1_schwartz(i, j, k, l) BEGIN_DOC ! @@ -137,8 +137,6 @@ double precision function j1b_gauss_2e_j1_schwartz(i, j, k, l) double precision :: schwartz_ij, thr double precision, allocatable :: schwartz_kl(:,:) - PROVIDE j1b_pen - dim1 = n_pt_max_integrals thr = ao_integrals_threshold * ao_integrals_threshold @@ -186,8 +184,7 @@ double precision function j1b_gauss_2e_j1_schwartz(i, j, k, l) schwartz_kl(0,0) = max( schwartz_kl(0,r) , schwartz_kl(0,0) ) enddo - - j1b_gauss_2e_j1_schwartz = 0.d0 + env_gauss_2e_j1_schwartz = 0.d0 do p = 1, ao_prim_num(i) expo1 = ao_expo_ordered_transp(p, i) @@ -226,7 +223,7 @@ double precision function j1b_gauss_2e_j1_schwartz(i, j, k, l) , P1_center, P1_new, pp1, fact_p1, p1_inv, iorder_p & , Q1_center, Q1_new, qq1, fact_q1, q1_inv, iorder_q ) - j1b_gauss_2e_j1_schwartz = j1b_gauss_2e_j1_schwartz + coef4 * ( cx + cy + cz ) + env_gauss_2e_j1_schwartz = env_gauss_2e_j1_schwartz + coef4 * ( cx + cy + cz ) enddo ! s enddo ! r enddo ! q @@ -235,7 +232,7 @@ double precision function j1b_gauss_2e_j1_schwartz(i, j, k, l) deallocate( schwartz_kl ) return -end function j1b_gauss_2e_j1_schwartz +end ! --- @@ -263,14 +260,12 @@ subroutine get_cxcycz_j1( dim1, cx, cy, cz & double precision :: general_primitive_integral_erf_shifted double precision :: general_primitive_integral_coul_shifted - PROVIDE j1b_pen - cx = 0.d0 cy = 0.d0 cz = 0.d0 do ii = 1, nucl_num - expoii = j1b_pen(ii) + expoii = env_expo(ii) Centerii(1:3) = nucl_coord(ii, 1:3) call gaussian_product(pp1, P1_center, expoii, Centerii, factii, pp2, P2_center) diff --git a/src/ao_tc_eff_map/two_e_1bgauss_j2.irp.f b/plugins/local/ao_tc_eff_map/two_e_1bgauss_j2.irp.f similarity index 98% rename from src/ao_tc_eff_map/two_e_1bgauss_j2.irp.f rename to plugins/local/ao_tc_eff_map/two_e_1bgauss_j2.irp.f index a61b5336..a04656c3 100644 --- a/src/ao_tc_eff_map/two_e_1bgauss_j2.irp.f +++ b/plugins/local/ao_tc_eff_map/two_e_1bgauss_j2.irp.f @@ -1,6 +1,6 @@ ! --- -double precision function j1b_gauss_2e_j2(i, j, k, l) +double precision function env_gauss_2e_j2(i, j, k, l) BEGIN_DOC ! @@ -36,12 +36,12 @@ double precision function j1b_gauss_2e_j2(i, j, k, l) double precision :: I_center(3), J_center(3), K_center(3), L_center(3) double precision :: ff, gg, cx, cy, cz - double precision :: j1b_gauss_2e_j2_schwartz + double precision :: env_gauss_2e_j2_schwartz dim1 = n_pt_max_integrals if( ao_prim_num(i) * ao_prim_num(j) * ao_prim_num(k) * ao_prim_num(l) > 1024 ) then - j1b_gauss_2e_j2 = j1b_gauss_2e_j2_schwartz(i, j, k, l) + env_gauss_2e_j2 = env_gauss_2e_j2_schwartz(i, j, k, l) return endif @@ -61,7 +61,7 @@ double precision function j1b_gauss_2e_j2(i, j, k, l) L_center(p) = nucl_coord(num_l,p) enddo - j1b_gauss_2e_j2 = 0.d0 + env_gauss_2e_j2 = 0.d0 do p = 1, ao_prim_num(i) coef1 = ao_coef_normalized_ordered_transp(p, i) @@ -91,18 +91,18 @@ double precision function j1b_gauss_2e_j2(i, j, k, l) , P1_center, P1_new, pp1, fact_p1, p1_inv, iorder_p & , Q1_center, Q1_new, qq1, fact_q1, q1_inv, iorder_q ) - j1b_gauss_2e_j2 = j1b_gauss_2e_j2 + coef4 * ( cx + cy + cz ) + env_gauss_2e_j2 = env_gauss_2e_j2 + coef4 * ( cx + cy + cz ) enddo ! s enddo ! r enddo ! q enddo ! p return -end function j1b_gauss_2e_j2 +end ! --- -double precision function j1b_gauss_2e_j2_schwartz(i, j, k, l) +double precision function env_gauss_2e_j2_schwartz(i, j, k, l) BEGIN_DOC ! @@ -187,7 +187,7 @@ double precision function j1b_gauss_2e_j2_schwartz(i, j, k, l) enddo - j1b_gauss_2e_j2_schwartz = 0.d0 + env_gauss_2e_j2_schwartz = 0.d0 do p = 1, ao_prim_num(i) expo1 = ao_expo_ordered_transp(p, i) @@ -226,7 +226,7 @@ double precision function j1b_gauss_2e_j2_schwartz(i, j, k, l) , P1_center, P1_new, pp1, fact_p1, p1_inv, iorder_p & , Q1_center, Q1_new, qq1, fact_q1, q1_inv, iorder_q ) - j1b_gauss_2e_j2_schwartz = j1b_gauss_2e_j2_schwartz + coef4 * ( cx + cy + cz ) + env_gauss_2e_j2_schwartz = env_gauss_2e_j2_schwartz + coef4 * ( cx + cy + cz ) enddo ! s enddo ! r enddo ! q @@ -235,7 +235,7 @@ double precision function j1b_gauss_2e_j2_schwartz(i, j, k, l) deallocate( schwartz_kl ) return -end function j1b_gauss_2e_j2_schwartz +end ! --- @@ -263,15 +263,13 @@ subroutine get_cxcycz_j2( dim1, cx, cy, cz & double precision :: general_primitive_integral_erf_shifted double precision :: general_primitive_integral_coul_shifted - PROVIDE j1b_pen j1b_coeff - cx = 0.d0 cy = 0.d0 cz = 0.d0 do ii = 1, nucl_num - expoii = j1b_pen (ii) - coefii = j1b_coeff(ii) + expoii = env_expo(ii) + coefii = env_coef(ii) Centerii(1:3) = nucl_coord(ii, 1:3) call gaussian_product(pp1, P1_center, expoii, Centerii, factii, pp2, P2_center) diff --git a/src/ao_tc_eff_map/two_e_ints_gauss.irp.f b/plugins/local/ao_tc_eff_map/two_e_ints_gauss.irp.f similarity index 100% rename from src/ao_tc_eff_map/two_e_ints_gauss.irp.f rename to plugins/local/ao_tc_eff_map/two_e_ints_gauss.irp.f diff --git a/src/ao_tc_eff_map/useful_sub.irp.f b/plugins/local/ao_tc_eff_map/useful_sub.irp.f similarity index 92% rename from src/ao_tc_eff_map/useful_sub.irp.f rename to plugins/local/ao_tc_eff_map/useful_sub.irp.f index 4cfdcad2..4c5efac1 100644 --- a/src/ao_tc_eff_map/useful_sub.irp.f +++ b/plugins/local/ao_tc_eff_map/useful_sub.irp.f @@ -174,7 +174,7 @@ double precision function general_primitive_integral_coul_shifted( dim general_primitive_integral_coul_shifted = fact_p * fact_q * accu * pi_5_2 * p_inv * q_inv / dsqrt(p_plus_q) return -end function general_primitive_integral_coul_shifted +end !______________________________________________________________________________________________________________________ !______________________________________________________________________________________________________________________ @@ -354,7 +354,7 @@ double precision function general_primitive_integral_erf_shifted( dim general_primitive_integral_erf_shifted = fact_p * fact_q * accu * pi_5_2 * p_inv * q_inv / dsqrt(p_plus_q) return -end function general_primitive_integral_erf_shifted +end !______________________________________________________________________________________________________________________ !______________________________________________________________________________________________________________________ @@ -362,3 +362,48 @@ end function general_primitive_integral_erf_shifted + +! --- + +subroutine inv_r_times_poly(r, dist_r, dist_vec, poly) + + BEGIN_DOC + ! + ! returns + ! + ! poly(1) = x / sqrt(x^2+y^2+z^2), poly(2) = y / sqrt(x^2+y^2+z^2), poly(3) = z / sqrt(x^2+y^2+z^2) + ! + ! with the arguments + ! + ! r(1) = x, r(2) = y, r(3) = z, dist_r = sqrt(x^2+y^2+z^2) + ! + ! dist_vec(1) = sqrt(y^2+z^2), dist_vec(2) = sqrt(x^2+z^2), dist_vec(3) = sqrt(x^2+y^2) + ! + END_DOC + + implicit none + double precision, intent(in) :: r(3), dist_r, dist_vec(3) + double precision, intent(out) :: poly(3) + integer :: i + double precision :: inv_dist + + if (dist_r .gt. 1.d-8)then + inv_dist = 1.d0/dist_r + do i = 1, 3 + poly(i) = r(i) * inv_dist + enddo + else + do i = 1, 3 + if(dabs(r(i)).lt.dist_vec(i)) then + inv_dist = 1.d0/dist_r + poly(i) = r(i) * inv_dist + else + poly(i) = 1.d0 + endif + enddo + endif + +end + +! --- + diff --git a/src/basis_correction/51.basis_c.bats b/plugins/local/basis_correction/51.basis_c.bats similarity index 93% rename from src/basis_correction/51.basis_c.bats rename to plugins/local/basis_correction/51.basis_c.bats index 2682361b..914b482b 100644 --- a/src/basis_correction/51.basis_c.bats +++ b/plugins/local/basis_correction/51.basis_c.bats @@ -10,8 +10,8 @@ function run() { qp set perturbation do_pt2 False qp set determinants n_det_max 8000 qp set determinants n_states 1 - qp set davidson threshold_davidson 1.e-10 - qp set davidson n_states_diag 8 + qp set davidson_keywords threshold_davidson 1.e-10 + qp set davidson_keywords n_states_diag 8 qp run fci energy1="$(ezfio get fci energy | tr '[]' ' ' | cut -d ',' -f 1)" eq $energy1 $1 $thresh diff --git a/src/basis_correction/NEED b/plugins/local/basis_correction/NEED similarity index 100% rename from src/basis_correction/NEED rename to plugins/local/basis_correction/NEED diff --git a/src/basis_correction/README.rst b/plugins/local/basis_correction/README.rst similarity index 94% rename from src/basis_correction/README.rst rename to plugins/local/basis_correction/README.rst index 311fec1c..7669a9b2 100644 --- a/src/basis_correction/README.rst +++ b/plugins/local/basis_correction/README.rst @@ -12,7 +12,7 @@ This basis set correction relies mainy on : When HF is a qualitative representation of the electron pairs (i.e. weakly correlated systems), such an approach for \mu(r) is OK. See for instance JPCL, 10, 2931-2937 (2019) for typical flavours of the results. Thanks to the trivial nature of such a two-body rdm, the equation (22) of J. Chem. Phys. 149, 194301 (2018) can be rewritten in a very efficient way, and therefore the limiting factor of such an approach is the AO->MO four-index transformation of the two-electron integrals. - b) "mu_of_r_potential = cas_ful" uses the two-body rdm of CAS-like wave function (i.e. linear combination of Slater determinants developped in an active space with the MOs stored in the EZFIO folder). + b) "mu_of_r_potential = cas_full" uses the two-body rdm of CAS-like wave function (i.e. linear combination of Slater determinants developped in an active space with the MOs stored in the EZFIO folder). If the CAS is properly chosen (i.e. the CAS-like wave function qualitatively represents the wave function of the systems), then such an approach is OK for \mu(r) even in the case of strong correlation. +) The use of DFT correlation functionals with multi-determinant reference (Ecmd). These functionals are originally defined in the RS-DFT framework (see for instance Theor. Chem. Acc.114, 305(2005)) and design to capture short-range correlation effects. A important quantity arising in the Ecmd is the exact on-top pair density of the system, and the main differences of approximated Ecmd relies on different approximations for the exact on-top pair density. diff --git a/src/basis_correction/TODO b/plugins/local/basis_correction/TODO similarity index 100% rename from src/basis_correction/TODO rename to plugins/local/basis_correction/TODO diff --git a/src/basis_correction/basis_correction.irp.f b/plugins/local/basis_correction/basis_correction.irp.f similarity index 100% rename from src/basis_correction/basis_correction.irp.f rename to plugins/local/basis_correction/basis_correction.irp.f diff --git a/src/basis_correction/eff_xi_based_func.irp.f b/plugins/local/basis_correction/eff_xi_based_func.irp.f similarity index 100% rename from src/basis_correction/eff_xi_based_func.irp.f rename to plugins/local/basis_correction/eff_xi_based_func.irp.f diff --git a/src/basis_correction/pbe_on_top.irp.f b/plugins/local/basis_correction/pbe_on_top.irp.f similarity index 98% rename from src/basis_correction/pbe_on_top.irp.f rename to plugins/local/basis_correction/pbe_on_top.irp.f index 9167f459..be3a23d7 100644 --- a/src/basis_correction/pbe_on_top.irp.f +++ b/plugins/local/basis_correction/pbe_on_top.irp.f @@ -39,7 +39,7 @@ grad_rho_a(1:3) = one_e_dm_and_grad_alpha_in_r(1:3,ipoint,istate) grad_rho_b(1:3) = one_e_dm_and_grad_beta_in_r(1:3,ipoint,istate) - if(mu_of_r_potential == "cas_ful")then + if(mu_of_r_potential == "cas_full")then ! You take the on-top of the CAS wave function which is computed with mu(r) on_top = on_top_cas_mu_r(ipoint,istate) else @@ -101,7 +101,7 @@ grad_rho_a(1:3) = one_e_dm_and_grad_alpha_in_r(1:3,ipoint,istate) grad_rho_b(1:3) = one_e_dm_and_grad_beta_in_r(1:3,ipoint,istate) - if(mu_of_r_potential == "cas_ful")then + if(mu_of_r_potential == "cas_full")then ! You take the on-top of the CAS wave function which is computed with mu(r) on_top = on_top_cas_mu_r(ipoint,istate) else @@ -163,7 +163,7 @@ grad_rho_a(1:3) = one_e_dm_and_grad_alpha_in_r(1:3,ipoint,istate) grad_rho_b(1:3) = one_e_dm_and_grad_beta_in_r(1:3,ipoint,istate) - if(mu_of_r_potential == "cas_ful")then + if(mu_of_r_potential == "cas_full")then ! You take the on-top of the CAS wave function which is computed with mu(r) on_top = on_top_cas_mu_r(ipoint,istate) else diff --git a/src/basis_correction/print_routine.irp.f b/plugins/local/basis_correction/print_routine.irp.f similarity index 91% rename from src/basis_correction/print_routine.irp.f rename to plugins/local/basis_correction/print_routine.irp.f index c2558d22..96faba30 100644 --- a/src/basis_correction/print_routine.irp.f +++ b/plugins/local/basis_correction/print_routine.irp.f @@ -4,8 +4,8 @@ subroutine print_basis_correction provide mu_average_prov if(mu_of_r_potential.EQ."hf")then provide ecmd_lda_mu_of_r ecmd_pbe_ueg_mu_of_r - else if(mu_of_r_potential.EQ."cas_ful".or.mu_of_r_potential.EQ."cas_truncated")then - provide ecmd_lda_mu_of_r ecmd_pbe_ueg_mu_of_r + else if(mu_of_r_potential.EQ."cas_full".or.mu_of_r_potential.EQ."cas_truncated")then + provide ecmd_lda_mu_of_r ecmd_pbe_ueg_mu_of_r provide ecmd_pbe_on_top_mu_of_r ecmd_pbe_on_top_su_mu_of_r endif @@ -25,7 +25,7 @@ subroutine print_basis_correction if(mu_of_r_potential.EQ."hf")then print*, '' print*,'Using a HF-like two-body density to define mu(r)' - print*,'This assumes that HF is a qualitative representation of the wave function ' + print*,'This assumes that HF is a qualitative representation of the wave function ' print*,'********************************************' print*,'Functionals more suited for weak correlation' print*,'********************************************' @@ -38,10 +38,10 @@ subroutine print_basis_correction write(*, '(A29,X,I3,X,A3,X,F16.10)') ' ECMD PBE-UEG , state ',istate,' = ',ecmd_pbe_ueg_mu_of_r(istate) enddo - else if(mu_of_r_potential.EQ."cas_ful".or.mu_of_r_potential.EQ."cas_truncated".or.mu_of_r_potential.EQ."pure_act")then + else if(mu_of_r_potential.EQ."cas_full".or.mu_of_r_potential.EQ."cas_truncated".or.mu_of_r_potential.EQ."pure_act")then print*, '' print*,'Using a CAS-like two-body density to define mu(r)' - print*,'This assumes that the CAS is a qualitative representation of the wave function ' + print*,'This assumes that the CAS is a qualitative representation of the wave function ' print*,'********************************************' print*,'Functionals more suited for weak correlation' print*,'********************************************' @@ -56,14 +56,14 @@ subroutine print_basis_correction print*,'' print*,'********************************************' print*,'********************************************' - print*,'+) PBE-on-top Ecmd functional : JCP, 152, 174104 (2020) ' + print*,'+) PBE-on-top Ecmd functional : JCP, 152, 174104 (2020) ' print*,'PBE at mu=0, extrapolated ontop pair density at large mu, usual spin-polarization' do istate = 1, N_states write(*, '(A29,X,I3,X,A3,X,F16.10)') ' ECMD PBE-OT , state ',istate,' = ',ecmd_pbe_on_top_mu_of_r(istate) enddo print*,'' print*,'********************************************' - print*,'+) PBE-on-top no spin polarization Ecmd functional : JCP, 152, 174104 (2020)' + print*,'+) PBE-on-top no spin polarization Ecmd functional : JCP, 152, 174104 (2020)' print*,'PBE at mu=0, extrapolated ontop pair density at large mu, and ZERO SPIN POLARIZATION' do istate = 1, N_states write(*, '(A29,X,I3,X,A3,X,F16.10)') ' ECMD SU-PBE-OT , state ',istate,' = ',ecmd_pbe_on_top_su_mu_of_r(istate) diff --git a/src/basis_correction/print_su_pbe_ot.irp.f b/plugins/local/basis_correction/print_su_pbe_ot.irp.f similarity index 100% rename from src/basis_correction/print_su_pbe_ot.irp.f rename to plugins/local/basis_correction/print_su_pbe_ot.irp.f diff --git a/src/basis_correction/weak_corr_func.irp.f b/plugins/local/basis_correction/weak_corr_func.irp.f similarity index 100% rename from src/basis_correction/weak_corr_func.irp.f rename to plugins/local/basis_correction/weak_corr_func.irp.f diff --git a/src/bi_ort_ints/NEED b/plugins/local/bi_ort_ints/NEED similarity index 100% rename from src/bi_ort_ints/NEED rename to plugins/local/bi_ort_ints/NEED diff --git a/src/bi_ort_ints/README.rst b/plugins/local/bi_ort_ints/README.rst similarity index 100% rename from src/bi_ort_ints/README.rst rename to plugins/local/bi_ort_ints/README.rst diff --git a/src/bi_ort_ints/bi_ort_ints.irp.f b/plugins/local/bi_ort_ints/bi_ort_ints.irp.f similarity index 100% rename from src/bi_ort_ints/bi_ort_ints.irp.f rename to plugins/local/bi_ort_ints/bi_ort_ints.irp.f diff --git a/src/bi_ort_ints/biorthog_mo_for_h.irp.f b/plugins/local/bi_ort_ints/biorthog_mo_for_h.irp.f similarity index 80% rename from src/bi_ort_ints/biorthog_mo_for_h.irp.f rename to plugins/local/bi_ort_ints/biorthog_mo_for_h.irp.f index 452c13f1..613a684f 100644 --- a/src/bi_ort_ints/biorthog_mo_for_h.irp.f +++ b/plugins/local/bi_ort_ints/biorthog_mo_for_h.irp.f @@ -1,4 +1,39 @@ + +! --- + +BEGIN_PROVIDER [double precision, ao_two_e_coul, (ao_num, ao_num, ao_num, ao_num) ] + + BEGIN_DOC + ! + ! ao_two_e_coul(k,i,l,j) = ( k i | 1/r12 | l j ) = < l k | 1/r12 | j i > + ! + END_DOC + + integer :: i, j, k, l + double precision, external :: get_ao_two_e_integral + + PROVIDE ao_integrals_map + + !$OMP PARALLEL DEFAULT(NONE) & + !$OMP SHARED(ao_num, ao_two_e_coul, ao_integrals_map) & + !$OMP PRIVATE(i, j, k, l) + !$OMP DO + do j = 1, ao_num + do l = 1, ao_num + do i = 1, ao_num + do k = 1, ao_num + ! < 1:k, 2:l | 1:i, 2:j > + ao_two_e_coul(k,i,l,j) = get_ao_two_e_integral(i, j, k, l, ao_integrals_map) + enddo + enddo + enddo + enddo + !$OMP END DO + !$OMP END PARALLEL + +END_PROVIDER + ! --- double precision function bi_ortho_mo_coul_ints(l, k, j, i) @@ -25,7 +60,7 @@ double precision function bi_ortho_mo_coul_ints(l, k, j, i) enddo enddo -end function bi_ortho_mo_coul_ints +end ! --- diff --git a/src/bi_ort_ints/no_dressing.irp.f b/plugins/local/bi_ort_ints/no_dressing.irp.f similarity index 100% rename from src/bi_ort_ints/no_dressing.irp.f rename to plugins/local/bi_ort_ints/no_dressing.irp.f diff --git a/src/bi_ort_ints/no_dressing_energy.irp.f b/plugins/local/bi_ort_ints/no_dressing_energy.irp.f similarity index 100% rename from src/bi_ort_ints/no_dressing_energy.irp.f rename to plugins/local/bi_ort_ints/no_dressing_energy.irp.f diff --git a/src/bi_ort_ints/no_dressing_naive.irp.f b/plugins/local/bi_ort_ints/no_dressing_naive.irp.f similarity index 100% rename from src/bi_ort_ints/no_dressing_naive.irp.f rename to plugins/local/bi_ort_ints/no_dressing_naive.irp.f diff --git a/src/bi_ort_ints/one_e_bi_ort.irp.f b/plugins/local/bi_ort_ints/one_e_bi_ort.irp.f similarity index 83% rename from src/bi_ort_ints/one_e_bi_ort.irp.f rename to plugins/local/bi_ort_ints/one_e_bi_ort.irp.f index 0ecc2a84..85cae273 100644 --- a/src/bi_ort_ints/one_e_bi_ort.irp.f +++ b/plugins/local/bi_ort_ints/one_e_bi_ort.irp.f @@ -8,23 +8,6 @@ BEGIN_PROVIDER [double precision, ao_one_e_integrals_tc_tot, (ao_num,ao_num)] ao_one_e_integrals_tc_tot = ao_one_e_integrals - !provide j1b_type - - !if( (j1b_type .eq. 1) .or. (j1b_type .eq. 2) ) then - ! - ! print *, ' do things properly !' - ! stop - - ! !do i = 1, ao_num - ! ! do j = 1, ao_num - ! ! ao_one_e_integrals_tc_tot(j,i) += ( j1b_gauss_hermI (j,i) & - ! ! + j1b_gauss_hermII (j,i) & - ! ! + j1b_gauss_nonherm(j,i) ) - ! ! enddo - ! !enddo - - !endif - END_PROVIDER ! --- diff --git a/src/bi_ort_ints/semi_num_ints_mo.irp.f b/plugins/local/bi_ort_ints/semi_num_ints_mo.irp.f similarity index 100% rename from src/bi_ort_ints/semi_num_ints_mo.irp.f rename to plugins/local/bi_ort_ints/semi_num_ints_mo.irp.f diff --git a/src/bi_ort_ints/three_body_ijm.irp.f b/plugins/local/bi_ort_ints/three_body_ijm.irp.f similarity index 100% rename from src/bi_ort_ints/three_body_ijm.irp.f rename to plugins/local/bi_ort_ints/three_body_ijm.irp.f diff --git a/src/bi_ort_ints/three_body_ijmk.irp.f b/plugins/local/bi_ort_ints/three_body_ijmk.irp.f similarity index 100% rename from src/bi_ort_ints/three_body_ijmk.irp.f rename to plugins/local/bi_ort_ints/three_body_ijmk.irp.f diff --git a/src/bi_ort_ints/three_body_ijmk_n4.irp.f b/plugins/local/bi_ort_ints/three_body_ijmk_n4.irp.f similarity index 100% rename from src/bi_ort_ints/three_body_ijmk_n4.irp.f rename to plugins/local/bi_ort_ints/three_body_ijmk_n4.irp.f diff --git a/src/bi_ort_ints/three_body_ijmk_old.irp.f b/plugins/local/bi_ort_ints/three_body_ijmk_old.irp.f similarity index 100% rename from src/bi_ort_ints/three_body_ijmk_old.irp.f rename to plugins/local/bi_ort_ints/three_body_ijmk_old.irp.f diff --git a/src/bi_ort_ints/three_body_ijmkl.irp.f b/plugins/local/bi_ort_ints/three_body_ijmkl.irp.f similarity index 100% rename from src/bi_ort_ints/three_body_ijmkl.irp.f rename to plugins/local/bi_ort_ints/three_body_ijmkl.irp.f diff --git a/src/bi_ort_ints/three_body_ijmkl_old.irp.f b/plugins/local/bi_ort_ints/three_body_ijmkl_old.irp.f similarity index 100% rename from src/bi_ort_ints/three_body_ijmkl_old.irp.f rename to plugins/local/bi_ort_ints/three_body_ijmkl_old.irp.f diff --git a/src/bi_ort_ints/three_body_ints_bi_ort.irp.f b/plugins/local/bi_ort_ints/three_body_ints_bi_ort.irp.f similarity index 100% rename from src/bi_ort_ints/three_body_ints_bi_ort.irp.f rename to plugins/local/bi_ort_ints/three_body_ints_bi_ort.irp.f diff --git a/src/bi_ort_ints/total_twoe_pot.irp.f b/plugins/local/bi_ort_ints/total_twoe_pot.irp.f similarity index 74% rename from src/bi_ort_ints/total_twoe_pot.irp.f rename to plugins/local/bi_ort_ints/total_twoe_pot.irp.f index 37a31a51..5e6a24e9 100644 --- a/src/bi_ort_ints/total_twoe_pot.irp.f +++ b/plugins/local/bi_ort_ints/total_twoe_pot.irp.f @@ -1,91 +1,4 @@ - -! --- - -BEGIN_PROVIDER [double precision, ao_two_e_vartc_tot, (ao_num, ao_num, ao_num, ao_num) ] - - integer :: i, j, k, l - - provide j1b_type - provide mo_r_coef mo_l_coef - - do j = 1, ao_num - do l = 1, ao_num - do i = 1, ao_num - do k = 1, ao_num - ao_two_e_vartc_tot(k,i,l,j) = ao_vartc_int_chemist(k,i,l,j) - enddo - enddo - enddo - enddo - -END_PROVIDER - -! --- - -BEGIN_PROVIDER [double precision, ao_two_e_tc_tot, (ao_num, ao_num, ao_num, ao_num) ] - - BEGIN_DOC - ! - ! ao_two_e_tc_tot(k,i,l,j) = (ki|V^TC(r_12)|lj) = where V^TC(r_12) is the total TC operator - ! - ! including both hermitian and non hermitian parts. THIS IS IN CHEMIST NOTATION. - ! - ! WARNING :: non hermitian ! acts on "the right functions" (i,j) - ! - END_DOC - - integer :: i, j, k, l - double precision :: integral_sym, integral_nsym - double precision, external :: get_ao_tc_sym_two_e_pot - - provide j1b_type - - if(j1b_type .eq. 0) then - - PROVIDE ao_tc_sym_two_e_pot_in_map - - !!! TODO :: OPENMP - do j = 1, ao_num - do l = 1, ao_num - do i = 1, ao_num - do k = 1, ao_num - - integral_sym = get_ao_tc_sym_two_e_pot(i, j, k, l, ao_tc_sym_two_e_pot_map) - ! ao_non_hermit_term_chemist(k,i,l,j) = < k l | [erf( mu r12) - 1] d/d_r12 | i j > on the AO basis - integral_nsym = ao_non_hermit_term_chemist(k,i,l,j) - - !print *, ' sym integ = ', integral_sym - !print *, ' non-sym integ = ', integral_nsym - - ao_two_e_tc_tot(k,i,l,j) = integral_sym + integral_nsym - !write(111,*) ao_two_e_tc_tot(k,i,l,j) - enddo - enddo - enddo - enddo - - else - - PROVIDE ao_tc_int_chemist - - do j = 1, ao_num - do l = 1, ao_num - do i = 1, ao_num - do k = 1, ao_num - ao_two_e_tc_tot(k,i,l,j) = ao_tc_int_chemist(k,i,l,j) - !write(222,*) ao_two_e_tc_tot(k,i,l,j) - enddo - enddo - enddo - enddo - - FREE ao_tc_int_chemist - - endif - -END_PROVIDER - ! --- double precision function bi_ortho_mo_ints(l, k, j, i) @@ -118,8 +31,6 @@ end function bi_ortho_mo_ints ! --- -! TODO :: transform into DEGEMM - BEGIN_PROVIDER [double precision, mo_bi_ortho_tc_two_e_chemist, (mo_num, mo_num, mo_num, mo_num)] BEGIN_DOC @@ -267,7 +178,6 @@ END_PROVIDER ! --- - BEGIN_PROVIDER [ double precision, mo_bi_ortho_tc_two_e_jj, (mo_num,mo_num)] &BEGIN_PROVIDER [ double precision, mo_bi_ortho_tc_two_e_jj_exchange, (mo_num,mo_num)] &BEGIN_PROVIDER [ double precision, mo_bi_ortho_tc_two_e_jj_anti, (mo_num,mo_num)] diff --git a/src/bi_ortho_mos/EZFIO.cfg b/plugins/local/bi_ortho_mos/EZFIO.cfg similarity index 100% rename from src/bi_ortho_mos/EZFIO.cfg rename to plugins/local/bi_ortho_mos/EZFIO.cfg diff --git a/src/bi_ortho_mos/NEED b/plugins/local/bi_ortho_mos/NEED similarity index 100% rename from src/bi_ortho_mos/NEED rename to plugins/local/bi_ortho_mos/NEED diff --git a/src/bi_ortho_mos/bi_density.irp.f b/plugins/local/bi_ortho_mos/bi_density.irp.f similarity index 100% rename from src/bi_ortho_mos/bi_density.irp.f rename to plugins/local/bi_ortho_mos/bi_density.irp.f diff --git a/src/bi_ortho_mos/bi_ort_mos_in_r.irp.f b/plugins/local/bi_ortho_mos/bi_ort_mos_in_r.irp.f similarity index 100% rename from src/bi_ortho_mos/bi_ort_mos_in_r.irp.f rename to plugins/local/bi_ortho_mos/bi_ort_mos_in_r.irp.f diff --git a/src/bi_ortho_mos/grad_bi_ort_mos_in_r.irp.f b/plugins/local/bi_ortho_mos/grad_bi_ort_mos_in_r.irp.f similarity index 100% rename from src/bi_ortho_mos/grad_bi_ort_mos_in_r.irp.f rename to plugins/local/bi_ortho_mos/grad_bi_ort_mos_in_r.irp.f diff --git a/src/bi_ortho_mos/mos_rl.irp.f b/plugins/local/bi_ortho_mos/mos_rl.irp.f similarity index 100% rename from src/bi_ortho_mos/mos_rl.irp.f rename to plugins/local/bi_ortho_mos/mos_rl.irp.f diff --git a/src/bi_ortho_mos/overlap.irp.f b/plugins/local/bi_ortho_mos/overlap.irp.f similarity index 100% rename from src/bi_ortho_mos/overlap.irp.f rename to plugins/local/bi_ortho_mos/overlap.irp.f diff --git a/src/casscf_tc_bi/NEED b/plugins/local/casscf_tc_bi/NEED similarity index 100% rename from src/casscf_tc_bi/NEED rename to plugins/local/casscf_tc_bi/NEED diff --git a/src/casscf_tc_bi/det_manip.irp.f b/plugins/local/casscf_tc_bi/det_manip.irp.f similarity index 100% rename from src/casscf_tc_bi/det_manip.irp.f rename to plugins/local/casscf_tc_bi/det_manip.irp.f diff --git a/src/casscf_tc_bi/grad_dm.irp.f b/plugins/local/casscf_tc_bi/grad_dm.irp.f similarity index 100% rename from src/casscf_tc_bi/grad_dm.irp.f rename to plugins/local/casscf_tc_bi/grad_dm.irp.f diff --git a/src/casscf_tc_bi/grad_old.irp.f b/plugins/local/casscf_tc_bi/grad_old.irp.f similarity index 100% rename from src/casscf_tc_bi/grad_old.irp.f rename to plugins/local/casscf_tc_bi/grad_old.irp.f diff --git a/src/casscf_tc_bi/gradient.irp.f b/plugins/local/casscf_tc_bi/gradient.irp.f similarity index 100% rename from src/casscf_tc_bi/gradient.irp.f rename to plugins/local/casscf_tc_bi/gradient.irp.f diff --git a/src/casscf_tc_bi/test_tc_casscf.irp.f b/plugins/local/casscf_tc_bi/test_tc_casscf.irp.f similarity index 100% rename from src/casscf_tc_bi/test_tc_casscf.irp.f rename to plugins/local/casscf_tc_bi/test_tc_casscf.irp.f diff --git a/src/cipsi_tc_bi_ortho/EZFIO.cfg b/plugins/local/cipsi_tc_bi_ortho/EZFIO.cfg similarity index 100% rename from src/cipsi_tc_bi_ortho/EZFIO.cfg rename to plugins/local/cipsi_tc_bi_ortho/EZFIO.cfg diff --git a/src/cipsi_tc_bi_ortho/NEED b/plugins/local/cipsi_tc_bi_ortho/NEED similarity index 100% rename from src/cipsi_tc_bi_ortho/NEED rename to plugins/local/cipsi_tc_bi_ortho/NEED diff --git a/src/cipsi_tc_bi_ortho/cipsi.irp.f b/plugins/local/cipsi_tc_bi_ortho/cipsi.irp.f similarity index 100% rename from src/cipsi_tc_bi_ortho/cipsi.irp.f rename to plugins/local/cipsi_tc_bi_ortho/cipsi.irp.f diff --git a/src/cipsi_tc_bi_ortho/energy.irp.f b/plugins/local/cipsi_tc_bi_ortho/energy.irp.f similarity index 100% rename from src/cipsi_tc_bi_ortho/energy.irp.f rename to plugins/local/cipsi_tc_bi_ortho/energy.irp.f diff --git a/src/cipsi_tc_bi_ortho/environment.irp.f b/plugins/local/cipsi_tc_bi_ortho/environment.irp.f similarity index 100% rename from src/cipsi_tc_bi_ortho/environment.irp.f rename to plugins/local/cipsi_tc_bi_ortho/environment.irp.f diff --git a/src/cipsi_tc_bi_ortho/fock_diag.irp.f b/plugins/local/cipsi_tc_bi_ortho/fock_diag.irp.f similarity index 100% rename from src/cipsi_tc_bi_ortho/fock_diag.irp.f rename to plugins/local/cipsi_tc_bi_ortho/fock_diag.irp.f diff --git a/src/cipsi_tc_bi_ortho/get_d.irp.f b/plugins/local/cipsi_tc_bi_ortho/get_d.irp.f similarity index 100% rename from src/cipsi_tc_bi_ortho/get_d.irp.f rename to plugins/local/cipsi_tc_bi_ortho/get_d.irp.f diff --git a/src/cipsi_tc_bi_ortho/get_d0_good.irp.f b/plugins/local/cipsi_tc_bi_ortho/get_d0_good.irp.f similarity index 100% rename from src/cipsi_tc_bi_ortho/get_d0_good.irp.f rename to plugins/local/cipsi_tc_bi_ortho/get_d0_good.irp.f diff --git a/src/cipsi_tc_bi_ortho/get_d1_good.irp.f b/plugins/local/cipsi_tc_bi_ortho/get_d1_good.irp.f similarity index 100% rename from src/cipsi_tc_bi_ortho/get_d1_good.irp.f rename to plugins/local/cipsi_tc_bi_ortho/get_d1_good.irp.f diff --git a/src/cipsi_tc_bi_ortho/get_d2_good.irp.f b/plugins/local/cipsi_tc_bi_ortho/get_d2_good.irp.f similarity index 100% rename from src/cipsi_tc_bi_ortho/get_d2_good.irp.f rename to plugins/local/cipsi_tc_bi_ortho/get_d2_good.irp.f diff --git a/src/cipsi_tc_bi_ortho/lock_2rdm.irp.f b/plugins/local/cipsi_tc_bi_ortho/lock_2rdm.irp.f similarity index 100% rename from src/cipsi_tc_bi_ortho/lock_2rdm.irp.f rename to plugins/local/cipsi_tc_bi_ortho/lock_2rdm.irp.f diff --git a/src/cipsi_tc_bi_ortho/pouet b/plugins/local/cipsi_tc_bi_ortho/pouet similarity index 100% rename from src/cipsi_tc_bi_ortho/pouet rename to plugins/local/cipsi_tc_bi_ortho/pouet diff --git a/src/cipsi_tc_bi_ortho/pt2.irp.f b/plugins/local/cipsi_tc_bi_ortho/pt2.irp.f similarity index 100% rename from src/cipsi_tc_bi_ortho/pt2.irp.f rename to plugins/local/cipsi_tc_bi_ortho/pt2.irp.f diff --git a/src/cipsi_tc_bi_ortho/pt2_stoch_routines.irp.f b/plugins/local/cipsi_tc_bi_ortho/pt2_stoch_routines.irp.f similarity index 100% rename from src/cipsi_tc_bi_ortho/pt2_stoch_routines.irp.f rename to plugins/local/cipsi_tc_bi_ortho/pt2_stoch_routines.irp.f diff --git a/src/cipsi_tc_bi_ortho/pt2_type.irp.f b/plugins/local/cipsi_tc_bi_ortho/pt2_type.irp.f similarity index 100% rename from src/cipsi_tc_bi_ortho/pt2_type.irp.f rename to plugins/local/cipsi_tc_bi_ortho/pt2_type.irp.f diff --git a/src/cipsi_tc_bi_ortho/run_pt2_slave.irp.f b/plugins/local/cipsi_tc_bi_ortho/run_pt2_slave.irp.f similarity index 100% rename from src/cipsi_tc_bi_ortho/run_pt2_slave.irp.f rename to plugins/local/cipsi_tc_bi_ortho/run_pt2_slave.irp.f diff --git a/src/cipsi_tc_bi_ortho/run_selection_slave.irp.f b/plugins/local/cipsi_tc_bi_ortho/run_selection_slave.irp.f similarity index 100% rename from src/cipsi_tc_bi_ortho/run_selection_slave.irp.f rename to plugins/local/cipsi_tc_bi_ortho/run_selection_slave.irp.f diff --git a/src/cipsi_tc_bi_ortho/selection.irp.f b/plugins/local/cipsi_tc_bi_ortho/selection.irp.f similarity index 100% rename from src/cipsi_tc_bi_ortho/selection.irp.f rename to plugins/local/cipsi_tc_bi_ortho/selection.irp.f diff --git a/src/cipsi_tc_bi_ortho/selection_buffer.irp.f b/plugins/local/cipsi_tc_bi_ortho/selection_buffer.irp.f similarity index 100% rename from src/cipsi_tc_bi_ortho/selection_buffer.irp.f rename to plugins/local/cipsi_tc_bi_ortho/selection_buffer.irp.f diff --git a/src/cipsi_tc_bi_ortho/selection_types.f90 b/plugins/local/cipsi_tc_bi_ortho/selection_types.f90 similarity index 100% rename from src/cipsi_tc_bi_ortho/selection_types.f90 rename to plugins/local/cipsi_tc_bi_ortho/selection_types.f90 diff --git a/src/cipsi_tc_bi_ortho/selection_weight.irp.f b/plugins/local/cipsi_tc_bi_ortho/selection_weight.irp.f similarity index 100% rename from src/cipsi_tc_bi_ortho/selection_weight.irp.f rename to plugins/local/cipsi_tc_bi_ortho/selection_weight.irp.f diff --git a/src/cipsi_tc_bi_ortho/slave_cipsi.irp.f b/plugins/local/cipsi_tc_bi_ortho/slave_cipsi.irp.f similarity index 100% rename from src/cipsi_tc_bi_ortho/slave_cipsi.irp.f rename to plugins/local/cipsi_tc_bi_ortho/slave_cipsi.irp.f diff --git a/src/cipsi_tc_bi_ortho/stochastic_cipsi.irp.f b/plugins/local/cipsi_tc_bi_ortho/stochastic_cipsi.irp.f similarity index 100% rename from src/cipsi_tc_bi_ortho/stochastic_cipsi.irp.f rename to plugins/local/cipsi_tc_bi_ortho/stochastic_cipsi.irp.f diff --git a/src/cipsi_tc_bi_ortho/write_cipsi_json.irp.f b/plugins/local/cipsi_tc_bi_ortho/write_cipsi_json.irp.f similarity index 100% rename from src/cipsi_tc_bi_ortho/write_cipsi_json.irp.f rename to plugins/local/cipsi_tc_bi_ortho/write_cipsi_json.irp.f diff --git a/src/cipsi_tc_bi_ortho/zmq_selection.irp.f b/plugins/local/cipsi_tc_bi_ortho/zmq_selection.irp.f similarity index 100% rename from src/cipsi_tc_bi_ortho/zmq_selection.irp.f rename to plugins/local/cipsi_tc_bi_ortho/zmq_selection.irp.f diff --git a/src/fci_tc_bi/13.fci_tc_bi_ortho.bats b/plugins/local/fci_tc_bi/13.fci_tc_bi_ortho.bats similarity index 100% rename from src/fci_tc_bi/13.fci_tc_bi_ortho.bats rename to plugins/local/fci_tc_bi/13.fci_tc_bi_ortho.bats diff --git a/src/fci_tc_bi/EZFIO.cfg b/plugins/local/fci_tc_bi/EZFIO.cfg similarity index 100% rename from src/fci_tc_bi/EZFIO.cfg rename to plugins/local/fci_tc_bi/EZFIO.cfg diff --git a/src/fci_tc_bi/NEED b/plugins/local/fci_tc_bi/NEED similarity index 100% rename from src/fci_tc_bi/NEED rename to plugins/local/fci_tc_bi/NEED diff --git a/src/fci_tc_bi/class.irp.f b/plugins/local/fci_tc_bi/class.irp.f similarity index 100% rename from src/fci_tc_bi/class.irp.f rename to plugins/local/fci_tc_bi/class.irp.f diff --git a/src/fci_tc_bi/copy_wf.irp.f b/plugins/local/fci_tc_bi/copy_wf.irp.f similarity index 100% rename from src/fci_tc_bi/copy_wf.irp.f rename to plugins/local/fci_tc_bi/copy_wf.irp.f diff --git a/src/fci_tc_bi/diagonalize_ci.irp.f b/plugins/local/fci_tc_bi/diagonalize_ci.irp.f similarity index 100% rename from src/fci_tc_bi/diagonalize_ci.irp.f rename to plugins/local/fci_tc_bi/diagonalize_ci.irp.f diff --git a/src/fci_tc_bi/fci_tc_bi_ortho.irp.f b/plugins/local/fci_tc_bi/fci_tc_bi_ortho.irp.f similarity index 100% rename from src/fci_tc_bi/fci_tc_bi_ortho.irp.f rename to plugins/local/fci_tc_bi/fci_tc_bi_ortho.irp.f diff --git a/src/fci_tc_bi/generators.irp.f b/plugins/local/fci_tc_bi/generators.irp.f similarity index 100% rename from src/fci_tc_bi/generators.irp.f rename to plugins/local/fci_tc_bi/generators.irp.f diff --git a/src/fci_tc_bi/pt2_tc.irp.f b/plugins/local/fci_tc_bi/pt2_tc.irp.f similarity index 100% rename from src/fci_tc_bi/pt2_tc.irp.f rename to plugins/local/fci_tc_bi/pt2_tc.irp.f diff --git a/src/fci_tc_bi/save_energy.irp.f b/plugins/local/fci_tc_bi/save_energy.irp.f similarity index 100% rename from src/fci_tc_bi/save_energy.irp.f rename to plugins/local/fci_tc_bi/save_energy.irp.f diff --git a/src/fci_tc_bi/scripts_fci_tc/CH2.xyz b/plugins/local/fci_tc_bi/scripts_fci_tc/CH2.xyz similarity index 100% rename from src/fci_tc_bi/scripts_fci_tc/CH2.xyz rename to plugins/local/fci_tc_bi/scripts_fci_tc/CH2.xyz diff --git a/src/fci_tc_bi/scripts_fci_tc/FH.xyz b/plugins/local/fci_tc_bi/scripts_fci_tc/FH.xyz similarity index 100% rename from src/fci_tc_bi/scripts_fci_tc/FH.xyz rename to plugins/local/fci_tc_bi/scripts_fci_tc/FH.xyz diff --git a/src/fci_tc_bi/scripts_fci_tc/extract_tables.sh b/plugins/local/fci_tc_bi/scripts_fci_tc/extract_tables.sh similarity index 100% rename from src/fci_tc_bi/scripts_fci_tc/extract_tables.sh rename to plugins/local/fci_tc_bi/scripts_fci_tc/extract_tables.sh diff --git a/src/fci_tc_bi/scripts_fci_tc/h2o.sh b/plugins/local/fci_tc_bi/scripts_fci_tc/h2o.sh similarity index 92% rename from src/fci_tc_bi/scripts_fci_tc/h2o.sh rename to plugins/local/fci_tc_bi/scripts_fci_tc/h2o.sh index d0afca30..697beeb5 100644 --- a/src/fci_tc_bi/scripts_fci_tc/h2o.sh +++ b/plugins/local/fci_tc_bi/scripts_fci_tc/h2o.sh @@ -23,10 +23,10 @@ cd $StartDir ############################################################################ #### EXAMPLE OF SCRIPT TO RUN A CIPSI CALCULATION ON 5 STATES ON THE Ne^+ CATION -#### USING NATURAL ORBITALS OF A SMALL CIPSI AS MOS +#### USING NATURAL ORBITALS OF A SMALL CIPSI AS MOS #### ALL STATES WILL HAVE THE SAME SPIN SIMETRY : A DOUBLET -####### YOU PUT THE PATH TO YOUR +####### YOU PUT THE PATH TO YOUR QP_ROOT=/home_lct/eginer/programs/qp2 source ${QP_ROOT}/quantum_package.rc ####### YOU LOAD SOME LIBRARIES diff --git a/src/fci_tc_bi/scripts_fci_tc/h2o.xyz b/plugins/local/fci_tc_bi/scripts_fci_tc/h2o.xyz similarity index 100% rename from src/fci_tc_bi/scripts_fci_tc/h2o.xyz rename to plugins/local/fci_tc_bi/scripts_fci_tc/h2o.xyz diff --git a/src/fci_tc_bi/scripts_fci_tc/script.sh b/plugins/local/fci_tc_bi/scripts_fci_tc/script.sh similarity index 100% rename from src/fci_tc_bi/scripts_fci_tc/script.sh rename to plugins/local/fci_tc_bi/scripts_fci_tc/script.sh diff --git a/src/fci_tc_bi/selectors.irp.f b/plugins/local/fci_tc_bi/selectors.irp.f similarity index 100% rename from src/fci_tc_bi/selectors.irp.f rename to plugins/local/fci_tc_bi/selectors.irp.f diff --git a/src/fci_tc_bi/zmq.irp.f b/plugins/local/fci_tc_bi/zmq.irp.f similarity index 100% rename from src/fci_tc_bi/zmq.irp.f rename to plugins/local/fci_tc_bi/zmq.irp.f diff --git a/plugins/local/jastrow/EZFIO.cfg b/plugins/local/jastrow/EZFIO.cfg new file mode 100644 index 00000000..0d4141af --- /dev/null +++ b/plugins/local/jastrow/EZFIO.cfg @@ -0,0 +1,146 @@ + +[j2e_type] +type: character*(32) +doc: type of the 2e-Jastrow: [ None | Mu | Mur | Qmckl ] +interface: ezfio,provider,ocaml +default: Mu + +[j1e_type] +type: character*(32) +doc: type of the 1e-Jastrow: [ None | Gauss | Charge_Harmonizer ] +interface: ezfio,provider,ocaml +default: None + +[env_type] +type: character*(32) +doc: type of envelop for Jastrow: [ None | Prod_Gauss | Sum_Gauss | Sum_Slat | Sum_Quartic ] +interface: ezfio, provider, ocaml +default: Sum_Gauss + +[jast_qmckl_type_nucl_num] +doc: Number of different nuclei types in QMCkl jastrow +type: integer +interface: ezfio, provider + +[jast_qmckl_type_nucl_vector] +doc: Nucleus type in QMCkl jastrow +type: integer +size: (nuclei.nucl_num) +interface: ezfio, provider + +[jast_qmckl_rescale_ee] +doc: Rescaling factor for electron-electron in QMCkl Jastrow +type: double precision +interface: ezfio, provider + +[jast_qmckl_rescale_en] +doc: Rescaling factor for electron-nucleus in QMCkl Jastrow +type: double precision +size: (jastrow.jast_qmckl_type_nucl_num) +interface: ezfio, provider + +[jast_qmckl_aord_num] +doc: Order of polynomials in e-n parameters of QMCkl jastrow +type: integer +interface: ezfio, provider + +[jast_qmckl_bord_num] +doc: Order of polynomials in e-e parameters of QMCkl jastrow +type: integer +interface: ezfio, provider + +[jast_qmckl_cord_num] +doc: Order of polynomials in e-e-n parameters of QMCkl jastrow +type: integer +interface: ezfio, provider + +[jast_qmckl_c_vector_size] +doc: Number of parameters for c_vector +type: integer +interface: ezfio, provider + +[jast_qmckl_a_vector] +doc: electron-nucleus parameters in QMCkl Jastrow +type: double precision +size: (jastrow.jast_qmckl_type_nucl_num*jastrow.jast_qmckl_aord_num+jastrow.jast_qmckl_type_nucl_num) +interface: ezfio, provider + +[jast_qmckl_b_vector] +doc: electron-electron parameters in QMCkl Jastrow +type: double precision +size: (jastrow.jast_qmckl_bord_num+1) +interface: ezfio, provider + +[jast_qmckl_c_vector] +doc: electron-electron-nucleus parameters in QMCkl Jastrow +type: double precision +size: (jastrow.jast_qmckl_c_vector_size) +interface: ezfio, provider + +[j1e_size] +type: integer +doc: number of functions per atom in 1e-Jastrow +interface: ezfio,provider,ocaml +default: 1 + +[j1e_coef] +type: double precision +doc: linear coef of functions in 1e-Jastrow +interface: ezfio +size: (jastrow.j1e_size,nuclei.nucl_num) + +[j1e_coef_ao] +type: double precision +doc: coefficients of the 1-electrob Jastrow in AOs +interface: ezfio +size: (ao_basis.ao_num) + +[j1e_coef_ao2] +type: double precision +doc: coefficients of the 1-electron Jastrow in AOsxAOs +interface: ezfio +size: (ao_basis.ao_num*ao_basis.ao_num) + +[j1e_coef_ao3] +type: double precision +doc: coefficients of the 1-electron Jastrow in AOsxAOs +interface: ezfio +size: (ao_basis.ao_num,3) + +[j1e_expo] +type: double precision +doc: exponenets of functions in 1e-Jastrow +interface: ezfio +size: (jastrow.j1e_size,nuclei.nucl_num) + +[env_expo] +type: double precision +doc: exponents of the envelop for Jastrow +interface: ezfio +size: (nuclei.nucl_num) + +[env_coef] +type: double precision +doc: coefficients of the envelop for Jastrow +interface: ezfio +size: (nuclei.nucl_num) + +[murho_type] +type: integer +doc: type of mu(rho) Jastrow +interface: ezfio, provider, ocaml +default: 0 + +[ng_fit_jast] +type: integer +doc: nb of Gaussians used to fit Jastrow fcts +interface: ezfio,provider,ocaml +default: 20 + +[a_boys] +type: double precision +doc: cutting of the interaction in the range separated model +interface: ezfio,provider,ocaml +default: 1.0 +ezfio_name: a_boys + diff --git a/src/jastrow/NEED b/plugins/local/jastrow/NEED similarity index 65% rename from src/jastrow/NEED rename to plugins/local/jastrow/NEED index f03c11fd..7d8fe789 100644 --- a/src/jastrow/NEED +++ b/plugins/local/jastrow/NEED @@ -1,2 +1,3 @@ nuclei electrons +ao_basis diff --git a/plugins/local/jastrow/README.md b/plugins/local/jastrow/README.md new file mode 100644 index 00000000..67898e23 --- /dev/null +++ b/plugins/local/jastrow/README.md @@ -0,0 +1,72 @@ +# Jastrow + +Information related to the Jastrow factor in trans-correlated calculations. + +The main keywords are: +- `j2e_type` +- `j1e_type` +- `env_type` + +## j2e_type Options + +1. **None:** No 2e-Jastrow is used. + +2. **Mu:** 2e-Jastrow inspired by Range Separated Density Functional Theory. It has the following shape: +

+ +

+ with, +

+ +

+ + +## env_type Options + +The 2-electron Jastrow is multiplied by an envelope \(v\): +

+ +

+ +- if `env_type` is **None**: No envelope is used. + +- if `env_type` is **Prod_Gauss**: +

+ +

+ +- if `env_type` is **Sum_Gauss**: +

+ +

+ +Here, \(A\) designates the nuclei, and the coefficients and exponents are defined in the tables `env_coef` and `env_expo` respectively. + + +## j1e_type Options + +The 1-electron Jastrow used is: +

+ +

+ +- if `j1e_type` is **None**: No one-electron Jastrow is used. + +- if `j1e_type` is **Gauss**: We use +

+ +

+ + +are defined by the tables `j1e_coef` and `j1e_expo`, respectively. + +- if `j1e_type` is **Charge_Harmonizer**: The one-electron Jastrow factor aims to offset the adverse impact of modifying the charge density induced by the two-electron factor +

+ +

+ +- if `j1e_type` is **Charge_Harmonizer_AO**: The one-electron Jastrow factor **Charge_Harmonizer** is fitted by the product of atomic orbitals: +

+ +

+ diff --git a/plugins/local/jastrow/env_param.irp.f b/plugins/local/jastrow/env_param.irp.f new file mode 100644 index 00000000..689b22cd --- /dev/null +++ b/plugins/local/jastrow/env_param.irp.f @@ -0,0 +1,102 @@ + +! --- + + BEGIN_PROVIDER [double precision, env_expo, (nucl_num)] +&BEGIN_PROVIDER [double precision, env_coef, (nucl_num)] + + BEGIN_DOC + ! + ! parameters of the env of the 2e-Jastrow + ! + END_DOC + + implicit none + logical :: exists + integer :: i + integer :: ierr + + PROVIDE ezfio_filename + + ! --- + + if (mpi_master) then + call ezfio_has_jastrow_env_expo(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' + call MPI_BCAST(env_expo, (nucl_num), MPI_DOUBLE_PRECISION, 0, MPI_COMM_WORLD, ierr) + if (ierr /= MPI_SUCCESS) then + stop 'Unable to read env_expo with MPI' + endif + IRP_ENDIF + + if (exists) then + if (mpi_master) then + write(6,'(A)') '.. >>>>> [ IO READ: env_expo ] <<<<< ..' + call ezfio_get_jastrow_env_expo(env_expo) + IRP_IF MPI + call MPI_BCAST(env_expo, (nucl_num), MPI_DOUBLE_PRECISION, 0, MPI_COMM_WORLD, ierr) + if (ierr /= MPI_SUCCESS) then + stop 'Unable to read env_expo with MPI' + endif + IRP_ENDIF + endif + else + + env_expo = 1d5 + call ezfio_set_jastrow_env_expo(env_expo) + endif + + ! --- + + if (mpi_master) then + call ezfio_has_jastrow_env_coef(exists) + endif + + IRP_IF MPI_DEBUG + print *, irp_here, mpi_rank + call MPI_BARRIER(MPI_COMM_WORLD, ierr) + IRP_ENDIF + + IRP_IF MPI + call MPI_BCAST(env_coef, (nucl_num), MPI_DOUBLE_PRECISION, 0, MPI_COMM_WORLD, ierr) + if (ierr /= MPI_SUCCESS) then + stop 'Unable to read env_coef with MPI' + endif + IRP_ENDIF + + if (exists) then + if (mpi_master) then + write(6,'(A)') '.. >>>>> [ IO READ: env_coef ] <<<<< ..' + call ezfio_get_jastrow_env_coef(env_coef) + IRP_IF MPI + call MPI_BCAST(env_coef, (nucl_num), MPI_DOUBLE_PRECISION, 0, MPI_COMM_WORLD, ierr) + if (ierr /= MPI_SUCCESS) then + stop 'Unable to read env_coef with MPI' + endif + IRP_ENDIF + endif + else + + env_coef = 1d0 + call ezfio_set_jastrow_env_coef(env_coef) + endif + + ! --- + + print *, ' parameters for nuclei jastrow' + print *, ' i, Z, env_expo, env_coef' + do i = 1, nucl_num + write(*,'(I4, 2x, 3(E15.7, 2X))') i, nucl_charge(i), env_expo(i), env_coef(i) + enddo + +END_PROVIDER + +! --- + diff --git a/src/ao_tc_eff_map/fit_j.irp.f b/plugins/local/jastrow/fit_j.irp.f similarity index 83% rename from src/ao_tc_eff_map/fit_j.irp.f rename to plugins/local/jastrow/fit_j.irp.f index 0fc3da2f..8a2d0036 100644 --- a/src/ao_tc_eff_map/fit_j.irp.f +++ b/plugins/local/jastrow/fit_j.irp.f @@ -1,41 +1,67 @@ - BEGIN_PROVIDER [ double precision, expo_j_xmu_1gauss ] -&BEGIN_PROVIDER [ double precision, coef_j_xmu_1gauss ] - implicit none - BEGIN_DOC - ! Upper bound long range fit of F(x) = x * (1 - erf(x)) - 1/sqrt(pi) * exp(-x**2) - ! - ! with a single gaussian. - ! - ! Such a function can be used to screen integrals with F(x). - END_DOC - expo_j_xmu_1gauss = 0.5d0 - coef_j_xmu_1gauss = 1.d0 -END_PROVIDER + ! --- -BEGIN_PROVIDER [ double precision, expo_erfc_gauss ] - implicit none - expo_erfc_gauss = 1.41211d0 + BEGIN_PROVIDER [double precision, expo_j_xmu_1gauss] +&BEGIN_PROVIDER [double precision, coef_j_xmu_1gauss] + + implicit none + + BEGIN_DOC + ! Upper bound long range fit of F(x) = x * (1 - erf(x)) - 1/sqrt(pi) * exp(-x**2) + ! + ! with a single gaussian. + ! + ! Such a function can be used to screen integrals with F(x). + END_DOC + + expo_j_xmu_1gauss = 0.5d0 + coef_j_xmu_1gauss = 1.d0 + END_PROVIDER -BEGIN_PROVIDER [ double precision, expo_erfc_mu_gauss ] - implicit none - expo_erfc_mu_gauss = expo_erfc_gauss * mu_erf * mu_erf +! --- + +BEGIN_PROVIDER [double precision, expo_erfc_gauss] + + implicit none + + expo_erfc_gauss = 1.41211d0 + END_PROVIDER - BEGIN_PROVIDER [ double precision, expo_good_j_mu_1gauss ] -&BEGIN_PROVIDER [ double precision, coef_good_j_mu_1gauss ] - implicit none - BEGIN_DOC - ! exponent of Gaussian in order to obtain an upper bound of J(r12,mu) - ! - ! Can be used to scree integrals with J(r12,mu) - END_DOC - expo_good_j_mu_1gauss = 2.D0 * mu_erf * expo_j_xmu_1gauss - coef_good_j_mu_1gauss = 0.5d0/mu_erf * coef_j_xmu_1gauss - END_PROVIDER +! --- -BEGIN_PROVIDER [ double precision, expo_j_xmu, (n_fit_1_erf_x) ] +BEGIN_PROVIDER [double precision, expo_erfc_mu_gauss] + + implicit none + + expo_erfc_mu_gauss = expo_erfc_gauss * mu_erf * mu_erf + +END_PROVIDER + +! --- + + BEGIN_PROVIDER [double precision, expo_good_j_mu_1gauss] +&BEGIN_PROVIDER [double precision, coef_good_j_mu_1gauss] + + BEGIN_DOC + ! + ! exponent of Gaussian in order to obtain an upper bound of J(r12,mu) + ! + ! Can be used to scree integrals with J(r12,mu) + ! + END_DOC + + implicit none + + expo_good_j_mu_1gauss = 2.d0 * mu_erf * expo_j_xmu_1gauss + coef_good_j_mu_1gauss = 0.5d0/mu_erf * coef_j_xmu_1gauss + +END_PROVIDER + +! --- + +BEGIN_PROVIDER [double precision, expo_j_xmu, (n_fit_1_erf_x)] BEGIN_DOC ! F(x) = x * (1 - erf(x)) - 1/sqrt(pi) * exp(-x**2) is fitted with a gaussian and a Slater @@ -465,53 +491,86 @@ END_PROVIDER ! --- double precision function F_x_j(x) - implicit none - BEGIN_DOC - ! F_x_j(x) = dimension-less correlation factor = x (1 - erf(x)) - 1/sqrt(pi) exp(-x^2) - END_DOC - double precision, intent(in) :: x - F_x_j = x * (1.d0 - derf(x)) - 1/dsqrt(dacos(-1.d0)) * dexp(-x**2) + + BEGIN_DOC + ! + ! dimension-less correlation factor: + ! + ! F_x_j(x) = x (1 - erf(x)) - 1/sqrt(pi) exp(-x^2) + ! + END_DOC + + implicit none + double precision, intent(in) :: x + + F_x_j = x * (1.d0 - derf(x)) - 1/dsqrt(dacos(-1.d0)) * dexp(-x**2) end +! --- + double precision function j_mu_F_x_j(x) - implicit none - BEGIN_DOC - ! j_mu_F_x_j(x) = correlation factor = 1/2 r12 * (1 - erf(mu*r12)) - 1/(2 sqrt(pi)*mu) exp(-(mu*r12)^2) - ! - ! = 1/(2*mu) * F_x_j(mu*x) - END_DOC - double precision :: F_x_j - double precision, intent(in) :: x - j_mu_F_x_j = 0.5d0/mu_erf * F_x_j(x*mu_erf) + + BEGIN_DOC + ! + ! correlation factor: + ! + ! j_mu_F_x_j(x) = 1/2 r12 * (1 - erf(mu*r12)) - 1/(2 sqrt(pi)*mu) exp(-(mu*r12)^2) + ! = 1/(2*mu) * F_x_j(mu*x) + ! + END_DOC + + implicit none + double precision, intent(in) :: x + double precision :: F_x_j + + j_mu_F_x_j = 0.5d0/mu_erf * F_x_j(x*mu_erf) + end +! --- + double precision function j_mu(x) - implicit none - double precision, intent(in) :: x - BEGIN_DOC - ! j_mu(x) = correlation factor = 1/2 r12 * (1 - erf(mu*r12)) - 1/(2 sqrt(pi)*mu) exp(-(mu*r12)^2) - END_DOC - j_mu = 0.5d0* x * (1.d0 - derf(mu_erf*x)) - 0.5d0/( dsqrt(dacos(-1.d0))*mu_erf) * dexp(-(mu_erf*x)*(mu_erf*x)) - -end -double precision function j_mu_fit_gauss(x) - implicit none - BEGIN_DOC - ! j_mu_fit_gauss(x) = correlation factor = 1/2 r12 * (1 - erf(mu*r12)) - 1/(2 sqrt(pi)*mu) exp(-(mu*r12)^2) - ! - ! but fitted with gaussians - END_DOC - double precision, intent(in) :: x - integer :: i - double precision :: alpha,coef - j_mu_fit_gauss = 0.d0 - do i = 1, n_max_fit_slat - alpha = expo_gauss_j_mu_x(i) - coef = coef_gauss_j_mu_x(i) - j_mu_fit_gauss += coef * dexp(-alpha*x*x) - enddo + BEGIN_DOC + ! + ! correlation factor: + ! + ! j_mu(x) = 1/2 r12 * (1 - erf(mu*r12)) - 1/(2 sqrt(pi)*mu) exp(-(mu*r12)^2) + ! + END_DOC + + implicit none + double precision, intent(in) :: x + + j_mu = 0.5d0* x * (1.d0 - derf(mu_erf*x)) - 0.5d0/( dsqrt(dacos(-1.d0))*mu_erf) * dexp(-(mu_erf*x)*(mu_erf*x)) + +end + +! --- + +double precision function j_mu_fit_gauss(x) + + BEGIN_DOC + ! + ! correlation factor fitted with gaussians: + ! + ! j_mu_fit_gauss(x) = 1/2 r12 * (1 - erf(mu*r12)) - 1/(2 sqrt(pi)*mu) exp(-(mu*r12)^2) + ! + ! + END_DOC + + implicit none + double precision, intent(in) :: x + integer :: i + double precision :: alpha, coef + + j_mu_fit_gauss = 0.d0 + do i = 1, n_max_fit_slat + alpha = expo_gauss_j_mu_x(i) + coef = coef_gauss_j_mu_x(i) + j_mu_fit_gauss += coef * dexp(-alpha*x*x) + enddo end diff --git a/src/ao_tc_eff_map/potential.irp.f b/plugins/local/jastrow/fit_potential.irp.f similarity index 78% rename from src/ao_tc_eff_map/potential.irp.f rename to plugins/local/jastrow/fit_potential.irp.f index 5b72b567..0bdf9c5b 100644 --- a/src/ao_tc_eff_map/potential.irp.f +++ b/plugins/local/jastrow/fit_potential.irp.f @@ -1,13 +1,16 @@ + ! --- BEGIN_PROVIDER [integer, n_gauss_eff_pot] BEGIN_DOC + ! ! number of gaussians to represent the effective potential : ! ! V(mu,r12) = -0.25 * (1 - erf(mu*r12))^2 + 1/(\sqrt(pi)mu) * exp(-(mu*r12)^2) ! ! Here (1 - erf(mu*r12))^2 is expanded in Gaussians as Eqs A11-A20 in JCP 154, 084119 (2021) + ! END_DOC implicit none @@ -21,10 +24,13 @@ END_PROVIDER BEGIN_PROVIDER [integer, n_gauss_eff_pot_deriv] BEGIN_DOC + ! ! V(r12) = -(1 - erf(mu*r12))^2 is expanded in Gaussians as Eqs A11-A20 in JCP 154, 084119 (2021) + ! END_DOC implicit none + n_gauss_eff_pot_deriv = ng_fit_jast END_PROVIDER @@ -35,11 +41,13 @@ END_PROVIDER &BEGIN_PROVIDER [double precision, coef_gauss_eff_pot, (n_gauss_eff_pot)] BEGIN_DOC + ! ! Coefficients and exponents of the Fit on Gaussians of V(X) = -(1 - erf(mu*X))^2 + 1/(\sqrt(pi)mu) * exp(-(mu*X)^2) ! ! V(X) = \sum_{i=1,n_gauss_eff_pot} coef_gauss_eff_pot(i) * exp(-expo_gauss_eff_pot(i) * X^2) ! ! Relies on the fit proposed in Eqs A11-A20 in JCP 154, 084119 (2021) + ! END_DOC include 'constants.include.F' @@ -64,7 +72,9 @@ END_PROVIDER double precision function eff_pot_gauss(x, mu) BEGIN_DOC + ! ! V(mu,r12) = -0.25 * (1 - erf(mu*r12))^2 + 1/(\sqrt(pi)mu) * exp(-(mu*r12)^2) + ! END_DOC implicit none @@ -74,44 +84,58 @@ double precision function eff_pot_gauss(x, mu) end -! ------------------------------------------------------------------------------------------------- ! --- double precision function eff_pot_fit_gauss(x) - implicit none - BEGIN_DOC - ! V(mu,r12) = -0.25 * (1 - erf(mu*r12))^2 + 1/(\sqrt(pi)mu) * exp(-(mu*r12)^2) - ! - ! but fitted with gaussians - END_DOC - double precision, intent(in) :: x - integer :: i - double precision :: alpha - eff_pot_fit_gauss = derf(mu_erf*x)/x - do i = 1, n_gauss_eff_pot - alpha = expo_gauss_eff_pot(i) - eff_pot_fit_gauss += coef_gauss_eff_pot(i) * dexp(-alpha*x*x) - enddo + + BEGIN_DOC + ! + ! V(mu,r12) = -0.25 * (1 - erf(mu*r12))^2 + 1/(\sqrt(pi)mu) * exp(-(mu*r12)^2) + ! + ! but fitted with gaussians + ! + END_DOC + + implicit none + double precision, intent(in) :: x + integer :: i + double precision :: alpha + + eff_pot_fit_gauss = derf(mu_erf*x)/x + do i = 1, n_gauss_eff_pot + alpha = expo_gauss_eff_pot(i) + eff_pot_fit_gauss += coef_gauss_eff_pot(i) * dexp(-alpha*x*x) + enddo + end +! --- + BEGIN_PROVIDER [integer, n_fit_1_erf_x] - implicit none - BEGIN_DOC -! - END_DOC - n_fit_1_erf_x = 2 + + implicit none + + n_fit_1_erf_x = 2 END_PROVIDER +! --- + BEGIN_PROVIDER [double precision, expos_slat_gauss_1_erf_x, (n_fit_1_erf_x)] - implicit none - BEGIN_DOC -! 1 - erf(mu*x) is fitted with a Slater and gaussian as in Eq.A15 of JCP 154, 084119 (2021) -! -! 1 - erf(mu*x) = e^{-expos_slat_gauss_1_erf_x(1) * mu *x} * e^{-expos_slat_gauss_1_erf_x(2) * mu^2 * x^2} - END_DOC - expos_slat_gauss_1_erf_x(1) = 1.09529d0 - expos_slat_gauss_1_erf_x(2) = 0.756023d0 + + BEGIN_DOC + ! + ! 1 - erf(mu*x) is fitted with a Slater and gaussian as in Eq.A15 of JCP 154, 084119 (2021) + ! + ! 1 - erf(mu*x) = e^{-expos_slat_gauss_1_erf_x(1) * mu *x} * e^{-expos_slat_gauss_1_erf_x(2) * mu^2 * x^2} + ! + END_DOC + + implicit none + + expos_slat_gauss_1_erf_x(1) = 1.09529d0 + expos_slat_gauss_1_erf_x(2) = 0.756023d0 + END_PROVIDER ! --- @@ -151,12 +175,14 @@ END_PROVIDER double precision function fit_1_erf_x(x) BEGIN_DOC + ! ! fit_1_erf_x(x) = \sum_i c_i exp (-alpha_i x^2) \approx (1 - erf(mu*x)) + ! END_DOC implicit none - integer :: i double precision, intent(in) :: x + integer :: i fit_1_erf_x = 0.d0 do i = 1, n_max_fit_slat @@ -171,11 +197,13 @@ end &BEGIN_PROVIDER [double precision, coef_gauss_1_erf_x_2, (ng_fit_jast)] BEGIN_DOC + ! ! (1 - erf(mu*x))^2 = \sum_i coef_gauss_1_erf_x_2(i) * exp(-expo_gauss_1_erf_x_2(i) * x^2) ! ! This is based on a fit of (1 - erf(mu*x)) by exp(-alpha * x) exp(-beta*mu^2x^2) ! ! and the slater function exp(-alpha * x) is fitted with n_max_fit_slat gaussians + ! END_DOC implicit none @@ -286,50 +314,22 @@ END_PROVIDER ! --- double precision function fit_1_erf_x_2(x) - implicit none - double precision, intent(in) :: x - BEGIN_DOC -! fit_1_erf_x_2(x) = \sum_i c_i exp (-alpha_i x^2) \approx (1 - erf(mu*x))^2 - END_DOC - integer :: i - fit_1_erf_x_2 = 0.d0 - do i = 1, n_max_fit_slat - fit_1_erf_x_2 += dexp(-expo_gauss_1_erf_x_2(i) *x*x) * coef_gauss_1_erf_x_2(i) - enddo + + BEGIN_DOC + ! + ! fit_1_erf_x_2(x) = \sum_i c_i exp (-alpha_i x^2) \approx (1 - erf(mu*x))^2 + ! + END_DOC + + implicit none + double precision, intent(in) :: x + integer :: i + + fit_1_erf_x_2 = 0.d0 + do i = 1, n_max_fit_slat + fit_1_erf_x_2 += dexp(-expo_gauss_1_erf_x_2(i) *x*x) * coef_gauss_1_erf_x_2(i) + enddo end -subroutine inv_r_times_poly(r, dist_r, dist_vec, poly) - implicit none - BEGIN_DOC -! returns -! -! poly(1) = x / sqrt(x^2+y^2+z^2), poly(2) = y / sqrt(x^2+y^2+z^2), poly(3) = z / sqrt(x^2+y^2+z^2) -! -! with the arguments -! -! r(1) = x, r(2) = y, r(3) = z, dist_r = sqrt(x^2+y^2+z^2) -! -! dist_vec(1) = sqrt(y^2+z^2), dist_vec(2) = sqrt(x^2+z^2), dist_vec(3) = sqrt(x^2+y^2) - END_DOC - double precision, intent(in) :: r(3), dist_r, dist_vec(3) - double precision, intent(out):: poly(3) - double precision :: inv_dist - integer :: i - if (dist_r.gt. 1.d-8)then - inv_dist = 1.d0/dist_r - do i = 1, 3 - poly(i) = r(i) * inv_dist - enddo - else - do i = 1, 3 - if(dabs(r(i)).lt.dist_vec(i))then - inv_dist = 1.d0/dist_r - poly(i) = r(i) * inv_dist - else !if(dabs(r(i)))then - poly(i) = 1.d0 -! poly(i) = 0.d0 - endif - enddo - endif -end +! --- diff --git a/src/ao_many_one_e_ints/fit_slat_gauss.irp.f b/plugins/local/jastrow/fit_slat_gauss.irp.f similarity index 100% rename from src/ao_many_one_e_ints/fit_slat_gauss.irp.f rename to plugins/local/jastrow/fit_slat_gauss.irp.f diff --git a/plugins/local/jastrow/jast_1e_param.irp.f b/plugins/local/jastrow/jast_1e_param.irp.f new file mode 100644 index 00000000..eca150be --- /dev/null +++ b/plugins/local/jastrow/jast_1e_param.irp.f @@ -0,0 +1,104 @@ + +! --- + + BEGIN_PROVIDER [double precision, j1e_expo, (j1e_size, nucl_num)] +&BEGIN_PROVIDER [double precision, j1e_coef, (j1e_size, nucl_num)] + + BEGIN_DOC + ! + ! parameters of the 1e-Jastrow + ! + END_DOC + + implicit none + logical :: exists + integer :: i, j + integer :: ierr + + PROVIDE ezfio_filename + + ! --- + + if (mpi_master) then + call ezfio_has_jastrow_j1e_expo(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' + call MPI_BCAST(j1e_expo, (j1e_size*nucl_num), MPI_DOUBLE_PRECISION, 0, MPI_COMM_WORLD, ierr) + if (ierr /= MPI_SUCCESS) then + stop 'Unable to read j1e_expo with MPI' + endif + IRP_ENDIF + + if (exists) then + if (mpi_master) then + write(6,'(A)') '.. >>>>> [ IO READ: j1e_expo ] <<<<< ..' + call ezfio_get_jastrow_j1e_expo(j1e_expo) + IRP_IF MPI + call MPI_BCAST(j1e_expo, (j1e_size*nucl_num), MPI_DOUBLE_PRECISION, 0, MPI_COMM_WORLD, ierr) + if (ierr /= MPI_SUCCESS) then + stop 'Unable to read j1e_expo with MPI' + endif + IRP_ENDIF + endif + else + + j1e_expo = 1.d0 + call ezfio_set_jastrow_j1e_expo(j1e_expo) + endif + + ! --- + + if (mpi_master) then + call ezfio_has_jastrow_j1e_coef(exists) + endif + + IRP_IF MPI_DEBUG + print *, irp_here, mpi_rank + call MPI_BARRIER(MPI_COMM_WORLD, ierr) + IRP_ENDIF + + IRP_IF MPI + call MPI_BCAST(j1e_coef, (j1e_size*nucl_num), MPI_DOUBLE_PRECISION, 0, MPI_COMM_WORLD, ierr) + if (ierr /= MPI_SUCCESS) then + stop 'Unable to read j1e_coef with MPI' + endif + IRP_ENDIF + + if (exists) then + if (mpi_master) then + write(6,'(A)') '.. >>>>> [ IO READ: j1e_coef ] <<<<< ..' + call ezfio_get_jastrow_j1e_coef(j1e_coef) + IRP_IF MPI + call MPI_BCAST(j1e_coef, (j1e_size*nucl_num), MPI_DOUBLE_PRECISION, 0, MPI_COMM_WORLD, ierr) + if (ierr /= MPI_SUCCESS) then + stop 'Unable to read j1e_coef with MPI' + endif + IRP_ENDIF + endif + else + + j1e_coef = 0.d0 + call ezfio_set_jastrow_j1e_coef(j1e_coef) + endif + + ! --- + + print *, ' parameters of the 1e-Jastrow' + do i = 1, nucl_num + print*, ' for Z = ', nucl_charge(i) + do j = 1, j1e_size + write(*,'(I4, 2x, 2(E15.7, 2X))') j, j1e_coef(j,i), j1e_expo(j,i) + enddo + enddo + +END_PROVIDER + +! --- + diff --git a/plugins/local/jastrow/listj1b.irp.f b/plugins/local/jastrow/listj1b.irp.f new file mode 100644 index 00000000..49954d47 --- /dev/null +++ b/plugins/local/jastrow/listj1b.irp.f @@ -0,0 +1,371 @@ + +! --- + +BEGIN_PROVIDER [integer, List_env1s_size] + + implicit none + + PROVIDE env_type + + if(env_type .eq. "None") then + + List_env1s_size = 1 + + elseif(env_type .eq. "Prod_Gauss") then + + List_env1s_size = 2**nucl_num + + elseif(env_type .eq. "Sum_Gauss") then + + List_env1s_size = nucl_num + 1 + + else + + print *, ' Error in List_env1s_size: Unknown env_type = ', env_type + stop + + endif + + print *, ' nb of 1s-Gaussian in the envelope = ', List_env1s_size + +END_PROVIDER + +! --- + +BEGIN_PROVIDER [integer, List_env1s, (nucl_num, List_env1s_size)] + + implicit none + integer :: i, j + + if(nucl_num .gt. 32) then + print *, ' nucl_num = ', nucl_num, '> 32' + stop + endif + + List_env1s = 0 + + do i = 0, List_env1s_size-1 + do j = 0, nucl_num-1 + if (btest(i,j)) then + List_env1s(j+1,i+1) = 1 + endif + enddo + enddo + +END_PROVIDER + +! --- + + BEGIN_PROVIDER [ double precision, List_env1s_coef, ( List_env1s_size)] +&BEGIN_PROVIDER [ double precision, List_env1s_expo, ( List_env1s_size)] +&BEGIN_PROVIDER [ double precision, List_env1s_cent, (3, List_env1s_size)] + + implicit none + integer :: i, j, k, phase + double precision :: tmp_alphaj, tmp_alphak + double precision :: tmp_cent_x, tmp_cent_y, tmp_cent_z + + provide env_type env_expo env_coef + + if(env_type .eq. "None") then + + List_env1s_coef( 1) = 1.d0 + List_env1s_expo( 1) = 0.d0 + List_env1s_cent(1:3,1) = 0.d0 + + elseif(env_type .eq. "Prod_Gauss") then + + List_env1s_coef = 0.d0 + List_env1s_expo = 0.d0 + List_env1s_cent = 0.d0 + + do i = 1, List_env1s_size + + tmp_cent_x = 0.d0 + tmp_cent_y = 0.d0 + tmp_cent_z = 0.d0 + do j = 1, nucl_num + tmp_alphaj = dble(List_env1s(j,i)) * env_expo(j) + List_env1s_expo(i) += tmp_alphaj + tmp_cent_x += tmp_alphaj * nucl_coord(j,1) + tmp_cent_y += tmp_alphaj * nucl_coord(j,2) + tmp_cent_z += tmp_alphaj * nucl_coord(j,3) + enddo + + if(List_env1s_expo(i) .lt. 1d-10) cycle + + List_env1s_cent(1,i) = tmp_cent_x / List_env1s_expo(i) + List_env1s_cent(2,i) = tmp_cent_y / List_env1s_expo(i) + List_env1s_cent(3,i) = tmp_cent_z / List_env1s_expo(i) + enddo + + ! --- + + do i = 1, List_env1s_size + + do j = 2, nucl_num, 1 + tmp_alphaj = dble(List_env1s(j,i)) * env_expo(j) + do k = 1, j-1, 1 + tmp_alphak = dble(List_env1s(k,i)) * env_expo(k) + + List_env1s_coef(i) += tmp_alphaj * tmp_alphak * ( (nucl_coord(j,1) - nucl_coord(k,1)) * (nucl_coord(j,1) - nucl_coord(k,1)) & + + (nucl_coord(j,2) - nucl_coord(k,2)) * (nucl_coord(j,2) - nucl_coord(k,2)) & + + (nucl_coord(j,3) - nucl_coord(k,3)) * (nucl_coord(j,3) - nucl_coord(k,3)) ) + enddo + enddo + + if(List_env1s_expo(i) .lt. 1d-10) cycle + + List_env1s_coef(i) = List_env1s_coef(i) / List_env1s_expo(i) + enddo + + ! --- + + do i = 1, List_env1s_size + + phase = 0 + do j = 1, nucl_num + phase += List_env1s(j,i) + enddo + + List_env1s_coef(i) = (-1.d0)**dble(phase) * dexp(-List_env1s_coef(i)) + enddo + + elseif(env_type .eq. "Sum_Gauss") then + + List_env1s_coef( 1) = 1.d0 + List_env1s_expo( 1) = 0.d0 + List_env1s_cent(1:3,1) = 0.d0 + do i = 1, nucl_num + List_env1s_coef( i+1) = -1.d0 * env_coef(i) + List_env1s_expo( i+1) = env_expo(i) + List_env1s_cent(1,i+1) = nucl_coord(i,1) + List_env1s_cent(2,i+1) = nucl_coord(i,2) + List_env1s_cent(3,i+1) = nucl_coord(i,3) + enddo + + else + + print *, ' Error in List_env1s: Unknown env_type = ', env_type + stop + + endif + +END_PROVIDER + +! --- + +BEGIN_PROVIDER [integer, List_env1s_square_size] + + implicit none + double precision :: tmp + + if(env_type .eq. "None") then + + List_env1s_square_size = 1 + + elseif(env_type .eq. "Prod_Gauss") then + + List_env1s_square_size = 3**nucl_num + + elseif(env_type .eq. "Sum_Gauss") then + + tmp = 0.5d0 * dble(nucl_num) * (dble(nucl_num) + 3.d0) + List_env1s_square_size = int(tmp) + 1 + + else + + print *, ' Error in List_env1s_square_size: Unknown env_type = ', env_type + stop + + endif + + print *, ' nb of 1s-Gaussian in the square of envelope = ', List_env1s_square_size + +END_PROVIDER + +! --- + +BEGIN_PROVIDER [integer, List_env1s_square, (nucl_num, List_env1s_square_size)] + + implicit none + integer :: i, j, ii, jj + integer, allocatable :: M(:,:), p(:) + + if(nucl_num .gt. 32) then + print *, ' nucl_num = ', nucl_num, '> 32' + stop + endif + + List_env1s_square(:,:) = 0 + List_env1s_square(:,List_env1s_square_size) = 2 + + allocate(p(nucl_num)) + p = 0 + + do i = 2, List_env1s_square_size-1 + do j = 1, nucl_num + + ii = 0 + do jj = 1, j-1, 1 + ii = ii + p(jj) * 3**(jj-1) + enddo + p(j) = modulo(i-1-ii, 3**j) / 3**(j-1) + + List_env1s_square(j,i) = p(j) + enddo + enddo + +END_PROVIDER + +! --- + + BEGIN_PROVIDER [ double precision, List_env1s_square_coef, ( List_env1s_square_size)] +&BEGIN_PROVIDER [ double precision, List_env1s_square_expo, ( List_env1s_square_size)] +&BEGIN_PROVIDER [ double precision, List_env1s_square_cent, (3, List_env1s_square_size)] + + implicit none + integer :: i, j, k, phase + integer :: ii + double precision :: tmp_alphaj, tmp_alphak, facto + double precision :: tmp1, tmp2, tmp3, tmp4 + double precision :: xi, yi, zi, xj, yj, zj + double precision :: dx, dy, dz, r2 + + provide env_type env_expo env_coef + + if(env_type .eq. "None") then + + List_env1s_square_coef( 1) = 1.d0 + List_env1s_square_expo( 1) = 0.d0 + List_env1s_square_cent(1:3,1) = 0.d0 + + elseif(env_type .eq. "Prod_Gauss") then + + List_env1s_square_coef = 0.d0 + List_env1s_square_expo = 0.d0 + List_env1s_square_cent = 0.d0 + + do i = 1, List_env1s_square_size + + do j = 1, nucl_num + tmp_alphaj = dble(List_env1s_square(j,i)) * env_expo(j) + List_env1s_square_expo(i) += tmp_alphaj + List_env1s_square_cent(1,i) += tmp_alphaj * nucl_coord(j,1) + List_env1s_square_cent(2,i) += tmp_alphaj * nucl_coord(j,2) + List_env1s_square_cent(3,i) += tmp_alphaj * nucl_coord(j,3) + + enddo + + if(List_env1s_square_expo(i) .lt. 1d-10) cycle + + List_env1s_square_cent(1,i) = List_env1s_square_cent(1,i) / List_env1s_square_expo(i) + List_env1s_square_cent(2,i) = List_env1s_square_cent(2,i) / List_env1s_square_expo(i) + List_env1s_square_cent(3,i) = List_env1s_square_cent(3,i) / List_env1s_square_expo(i) + enddo + + ! --- + + do i = 1, List_env1s_square_size + + do j = 2, nucl_num, 1 + tmp_alphaj = dble(List_env1s_square(j,i)) * env_expo(j) + do k = 1, j-1, 1 + tmp_alphak = dble(List_env1s_square(k,i)) * env_expo(k) + + List_env1s_square_coef(i) += tmp_alphaj * tmp_alphak * ( (nucl_coord(j,1) - nucl_coord(k,1)) * (nucl_coord(j,1) - nucl_coord(k,1)) & + + (nucl_coord(j,2) - nucl_coord(k,2)) * (nucl_coord(j,2) - nucl_coord(k,2)) & + + (nucl_coord(j,3) - nucl_coord(k,3)) * (nucl_coord(j,3) - nucl_coord(k,3)) ) + enddo + enddo + + if(List_env1s_square_expo(i) .lt. 1d-10) cycle + + List_env1s_square_coef(i) = List_env1s_square_coef(i) / List_env1s_square_expo(i) + enddo + + ! --- + + do i = 1, List_env1s_square_size + + facto = 1.d0 + phase = 0 + do j = 1, nucl_num + tmp_alphaj = dble(List_env1s_square(j,i)) + + facto *= 2.d0 / (gamma(tmp_alphaj+1.d0) * gamma(3.d0-tmp_alphaj)) + phase += List_env1s_square(j,i) + enddo + + List_env1s_square_coef(i) = (-1.d0)**dble(phase) * facto * dexp(-List_env1s_square_coef(i)) + enddo + + elseif(env_type .eq. "Sum_Gauss") then + + ii = 1 + List_env1s_square_coef( ii) = 1.d0 + List_env1s_square_expo( ii) = 0.d0 + List_env1s_square_cent(1:3,ii) = 0.d0 + + do i = 1, nucl_num + ii = ii + 1 + List_env1s_square_coef( ii) = -2.d0 * env_coef(i) + List_env1s_square_expo( ii) = env_expo(i) + List_env1s_square_cent(1,ii) = nucl_coord(i,1) + List_env1s_square_cent(2,ii) = nucl_coord(i,2) + List_env1s_square_cent(3,ii) = nucl_coord(i,3) + enddo + + do i = 1, nucl_num + ii = ii + 1 + List_env1s_square_coef( ii) = 1.d0 * env_coef(i) * env_coef(i) + List_env1s_square_expo( ii) = 2.d0 * env_expo(i) + List_env1s_square_cent(1,ii) = nucl_coord(i,1) + List_env1s_square_cent(2,ii) = nucl_coord(i,2) + List_env1s_square_cent(3,ii) = nucl_coord(i,3) + enddo + + do i = 1, nucl_num-1 + + tmp1 = env_expo(i) + + xi = nucl_coord(i,1) + yi = nucl_coord(i,2) + zi = nucl_coord(i,3) + + do j = i+1, nucl_num + + tmp2 = env_expo(j) + tmp3 = tmp1 + tmp2 + tmp4 = 1.d0 / tmp3 + + xj = nucl_coord(j,1) + yj = nucl_coord(j,2) + zj = nucl_coord(j,3) + + dx = xi - xj + dy = yi - yj + dz = zi - zj + r2 = dx*dx + dy*dy + dz*dz + + ii = ii + 1 + ! x 2 to avoid doing integrals twice + List_env1s_square_coef( ii) = 2.d0 * dexp(-tmp1*tmp2*tmp4*r2) * env_coef(i) * env_coef(j) + List_env1s_square_expo( ii) = tmp3 + List_env1s_square_cent(1,ii) = tmp4 * (tmp1 * xi + tmp2 * xj) + List_env1s_square_cent(2,ii) = tmp4 * (tmp1 * yi + tmp2 * yj) + List_env1s_square_cent(3,ii) = tmp4 * (tmp1 * zi + tmp2 * zj) + enddo + enddo + + else + + print *, ' Error in List_env1s_square: Unknown env_type = ', env_type + stop + + endif + +END_PROVIDER + +! --- + diff --git a/src/mo_localization/84.mo_localization.bats b/plugins/local/mo_localization/84.mo_localization.bats similarity index 100% rename from src/mo_localization/84.mo_localization.bats rename to plugins/local/mo_localization/84.mo_localization.bats diff --git a/src/mo_localization/EZFIO.cfg b/plugins/local/mo_localization/EZFIO.cfg similarity index 100% rename from src/mo_localization/EZFIO.cfg rename to plugins/local/mo_localization/EZFIO.cfg diff --git a/src/mo_localization/NEED b/plugins/local/mo_localization/NEED similarity index 100% rename from src/mo_localization/NEED rename to plugins/local/mo_localization/NEED diff --git a/src/mo_localization/README.md b/plugins/local/mo_localization/README.md similarity index 100% rename from src/mo_localization/README.md rename to plugins/local/mo_localization/README.md diff --git a/src/mo_localization/break_spatial_sym.irp.f b/plugins/local/mo_localization/break_spatial_sym.irp.f similarity index 100% rename from src/mo_localization/break_spatial_sym.irp.f rename to plugins/local/mo_localization/break_spatial_sym.irp.f diff --git a/src/mo_localization/debug_gradient_loc.irp.f b/plugins/local/mo_localization/debug_gradient_loc.irp.f similarity index 100% rename from src/mo_localization/debug_gradient_loc.irp.f rename to plugins/local/mo_localization/debug_gradient_loc.irp.f diff --git a/src/mo_localization/debug_hessian_loc.irp.f b/plugins/local/mo_localization/debug_hessian_loc.irp.f similarity index 100% rename from src/mo_localization/debug_hessian_loc.irp.f rename to plugins/local/mo_localization/debug_hessian_loc.irp.f diff --git a/src/mo_localization/kick_the_mos.irp.f b/plugins/local/mo_localization/kick_the_mos.irp.f similarity index 100% rename from src/mo_localization/kick_the_mos.irp.f rename to plugins/local/mo_localization/kick_the_mos.irp.f diff --git a/src/mo_localization/localization.irp.f b/plugins/local/mo_localization/localization.irp.f similarity index 100% rename from src/mo_localization/localization.irp.f rename to plugins/local/mo_localization/localization.irp.f diff --git a/src/mo_localization/localization_sub.irp.f b/plugins/local/mo_localization/localization_sub.irp.f similarity index 100% rename from src/mo_localization/localization_sub.irp.f rename to plugins/local/mo_localization/localization_sub.irp.f diff --git a/src/ccsd/org/TANGLE_org_mode.sh b/plugins/local/mo_localization/org/TANGLE_org_mode.sh similarity index 100% rename from src/ccsd/org/TANGLE_org_mode.sh rename to plugins/local/mo_localization/org/TANGLE_org_mode.sh diff --git a/src/mo_localization/org/break_spatial_sym.org b/plugins/local/mo_localization/org/break_spatial_sym.org similarity index 100% rename from src/mo_localization/org/break_spatial_sym.org rename to plugins/local/mo_localization/org/break_spatial_sym.org diff --git a/src/mo_localization/org/debug_gradient_loc.org b/plugins/local/mo_localization/org/debug_gradient_loc.org similarity index 100% rename from src/mo_localization/org/debug_gradient_loc.org rename to plugins/local/mo_localization/org/debug_gradient_loc.org diff --git a/src/mo_localization/org/debug_hessian_loc.org b/plugins/local/mo_localization/org/debug_hessian_loc.org similarity index 100% rename from src/mo_localization/org/debug_hessian_loc.org rename to plugins/local/mo_localization/org/debug_hessian_loc.org diff --git a/src/mo_localization/org/kick_the_mos.org b/plugins/local/mo_localization/org/kick_the_mos.org similarity index 100% rename from src/mo_localization/org/kick_the_mos.org rename to plugins/local/mo_localization/org/kick_the_mos.org diff --git a/src/mo_localization/org/localization.org b/plugins/local/mo_localization/org/localization.org similarity index 100% rename from src/mo_localization/org/localization.org rename to plugins/local/mo_localization/org/localization.org diff --git a/src/non_h_ints_mu/NEED b/plugins/local/non_h_ints_mu/NEED similarity index 77% rename from src/non_h_ints_mu/NEED rename to plugins/local/non_h_ints_mu/NEED index c44c65af..48c1c24b 100644 --- a/src/non_h_ints_mu/NEED +++ b/plugins/local/non_h_ints_mu/NEED @@ -1,4 +1,5 @@ qmckl +hamiltonian jastrow ao_tc_eff_map bi_ortho_mos diff --git a/src/non_h_ints_mu/README.rst b/plugins/local/non_h_ints_mu/README.rst similarity index 100% rename from src/non_h_ints_mu/README.rst rename to plugins/local/non_h_ints_mu/README.rst diff --git a/plugins/local/non_h_ints_mu/deb_aos.irp.f b/plugins/local/non_h_ints_mu/deb_aos.irp.f new file mode 100644 index 00000000..c9bc9c9a --- /dev/null +++ b/plugins/local/non_h_ints_mu/deb_aos.irp.f @@ -0,0 +1,56 @@ + +! --- + +program deb_Aos + + implicit none + + my_grid_becke = .True. + PROVIDE tc_grid1_a tc_grid1_r + my_n_pt_r_grid = tc_grid1_r + my_n_pt_a_grid = tc_grid1_a + touch my_grid_becke my_n_pt_r_grid my_n_pt_a_grid + + if(tc_integ_type .eq. "numeric") then + my_extra_grid_becke = .True. + PROVIDE tc_grid2_a tc_grid2_r + my_n_pt_r_extra_grid = tc_grid2_r + my_n_pt_a_extra_grid = tc_grid2_a + touch my_extra_grid_becke my_n_pt_r_extra_grid my_n_pt_a_extra_grid + endif + + call print_aos() + +end + +! --- + +subroutine print_aos() + + implicit none + integer :: i, ipoint + double precision :: r(3) + double precision :: ao_val, ao_der(3), ao_lap + + PROVIDE final_grid_points aos_in_r_array aos_grad_in_r_array aos_lapl_in_r_array + + do ipoint = 1, n_points_final_grid + r(:) = final_grid_points(:,ipoint) + print*, r + enddo + + do ipoint = 1, n_points_final_grid + r(:) = final_grid_points(:,ipoint) + do i = 1, ao_num + ao_val = aos_in_r_array (i,ipoint) + ao_der(:) = aos_grad_in_r_array(i,ipoint,:) + ao_lap = aos_lapl_in_r_array(1,i,ipoint) + aos_lapl_in_r_array(2,i,ipoint) + aos_lapl_in_r_array(3,i,ipoint) + write(*, '(5(f15.7, 3X))') ao_val, ao_der, ao_lap + enddo + enddo + + return +end + +! --- + diff --git a/src/non_h_ints_mu/debug_fit.irp.f b/plugins/local/non_h_ints_mu/debug_fit.irp.f similarity index 54% rename from src/non_h_ints_mu/debug_fit.irp.f rename to plugins/local/non_h_ints_mu/debug_fit.irp.f index d3152836..d4b917ec 100644 --- a/src/non_h_ints_mu/debug_fit.irp.f +++ b/plugins/local/non_h_ints_mu/debug_fit.irp.f @@ -11,9 +11,12 @@ program debug_fit my_n_pt_a_grid = tc_grid1_a touch my_grid_becke my_n_pt_r_grid my_n_pt_a_grid - PROVIDE mu_erf j1b_pen + PROVIDE j2e_type mu_erf + PROVIDE j1e_type j1e_coef j1e_expo + PROVIDE env_type env_coef env_expo + provide tc_integ_type - if(j1b_type .ge. 100) then + if(tc_integ_type .eq. "numeric") then my_extra_grid_becke = .True. PROVIDE tc_grid2_a tc_grid2_r my_n_pt_r_extra_grid = tc_grid2_r @@ -21,12 +24,8 @@ program debug_fit touch my_extra_grid_becke my_n_pt_r_extra_grid my_n_pt_a_extra_grid endif - !call test_j1b_nucl() - !call test_grad_j1b_nucl() - !call test_lapl_j1b_nucl() - - !call test_list_b2() - !call test_list_b3() + !call test_env_nucl() + !call test_grad_env_nucl() !call test_fit_u() !call test_fit_u2() @@ -38,17 +37,17 @@ end ! --- -subroutine test_j1b_nucl() +subroutine test_env_nucl() implicit none integer :: ipoint double precision :: acc_ij, acc_tot, eps_ij, i_exc, i_num, normalz double precision :: r(3) - double precision, external :: j1b_nucl + double precision, external :: env_nucl - print*, ' test_j1b_nucl ...' + print*, ' test_env_nucl ...' - PROVIDE v_1b + PROVIDE env_val eps_ij = 1d-7 acc_tot = 0.d0 @@ -60,11 +59,11 @@ subroutine test_j1b_nucl() r(2) = final_grid_points(2,ipoint) r(3) = final_grid_points(3,ipoint) - i_exc = v_1b(ipoint) - i_num = j1b_nucl(r) + i_exc = env_val(ipoint) + i_num = env_nucl(r) acc_ij = dabs(i_exc - i_num) if(acc_ij .gt. eps_ij) then - print *, ' problem in v_1b on', ipoint + print *, ' problem in env_val on', ipoint print *, ' analyt = ', i_exc print *, ' numeri = ', i_num print *, ' diff = ', acc_ij @@ -78,23 +77,23 @@ subroutine test_j1b_nucl() print*, ' normalz = ', normalz return -end subroutine test_j1b_nucl +end ! --- -subroutine test_grad_j1b_nucl() +subroutine test_grad_env_nucl() implicit none integer :: ipoint double precision :: acc_ij, acc_tot, eps_ij, i_exc, i_num, normalz double precision :: r(3) - double precision, external :: grad_x_j1b_nucl_num - double precision, external :: grad_y_j1b_nucl_num - double precision, external :: grad_z_j1b_nucl_num + double precision, external :: grad_x_env_nucl_num + double precision, external :: grad_y_env_nucl_num + double precision, external :: grad_z_env_nucl_num - print*, ' test_grad_j1b_nucl ...' + PROVIDE env_grad - PROVIDE v_1b_grad + print*, ' test_grad_env_nucl ...' eps_ij = 1d-7 acc_tot = 0.d0 @@ -106,31 +105,31 @@ subroutine test_grad_j1b_nucl() r(2) = final_grid_points(2,ipoint) r(3) = final_grid_points(3,ipoint) - i_exc = v_1b_grad(1,ipoint) - i_num = grad_x_j1b_nucl_num(r) + i_exc = env_grad(1,ipoint) + i_num = grad_x_env_nucl_num(r) acc_ij = dabs(i_exc - i_num) if(acc_ij .gt. eps_ij) then - print *, ' problem in x of v_1b_grad on', ipoint + print *, ' problem in x of env_grad on', ipoint print *, ' analyt = ', i_exc print *, ' numeri = ', i_num print *, ' diff = ', acc_ij endif - i_exc = v_1b_grad(2,ipoint) - i_num = grad_y_j1b_nucl_num(r) + i_exc = env_grad(2,ipoint) + i_num = grad_y_env_nucl_num(r) acc_ij = dabs(i_exc - i_num) if(acc_ij .gt. eps_ij) then - print *, ' problem in y of v_1b_grad on', ipoint + print *, ' problem in y of env_grad on', ipoint print *, ' analyt = ', i_exc print *, ' numeri = ', i_num print *, ' diff = ', acc_ij endif - i_exc = v_1b_grad(3,ipoint) - i_num = grad_z_j1b_nucl_num(r) + i_exc = env_grad(3,ipoint) + i_num = grad_z_env_nucl_num(r) acc_ij = dabs(i_exc - i_num) if(acc_ij .gt. eps_ij) then - print *, ' problem in z of v_1b_grad on', ipoint + print *, ' problem in z of env_grad on', ipoint print *, ' analyt = ', i_exc print *, ' numeri = ', i_num print *, ' diff = ', acc_ij @@ -144,278 +143,7 @@ subroutine test_grad_j1b_nucl() print*, ' normalz = ', normalz return -end subroutine test_grad_j1b_nucl - -! --- - -subroutine test_lapl_j1b_nucl() - - implicit none - integer :: ipoint - double precision :: acc_ij, acc_tot, eps_ij, i_exc, i_num, normalz - double precision :: r(3) - double precision, external :: lapl_j1b_nucl - - print*, ' test_lapl_j1b_nucl ...' - - PROVIDE v_1b_lapl - - eps_ij = 1d-5 - acc_tot = 0.d0 - normalz = 0.d0 - - do ipoint = 1, n_points_final_grid - - r(1) = final_grid_points(1,ipoint) - r(2) = final_grid_points(2,ipoint) - r(3) = final_grid_points(3,ipoint) - - i_exc = v_1b_lapl(ipoint) - i_num = lapl_j1b_nucl(r) - acc_ij = dabs(i_exc - i_num) - if(acc_ij .gt. eps_ij) then - print *, ' problem in v_1b_lapl on', ipoint - print *, ' analyt = ', i_exc - print *, ' numeri = ', i_num - print *, ' diff = ', acc_ij - endif - - acc_tot += acc_ij - normalz += dabs(i_num) - enddo - - print*, ' acc_tot = ', acc_tot - print*, ' normalz = ', normalz - - return -end subroutine test_lapl_j1b_nucl - -! --- - -subroutine test_list_b2() - - implicit none - integer :: ipoint - double precision :: acc_ij, acc_tot, eps_ij, i_exc, i_num, normalz - double precision :: r(3) - double precision, external :: j1b_nucl - - print*, ' test_list_b2 ...' - - PROVIDE v_1b_list_b2 - - eps_ij = 1d-7 - acc_tot = 0.d0 - normalz = 0.d0 - - do ipoint = 1, n_points_final_grid - - r(1) = final_grid_points(1,ipoint) - r(2) = final_grid_points(2,ipoint) - r(3) = final_grid_points(3,ipoint) - - i_exc = v_1b_list_b2(ipoint) - i_num = j1b_nucl(r) - acc_ij = dabs(i_exc - i_num) - if(acc_ij .gt. eps_ij) then - print *, ' problem in list_b2 on', ipoint - print *, ' analyt = ', i_exc - print *, ' numeri = ', i_num - print *, ' diff = ', acc_ij - endif - - acc_tot += acc_ij - normalz += dabs(i_num) - enddo - - print*, ' acc_tot = ', acc_tot - print*, ' normalz = ', normalz - - return -end subroutine test_list_b2 - -! --- - -subroutine test_list_b3() - - implicit none - integer :: ipoint - double precision :: acc_ij, acc_tot, eps_ij, i_exc, i_tmp, i_num, normalz - double precision :: r(3) - double precision :: grad_num(3), eps_der, eps_lap, tmp_der, tmp_lap, i0, ip, im - double precision, external :: j1b_nucl_square - - print*, ' test_list_b3 ...' - - eps_ij = 1d-7 - - eps_der = 1d-5 - tmp_der = 0.5d0 / eps_der - - eps_lap = 1d-4 - tmp_lap = 1.d0 / (eps_lap*eps_lap) - - ! --- - - PROVIDE v_1b_list_b3 - - acc_tot = 0.d0 - normalz = 0.d0 - do ipoint = 1, n_points_final_grid - - r(1) = final_grid_points(1,ipoint) - r(2) = final_grid_points(2,ipoint) - r(3) = final_grid_points(3,ipoint) - - i_exc = v_1b_list_b3(ipoint) - i_num = j1b_nucl_square(r) - acc_ij = dabs(i_exc - i_num) - if(acc_ij .gt. eps_ij) then - print *, ' problem in list_b3 on', ipoint - print *, ' r = ', r - print *, ' r2 = ', r(1)*r(1) + r(2)*r(2) + r(3)*r(3) - print *, ' analyt = ', i_exc - print *, ' numeri = ', i_num - print *, ' diff = ', acc_ij - endif - - acc_tot += acc_ij - normalz += dabs(i_num) - enddo - - print*, ' acc_tot on val = ', acc_tot - print*, ' normalz on val = ', normalz - - ! --- - - PROVIDE v_1b_square_grad - - acc_tot = 0.d0 - normalz = 0.d0 - do ipoint = 1, n_points_final_grid - - r(1) = final_grid_points(1,ipoint) - r(2) = final_grid_points(2,ipoint) - r(3) = final_grid_points(3,ipoint) - - i_exc = v_1b_square_grad(ipoint,1) - r(1) = r(1) + eps_der - ip = j1b_nucl_square(r) - r(1) = r(1) - 2.d0 * eps_der - im = j1b_nucl_square(r) - r(1) = r(1) + eps_der - i_num = tmp_der * (ip - im) - acc_ij = dabs(i_exc - i_num) - if(acc_ij .gt. eps_ij) then - print *, ' problem in grad_x list_b3 on', ipoint - print *, ' r = ', r - print *, ' r2 = ', r(1)*r(1) + r(2)*r(2) + r(3)*r(3) - print *, ' analyt = ', i_exc - print *, ' numeri = ', i_num - print *, ' diff = ', acc_ij - endif - acc_tot += acc_ij - normalz += dabs(i_num) - - i_exc = v_1b_square_grad(ipoint,2) - r(2) = r(2) + eps_der - ip = j1b_nucl_square(r) - r(2) = r(2) - 2.d0 * eps_der - im = j1b_nucl_square(r) - r(2) = r(2) + eps_der - i_num = tmp_der * (ip - im) - acc_ij = dabs(i_exc - i_num) - if(acc_ij .gt. eps_ij) then - print *, ' problem in grad_y list_b3 on', ipoint - print *, ' r = ', r - print *, ' r2 = ', r(1)*r(1) + r(2)*r(2) + r(3)*r(3) - print *, ' analyt = ', i_exc - print *, ' numeri = ', i_num - print *, ' diff = ', acc_ij - endif - acc_tot += acc_ij - normalz += dabs(i_num) - - i_exc = v_1b_square_grad(ipoint,3) - r(3) = r(3) + eps_der - ip = j1b_nucl_square(r) - r(3) = r(3) - 2.d0 * eps_der - im = j1b_nucl_square(r) - r(3) = r(3) + eps_der - i_num = tmp_der * (ip - im) - acc_ij = dabs(i_exc - i_num) - if(acc_ij .gt. eps_ij) then - print *, ' problem in grad_z list_b3 on', ipoint - print *, ' r = ', r - print *, ' r2 = ', r(1)*r(1) + r(2)*r(2) + r(3)*r(3) - print *, ' analyt = ', i_exc - print *, ' numeri = ', i_num - print *, ' diff = ', acc_ij - endif - acc_tot += acc_ij - normalz += dabs(i_num) - enddo - - print*, ' acc_tot on grad = ', acc_tot - print*, ' normalz on grad = ', normalz - - ! --- - - PROVIDE v_1b_square_lapl - - acc_tot = 0.d0 - normalz = 0.d0 - do ipoint = 1, n_points_final_grid - - r(1) = final_grid_points(1,ipoint) - r(2) = final_grid_points(2,ipoint) - r(3) = final_grid_points(3,ipoint) - i0 = j1b_nucl_square(r) - - i_exc = v_1b_square_lapl(ipoint) - - r(1) = r(1) + eps_lap - ip = j1b_nucl_square(r) - r(1) = r(1) - 2.d0 * eps_lap - im = j1b_nucl_square(r) - r(1) = r(1) + eps_lap - i_num = tmp_lap * (ip - 2.d0 * i0 + im) - - r(2) = r(2) + eps_lap - ip = j1b_nucl_square(r) - r(2) = r(2) - 2.d0 * eps_lap - im = j1b_nucl_square(r) - r(2) = r(2) + eps_lap - i_num = i_num + tmp_lap * (ip - 2.d0 * i0 + im) - - r(3) = r(3) + eps_lap - ip = j1b_nucl_square(r) - r(3) = r(3) - 2.d0 * eps_lap - im = j1b_nucl_square(r) - r(3) = r(3) + eps_lap - i_num = i_num + tmp_lap * (ip - 2.d0 * i0 + im) - - acc_ij = dabs(i_exc - i_num) - if(acc_ij .gt. eps_ij) then - print *, ' problem in lapl list_b3 on', ipoint - print *, ' r = ', r - print *, ' r2 = ', r(1)*r(1) + r(2)*r(2) + r(3)*r(3) - print *, ' analyt = ', i_exc - print *, ' numeri = ', i_num - print *, ' diff = ', acc_ij - endif - - acc_tot += acc_ij - normalz += dabs(i_num) - enddo - - print*, ' acc_tot on lapl = ', acc_tot - print*, ' normalz on lapl = ', normalz - - ! --- - - return -end subroutine test_list_b3 +end ! --- @@ -516,7 +244,7 @@ subroutine test_fit_ugradu() enddo return -end subroutine test_fit_ugradu +end ! --- @@ -582,7 +310,7 @@ subroutine test_fit_u() enddo return -end subroutine test_fit_u +end ! --- @@ -649,7 +377,7 @@ subroutine test_fit_u2() enddo return -end subroutine test_fit_u2 +end ! --- @@ -673,10 +401,10 @@ subroutine test_grad1_u12_withsq_num() do ipoint = 1, n_points_final_grid - call get_grad1_u12_withsq_r1_seq(final_grid_points(1,ipoint), n_points_extra_final_grid, tmp_grad1_u12(1,ipoint,1) & - , tmp_grad1_u12(1,ipoint,2) & - , tmp_grad1_u12(1,ipoint,3) & - , tmp_grad1_u12_squared(1,ipoint)) + call get_grad1_u12_withsq_r1_seq(ipoint, n_points_extra_final_grid, tmp_grad1_u12(1,ipoint,1) & + , tmp_grad1_u12(1,ipoint,2) & + , tmp_grad1_u12(1,ipoint,3) & + , tmp_grad1_u12_squared(1,ipoint)) do jpoint = 1, n_points_extra_final_grid i_exc = grad1_u12_squared_num(jpoint,ipoint) @@ -714,7 +442,7 @@ subroutine test_grad1_u12_withsq_num() print*, ' accuracy (%) = ', 100.d0 * acc_tot / normalz return -end subroutine test_grad1_u12_withsq_num +end ! --- diff --git a/src/non_h_ints_mu/debug_integ_jmu_modif.irp.f b/plugins/local/non_h_ints_mu/debug_integ_jmu_modif.irp.f similarity index 67% rename from src/non_h_ints_mu/debug_integ_jmu_modif.irp.f rename to plugins/local/non_h_ints_mu/debug_integ_jmu_modif.irp.f index b9e8df25..8d3a163c 100644 --- a/src/non_h_ints_mu/debug_integ_jmu_modif.irp.f +++ b/plugins/local/non_h_ints_mu/debug_integ_jmu_modif.irp.f @@ -11,40 +11,40 @@ program debug_integ_jmu_modif my_n_pt_a_grid = tc_grid1_a touch my_grid_becke my_n_pt_r_grid my_n_pt_a_grid - PROVIDE mu_erf j1b_pen + PROVIDE mu_erf -! call test_v_ij_u_cst_mu_j1b() -! call test_v_ij_erf_rk_cst_mu_j1b() -! call test_x_v_ij_erf_rk_cst_mu_j1b() -! call test_int2_u2_j1b2() -! call test_int2_grad1u2_grad2u2_j1b2() -! call test_int2_u_grad1u_total_j1b2() +! call test_v_ij_u_cst_mu_env() +! call test_v_ij_erf_rk_cst_mu_env() +! call test_x_v_ij_erf_rk_cst_mu_env() +! call test_int2_u2_env2() +! call test_int2_grad1u2_grad2u2_env2() +! call test_int2_u_grad1u_total_env2() ! -! call test_int2_grad1_u12_ao() +! call test_int2_grad1_u12_ao_num() ! ! call test_grad12_j12() - call test_tchint_rsdft() -! call test_u12sq_j1bsq() -! call test_u12_grad1_u12_j1b_grad1_j1b() -! !call test_gradu_squared_u_ij_mu() +! call test_u12sq_envsq() +! call test_u12_grad1_u12_env_grad1_env() !call test_vect_overlap_gauss_r12_ao() !call test_vect_overlap_gauss_r12_ao_with1s() + !call test_Ir2_Mu_long_Du_0() + end ! --- -subroutine test_v_ij_u_cst_mu_j1b() +subroutine test_v_ij_u_cst_mu_env() implicit none integer :: i, j, ipoint double precision :: acc_ij, acc_tot, eps_ij, i_exc, i_num, normalz - double precision, external :: num_v_ij_u_cst_mu_j1b + double precision, external :: num_v_ij_u_cst_mu_env - print*, ' test_v_ij_u_cst_mu_j1b ...' + print*, ' test_v_ij_u_cst_mu_env ...' - PROVIDE v_ij_u_cst_mu_j1b_fit + PROVIDE v_ij_u_cst_mu_env_fit eps_ij = 1d-3 acc_tot = 0.d0 @@ -54,11 +54,11 @@ subroutine test_v_ij_u_cst_mu_j1b() do j = 1, ao_num do i = 1, ao_num - i_exc = v_ij_u_cst_mu_j1b_fit(i,j,ipoint) - i_num = num_v_ij_u_cst_mu_j1b (i,j,ipoint) + i_exc = v_ij_u_cst_mu_env_fit(i,j,ipoint) + i_num = num_v_ij_u_cst_mu_env (i,j,ipoint) acc_ij = dabs(i_exc - i_num) if(acc_ij .gt. eps_ij) then - print *, ' problem in v_ij_u_cst_mu_j1b_fit on', i, j, ipoint + print *, ' problem in v_ij_u_cst_mu_env_fit on', i, j, ipoint print *, ' analyt integ = ', i_exc print *, ' numeri integ = ', i_num print *, ' diff = ', acc_ij @@ -70,24 +70,23 @@ subroutine test_v_ij_u_cst_mu_j1b() enddo enddo - print*, ' acc_tot = ', acc_tot - print*, ' normalz = ', normalz + print*, ' acc_tot (%) = ', 100.d0 * acc_tot / normalz return -end subroutine test_v_ij_u_cst_mu_j1b +end ! --- -subroutine test_v_ij_erf_rk_cst_mu_j1b() +subroutine test_v_ij_erf_rk_cst_mu_env() implicit none integer :: i, j, ipoint double precision :: acc_ij, acc_tot, eps_ij, i_exc, i_num, normalz - double precision, external :: num_v_ij_erf_rk_cst_mu_j1b + double precision, external :: num_v_ij_erf_rk_cst_mu_env - print*, ' test_v_ij_erf_rk_cst_mu_j1b ...' + print*, ' test_v_ij_erf_rk_cst_mu_env ...' - PROVIDE v_ij_erf_rk_cst_mu_j1b + PROVIDE v_ij_erf_rk_cst_mu_env eps_ij = 1d-3 acc_tot = 0.d0 @@ -98,11 +97,11 @@ subroutine test_v_ij_erf_rk_cst_mu_j1b() do j = 1, ao_num do i = 1, ao_num - i_exc = v_ij_erf_rk_cst_mu_j1b(i,j,ipoint) - i_num = num_v_ij_erf_rk_cst_mu_j1b(i,j,ipoint) + i_exc = v_ij_erf_rk_cst_mu_env(i,j,ipoint) + i_num = num_v_ij_erf_rk_cst_mu_env(i,j,ipoint) acc_ij = dabs(i_exc - i_num) if(acc_ij .gt. eps_ij) then - print *, ' problem in v_ij_erf_rk_cst_mu_j1b on', i, j, ipoint + print *, ' problem in v_ij_erf_rk_cst_mu_env on', i, j, ipoint print *, ' analyt integ = ', i_exc print *, ' numeri integ = ', i_num print *, ' diff = ', acc_ij @@ -118,20 +117,20 @@ subroutine test_v_ij_erf_rk_cst_mu_j1b() print*, ' normalz = ', normalz return -end subroutine test_v_ij_erf_rk_cst_mu_j1b +end ! --- -subroutine test_x_v_ij_erf_rk_cst_mu_j1b() +subroutine test_x_v_ij_erf_rk_cst_mu_env() implicit none integer :: i, j, ipoint double precision :: acc_ij, acc_tot, eps_ij, i_exc, i_num, normalz double precision :: integ(3) - print*, ' test_x_v_ij_erf_rk_cst_mu_j1b ...' + print*, ' test_x_v_ij_erf_rk_cst_mu_env ...' - PROVIDE x_v_ij_erf_rk_cst_mu_j1b + PROVIDE x_v_ij_erf_rk_cst_mu_env eps_ij = 1d-3 acc_tot = 0.d0 @@ -142,13 +141,13 @@ subroutine test_x_v_ij_erf_rk_cst_mu_j1b() do j = 1, ao_num do i = 1, ao_num - call num_x_v_ij_erf_rk_cst_mu_j1b(i, j, ipoint, integ) + call num_x_v_ij_erf_rk_cst_mu_env(i, j, ipoint, integ) - i_exc = x_v_ij_erf_rk_cst_mu_j1b(i,j,ipoint,1) + i_exc = x_v_ij_erf_rk_cst_mu_env(i,j,ipoint,1) i_num = integ(1) acc_ij = dabs(i_exc - i_num) if(acc_ij .gt. eps_ij) then - print *, ' problem in x part of x_v_ij_erf_rk_cst_mu_j1b on', i, j, ipoint + print *, ' problem in x part of x_v_ij_erf_rk_cst_mu_env on', i, j, ipoint print *, ' analyt integ = ', i_exc print *, ' numeri integ = ', i_num print *, ' diff = ', acc_ij @@ -156,11 +155,11 @@ subroutine test_x_v_ij_erf_rk_cst_mu_j1b() acc_tot += acc_ij normalz += dabs(i_num) - i_exc = x_v_ij_erf_rk_cst_mu_j1b(i,j,ipoint,2) + i_exc = x_v_ij_erf_rk_cst_mu_env(i,j,ipoint,2) i_num = integ(2) acc_ij = dabs(i_exc - i_num) if(acc_ij .gt. eps_ij) then - print *, ' problem in y part of x_v_ij_erf_rk_cst_mu_j1b on', i, j, ipoint + print *, ' problem in y part of x_v_ij_erf_rk_cst_mu_env on', i, j, ipoint print *, ' analyt integ = ', i_exc print *, ' numeri integ = ', i_num print *, ' diff = ', acc_ij @@ -168,11 +167,11 @@ subroutine test_x_v_ij_erf_rk_cst_mu_j1b() acc_tot += acc_ij normalz += dabs(i_num) - i_exc = x_v_ij_erf_rk_cst_mu_j1b(i,j,ipoint,3) + i_exc = x_v_ij_erf_rk_cst_mu_env(i,j,ipoint,3) i_num = integ(3) acc_ij = dabs(i_exc - i_num) if(acc_ij .gt. eps_ij) then - print *, ' problem in z part of x_v_ij_erf_rk_cst_mu_j1b on', i, j, ipoint + print *, ' problem in z part of x_v_ij_erf_rk_cst_mu_env on', i, j, ipoint print *, ' analyt integ = ', i_exc print *, ' numeri integ = ', i_num print *, ' diff = ', acc_ij @@ -188,35 +187,34 @@ subroutine test_x_v_ij_erf_rk_cst_mu_j1b() print*, ' normalz = ', normalz return -end subroutine test_x_v_ij_erf_rk_cst_mu_j1b +end ! --- -subroutine test_int2_u2_j1b2() +subroutine test_int2_u2_env2() implicit none integer :: i, j, ipoint double precision :: acc_ij, acc_tot, eps_ij, i_exc, i_num, normalz - double precision, external :: num_int2_u2_j1b2 + double precision, external :: num_int2_u2_env2 - print*, ' test_int2_u2_j1b2 ...' + print*, ' test_int2_u2_env2 ...' - PROVIDE int2_u2_j1b2 + PROVIDE int2_u2_env2 eps_ij = 1d-3 acc_tot = 0.d0 normalz = 0.d0 - !do ipoint = 1, 10 do ipoint = 1, n_points_final_grid do j = 1, ao_num do i = 1, ao_num - i_exc = int2_u2_j1b2(i,j,ipoint) - i_num = num_int2_u2_j1b2(i,j,ipoint) + i_exc = int2_u2_env2(i,j,ipoint) + i_num = num_int2_u2_env2(i,j,ipoint) acc_ij = dabs(i_exc - i_num) if(acc_ij .gt. eps_ij) then - print *, ' problem in int2_u2_j1b2 on', i, j, ipoint + print *, ' problem in int2_u2_env2 on', i, j, ipoint print *, ' analyt integ = ', i_exc print *, ' numeri integ = ', i_num print *, ' diff = ', acc_ij @@ -233,20 +231,20 @@ subroutine test_int2_u2_j1b2() print*, ' normalz = ', normalz return -end subroutine test_int2_u2_j1b2 +end ! --- -subroutine test_int2_grad1u2_grad2u2_j1b2() +subroutine test_int2_grad1u2_grad2u2_env2() implicit none integer :: i, j, ipoint double precision :: acc_ij, acc_tot, eps_ij, i_exc, i_num, normalz - double precision, external :: num_int2_grad1u2_grad2u2_j1b2 + double precision, external :: num_int2_grad1u2_grad2u2_env2 - print*, ' test_int2_grad1u2_grad2u2_j1b2 ...' + print*, ' test_int2_grad1u2_grad2u2_env2 ...' - PROVIDE int2_grad1u2_grad2u2_j1b2 + PROVIDE int2_grad1u2_grad2u2_env2 eps_ij = 1d-3 acc_tot = 0.d0 @@ -257,11 +255,11 @@ subroutine test_int2_grad1u2_grad2u2_j1b2() do j = 1, ao_num do i = 1, ao_num - i_exc = int2_grad1u2_grad2u2_j1b2(i,j,ipoint) - i_num = num_int2_grad1u2_grad2u2_j1b2(i,j,ipoint) + i_exc = int2_grad1u2_grad2u2_env2(i,j,ipoint) + i_num = num_int2_grad1u2_grad2u2_env2(i,j,ipoint) acc_ij = dabs(i_exc - i_num) if(acc_ij .gt. eps_ij) then - print *, ' problem in int2_grad1u2_grad2u2_j1b2 on', i, j, ipoint + print *, ' problem in int2_grad1u2_grad2u2_env2 on', i, j, ipoint print *, ' analyt integ = ', i_exc print *, ' numeri integ = ', i_num print *, ' diff = ', acc_ij @@ -277,18 +275,18 @@ subroutine test_int2_grad1u2_grad2u2_j1b2() print*, ' normalz = ', normalz return -end subroutine test_int2_grad1u2_grad2u2_j1b2 +end ! --- -subroutine test_int2_grad1_u12_ao() +subroutine test_int2_grad1_u12_ao_num() implicit none integer :: i, j, ipoint double precision :: acc_ij, acc_tot, eps_ij, i_exc, i_num, normalz double precision :: integ(3) - print*, ' test_int2_grad1_u12_ao ...' + print*, ' test_int2_grad1_u12_ao_num ...' PROVIDE int2_grad1_u12_ao @@ -346,11 +344,11 @@ subroutine test_int2_grad1_u12_ao() print*, ' normalz = ', normalz return -end subroutine test_int2_grad1_u12_ao +end ! --- -subroutine test_int2_u_grad1u_total_j1b2() +subroutine test_int2_u_grad1u_total_env2() implicit none integer :: i, j, ipoint @@ -358,10 +356,10 @@ subroutine test_int2_u_grad1u_total_j1b2() double precision :: x, y, z double precision :: integ(3) - print*, ' test_int2_u_grad1u_total_j1b2 ...' + print*, ' test_int2_u_grad1u_total_env2 ...' - PROVIDE int2_u_grad1u_j1b2 - PROVIDE int2_u_grad1u_x_j1b2 + PROVIDE int2_u_grad1u_env2 + PROVIDE int2_u_grad1u_x_env2 eps_ij = 1d-3 acc_tot = 0.d0 @@ -376,13 +374,13 @@ subroutine test_int2_u_grad1u_total_j1b2() do j = 1, ao_num do i = 1, ao_num - call num_int2_u_grad1u_total_j1b2(i, j, ipoint, integ) + call num_int2_u_grad1u_total_env2(i, j, ipoint, integ) - i_exc = x * int2_u_grad1u_j1b2(i,j,ipoint) - int2_u_grad1u_x_j1b2(i,j,ipoint,1) + i_exc = x * int2_u_grad1u_env2(i,j,ipoint) - int2_u_grad1u_x_env2(i,j,ipoint,1) i_num = integ(1) acc_ij = dabs(i_exc - i_num) if(acc_ij .gt. eps_ij) then - print *, ' problem in x part of int2_u_grad1u_total_j1b2 on', i, j, ipoint + print *, ' problem in x part of int2_u_grad1u_total_env2 on', i, j, ipoint print *, ' analyt integ = ', i_exc print *, ' numeri integ = ', i_num print *, ' diff = ', acc_ij @@ -390,11 +388,11 @@ subroutine test_int2_u_grad1u_total_j1b2() acc_tot += acc_ij normalz += dabs(i_num) - i_exc = y * int2_u_grad1u_j1b2(i,j,ipoint) - int2_u_grad1u_x_j1b2(i,j,ipoint,2) + i_exc = y * int2_u_grad1u_env2(i,j,ipoint) - int2_u_grad1u_x_env2(i,j,ipoint,2) i_num = integ(2) acc_ij = dabs(i_exc - i_num) if(acc_ij .gt. eps_ij) then - print *, ' problem in y part of int2_u_grad1u_total_j1b2 on', i, j, ipoint + print *, ' problem in y part of int2_u_grad1u_total_env2 on', i, j, ipoint print *, ' analyt integ = ', i_exc print *, ' numeri integ = ', i_num print *, ' diff = ', acc_ij @@ -402,11 +400,11 @@ subroutine test_int2_u_grad1u_total_j1b2() acc_tot += acc_ij normalz += dabs(i_num) - i_exc = z * int2_u_grad1u_j1b2(i,j,ipoint) - int2_u_grad1u_x_j1b2(i,j,ipoint,3) + i_exc = z * int2_u_grad1u_env2(i,j,ipoint) - int2_u_grad1u_x_env2(i,j,ipoint,3) i_num = integ(3) acc_ij = dabs(i_exc - i_num) if(acc_ij .gt. eps_ij) then - print *, ' problem in z part of int2_u_grad1u_total_j1b2 on', i, j, ipoint + print *, ' problem in z part of int2_u_grad1u_total_env2 on', i, j, ipoint print *, ' analyt integ = ', i_exc print *, ' numeri integ = ', i_num print *, ' diff = ', acc_ij @@ -422,109 +420,7 @@ subroutine test_int2_u_grad1u_total_j1b2() print*, ' normalz = ', normalz return -end subroutine test_int2_u_grad1u_total_j1b2 - -! --- - -subroutine test_gradu_squared_u_ij_mu() - - implicit none - integer :: i, j, ipoint - double precision :: acc_ij, acc_tot, eps_ij, i_exc, i_num, normalz - double precision, external :: num_gradu_squared_u_ij_mu - - print*, ' test_gradu_squared_u_ij_mu ...' - - PROVIDE gradu_squared_u_ij_mu - - eps_ij = 1d-3 - acc_tot = 0.d0 - normalz = 0.d0 - - do ipoint = 1, n_points_final_grid - do j = 1, ao_num - do i = 1, ao_num - - i_exc = gradu_squared_u_ij_mu(i,j,ipoint) - i_num = num_gradu_squared_u_ij_mu(i, j, ipoint) - acc_ij = dabs(i_exc - i_num) - if(acc_ij .gt. eps_ij) then - print *, ' problem in gradu_squared_u_ij_mu on', i, j, ipoint - print *, ' analyt integ = ', i_exc - print *, ' numeri integ = ', i_num - print *, ' diff = ', acc_ij - endif - acc_tot += acc_ij - normalz += dabs(i_num) - - enddo - enddo - enddo - - print*, ' acc_tot = ', acc_tot - print*, ' normalz = ', normalz - - return -end subroutine test_gradu_squared_u_ij_mu - -! --- - -subroutine test_tchint_rsdft() - - implicit none - integer :: i, j, m, ipoint, jpoint - double precision :: acc_ij, acc_tot, eps_ij, i_exc, i_num, normalz - double precision :: x(3), y(3), dj_1(3), dj_2(3), dj_3(3) - - print*, ' test rsdft_jastrow ...' - - PROVIDE grad1_u12_num - - eps_ij = 1d-4 - acc_tot = 0.d0 - normalz = 0.d0 - - do ipoint = 1, n_points_final_grid - x(1) = final_grid_points(1,ipoint) - x(2) = final_grid_points(2,ipoint) - x(3) = final_grid_points(3,ipoint) - - do jpoint = 1, n_points_extra_final_grid - y(1) = final_grid_points_extra(1,jpoint) - y(2) = final_grid_points_extra(2,jpoint) - y(3) = final_grid_points_extra(3,jpoint) - - dj_1(1) = grad1_u12_num(jpoint,ipoint,1) - dj_1(2) = grad1_u12_num(jpoint,ipoint,2) - dj_1(3) = grad1_u12_num(jpoint,ipoint,3) - - call get_tchint_rsdft_jastrow(x, y, dj_2) - - do m = 1, 3 - i_exc = dj_1(m) - i_num = dj_2(m) - acc_ij = dabs(i_exc - i_num) - if(acc_ij .gt. eps_ij) then - print *, ' problem on', ipoint, jpoint, m - print *, ' x = ', x - print *, ' y = ', y - print *, ' exc, num, diff = ', i_exc, i_num, acc_ij - call grad1_jmu_modif_num(x, y, dj_3) - print *, ' check = ', dj_3(m) - stop - endif - - acc_tot += acc_ij - normalz += dabs(i_exc) - enddo - enddo - enddo - - print*, ' acc_tot = ', acc_tot - print*, ' normalz = ', normalz - - return -end subroutine test_tchint_rsdft +end ! --- @@ -567,20 +463,20 @@ subroutine test_grad12_j12() print*, ' normalz = ', normalz return -end subroutine test_grad12_j12 +end ! --- -subroutine test_u12sq_j1bsq() +subroutine test_u12sq_envsq() implicit none integer :: i, j, ipoint double precision :: acc_ij, acc_tot, eps_ij, i_exc, i_num, normalz - double precision, external :: num_u12sq_j1bsq + double precision, external :: num_u12sq_envsq - print*, ' test_u12sq_j1bsq ...' + print*, ' test_u12sq_envsq ...' - PROVIDE u12sq_j1bsq + PROVIDE u12sq_envsq eps_ij = 1d-3 acc_tot = 0.d0 @@ -590,11 +486,11 @@ subroutine test_u12sq_j1bsq() do j = 1, ao_num do i = 1, ao_num - i_exc = u12sq_j1bsq(i,j,ipoint) - i_num = num_u12sq_j1bsq(i, j, ipoint) + i_exc = u12sq_envsq(i,j,ipoint) + i_num = num_u12sq_envsq(i, j, ipoint) acc_ij = dabs(i_exc - i_num) if(acc_ij .gt. eps_ij) then - print *, ' problem in u12sq_j1bsq on', i, j, ipoint + print *, ' problem in u12sq_envsq on', i, j, ipoint print *, ' analyt integ = ', i_exc print *, ' numeri integ = ', i_num print *, ' diff = ', acc_ij @@ -610,20 +506,20 @@ subroutine test_u12sq_j1bsq() print*, ' normalz = ', normalz return -end subroutine test_u12sq_j1bsq +end ! --- -subroutine test_u12_grad1_u12_j1b_grad1_j1b() +subroutine test_u12_grad1_u12_env_grad1_env() implicit none integer :: i, j, ipoint double precision :: acc_ij, acc_tot, eps_ij, i_exc, i_num, normalz - double precision, external :: num_u12_grad1_u12_j1b_grad1_j1b + double precision, external :: num_u12_grad1_u12_env_grad1_env - print*, ' test_u12_grad1_u12_j1b_grad1_j1b ...' + print*, ' test_u12_grad1_u12_env_grad1_env ...' - PROVIDE u12_grad1_u12_j1b_grad1_j1b + PROVIDE u12_grad1_u12_env_grad1_env eps_ij = 1d-3 acc_tot = 0.d0 @@ -633,11 +529,11 @@ subroutine test_u12_grad1_u12_j1b_grad1_j1b() do j = 1, ao_num do i = 1, ao_num - i_exc = u12_grad1_u12_j1b_grad1_j1b(i,j,ipoint) - i_num = num_u12_grad1_u12_j1b_grad1_j1b(i, j, ipoint) + i_exc = u12_grad1_u12_env_grad1_env(i,j,ipoint) + i_num = num_u12_grad1_u12_env_grad1_env(i, j, ipoint) acc_ij = dabs(i_exc - i_num) if(acc_ij .gt. eps_ij) then - print *, ' problem in u12_grad1_u12_j1b_grad1_j1b on', i, j, ipoint + print *, ' problem in u12_grad1_u12_env_grad1_env on', i, j, ipoint print *, ' analyt integ = ', i_exc print *, ' numeri integ = ', i_num print *, ' diff = ', acc_ij @@ -653,7 +549,7 @@ subroutine test_u12_grad1_u12_j1b_grad1_j1b() print*, ' normalz = ', normalz return -end subroutine test_u12_grad1_u12_j1b_grad1_j1b +end ! --- @@ -670,7 +566,7 @@ subroutine test_vect_overlap_gauss_r12_ao() print *, ' test_vect_overlap_gauss_r12_ao ...' - provide mu_erf final_grid_points_transp j1b_pen + provide mu_erf final_grid_points_transp expo_fit = expo_gauss_j_mu_x_2(1) @@ -740,7 +636,7 @@ subroutine test_vect_overlap_gauss_r12_ao() print*, ' normalz = ', normalz return -end subroutine test_vect_overlap_gauss_r12_ao +end ! --- @@ -757,13 +653,13 @@ subroutine test_vect_overlap_gauss_r12_ao_with1s() print *, ' test_vect_overlap_gauss_r12_ao_with1s ...' - provide mu_erf final_grid_points_transp j1b_pen + provide mu_erf final_grid_points_transp expo_fit = expo_gauss_j_mu_x_2(1) - beta = List_all_comb_b3_expo (2) - B_center(1) = List_all_comb_b3_cent(1,2) - B_center(2) = List_all_comb_b3_cent(2,2) - B_center(3) = List_all_comb_b3_cent(3,2) + beta = List_env1s_square_expo (2) + B_center(1) = List_env1s_square_cent(1,2) + B_center(2) = List_env1s_square_cent(2,2) + B_center(3) = List_env1s_square_cent(3,2) ! --- @@ -831,5 +727,52 @@ subroutine test_vect_overlap_gauss_r12_ao_with1s() print*, ' normalz = ', normalz return -end subroutine test_vect_overlap_gauss_r12_ao +end + +! --- + +subroutine test_Ir2_Mu_long_Du_0() + + implicit none + integer :: i, j, ipoint + double precision :: i_old, i_new + double precision :: acc_ij, acc_tot, eps_ij, normalz + + print*, ' test_Ir2_Mu_long_Du_0 ...' + + PROVIDE v_ij_erf_rk_cst_mu_env + PROVIDE Ir2_Mu_long_Du_0 + + eps_ij = 1d-10 + acc_tot = 0.d0 + normalz = 0.d0 + + do ipoint = 1, n_points_final_grid + do j = 1, ao_num + do i = 1, ao_num + + i_old = v_ij_erf_rk_cst_mu_env(i,j,ipoint) + i_new = Ir2_Mu_long_Du_0 (i,j,ipoint) + + acc_ij = dabs(i_old - i_new) + if(acc_ij .gt. eps_ij) then + print *, ' problem in Ir2_Mu_long_Du_0 on', i, j, ipoint + print *, ' old integ = ', i_old + print *, ' new integ = ', i_new + print *, ' diff = ', acc_ij + stop + endif + + acc_tot += acc_ij + normalz += dabs(i_old) + enddo + enddo + enddo + + print*, ' acc_tot (%) = ', 100.d0 * acc_tot / normalz + + return +end + +! --- diff --git a/plugins/local/non_h_ints_mu/grad_squared.irp.f b/plugins/local/non_h_ints_mu/grad_squared.irp.f new file mode 100644 index 00000000..342e1fe7 --- /dev/null +++ b/plugins/local/non_h_ints_mu/grad_squared.irp.f @@ -0,0 +1,125 @@ + +! --- + +BEGIN_PROVIDER [double precision, grad12_j12, (ao_num, ao_num, n_points_final_grid)] + + implicit none + integer :: ipoint, i, j, m, igauss + double precision :: r(3), delta, coef + double precision :: tmp1 + double precision :: time0, time1 + double precision, external :: overlap_gauss_r12_ao + + print*, ' providing grad12_j12 ...' + call wall_time(time0) + + PROVIDE int2_grad1u2_grad2u2_env2 + + do ipoint = 1, n_points_final_grid + tmp1 = env_val(ipoint) + tmp1 = tmp1 * tmp1 + do j = 1, ao_num + do i = 1, ao_num + grad12_j12(i,j,ipoint) = tmp1 * int2_grad1u2_grad2u2_env2(i,j,ipoint) + enddo + enddo + enddo + + FREE int2_grad1u2_grad2u2_env2 + + call wall_time(time1) + print*, ' Wall time for grad12_j12 (min) = ', (time1 - time0) / 60.d0 + +END_PROVIDER + +! --- + +BEGIN_PROVIDER [double precision, u12sq_envsq, (ao_num, ao_num, n_points_final_grid)] + + implicit none + integer :: ipoint, i, j + double precision :: tmp_x, tmp_y, tmp_z + double precision :: tmp1 + double precision :: time0, time1 + + print*, ' providing u12sq_envsq ...' + call wall_time(time0) + + ! do not free here + PROVIDE int2_u2_env2 + + do ipoint = 1, n_points_final_grid + tmp_x = env_grad(1,ipoint) + tmp_y = env_grad(2,ipoint) + tmp_z = env_grad(3,ipoint) + tmp1 = -0.5d0 * (tmp_x * tmp_x + tmp_y * tmp_y + tmp_z * tmp_z) + do j = 1, ao_num + do i = 1, ao_num + u12sq_envsq(i,j,ipoint) = tmp1 * int2_u2_env2(i,j,ipoint) + enddo + enddo + enddo + + call wall_time(time1) + print*, ' Wall time for u12sq_envsq (min) = ', (time1 - time0) / 60.d0 + +END_PROVIDER + +! --- + +BEGIN_PROVIDER [double precision, u12_grad1_u12_env_grad1_env, (ao_num, ao_num, n_points_final_grid)] + + implicit none + integer :: ipoint, i, j, m, igauss + double precision :: x, y, z + double precision :: tmp_v, tmp_x, tmp_y, tmp_z + double precision :: tmp3, tmp4, tmp5, tmp6, tmp7, tmp8, tmp9 + double precision :: time0, time1 + double precision, external :: overlap_gauss_r12_ao + + print*, ' providing u12_grad1_u12_env_grad1_env ...' + call wall_time(time0) + + PROVIDE int2_u_grad1u_env2 + PROVIDE int2_u_grad1u_x_env2 + + do ipoint = 1, n_points_final_grid + + x = final_grid_points(1,ipoint) + y = final_grid_points(2,ipoint) + z = final_grid_points(3,ipoint) + tmp_v = env_val (ipoint) + tmp_x = env_grad(1,ipoint) + tmp_y = env_grad(2,ipoint) + tmp_z = env_grad(3,ipoint) + + tmp3 = tmp_v * tmp_x + tmp4 = tmp_v * tmp_y + tmp5 = tmp_v * tmp_z + + tmp6 = -x * tmp3 + tmp7 = -y * tmp4 + tmp8 = -z * tmp5 + + do j = 1, ao_num + do i = 1, ao_num + + tmp9 = int2_u_grad1u_env2(i,j,ipoint) + + u12_grad1_u12_env_grad1_env(i,j,ipoint) = tmp6 * tmp9 + tmp3 * int2_u_grad1u_x_env2(i,j,ipoint,1) & + + tmp7 * tmp9 + tmp4 * int2_u_grad1u_x_env2(i,j,ipoint,2) & + + tmp8 * tmp9 + tmp5 * int2_u_grad1u_x_env2(i,j,ipoint,3) + enddo + enddo + enddo + + FREE int2_u_grad1u_env2 + FREE int2_u_grad1u_x_env2 + + call wall_time(time1) + print*, ' Wall time for u12_grad1_u12_env_grad1_env (min) = ', (time1 - time0) / 60.d0 + +END_PROVIDER + +! --- + diff --git a/src/non_h_ints_mu/grad_squared_manu.irp.f b/plugins/local/non_h_ints_mu/grad_squared_manu.irp.f similarity index 73% rename from src/non_h_ints_mu/grad_squared_manu.irp.f rename to plugins/local/non_h_ints_mu/grad_squared_manu.irp.f index dcfeff47..8bfddf7e 100644 --- a/src/non_h_ints_mu/grad_squared_manu.irp.f +++ b/plugins/local/non_h_ints_mu/grad_squared_manu.irp.f @@ -1,4 +1,6 @@ +! --- + BEGIN_PROVIDER [double precision, tc_grad_square_ao_test, (ao_num, ao_num, ao_num, ao_num)] BEGIN_DOC @@ -24,7 +26,7 @@ BEGIN_PROVIDER [double precision, tc_grad_square_ao_test, (ao_num, ao_num, ao_nu else - provide u12sq_j1bsq_test u12_grad1_u12_j1b_grad1_j1b_test grad12_j12_test + provide u12sq_envsq_test u12_grad1_u12_env_grad1_env_test grad12_j12_test allocate(b_mat(n_points_final_grid,ao_num,ao_num), tmp(ao_num,ao_num,n_points_final_grid)) @@ -48,12 +50,12 @@ BEGIN_PROVIDER [double precision, tc_grad_square_ao_test, (ao_num, ao_num, ao_nu !$OMP PARALLEL & !$OMP DEFAULT (NONE) & !$OMP PRIVATE (j, l, ipoint) & - !$OMP SHARED (tmp, ao_num, n_points_final_grid, u12sq_j1bsq_test, u12_grad1_u12_j1b_grad1_j1b_test, grad12_j12_test) + !$OMP SHARED (tmp, ao_num, n_points_final_grid, u12sq_envsq_test, u12_grad1_u12_env_grad1_env_test, grad12_j12_test) !$OMP DO SCHEDULE (static) do ipoint = 1, n_points_final_grid do j = 1, ao_num do l = 1, ao_num - tmp(l,j,ipoint) = u12sq_j1bsq_test(l,j,ipoint) + u12_grad1_u12_j1b_grad1_j1b_test(l,j,ipoint) + 0.5d0 * grad12_j12_test(l,j,ipoint) + tmp(l,j,ipoint) = u12sq_envsq_test(l,j,ipoint) + u12_grad1_u12_env_grad1_env_test(l,j,ipoint) + 0.5d0 * grad12_j12_test(l,j,ipoint) enddo enddo enddo @@ -102,7 +104,7 @@ BEGIN_PROVIDER [double precision, tc_grad_square_ao_test_ref, (ao_num, ao_num, a print*, ' providing tc_grad_square_ao_test_ref ...' call wall_time(time0) - provide u12sq_j1bsq_test u12_grad1_u12_j1b_grad1_j1b_test grad12_j12_test + provide u12sq_envsq_test u12_grad1_u12_env_grad1_env_test grad12_j12_test allocate(ac_mat(ao_num,ao_num,ao_num,ao_num), b_mat(n_points_final_grid,ao_num,ao_num), tmp(ao_num,ao_num,n_points_final_grid)) @@ -126,12 +128,12 @@ BEGIN_PROVIDER [double precision, tc_grad_square_ao_test_ref, (ao_num, ao_num, a !$OMP PARALLEL & !$OMP DEFAULT (NONE) & !$OMP PRIVATE (j, l, ipoint) & - !$OMP SHARED (tmp, ao_num, n_points_final_grid, u12sq_j1bsq_test, u12_grad1_u12_j1b_grad1_j1b_test, grad12_j12_test) + !$OMP SHARED (tmp, ao_num, n_points_final_grid, u12sq_envsq_test, u12_grad1_u12_env_grad1_env_test, grad12_j12_test) !$OMP DO SCHEDULE (static) do ipoint = 1, n_points_final_grid do j = 1, ao_num do l = 1, ao_num - tmp(l,j,ipoint) = u12sq_j1bsq_test(l,j,ipoint) + u12_grad1_u12_j1b_grad1_j1b_test(l,j,ipoint) + 0.5d0 * grad12_j12_test(l,j,ipoint) + tmp(l,j,ipoint) = u12sq_envsq_test(l,j,ipoint) + u12_grad1_u12_env_grad1_env_test(l,j,ipoint) + 0.5d0 * grad12_j12_test(l,j,ipoint) enddo enddo enddo @@ -170,7 +172,7 @@ END_PROVIDER ! --- -BEGIN_PROVIDER [ double precision, u12sq_j1bsq_test, (ao_num, ao_num, n_points_final_grid) ] +BEGIN_PROVIDER [ double precision, u12sq_envsq_test, (ao_num, ao_num, n_points_final_grid) ] implicit none integer :: ipoint, i, j @@ -178,29 +180,29 @@ BEGIN_PROVIDER [ double precision, u12sq_j1bsq_test, (ao_num, ao_num, n_points_f double precision :: tmp1 double precision :: time0, time1 - print*, ' providing u12sq_j1bsq_test ...' + print*, ' providing u12sq_envsq_test ...' call wall_time(time0) do ipoint = 1, n_points_final_grid - tmp_x = v_1b_grad(1,ipoint) - tmp_y = v_1b_grad(2,ipoint) - tmp_z = v_1b_grad(3,ipoint) + tmp_x = env_grad(1,ipoint) + tmp_y = env_grad(2,ipoint) + tmp_z = env_grad(3,ipoint) tmp1 = -0.5d0 * (tmp_x * tmp_x + tmp_y * tmp_y + tmp_z * tmp_z) do j = 1, ao_num do i = 1, ao_num - u12sq_j1bsq_test(i,j,ipoint) = tmp1 * int2_u2_j1b2_test(i,j,ipoint) + u12sq_envsq_test(i,j,ipoint) = tmp1 * int2_u2_env2_test(i,j,ipoint) enddo enddo enddo call wall_time(time1) - print*, ' Wall time for u12sq_j1bsq_test = ', time1 - time0 + print*, ' Wall time for u12sq_envsq_test (min) = ', (time1 - time0) / 60.d0 END_PROVIDER ! --- -BEGIN_PROVIDER [ double precision, u12_grad1_u12_j1b_grad1_j1b_test, (ao_num, ao_num, n_points_final_grid) ] +BEGIN_PROVIDER [double precision, u12_grad1_u12_env_grad1_env_test, (ao_num, ao_num, n_points_final_grid)] implicit none integer :: ipoint, i, j, m, igauss @@ -210,9 +212,9 @@ BEGIN_PROVIDER [ double precision, u12_grad1_u12_j1b_grad1_j1b_test, (ao_num, ao double precision :: time0, time1 double precision, external :: overlap_gauss_r12_ao - print*, ' providing u12_grad1_u12_j1b_grad1_j1b_test ...' + print*, ' providing u12_grad1_u12_env_grad1_env_test ...' - provide int2_u_grad1u_x_j1b2_test + provide int2_u_grad1u_x_env2_test call wall_time(time0) do ipoint = 1, n_points_final_grid @@ -220,10 +222,10 @@ BEGIN_PROVIDER [ double precision, u12_grad1_u12_j1b_grad1_j1b_test, (ao_num, ao x = final_grid_points(1,ipoint) y = final_grid_points(2,ipoint) z = final_grid_points(3,ipoint) - tmp_v = v_1b (ipoint) - tmp_x = v_1b_grad(1,ipoint) - tmp_y = v_1b_grad(2,ipoint) - tmp_z = v_1b_grad(3,ipoint) + tmp_v = env_val (ipoint) + tmp_x = env_grad(1,ipoint) + tmp_y = env_grad(2,ipoint) + tmp_z = env_grad(3,ipoint) tmp3 = tmp_v * tmp_x tmp4 = tmp_v * tmp_y @@ -236,23 +238,23 @@ BEGIN_PROVIDER [ double precision, u12_grad1_u12_j1b_grad1_j1b_test, (ao_num, ao do j = 1, ao_num do i = 1, ao_num - tmp9 = int2_u_grad1u_j1b2_test(i,j,ipoint) + tmp9 = int2_u_grad1u_env2_test(i,j,ipoint) - u12_grad1_u12_j1b_grad1_j1b_test(i,j,ipoint) = tmp6 * tmp9 + tmp3 * int2_u_grad1u_x_j1b2_test(i,j,ipoint,1) & - + tmp7 * tmp9 + tmp4 * int2_u_grad1u_x_j1b2_test(i,j,ipoint,2) & - + tmp8 * tmp9 + tmp5 * int2_u_grad1u_x_j1b2_test(i,j,ipoint,3) + u12_grad1_u12_env_grad1_env_test(i,j,ipoint) = tmp6 * tmp9 + tmp3 * int2_u_grad1u_x_env2_test(i,j,ipoint,1) & + + tmp7 * tmp9 + tmp4 * int2_u_grad1u_x_env2_test(i,j,ipoint,2) & + + tmp8 * tmp9 + tmp5 * int2_u_grad1u_x_env2_test(i,j,ipoint,3) enddo enddo enddo call wall_time(time1) - print*, ' Wall time for u12_grad1_u12_j1b_grad1_j1b_test = ', time1 - time0 + print*, ' Wall time for u12_grad1_u12_env_grad1_env_test (min) = ', (time1 - time0) / 60.d0 END_PROVIDER ! --- -BEGIN_PROVIDER [ double precision, grad12_j12_test, (ao_num, ao_num, n_points_final_grid) ] +BEGIN_PROVIDER [double precision, grad12_j12_test, (ao_num, ao_num, n_points_final_grid)] implicit none integer :: ipoint, i, j, m, igauss @@ -260,46 +262,32 @@ BEGIN_PROVIDER [ double precision, grad12_j12_test, (ao_num, ao_num, n_points_fi double precision :: tmp1 double precision :: time0, time1 double precision, external :: overlap_gauss_r12_ao - provide int2_grad1u2_grad2u2_j1b2_test + + provide int2_grad1u2_grad2u2_env2_test print*, ' providing grad12_j12_test ...' call wall_time(time0) - PROVIDE j1b_type - - if(j1b_type .eq. 3) then + if((j2e_type .eq. "Mu") .and. (env_type .eq. "Prod_Gauss")) then do ipoint = 1, n_points_final_grid - tmp1 = v_1b(ipoint) + tmp1 = env_val(ipoint) tmp1 = tmp1 * tmp1 do j = 1, ao_num do i = 1, ao_num - grad12_j12_test(i,j,ipoint) = tmp1 * int2_grad1u2_grad2u2_j1b2_test(i,j,ipoint) + grad12_j12_test(i,j,ipoint) = tmp1 * int2_grad1u2_grad2u2_env2_test(i,j,ipoint) enddo enddo enddo else - grad12_j12_test = 0.d0 - do ipoint = 1, n_points_final_grid - r(1) = final_grid_points(1,ipoint) - r(2) = final_grid_points(2,ipoint) - r(3) = final_grid_points(3,ipoint) - do j = 1, ao_num - do i = 1, ao_num - do igauss = 1, n_max_fit_slat - delta = expo_gauss_1_erf_x_2(igauss) - coef = coef_gauss_1_erf_x_2(igauss) - grad12_j12_test(i,j,ipoint) += -0.25d0 * coef * overlap_gauss_r12_ao(r, delta, i, j) - enddo - enddo - enddo - enddo + print *, ' Error in grad12_j12_test: Unknown Jastrow' + stop endif call wall_time(time1) - print*, ' Wall time for grad12_j12_test = ', time1 - time0 + print*, ' Wall time for grad12_j12_test (min) = ', (time1 - time0) / 60.d0 END_PROVIDER diff --git a/src/non_h_ints_mu/grad_tc_int.irp.f b/plugins/local/non_h_ints_mu/grad_tc_int.irp.f similarity index 100% rename from src/non_h_ints_mu/grad_tc_int.irp.f rename to plugins/local/non_h_ints_mu/grad_tc_int.irp.f diff --git a/plugins/local/non_h_ints_mu/j12_nucl_utils.irp.f b/plugins/local/non_h_ints_mu/j12_nucl_utils.irp.f new file mode 100644 index 00000000..27b92a13 --- /dev/null +++ b/plugins/local/non_h_ints_mu/j12_nucl_utils.irp.f @@ -0,0 +1,597 @@ + +! --- + +BEGIN_PROVIDER [double precision, env_val, (n_points_final_grid)] + + implicit none + integer :: ipoint, i, j, phase + double precision :: x, y, z, dx, dy, dz + double precision :: a, d, e, fact_r + + if(env_type .eq. "None") then + + env_val = 1.d0 + + elseif(env_type .eq. "Prod_Gauss") then + + ! v(r) = \Pi_{a} [1 - \exp(-\alpha_a (r - r_a)^2)] + + do ipoint = 1, n_points_final_grid + + x = final_grid_points(1,ipoint) + y = final_grid_points(2,ipoint) + z = final_grid_points(3,ipoint) + + fact_r = 1.d0 + do j = 1, nucl_num + a = env_expo(j) + dx = x - nucl_coord(j,1) + dy = y - nucl_coord(j,2) + dz = z - nucl_coord(j,3) + d = dx*dx + dy*dy + dz*dz + e = 1.d0 - dexp(-a*d) + + fact_r = fact_r * e + enddo + + env_val(ipoint) = fact_r + enddo + + elseif(env_type .eq. "Sum_Gauss") then + + ! v(r) = 1 - \sum_{a} \beta_a \exp(-\alpha_a (r - r_a)^2) + + do ipoint = 1, n_points_final_grid + + x = final_grid_points(1,ipoint) + y = final_grid_points(2,ipoint) + z = final_grid_points(3,ipoint) + + fact_r = 1.d0 + do j = 1, nucl_num + a = env_expo(j) + dx = x - nucl_coord(j,1) + dy = y - nucl_coord(j,2) + dz = z - nucl_coord(j,3) + d = dx*dx + dy*dy + dz*dz + + fact_r = fact_r - env_coef(j) * dexp(-a*d) + enddo + + env_val(ipoint) = fact_r + enddo + + else + + print *, ' Error in env_val: Unknown env_type = ', env_type + stop + + endif + +END_PROVIDER + +! --- + +BEGIN_PROVIDER [double precision, env_grad, (3, n_points_final_grid)] + + implicit none + integer :: ipoint, i, j, phase + double precision :: x, y, z, dx, dy, dz, r2 + double precision :: a, d, e + double precision :: fact_x, fact_y, fact_z + double precision :: ax_der, ay_der, az_der, a_expo + + if(env_type .eq. "None") then + + env_grad = 0.d0 + + elseif(env_type .eq. "Prod_Gauss") then + + ! v(r) = \Pi_{a} [1 - \exp(-\alpha_a (r - r_a)^2)] + + do ipoint = 1, n_points_final_grid + + x = final_grid_points(1,ipoint) + y = final_grid_points(2,ipoint) + z = final_grid_points(3,ipoint) + + fact_x = 0.d0 + fact_y = 0.d0 + fact_z = 0.d0 + do i = 1, List_env1s_size + + phase = 0 + a_expo = 0.d0 + ax_der = 0.d0 + ay_der = 0.d0 + az_der = 0.d0 + do j = 1, nucl_num + a = dble(List_env1s(j,i)) * env_expo(j) + dx = x - nucl_coord(j,1) + dy = y - nucl_coord(j,2) + dz = z - nucl_coord(j,3) + + phase += List_env1s(j,i) + a_expo += a * (dx*dx + dy*dy + dz*dz) + ax_der += a * dx + ay_der += a * dy + az_der += a * dz + enddo + e = -2.d0 * (-1.d0)**dble(phase) * dexp(-a_expo) + + fact_x += e * ax_der + fact_y += e * ay_der + fact_z += e * az_der + enddo + + env_grad(1,ipoint) = fact_x + env_grad(2,ipoint) = fact_y + env_grad(3,ipoint) = fact_z + enddo + + elseif(env_type .eq. "Sum_Gauss") then + + ! v(r) = 1 - \sum_{a} \beta_a \exp(-\alpha_a (r - r_a)^2) + + do ipoint = 1, n_points_final_grid + + x = final_grid_points(1,ipoint) + y = final_grid_points(2,ipoint) + z = final_grid_points(3,ipoint) + + ax_der = 0.d0 + ay_der = 0.d0 + az_der = 0.d0 + do j = 1, nucl_num + + dx = x - nucl_coord(j,1) + dy = y - nucl_coord(j,2) + dz = z - nucl_coord(j,3) + r2 = dx*dx + dy*dy + dz*dz + + a = env_expo(j) + e = a * env_coef(j) * dexp(-a * r2) + + ax_der += e * dx + ay_der += e * dy + az_der += e * dz + enddo + + env_grad(1,ipoint) = 2.d0 * ax_der + env_grad(2,ipoint) = 2.d0 * ay_der + env_grad(3,ipoint) = 2.d0 * az_der + enddo + + else + + print *, ' Error in env_grad: Unknown env_type = ', env_type + stop + + endif + +END_PROVIDER + +! --- + + BEGIN_PROVIDER [double precision, env_square_grad, (n_points_final_grid,3)] +&BEGIN_PROVIDER [double precision, env_square_lapl, (n_points_final_grid) ] + + implicit none + integer :: ipoint, i + double precision :: x, y, z, dx, dy, dz, r2 + double precision :: coef, expo, a_expo, tmp + double precision :: fact_x, fact_y, fact_z, fact_r + + PROVIDE List_env1s_square_coef List_env1s_square_expo List_env1s_square_cent + + if(env_type .eq. "None") then + + env_square_grad = 0.d0 + env_square_lapl = 0.d0 + + elseif((env_type .eq. "Prod_Gauss") .or. (env_type .eq. "Sum_Gauss")) then + + do ipoint = 1, n_points_final_grid + + x = final_grid_points(1,ipoint) + y = final_grid_points(2,ipoint) + z = final_grid_points(3,ipoint) + + fact_x = 0.d0 + fact_y = 0.d0 + fact_z = 0.d0 + fact_r = 0.d0 + do i = 1, List_env1s_square_size + + coef = List_env1s_square_coef(i) + expo = List_env1s_square_expo(i) + + dx = x - List_env1s_square_cent(1,i) + dy = y - List_env1s_square_cent(2,i) + dz = z - List_env1s_square_cent(3,i) + r2 = dx * dx + dy * dy + dz * dz + + a_expo = expo * r2 + tmp = coef * expo * dexp(-a_expo) + + fact_x += tmp * dx + fact_y += tmp * dy + fact_z += tmp * dz + fact_r += tmp * (3.d0 - 2.d0 * a_expo) + enddo + + env_square_grad(ipoint,1) = -2.d0 * fact_x + env_square_grad(ipoint,2) = -2.d0 * fact_y + env_square_grad(ipoint,3) = -2.d0 * fact_z + env_square_lapl(ipoint) = -2.d0 * fact_r + enddo + + else + + print *, ' Error in env_val_square_grad & env_val_square_lapl: Unknown env_type = ', env_type + stop + + endif + +END_PROVIDER + +! --- + +double precision function j12_mu_r12(r12) + + include 'constants.include.F' + + implicit none + double precision, intent(in) :: r12 + double precision :: mu_r12 + + mu_r12 = mu_erf * r12 + + j12_mu_r12 = 0.5d0 * r12 * (1.d0 - derf(mu_r12)) - inv_sq_pi_2 * dexp(-mu_r12*mu_r12) / mu_erf + + return +end + +! --- + +double precision function jmu_modif(r1, r2) + + implicit none + double precision, intent(in) :: r1(3), r2(3) + double precision, external :: j12_mu, j12_nucl + + jmu_modif = j12_mu(r1, r2) * j12_nucl(r1, r2) + + return +end + +! --- + +double precision function j12_mu_gauss(r1, r2) + + implicit none + double precision, intent(in) :: r1(3), r2(3) + integer :: i + double precision :: r12, coef, expo + + r12 = (r1(1) - r2(1)) * (r1(1) - r2(1)) & + + (r1(2) - r2(2)) * (r1(2) - r2(2)) & + + (r1(3) - r2(3)) * (r1(3) - r2(3)) + + j12_mu_gauss = 0.d0 + do i = 1, n_max_fit_slat + expo = expo_gauss_j_mu_x(i) + coef = coef_gauss_j_mu_x(i) + + j12_mu_gauss += coef * dexp(-expo*r12) + enddo + + return +end + +! --- + +double precision function j12_nucl(r1, r2) + + implicit none + double precision, intent(in) :: r1(3), r2(3) + double precision, external :: env_nucl + + j12_nucl = env_nucl(r1) * env_nucl(r2) + + return +end + +! --- + +double precision function grad_x_env_nucl_num(r) + + implicit none + double precision, intent(in) :: r(3) + double precision :: r_eps(3), eps, fp, fm, delta + double precision, external :: env_nucl + + eps = 1d-6 + r_eps = r + delta = max(eps, dabs(eps*r(1))) + + r_eps(1) = r_eps(1) + delta + fp = env_nucl(r_eps) + r_eps(1) = r_eps(1) - 2.d0 * delta + fm = env_nucl(r_eps) + + grad_x_env_nucl_num = 0.5d0 * (fp - fm) / delta + + return +end + +! --- + +double precision function grad_y_env_nucl_num(r) + + implicit none + double precision, intent(in) :: r(3) + double precision :: r_eps(3), eps, fp, fm, delta + double precision, external :: env_nucl + + eps = 1d-6 + r_eps = r + delta = max(eps, dabs(eps*r(2))) + + r_eps(2) = r_eps(2) + delta + fp = env_nucl(r_eps) + r_eps(2) = r_eps(2) - 2.d0 * delta + fm = env_nucl(r_eps) + + grad_y_env_nucl_num = 0.5d0 * (fp - fm) / delta + + return +end + +! --- + +double precision function grad_z_env_nucl_num(r) + + implicit none + double precision, intent(in) :: r(3) + double precision :: r_eps(3), eps, fp, fm, delta + double precision, external :: env_nucl + + eps = 1d-6 + r_eps = r + delta = max(eps, dabs(eps*r(3))) + + r_eps(3) = r_eps(3) + delta + fp = env_nucl(r_eps) + r_eps(3) = r_eps(3) - 2.d0 * delta + fm = env_nucl(r_eps) + + grad_z_env_nucl_num = 0.5d0 * (fp - fm) / delta + + return +end + +! --- + +double precision function lapl_env_nucl(r) + + implicit none + double precision, intent(in) :: r(3) + double precision :: r_eps(3), eps, fp, fm, delta + double precision, external :: grad_x_env_nucl_num + double precision, external :: grad_y_env_nucl_num + double precision, external :: grad_z_env_nucl_num + + eps = 1d-5 + r_eps = r + + lapl_env_nucl = 0.d0 + + ! --- + + delta = max(eps, dabs(eps*r(1))) + r_eps(1) = r_eps(1) + delta + fp = grad_x_env_nucl_num(r_eps) + r_eps(1) = r_eps(1) - 2.d0 * delta + fm = grad_x_env_nucl_num(r_eps) + r_eps(1) = r_eps(1) + delta + + lapl_env_nucl += 0.5d0 * (fp - fm) / delta + + ! --- + + delta = max(eps, dabs(eps*r(2))) + r_eps(2) = r_eps(2) + delta + fp = grad_y_env_nucl_num(r_eps) + r_eps(2) = r_eps(2) - 2.d0 * delta + fm = grad_y_env_nucl_num(r_eps) + r_eps(2) = r_eps(2) + delta + + lapl_env_nucl += 0.5d0 * (fp - fm) / delta + + ! --- + + delta = max(eps, dabs(eps*r(3))) + r_eps(3) = r_eps(3) + delta + fp = grad_z_env_nucl_num(r_eps) + r_eps(3) = r_eps(3) - 2.d0 * delta + fm = grad_z_env_nucl_num(r_eps) + r_eps(3) = r_eps(3) + delta + + lapl_env_nucl += 0.5d0 * (fp - fm) / delta + + ! --- + + return +end + +! --- + +double precision function grad1_x_jmu_modif(r1, r2) + + implicit none + double precision, intent(in) :: r1(3), r2(3) + double precision :: r1_eps(3), eps, fp, fm, delta + double precision, external :: jmu_modif + + eps = 1d-7 + r1_eps = r1 + delta = max(eps, dabs(eps*r1(1))) + + r1_eps(1) = r1_eps(1) + delta + fp = jmu_modif(r1_eps, r2) + r1_eps(1) = r1_eps(1) - 2.d0 * delta + fm = jmu_modif(r1_eps, r2) + + grad1_x_jmu_modif = 0.5d0 * (fp - fm) / delta + + return +end + +! --- + +double precision function grad1_y_jmu_modif(r1, r2) + + implicit none + double precision, intent(in) :: r1(3), r2(3) + double precision :: r1_eps(3), eps, fp, fm, delta + double precision, external :: jmu_modif + + eps = 1d-7 + r1_eps = r1 + delta = max(eps, dabs(eps*r1(2))) + + r1_eps(2) = r1_eps(2) + delta + fp = jmu_modif(r1_eps, r2) + r1_eps(2) = r1_eps(2) - 2.d0 * delta + fm = jmu_modif(r1_eps, r2) + + grad1_y_jmu_modif = 0.5d0 * (fp - fm) / delta + + return +end + +! --- + +double precision function grad1_z_jmu_modif(r1, r2) + + implicit none + double precision, intent(in) :: r1(3), r2(3) + double precision :: r1_eps(3), eps, fp, fm, delta + double precision, external :: jmu_modif + + eps = 1d-7 + r1_eps = r1 + delta = max(eps, dabs(eps*r1(3))) + + r1_eps(3) = r1_eps(3) + delta + fp = jmu_modif(r1_eps, r2) + r1_eps(3) = r1_eps(3) - 2.d0 * delta + fm = jmu_modif(r1_eps, r2) + + grad1_z_jmu_modif = 0.5d0 * (fp - fm) / delta + + return +end + +! --- + +double precision function grad1_x_j12_mu_num(r1, r2) + + implicit none + double precision, intent(in) :: r1(3), r2(3) + double precision :: r1_eps(3), eps, fp, fm, delta + double precision, external :: j12_mu + + eps = 1d-7 + r1_eps = r1 + delta = max(eps, dabs(eps*r1(1))) + + r1_eps(1) = r1_eps(1) + delta + fp = j12_mu(r1_eps, r2) + r1_eps(1) = r1_eps(1) - 2.d0 * delta + fm = j12_mu(r1_eps, r2) + + grad1_x_j12_mu_num = 0.5d0 * (fp - fm) / delta + + return +end + +! --- + +double precision function grad1_y_j12_mu_num(r1, r2) + + implicit none + double precision, intent(in) :: r1(3), r2(3) + double precision :: r1_eps(3), eps, fp, fm, delta + double precision, external :: j12_mu + + eps = 1d-7 + r1_eps = r1 + delta = max(eps, dabs(eps*r1(2))) + + r1_eps(2) = r1_eps(2) + delta + fp = j12_mu(r1_eps, r2) + r1_eps(2) = r1_eps(2) - 2.d0 * delta + fm = j12_mu(r1_eps, r2) + + grad1_y_j12_mu_num = 0.5d0 * (fp - fm) / delta + + return +end + +! --- + +double precision function grad1_z_j12_mu_num(r1, r2) + + implicit none + double precision, intent(in) :: r1(3), r2(3) + double precision :: r1_eps(3), eps, fp, fm, delta + double precision, external :: j12_mu + + eps = 1d-7 + r1_eps = r1 + delta = max(eps, dabs(eps*r1(3))) + + r1_eps(3) = r1_eps(3) + delta + fp = j12_mu(r1_eps, r2) + r1_eps(3) = r1_eps(3) - 2.d0 * delta + fm = j12_mu(r1_eps, r2) + + grad1_z_j12_mu_num = 0.5d0 * (fp - fm) / delta + + return +end + +! --- + +subroutine grad1_jmu_modif_num(r1, r2, grad) + + implicit none + + double precision, intent(in) :: r1(3), r2(3) + double precision, intent(out) :: grad(3) + + double precision :: tmp0, tmp1, tmp2, grad_u12(3) + + double precision, external :: j12_mu + double precision, external :: env_nucl + double precision, external :: grad_x_env_nucl_num + double precision, external :: grad_y_env_nucl_num + double precision, external :: grad_z_env_nucl_num + + call grad1_j12_mu(r1, r2, grad_u12) + + tmp0 = env_nucl(r1) + tmp1 = env_nucl(r2) + tmp2 = j12_mu(r1, r2) + + grad(1) = (tmp0 * grad_u12(1) + tmp2 * grad_x_env_nucl_num(r1)) * tmp1 + grad(2) = (tmp0 * grad_u12(2) + tmp2 * grad_y_env_nucl_num(r1)) * tmp1 + grad(3) = (tmp0 * grad_u12(3) + tmp2 * grad_z_env_nucl_num(r1)) * tmp1 + + return +end + +! --- + diff --git a/plugins/local/non_h_ints_mu/jast_1e.irp.f b/plugins/local/non_h_ints_mu/jast_1e.irp.f new file mode 100644 index 00000000..fbd032ed --- /dev/null +++ b/plugins/local/non_h_ints_mu/jast_1e.irp.f @@ -0,0 +1,451 @@ + +! --- + +BEGIN_PROVIDER [double precision, j1e_val, (n_points_final_grid)] + + implicit none + integer :: ipoint, i, j, p + double precision :: x, y, z, dx, dy, dz, d2 + double precision :: a, c, tmp + double precision :: time0, time1 + + PROVIDE j1e_type + + call wall_time(time0) + print*, ' providing j1e_val ...' + + if(j1e_type .eq. "None") then + + j1e_val = 0.d0 + + elseif(j1e_type .eq. "Gauss") then + + ! \sum_{A} \sum_p c_{p_A} \exp(-\alpha_{p_A} (r - R_A)^2) + + PROVIDE j1e_size j1e_coef j1e_expo + + do ipoint = 1, n_points_final_grid + + x = final_grid_points(1,ipoint) + y = final_grid_points(2,ipoint) + z = final_grid_points(3,ipoint) + + tmp = 0.d0 + do j = 1, nucl_num + + dx = x - nucl_coord(j,1) + dy = y - nucl_coord(j,2) + dz = z - nucl_coord(j,3) + d2 = dx*dx + dy*dy + dz*dz + + do p = 1, j1e_size + + c = j1e_coef(p,j) + a = j1e_expo(p,j) + + tmp = tmp + c * dexp(-a*d2) + enddo + enddo + + j1e_val(ipoint) = tmp + enddo + + else + + print *, ' Error in j1e_val: Unknown j1e_type = ', j1e_type + stop + + endif + + call wall_time(time1) + print*, ' Wall time for j1e_val (min) = ', (time1 - time0) / 60.d0 + call print_memory_usage() + +END_PROVIDER + +! --- + + BEGIN_PROVIDER [double precision, j1e_gradx, (n_points_final_grid)] +&BEGIN_PROVIDER [double precision, j1e_grady, (n_points_final_grid)] +&BEGIN_PROVIDER [double precision, j1e_gradz, (n_points_final_grid)] + + implicit none + integer :: ipoint, i, j, ij, p + integer :: ierr + logical :: exists + double precision :: x, y, z, dx, dy, dz, d2 + double precision :: a, c, g, tmp_x, tmp_y, tmp_z + double precision :: cx, cy, cz + double precision :: time0, time1 + double precision, allocatable :: Pa(:,:), Pb(:,:), Pt(:,:) + double precision, allocatable :: coef_fit(:), coef_fit2(:), coef_fit3(:,:) + + PROVIDE j1e_type + + call wall_time(time0) + print*, ' providing j1e_grad ...' + + if(j1e_type .eq. "None") then + + j1e_gradx = 0.d0 + j1e_grady = 0.d0 + j1e_gradz = 0.d0 + + elseif(j1e_type .eq. "Gauss") then + + ! - \sum_{A} (r - R_A) \sum_p c_{p_A} \exp(-\alpha_{p_A} (r - R_A)^2) + + PROVIDE j1e_size j1e_coef j1e_expo + + do ipoint = 1, n_points_final_grid + + x = final_grid_points(1,ipoint) + y = final_grid_points(2,ipoint) + z = final_grid_points(3,ipoint) + + tmp_x = 0.d0 + tmp_y = 0.d0 + tmp_z = 0.d0 + do j = 1, nucl_num + + dx = x - nucl_coord(j,1) + dy = y - nucl_coord(j,2) + dz = z - nucl_coord(j,3) + d2 = dx*dx + dy*dy + dz*dz + + do p = 1, j1e_size + + c = j1e_coef(p,j) + a = j1e_expo(p,j) + g = c * a * dexp(-a*d2) + + tmp_x = tmp_x + g * dx + tmp_y = tmp_y + g * dy + tmp_z = tmp_z + g * dz + enddo + enddo + + j1e_gradx(ipoint) = -2.d0 * tmp_x + j1e_grady(ipoint) = -2.d0 * tmp_y + j1e_gradz(ipoint) = -2.d0 * tmp_z + enddo + + elseif(j1e_type .eq. "Charge_Harmonizer") then + + ! -[(N-1)/2N] x \sum_{\mu,\nu} P_{\mu,\nu} \int dr2 [\grad_r1 J_2e(r1,r2)] \phi_\mu(r2) \phi_nu(r2) + + PROVIDE elec_alpha_num elec_beta_num elec_num + PROVIDE mo_coef + PROVIDE int2_grad1_u2e_ao + + allocate(Pa(ao_num,ao_num), Pb(ao_num,ao_num), Pt(ao_num,ao_num)) + + call dgemm( 'N', 'T', ao_num, ao_num, elec_alpha_num, 1.d0 & + , mo_coef, size(mo_coef, 1), mo_coef, size(mo_coef, 1) & + , 0.d0, Pa, size(Pa, 1)) + + if(elec_alpha_num .eq. elec_beta_num) then + Pb = Pa + else + call dgemm( 'N', 'T', ao_num, ao_num, elec_beta_num, 1.d0 & + , mo_coef, size(mo_coef, 1), mo_coef, size(mo_coef, 1) & + , 0.d0, Pb, size(Pb, 1)) + endif + Pt = Pa + Pb + + g = -0.5d0 * (dble(elec_num) - 1.d0) / dble(elec_num) + + call dgemv("T", ao_num*ao_num, n_points_final_grid, g, int2_grad1_u2e_ao(1,1,1,1), ao_num*ao_num, Pt, 1, 0.d0, j1e_gradx, 1) + call dgemv("T", ao_num*ao_num, n_points_final_grid, g, int2_grad1_u2e_ao(1,1,1,2), ao_num*ao_num, Pt, 1, 0.d0, j1e_grady, 1) + call dgemv("T", ao_num*ao_num, n_points_final_grid, g, int2_grad1_u2e_ao(1,1,1,3), ao_num*ao_num, Pt, 1, 0.d0, j1e_gradz, 1) + + FREE int2_grad1_u2e_ao + + deallocate(Pa, Pb, Pt) + +! elseif(j1e_type .eq. "Charge_Harmonizer_AO") then +! +! ! \grad_1 \sum_{\eta} C_{\eta} \chi_{\eta} +! ! where +! ! \chi_{\eta} are the AOs +! ! C_{\eta} are fitted to mimic (j1e_type .eq. "Charge_Harmonizer") +! ! +! ! The - sign is in the parameters C_{\eta} +! +! PROVIDE aos_grad_in_r_array +! +! allocate(coef_fit(ao_num)) +! +! if(mpi_master) then +! call ezfio_has_jastrow_j1e_coef_ao(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' +! call MPI_BCAST(coef_fit, ao_num, MPI_DOUBLE_PRECISION, 0, MPI_COMM_WORLD, ierr) +! if (ierr /= MPI_SUCCESS) then +! stop 'Unable to read j1e_coef_ao with MPI' +! endif +! IRP_ENDIF +! if(exists) then +! if(mpi_master) then +! write(6,'(A)') '.. >>>>> [ IO READ: j1e_coef_ao ] <<<<< ..' +! call ezfio_get_jastrow_j1e_coef_ao(coef_fit) +! IRP_IF MPI +! call MPI_BCAST(coef_fit, ao_num, MPI_DOUBLE_PRECISION, 0, MPI_COMM_WORLD, ierr) +! if (ierr /= MPI_SUCCESS) then +! stop 'Unable to read j1e_coef_ao with MPI' +! endif +! IRP_ENDIF +! endif +! else +! +! call get_j1e_coef_fit_ao(ao_num, coef_fit) +! call ezfio_set_jastrow_j1e_coef_ao(coef_fit) +! +! endif +! +! !$OMP PARALLEL & +! !$OMP DEFAULT (NONE) & +! !$OMP PRIVATE (i, ipoint, c) & +! !$OMP SHARED (n_points_final_grid, ao_num, & +! !$OMP aos_grad_in_r_array, coef_fit, & +! !$OMP j1e_gradx, j1e_grady, j1e_gradz) +! !$OMP DO SCHEDULE (static) +! do ipoint = 1, n_points_final_grid +! +! j1e_gradx(ipoint) = 0.d0 +! j1e_grady(ipoint) = 0.d0 +! j1e_gradz(ipoint) = 0.d0 +! do i = 1, ao_num +! c = coef_fit(i) +! j1e_gradx(ipoint) = j1e_gradx(ipoint) + c * aos_grad_in_r_array(i,ipoint,1) +! j1e_grady(ipoint) = j1e_grady(ipoint) + c * aos_grad_in_r_array(i,ipoint,2) +! j1e_gradz(ipoint) = j1e_gradz(ipoint) + c * aos_grad_in_r_array(i,ipoint,3) +! enddo +! enddo +! !$OMP END DO +! !$OMP END PARALLEL +! +! deallocate(coef_fit) + + elseif(j1e_type .eq. "Charge_Harmonizer_AO") then + + ! \grad_1 \sum_{\eta,\beta} C_{\eta,\beta} \chi_{\eta} \chi_{\beta} + ! where + ! \chi_{\eta} are the AOs + ! C_{\eta,\beta} are fitted to mimic (j1e_type .eq. "Charge_Harmonizer") + ! + ! The - sign is in the parameters C_{\eta,\beta} + + PROVIDE aos_grad_in_r_array + + allocate(coef_fit2(ao_num*ao_num)) + + if(mpi_master) then + call ezfio_has_jastrow_j1e_coef_ao2(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' + call MPI_BCAST(coef_fit2, ao_num*ao_num, MPI_DOUBLE_PRECISION, 0, MPI_COMM_WORLD, ierr) + if (ierr /= MPI_SUCCESS) then + stop 'Unable to read j1e_coef_ao2 with MPI' + endif + IRP_ENDIF + if(exists) then + if(mpi_master) then + write(6,'(A)') '.. >>>>> [ IO READ: j1e_coef_ao2 ] <<<<< ..' + call ezfio_get_jastrow_j1e_coef_ao2(coef_fit2) + IRP_IF MPI + call MPI_BCAST(coef_fit2, ao_num*ao_num, MPI_DOUBLE_PRECISION, 0, MPI_COMM_WORLD, ierr) + if (ierr /= MPI_SUCCESS) then + stop 'Unable to read j1e_coef_ao2 with MPI' + endif + IRP_ENDIF + endif + else + + call get_j1e_coef_fit_ao2(ao_num*ao_num, coef_fit2) + call ezfio_set_jastrow_j1e_coef_ao2(coef_fit2) + + endif + + !$OMP PARALLEL & + !$OMP DEFAULT (NONE) & + !$OMP PRIVATE (i, j, ij, ipoint, c) & + !$OMP SHARED (n_points_final_grid, ao_num, & + !$OMP aos_grad_in_r_array, coef_fit2, & + !$OMP aos_in_r_array, j1e_gradx, j1e_grady, j1e_gradz) + !$OMP DO SCHEDULE (static) + do ipoint = 1, n_points_final_grid + + j1e_gradx(ipoint) = 0.d0 + j1e_grady(ipoint) = 0.d0 + j1e_gradz(ipoint) = 0.d0 + + do i = 1, ao_num + do j = 1, ao_num + ij = (i-1)*ao_num + j + + c = coef_fit2(ij) + + j1e_gradx(ipoint) += c * (aos_in_r_array(i,ipoint) * aos_grad_in_r_array(j,ipoint,1) + aos_grad_in_r_array(i,ipoint,1) * aos_in_r_array(j,ipoint)) + j1e_grady(ipoint) += c * (aos_in_r_array(i,ipoint) * aos_grad_in_r_array(j,ipoint,2) + aos_grad_in_r_array(i,ipoint,2) * aos_in_r_array(j,ipoint)) + j1e_gradz(ipoint) += c * (aos_in_r_array(i,ipoint) * aos_grad_in_r_array(j,ipoint,3) + aos_grad_in_r_array(i,ipoint,3) * aos_in_r_array(j,ipoint)) + enddo + enddo + enddo + !$OMP END DO + !$OMP END PARALLEL + + deallocate(coef_fit2) + +! elseif(j1e_type .eq. "Charge_Harmonizer_AO3") then +! +! ! \sum_{\eta} \vec{C}_{\eta} \chi_{\eta} +! ! where +! ! \chi_{\eta} are the AOs +! ! \vec{C}_{\eta} are fitted to mimic (j1e_type .eq. "Charge_Harmonizer") +! ! +! ! The - sign is in the parameters \vec{C}_{\eta} +! +! PROVIDE aos_grad_in_r_array +! +! allocate(coef_fit3(ao_num,3)) +! +! if(mpi_master) then +! call ezfio_has_jastrow_j1e_coef_ao3(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' +! call MPI_BCAST(coef_fit3, (ao_num*3), MPI_DOUBLE_PRECISION, 0, MPI_COMM_WORLD, ierr) +! if (ierr /= MPI_SUCCESS) then +! stop 'Unable to read j1e_coef_ao3 with MPI' +! endif +! IRP_ENDIF +! if(exists) then +! if(mpi_master) then +! write(6,'(A)') '.. >>>>> [ IO READ: j1e_coef_ao3 ] <<<<< ..' +! call ezfio_get_jastrow_j1e_coef_ao3(coef_fit3) +! IRP_IF MPI +! call MPI_BCAST(coef_fit3, (ao_num*3), MPI_DOUBLE_PRECISION, 0, MPI_COMM_WORLD, ierr) +! if (ierr /= MPI_SUCCESS) then +! stop 'Unable to read j1e_coef_ao3 with MPI' +! endif +! IRP_ENDIF +! endif +! else +! +! call get_j1e_coef_fit_ao3(ao_num, coef_fit3) +! call ezfio_set_jastrow_j1e_coef_ao3(coef_fit3) +! +! endif +! +! !$OMP PARALLEL & +! !$OMP DEFAULT (NONE) & +! !$OMP PRIVATE (i, ipoint, cx, cy, cz) & +! !$OMP SHARED (n_points_final_grid, ao_num, & +! !$OMP aos_grad_in_r_array, coef_fit3, & +! !$OMP aos_in_r_array, j1e_gradx, j1e_grady, j1e_gradz) +! !$OMP DO SCHEDULE (static) +! do ipoint = 1, n_points_final_grid +! +! j1e_gradx(ipoint) = 0.d0 +! j1e_grady(ipoint) = 0.d0 +! j1e_gradz(ipoint) = 0.d0 +! do i = 1, ao_num +! cx = coef_fit3(i,1) +! cy = coef_fit3(i,2) +! cz = coef_fit3(i,3) +! +! j1e_gradx(ipoint) += cx * aos_in_r_array(i,ipoint) +! j1e_grady(ipoint) += cy * aos_in_r_array(i,ipoint) +! j1e_gradz(ipoint) += cz * aos_in_r_array(i,ipoint) +! enddo +! enddo +! !$OMP END DO +! !$OMP END PARALLEL +! +! deallocate(coef_fit3) + + else + + print *, ' Error in j1e_grad: Unknown j1e_type = ', j1e_type + stop + + endif + + call wall_time(time1) + print*, ' Wall time for j1e_grad (min) = ', (time1 - time0) / 60.d0 + call print_memory_usage() + +END_PROVIDER + +! --- + +BEGIN_PROVIDER [double precision, j1e_lapl, (n_points_final_grid)] + + implicit none + integer :: ipoint, i, j, p + double precision :: x, y, z, dx, dy, dz, d2 + double precision :: a, c, g, tmp + + if(j1e_type .eq. "None") then + + j1e_lapl = 0.d0 + + elseif(j1e_type .eq. "Gauss") then + + ! - \sum_{A} (r - R_A) \sum_p c_{p_A} \exp(-\alpha_{p_A} (r - R_A)^2) + + PROVIDE j1e_size j1e_coef j1e_expo + + do ipoint = 1, n_points_final_grid + + x = final_grid_points(1,ipoint) + y = final_grid_points(2,ipoint) + z = final_grid_points(3,ipoint) + + tmp = 0.d0 + do j = 1, nucl_num + + dx = x - nucl_coord(j,1) + dy = y - nucl_coord(j,2) + dz = z - nucl_coord(j,3) + d2 = dx*dx + dy*dy + dz*dz + + do p = 1, j1e_size + + c = j1e_coef(p,j) + a = j1e_expo(p,j) + g = c * a * dexp(-a*d2) + + tmp = tmp + (2.d0 * a * d2 - 3.d0) * g + enddo + enddo + + j1e_lapl(ipoint) = tmp + enddo + + else + + print *, ' Error in j1e_lapl: Unknown j1e_type = ', j1e_type + stop + + endif + +END_PROVIDER + +! --- + diff --git a/plugins/local/non_h_ints_mu/jast_1e_utils.irp.f b/plugins/local/non_h_ints_mu/jast_1e_utils.irp.f new file mode 100644 index 00000000..842908a7 --- /dev/null +++ b/plugins/local/non_h_ints_mu/jast_1e_utils.irp.f @@ -0,0 +1,395 @@ + +! --- + +subroutine get_j1e_coef_fit_ao(dim_fit, coef_fit) + + implicit none + integer , intent(in) :: dim_fit + double precision, intent(out) :: coef_fit(dim_fit) + + integer :: i, ipoint + double precision :: g + double precision :: t0, t1 + double precision, allocatable :: A(:,:), b(:), A_inv(:,:) + double precision, allocatable :: Pa(:,:), Pb(:,:), Pt(:,:) + double precision, allocatable :: u1e_tmp(:) + + + PROVIDE j1e_type + PROVIDE int2_u2e_ao + PROVIDE elec_alpha_num elec_beta_num elec_num + PROVIDE mo_coef + PROVIDE ao_overlap + + call wall_time(t0) + print*, ' PROVIDING the representation of 1e-Jastrow in AOs ... ' + + ! --- --- --- + ! get u1e(r) + + allocate(Pa(ao_num,ao_num), Pb(ao_num,ao_num), Pt(ao_num,ao_num)) + + call dgemm( 'N', 'T', ao_num, ao_num, elec_alpha_num, 1.d0 & + , mo_coef, size(mo_coef, 1), mo_coef, size(mo_coef, 1) & + , 0.d0, Pa, size(Pa, 1)) + + if(elec_alpha_num .eq. elec_beta_num) then + Pb = Pa + else + call dgemm( 'N', 'T', ao_num, ao_num, elec_beta_num, 1.d0 & + , mo_coef, size(mo_coef, 1), mo_coef, size(mo_coef, 1) & + , 0.d0, Pb, size(Pb, 1)) + endif + Pt = Pa + Pb + + allocate(u1e_tmp(n_points_final_grid)) + + g = -0.5d0 * (dble(elec_num) - 1.d0) / dble(elec_num) + call dgemv("T", ao_num*ao_num, n_points_final_grid, g, int2_u2e_ao, ao_num*ao_num, Pt, 1, 0.d0, u1e_tmp, 1) + + FREE int2_u2e_ao + + deallocate(Pa, Pb, Pt) + + ! --- --- --- + ! get A & b + + allocate(A(ao_num,ao_num), b(ao_num)) + + A(1:ao_num,1:ao_num) = ao_overlap(1:ao_num,1:ao_num) + + !$OMP PARALLEL & + !$OMP DEFAULT (NONE) & + !$OMP PRIVATE (i, ipoint) & + !$OMP SHARED (n_points_final_grid, ao_num, & + !$OMP final_weight_at_r_vector, aos_in_r_array_transp, u1e_tmp, b) + !$OMP DO SCHEDULE (static) + do i = 1, ao_num + b(i) = 0.d0 + do ipoint = 1, n_points_final_grid + b(i) = b(i) + final_weight_at_r_vector(ipoint) * aos_in_r_array_transp(ipoint,i) * u1e_tmp(ipoint) + enddo + enddo + !$OMP END DO + !$OMP END PARALLEL + + deallocate(u1e_tmp) + + ! --- --- --- + ! solve Ax = b + + allocate(A_inv(ao_num,ao_num)) + call get_inverse(A, ao_num, ao_num, A_inv, ao_num) + + ! coef_fit = A_inv x b + call dgemv("N", ao_num, ao_num, 1.d0, A_inv, ao_num, b, 1, 0.d0, coef_fit, 1) + + integer :: j + double precision :: tmp, acc, nrm + + acc = 0.d0 + nrm = 0.d0 + print *, ' check A_inv' + do i = 1, ao_num + tmp = 0.d0 + do j = 1, ao_num + tmp += ao_overlap(i,j) * coef_fit(j) + enddo + tmp = tmp - b(i) + if(dabs(tmp) .gt. 1d-8) then + print*, ' problem found in fitting 1e-Jastrow' + print*, i, tmp + endif + + acc += dabs(tmp) + nrm += dabs(b(i)) + enddo + print *, ' Relative Error (%) =', 100.d0*acc/nrm + + deallocate(A, A_inv, b) + + call wall_time(t1) + print*, ' END after (min) ', (t1-t0)/60.d0 + + return +end + +! --- + +subroutine get_j1e_coef_fit_ao2(dim_fit, coef_fit) + + implicit none + integer , intent(in) :: dim_fit + double precision, intent(out) :: coef_fit(dim_fit) + + integer :: i, j, k, l, ipoint + integer :: ij, kl + double precision :: g + double precision :: t0, t1 + double precision, allocatable :: A(:,:), b(:), A_inv(:,:) + double precision, allocatable :: Pa(:,:), Pb(:,:), Pt(:,:) + double precision, allocatable :: u1e_tmp(:) + + + PROVIDE j1e_type + PROVIDE int2_u2e_ao + PROVIDE elec_alpha_num elec_beta_num elec_num + PROVIDE mo_coef + + call wall_time(t0) + print*, ' PROVIDING the representation of 1e-Jastrow in AOs x AOs ... ' + + ! --- --- --- + ! get u1e(r) + + allocate(Pa(ao_num,ao_num), Pb(ao_num,ao_num), Pt(ao_num,ao_num)) + + call dgemm( 'N', 'T', ao_num, ao_num, elec_alpha_num, 1.d0 & + , mo_coef, size(mo_coef, 1), mo_coef, size(mo_coef, 1) & + , 0.d0, Pa, size(Pa, 1)) + + if(elec_alpha_num .eq. elec_beta_num) then + Pb = Pa + else + call dgemm( 'N', 'T', ao_num, ao_num, elec_beta_num, 1.d0 & + , mo_coef, size(mo_coef, 1), mo_coef, size(mo_coef, 1) & + , 0.d0, Pb, size(Pb, 1)) + endif + Pt = Pa + Pb + + allocate(u1e_tmp(n_points_final_grid)) + + g = -0.5d0 * (dble(elec_num) - 1.d0) / dble(elec_num) + call dgemv("T", ao_num*ao_num, n_points_final_grid, g, int2_u2e_ao, ao_num*ao_num, Pt, 1, 0.d0, u1e_tmp, 1) + + FREE int2_u2e_ao + + deallocate(Pa, Pb, Pt) + + ! --- --- --- + ! get A + + allocate(A(ao_num*ao_num,ao_num*ao_num)) + + !$OMP PARALLEL & + !$OMP DEFAULT (NONE) & + !$OMP PRIVATE (i, j, k, l, ij, kl, ipoint) & + !$OMP SHARED (n_points_final_grid, ao_num, & + !$OMP final_weight_at_r_vector, aos_in_r_array_transp, A) + !$OMP DO COLLAPSE(2) + do k = 1, ao_num + do l = 1, ao_num + kl = (k-1)*ao_num + l + + do i = 1, ao_num + do j = 1, ao_num + ij = (i-1)*ao_num + j + + A(ij,kl) = 0.d0 + do ipoint = 1, n_points_final_grid + A(ij,kl) += final_weight_at_r_vector(ipoint) * aos_in_r_array_transp(ipoint,i) * aos_in_r_array_transp(ipoint,j) & + * aos_in_r_array_transp(ipoint,k) * aos_in_r_array_transp(ipoint,l) + enddo + enddo + enddo + enddo + enddo + !$OMP END DO + !$OMP END PARALLEL + +! print *, ' A' +! do ij = 1, ao_num*ao_num +! write(*, '(100000(f15.7))') (A(ij,kl), kl = 1, ao_num*ao_num) +! enddo + + ! --- --- --- + ! get b + + allocate(b(ao_num*ao_num)) + + !$OMP PARALLEL & + !$OMP DEFAULT (NONE) & + !$OMP PRIVATE (i, j, ij, ipoint) & + !$OMP SHARED (n_points_final_grid, ao_num, & + !$OMP final_weight_at_r_vector, aos_in_r_array_transp, u1e_tmp, b) + !$OMP DO COLLAPSE(2) + do i = 1, ao_num + do j = 1, ao_num + ij = (i-1)*ao_num + j + + b(ij) = 0.d0 + do ipoint = 1, n_points_final_grid + b(ij) = b(ij) + final_weight_at_r_vector(ipoint) * aos_in_r_array_transp(ipoint,i) * aos_in_r_array_transp(ipoint,j) * u1e_tmp(ipoint) + enddo + enddo + enddo + !$OMP END DO + !$OMP END PARALLEL + + deallocate(u1e_tmp) + + ! --- --- --- + ! solve Ax = b + + allocate(A_inv(ao_num*ao_num,ao_num*ao_num)) + !call get_inverse(A, ao_num*ao_num, ao_num*ao_num, A_inv, ao_num*ao_num) + call get_pseudo_inverse(A, ao_num*ao_num, ao_num*ao_num, ao_num*ao_num, A_inv, ao_num*ao_num, 5d-8) + + ! coef_fit = A_inv x b + call dgemv("N", ao_num*ao_num, ao_num*ao_num, 1.d0, A_inv, ao_num*ao_num, b, 1, 0.d0, coef_fit, 1) + + integer :: mn + double precision :: tmp, acc, nrm + + acc = 0.d0 + nrm = 0.d0 + do ij = 1, ao_num*ao_num + tmp = 0.d0 + do kl = 1, ao_num*ao_num + tmp += A(ij,kl) * coef_fit(kl) + enddo + tmp = tmp - b(ij) + if(dabs(tmp) .gt. 1d-7) then + print*, ' problem found in fitting 1e-Jastrow' + print*, ij, tmp + endif + + acc += dabs(tmp) + nrm += dabs(b(ij)) + enddo + print *, ' Relative Error (%) =', 100.d0*acc/nrm + + + deallocate(A, A_inv, b) + + call wall_time(t1) + print*, ' END after (min) ', (t1-t0)/60.d0 + + return +end + +! --- + +subroutine get_j1e_coef_fit_ao3(dim_fit, coef_fit) + + implicit none + integer , intent(in) :: dim_fit + double precision, intent(out) :: coef_fit(dim_fit,3) + + integer :: i, d, ipoint + double precision :: g + double precision :: t0, t1 + double precision, allocatable :: A(:,:), b(:,:), A_inv(:,:) + double precision, allocatable :: Pa(:,:), Pb(:,:), Pt(:,:) + double precision, allocatable :: u1e_tmp(:,:) + + + PROVIDE j1e_type + PROVIDE int2_grad1_u2e_ao + PROVIDE elec_alpha_num elec_beta_num elec_num + PROVIDE mo_coef + PROVIDE ao_overlap + + call wall_time(t0) + print*, ' PROVIDING the representation of 1e-Jastrow in AOs ... ' + + ! --- --- --- + ! get u1e(r) + + allocate(Pa(ao_num,ao_num), Pb(ao_num,ao_num), Pt(ao_num,ao_num)) + + call dgemm( 'N', 'T', ao_num, ao_num, elec_alpha_num, 1.d0 & + , mo_coef, size(mo_coef, 1), mo_coef, size(mo_coef, 1) & + , 0.d0, Pa, size(Pa, 1)) + + if(elec_alpha_num .eq. elec_beta_num) then + Pb = Pa + else + call dgemm( 'N', 'T', ao_num, ao_num, elec_beta_num, 1.d0 & + , mo_coef, size(mo_coef, 1), mo_coef, size(mo_coef, 1) & + , 0.d0, Pb, size(Pb, 1)) + endif + Pt = Pa + Pb + + allocate(u1e_tmp(n_points_final_grid,3)) + + g = -0.5d0 * (dble(elec_num) - 1.d0) / dble(elec_num) + do d = 1, 3 + call dgemv("T", ao_num*ao_num, n_points_final_grid, g, int2_grad1_u2e_ao(1,1,1,d), ao_num*ao_num, Pt, 1, 0.d0, u1e_tmp(1,d), 1) + enddo + + deallocate(Pa, Pb, Pt) + + ! --- --- --- + ! get A & b + + allocate(A(ao_num,ao_num), b(ao_num,3)) + + A(1:ao_num,1:ao_num) = ao_overlap(1:ao_num,1:ao_num) + + !$OMP PARALLEL & + !$OMP DEFAULT (NONE) & + !$OMP PRIVATE (i, ipoint) & + !$OMP SHARED (n_points_final_grid, ao_num, & + !$OMP final_weight_at_r_vector, aos_in_r_array_transp, u1e_tmp, b) + !$OMP DO SCHEDULE (static) + do i = 1, ao_num + b(i,1) = 0.d0 + b(i,2) = 0.d0 + b(i,3) = 0.d0 + do ipoint = 1, n_points_final_grid + b(i,1) = b(i,1) + final_weight_at_r_vector(ipoint) * aos_in_r_array_transp(ipoint,i) * u1e_tmp(ipoint,1) + b(i,2) = b(i,2) + final_weight_at_r_vector(ipoint) * aos_in_r_array_transp(ipoint,i) * u1e_tmp(ipoint,2) + b(i,3) = b(i,3) + final_weight_at_r_vector(ipoint) * aos_in_r_array_transp(ipoint,i) * u1e_tmp(ipoint,3) + enddo + enddo + !$OMP END DO + !$OMP END PARALLEL + + deallocate(u1e_tmp) + + ! --- --- --- + ! solve Ax = b + + allocate(A_inv(ao_num,ao_num)) + call get_inverse(A, ao_num, ao_num, A_inv, ao_num) + + ! coef_fit = A_inv x b + do d = 1, 3 + call dgemv("N", ao_num, ao_num, 1.d0, A_inv, ao_num, b(1,d), 1, 0.d0, coef_fit(1,d), 1) + enddo + + integer :: j + double precision :: tmp, acc, nrm + + acc = 0.d0 + nrm = 0.d0 + print *, ' check A_inv' + do d = 1, 3 + do i = 1, ao_num + tmp = 0.d0 + do j = 1, ao_num + tmp += ao_overlap(i,j) * coef_fit(j,d) + enddo + tmp = tmp - b(i,d) + if(dabs(tmp) .gt. 1d-8) then + print*, ' problem found in fitting 1e-Jastrow' + print*, d, i, tmp + endif + + acc += dabs(tmp) + nrm += dabs(b(i,d)) + enddo + enddo + print *, ' Relative Error (%) =', 100.d0*acc/nrm + + deallocate(A, A_inv, b) + + call wall_time(t1) + print*, ' END after (min) ', (t1-t0)/60.d0 + + return +end + +! --- + diff --git a/plugins/local/non_h_ints_mu/jast_2e_utils.irp.f b/plugins/local/non_h_ints_mu/jast_2e_utils.irp.f new file mode 100644 index 00000000..8c25b377 --- /dev/null +++ b/plugins/local/non_h_ints_mu/jast_2e_utils.irp.f @@ -0,0 +1,188 @@ + +! --- + +BEGIN_PROVIDER [double precision, int2_u2e_ao, (ao_num, ao_num, n_points_final_grid)] + + BEGIN_DOC + ! + ! int2_u2e_ao(i,j,ipoint,:) = \int dr2 J_2e(r1,r2) \phi_i(r2) \phi_j(r2) + ! + ! where r1 = r(ipoint) + ! + END_DOC + + implicit none + integer :: ipoint, i, j, jpoint + double precision :: time0, time1 + double precision :: x, y, z, r2 + double precision :: dx, dy, dz + double precision :: tmp_ct + double precision :: tmp0, tmp1, tmp2, tmp3 + + PROVIDE j2e_type + PROVIDE Env_type + + call wall_time(time0) + print*, ' providing int2_u2e_ao ...' + + if( (j2e_type .eq. "Mu") .and. & + ( (env_type .eq. "None") .or. (env_type .eq. "Prod_Gauss") .or. (env_type .eq. "Sum_Gauss") ) ) then + + PROVIDE mu_erf + PROVIDE env_type env_val + PROVIDE Ir2_Mu_long_Du_0 Ir2_Mu_long_Du_x Ir2_Mu_long_Du_y Ir2_Mu_long_Du_z Ir2_Mu_long_Du_2 + PROVIDE Ir2_Mu_gauss_Du + + tmp_ct = 0.5d0 / (dsqrt(dacos(-1.d0)) * mu_erf) + + !$OMP PARALLEL & + !$OMP DEFAULT (NONE) & + !$OMP PRIVATE (ipoint, i, j, x, y, z, r2, dx, dy, dz, & + !$OMP tmp0, tmp1, tmp2, tmp3) & + !$OMP SHARED (ao_num, n_points_final_grid, final_grid_points, & + !$OMP tmp_ct, env_val, Ir2_Mu_long_Du_0, & + !$OMP Ir2_Mu_long_Du_x, Ir2_Mu_long_Du_y, & + !$OMP Ir2_Mu_long_Du_z, Ir2_Mu_gauss_Du, & + !$OMP Ir2_Mu_long_Du_2, int2_u2e_ao) + !$OMP DO SCHEDULE (static) + do ipoint = 1, n_points_final_grid + + x = final_grid_points(1,ipoint) + y = final_grid_points(2,ipoint) + z = final_grid_points(3,ipoint) + r2 = x*x + y*y + z*z + + dx = x * env_val(ipoint) + dy = y * env_val(ipoint) + dz = z * env_val(ipoint) + + tmp0 = 0.5d0 * env_val(ipoint) * r2 + tmp1 = 0.5d0 * env_val(ipoint) + tmp3 = tmp_ct * env_val(ipoint) + + do j = 1, ao_num + do i = 1, ao_num + + tmp2 = tmp1 * Ir2_Mu_long_Du_2(i,j,ipoint) - dx * Ir2_Mu_long_Du_x(i,j,ipoint) - dy * Ir2_Mu_long_Du_y(i,j,ipoint) - dz * Ir2_Mu_long_Du_z(i,j,ipoint) + + int2_u2e_ao(i,j,ipoint) = tmp0 * Ir2_Mu_long_Du_0(i,j,ipoint) + tmp2 - tmp3 * Ir2_Mu_gauss_Du(i,j,ipoint) + enddo + enddo + enddo + !$OMP END DO + !$OMP END PARALLEL + + else + + print *, ' Error in int2_u2e_ao: Unknown Jastrow' + stop + + endif ! j2e_type + + call wall_time(time1) + print*, ' wall time for int2_u2e_ao (min) =', (time1-time0)/60.d0 + call print_memory_usage() + +END_PROVIDER + +! --- + +BEGIN_PROVIDER [double precision, int2_grad1_u2e_ao, (ao_num, ao_num, n_points_final_grid, 3)] + + BEGIN_DOC + ! + ! int2_grad1_u2e_ao(i,j,ipoint,:) = \int dr2 [\grad_r1 J_2e(r1,r2)] \phi_i(r2) \phi_j(r2) + ! + ! where r1 = r(ipoint) + ! + END_DOC + + implicit none + integer :: ipoint, i, j, m, jpoint + double precision :: time0, time1 + double precision :: x, y, z, r2 + double precision :: dx, dy, dz + double precision :: tmp_ct + double precision :: tmp0, tmp1, tmp2 + double precision :: tmp0_x, tmp0_y, tmp0_z + double precision :: tmp1_x, tmp1_y, tmp1_z + + PROVIDE j2e_type + PROVIDE Env_type + + call wall_time(time0) + print*, ' providing int2_grad1_u2e_ao ...' + + if( (j2e_type .eq. "Mu") .and. & + ( (env_type .eq. "None") .or. (env_type .eq. "Prod_Gauss") .or. (env_type .eq. "Sum_Gauss") ) ) then + + PROVIDE mu_erf + PROVIDE env_type env_val env_grad + PROVIDE Ir2_Mu_long_Du_0 Ir2_Mu_long_Du_x Ir2_Mu_long_Du_y Ir2_Mu_long_Du_z Ir2_Mu_long_Du_2 + PROVIDE Ir2_Mu_gauss_Du + + tmp_ct = 0.5d0 / (dsqrt(dacos(-1.d0)) * mu_erf) + + !$OMP PARALLEL & + !$OMP DEFAULT (NONE) & + !$OMP PRIVATE (ipoint, i, j, x, y, z, r2, dx, dy, dz, tmp1, tmp2, & + !$OMP tmp0_x, tmp0_y, tmp0_z, tmp1_x, tmp1_y, tmp1_z) & + !$OMP SHARED (ao_num, n_points_final_grid, final_grid_points, & + !$OMP tmp_ct, env_val, env_grad, Ir2_Mu_long_Du_0, & + !$OMP Ir2_Mu_long_Du_x, Ir2_Mu_long_Du_y, & + !$OMP Ir2_Mu_long_Du_z, Ir2_Mu_gauss_Du, & + !$OMP Ir2_Mu_long_Du_2, int2_grad1_u2e_ao) + !$OMP DO SCHEDULE (static) + do ipoint = 1, n_points_final_grid + + x = final_grid_points(1,ipoint) + y = final_grid_points(2,ipoint) + z = final_grid_points(3,ipoint) + r2 = x*x + y*y + z*z + + dx = env_grad(1,ipoint) + dy = env_grad(2,ipoint) + dz = env_grad(3,ipoint) + + tmp0_x = 0.5d0 * (env_val(ipoint) * x + r2 * dx) + tmp0_y = 0.5d0 * (env_val(ipoint) * y + r2 * dy) + tmp0_z = 0.5d0 * (env_val(ipoint) * z + r2 * dz) + + tmp1 = 0.5d0 * env_val(ipoint) + + tmp1_x = tmp_ct * dx + tmp1_y = tmp_ct * dy + tmp1_z = tmp_ct * dz + + do j = 1, ao_num + do i = 1, ao_num + + tmp2 = 0.5d0 * Ir2_Mu_long_Du_2(i,j,ipoint) - x * Ir2_Mu_long_Du_x(i,j,ipoint) - y * Ir2_Mu_long_Du_y(i,j,ipoint) - z * Ir2_Mu_long_Du_z(i,j,ipoint) + + int2_grad1_u2e_ao(i,j,ipoint,1) = Ir2_Mu_long_Du_0(i,j,ipoint) * tmp0_x - tmp1 * Ir2_Mu_long_Du_x(i,j,ipoint) + dx * tmp2 - tmp1_x * Ir2_Mu_gauss_Du(i,j,ipoint) + int2_grad1_u2e_ao(i,j,ipoint,2) = Ir2_Mu_long_Du_0(i,j,ipoint) * tmp0_y - tmp1 * Ir2_Mu_long_Du_y(i,j,ipoint) + dy * tmp2 - tmp1_y * Ir2_Mu_gauss_Du(i,j,ipoint) + int2_grad1_u2e_ao(i,j,ipoint,3) = Ir2_Mu_long_Du_0(i,j,ipoint) * tmp0_z - tmp1 * Ir2_Mu_long_Du_z(i,j,ipoint) + dz * tmp2 - tmp1_z * Ir2_Mu_gauss_Du(i,j,ipoint) + enddo + enddo + enddo + !$OMP END DO + !$OMP END PARALLEL + + FREE Ir2_Mu_long_Du_0 Ir2_Mu_long_Du_x Ir2_Mu_long_Du_y Ir2_Mu_long_Du_z Ir2_Mu_long_Du_2 + FREE Ir2_Mu_gauss_Du + + else + + print *, ' Error in int2_grad1_u2e_ao: Unknown Jastrow' + stop + + endif ! j2e_type + + call wall_time(time1) + print*, ' wall time for int2_grad1_u2e_ao (min) =', (time1-time0)/60.d0 + call print_memory_usage() + +END_PROVIDER + +! --- + diff --git a/plugins/local/non_h_ints_mu/jast_deriv.irp.f b/plugins/local/non_h_ints_mu/jast_deriv.irp.f new file mode 100644 index 00000000..9a430135 --- /dev/null +++ b/plugins/local/non_h_ints_mu/jast_deriv.irp.f @@ -0,0 +1,235 @@ + +! --- + + BEGIN_PROVIDER [double precision, grad1_u12_num, (n_points_extra_final_grid, n_points_final_grid, 3)] +&BEGIN_PROVIDER [double precision, grad1_u12_squared_num, (n_points_extra_final_grid, n_points_final_grid)] + + BEGIN_DOC + ! + ! + ! grad_1 u(r1,r2) + ! numerical integration over r1 & r2 + ! + END_DOC + + implicit none + integer :: ipoint, jpoint + double precision :: r1(3), r2(3) + double precision :: v_r1, v_r2, u2b_r12 + double precision :: grad1_v(3), grad1_u2b(3) + double precision :: dx, dy, dz + double precision :: time0, time1 + double precision, external :: j12_mu, env_nucl + + PROVIDE env_type + PROVIDE final_grid_points_extra + + print*, ' providing grad1_u12_num & grad1_u12_squared_num ...' + call wall_time(time0) + + grad1_u12_num = 0.d0 + grad1_u12_squared_num = 0.d0 + + if( ((j2e_type .eq. "Mu") .and. (env_type .eq. "None")) .or. & + (j2e_type .eq. "Mur") ) then + + !$OMP PARALLEL & + !$OMP DEFAULT (NONE) & + !$OMP PRIVATE (ipoint, jpoint, r1, r2, v_r1, v_r2, u2b_r12, grad1_v, grad1_u2b, dx, dy, dz) & + !$OMP SHARED (n_points_final_grid, n_points_extra_final_grid, final_grid_points, & + !$OMP final_grid_points_extra, grad1_u12_num, grad1_u12_squared_num) + !$OMP DO SCHEDULE (static) + do ipoint = 1, n_points_final_grid ! r1 + + r1(1) = final_grid_points(1,ipoint) + r1(2) = final_grid_points(2,ipoint) + r1(3) = final_grid_points(3,ipoint) + + do jpoint = 1, n_points_extra_final_grid ! r2 + + r2(1) = final_grid_points_extra(1,jpoint) + r2(2) = final_grid_points_extra(2,jpoint) + r2(3) = final_grid_points_extra(3,jpoint) + + call grad1_j12_mu(r2, r1, grad1_u2b) + + dx = grad1_u2b(1) + dy = grad1_u2b(2) + dz = grad1_u2b(3) + + grad1_u12_num(jpoint,ipoint,1) = dx + grad1_u12_num(jpoint,ipoint,2) = dy + grad1_u12_num(jpoint,ipoint,3) = dz + + grad1_u12_squared_num(jpoint,ipoint) = dx*dx + dy*dy + dz*dz + enddo + enddo + !$OMP END DO + !$OMP END PARALLEL + + elseif((j2e_type .eq. "Mu") .and. (env_type .ne. "None")) then + + PROVIDE final_grid_points + + !$OMP PARALLEL & + !$OMP DEFAULT (NONE) & + !$OMP PRIVATE (ipoint, jpoint, r1, r2, v_r1, v_r2, u2b_r12, grad1_v, grad1_u2b, dx, dy, dz) & + !$OMP SHARED (n_points_final_grid, n_points_extra_final_grid, final_grid_points, & + !$OMP final_grid_points_extra, grad1_u12_num, grad1_u12_squared_num) + !$OMP DO SCHEDULE (static) + do ipoint = 1, n_points_final_grid ! r1 + + r1(1) = final_grid_points(1,ipoint) + r1(2) = final_grid_points(2,ipoint) + r1(3) = final_grid_points(3,ipoint) + + v_r1 = env_nucl(r1) + call grad1_env_nucl(r1, grad1_v) + + do jpoint = 1, n_points_extra_final_grid ! r2 + + r2(1) = final_grid_points_extra(1,jpoint) + r2(2) = final_grid_points_extra(2,jpoint) + r2(3) = final_grid_points_extra(3,jpoint) + + v_r2 = env_nucl(r2) + u2b_r12 = j12_mu(r1, r2) + call grad1_j12_mu(r2, r1, grad1_u2b) + + dx = (grad1_u2b(1) * v_r1 + u2b_r12 * grad1_v(1)) * v_r2 + dy = (grad1_u2b(2) * v_r1 + u2b_r12 * grad1_v(2)) * v_r2 + dz = (grad1_u2b(3) * v_r1 + u2b_r12 * grad1_v(3)) * v_r2 + + grad1_u12_num(jpoint,ipoint,1) = dx + grad1_u12_num(jpoint,ipoint,2) = dy + grad1_u12_num(jpoint,ipoint,3) = dz + + grad1_u12_squared_num(jpoint,ipoint) = dx*dx + dy*dy + dz*dz + enddo + enddo + !$OMP END DO + !$OMP END PARALLEL + + elseif(j2e_type .eq. "Qmckl") then + + double precision :: f + f = 1.d0 / dble(elec_num - 1) + + integer*8 :: n_points, n_points_max, k + integer :: ipoint_block, ipoint_end + + n_points_max = n_points_extra_final_grid * n_points_final_grid + n_points = 100_8*n_points_extra_final_grid + + double precision, allocatable :: rij(:,:,:) + allocate( rij(3, 2, n_points) ) + + use qmckl + integer(qmckl_exit_code) :: rc + + double precision, allocatable :: gl(:,:,:) + + allocate( gl(2,4,n_points) ) + + do ipoint_block = 1, n_points_final_grid, 100 ! r1 + ipoint_end = min(n_points_final_grid, ipoint_block+99) + + k=0 + do ipoint = ipoint_block, ipoint_end + do jpoint = 1, n_points_extra_final_grid ! r2 + k=k+1 + rij(1:3, 1, k) = final_grid_points (1:3, ipoint) + rij(1:3, 2, k) = final_grid_points_extra(1:3, jpoint) + end do + enddo + + rc = qmckl_set_electron_coord(qmckl_ctx_jastrow, 'N', n_points, rij, n_points*6_8) + if (rc /= QMCKL_SUCCESS) then + print *, irp_here, 'qmckl error in set_electron_coord' + rc = qmckl_check(qmckl_ctx_jastrow, rc) + stop -1 + endif + + ! --- + ! e-e term + + rc = qmckl_get_jastrow_champ_factor_ee_gl(qmckl_ctx_jastrow, gl, 8_8*n_points) + if (rc /= QMCKL_SUCCESS) then + print *, irp_here, ' qmckl error in fact_ee_gl' + rc = qmckl_check(qmckl_ctx_jastrow, rc) + stop -1 + endif + + k=0 + do ipoint = ipoint_block, ipoint_end + do jpoint = 1, n_points_extra_final_grid ! r2 + k=k+1 + grad1_u12_num(jpoint,ipoint,1) = gl(1,1,k) + grad1_u12_num(jpoint,ipoint,2) = gl(1,2,k) + grad1_u12_num(jpoint,ipoint,3) = gl(1,3,k) + enddo + enddo + + ! --- + ! e-e-n term + +! rc = qmckl_get_jastrow_champ_factor_een_gl(qmckl_ctx_jastrow, gl, 8_8*n_points) +! if (rc /= QMCKL_SUCCESS) then +! print *, irp_here, 'qmckl error in fact_een_gl' +! rc = qmckl_check(qmckl_ctx_jastrow, rc) +! stop -1 +! endif +! +! k=0 +! do ipoint = 1, n_points_final_grid ! r1 +! do jpoint = 1, n_points_extra_final_grid ! r2 +! k=k+1 +! grad1_u12_num(jpoint,ipoint,1) = grad1_u12_num(jpoint,ipoint,1) + gl(1,1,k) +! grad1_u12_num(jpoint,ipoint,2) = grad1_u12_num(jpoint,ipoint,2) + gl(1,2,k) +! grad1_u12_num(jpoint,ipoint,3) = grad1_u12_num(jpoint,ipoint,3) + gl(1,3,k) +! enddo +! enddo + + ! --- + ! e-n term + + rc = qmckl_get_jastrow_champ_factor_en_gl(qmckl_ctx_jastrow, gl, 8_8*n_points) + if (rc /= QMCKL_SUCCESS) then + print *, irp_here, 'qmckl error in fact_en_gl' + rc = qmckl_check(qmckl_ctx_jastrow, rc) + stop -1 + endif + + k=0 + do ipoint = ipoint_block, ipoint_end ! r1 + do jpoint = 1, n_points_extra_final_grid ! r2 + k = k+1 + grad1_u12_num(jpoint,ipoint,1) = grad1_u12_num(jpoint,ipoint,1) + f * gl(1,1,k) + grad1_u12_num(jpoint,ipoint,2) = grad1_u12_num(jpoint,ipoint,2) + f * gl(1,2,k) + grad1_u12_num(jpoint,ipoint,3) = grad1_u12_num(jpoint,ipoint,3) + f * gl(1,3,k) + + dx = grad1_u12_num(jpoint,ipoint,1) + dy = grad1_u12_num(jpoint,ipoint,2) + dz = grad1_u12_num(jpoint,ipoint,3) + grad1_u12_squared_num(jpoint,ipoint) = dx*dx + dy*dy + dz*dz + enddo + enddo + + enddo !ipoint_block + + deallocate(gl, rij) + + else + + print *, ' Error in grad1_u12_num & grad1_u12_squared_num: Unknown Jastrow' + stop + + endif ! j2e_type + + call wall_time(time1) + print*, ' Wall time for grad1_u12_num & grad1_u12_squared_num (min) = ', (time1-time0)/60.d0 + +END_PROVIDER + +! --- + diff --git a/src/non_h_ints_mu/jast_deriv_utils.irp.f b/plugins/local/non_h_ints_mu/jast_deriv_utils.irp.f similarity index 61% rename from src/non_h_ints_mu/jast_deriv_utils.irp.f rename to plugins/local/non_h_ints_mu/jast_deriv_utils.irp.f index bcbe16af..79822508 100644 --- a/src/non_h_ints_mu/jast_deriv_utils.irp.f +++ b/plugins/local/non_h_ints_mu/jast_deriv_utils.irp.f @@ -9,7 +9,7 @@ double precision function j12_mu(r1, r2) double precision, intent(in) :: r1(3), r2(3) double precision :: mu_tmp, r12 - if((j1b_type .ge. 0) .and. (j1b_type .lt. 200)) then + if(j2e_type .eq. "Mu") then r12 = dsqrt( (r1(1) - r2(1)) * (r1(1) - r2(1)) & + (r1(2) - r2(2)) * (r1(2) - r2(2)) & @@ -20,13 +20,13 @@ double precision function j12_mu(r1, r2) else - print *, ' j1b_type = ', j1b_type, 'not implemented for j12_mu' + print *, ' Error in j12_mu: Unknown j2e_type = ', j2e_type stop - endif + endif ! j2e_type return -end function j12_mu +end ! --- @@ -36,11 +36,11 @@ subroutine grad1_j12_mu(r1, r2, grad) ! ! gradient of j(mu(r1,r2),r12) form of jastrow. ! - ! if mu(r1,r2) = cst ---> j1b_type < 200 and + ! if mu(r1,r2) = cst ---> ! ! d/dx1 j(mu,r12) = 0.5 * (1 - erf(mu *r12))/r12 * (x1 - x2) ! - ! if mu(r1,r2) /= cst ---> 200 < j1b_type < 300 and + ! if mu(r1,r2) /= cst ---> ! ! d/dx1 j(mu(r1,r2),r12) = exp(-(mu(r1,r2)*r12)**2) /(2 *sqrt(pi) * mu(r1,r2)**2 ) d/dx1 mu(r1,r2) ! + 0.5 * (1 - erf(mu(r1,r2) *r12))/r12 * (x1 - x2) @@ -53,10 +53,11 @@ subroutine grad1_j12_mu(r1, r2, grad) double precision, intent(in) :: r1(3), r2(3) double precision, intent(out) :: grad(3) double precision :: dx, dy, dz, r12, tmp + double precision :: mu_val, mu_tmp, mu_der(3) grad = 0.d0 - if((j1b_type .ge. 0) .and. (j1b_type .lt. 200)) then + if(j2e_type .eq. "Mu") then dx = r1(1) - r2(1) dy = r1(2) - r2(2) @@ -71,9 +72,7 @@ subroutine grad1_j12_mu(r1, r2, grad) grad(2) = tmp * dy grad(3) = tmp * dz - elseif((j1b_type .ge. 200) .and. (j1b_type .lt. 300)) then - - double precision :: mu_val, mu_tmp, mu_der(3) + elseif(j2e_type .eq. "Mur") then dx = r1(1) - r2(1) dy = r1(2) - r2(2) @@ -95,151 +94,153 @@ subroutine grad1_j12_mu(r1, r2, grad) else - print *, ' j1b_type = ', j1b_type, 'not implemented yet' + print *, ' Error in grad1_j12_mu: Unknown j2e_type = ', j2e_type stop - endif + endif ! j2e_type + + grad = -grad return -end subroutine grad1_j12_mu +end ! --- -double precision function j1b_nucl(r) +double precision function env_nucl(r) implicit none double precision, intent(in) :: r(3) integer :: i double precision :: a, d, e, x, y, z - if((j1b_type .eq. 2) .or. (j1b_type .eq. 102)) then + if(env_type .eq. "Sum_Slat") then - j1b_nucl = 1.d0 + env_nucl = 1.d0 do i = 1, nucl_num - a = j1b_pen(i) + a = env_expo(i) d = ( (r(1) - nucl_coord(i,1)) * (r(1) - nucl_coord(i,1)) & + (r(2) - nucl_coord(i,2)) * (r(2) - nucl_coord(i,2)) & + (r(3) - nucl_coord(i,3)) * (r(3) - nucl_coord(i,3)) ) - j1b_nucl = j1b_nucl - dexp(-a*dsqrt(d)) + env_nucl = env_nucl - env_coef(i) * dexp(-a*dsqrt(d)) enddo - elseif((j1b_type .eq. 3) .or. (j1b_type .eq. 103)) then + elseif(env_type .eq. "Prod_Gauss") then - j1b_nucl = 1.d0 + env_nucl = 1.d0 do i = 1, nucl_num - a = j1b_pen(i) + a = env_expo(i) d = ( (r(1) - nucl_coord(i,1)) * (r(1) - nucl_coord(i,1)) & + (r(2) - nucl_coord(i,2)) * (r(2) - nucl_coord(i,2)) & + (r(3) - nucl_coord(i,3)) * (r(3) - nucl_coord(i,3)) ) e = 1.d0 - dexp(-a*d) - j1b_nucl = j1b_nucl * e + env_nucl = env_nucl * e enddo - elseif((j1b_type .eq. 4) .or. (j1b_type .eq. 104)) then + elseif(env_type .eq. "Sum_Gauss") then - j1b_nucl = 1.d0 + env_nucl = 1.d0 do i = 1, nucl_num - a = j1b_pen(i) + a = env_expo(i) d = ( (r(1) - nucl_coord(i,1)) * (r(1) - nucl_coord(i,1)) & + (r(2) - nucl_coord(i,2)) * (r(2) - nucl_coord(i,2)) & + (r(3) - nucl_coord(i,3)) * (r(3) - nucl_coord(i,3)) ) - j1b_nucl = j1b_nucl - j1b_pen_coef(i) * dexp(-a*d) + env_nucl = env_nucl - env_coef(i) * dexp(-a*d) enddo - elseif((j1b_type .eq. 5) .or. (j1b_type .eq. 105)) then + elseif(env_type .eq. "Sum_Quartic") then - j1b_nucl = 1.d0 + env_nucl = 1.d0 do i = 1, nucl_num - a = j1b_pen(i) + a = env_expo(i) x = r(1) - nucl_coord(i,1) y = r(2) - nucl_coord(i,2) z = r(3) - nucl_coord(i,3) d = x*x + y*y + z*z - j1b_nucl = j1b_nucl - dexp(-a*d*d) + env_nucl = env_nucl - env_coef(i) * dexp(-a*d*d) enddo else - print *, ' j1b_type = ', j1b_type, 'not implemented for j1b_nucl' + print *, ' Error in env_nucl: Unknown env_type = ', env_type stop endif return -end function j1b_nucl +end ! --- -double precision function j1b_nucl_square(r) +double precision function env_nucl_square(r) implicit none double precision, intent(in) :: r(3) integer :: i double precision :: a, d, e, x, y, z - if((j1b_type .eq. 2) .or. (j1b_type .eq. 102)) then + if(env_type .eq. "Sum_Slat") then - j1b_nucl_square = 1.d0 + env_nucl_square = 1.d0 do i = 1, nucl_num - a = j1b_pen(i) + a = env_expo(i) d = ( (r(1) - nucl_coord(i,1)) * (r(1) - nucl_coord(i,1)) & + (r(2) - nucl_coord(i,2)) * (r(2) - nucl_coord(i,2)) & + (r(3) - nucl_coord(i,3)) * (r(3) - nucl_coord(i,3)) ) - j1b_nucl_square = j1b_nucl_square - dexp(-a*dsqrt(d)) + env_nucl_square = env_nucl_square - env_coef(i) * dexp(-a*dsqrt(d)) enddo - j1b_nucl_square = j1b_nucl_square * j1b_nucl_square + env_nucl_square = env_nucl_square * env_nucl_square - elseif((j1b_type .eq. 3) .or. (j1b_type .eq. 103)) then + elseif(env_type .eq. "Prod_Gauss") then - j1b_nucl_square = 1.d0 + env_nucl_square = 1.d0 do i = 1, nucl_num - a = j1b_pen(i) + a = env_expo(i) d = ( (r(1) - nucl_coord(i,1)) * (r(1) - nucl_coord(i,1)) & + (r(2) - nucl_coord(i,2)) * (r(2) - nucl_coord(i,2)) & + (r(3) - nucl_coord(i,3)) * (r(3) - nucl_coord(i,3)) ) e = 1.d0 - dexp(-a*d) - j1b_nucl_square = j1b_nucl_square * e + env_nucl_square = env_nucl_square * e enddo - j1b_nucl_square = j1b_nucl_square * j1b_nucl_square + env_nucl_square = env_nucl_square * env_nucl_square - elseif((j1b_type .eq. 4) .or. (j1b_type .eq. 104)) then + elseif(env_type .eq. "Sum_Gauss") then - j1b_nucl_square = 1.d0 + env_nucl_square = 1.d0 do i = 1, nucl_num - a = j1b_pen(i) + a = env_expo(i) d = ( (r(1) - nucl_coord(i,1)) * (r(1) - nucl_coord(i,1)) & + (r(2) - nucl_coord(i,2)) * (r(2) - nucl_coord(i,2)) & + (r(3) - nucl_coord(i,3)) * (r(3) - nucl_coord(i,3)) ) - j1b_nucl_square = j1b_nucl_square - j1b_pen_coef(i) * dexp(-a*d) + env_nucl_square = env_nucl_square - env_coef(i) * dexp(-a*d) enddo - j1b_nucl_square = j1b_nucl_square * j1b_nucl_square + env_nucl_square = env_nucl_square * env_nucl_square - elseif((j1b_type .eq. 5) .or. (j1b_type .eq. 105)) then + elseif(env_type .eq. "Sum_Quartic") then - j1b_nucl_square = 1.d0 + env_nucl_square = 1.d0 do i = 1, nucl_num - a = j1b_pen(i) + a = env_expo(i) x = r(1) - nucl_coord(i,1) y = r(2) - nucl_coord(i,2) z = r(3) - nucl_coord(i,3) d = x*x + y*y + z*z - j1b_nucl_square = j1b_nucl_square - dexp(-a*d*d) + env_nucl_square = env_nucl_square - env_coef(i) * dexp(-a*d*d) enddo - j1b_nucl_square = j1b_nucl_square * j1b_nucl_square + env_nucl_square = env_nucl_square * env_nucl_square else - print *, ' j1b_type = ', j1b_type, 'not implemented for j1b_nucl_square' + print *, ' Error in env_nucl_square: Unknown env_type = ', env_type stop endif return -end function j1b_nucl_square +end ! --- -subroutine grad1_j1b_nucl(r, grad) +subroutine grad1_env_nucl(r, grad) implicit none double precision, intent(in) :: r(3) @@ -250,18 +251,18 @@ subroutine grad1_j1b_nucl(r, grad) double precision :: fact_x, fact_y, fact_z double precision :: ax_der, ay_der, az_der, a_expo - if((j1b_type .eq. 2) .or. (j1b_type .eq. 102)) then + if(env_type .eq. "Sum_Slat") then fact_x = 0.d0 fact_y = 0.d0 fact_z = 0.d0 do i = 1, nucl_num - a = j1b_pen(i) + a = env_expo(i) x = r(1) - nucl_coord(i,1) y = r(2) - nucl_coord(i,2) z = r(3) - nucl_coord(i,3) d = dsqrt(x*x + y*y + z*z) - e = a * dexp(-a*d) / d + e = a * env_coef(i) * dexp(-a*d) / d fact_x += e * x fact_y += e * y @@ -272,7 +273,7 @@ subroutine grad1_j1b_nucl(r, grad) grad(2) = fact_y grad(3) = fact_z - elseif((j1b_type .eq. 3) .or. (j1b_type .eq. 103)) then + elseif(env_type .eq. "Prod_Gauss") then x = r(1) y = r(2) @@ -281,7 +282,7 @@ subroutine grad1_j1b_nucl(r, grad) fact_x = 0.d0 fact_y = 0.d0 fact_z = 0.d0 - do i = 1, List_all_comb_b2_size + do i = 1, List_env1s_size phase = 0 a_expo = 0.d0 @@ -289,12 +290,12 @@ subroutine grad1_j1b_nucl(r, grad) ay_der = 0.d0 az_der = 0.d0 do j = 1, nucl_num - a = dble(List_all_comb_b2(j,i)) * j1b_pen(j) + a = dble(List_env1s(j,i)) * env_expo(j) dx = x - nucl_coord(j,1) dy = y - nucl_coord(j,2) dz = z - nucl_coord(j,3) - phase += List_all_comb_b2(j,i) + phase += List_env1s(j,i) a_expo += a * (dx*dx + dy*dy + dz*dz) ax_der += a * dx ay_der += a * dy @@ -311,18 +312,18 @@ subroutine grad1_j1b_nucl(r, grad) grad(2) = fact_y grad(3) = fact_z - elseif((j1b_type .eq. 4) .or. (j1b_type .eq. 104)) then + elseif(env_type .eq. "Sum_Gauss") then fact_x = 0.d0 fact_y = 0.d0 fact_z = 0.d0 do i = 1, nucl_num - a = j1b_pen(i) + a = env_expo(i) x = r(1) - nucl_coord(i,1) y = r(2) - nucl_coord(i,2) z = r(3) - nucl_coord(i,3) d = x*x + y*y + z*z - e = a * j1b_pen_coef(i) * dexp(-a*d) + e = a * env_coef(i) * dexp(-a*d) fact_x += e * x fact_y += e * y @@ -333,18 +334,18 @@ subroutine grad1_j1b_nucl(r, grad) grad(2) = 2.d0 * fact_y grad(3) = 2.d0 * fact_z - elseif((j1b_type .eq. 5) .or. (j1b_type .eq. 105)) then + elseif(env_type .eq. "Sum_Quartic") then fact_x = 0.d0 fact_y = 0.d0 fact_z = 0.d0 do i = 1, nucl_num - a = j1b_pen(i) + a = env_expo(i) x = r(1) - nucl_coord(i,1) y = r(2) - nucl_coord(i,2) z = r(3) - nucl_coord(i,3) d = x*x + y*y + z*z - e = a * d * dexp(-a*d*d) + e = a * env_coef(i) * d * dexp(-a*d*d) fact_x += e * x fact_y += e * y @@ -357,13 +358,13 @@ subroutine grad1_j1b_nucl(r, grad) else - print *, ' j1b_type = ', j1b_type, 'not implemented for grad1_j1b_nucl' + print *, ' Error in grad1_env_nucl: Unknown env_type = ', env_type stop endif return -end subroutine grad1_j1b_nucl +end ! --- @@ -379,7 +380,10 @@ subroutine mu_r_val_and_grad(r1, r2, mu_val, mu_der) double precision :: f_rho1, f_rho2, d_drho_f_rho1 double precision :: d_dx1_f_rho1(3),d_dx_rho_f_rho(3),nume - if(j1b_type .eq. 200) then + PROVIDE murho_type + PROVIDE mu_r_ct mu_erf + + if(murho_type .eq. 1) then ! ! r = 0.5 (r1 + r2) @@ -390,8 +394,6 @@ subroutine mu_r_val_and_grad(r1, r2, mu_val, mu_der) ! d mu[rho(r)] / dx = [0.5 alpha / sqrt(rho) - mu0 exp(-rho)] (d rho(r) / dx) ! - PROVIDE mu_r_ct mu_erf - r(1) = 0.5d0 * (r1(1) + r2(1)) r(2) = 0.5d0 * (r1(2) + r2(2)) r(3) = 0.5d0 * (r1(3) + r2(3)) @@ -412,7 +414,7 @@ subroutine mu_r_val_and_grad(r1, r2, mu_val, mu_der) mu_der(2) = tmp3 * (grad_dm_a(2,1) + grad_dm_b(2,1)) mu_der(3) = tmp3 * (grad_dm_a(3,1) + grad_dm_b(3,1)) - elseif(j1b_type .eq. 201) then + elseif(murho_type .eq. 2) then ! ! r = 0.5 (r1 + r2) @@ -423,8 +425,6 @@ subroutine mu_r_val_and_grad(r1, r2, mu_val, mu_der) ! d mu[rho(r)] / dx = [0.5 alpha / sqrt(rho) - mu0 exp(-rho)] (d rho(r) / dx) ! - PROVIDE mu_r_ct mu_erf - r(1) = 0.5d0 * (r1(1) + r2(1)) r(2) = 0.5d0 * (r1(2) + r2(2)) r(3) = 0.5d0 * (r1(3) + r2(3)) @@ -441,7 +441,7 @@ subroutine mu_r_val_and_grad(r1, r2, mu_val, mu_der) mu_der(2) = tmp3 * (grad_dm_a(2,1) + grad_dm_b(2,1)) mu_der(3) = tmp3 * (grad_dm_a(3,1) + grad_dm_b(3,1)) - elseif(j1b_type .eq. 202) then + elseif(murho_type .eq. 3) then ! mu(r1,r2) = {rho(r1) f[rho(r1)] + rho(r2) f[rho(r2)]} / RHO ! @@ -468,7 +468,8 @@ subroutine mu_r_val_and_grad(r1, r2, mu_val, mu_der) nume = rho1 * f_rho1 + rho2 * f_rho2 mu_val = nume * inv_rho_tot mu_der(1:3) = inv_rho_tot*inv_rho_tot * (rho_tot * d_dx_rho_f_rho(1:3) - grad_rho1(1:3) * nume) - elseif(j1b_type .eq. 203) then + + elseif(murho_type .eq. 4) then ! mu(r1,r2) = {rho(r1) f[rho(r1)] + rho(r2) f[rho(r2)]} / RHO ! @@ -486,6 +487,13 @@ subroutine mu_r_val_and_grad(r1, r2, mu_val, mu_der) !!!!!!!!! rho1,rho2,rho1+rho2 call get_all_rho_grad_rho(r1,r2,rho1,rho2,grad_rho1) rho_tot = rho1 + rho2 +! if(rho_tot.lt.1.d-10)rho_tot = 1.d-10 + if(rho_tot.lt.1.d-10)then + mu_val = mu_erf + mu_der = 0.d0 + return + endif + if(rho_tot.lt.1.d-10)rho_tot = 1.d-10 inv_rho_tot = 1.d0/rho_tot ! f(rho) = mu_r_ct * rho**beta_rho_power + mu_erf @@ -495,7 +503,8 @@ subroutine mu_r_val_and_grad(r1, r2, mu_val, mu_der) nume = rho1 * f_rho1 + rho2 * f_rho2 mu_val = nume * inv_rho_tot mu_der(1:3) = inv_rho_tot*inv_rho_tot * (rho_tot * d_dx_rho_f_rho(1:3) - grad_rho1(1:3) * nume) - elseif(j1b_type .eq. 204) then + + elseif(murho_type .eq. 5) then ! mu(r1,r2) = 1/2 * (f[rho(r1)] + f[rho(r2)]} ! @@ -506,36 +515,45 @@ subroutine mu_r_val_and_grad(r1, r2, mu_val, mu_der) ! d/dx1 f[rho(r1)] = [0.5 alpha / sqrt(rho(r1)) ] (d rho(r1) / dx1) ! ! d/dx1 (rho(r1) f[rho(r1)] = rho(r1) * d/dx1 f[rho(r1)] + f[rho(r1)] * d/dx1 rho(r1) - !!!!!!!!! rho1,rho2,rho1+rho2 call get_all_rho_grad_rho(r1,r2,rho1,rho2,grad_rho1) rho_tot = rho1 + rho2 +! if(rho_tot.lt.1.d-10)rho_tot = 1.d-10 + if(rho_tot.lt.1.d-10)then + mu_val = mu_erf + mu_der = 0.d0 + return + endif + if(rho_tot.lt.1.d-10)rho_tot = 1.d-10 inv_rho_tot = 1.d0/rho_tot - ! f(rho) = mu_r_ct * rho**beta_rho_power + mu_erf - call get_all_f_rho_simple(rho1,rho2,mu_r_ct,mu_erf,beta_rho_power,f_rho1,d_drho_f_rho1,f_rho2) + ! f(rho) = (mu_r_ct* rho)**beta_rho_power * erf(zeta_erf_mu_of_r * rho) + mu_eff * (1 - erf(zeta_erf_mu_of_r*rho)) + call get_all_f_rho_erf(rho1,rho2,mu_r_ct,beta_rho_power,mu_erf,zeta_erf_mu_of_r,f_rho1,d_drho_f_rho1,f_rho2) d_dx1_f_rho1(1:3) = d_drho_f_rho1 * grad_rho1(1:3) d_dx_rho_f_rho(1:3) = rho1 * d_dx1_f_rho1(1:3) + f_rho1 * grad_rho1(1:3) - mu_val = 0.5d0 * ( f_rho1 + f_rho2) - mu_der(1:3) = d_dx_rho_f_rho(1:3) + nume = rho1 * f_rho1 + rho2 * f_rho2 + mu_val = nume * inv_rho_tot + mu_der(1:3) = inv_rho_tot*inv_rho_tot * (rho_tot * d_dx_rho_f_rho(1:3) - grad_rho1(1:3) * nume) + else - print *, ' j1b_type = ', j1b_type, 'not implemented yet' + + print *, ' Error in mu_r_val_and_grad: Unknown env_type = ', env_type stop endif return -end subroutine mu_r_val_and_grad +end ! --- -subroutine grad1_j1b_nucl_square_num(r1, grad) +subroutine grad1_env_nucl_square_num(r1, grad) implicit none double precision, intent(in) :: r1(3) double precision, intent(out) :: grad(3) double precision :: r(3), eps, tmp_eps, vp, vm - double precision, external :: j1b_nucl_square + double precision, external :: env_nucl_square eps = 1d-5 tmp_eps = 0.5d0 / eps @@ -543,28 +561,28 @@ subroutine grad1_j1b_nucl_square_num(r1, grad) r(1:3) = r1(1:3) r(1) = r(1) + eps - vp = j1b_nucl_square(r) + vp = env_nucl_square(r) r(1) = r(1) - 2.d0 * eps - vm = j1b_nucl_square(r) + vm = env_nucl_square(r) r(1) = r(1) + eps grad(1) = tmp_eps * (vp - vm) r(2) = r(2) + eps - vp = j1b_nucl_square(r) + vp = env_nucl_square(r) r(2) = r(2) - 2.d0 * eps - vm = j1b_nucl_square(r) + vm = env_nucl_square(r) r(2) = r(2) + eps grad(2) = tmp_eps * (vp - vm) r(3) = r(3) + eps - vp = j1b_nucl_square(r) + vp = env_nucl_square(r) r(3) = r(3) - 2.d0 * eps - vm = j1b_nucl_square(r) + vm = env_nucl_square(r) r(3) = r(3) + eps grad(3) = tmp_eps * (vp - vm) return -end subroutine grad1_j1b_nucl_square_num +end ! --- @@ -606,7 +624,7 @@ subroutine grad1_j12_mu_square_num(r1, r2, grad) grad(3) = tmp_eps * (vp - vm) return -end subroutine grad1_j12_mu_square_num +end ! --- @@ -619,80 +637,170 @@ double precision function j12_mu_square(r1, r2) j12_mu_square = j12_mu(r1, r2) * j12_mu(r1, r2) return -end function j12_mu_square +end ! --- -subroutine f_mu_and_deriv_mu(rho,alpha,mu0,beta,f_mu,d_drho_f_mu) - implicit none - BEGIN_DOC -! function giving mu as a function of rho -! -! f_mu = alpha * rho**beta + mu0 * exp(-rho) -! -! and its derivative with respect to rho d_drho_f_mu - END_DOC - double precision, intent(in) :: rho,alpha,mu0,beta - double precision, intent(out) :: f_mu,d_drho_f_mu - f_mu = alpha * (rho)**beta + mu0 * dexp(-rho) - d_drho_f_mu = alpha * beta * rho**(beta-1.d0) - mu0 * dexp(-rho) +subroutine f_mu_and_deriv_mu(rho, alpha, mu0, beta, f_mu, d_drho_f_mu) + + BEGIN_DOC + ! function giving mu as a function of rho + ! + ! f_mu = alpha * rho**beta + mu0 * exp(-rho) + ! + ! and its derivative with respect to rho d_drho_f_mu + END_DOC + + implicit none + double precision, intent(in) :: rho, alpha, mu0, beta + double precision, intent(out) :: f_mu, d_drho_f_mu + + f_mu = alpha * (rho)**beta + mu0 * dexp(-rho) + d_drho_f_mu = alpha * beta * rho**(beta-1.d0) - mu0 * dexp(-rho) end +! --- + +subroutine get_all_rho_grad_rho(r1, r2, rho1, rho2, grad_rho1) + + BEGIN_DOC + ! returns the density in r1,r2 and grad_rho at r1 + END_DOC + + implicit none + double precision, intent(in) :: r1(3), r2(3) + double precision, intent(out) :: grad_rho1(3), rho1, rho2 + double precision :: dm_a(1), dm_b(1), grad_dm_a(3,1), grad_dm_b(3,1) + + call density_and_grad_alpha_beta(r1, dm_a, dm_b, grad_dm_a, grad_dm_b) + rho1 = dm_a(1) + dm_b(1) + grad_rho1(1:3) = grad_dm_a(1:3,1) + grad_dm_b(1:3,1) + call density_and_grad_alpha_beta(r2, dm_a, dm_b, grad_dm_a, grad_dm_b) + rho2 = dm_a(1) + dm_b(1) -subroutine get_all_rho_grad_rho(r1,r2,rho1,rho2,grad_rho1) - implicit none - BEGIN_DOC -! returns the density in r1,r2 and grad_rho at r1 - END_DOC - double precision, intent(in) :: r1(3),r2(3) - double precision, intent(out):: grad_rho1(3),rho1,rho2 - double precision :: dm_a(1), dm_b(1), grad_dm_a(3,1), grad_dm_b(3,1) - call density_and_grad_alpha_beta(r1, dm_a, dm_b, grad_dm_a, grad_dm_b) - rho1 = dm_a(1) + dm_b(1) - grad_rho1(1:3) = grad_dm_a(1:3,1) + grad_dm_b(1:3,1) - call density_and_grad_alpha_beta(r2, dm_a, dm_b, grad_dm_a, grad_dm_b) - rho2 = dm_a(1) + dm_b(1) end -subroutine get_all_f_rho(rho1,rho2,alpha,mu0,beta,f_rho1,d_drho_f_rho1,f_rho2) - implicit none - BEGIN_DOC -! returns the values f(mu(r1)), f(mu(r2)) and d/drho(1) f(mu(r1)) - END_DOC - double precision, intent(in) :: rho1,rho2,alpha,mu0,beta - double precision, intent(out):: f_rho1,d_drho_f_rho1,f_rho2 - double precision :: tmp - call f_mu_and_deriv_mu(rho1,alpha,mu0,beta,f_rho1,d_drho_f_rho1) - call f_mu_and_deriv_mu(rho2,alpha,mu0,beta,f_rho2,tmp) +! --- + +subroutine get_all_f_rho(rho1, rho2, alpha, mu0, beta, f_rho1, d_drho_f_rho1, f_rho2) + + BEGIN_DOC + ! returns the values f(mu(r1)), f(mu(r2)) and d/drho(1) f(mu(r1)) + END_DOC + + implicit none + double precision, intent(in) :: rho1, rho2, alpha, mu0, beta + double precision, intent(out) :: f_rho1, d_drho_f_rho1, f_rho2 + double precision :: tmp + + call f_mu_and_deriv_mu(rho1, alpha, mu0, beta, f_rho1, d_drho_f_rho1) + call f_mu_and_deriv_mu(rho2, alpha, mu0, beta, f_rho2, tmp) + end +! --- subroutine get_all_f_rho_simple(rho1,rho2,alpha,mu0,beta,f_rho1,d_drho_f_rho1,f_rho2) - implicit none - BEGIN_DOC -! returns the values f(mu(r1)), f(mu(r2)) and d/drho(1) f(mu(r1)) - END_DOC - double precision, intent(in) :: rho1,rho2,alpha,mu0,beta - double precision, intent(out):: f_rho1,d_drho_f_rho1,f_rho2 - double precision :: tmp - call f_mu_and_deriv_mu_simple(rho1,alpha,mu0,beta,f_rho1,d_drho_f_rho1) - call f_mu_and_deriv_mu_simple(rho2,alpha,mu0,beta,f_rho2,tmp) -end -subroutine f_mu_and_deriv_mu_simple(rho,alpha,mu0,beta,f_mu,d_drho_f_mu) - implicit none - BEGIN_DOC -! function giving mu as a function of rho -! -! f_mu = alpha * rho**beta + mu0 -! -! and its derivative with respect to rho d_drho_f_mu - END_DOC - double precision, intent(in) :: rho,alpha,mu0,beta - double precision, intent(out) :: f_mu,d_drho_f_mu - f_mu = alpha * (rho)**beta + mu0 - d_drho_f_mu = alpha * beta * rho**(beta-1.d0) + BEGIN_DOC + ! returns the values f(mu(r1)), f(mu(r2)) and d/drho(1) f(mu(r1)) + END_DOC + + implicit none + double precision, intent(in) :: rho1, rho2, alpha, mu0, beta + double precision, intent(out) :: f_rho1, d_drho_f_rho1, f_rho2 + double precision :: tmp + + if(rho1.lt.1.d-10) then + f_rho1 = 0.d0 + d_drho_f_rho1 = 0.d0 + else + call f_mu_and_deriv_mu_simple(rho1, alpha, mu0, beta, f_rho1, d_drho_f_rho1) + endif + + if(rho2.lt.1.d-10)then + f_rho2 = 0.d0 + else + call f_mu_and_deriv_mu_simple(rho2, alpha, mu0, beta, f_rho2, tmp) + endif + +end + +! --- + +subroutine f_mu_and_deriv_mu_simple(rho, alpha, mu0, beta, f_mu, d_drho_f_mu) + + BEGIN_DOC + ! function giving mu as a function of rho + ! + ! f_mu = alpha * rho**beta + mu0 + ! + ! and its derivative with respect to rho d_drho_f_mu + END_DOC + + implicit none + double precision, intent(in) :: rho, alpha, mu0, beta + double precision, intent(out) :: f_mu, d_drho_f_mu + + f_mu = alpha**beta * (rho)**beta + mu0 + d_drho_f_mu = alpha**beta * beta * rho**(beta-1.d0) + +end + +! --- + +subroutine f_mu_and_deriv_mu_erf(rho,alpha,zeta,mu0,beta,f_mu,d_drho_f_mu) + + include 'constants.include.F' + + BEGIN_DOC + ! function giving mu as a function of rho + ! + ! f_mu = (alpha * rho)**zeta * erf(beta * rho) + mu0 * (1 - erf(beta*rho)) + ! + ! and its derivative with respect to rho d_drho_f_mu + ! + ! d_drho_f_mu = 2 beta/sqrt(pi) * exp(-(beta*rho)**2) * ( (alpha*rho)**zeta - mu0) + ! + alpha * zeta * (alpha *rho)**(zeta-1) * erf(beta*rho) + END_DOC + + implicit none + double precision, intent(in) :: rho, alpha, mu0, beta, zeta + double precision, intent(out) :: f_mu, d_drho_f_mu + + f_mu = (alpha * rho)**zeta * derf(beta * rho) + mu0 * (1.d0 - derf(beta*rho)) + d_drho_f_mu = 2.d0 * beta * inv_sq_pi * dexp(-(beta*rho)**2) * ( (alpha*rho)**zeta - mu0) & + + alpha * zeta * (alpha *rho)**(zeta-1) * derf(beta*rho) + +end + +! --- + +subroutine get_all_f_rho_erf(rho1, rho2, alpha, zeta, mu0, beta, f_rho1, d_drho_f_rho1, f_rho2) + + BEGIN_DOC + ! returns the values f(mu(r1)), f(mu(r2)) and d/drho(1) f(mu(r1)) + ! with f_mu = (alpha * rho)**zeta * erf(beta * rho) + mu0 * (1 - erf(beta*rho)) + END_DOC + + implicit none + double precision, intent(in) :: rho1, rho2, alpha, mu0, beta, zeta + double precision, intent(out) :: f_rho1, d_drho_f_rho1, f_rho2 + double precision :: tmp + + if(rho1 .lt. 1.d-10) then + f_rho1 = mu_erf + d_drho_f_rho1 = 0.d0 + else + call f_mu_and_deriv_mu_erf(rho1, alpha, zeta, mu0, beta, f_rho1, d_drho_f_rho1) + endif + + if(rho2 .lt. 1.d-10)then + f_rho2 = mu_erf + else + call f_mu_and_deriv_mu_erf(rho2, alpha, zeta, mu0, beta, f_rho2, tmp) + endif end diff --git a/src/non_h_ints_mu/jast_deriv_utils_vect.irp.f b/plugins/local/non_h_ints_mu/jast_deriv_utils_vect.irp.f similarity index 52% rename from src/non_h_ints_mu/jast_deriv_utils_vect.irp.f rename to plugins/local/non_h_ints_mu/jast_deriv_utils_vect.irp.f index f9512827..b58d8c17 100644 --- a/src/non_h_ints_mu/jast_deriv_utils_vect.irp.f +++ b/plugins/local/non_h_ints_mu/jast_deriv_utils_vect.irp.f @@ -1,100 +1,104 @@ ! --- -subroutine get_grad1_u12_withsq_r1_seq(r1, n_grid2, resx, resy, resz, res) +subroutine get_grad1_u12_withsq_r1_seq(ipoint, n_grid2, resx, resy, resz, res) BEGIN_DOC ! ! grad_1 u(r1,r2) ! - ! this will be integrated numerically over r2: - ! we use grid for r1 and extra_grid for r2 - ! - ! for 99 < j1b_type < 199 - ! - ! u(r1,r2) = j12_mu(r12) x v(r1) x v(r2) - ! grad1 u(r1, r2) = [(grad1 j12_mu) v(r1) + j12_mu grad1 v(r1)] v(r2) + ! we use grid for r1 and extra_grid for r2 ! END_DOC implicit none - integer, intent(in) :: n_grid2 - double precision, intent(in) :: r1(3) + integer, intent(in) :: ipoint, n_grid2 double precision, intent(out) :: resx(n_grid2), resy(n_grid2), resz(n_grid2), res(n_grid2) integer :: jpoint - double precision :: v1b_r1 - double precision :: grad1_v1b(3) - double precision, allocatable :: v1b_r2(:) + double precision :: env_r1, tmp + double precision :: grad1_env(3), r1(3) + double precision, allocatable :: env_r2(:) double precision, allocatable :: u2b_r12(:) double precision, allocatable :: gradx1_u2b(:), grady1_u2b(:), gradz1_u2b(:) - double precision, external :: j1b_nucl + double precision, external :: env_nucl - PROVIDE j1b_type + PROVIDE j1e_type j2e_type env_type + PROVIDE final_grid_points PROVIDE final_grid_points_extra - if( (j1b_type .eq. 100) .or. & - (j1b_type .ge. 200) .and. (j1b_type .lt. 300) ) then + r1(1) = final_grid_points(1,ipoint) + r1(2) = final_grid_points(2,ipoint) + r1(3) = final_grid_points(3,ipoint) - call grad1_j12_mu_r1_seq(r1, n_grid2, resx, resy, resz) - do jpoint = 1, n_points_extra_final_grid - res(jpoint) = resx(jpoint) * resx(jpoint) & - + resy(jpoint) * resy(jpoint) & - + resz(jpoint) * resz(jpoint) - enddo + if( (j2e_type .eq. "Mu") .or. & + (j2e_type .eq. "Mur") .or. & + (j2e_type .eq. "Boys") ) then - elseif((j1b_type .gt. 100) .and. (j1b_type .lt. 200)) then + if(env_type .eq. "None") then - allocate(v1b_r2(n_grid2)) - allocate(u2b_r12(n_grid2)) - allocate(gradx1_u2b(n_grid2)) - allocate(grady1_u2b(n_grid2)) - allocate(gradz1_u2b(n_grid2)) + call grad1_j12_r1_seq(r1, n_grid2, resx, resy, resz) - v1b_r1 = j1b_nucl(r1) - call grad1_j1b_nucl(r1, grad1_v1b) + else - call j1b_nucl_r1_seq(n_grid2, v1b_r2) - call j12_mu_r1_seq(r1, n_grid2, u2b_r12) - call grad1_j12_mu_r1_seq(r1, n_grid2, gradx1_u2b, grady1_u2b, gradz1_u2b) + ! u(r1,r2) = j12_mu(r12) x v(r1) x v(r2) + ! grad1 u(r1, r2) = [(grad1 j12_mu) v(r1) + j12_mu grad1 v(r1)] v(r2) - do jpoint = 1, n_points_extra_final_grid - resx(jpoint) = (gradx1_u2b(jpoint) * v1b_r1 + u2b_r12(jpoint) * grad1_v1b(1)) * v1b_r2(jpoint) - resy(jpoint) = (grady1_u2b(jpoint) * v1b_r1 + u2b_r12(jpoint) * grad1_v1b(2)) * v1b_r2(jpoint) - resz(jpoint) = (gradz1_u2b(jpoint) * v1b_r1 + u2b_r12(jpoint) * grad1_v1b(3)) * v1b_r2(jpoint) - res (jpoint) = resx(jpoint) * resx(jpoint) & - + resy(jpoint) * resy(jpoint) & - + resz(jpoint) * resz(jpoint) - enddo + allocate(env_r2(n_grid2)) + allocate(u2b_r12(n_grid2)) + allocate(gradx1_u2b(n_grid2)) + allocate(grady1_u2b(n_grid2)) + allocate(gradz1_u2b(n_grid2)) - deallocate(v1b_r2, u2b_r12, gradx1_u2b, grady1_u2b, gradz1_u2b) + env_r1 = env_nucl(r1) + call grad1_env_nucl(r1, grad1_env) + + call env_nucl_r1_seq(n_grid2, env_r2) + call j12_r1_seq(r1, n_grid2, u2b_r12) + call grad1_j12_r1_seq(r1, n_grid2, gradx1_u2b, grady1_u2b, gradz1_u2b) + + do jpoint = 1, n_points_extra_final_grid + resx(jpoint) = (gradx1_u2b(jpoint) * env_r1 + u2b_r12(jpoint) * grad1_env(1)) * env_r2(jpoint) + resy(jpoint) = (grady1_u2b(jpoint) * env_r1 + u2b_r12(jpoint) * grad1_env(2)) * env_r2(jpoint) + resz(jpoint) = (gradz1_u2b(jpoint) * env_r1 + u2b_r12(jpoint) * grad1_env(3)) * env_r2(jpoint) + enddo + + deallocate(env_r2, u2b_r12, gradx1_u2b, grady1_u2b, gradz1_u2b) + + endif ! env_type else - print *, ' j1b_type = ', j1b_type, 'not implemented yet' + print *, ' Error in get_grad1_u12_withsq_r1_seq: Unknown Jastrow' stop + endif ! j2e_type + + + if(j1e_type .ne. "None") then + PROVIDE j1e_gradx j1e_grady j1e_gradz + PROVIDE elec_num + tmp = 1.d0 / (dble(elec_num) - 1.d0) + do jpoint = 1, n_points_extra_final_grid + resx(jpoint) = resx(jpoint) + tmp * j1e_gradx(ipoint) + resy(jpoint) = resy(jpoint) + tmp * j1e_grady(ipoint) + resz(jpoint) = resz(jpoint) + tmp * j1e_gradz(ipoint) + enddo endif + do jpoint = 1, n_points_extra_final_grid + res(jpoint) = resx(jpoint) * resx(jpoint) + resy(jpoint) * resy(jpoint) + resz(jpoint) * resz(jpoint) + enddo + return -end subroutine get_grad1_u12_withsq_r1_seq +end ! --- -subroutine grad1_j12_mu_r1_seq(r1, n_grid2, gradx, grady, gradz) +subroutine grad1_j12_r1_seq(r1, n_grid2, gradx, grady, gradz) BEGIN_DOC ! - ! gradient of j(mu(r1,r2),r12) form of jastrow. - ! - ! if mu(r1,r2) = cst ---> j1b_type < 200 and - ! - ! d/dx1 j(mu,r12) = 0.5 * (1 - erf(mu *r12))/r12 * (x1 - x2) - ! - ! if mu(r1,r2) /= cst ---> 200 < j1b_type < 300 and - ! - ! d/dx1 j(mu(r1,r2),r12) = exp(-(mu(r1,r2)*r12)**2) /(2 *sqrt(pi) * mu(r1,r2)**2 ) d/dx1 mu(r1,r2) - ! + 0.5 * (1 - erf(mu(r1,r2) *r12))/r12 * (x1 - x2) ! END_DOC @@ -110,8 +114,12 @@ subroutine grad1_j12_mu_r1_seq(r1, n_grid2, gradx, grady, gradz) integer :: jpoint double precision :: r2(3) double precision :: dx, dy, dz, r12, tmp + double precision :: mu_val, mu_tmp, mu_der(3) - if((j1b_type .ge. 0) .and. (j1b_type .lt. 200)) then + if(j2e_type .eq. "Mu") then + + ! d/dx1 j(mu,r12) = 0.5 * (1 - erf(mu *r12))/r12 * (x1 - x2) + ! do jpoint = 1, n_points_extra_final_grid ! r2 @@ -138,9 +146,10 @@ subroutine grad1_j12_mu_r1_seq(r1, n_grid2, gradx, grady, gradz) gradz(jpoint) = tmp * dz enddo - elseif((j1b_type .ge. 200) .and. (j1b_type .lt. 300)) then + elseif(j2e_type .eq. "Mur") then - double precision :: mu_val, mu_tmp, mu_der(3) + ! d/dx1 j(mu(r1,r2),r12) = exp(-(mu(r1,r2)*r12)**2) /(2 *sqrt(pi) * mu(r1,r2)**2 ) d/dx1 mu(r1,r2) + ! + 0.5 * (1 - erf(mu(r1,r2) *r12))/r12 * (x1 - x2) do jpoint = 1, n_points_extra_final_grid ! r2 @@ -174,19 +183,50 @@ subroutine grad1_j12_mu_r1_seq(r1, n_grid2, gradx, grady, gradz) gradz(jpoint) = gradz(jpoint) + tmp * dz enddo + elseif(j2e_type .eq. "Boys") then + + ! j(r12) = 0.5 r12 / (1 + a_boys r_12) + + PROVIDE a_boys + + do jpoint = 1, n_points_extra_final_grid ! r2 + + r2(1) = final_grid_points_extra(1,jpoint) + r2(2) = final_grid_points_extra(2,jpoint) + r2(3) = final_grid_points_extra(3,jpoint) + + dx = r1(1) - r2(1) + dy = r1(2) - r2(2) + dz = r1(3) - r2(3) + r12 = dsqrt(dx * dx + dy * dy + dz * dz) + if(r12 .lt. 1d-10) then + gradx(jpoint) = 0.d0 + grady(jpoint) = 0.d0 + gradz(jpoint) = 0.d0 + cycle + endif + + tmp = 1.d0 + a_boys * r12 + tmp = 0.5d0 / (r12 * tmp * tmp) + + gradx(jpoint) = tmp * dx + grady(jpoint) = tmp * dy + gradz(jpoint) = tmp * dz + enddo + else - print *, ' j1b_type = ', j1b_type, 'not implemented yet' + print *, ' Error in grad1_j12_r1_seq: Unknown j2e_type = ', j2e_type stop - endif + endif ! j2e_type return -end subroutine grad1_j12_mu_r1_seq +end ! --- -subroutine j12_mu_r1_seq(r1, n_grid2, res) +subroutine j12_r1_seq(r1, n_grid2, res) include 'constants.include.F' @@ -197,11 +237,36 @@ subroutine j12_mu_r1_seq(r1, n_grid2, res) integer :: jpoint double precision :: r2(3) + double precision :: dx, dy, dz double precision :: mu_tmp, r12 PROVIDE final_grid_points_extra - if((j1b_type .ge. 0) .and. (j1b_type .lt. 200)) then + if(j2e_type .eq. "Mu") then + + PROVIDE mu_erf + + do jpoint = 1, n_points_extra_final_grid ! r2 + + r2(1) = final_grid_points_extra(1,jpoint) + r2(2) = final_grid_points_extra(2,jpoint) + r2(3) = final_grid_points_extra(3,jpoint) + + dx = r1(1) - r2(1) + dy = r1(2) - r2(2) + dz = r1(3) - r2(3) + r12 = dsqrt(dx * dx + dy * dy + dz * dz) + + mu_tmp = mu_erf * r12 + + res(jpoint) = 0.5d0 * r12 * (1.d0 - derf(mu_tmp)) - inv_sq_pi_2 * dexp(-mu_tmp*mu_tmp) / mu_erf + enddo + + elseif(j2e_type .eq. "Boys") then + + ! j(r12) = 0.5 r12 / (1 + a_boys r_12) + + PROVIDE a_boys do jpoint = 1, n_points_extra_final_grid ! r2 @@ -209,27 +274,27 @@ subroutine j12_mu_r1_seq(r1, n_grid2, res) r2(2) = final_grid_points_extra(2,jpoint) r2(3) = final_grid_points_extra(3,jpoint) - r12 = dsqrt( (r1(1) - r2(1)) * (r1(1) - r2(1)) & - + (r1(2) - r2(2)) * (r1(2) - r2(2)) & - + (r1(3) - r2(3)) * (r1(3) - r2(3)) ) - mu_tmp = mu_erf * r12 + dx = r1(1) - r2(1) + dy = r1(2) - r2(2) + dz = r1(3) - r2(3) + r12 = dsqrt(dx * dx + dy * dy + dz * dz) - res(jpoint) = 0.5d0 * r12 * (1.d0 - derf(mu_tmp)) - inv_sq_pi_2 * dexp(-mu_tmp*mu_tmp) / mu_erf + res(jpoint) = 0.5d0 * r12 / (1.d0 + a_boys * r12) enddo else - print *, ' j1b_type = ', j1b_type, 'not implemented for j12_mu_r1_seq' + print *, ' Error in j12_r1_seq: Unknown j2e_type = ', j2e_type stop - endif + endif ! j2e_type return -end subroutine j12_mu_r1_seq +end ! --- -subroutine j1b_nucl_r1_seq(n_grid2, res) +subroutine env_nucl_r1_seq(n_grid2, res) ! TODO ! change loops order @@ -242,7 +307,7 @@ subroutine j1b_nucl_r1_seq(n_grid2, res) integer :: i, jpoint double precision :: a, d, e, x, y, z - if((j1b_type .eq. 2) .or. (j1b_type .eq. 102)) then + if(env_type .eq. "Sum_Slat") then res = 1.d0 @@ -252,16 +317,16 @@ subroutine j1b_nucl_r1_seq(n_grid2, res) r(3) = final_grid_points_extra(3,jpoint) do i = 1, nucl_num - a = j1b_pen(i) + a = env_expo(i) d = ( (r(1) - nucl_coord(i,1)) * (r(1) - nucl_coord(i,1)) & + (r(2) - nucl_coord(i,2)) * (r(2) - nucl_coord(i,2)) & + (r(3) - nucl_coord(i,3)) * (r(3) - nucl_coord(i,3)) ) - res(jpoint) -= dexp(-a*dsqrt(d)) + res(jpoint) -= env_coef(i) * dexp(-a*dsqrt(d)) enddo enddo - elseif((j1b_type .eq. 3) .or. (j1b_type .eq. 103)) then + elseif(env_type .eq. "Prod_Gauss") then res = 1.d0 @@ -271,7 +336,7 @@ subroutine j1b_nucl_r1_seq(n_grid2, res) r(3) = final_grid_points_extra(3,jpoint) do i = 1, nucl_num - a = j1b_pen(i) + a = env_expo(i) d = ( (r(1) - nucl_coord(i,1)) * (r(1) - nucl_coord(i,1)) & + (r(2) - nucl_coord(i,2)) * (r(2) - nucl_coord(i,2)) & + (r(3) - nucl_coord(i,3)) * (r(3) - nucl_coord(i,3)) ) @@ -281,7 +346,7 @@ subroutine j1b_nucl_r1_seq(n_grid2, res) enddo enddo - elseif((j1b_type .eq. 4) .or. (j1b_type .eq. 104)) then + elseif(env_type .eq. "Sum_Gauss") then res = 1.d0 @@ -291,15 +356,15 @@ subroutine j1b_nucl_r1_seq(n_grid2, res) r(3) = final_grid_points_extra(3,jpoint) do i = 1, nucl_num - a = j1b_pen(i) + a = env_expo(i) d = ( (r(1) - nucl_coord(i,1)) * (r(1) - nucl_coord(i,1)) & + (r(2) - nucl_coord(i,2)) * (r(2) - nucl_coord(i,2)) & + (r(3) - nucl_coord(i,3)) * (r(3) - nucl_coord(i,3)) ) - res(jpoint) -= j1b_pen_coef(i) * dexp(-a*d) + res(jpoint) -= env_coef(i) * dexp(-a*d) enddo enddo - elseif((j1b_type .eq. 5) .or. (j1b_type .eq. 105)) then + elseif(env_type .eq. "Sum_Quartic") then res = 1.d0 @@ -309,24 +374,24 @@ subroutine j1b_nucl_r1_seq(n_grid2, res) r(3) = final_grid_points_extra(3,jpoint) do i = 1, nucl_num - a = j1b_pen(i) + a = env_expo(i) x = r(1) - nucl_coord(i,1) y = r(2) - nucl_coord(i,2) z = r(3) - nucl_coord(i,3) d = x*x + y*y + z*z - res(jpoint) -= dexp(-a*d*d) + res(jpoint) -= env_coef(i) * dexp(-a*d*d) enddo enddo else - print *, ' j1b_type = ', j1b_type, 'not implemented for j1b_nucl_r1_seq' + print *, ' Error in env_nucl_r1_seq: Unknown env_type = ', env_type stop endif return -end subroutine j1b_nucl_r1_seq +end ! --- diff --git a/src/non_h_ints_mu/new_grad_tc_manu.irp.f b/plugins/local/non_h_ints_mu/new_grad_tc_manu.irp.f similarity index 78% rename from src/non_h_ints_mu/new_grad_tc_manu.irp.f rename to plugins/local/non_h_ints_mu/new_grad_tc_manu.irp.f index 7ab5b327..5df80a0e 100644 --- a/src/non_h_ints_mu/new_grad_tc_manu.irp.f +++ b/plugins/local/non_h_ints_mu/new_grad_tc_manu.irp.f @@ -3,6 +3,15 @@ BEGIN_PROVIDER [ double precision, int2_grad1_u12_ao_test, (ao_num, ao_num, n_po BEGIN_DOC ! + ! !!!!!! WARNING !!!!!!!!! + ! + ! DEFINED WITH - SIGN + ! + ! FOR 3e-iontegrals this doesn't matter + ! + ! !!!!!! WARNING !!!!!!!!! + ! + ! ! int2_grad1_u12_ao_test(i,j,ipoint,:) = \int dr2 [-1 * \grad_r1 J(r1,r2)] \phi_i(r2) \phi_j(r2) ! ! where r1 = r(ipoint) @@ -16,9 +25,9 @@ BEGIN_PROVIDER [ double precision, int2_grad1_u12_ao_test, (ao_num, ao_num, n_po ! ! int2_grad1_u12_ao_test(i,j,ipoint,:) = v1 x [ 0.5 x \int dr2 [(r1 - r2) (erf(mu * r12)-1)r_12] v2 \phi_i(r2) \phi_j(r2) ] ! - \grad_1 v1 x [ \int dr2 u12 v2 \phi_i(r2) \phi_j(r2) ] - ! = 0.5 v_1b(ipoint) * v_ij_erf_rk_cst_mu_j1b(i,j,ipoint) * r(:) - ! - 0.5 v_1b(ipoint) * x_v_ij_erf_rk_cst_mu_j1b(i,j,ipoint,:) - ! - v_1b_grad[:,ipoint] * v_ij_u_cst_mu_j1b(i,j,ipoint) + ! = 0.5 env_val(ipoint) * v_ij_erf_rk_cst_mu_env(i,j,ipoint) * r(:) + ! - 0.5 env_val(ipoint) * x_v_ij_erf_rk_cst_mu_env(i,j,ipoint,:) + ! - env_grad[:,ipoint] * v_ij_u_cst_mu_env(i,j,ipoint) ! ! END_DOC @@ -31,8 +40,6 @@ BEGIN_PROVIDER [ double precision, int2_grad1_u12_ao_test, (ao_num, ao_num, n_po print*, ' providing int2_grad1_u12_ao_test ...' call wall_time(time0) - PROVIDE j1b_type - if(read_tc_integ) then open(unit=11, form="unformatted", file=trim(ezfio_filename)//'/work/int2_grad1_u12_ao_test', action="read") @@ -41,41 +48,33 @@ BEGIN_PROVIDER [ double precision, int2_grad1_u12_ao_test, (ao_num, ao_num, n_po else - if(j1b_type .eq. 3) then + if((j2e_type .eq. "Mu") .and. (env_type .eq. "Prod_Gauss")) then + do ipoint = 1, n_points_final_grid x = final_grid_points(1,ipoint) y = final_grid_points(2,ipoint) z = final_grid_points(3,ipoint) - tmp0 = 0.5d0 * v_1b(ipoint) - tmp_x = v_1b_grad(1,ipoint) - tmp_y = v_1b_grad(2,ipoint) - tmp_z = v_1b_grad(3,ipoint) + tmp0 = 0.5d0 * env_val(ipoint) + tmp_x = env_grad(1,ipoint) + tmp_y = env_grad(2,ipoint) + tmp_z = env_grad(3,ipoint) do j = 1, ao_num do i = 1, ao_num - tmp1 = tmp0 * v_ij_erf_rk_cst_mu_j1b_test(i,j,ipoint) - tmp2 = v_ij_u_cst_mu_j1b_test(i,j,ipoint) - int2_grad1_u12_ao_test(i,j,ipoint,1) = tmp1 * x - tmp0 * x_v_ij_erf_rk_cst_mu_j1b_test(i,j,ipoint,1) - tmp2 * tmp_x - int2_grad1_u12_ao_test(i,j,ipoint,2) = tmp1 * y - tmp0 * x_v_ij_erf_rk_cst_mu_j1b_test(i,j,ipoint,2) - tmp2 * tmp_y - int2_grad1_u12_ao_test(i,j,ipoint,3) = tmp1 * z - tmp0 * x_v_ij_erf_rk_cst_mu_j1b_test(i,j,ipoint,3) - tmp2 * tmp_z + tmp1 = tmp0 * v_ij_erf_rk_cst_mu_env_test(i,j,ipoint) + tmp2 = v_ij_u_cst_mu_env_test(i,j,ipoint) + int2_grad1_u12_ao_test(i,j,ipoint,1) = tmp1 * x - tmp0 * x_v_ij_erf_rk_cst_mu_env_test(i,j,ipoint,1) - tmp2 * tmp_x + int2_grad1_u12_ao_test(i,j,ipoint,2) = tmp1 * y - tmp0 * x_v_ij_erf_rk_cst_mu_env_test(i,j,ipoint,2) - tmp2 * tmp_y + int2_grad1_u12_ao_test(i,j,ipoint,3) = tmp1 * z - tmp0 * x_v_ij_erf_rk_cst_mu_env_test(i,j,ipoint,3) - tmp2 * tmp_z enddo enddo enddo + else - do ipoint = 1, n_points_final_grid - x = final_grid_points(1,ipoint) - y = final_grid_points(2,ipoint) - z = final_grid_points(3,ipoint) - do j = 1, ao_num - do i = 1, ao_num - tmp1 = v_ij_erf_rk_cst_mu(i,j,ipoint) - int2_grad1_u12_ao_test(i,j,ipoint,1) = tmp1 * x - x_v_ij_erf_rk_cst_mu_tmp(i,j,ipoint,1) - int2_grad1_u12_ao_test(i,j,ipoint,2) = tmp1 * y - x_v_ij_erf_rk_cst_mu_tmp(i,j,ipoint,2) - int2_grad1_u12_ao_test(i,j,ipoint,3) = tmp1 * z - x_v_ij_erf_rk_cst_mu_tmp(i,j,ipoint,3) - enddo - enddo - enddo - int2_grad1_u12_ao_test *= 0.5d0 - endif + + print *, ' Error in int2_grad1_u12_ao_test: Unknown j2e_type = ', j2e_type + stop + + endif ! j2e_type endif @@ -191,7 +190,7 @@ BEGIN_PROVIDER [double precision, tc_grad_and_lapl_ao_test, (ao_num, ao_num, ao_ endif call wall_time(time1) - print*, ' Wall time for tc_grad_and_lapl_ao_test = ', time1 - time0 + print*, ' Wall time for tc_grad_and_lapl_ao_test (min) = ', (time1 - time0) / 60.d0 END_PROVIDER diff --git a/src/non_h_ints_mu/numerical_integ.irp.f b/plugins/local/non_h_ints_mu/numerical_integ.irp.f similarity index 67% rename from src/non_h_ints_mu/numerical_integ.irp.f rename to plugins/local/non_h_ints_mu/numerical_integ.irp.f index f9457247..5436b857 100644 --- a/src/non_h_ints_mu/numerical_integ.irp.f +++ b/plugins/local/non_h_ints_mu/numerical_integ.irp.f @@ -1,11 +1,11 @@ ! --- -double precision function num_v_ij_u_cst_mu_j1b(i, j, ipoint) +double precision function num_v_ij_u_cst_mu_env(i, j, ipoint) BEGIN_DOC ! - ! \int dr2 u12 \phi_i(r2) \phi_j(r2) x v_1b(r2) + ! \int dr2 u12 \phi_i(r2) \phi_j(r2) x v_env(r2) ! END_DOC @@ -17,31 +17,31 @@ double precision function num_v_ij_u_cst_mu_j1b(i, j, ipoint) double precision :: r1(3), r2(3) double precision, external :: ao_value - double precision, external :: j12_mu, j1b_nucl, j12_mu_gauss + double precision, external :: j12_mu, env_nucl, j12_mu_gauss r1(1) = final_grid_points(1,ipoint) r1(2) = final_grid_points(2,ipoint) r1(3) = final_grid_points(3,ipoint) - num_v_ij_u_cst_mu_j1b = 0.d0 + num_v_ij_u_cst_mu_env = 0.d0 do jpoint = 1, n_points_final_grid r2(1) = final_grid_points(1,jpoint) r2(2) = final_grid_points(2,jpoint) r2(3) = final_grid_points(3,jpoint) - num_v_ij_u_cst_mu_j1b += ao_value(i, r2) * ao_value(j, r2) * j12_mu_gauss(r1, r2) * j1b_nucl(r2) * final_weight_at_r_vector(jpoint) + num_v_ij_u_cst_mu_env += ao_value(i, r2) * ao_value(j, r2) * j12_mu_gauss(r1, r2) * env_nucl(r2) * final_weight_at_r_vector(jpoint) enddo return -end function num_v_ij_u_cst_mu_j1b +end ! --- -double precision function num_int2_u2_j1b2(i, j, ipoint) +double precision function num_int2_u2_env2(i, j, ipoint) BEGIN_DOC ! - ! \int dr2 u12^2 \phi_i(r2) \phi_j(r2) x v_1b(r2)^2 + ! \int dr2 u12^2 \phi_i(r2) \phi_j(r2) x v_env(r2)^2 ! END_DOC @@ -54,14 +54,14 @@ double precision function num_int2_u2_j1b2(i, j, ipoint) double precision :: dx, dy, dz, r12, x2, tmp1, tmp2, tmp3, coef, expo double precision, external :: ao_value - double precision, external :: j1b_nucl + double precision, external :: env_nucl double precision, external :: j12_mu r1(1) = final_grid_points(1,ipoint) r1(2) = final_grid_points(2,ipoint) r1(3) = final_grid_points(3,ipoint) - num_int2_u2_j1b2 = 0.d0 + num_int2_u2_env2 = 0.d0 do jpoint = 1, n_points_final_grid r2(1) = final_grid_points(1,jpoint) r2(2) = final_grid_points(2,jpoint) @@ -72,7 +72,7 @@ double precision function num_int2_u2_j1b2(i, j, ipoint) x2 = dx * dx + dy * dy + dz * dz r12 = dsqrt(x2) - tmp1 = j1b_nucl(r2) + tmp1 = env_nucl(r2) tmp2 = tmp1 * tmp1 * ao_value(i, r2) * ao_value(j, r2) * final_weight_at_r_vector(jpoint) !tmp3 = 0.d0 @@ -84,19 +84,19 @@ double precision function num_int2_u2_j1b2(i, j, ipoint) tmp3 = j12_mu(r1, r2) tmp3 = tmp3 * tmp3 - num_int2_u2_j1b2 += tmp2 * tmp3 + num_int2_u2_env2 += tmp2 * tmp3 enddo return -end function num_int2_u2_j1b2 +end ! --- -double precision function num_int2_grad1u2_grad2u2_j1b2(i, j, ipoint) +double precision function num_int2_grad1u2_grad2u2_env2(i, j, ipoint) BEGIN_DOC ! - ! \int dr2 \frac{-[erf(mu r12) -1]^2}{4} \phi_i(r2) \phi_j(r2) x v_1b(r2)^2 + ! \int dr2 \frac{-[erf(mu r12) -1]^2}{4} \phi_i(r2) \phi_j(r2) x v_env(r2)^2 ! END_DOC @@ -109,13 +109,13 @@ double precision function num_int2_grad1u2_grad2u2_j1b2(i, j, ipoint) double precision :: dx, dy, dz, r12, x2, tmp1, tmp2, tmp3, coef, expo double precision, external :: ao_value - double precision, external :: j1b_nucl + double precision, external :: env_nucl r1(1) = final_grid_points(1,ipoint) r1(2) = final_grid_points(2,ipoint) r1(3) = final_grid_points(3,ipoint) - num_int2_grad1u2_grad2u2_j1b2 = 0.d0 + num_int2_grad1u2_grad2u2_env2 = 0.d0 do jpoint = 1, n_points_final_grid r2(1) = final_grid_points(1,jpoint) r2(2) = final_grid_points(2,jpoint) @@ -126,7 +126,7 @@ double precision function num_int2_grad1u2_grad2u2_j1b2(i, j, ipoint) x2 = dx * dx + dy * dy + dz * dz r12 = dsqrt(x2) - tmp1 = j1b_nucl(r2) + tmp1 = env_nucl(r2) tmp2 = tmp1 * tmp1 * ao_value(i, r2) * ao_value(j, r2) * final_weight_at_r_vector(jpoint) !tmp3 = 0.d0 @@ -140,19 +140,19 @@ double precision function num_int2_grad1u2_grad2u2_j1b2(i, j, ipoint) tmp3 = -0.25d0 * tmp3 - num_int2_grad1u2_grad2u2_j1b2 += tmp2 * tmp3 + num_int2_grad1u2_grad2u2_env2 += tmp2 * tmp3 enddo return -end function num_int2_grad1u2_grad2u2_j1b2 +end ! --- -double precision function num_v_ij_erf_rk_cst_mu_j1b(i, j, ipoint) +double precision function num_v_ij_erf_rk_cst_mu_env(i, j, ipoint) BEGIN_DOC ! - ! \int dr2 [erf(mu r12) -1]/r12 \phi_i(r2) \phi_j(r2) x v_1b(r2) + ! \int dr2 [erf(mu r12) -1]/r12 \phi_i(r2) \phi_j(r2) x v_env(r2) ! END_DOC @@ -165,13 +165,13 @@ double precision function num_v_ij_erf_rk_cst_mu_j1b(i, j, ipoint) double precision :: dx, dy, dz, r12, tmp1, tmp2 double precision, external :: ao_value - double precision, external :: j1b_nucl + double precision, external :: env_nucl r1(1) = final_grid_points(1,ipoint) r1(2) = final_grid_points(2,ipoint) r1(3) = final_grid_points(3,ipoint) - num_v_ij_erf_rk_cst_mu_j1b = 0.d0 + num_v_ij_erf_rk_cst_mu_env = 0.d0 do jpoint = 1, n_points_final_grid r2(1) = final_grid_points(1,jpoint) r2(2) = final_grid_points(2,jpoint) @@ -183,21 +183,21 @@ double precision function num_v_ij_erf_rk_cst_mu_j1b(i, j, ipoint) if(r12 .lt. 1d-10) cycle tmp1 = (derf(mu_erf * r12) - 1.d0) / r12 - tmp2 = tmp1 * ao_value(i, r2) * ao_value(j, r2) * j1b_nucl(r2) * final_weight_at_r_vector(jpoint) + tmp2 = tmp1 * ao_value(i, r2) * ao_value(j, r2) * env_nucl(r2) * final_weight_at_r_vector(jpoint) - num_v_ij_erf_rk_cst_mu_j1b += tmp2 + num_v_ij_erf_rk_cst_mu_env += tmp2 enddo return -end function num_v_ij_erf_rk_cst_mu_j1b +end ! --- -subroutine num_x_v_ij_erf_rk_cst_mu_j1b(i, j, ipoint, integ) +subroutine num_x_v_ij_erf_rk_cst_mu_env(i, j, ipoint, integ) BEGIN_DOC ! - ! \int dr2 [erf(mu r12) -1]/r12 \phi_i(r2) \phi_j(r2) x v_1b(r2) x r2 + ! \int dr2 [erf(mu r12) -1]/r12 \phi_i(r2) \phi_j(r2) x v_env(r2) x r2 ! END_DOC @@ -212,7 +212,7 @@ subroutine num_x_v_ij_erf_rk_cst_mu_j1b(i, j, ipoint, integ) double precision :: tmp_x, tmp_y, tmp_z double precision, external :: ao_value - double precision, external :: j1b_nucl + double precision, external :: env_nucl r1(1) = final_grid_points(1,ipoint) r1(2) = final_grid_points(2,ipoint) @@ -232,7 +232,7 @@ subroutine num_x_v_ij_erf_rk_cst_mu_j1b(i, j, ipoint, integ) if(r12 .lt. 1d-10) cycle tmp1 = (derf(mu_erf * r12) - 1.d0) / r12 - tmp2 = tmp1 * ao_value(i, r2) * ao_value(j, r2) * j1b_nucl(r2) * final_weight_at_r_vector(jpoint) + tmp2 = tmp1 * ao_value(i, r2) * ao_value(j, r2) * env_nucl(r2) * final_weight_at_r_vector(jpoint) tmp_x += tmp2 * r2(1) tmp_y += tmp2 * r2(2) @@ -244,7 +244,7 @@ subroutine num_x_v_ij_erf_rk_cst_mu_j1b(i, j, ipoint, integ) integ(3) = tmp_z return -end subroutine num_x_v_ij_erf_rk_cst_mu_j1b +end ! --- @@ -252,7 +252,7 @@ subroutine num_int2_grad1_u12_ao(i, j, ipoint, integ) BEGIN_DOC ! - ! \int dr2 [-grad_1 u12] \phi_i(r2) \phi_j(r2) x v12_1b(r1, r2) + ! \int dr2 [-grad_1 u12] \phi_i(r2) \phi_j(r2) x v12_env(r1, r2) ! END_DOC @@ -292,78 +292,7 @@ subroutine num_int2_grad1_u12_ao(i, j, ipoint, integ) integ(3) = tmp_z return -end subroutine num_int2_grad1_u12_ao - -! --- - -double precision function num_gradu_squared_u_ij_mu(i, j, ipoint) - - BEGIN_DOC - ! - ! -0.50 x \int r2 \phi_i(2) \phi_j(2) x v2^2 - ! [ v1^2 ((grad_1 u12)^2 + (grad_2 u12^2)]) - ! + u12^2 (grad_1 v1)^2 - ! + 2 u12 v1 (grad_1 u12) . (grad_1 v1) - ! - END_DOC - - - implicit none - - integer, intent(in) :: i, j, ipoint - - integer :: jpoint - double precision :: r1(3), r2(3) - double precision :: tmp_x, tmp_y, tmp_z, r12 - double precision :: dx1_v1, dy1_v1, dz1_v1, grad_u12(3) - double precision :: tmp1, v1_tmp, v2_tmp, u12_tmp - double precision :: fst_term, scd_term, thd_term, tmp - - double precision, external :: ao_value - double precision, external :: j1b_nucl - double precision, external :: j12_mu - double precision, external :: grad_x_j1b_nucl_num - double precision, external :: grad_y_j1b_nucl_num - double precision, external :: grad_z_j1b_nucl_num - - r1(1) = final_grid_points(1,ipoint) - r1(2) = final_grid_points(2,ipoint) - r1(3) = final_grid_points(3,ipoint) - - num_gradu_squared_u_ij_mu = 0.d0 - do jpoint = 1, n_points_final_grid - - r2(1) = final_grid_points(1,jpoint) - r2(2) = final_grid_points(2,jpoint) - r2(3) = final_grid_points(3,jpoint) - - tmp_x = r1(1) - r2(1) - tmp_y = r1(2) - r2(2) - tmp_z = r1(3) - r2(3) - r12 = dsqrt(tmp_x*tmp_x + tmp_y*tmp_y + tmp_z*tmp_z) - - dx1_v1 = grad_x_j1b_nucl_num(r1) - dy1_v1 = grad_y_j1b_nucl_num(r1) - dz1_v1 = grad_z_j1b_nucl_num(r1) - - call grad1_j12_mu(r1, r2, grad_u12) - - tmp1 = 1.d0 - derf(mu_erf * r12) - v1_tmp = j1b_nucl(r1) - v2_tmp = j1b_nucl(r2) - u12_tmp = j12_mu(r1, r2) - - fst_term = 0.5d0 * tmp1 * tmp1 * v1_tmp * v1_tmp - scd_term = u12_tmp * u12_tmp * (dx1_v1*dx1_v1 + dy1_v1*dy1_v1 + dz1_v1*dz1_v1) - thd_term = 2.d0 * v1_tmp * u12_tmp * (dx1_v1*grad_u12(1) + dy1_v1*grad_u12(2) + dz1_v1*grad_u12(3)) - - tmp = -0.5d0 * ao_value(i, r2) * ao_value(j, r2) * final_weight_at_r_vector(jpoint) * (fst_term + scd_term + thd_term) * v2_tmp * v2_tmp - - num_gradu_squared_u_ij_mu += tmp - enddo - - return -end function num_gradu_squared_u_ij_mu +end ! --- @@ -388,11 +317,11 @@ double precision function num_grad12_j12(i, j, ipoint) double precision :: fst_term, scd_term, thd_term, tmp double precision, external :: ao_value - double precision, external :: j1b_nucl + double precision, external :: env_nucl double precision, external :: j12_mu - double precision, external :: grad_x_j1b_nucl_num - double precision, external :: grad_y_j1b_nucl_num - double precision, external :: grad_z_j1b_nucl_num + double precision, external :: grad_x_env_nucl_num + double precision, external :: grad_y_env_nucl_num + double precision, external :: grad_z_env_nucl_num r1(1) = final_grid_points(1,ipoint) r1(2) = final_grid_points(2,ipoint) @@ -410,15 +339,15 @@ double precision function num_grad12_j12(i, j, ipoint) tmp_z = r1(3) - r2(3) r12 = dsqrt(tmp_x*tmp_x + tmp_y*tmp_y + tmp_z*tmp_z) - dx1_v1 = grad_x_j1b_nucl_num(r1) - dy1_v1 = grad_y_j1b_nucl_num(r1) - dz1_v1 = grad_z_j1b_nucl_num(r1) + dx1_v1 = grad_x_env_nucl_num(r1) + dy1_v1 = grad_y_env_nucl_num(r1) + dz1_v1 = grad_z_env_nucl_num(r1) call grad1_j12_mu(r1, r2, grad_u12) tmp1 = 1.d0 - derf(mu_erf * r12) - v1_tmp = j1b_nucl(r1) - v2_tmp = j1b_nucl(r2) + v1_tmp = env_nucl(r1) + v2_tmp = env_nucl(r2) u12_tmp = j12_mu(r1, r2) fst_term = 0.5d0 * tmp1 * tmp1 * v1_tmp * v1_tmp @@ -429,11 +358,11 @@ double precision function num_grad12_j12(i, j, ipoint) enddo return -end function num_grad12_j12 +end ! --- -double precision function num_u12sq_j1bsq(i, j, ipoint) +double precision function num_u12sq_envsq(i, j, ipoint) BEGIN_DOC ! @@ -454,17 +383,17 @@ double precision function num_u12sq_j1bsq(i, j, ipoint) double precision :: fst_term, scd_term, thd_term, tmp double precision, external :: ao_value - double precision, external :: j1b_nucl + double precision, external :: env_nucl double precision, external :: j12_mu - double precision, external :: grad_x_j1b_nucl_num - double precision, external :: grad_y_j1b_nucl_num - double precision, external :: grad_z_j1b_nucl_num + double precision, external :: grad_x_env_nucl_num + double precision, external :: grad_y_env_nucl_num + double precision, external :: grad_z_env_nucl_num r1(1) = final_grid_points(1,ipoint) r1(2) = final_grid_points(2,ipoint) r1(3) = final_grid_points(3,ipoint) - num_u12sq_j1bsq = 0.d0 + num_u12sq_envsq = 0.d0 do jpoint = 1, n_points_final_grid r2(1) = final_grid_points(1,jpoint) @@ -476,30 +405,30 @@ double precision function num_u12sq_j1bsq(i, j, ipoint) tmp_z = r1(3) - r2(3) r12 = dsqrt(tmp_x*tmp_x + tmp_y*tmp_y + tmp_z*tmp_z) - dx1_v1 = grad_x_j1b_nucl_num(r1) - dy1_v1 = grad_y_j1b_nucl_num(r1) - dz1_v1 = grad_z_j1b_nucl_num(r1) + dx1_v1 = grad_x_env_nucl_num(r1) + dy1_v1 = grad_y_env_nucl_num(r1) + dz1_v1 = grad_z_env_nucl_num(r1) call grad1_j12_mu(r1, r2, grad_u12) tmp1 = 1.d0 - derf(mu_erf * r12) - v1_tmp = j1b_nucl(r1) - v2_tmp = j1b_nucl(r2) + v1_tmp = env_nucl(r1) + v2_tmp = env_nucl(r2) u12_tmp = j12_mu(r1, r2) scd_term = u12_tmp * u12_tmp * (dx1_v1*dx1_v1 + dy1_v1*dy1_v1 + dz1_v1*dz1_v1) tmp = -0.5d0 * ao_value(i, r2) * ao_value(j, r2) * final_weight_at_r_vector(jpoint) * scd_term * v2_tmp * v2_tmp - num_u12sq_j1bsq += tmp + num_u12sq_envsq += tmp enddo return -end function num_u12sq_j1bsq +end ! --- -double precision function num_u12_grad1_u12_j1b_grad1_j1b(i, j, ipoint) +double precision function num_u12_grad1_u12_env_grad1_env(i, j, ipoint) BEGIN_DOC ! @@ -520,17 +449,17 @@ double precision function num_u12_grad1_u12_j1b_grad1_j1b(i, j, ipoint) double precision :: fst_term, scd_term, thd_term, tmp double precision, external :: ao_value - double precision, external :: j1b_nucl + double precision, external :: env_nucl double precision, external :: j12_mu - double precision, external :: grad_x_j1b_nucl_num - double precision, external :: grad_y_j1b_nucl_num - double precision, external :: grad_z_j1b_nucl_num + double precision, external :: grad_x_env_nucl_num + double precision, external :: grad_y_env_nucl_num + double precision, external :: grad_z_env_nucl_num r1(1) = final_grid_points(1,ipoint) r1(2) = final_grid_points(2,ipoint) r1(3) = final_grid_points(3,ipoint) - num_u12_grad1_u12_j1b_grad1_j1b = 0.d0 + num_u12_grad1_u12_env_grad1_env = 0.d0 do jpoint = 1, n_points_final_grid r2(1) = final_grid_points(1,jpoint) @@ -542,34 +471,34 @@ double precision function num_u12_grad1_u12_j1b_grad1_j1b(i, j, ipoint) tmp_z = r1(3) - r2(3) r12 = dsqrt(tmp_x*tmp_x + tmp_y*tmp_y + tmp_z*tmp_z) - dx1_v1 = grad_x_j1b_nucl_num(r1) - dy1_v1 = grad_y_j1b_nucl_num(r1) - dz1_v1 = grad_z_j1b_nucl_num(r1) + dx1_v1 = grad_x_env_nucl_num(r1) + dy1_v1 = grad_y_env_nucl_num(r1) + dz1_v1 = grad_z_env_nucl_num(r1) call grad1_j12_mu(r1, r2, grad_u12) tmp1 = 1.d0 - derf(mu_erf * r12) - v1_tmp = j1b_nucl(r1) - v2_tmp = j1b_nucl(r2) + v1_tmp = env_nucl(r1) + v2_tmp = env_nucl(r2) u12_tmp = j12_mu(r1, r2) thd_term = 2.d0 * v1_tmp * u12_tmp * (dx1_v1*grad_u12(1) + dy1_v1*grad_u12(2) + dz1_v1*grad_u12(3)) tmp = -0.5d0 * ao_value(i, r2) * ao_value(j, r2) * final_weight_at_r_vector(jpoint) * thd_term * v2_tmp * v2_tmp - num_u12_grad1_u12_j1b_grad1_j1b += tmp + num_u12_grad1_u12_env_grad1_env += tmp enddo return -end function num_u12_grad1_u12_j1b_grad1_j1b +end ! --- -subroutine num_int2_u_grad1u_total_j1b2(i, j, ipoint, integ) +subroutine num_int2_u_grad1u_total_env2(i, j, ipoint, integ) BEGIN_DOC ! - ! \int dr2 u12 (grad_1 u12) \phi_i(r2) \phi_j(r2) x v_1b(r2)^2 + ! \int dr2 u12 (grad_1 u12) \phi_i(r2) \phi_j(r2) x v_env(r2)^2 ! END_DOC @@ -584,7 +513,7 @@ subroutine num_int2_u_grad1u_total_j1b2(i, j, ipoint, integ) double precision :: tmp_x, tmp_y, tmp_z double precision, external :: ao_value - double precision, external :: j1b_nucl + double precision, external :: env_nucl double precision, external :: j12_mu r1(1) = final_grid_points(1,ipoint) @@ -604,7 +533,7 @@ subroutine num_int2_u_grad1u_total_j1b2(i, j, ipoint, integ) r12 = dsqrt( dx * dx + dy * dy + dz * dz ) if(r12 .lt. 1d-10) cycle - tmp0 = j1b_nucl(r2) + tmp0 = env_nucl(r2) tmp1 = 0.5d0 * j12_mu(r1, r2) * (1.d0 - derf(mu_erf * r12)) / r12 tmp2 = tmp0 * tmp0 * tmp1 * ao_value(i, r2) * ao_value(j, r2) * final_weight_at_r_vector(jpoint) @@ -618,6 +547,6 @@ subroutine num_int2_u_grad1u_total_j1b2(i, j, ipoint, integ) integ(3) = tmp_z return -end subroutine num_int2_u_grad1u_total_j1b2 +end ! --- diff --git a/src/non_h_ints_mu/plot_mu_of_r.irp.f b/plugins/local/non_h_ints_mu/plot_mu_of_r.irp.f similarity index 65% rename from src/non_h_ints_mu/plot_mu_of_r.irp.f rename to plugins/local/non_h_ints_mu/plot_mu_of_r.irp.f index 1100cd7c..3a5984bd 100644 --- a/src/non_h_ints_mu/plot_mu_of_r.irp.f +++ b/plugins/local/non_h_ints_mu/plot_mu_of_r.irp.f @@ -13,9 +13,9 @@ subroutine routine_print integer :: i_unit_output,getUnitAndOpen output=trim(ezfio_filename)//'.mu_of_r' i_unit_output = getUnitAndOpen(output,'w') - integer :: ipoint,nx - double precision :: xmax,xmin,r(3),dx - double precision :: mu_val, mu_der(3),dm_a,dm_b,grad + integer :: ipoint,nx,i + double precision :: xmax,xmin,r(3),dx,sigma + double precision :: mu_val, mu_der(3),dm_a,dm_b,grad,grad_dm_a(3), grad_dm_b(3) xmax = 5.D0 xmin = -5.D0 nx = 10000 @@ -24,10 +24,15 @@ subroutine routine_print r(1) = xmin do ipoint = 1, nx call mu_r_val_and_grad(r, r, mu_val, mu_der) - call dm_dft_alpha_beta_at_r(r,dm_a,dm_b) + call density_and_grad_alpha_beta(r,dm_a,dm_b, grad_dm_a, grad_dm_b) + sigma = 0.d0 + do i = 1,3 + sigma += grad_dm_a(i)**2 + enddo + sigma=dsqrt(sigma) grad = mu_der(1)**2 + mu_der(2)**2 + mu_der(3)**2 grad = dsqrt(grad) - write(i_unit_output,'(100(F16.7,X))')r(1),mu_val,dm_a+dm_b,grad + write(i_unit_output,'(100(F16.7,X))')r(1),mu_val,dm_a+dm_b,grad,sigma/dm_a r(1) += dx enddo end diff --git a/src/non_h_ints_mu/qmckl.irp.f b/plugins/local/non_h_ints_mu/qmckl.irp.f similarity index 98% rename from src/non_h_ints_mu/qmckl.irp.f rename to plugins/local/non_h_ints_mu/qmckl.irp.f index b9802371..1df80457 100644 --- a/src/non_h_ints_mu/qmckl.irp.f +++ b/plugins/local/non_h_ints_mu/qmckl.irp.f @@ -6,11 +6,10 @@ BEGIN_PROVIDER [ integer*8, qmckl_ctx_jastrow ] ! Context for the QMCKL library END_DOC integer(qmckl_exit_code) :: rc - logical(c_bool) :: c_true = .True. qmckl_ctx_jastrow = qmckl_context_create() - rc = qmckl_set_jastrow_champ_spin_independent(qmckl_ctx_jastrow, c_true) + rc = qmckl_set_jastrow_champ_spin_independent(qmckl_ctx_jastrow, 1) rc = qmckl_check(qmckl_ctx_jastrow, rc) if (rc /= QMCKL_SUCCESS) stop -1 diff --git a/plugins/local/non_h_ints_mu/tc_integ.irp.f b/plugins/local/non_h_ints_mu/tc_integ.irp.f new file mode 100644 index 00000000..775a9e4c --- /dev/null +++ b/plugins/local/non_h_ints_mu/tc_integ.irp.f @@ -0,0 +1,398 @@ + +BEGIN_PROVIDER [double precision, int2_grad1_u12_ao, (ao_num, ao_num, n_points_final_grid, 3)] + + BEGIN_DOC + ! + ! int2_grad1_u12_ao(i,j,ipoint,:) = \int dr2 [\grad_r1 J(r1,r2)] \phi_i(r2) \phi_j(r2) + ! + ! where r1 = r(ipoint) + ! + END_DOC + + implicit none + integer :: ipoint, i, j, m, jpoint + double precision :: time0, time1 + double precision :: x, y, z, r2 + double precision :: dx, dy, dz + double precision :: tmp_ct + double precision :: tmp0, tmp1, tmp2 + double precision :: tmp0_x, tmp0_y, tmp0_z + double precision :: tmp1_x, tmp1_y, tmp1_z + + PROVIDE j2e_type + PROVIDE j1e_type + + call wall_time(time0) + + print*, ' providing int2_grad1_u12_ao ...' + + if(read_tc_integ) then + + print*, ' Reading int2_grad1_u12_ao from ', trim(ezfio_filename) // '/work/int2_grad1_u12_ao' + + open(unit=11, form="unformatted", file=trim(ezfio_filename)//'/work/int2_grad1_u12_ao', action="read") + read(11) int2_grad1_u12_ao + close(11) + + else + + if(tc_integ_type .eq. "analytic") then + + write(*, '(A, A, A)') ' Error: The integration type ', trim(tc_integ_type), ' has not been implemented yet.' + stop + + elseif(tc_integ_type .eq. "numeric") then + + print *, ' Numerical integration over r1 and r2 will be performed' + + ! TODO combine 1shot & int2_grad1_u12_ao_num + + PROVIDE int2_grad1_u12_ao_num + int2_grad1_u12_ao = int2_grad1_u12_ao_num + + !PROVIDE int2_grad1_u12_ao_num_1shot + !int2_grad1_u12_ao = int2_grad1_u12_ao_num_1shot + + elseif(tc_integ_type .eq. "semi-analytic") then + + print*, ' Numerical integration over r1, with analytical integration over r2' + + ! --- + + if(j2e_type .eq. "None") then + + int2_grad1_u12_ao = 0.d0 + + elseif( (j2e_type .eq. "Mu") .and. & + ( (env_type .eq. "None") .or. (env_type .eq. "Prod_Gauss") .or. (env_type .eq. "Sum_Gauss") ) ) then + + PROVIDE int2_grad1_u2e_ao + int2_grad1_u12_ao = int2_grad1_u2e_ao + + else + + print *, ' Error in int2_grad1_u12_ao: Unknown Jastrow' + stop + + endif ! j2e_type + + ! --- + + if(j1e_type .ne. "None") then + + PROVIDE elec_num + PROVIDE ao_overlap + PROVIDE j1e_gradx j1e_grady j1e_gradz + + tmp_ct = 1.d0 / (dble(elec_num) - 1.d0) + + !$OMP PARALLEL & + !$OMP DEFAULT (NONE) & + !$OMP PRIVATE (ipoint, i, j, tmp0_x, tmp0_y, tmp0_z) & + !$OMP SHARED (ao_num, n_points_final_grid, tmp_ct, ao_overlap, & + !$OMP j1e_gradx, j1e_grady, j1e_gradz, int2_grad1_u12_ao) + !$OMP DO + do ipoint = 1, n_points_final_grid + tmp0_x = tmp_ct * j1e_gradx(ipoint) + tmp0_y = tmp_ct * j1e_grady(ipoint) + tmp0_z = tmp_ct * j1e_gradz(ipoint) + do j = 1, ao_num + do i = 1, ao_num + int2_grad1_u12_ao(i,j,ipoint,1) = int2_grad1_u12_ao(i,j,ipoint,1) + tmp0_x * ao_overlap(i,j) + int2_grad1_u12_ao(i,j,ipoint,2) = int2_grad1_u12_ao(i,j,ipoint,2) + tmp0_y * ao_overlap(i,j) + int2_grad1_u12_ao(i,j,ipoint,3) = int2_grad1_u12_ao(i,j,ipoint,3) + tmp0_z * ao_overlap(i,j) + enddo + enddo + enddo + !$OMP END DO + !$OMP END PARALLEL + + endif ! j1e_type + + ! --- + + else + + write(*, '(A, A, A)') ' Error: The integration type ', trim(tc_integ_type), ' has not been implemented yet' + stop + + endif ! tc_integ_type + + endif ! read_tc_integ + + + if(write_tc_integ .and. mpi_master) then + + print*, ' Writing int2_grad1_u12_ao in ', trim(ezfio_filename) // '/work/int2_grad1_u12_ao' + + open(unit=11, form="unformatted", file=trim(ezfio_filename)//'/work/int2_grad1_u12_ao', action="write") + call ezfio_set_work_empty(.False.) + write(11) int2_grad1_u12_ao + close(11) + call ezfio_set_tc_keywords_io_tc_integ('Read') + endif + + call wall_time(time1) + print*, ' wall time for int2_grad1_u12_ao (min) =', (time1-time0)/60.d0 + call print_memory_usage() + +END_PROVIDER + +! --- + +BEGIN_PROVIDER [double precision, int2_grad1_u12_square_ao, (ao_num, ao_num, n_points_final_grid)] + + BEGIN_DOC + ! + ! int2_grad1_u12_square_ao = -(1/2) x int dr2 chi_l(r2) chi_j(r2) [grad_1 u(r1,r2)]^2 + ! + END_DOC + + implicit none + integer :: ipoint, i, j, m, jpoint + double precision :: x, y, z, r2 + double precision :: dx, dy, dz, dr2 + double precision :: dx1, dy1, dz1, dx2, dy2, dz2, dr12 + double precision :: tmp_ct, tmp_ct1, tmp_ct2 + double precision :: tmp0, tmp1, tmp2 + double precision :: tmp3, tmp4, tmp5, tmp6 + double precision :: tmp0_x, tmp0_y, tmp0_z + double precision :: tmp1_x, tmp1_y, tmp1_z + double precision :: time0, time1 + + PROVIDE j2e_type + PROVIDE j1e_type + PROVIDE tc_integ_type + + call wall_time(time0) + + print*, ' providing int2_grad1_u12_square_ao ...' + + if(tc_integ_type .eq. "analytic") then + + write(*, '(A, A, A)') ' Error: The integration type ', trim(tc_integ_type), ' has not been implemented yet.' + stop + + elseif(tc_integ_type .eq. "numeric") then + + print *, ' Numerical integration over r1 and r2 will be performed' + + ! TODO combine 1shot & int2_grad1_u12_square_ao_num + + PROVIDE int2_grad1_u12_square_ao_num + int2_grad1_u12_square_ao = int2_grad1_u12_square_ao_num + + !PROVIDE int2_grad1_u12_square_ao_num_1shot + !int2_grad1_u12_square_ao = int2_grad1_u12_square_ao_num_1shot + + elseif(tc_integ_type .eq. "semi-analytic") then + + print*, ' Numerical integration over r1, with analytical integration over r2' + + ! --- + + if(j2e_type .eq. "None") then + + int2_grad1_u12_square_ao = 0.d0 + + elseif((j2e_type .eq. "Mu") .and. (env_type .eq. "None")) then + + PROVIDE int2_grad1u2_grad2u2 + + !$OMP PARALLEL & + !$OMP DEFAULT (NONE) & + !$OMP PRIVATE (i, j, ipoint) & + !$OMP SHARED (int2_grad1_u12_square_ao, ao_num, n_points_final_grid, int2_grad1u2_grad2u2) + !$OMP DO SCHEDULE (static) + do ipoint = 1, n_points_final_grid + do j = 1, ao_num + do i = 1, ao_num + int2_grad1_u12_square_ao(i,j,ipoint) = -0.5d0 * int2_grad1u2_grad2u2(i,j,ipoint) + enddo + enddo + enddo + !$OMP END DO + !$OMP END PARALLEL + + FREE int2_grad1u2_grad2u2 + + elseif((j2e_type .eq. "Mu") .and. (env_type .eq. "Prod_Gauss")) then + + PROVIDE mu_erf + PROVIDE env_val env_grad + + if(use_ipp) then + + ! the term u12_grad1_u12_env_grad1_env is added directly for performance + PROVIDE u12sq_envsq grad12_j12 + + !$OMP PARALLEL & + !$OMP DEFAULT (NONE) & + !$OMP PRIVATE (i, j, ipoint) & + !$OMP SHARED (int2_grad1_u12_square_ao, ao_num, n_points_final_grid, u12sq_envsq, grad12_j12) + !$OMP DO SCHEDULE (static) + do ipoint = 1, n_points_final_grid + do j = 1, ao_num + do i = 1, ao_num + int2_grad1_u12_square_ao(i,j,ipoint) = u12sq_envsq(i,j,ipoint) + 0.5d0 * grad12_j12(i,j,ipoint) + enddo + enddo + enddo + !$OMP END DO + !$OMP END PARALLEL + + FREE u12sq_envsq grad12_j12 + + else + + PROVIDE u12sq_envsq u12_grad1_u12_env_grad1_env grad12_j12 + + !$OMP PARALLEL & + !$OMP DEFAULT (NONE) & + !$OMP PRIVATE (i, j, ipoint) & + !$OMP SHARED (int2_grad1_u12_square_ao, ao_num, n_points_final_grid, u12sq_envsq, grad12_j12, u12_grad1_u12_env_grad1_env) + !$OMP DO SCHEDULE (static) + do ipoint = 1, n_points_final_grid + do j = 1, ao_num + do i = 1, ao_num + int2_grad1_u12_square_ao(i,j,ipoint) = u12sq_envsq(i,j,ipoint) + u12_grad1_u12_env_grad1_env(i,j,ipoint) + 0.5d0 * grad12_j12(i,j,ipoint) + enddo + enddo + enddo + !$OMP END DO + !$OMP END PARALLEL + + FREE u12sq_envsq u12_grad1_u12_env_grad1_env grad12_j12 + + endif ! use_ipp + + elseif((j2e_type .eq. "Mu") .and. (env_type .eq. "Sum_Gauss")) then + + PROVIDE mu_erf + PROVIDE env_type env_val env_grad + + if(use_ipp) then + + ! do not free int2_u2_env2 here + PROVIDE int2_u2_env2 + PROVIDE int2_grad1u2_grad2u2_env2 + + !$OMP PARALLEL & + !$OMP DEFAULT (NONE) & + !$OMP PRIVATE (i, j, ipoint, tmp0_x, tmp0_y, tmp0_z, tmp1, tmp2) & + !$OMP SHARED (int2_grad1_u12_square_ao, ao_num, n_points_final_grid, & + !$OMP env_val, env_grad, int2_u2_env2, int2_grad1u2_grad2u2_env2) + !$OMP DO SCHEDULE (static) + do ipoint = 1, n_points_final_grid + tmp0_x = env_grad(1,ipoint) + tmp0_y = env_grad(2,ipoint) + tmp0_z = env_grad(3,ipoint) + tmp1 = -0.5d0 * (tmp0_x * tmp0_x + tmp0_y * tmp0_y + tmp0_z * tmp0_z) + tmp2 = 0.5d0 * env_val(ipoint) * env_val(ipoint) + do j = 1, ao_num + do i = 1, ao_num + int2_grad1_u12_square_ao(i,j,ipoint) = tmp1 * int2_u2_env2(i,j,ipoint) + tmp2 * int2_grad1u2_grad2u2_env2(i,j,ipoint) + enddo + enddo + enddo + !$OMP END DO + !$OMP END PARALLEL + + FREE int2_grad1u2_grad2u2_env2 + + else + + PROVIDE u12sq_envsq u12_grad1_u12_env_grad1_env grad12_j12 + + !$OMP PARALLEL & + !$OMP DEFAULT (NONE) & + !$OMP PRIVATE (i, j, ipoint) & + !$OMP SHARED (int2_grad1_u12_square_ao, ao_num, n_points_final_grid, u12sq_envsq, grad12_j12, u12_grad1_u12_env_grad1_env) + !$OMP DO SCHEDULE (static) + do ipoint = 1, n_points_final_grid + do j = 1, ao_num + do i = 1, ao_num + int2_grad1_u12_square_ao(i,j,ipoint) = u12sq_envsq(i,j,ipoint) + u12_grad1_u12_env_grad1_env(i,j,ipoint) + 0.5d0 * grad12_j12(i,j,ipoint) + enddo + enddo + enddo + !$OMP END DO + !$OMP END PARALLEL + + FREE u12sq_envsq u12_grad1_u12_env_grad1_env grad12_j12 + + endif ! use_ipp + + else + + print *, ' Error in int2_grad1_u12_square_ao: Unknown Jastrow' + stop + + endif ! j2e_type + + ! --- + + if(j1e_type .ne. "None") then + + PROVIDE elec_num + PROVIDE ao_overlap + PROVIDE j1e_gradx j1e_grady j1e_gradz + PROVIDE int2_grad1_u2e_ao + + tmp_ct1 = -1.0d0 / (dble(elec_num) - 1.d0) + tmp_ct2 = -0.5d0 / ((dble(elec_num) - 1.d0) * (dble(elec_num) - 1.d0)) + + !$OMP PARALLEL & + !$OMP DEFAULT (NONE) & + !$OMP PRIVATE (ipoint, i, j, dx, dy, dz, r2, & + !$OMP tmp0, tmp0_x, tmp0_y, tmp0_z) & + !$OMP SHARED (ao_num, n_points_final_grid, & + !$OMP tmp_ct1, tmp_ct2, ao_overlap, & + !$OMP j1e_gradx, j1e_grady, j1e_gradz, & + !$OMP int2_grad1_u2e_ao, int2_grad1_u12_square_ao) + !$OMP DO + do ipoint = 1, n_points_final_grid + + dx = j1e_gradx(ipoint) + dy = j1e_grady(ipoint) + dz = j1e_gradz(ipoint) + r2 = dx*dx + dy*dy + dz*dz + + tmp0 = tmp_ct2 * r2 + tmp0_x = tmp_ct1 * dx + tmp0_y = tmp_ct1 * dy + tmp0_z = tmp_ct1 * dz + + do j = 1, ao_num + do i = 1, ao_num + + int2_grad1_u12_square_ao(i,j,ipoint) = int2_grad1_u12_square_ao(i,j,ipoint) & + + tmp0 * ao_overlap(i,j) & + + tmp0_x * int2_grad1_u2e_ao(i,j,ipoint,1) & + + tmp0_y * int2_grad1_u2e_ao(i,j,ipoint,2) & + + tmp0_z * int2_grad1_u2e_ao(i,j,ipoint,3) + enddo + enddo + enddo + !$OMP END DO + !$OMP END PARALLEL + + endif ! j1e_type + + ! --- + + else + + write(*, '(A, A, A)') ' Error: The integration type ', trim(tc_integ_type), ' has not been implemented yet' + stop + + endif ! tc_integ_type + + call wall_time(time1) + print*, ' wall time for int2_grad1_u12_square_ao (min) = ', (time1-time0) / 60.d0 + call print_memory_usage() + +END_PROVIDER + +! --- + diff --git a/src/non_h_ints_mu/tc_integ_num.irp.f b/plugins/local/non_h_ints_mu/tc_integ_num.irp.f similarity index 86% rename from src/non_h_ints_mu/tc_integ_num.irp.f rename to plugins/local/non_h_ints_mu/tc_integ_num.irp.f index ee34f531..6b6e755d 100644 --- a/src/non_h_ints_mu/tc_integ_num.irp.f +++ b/plugins/local/non_h_ints_mu/tc_integ_num.irp.f @@ -1,10 +1,12 @@ +! --- + BEGIN_PROVIDER [double precision, int2_grad1_u12_ao_num , (ao_num,ao_num,n_points_final_grid,3)] &BEGIN_PROVIDER [double precision, int2_grad1_u12_square_ao_num, (ao_num,ao_num,n_points_final_grid) ] BEGIN_DOC ! - ! int2_grad1_u12_ao_num(i,j,ipoint,:) = \int dr2 [-1 * \grad_r1 J(r1,r2)] \phi_i(r2) \phi_j(r2) + ! int2_grad1_u12_ao_num(i,j,ipoint,:) = \int dr2 [\grad_r1 J(r1,r2)] \phi_i(r2) \phi_j(r2) ! ! int2_grad1_u12_square_ao_num = -(1/2) x int dr2 chi_l(r2) chi_j(r2) [grad_1 u(r1,r2)]^2 ! @@ -47,7 +49,7 @@ call total_memory(mem) mem = max(1.d0, qp_max_mem - mem) n_double = mem * 1.d8 - n_blocks = min(n_double / (n_points_extra_final_grid * 4), 1.d0*n_points_final_grid) + n_blocks = int(min(n_double / (n_points_extra_final_grid * 4.d0), 1.d0*n_points_final_grid)) n_rest = int(mod(n_points_final_grid, n_blocks)) n_pass = int((n_points_final_grid - n_rest) / n_blocks) @@ -71,10 +73,10 @@ !$OMP DO do i_blocks = 1, n_blocks ipoint = ii - 1 + i_blocks ! r1 - call get_grad1_u12_withsq_r1_seq(final_grid_points(1,ipoint), n_points_extra_final_grid, tmp_grad1_u12(1,i_blocks,1) & - , tmp_grad1_u12(1,i_blocks,2) & - , tmp_grad1_u12(1,i_blocks,3) & - , tmp_grad1_u12_squared(1,i_blocks)) + call get_grad1_u12_withsq_r1_seq(ipoint, n_points_extra_final_grid, tmp_grad1_u12(1,i_blocks,1) & + , tmp_grad1_u12(1,i_blocks,2) & + , tmp_grad1_u12(1,i_blocks,3) & + , tmp_grad1_u12_squared(1,i_blocks)) enddo !$OMP END DO !$OMP END PARALLEL @@ -107,10 +109,10 @@ !$OMP DO do i_rest = 1, n_rest ipoint = ii - 1 + i_rest ! r1 - call get_grad1_u12_withsq_r1_seq(final_grid_points(1,ipoint), n_points_extra_final_grid, tmp_grad1_u12(1,i_rest,1) & - , tmp_grad1_u12(1,i_rest,2) & - , tmp_grad1_u12(1,i_rest,3) & - , tmp_grad1_u12_squared(1,i_rest)) + call get_grad1_u12_withsq_r1_seq(ipoint, n_points_extra_final_grid, tmp_grad1_u12(1,i_rest,1) & + , tmp_grad1_u12(1,i_rest,2) & + , tmp_grad1_u12(1,i_rest,3) & + , tmp_grad1_u12_squared(1,i_rest)) enddo !$OMP END DO !$OMP END PARALLEL @@ -142,7 +144,7 @@ END_PROVIDER BEGIN_DOC ! - ! int2_grad1_u12_ao_num_1shot(i,j,ipoint,:) = \int dr2 [-1 * \grad_r1 J(r1,r2)] \phi_i(r2) \phi_j(r2) + ! int2_grad1_u12_ao_num_1shot(i,j,ipoint,:) = \int dr2 [\grad_r1 J(r1,r2)] \phi_i(r2) \phi_j(r2) ! ! int2_grad1_u12_square_ao_num_1shot = -(1/2) x int dr2 chi_l(r2) chi_j(r2) [grad_1 u(r1,r2)]^2 ! @@ -176,9 +178,7 @@ END_PROVIDER !$OMP END PARALLEL do m = 1, 3 - !call dgemm( "T", "N", ao_num*ao_num, n_points_final_grid, n_points_extra_final_grid, -1.d0 & - ! this work also because of the symmetry in K(1,2) and sign compensation in L(1,2,3) - call dgemm( "T", "N", ao_num*ao_num, n_points_final_grid, n_points_extra_final_grid, +1.d0 & + call dgemm( "T", "N", ao_num*ao_num, n_points_final_grid, n_points_extra_final_grid, 1.d0 & , tmp(1,1,1), n_points_extra_final_grid, grad1_u12_num(1,1,m), n_points_extra_final_grid & , 0.d0, int2_grad1_u12_ao_num_1shot(1,1,1,m), ao_num*ao_num) enddo diff --git a/plugins/local/non_h_ints_mu/test_non_h_ints.irp.f b/plugins/local/non_h_ints_mu/test_non_h_ints.irp.f new file mode 100644 index 00000000..90e5a7b3 --- /dev/null +++ b/plugins/local/non_h_ints_mu/test_non_h_ints.irp.f @@ -0,0 +1,1114 @@ + +! --- + +program test_non_h + + implicit none + + my_grid_becke = .True. + PROVIDE tc_grid1_a tc_grid1_r + my_n_pt_r_grid = tc_grid1_r + my_n_pt_a_grid = tc_grid1_a + touch my_grid_becke my_n_pt_r_grid my_n_pt_a_grid + + if(tc_integ_type .eq. "numeric") then + my_extra_grid_becke = .True. + PROVIDE tc_grid2_a tc_grid2_r + my_n_pt_r_extra_grid = tc_grid2_r + my_n_pt_a_extra_grid = tc_grid2_a + touch my_extra_grid_becke my_n_pt_r_extra_grid my_n_pt_a_extra_grid + endif + + PROVIDE j2e_type + PROVIDE j1e_type + PROVIDE env_type + print *, ' j2e_type = ', j2e_type + print *, ' j1e_type = ', j1e_type + print *, ' env_type = ', env_type + + !call routine_fit() + + !call test_ipp() + + !call test_v_ij_u_cst_mu_env_an() + + !call test_int2_grad1_u12_square_ao() + !call test_int2_grad1_u12_ao() + + !call test_j1e_grad() + + !call test_j1e_fit_ao() + + call test_tc_grad_and_lapl_ao_new() + call test_tc_grad_square_ao_new() +end + +! --- + +subroutine routine_fit + + implicit none + integer :: i,nx + double precision :: dx,xmax,x,j_mu,j_mu_F_x_j,j_mu_fit_gauss + + nx = 500 + xmax = 5.d0 + dx = xmax/dble(nx) + x = 0.d0 + print*,'coucou',mu_erf + do i = 1, nx + write(33,'(100(F16.10,X))') x,j_mu(x),j_mu_F_x_j(x),j_mu_fit_gauss(x) + x += dx + enddo + +end + +! --- + +subroutine test_ipp() + + implicit none + integer :: i, j, k, l, ipoint + double precision :: accu, norm, diff, old, new, eps, int_num + double precision :: weight1, ao_i_r, ao_k_r + double precision, allocatable :: b_mat(:,:,:), I1(:,:,:,:), I2(:,:,:,:) + + eps = 1d-7 + + allocate(b_mat(n_points_final_grid,ao_num,ao_num)) + b_mat = 0.d0 + + ! --- + + ! first way + + allocate(I1(ao_num,ao_num,ao_num,ao_num)) + I1 = 0.d0 + + PROVIDE u12_grad1_u12_env_grad1_env + + !$OMP PARALLEL & + !$OMP DEFAULT (NONE) & + !$OMP PRIVATE (i, k, ipoint) & + !$OMP SHARED (aos_in_r_array_transp, b_mat, ao_num, n_points_final_grid, final_weight_at_r_vector) + !$OMP DO SCHEDULE (static) + do i = 1, ao_num + do k = 1, ao_num + do ipoint = 1, n_points_final_grid + b_mat(ipoint,k,i) = final_weight_at_r_vector(ipoint) * aos_in_r_array_transp(ipoint,i) * aos_in_r_array_transp(ipoint,k) + enddo + enddo + enddo + !$OMP END DO + !$OMP END PARALLEL + + call dgemm( "N", "N", ao_num*ao_num, ao_num*ao_num, n_points_final_grid, 1.d0 & + , u12_grad1_u12_env_grad1_env(1,1,1), ao_num*ao_num, b_mat(1,1,1), n_points_final_grid & + , 0.d0, I1, ao_num*ao_num) + + ! --- + + ! 2nd way + + allocate(I2(ao_num,ao_num,ao_num,ao_num)) + I2 = 0.d0 + + PROVIDE int2_u2_env2 + + b_mat = 0.d0 + !$OMP PARALLEL & + !$OMP DEFAULT (NONE) & + !$OMP PRIVATE (i, k, ipoint, weight1, ao_i_r, ao_k_r) & + !$OMP SHARED (aos_in_r_array_transp, b_mat, ao_num, n_points_final_grid, final_weight_at_r_vector, & + !$OMP env_square_grad, env_square_lapl, aos_grad_in_r_array_transp_bis) + !$OMP DO SCHEDULE (static) + do i = 1, ao_num + do k = 1, ao_num + do ipoint = 1, n_points_final_grid + + weight1 = 0.25d0 * final_weight_at_r_vector(ipoint) + + ao_i_r = aos_in_r_array_transp(ipoint,i) + ao_k_r = aos_in_r_array_transp(ipoint,k) + + b_mat(ipoint,k,i) = weight1 * ( ao_k_r * ao_i_r * env_square_lapl(ipoint) & + + (ao_k_r * aos_grad_in_r_array_transp_bis(ipoint,i,1) + ao_i_r * aos_grad_in_r_array_transp_bis(ipoint,k,1)) * env_square_grad(ipoint,1) & + + (ao_k_r * aos_grad_in_r_array_transp_bis(ipoint,i,2) + ao_i_r * aos_grad_in_r_array_transp_bis(ipoint,k,2)) * env_square_grad(ipoint,2) & + + (ao_k_r * aos_grad_in_r_array_transp_bis(ipoint,i,3) + ao_i_r * aos_grad_in_r_array_transp_bis(ipoint,k,3)) * env_square_grad(ipoint,3) ) + enddo + enddo + enddo + !$OMP END DO + !$OMP END PARALLEL + + call dgemm( "N", "N", ao_num*ao_num, ao_num*ao_num, n_points_final_grid, 1.d0 & + , int2_u2_env2(1,1,1), ao_num*ao_num, b_mat(1,1,1), n_points_final_grid & + , 0.d0, I2, ao_num*ao_num) + + ! --- + + deallocate(b_mat) + + accu = 0.d0 + norm = 0.d0 + do i = 1, ao_num + do k = 1, ao_num + do l = 1, ao_num + do j = 1, ao_num + + old = I1(j,l,k,i) + new = I2(j,l,k,i) + + !print*, l, k, j, i + !print*, old, new + + diff = new - old + if(dabs(diff) .gt. eps) then + print*, ' problem on :', j, l, k, i + print*, ' diff = ', diff + print*, ' old value = ', old + print*, ' new value = ', new + call I_grade_gradu_naive1(i, j, k, l, int_num) + print*, ' full num1 = ', int_num + call I_grade_gradu_naive2(i, j, k, l, int_num) + print*, ' full num2 = ', int_num + call I_grade_gradu_naive3(i, j, k, l, int_num) + print*, ' full num3 = ', int_num + call I_grade_gradu_naive4(i, j, k, l, int_num) + print*, ' full num4 = ', int_num + call I_grade_gradu_seminaive(i, j, k, l, int_num) + print*, ' semi num = ', int_num + endif + + accu += dabs(diff) + norm += dabs(old) + enddo + enddo + enddo + enddo + + deallocate(I1, I2) + + print*, ' accu = ', accu + print*, ' norm = ', norm + + return +end subroutine test_ipp + +! --- + +subroutine I_grade_gradu_naive1(i, j, k, l, int) + + implicit none + integer, intent(in) :: i, j, k, l + double precision, intent(out) :: int + integer :: ipoint, jpoint + double precision :: r1(3), r2(3) + double precision :: weight1_x, weight1_y, weight1_z + double precision :: weight2_x, weight2_y, weight2_z + double precision :: aor_i, aor_j, aor_k, aor_l + double precision :: e1_val, e2_val, e1_der(3), u12_val, u12_der(3) + double precision, external :: env_nucl, j12_mu + + int = 0.d0 + + do ipoint = 1, n_points_final_grid ! r1 + + r1(1) = final_grid_points(1,ipoint) + r1(2) = final_grid_points(2,ipoint) + r1(3) = final_grid_points(3,ipoint) + + aor_i = aos_in_r_array_transp(ipoint,i) + aor_k = aos_in_r_array_transp(ipoint,k) + + e1_val = env_nucl(r1) + call grad1_env_nucl(r1, e1_der) + + weight1_x = aor_i * aor_k * e1_val * final_weight_at_r_vector(ipoint) * e1_der(1) + weight1_y = aor_i * aor_k * e1_val * final_weight_at_r_vector(ipoint) * e1_der(2) + weight1_z = aor_i * aor_k * e1_val * final_weight_at_r_vector(ipoint) * e1_der(3) + + do jpoint = 1, n_points_extra_final_grid ! r2 + + r2(1) = final_grid_points_extra(1,jpoint) + r2(2) = final_grid_points_extra(2,jpoint) + r2(3) = final_grid_points_extra(3,jpoint) + + aor_j = aos_in_r_array_extra_transp(jpoint,j) + aor_l = aos_in_r_array_extra_transp(jpoint,l) + + e2_val = env_nucl(r2) + + u12_val = j12_mu(r1, r2) + call grad1_j12_mu(r1, r2, u12_der) + + weight2_x = aor_j * aor_l * e2_val * e2_val * u12_val * final_weight_at_r_vector_extra(jpoint) * u12_der(1) + weight2_y = aor_j * aor_l * e2_val * e2_val * u12_val * final_weight_at_r_vector_extra(jpoint) * u12_der(2) + weight2_z = aor_j * aor_l * e2_val * e2_val * u12_val * final_weight_at_r_vector_extra(jpoint) * u12_der(3) + + int = int - (weight1_x * weight2_x + weight1_y * weight2_y + weight1_z * weight2_z) + enddo + enddo + + return +end subroutine I_grade_gradu_naive1 + +! --- + +subroutine I_grade_gradu_naive2(i, j, k, l, int) + + implicit none + integer, intent(in) :: i, j, k, l + double precision, intent(out) :: int + integer :: ipoint, jpoint + double precision :: r1(3), r2(3) + double precision :: weight1_x, weight1_y, weight1_z + double precision :: weight2_x, weight2_y, weight2_z + double precision :: aor_i, aor_j, aor_k, aor_l + double precision :: e1_square_der(3), e2_val, u12_square_der(3) + double precision, external :: env_nucl + + int = 0.d0 + + do ipoint = 1, n_points_final_grid ! r1 + + r1(1) = final_grid_points(1,ipoint) + r1(2) = final_grid_points(2,ipoint) + r1(3) = final_grid_points(3,ipoint) + + aor_i = aos_in_r_array_transp(ipoint,i) + aor_k = aos_in_r_array_transp(ipoint,k) + + call grad1_env_nucl_square_num(r1, e1_square_der) + + weight1_x = aor_i * aor_k * final_weight_at_r_vector(ipoint) * e1_square_der(1) + weight1_y = aor_i * aor_k * final_weight_at_r_vector(ipoint) * e1_square_der(2) + weight1_z = aor_i * aor_k * final_weight_at_r_vector(ipoint) * e1_square_der(3) + + do jpoint = 1, n_points_extra_final_grid ! r2 + + r2(1) = final_grid_points_extra(1,jpoint) + r2(2) = final_grid_points_extra(2,jpoint) + r2(3) = final_grid_points_extra(3,jpoint) + + aor_j = aos_in_r_array_extra_transp(jpoint,j) + aor_l = aos_in_r_array_extra_transp(jpoint,l) + + e2_val = env_nucl(r2) + call grad1_j12_mu_square_num(r1, r2, u12_square_der) + + weight2_x = aor_j * aor_l * e2_val * e2_val * final_weight_at_r_vector_extra(jpoint) * u12_square_der(1) + weight2_y = aor_j * aor_l * e2_val * e2_val * final_weight_at_r_vector_extra(jpoint) * u12_square_der(2) + weight2_z = aor_j * aor_l * e2_val * e2_val * final_weight_at_r_vector_extra(jpoint) * u12_square_der(3) + + int = int - 0.25d0 * (weight1_x * weight2_x + weight1_y * weight2_y + weight1_z * weight2_z) + enddo + enddo + + return +end subroutine I_grade_gradu_naive2 + +! --- + +subroutine I_grade_gradu_naive3(i, j, k, l, int) + + implicit none + integer, intent(in) :: i, j, k, l + double precision, intent(out) :: int + integer :: ipoint, jpoint + double precision :: r1(3), r2(3) + double precision :: weight1, weight2 + double precision :: aor_j, aor_l + double precision :: grad(3), e2_val, u12_val + double precision, external :: env_nucl, j12_mu + + int = 0.d0 + + do ipoint = 1, n_points_final_grid ! r1 + + r1(1) = final_grid_points(1,ipoint) + r1(2) = final_grid_points(2,ipoint) + r1(3) = final_grid_points(3,ipoint) + + call grad1_aos_ik_grad1_esquare(i, k, r1, grad) + + weight1 = final_weight_at_r_vector(ipoint) * (grad(1) + grad(2) + grad(3)) + + do jpoint = 1, n_points_extra_final_grid ! r2 + + r2(1) = final_grid_points_extra(1,jpoint) + r2(2) = final_grid_points_extra(2,jpoint) + r2(3) = final_grid_points_extra(3,jpoint) + + aor_j = aos_in_r_array_extra_transp(jpoint,j) + aor_l = aos_in_r_array_extra_transp(jpoint,l) + + e2_val = env_nucl(r2) + u12_val = j12_mu(r1, r2) + + weight2 = aor_j * aor_l * e2_val * e2_val * u12_val * u12_val * final_weight_at_r_vector_extra(jpoint) + + int = int + 0.25d0 * weight1 * weight2 + enddo + enddo + + return +end subroutine I_grade_gradu_naive3 + +! --- + +subroutine I_grade_gradu_naive4(i, j, k, l, int) + + implicit none + integer, intent(in) :: i, j, k, l + double precision, intent(out) :: int + integer :: ipoint, jpoint + double precision :: r1(3), r2(3) + double precision :: weight1, weight2 + double precision :: aor_j, aor_l, aor_k, aor_i + double precision :: grad(3), e2_val, u12_val + double precision, external :: env_nucl, j12_mu + + int = 0.d0 + + do ipoint = 1, n_points_final_grid ! r1 + + r1(1) = final_grid_points(1,ipoint) + r1(2) = final_grid_points(2,ipoint) + r1(3) = final_grid_points(3,ipoint) + + aor_i = aos_in_r_array_transp(ipoint,i) + aor_k = aos_in_r_array_transp(ipoint,k) + + weight1 = final_weight_at_r_vector(ipoint) * ( aor_k * aor_i * env_square_lapl(ipoint) & + + (aor_k * aos_grad_in_r_array_transp_bis(ipoint,i,1) + aor_i * aos_grad_in_r_array_transp_bis(ipoint,k,1)) * env_square_grad(ipoint,1) & + + (aor_k * aos_grad_in_r_array_transp_bis(ipoint,i,2) + aor_i * aos_grad_in_r_array_transp_bis(ipoint,k,2)) * env_square_grad(ipoint,2) & + + (aor_k * aos_grad_in_r_array_transp_bis(ipoint,i,3) + aor_i * aos_grad_in_r_array_transp_bis(ipoint,k,3)) * env_square_grad(ipoint,3) ) + + do jpoint = 1, n_points_extra_final_grid ! r2 + + r2(1) = final_grid_points_extra(1,jpoint) + r2(2) = final_grid_points_extra(2,jpoint) + r2(3) = final_grid_points_extra(3,jpoint) + + aor_j = aos_in_r_array_extra_transp(jpoint,j) + aor_l = aos_in_r_array_extra_transp(jpoint,l) + + e2_val = env_nucl(r2) + u12_val = j12_mu(r1, r2) + + weight2 = aor_j * aor_l * e2_val * e2_val * u12_val * u12_val * final_weight_at_r_vector_extra(jpoint) + + int = int + 0.25d0 * weight1 * weight2 + enddo + enddo + + return +end + +! --- + +subroutine I_grade_gradu_seminaive(i, j, k, l, int) + + implicit none + integer, intent(in) :: i, j, k, l + double precision, intent(out) :: int + integer :: ipoint + double precision :: r1(3) + double precision :: weight1 + double precision :: aor_i, aor_k + + int = 0.d0 + + do ipoint = 1, n_points_final_grid ! r1 + + aor_i = aos_in_r_array_transp(ipoint,i) + aor_k = aos_in_r_array_transp(ipoint,k) + + weight1 = 0.25d0 * final_weight_at_r_vector(ipoint) * ( aor_k * aor_i * env_square_lapl(ipoint) & + + (aor_k * aos_grad_in_r_array_transp_bis(ipoint,i,1) + aor_i * aos_grad_in_r_array_transp_bis(ipoint,k,1)) * env_square_grad(ipoint,1) & + + (aor_k * aos_grad_in_r_array_transp_bis(ipoint,i,2) + aor_i * aos_grad_in_r_array_transp_bis(ipoint,k,2)) * env_square_grad(ipoint,2) & + + (aor_k * aos_grad_in_r_array_transp_bis(ipoint,i,3) + aor_i * aos_grad_in_r_array_transp_bis(ipoint,k,3)) * env_square_grad(ipoint,3) ) + + int = int + weight1 * int2_u2_env2(j,l,ipoint) + enddo + + return +end + +! --- + +subroutine aos_ik_grad1_esquare(i, k, r1, val) + + implicit none + integer, intent(in) :: i, k + double precision, intent(in) :: r1(3) + double precision, intent(out) :: val(3) + double precision :: tmp + double precision :: der(3), aos_array(ao_num), aos_grad_array(3,ao_num) + + call give_all_aos_and_grad_at_r(r1, aos_array, aos_grad_array) + call grad1_env_nucl_square_num(r1, der) + + tmp = aos_array(i) * aos_array(k) + val(1) = tmp * der(1) + val(2) = tmp * der(2) + val(3) = tmp * der(3) + + return +end subroutine phi_ik_grad1_esquare + +! --- + +subroutine grad1_aos_ik_grad1_esquare(i, k, r1, grad) + + implicit none + integer, intent(in) :: i, k + double precision, intent(in) :: r1(3) + double precision, intent(out) :: grad(3) + double precision :: r(3), eps, tmp_eps, val_p(3), val_m(3) + + eps = 1d-5 + tmp_eps = 0.5d0 / eps + + r(1:3) = r1(1:3) + + r(1) = r(1) + eps + call aos_ik_grad1_esquare(i, k, r, val_p) + r(1) = r(1) - 2.d0 * eps + call aos_ik_grad1_esquare(i, k, r, val_m) + r(1) = r(1) + eps + grad(1) = tmp_eps * (val_p(1) - val_m(1)) + + r(2) = r(2) + eps + call aos_ik_grad1_esquare(i, k, r, val_p) + r(2) = r(2) - 2.d0 * eps + call aos_ik_grad1_esquare(i, k, r, val_m) + r(2) = r(2) + eps + grad(2) = tmp_eps * (val_p(2) - val_m(2)) + + r(3) = r(3) + eps + call aos_ik_grad1_esquare(i, k, r, val_p) + r(3) = r(3) - 2.d0 * eps + call aos_ik_grad1_esquare(i, k, r, val_m) + r(3) = r(3) + eps + grad(3) = tmp_eps * (val_p(3) - val_m(3)) + + return +end subroutine grad1_aos_ik_grad1_esquare + +! --- + +subroutine test_v_ij_u_cst_mu_env_an() + + implicit none + integer :: i, j, ipoint + double precision :: I_old, I_new + double precision :: norm, accu, thr, diff + + PROVIDE v_ij_u_cst_mu_env_an_old v_ij_u_cst_mu_env_an + + thr = 1d-12 + norm = 0.d0 + accu = 0.d0 + do ipoint = 1, n_points_final_grid + do i = 1, ao_num + do j = 1, ao_num + + I_old = v_ij_u_cst_mu_env_an_old(j,i,ipoint) + I_new = v_ij_u_cst_mu_env_an (j,i,ipoint) + + diff = dabs(I_new-I_old) + if(diff .gt. thr) then + print *, ' problem on:', j, i, ipoint + print *, ' old value :', I_old + print *, ' new value :', I_new + stop + endif + + accu += diff + norm += dabs(I_old) + enddo + enddo + enddo + + print*, ' accuracy(%) = ', 100.d0 * accu / norm + + return +end + +! --- + +subroutine test_int2_grad1_u12_square_ao() + + implicit none + integer :: i, j, ipoint + double precision :: I_old, I_new + double precision :: norm, accu, thr, diff + + PROVIDE int2_grad1_u12_square_ao + PROVIDE int2_grad1_u12_square_ao_num_1shot + + thr = 1d-8 + norm = 0.d0 + accu = 0.d0 + do ipoint = 1, n_points_final_grid + do i = 1, ao_num + do j = 1, ao_num + + I_old = int2_grad1_u12_square_ao_num_1shot(j,i,ipoint) + I_new = int2_grad1_u12_square_ao (j,i,ipoint) + !I_new = int2_grad1_u12_square_ao_num (j,i,ipoint) + + diff = dabs(I_new-I_old) + if(diff .gt. thr) then + print *, ' problem on:', j, i, ipoint + print *, ' old value :', I_old + print *, ' new value :', I_new + !stop + endif + + accu += diff + norm += dabs(I_old) + enddo + enddo + enddo + + print*, ' accuracy(%) = ', 100.d0 * accu / norm + + return +end + +! --- + +subroutine test_int2_grad1_u12_ao() + + implicit none + integer :: i, j, ipoint, m + double precision :: I_old, I_new + double precision :: norm, accu, thr, diff + + PROVIDE int2_grad1_u12_ao + PROVIDE int2_grad1_u12_ao_num_1shot + + thr = 1d-8 + norm = 0.d0 + accu = 0.d0 + do ipoint = 1, n_points_final_grid + do i = 1, ao_num + do j = 1, ao_num + + do m = 1, 3 + I_old = int2_grad1_u12_ao_num_1shot(j,i,ipoint,m) + I_new = int2_grad1_u12_ao (j,i,ipoint,m) + !I_new = int2_grad1_u12_ao_num (j,i,ipoint,m) + + diff = dabs(I_new-I_old) + if(diff .gt. thr) then + print *, ' problem on:', j, i, ipoint, m + print *, ' old value :', I_old + print *, ' new value :', I_new + !stop + endif + + accu += diff + norm += dabs(I_old) + enddo + enddo + enddo + enddo + + print*, ' accuracy(%) = ', 100.d0 * accu / norm + + return +end + +! --- + +subroutine test_j1e_grad() + + implicit none + integer :: i, j, ipoint + double precision :: g + double precision :: x_loops, x_dgemm, diff, thr, accu, norm + double precision, allocatable :: pa(:,:), Pb(:,:), Pt(:,:) + double precision, allocatable :: x(:), y(:), z(:) + + PROVIDE int2_grad1_u2e_ao + PROVIDE mo_coef + + allocate(Pa(ao_num,ao_num), Pb(ao_num,ao_num), Pt(ao_num,ao_num)) + + call dgemm( 'N', 'T', ao_num, ao_num, elec_alpha_num, 1.d0 & + , mo_coef, size(mo_coef, 1), mo_coef, size(mo_coef, 1) & + , 0.d0, Pa, size(Pa, 1)) + + if(elec_alpha_num .eq. elec_beta_num) then + Pb = Pa + else + call dgemm( 'N', 'T', ao_num, ao_num, elec_beta_num, 1.d0 & + , mo_coef, size(mo_coef, 1), mo_coef, size(mo_coef, 1) & + , 0.d0, Pb, size(Pb, 1)) + endif + Pt = Pa + Pa + + + g = 0.5d0 * (dble(elec_num) - 1.d0) / dble(elec_num) + + allocate(x(n_points_final_grid), y(n_points_final_grid), z(n_points_final_grid)) + + do ipoint = 1, n_points_final_grid + x(ipoint) = 0.d0 + y(ipoint) = 0.d0 + z(ipoint) = 0.d0 + do i = 1, ao_num + do j = 1, ao_num + x(ipoint) = x(ipoint) + g * Pt(i,j) * int2_grad1_u2e_ao(i,j,ipoint,1) + y(ipoint) = y(ipoint) + g * Pt(i,j) * int2_grad1_u2e_ao(i,j,ipoint,2) + z(ipoint) = z(ipoint) + g * Pt(i,j) * int2_grad1_u2e_ao(i,j,ipoint,3) + enddo + enddo + enddo + + deallocate(Pa, Pb, Pt) + + ! --- + + thr = 1d-10 + norm = 0.d0 + accu = 0.d0 + do ipoint = 1, n_points_final_grid + + x_loops = x (ipoint) + x_dgemm = j1e_gradx(ipoint) + diff = dabs(x_loops - x_dgemm) + if(diff .gt. thr) then + print *, ' problem in j1e_gradx on:', ipoint + print *, ' loops :', x_loops + print *, ' dgemm :', x_dgemm + stop + endif + accu += diff + norm += dabs(x_loops) + + x_loops = y (ipoint) + x_dgemm = j1e_grady(ipoint) + diff = dabs(x_loops - x_dgemm) + if(diff .gt. thr) then + print *, ' problem in j1e_grady on:', ipoint + print *, ' loops :', x_loops + print *, ' dgemm :', x_dgemm + stop + endif + accu += diff + norm += dabs(x_loops) + + x_loops = z (ipoint) + x_dgemm = j1e_gradz(ipoint) + diff = dabs(x_loops - x_dgemm) + if(diff .gt. thr) then + print *, ' problem in j1e_gradz on:', ipoint + print *, ' loops :', x_loops + print *, ' dgemm :', x_dgemm + stop + endif + accu += diff + norm += dabs(x_loops) + + enddo + + deallocate(x, y, z) + + print*, ' accuracy(%) = ', 100.d0 * accu / norm + + return +end + +! --- + +subroutine test_j1e_fit_ao() + + implicit none + integer :: i, j, ipoint + double precision :: g, c + double precision :: x_loops, x_dgemm, diff, thr, accu, norm + double precision, allocatable :: pa(:,:), Pb(:,:), Pt(:,:) + double precision, allocatable :: x(:), y(:), z(:) + double precision, allocatable :: x_fit(:), y_fit(:), z_fit(:), coef_fit(:) + + PROVIDE mo_coef + PROVIDE int2_grad1_u2e_ao + + ! --- + + allocate(Pa(ao_num,ao_num), Pb(ao_num,ao_num), Pt(ao_num,ao_num)) + + call dgemm( 'N', 'T', ao_num, ao_num, elec_alpha_num, 1.d0 & + , mo_coef, size(mo_coef, 1), mo_coef, size(mo_coef, 1) & + , 0.d0, Pa, size(Pa, 1)) + + if(elec_alpha_num .eq. elec_beta_num) then + Pb = Pa + else + call dgemm( 'N', 'T', ao_num, ao_num, elec_beta_num, 1.d0 & + , mo_coef, size(mo_coef, 1), mo_coef, size(mo_coef, 1) & + , 0.d0, Pb, size(Pb, 1)) + endif + Pt = Pa + Pa + + allocate(x(n_points_final_grid), y(n_points_final_grid), z(n_points_final_grid)) + + g = -0.5d0 * (dble(elec_num) - 1.d0) / dble(elec_num) + + call dgemv("T", ao_num*ao_num, n_points_final_grid, g, int2_grad1_u2e_ao(1,1,1,1), ao_num*ao_num, Pt, 1, 0.d0, x, 1) + call dgemv("T", ao_num*ao_num, n_points_final_grid, g, int2_grad1_u2e_ao(1,1,1,2), ao_num*ao_num, Pt, 1, 0.d0, y, 1) + call dgemv("T", ao_num*ao_num, n_points_final_grid, g, int2_grad1_u2e_ao(1,1,1,3), ao_num*ao_num, Pt, 1, 0.d0, z, 1) + + FREE int2_grad1_u2e_ao + + deallocate(Pa, Pb, Pt) + + ! --- + + allocate(x_fit(n_points_final_grid), y_fit(n_points_final_grid), z_fit(n_points_final_grid)) + allocate(coef_fit(ao_num)) + + call get_j1e_coef_fit_ao(ao_num, coef_fit) + !print *, ' coef fit in AO:' + !print*, coef_fit + +! !$OMP PARALLEL & +! !$OMP DEFAULT (NONE) & +! !$OMP PRIVATE (i, ipoint, c) & +! !$OMP SHARED (n_points_final_grid, ao_num, & +! !$OMP aos_grad_in_r_array, coef_fit, x_fit, y_fit, z_fit) +! !$OMP DO SCHEDULE (static) + do ipoint = 1, n_points_final_grid + x_fit(ipoint) = 0.d0 + y_fit(ipoint) = 0.d0 + z_fit(ipoint) = 0.d0 + do i = 1, ao_num + c = coef_fit(i) + x_fit(ipoint) = x_fit(ipoint) + c * aos_grad_in_r_array(i,ipoint,1) + y_fit(ipoint) = y_fit(ipoint) + c * aos_grad_in_r_array(i,ipoint,2) + z_fit(ipoint) = z_fit(ipoint) + c * aos_grad_in_r_array(i,ipoint,3) + enddo + enddo +! !$OMP END DO +! !$OMP END PARALLEL + + deallocate(coef_fit) + + ! --- + + thr = 1d-10 + norm = 0.d0 + accu = 0.d0 + do ipoint = 1, n_points_final_grid + + x_loops = x (ipoint) + x_dgemm = x_fit(ipoint) + diff = dabs(x_loops - x_dgemm) + !if(diff .gt. thr) then + ! print *, ' problem in j1e_gradx on:', ipoint + ! print *, ' loops :', x_loops + ! print *, ' dgemm :', x_dgemm + ! stop + !endif + accu += diff + norm += dabs(x_loops) + + x_loops = y (ipoint) + x_dgemm = y_fit(ipoint) + diff = dabs(x_loops - x_dgemm) + !if(diff .gt. thr) then + ! print *, ' problem in j1e_grady on:', ipoint + ! print *, ' loops :', x_loops + ! print *, ' dgemm :', x_dgemm + ! stop + !endif + accu += diff + norm += dabs(x_loops) + + x_loops = z (ipoint) + x_dgemm = z_fit(ipoint) + diff = dabs(x_loops - x_dgemm) + !if(diff .gt. thr) then + ! print *, ' problem in j1e_gradz on:', ipoint + ! print *, ' loops :', x_loops + ! print *, ' dgemm :', x_dgemm + ! stop + !endif + accu += diff + norm += dabs(x_loops) + enddo + + deallocate(x, y, z) + deallocate(x_fit, y_fit, z_fit) + + print*, ' fit accuracy (%) = ', 100.d0 * accu / norm + +end + +! --- + +subroutine test_tc_grad_and_lapl_ao_new() + + implicit none + integer :: i, j, k, l + double precision :: i_old, i_new, diff, thr, accu, norm + double precision, allocatable :: tc_grad_and_lapl_ao_old(:,:,:,:) + + PROVIDE tc_grad_and_lapl_ao_new + + thr = 1d-10 + norm = 0.d0 + accu = 0.d0 + + allocate(tc_grad_and_lapl_ao_old(ao_num,ao_num,ao_num,ao_num)) + + open(unit=11, form="unformatted", file=trim(ezfio_filename)//'/work/tc_grad_and_lapl_ao_old', action="read") + read(11) tc_grad_and_lapl_ao_old + close(11) + + do i = 1, ao_num + do j = 1, ao_num + do k = 1, ao_num + do l = 1, ao_num + + i_old = tc_grad_and_lapl_ao_old(l,k,j,i) + i_new = tc_grad_and_lapl_ao_new(l,k,j,i) + diff = dabs(i_old - i_new) + if(diff .gt. thr) then + print *, ' problem in tc_grad_and_lapl_ao_new on:', l, k, j, i + print *, ' old :', i_old + print *, ' new :', i_new + stop + endif + accu += diff + norm += dabs(i_old) + enddo + enddo + enddo + enddo + + deallocate(tc_grad_and_lapl_ao_old) + + print*, ' accuracy (%) = ', 100.d0 * accu / norm + +end + +! --- + +subroutine test_tc_grad_square_ao_new() + + implicit none + integer :: i, j, k, l + double precision :: i_old, i_new, diff, thr, accu, norm + double precision, allocatable :: tc_grad_square_ao_old(:,:,:,:) + + PROVIDE tc_grad_square_ao_new + + thr = 1d-10 + norm = 0.d0 + accu = 0.d0 + + allocate(tc_grad_square_ao_old(ao_num,ao_num,ao_num,ao_num)) + + open(unit=11, form="unformatted", file=trim(ezfio_filename)//'/work/tc_grad_square_ao_old', action="read") + read(11) tc_grad_square_ao_old + close(11) + + do i = 1, ao_num + do j = 1, ao_num + do k = 1, ao_num + do l = 1, ao_num + + i_old = tc_grad_square_ao_old(l,k,j,i) + i_new = tc_grad_square_ao_new(l,k,j,i) + diff = dabs(i_old - i_new) + if(diff .gt. thr) then + print *, ' problem in tc_grad_and_lapl_ao_new on:', l, k, j, i + print *, ' old :', i_old + print *, ' new :', i_new + stop + endif + accu += diff + norm += dabs(i_old) + enddo + enddo + enddo + enddo + + deallocate(tc_grad_square_ao_old) + + print*, ' accuracy (%) = ', 100.d0 * accu / norm + +end + +! --- + +BEGIN_PROVIDER [double precision, tc_grad_square_ao_new, (ao_num, ao_num, ao_num, ao_num)] + + implicit none + integer :: i, j, k, l, m, ipoint + double precision :: weight1, ao_k_r, ao_i_r + double precision :: der_envsq_x, der_envsq_y, der_envsq_z, lap_envsq + double precision :: time0, time1 + double precision, allocatable :: b_mat(:,:,:,:), c_mat(:,:,:) + double precision, external :: get_ao_two_e_integral + + PROVIDe tc_integ_type + PROVIDE env_type + PROVIDE j2e_type + PROVIDE j1e_type + + call wall_time(time0) + + print *, ' providing tc_grad_square_ao_new ...' + + PROVIDE int2_grad1_u12_square_ao + + allocate(c_mat(n_points_final_grid,ao_num,ao_num)) + + !$OMP PARALLEL & + !$OMP DEFAULT (NONE) & + !$OMP PRIVATE (i, k, ipoint) & + !$OMP SHARED (aos_in_r_array_transp, c_mat, ao_num, n_points_final_grid, final_weight_at_r_vector) + !$OMP DO SCHEDULE (static) + do i = 1, ao_num + do k = 1, ao_num + do ipoint = 1, n_points_final_grid + c_mat(ipoint,k,i) = final_weight_at_r_vector(ipoint) * aos_in_r_array_transp(ipoint,i) * aos_in_r_array_transp(ipoint,k) + enddo + enddo + enddo + !$OMP END DO + !$OMP END PARALLEL + + call dgemm( "N", "N", ao_num*ao_num, ao_num*ao_num, n_points_final_grid, 1.d0 & + , int2_grad1_u12_square_ao(1,1,1), ao_num*ao_num, c_mat(1,1,1), n_points_final_grid & + , 0.d0, tc_grad_square_ao_new, ao_num*ao_num) + + FREE int2_grad1_u12_square_ao + + if( (tc_integ_type .eq. "semi-analytic") .and. & + (j2e_type .eq. "Mu") .and. & + ((env_type .eq. "Prod_Gauss") .or. (env_type .eq. "Sum_Gauss")) .and. & + use_ipp ) then + + ! an additional term is added here directly instead of + ! being added in int2_grad1_u12_square_ao for performance + + PROVIDE int2_u2_env2 + + !$OMP PARALLEL & + !$OMP DEFAULT (NONE) & + !$OMP PRIVATE (i, k, ipoint, weight1, ao_i_r, ao_k_r) & + !$OMP SHARED (aos_in_r_array_transp, c_mat, ao_num, n_points_final_grid, final_weight_at_r_vector, & + !$OMP env_square_grad, env_square_lapl, aos_grad_in_r_array_transp_bis) + !$OMP DO SCHEDULE (static) + do i = 1, ao_num + do k = 1, ao_num + do ipoint = 1, n_points_final_grid + + weight1 = 0.25d0 * final_weight_at_r_vector(ipoint) + + ao_i_r = aos_in_r_array_transp(ipoint,i) + ao_k_r = aos_in_r_array_transp(ipoint,k) + + c_mat(ipoint,k,i) = weight1 * ( ao_k_r * ao_i_r * env_square_lapl(ipoint) & + + (ao_k_r * aos_grad_in_r_array_transp_bis(ipoint,i,1) + ao_i_r * aos_grad_in_r_array_transp_bis(ipoint,k,1)) * env_square_grad(ipoint,1) & + + (ao_k_r * aos_grad_in_r_array_transp_bis(ipoint,i,2) + ao_i_r * aos_grad_in_r_array_transp_bis(ipoint,k,2)) * env_square_grad(ipoint,2) & + + (ao_k_r * aos_grad_in_r_array_transp_bis(ipoint,i,3) + ao_i_r * aos_grad_in_r_array_transp_bis(ipoint,k,3)) * env_square_grad(ipoint,3) ) + enddo + enddo + enddo + !$OMP END DO + !$OMP END PARALLEL + + call dgemm( "N", "N", ao_num*ao_num, ao_num*ao_num, n_points_final_grid, 1.d0 & + , int2_u2_env2(1,1,1), ao_num*ao_num, c_mat(1,1,1), n_points_final_grid & + , 1.d0, tc_grad_square_ao_new, ao_num*ao_num) + + FREE int2_u2_env2 + endif ! use_ipp + + deallocate(c_mat) + + call sum_A_At(tc_grad_square_ao_new(1,1,1,1), ao_num*ao_num) + + call wall_time(time1) + print*, ' Wall time for tc_grad_square_ao_new (min) = ', (time1 - time0) / 60.d0 + +END_PROVIDER + +! --- + +BEGIN_PROVIDER [double precision, tc_grad_and_lapl_ao_new, (ao_num, ao_num, ao_num, ao_num)] + + implicit none + integer :: i, j, k, l, m, ipoint + double precision :: weight1, ao_k_r, ao_i_r + double precision :: der_envsq_x, der_envsq_y, der_envsq_z, lap_envsq + double precision :: time0, time1 + double precision, allocatable :: b_mat(:,:,:,:), c_mat(:,:,:) + double precision, external :: get_ao_two_e_integral + + PROVIDe tc_integ_type + PROVIDE env_type + PROVIDE j2e_type + PROVIDE j1e_type + + call wall_time(time0) + + print *, ' providing tc_grad_square_ao_new ...' + + + PROVIDE int2_grad1_u12_ao + + allocate(b_mat(n_points_final_grid,ao_num,ao_num,3)) + + !$OMP PARALLEL & + !$OMP DEFAULT (NONE) & + !$OMP PRIVATE (i, k, ipoint, weight1, ao_i_r, ao_k_r) & + !$OMP SHARED (aos_in_r_array_transp, aos_grad_in_r_array_transp_bis, b_mat, & + !$OMP ao_num, n_points_final_grid, final_weight_at_r_vector) + !$OMP DO SCHEDULE (static) + do i = 1, ao_num + do k = 1, ao_num + do ipoint = 1, n_points_final_grid + + weight1 = 0.5d0 * final_weight_at_r_vector(ipoint) + ao_i_r = aos_in_r_array_transp(ipoint,i) + ao_k_r = aos_in_r_array_transp(ipoint,k) + + b_mat(ipoint,k,i,1) = weight1 * (ao_k_r * aos_grad_in_r_array_transp_bis(ipoint,i,1) - ao_i_r * aos_grad_in_r_array_transp_bis(ipoint,k,1)) + b_mat(ipoint,k,i,2) = weight1 * (ao_k_r * aos_grad_in_r_array_transp_bis(ipoint,i,2) - ao_i_r * aos_grad_in_r_array_transp_bis(ipoint,k,2)) + b_mat(ipoint,k,i,3) = weight1 * (ao_k_r * aos_grad_in_r_array_transp_bis(ipoint,i,3) - ao_i_r * aos_grad_in_r_array_transp_bis(ipoint,k,3)) + enddo + enddo + enddo + !$OMP END DO + !$OMP END PARALLEL + + tc_grad_and_lapl_ao_new = 0.d0 + do m = 1, 3 + call dgemm( "N", "N", ao_num*ao_num, ao_num*ao_num, n_points_final_grid, -1.d0 & + , int2_grad1_u12_ao(1,1,1,m), ao_num*ao_num, b_mat(1,1,1,m), n_points_final_grid & + , 1.d0, tc_grad_and_lapl_ao_new, ao_num*ao_num) + enddo + deallocate(b_mat) + + FREE int2_grad1_u12_ao + FREE int2_grad1_u2e_ao + + call sum_A_At(tc_grad_and_lapl_ao_new(1,1,1,1), ao_num*ao_num) + + call wall_time(time1) + print*, ' Wall time for tc_grad_and_lapl_ao_new (min) = ', (time1 - time0) / 60.d0 + +END_PROVIDER + +! --- + diff --git a/plugins/local/non_h_ints_mu/total_tc_int.irp.f b/plugins/local/non_h_ints_mu/total_tc_int.irp.f new file mode 100644 index 00000000..38da4047 --- /dev/null +++ b/plugins/local/non_h_ints_mu/total_tc_int.irp.f @@ -0,0 +1,223 @@ + +! --- + +BEGIN_PROVIDER [double precision, ao_two_e_tc_tot, (ao_num, ao_num, ao_num, ao_num)] + + BEGIN_DOC + ! + ! CHEMIST NOTATION IS USED + ! + ! ao_two_e_tc_tot(k,i,l,j) = (ki|V^TC(r_12)|lj) + ! = where V^TC(r_12) is the total TC operator + ! = tc_grad_and_lapl_ao(k,i,l,j) + tc_grad_square_ao(k,i,l,j) + ao_two_e_coul(k,i,l,j) + ! AND IF(var_tc): + ! + ! ao_two_e_tot(k,i,l,j) = (ki|V^TC(r_12) + [(V^TC)(r_12)]^\dagger|lj) / 2.0 + ! = tc_grad_square_ao(k,i,l,j) + ao_two_e_coul(k,i,l,j) + ! + ! + ! where: + ! + ! tc_grad_and_lapl_ao(k,i,l,j) = < k l | -1/2 \Delta_1 u(r1,r2) - \grad_1 u(r1,r2) . \grad_1 | ij > + ! = -1/2 \int dr1 (phi_k(r1) \grad_r1 phi_i(r1) - phi_i(r1) \grad_r1 phi_k(r1)) . \int dr2 \grad_r1 u(r1,r2) \phi_l(r2) \phi_j(r2) + ! = 1/2 \int dr1 (phi_k(r1) \grad_r1 phi_i(r1) - phi_i(r1) \grad_r1 phi_k(r1)) . \int dr2 (-1) \grad_r1 u(r1,r2) \phi_l(r2) \phi_j(r2) + ! + ! tc_grad_square_ao(k,i,l,j) = -1/2 + ! + ! ao_two_e_coul(k,i,l,j) = < l k | 1/r12 | j i > = ( k i | 1/r12 | l j ) + ! + END_DOC + + implicit none + integer :: i, j, k, l, m, ipoint + double precision :: weight1, ao_k_r, ao_i_r + double precision :: der_envsq_x, der_envsq_y, der_envsq_z, lap_envsq + double precision :: time0, time1 + double precision, allocatable :: b_mat(:,:,:,:), c_mat(:,:,:) + double precision, external :: get_ao_two_e_integral + + PROVIDe tc_integ_type + PROVIDE env_type + PROVIDE j2e_type + PROVIDE j1e_type + + call wall_time(time0) + + print *, ' providing ao_two_e_tc_tot ...' + print*, ' j2e_type: ', j2e_type + print*, ' j1e_type: ', j1e_type + print*, ' env_type: ', env_type + + if(read_tc_integ) then + + print*, ' Reading ao_two_e_tc_tot from ', trim(ezfio_filename) // '/work/ao_two_e_tc_tot' + + open(unit=11, form="unformatted", file=trim(ezfio_filename)//'/work/ao_two_e_tc_tot', action="read") + read(11) ao_two_e_tc_tot + close(11) + + else + + PROVIDE tc_integ_type + print*, ' approach for integrals: ', tc_integ_type + + ! --- + + PROVIDE int2_grad1_u12_square_ao + + allocate(c_mat(n_points_final_grid,ao_num,ao_num)) + + !$OMP PARALLEL & + !$OMP DEFAULT (NONE) & + !$OMP PRIVATE (i, k, ipoint) & + !$OMP SHARED (aos_in_r_array_transp, c_mat, ao_num, n_points_final_grid, final_weight_at_r_vector) + !$OMP DO SCHEDULE (static) + do i = 1, ao_num + do k = 1, ao_num + do ipoint = 1, n_points_final_grid + c_mat(ipoint,k,i) = final_weight_at_r_vector(ipoint) * aos_in_r_array_transp(ipoint,i) * aos_in_r_array_transp(ipoint,k) + enddo + enddo + enddo + !$OMP END DO + !$OMP END PARALLEL + + call dgemm( "N", "N", ao_num*ao_num, ao_num*ao_num, n_points_final_grid, 1.d0 & + , int2_grad1_u12_square_ao(1,1,1), ao_num*ao_num, c_mat(1,1,1), n_points_final_grid & + , 0.d0, ao_two_e_tc_tot, ao_num*ao_num) + + FREE int2_grad1_u12_square_ao + + if( (tc_integ_type .eq. "semi-analytic") .and. & + (j2e_type .eq. "Mu") .and. & + ((env_type .eq. "Prod_Gauss") .or. (env_type .eq. "Sum_Gauss")) .and. & + use_ipp ) then + + ! an additional term is added here directly instead of + ! being added in int2_grad1_u12_square_ao for performance + + PROVIDE int2_u2_env2 + + !$OMP PARALLEL & + !$OMP DEFAULT (NONE) & + !$OMP PRIVATE (i, k, ipoint, weight1, ao_i_r, ao_k_r) & + !$OMP SHARED (aos_in_r_array_transp, c_mat, ao_num, n_points_final_grid, final_weight_at_r_vector, & + !$OMP env_square_grad, env_square_lapl, aos_grad_in_r_array_transp_bis) + !$OMP DO SCHEDULE (static) + do i = 1, ao_num + do k = 1, ao_num + do ipoint = 1, n_points_final_grid + + weight1 = 0.25d0 * final_weight_at_r_vector(ipoint) + + ao_i_r = aos_in_r_array_transp(ipoint,i) + ao_k_r = aos_in_r_array_transp(ipoint,k) + + c_mat(ipoint,k,i) = weight1 * ( ao_k_r * ao_i_r * env_square_lapl(ipoint) & + + (ao_k_r * aos_grad_in_r_array_transp_bis(ipoint,i,1) + ao_i_r * aos_grad_in_r_array_transp_bis(ipoint,k,1)) * env_square_grad(ipoint,1) & + + (ao_k_r * aos_grad_in_r_array_transp_bis(ipoint,i,2) + ao_i_r * aos_grad_in_r_array_transp_bis(ipoint,k,2)) * env_square_grad(ipoint,2) & + + (ao_k_r * aos_grad_in_r_array_transp_bis(ipoint,i,3) + ao_i_r * aos_grad_in_r_array_transp_bis(ipoint,k,3)) * env_square_grad(ipoint,3) ) + enddo + enddo + enddo + !$OMP END DO + !$OMP END PARALLEL + + call dgemm( "N", "N", ao_num*ao_num, ao_num*ao_num, n_points_final_grid, 1.d0 & + , int2_u2_env2(1,1,1), ao_num*ao_num, c_mat(1,1,1), n_points_final_grid & + , 1.d0, ao_two_e_tc_tot, ao_num*ao_num) + + FREE int2_u2_env2 + endif ! use_ipp + + deallocate(c_mat) + + ! --- + + if(.not. var_tc) then + + PROVIDE int2_grad1_u12_ao + + allocate(b_mat(n_points_final_grid,ao_num,ao_num,3)) + + !$OMP PARALLEL & + !$OMP DEFAULT (NONE) & + !$OMP PRIVATE (i, k, ipoint, weight1, ao_i_r, ao_k_r) & + !$OMP SHARED (aos_in_r_array_transp, aos_grad_in_r_array_transp_bis, b_mat, & + !$OMP ao_num, n_points_final_grid, final_weight_at_r_vector) + !$OMP DO SCHEDULE (static) + do i = 1, ao_num + do k = 1, ao_num + do ipoint = 1, n_points_final_grid + + weight1 = 0.5d0 * final_weight_at_r_vector(ipoint) + ao_i_r = aos_in_r_array_transp(ipoint,i) + ao_k_r = aos_in_r_array_transp(ipoint,k) + + b_mat(ipoint,k,i,1) = weight1 * (ao_k_r * aos_grad_in_r_array_transp_bis(ipoint,i,1) - ao_i_r * aos_grad_in_r_array_transp_bis(ipoint,k,1)) + b_mat(ipoint,k,i,2) = weight1 * (ao_k_r * aos_grad_in_r_array_transp_bis(ipoint,i,2) - ao_i_r * aos_grad_in_r_array_transp_bis(ipoint,k,2)) + b_mat(ipoint,k,i,3) = weight1 * (ao_k_r * aos_grad_in_r_array_transp_bis(ipoint,i,3) - ao_i_r * aos_grad_in_r_array_transp_bis(ipoint,k,3)) + enddo + enddo + enddo + !$OMP END DO + !$OMP END PARALLEL + + do m = 1, 3 + call dgemm( "N", "N", ao_num*ao_num, ao_num*ao_num, n_points_final_grid, -1.d0 & + , int2_grad1_u12_ao(1,1,1,m), ao_num*ao_num, b_mat(1,1,1,m), n_points_final_grid & + , 1.d0, ao_two_e_tc_tot, ao_num*ao_num) + enddo + deallocate(b_mat) + + FREE int2_grad1_u12_ao + FREE int2_grad1_u2e_ao + + endif ! var_tc + + ! --- + + call sum_A_At(ao_two_e_tc_tot(1,1,1,1), ao_num*ao_num) + + PROVIDE ao_integrals_map + + !$OMP PARALLEL DEFAULT(NONE) & + !$OMP SHARED(ao_num, ao_two_e_tc_tot, ao_integrals_map) & + !$OMP PRIVATE(i, j, k, l) + !$OMP DO + do j = 1, ao_num + do l = 1, ao_num + do i = 1, ao_num + do k = 1, ao_num + ! < 1:i, 2:j | 1:k, 2:l > + ao_two_e_tc_tot(k,i,l,j) = ao_two_e_tc_tot(k,i,l,j) + get_ao_two_e_integral(i, j, k, l, ao_integrals_map) + enddo + enddo + enddo + enddo + !$OMP END DO + !$OMP END PARALLEL + + if(tc_integ_type .eq. "numeric") then + FREE int2_grad1_u12_ao_num int2_grad1_u12_square_ao_num + endif + + endif ! read_tc_integ + + if(write_tc_integ .and. mpi_master) then + print*, ' Saving ao_two_e_tc_tot in ', trim(ezfio_filename) // '/work/ao_two_e_tc_tot' + open(unit=11, form="unformatted", file=trim(ezfio_filename)//'/work/ao_two_e_tc_tot', action="write") + call ezfio_set_work_empty(.False.) + write(11) ao_two_e_tc_tot + close(11) + call ezfio_set_tc_keywords_io_tc_integ('Read') + endif + + call wall_time(time1) + print*, ' Wall time for ao_two_e_tc_tot (min) = ', (time1 - time0) / 60.d0 + call print_memory_usage() + +END_PROVIDER + +! --- + diff --git a/src/non_hermit_dav/NEED b/plugins/local/non_hermit_dav/NEED similarity index 100% rename from src/non_hermit_dav/NEED rename to plugins/local/non_hermit_dav/NEED diff --git a/src/non_hermit_dav/biorthog.irp.f b/plugins/local/non_hermit_dav/biorthog.irp.f similarity index 88% rename from src/non_hermit_dav/biorthog.irp.f rename to plugins/local/non_hermit_dav/biorthog.irp.f index 78fddf54..2229e17d 100644 --- a/src/non_hermit_dav/biorthog.irp.f +++ b/plugins/local/non_hermit_dav/biorthog.irp.f @@ -142,7 +142,7 @@ subroutine non_hrmt_diag_split_degen(n, A, leigvec, reigvec, n_real_eigv, eigval enddo enddo -end subroutine non_hrmt_diag_split_degen +end ! --- @@ -248,7 +248,7 @@ subroutine non_hrmt_real_diag_new(n, A, leigvec, reigvec, n_real_eigv, eigval) print*,'Your matrix intrinsically contains complex eigenvalues' endif -end subroutine non_hrmt_real_diag_new +end ! --- @@ -270,14 +270,17 @@ subroutine non_hrmt_bieig(n, A, thr_d, thr_nd, leigvec, reigvec, n_real_eigv, ei integer, intent(out) :: n_real_eigv double precision, intent(out) :: reigvec(n,n), leigvec(n,n), eigval(n) - integer :: i, j + integer :: i, j,k integer :: n_good double precision :: thr, thr_cut, thr_diag, thr_norm double precision :: accu_d, accu_nd - integer, allocatable :: list_good(:), iorder(:) + integer, allocatable :: list_good(:), iorder(:), deg_num(:) double precision, allocatable :: WR(:), WI(:), VL(:,:), VR(:,:) double precision, allocatable :: S(:,:) + double precision, allocatable :: phi_1_tilde(:),phi_2_tilde(:),chi_1_tilde(:),chi_2_tilde(:) + + allocate(phi_1_tilde(n),phi_2_tilde(n),chi_1_tilde(n),chi_2_tilde(n)) ! ------------------------------------------------------------------------------------- @@ -301,11 +304,78 @@ subroutine non_hrmt_bieig(n, A, thr_d, thr_nd, leigvec, reigvec, n_real_eigv, ei call lapack_diag_non_sym(n, A, WR, WI, VL, VR) !call lapack_diag_non_sym_new(n, A, WR, WI, VL, VR) + + !print *, ' ' !print *, ' eigenvalues' - !do i = 1, n - ! write(*, '(1000(F16.10,X))') WR(i), WI(i) - !enddo + i = 1 + do while(i .le. n) + !write(*, '(I3,X,1000(F16.10,X))')i, WR(i), WI(i) + if(.false.)then + if(WI(i).ne.0.d0)then + print*,'*****************' + print*,'WARNING ! IMAGINARY EIGENVALUES !!!' + write(*, '(1000(F16.10,X))') WR(i), WI(i+1) + ! phi = VR(:,i), psi = VR(:,i+1), |Phi_i> = phi + j psi , |Phi_i+1> = phi - j psi + ! chi = VL(:,i), xhi = VL(:,i+1), |Chi_i> = chi + j xhi , |Chi_i+1> = chi - j xhi + ! + accu_chi_phi = 0.d0 + accu_xhi_psi = 0.d0 + accu_chi_psi = 0.d0 + accu_xhi_phi = 0.d0 + double precision :: accu_chi_phi, accu_xhi_psi, accu_chi_psi, accu_xhi_phi + double precision :: mat_ovlp(2,2),eigval_tmp(2),eigvec(2,2),mat_ovlp_orig(2,2) + do j = 1, n + accu_chi_phi += VL(j,i) * VR(j,i) + accu_xhi_psi += VL(j,i+1) * VR(j,i+1) + accu_chi_psi += VL(j,i) * VR(j,i+1) + accu_xhi_phi += VL(j,i+1) * VR(j,i) + enddo + mat_ovlp_orig(1,1) = accu_chi_phi + mat_ovlp_orig(2,1) = accu_xhi_phi + mat_ovlp_orig(1,2) = accu_chi_psi + mat_ovlp_orig(2,2) = accu_xhi_psi + print*,'old overlap matrix ' + write(*,'(100(F16.10,X))')mat_ovlp_orig(1:2,1) + write(*,'(100(F16.10,X))')mat_ovlp_orig(1:2,2) + + + mat_ovlp(1,1) = accu_xhi_phi + mat_ovlp(2,1) = accu_chi_phi + mat_ovlp(1,2) = accu_xhi_psi + mat_ovlp(2,2) = accu_chi_psi + !print*,'accu_chi_phi = ',accu_chi_phi + !print*,'accu_xhi_psi = ',accu_xhi_psi + !print*,'accu_chi_psi = ',accu_chi_psi + !print*,'accu_xhi_phi = ',accu_xhi_phi + print*,'new overlap matrix ' + write(*,'(100(F16.10,X))')mat_ovlp(1:2,1) + write(*,'(100(F16.10,X))')mat_ovlp(1:2,2) + call lapack_diag(eigval_tmp,eigvec,mat_ovlp,2,2) + print*,'eigval_tmp(1) = ',eigval_tmp(1) + print*,'eigvec(1) = ',eigvec(1:2,1) + print*,'eigval_tmp(2) = ',eigval_tmp(2) + print*,'eigvec(2) = ',eigvec(1:2,2) + print*,'*****************' + phi_1_tilde = 0.d0 + phi_2_tilde = 0.d0 + chi_1_tilde = 0.d0 + chi_2_tilde = 0.d0 + do j = 1, n + phi_1_tilde(j) += VR(j,i) * eigvec(1,1) + VR(j,i+1) * eigvec(2,1) + phi_2_tilde(j) += VR(j,i) * eigvec(1,2) + VR(j,i+1) * eigvec(2,2) + chi_1_tilde(j) += VL(j,i+1) * eigvec(1,1) + VL(j,i) * eigvec(2,1) + chi_2_tilde(j) += VL(j,i+1) * eigvec(1,2) + VL(j,i) * eigvec(2,2) + enddo + VR(1:n,i) = phi_1_tilde(1:n) + VR(1:n,i+1) = phi_2_tilde(1:n) +! Vl(1:n,i) = -chi_1_tilde(1:n) +! Vl(1:n,i+1) = chi_2_tilde(1:n) + i+=1 + endif + endif + i+=1 + enddo !print *, ' right eigenvect bef' !do i = 1, n ! write(*, '(1000(F16.10,X))') VR(:,i) @@ -317,7 +387,7 @@ subroutine non_hrmt_bieig(n, A, thr_d, thr_nd, leigvec, reigvec, n_real_eigv, ei thr_diag = 1d-06 thr_norm = 1d+10 - call check_EIGVEC(n, n, A, WR, VL, VR, thr_diag, thr_norm, .false.) + !call check_EIGVEC(n, n, A, WR, VL, VR, thr_diag, thr_norm, .false.) ! ! ------------------------------------------------------------------------------------- @@ -405,38 +475,32 @@ subroutine non_hrmt_bieig(n, A, thr_d, thr_nd, leigvec, reigvec, n_real_eigv, ei if( (accu_nd .lt. thr_nd) .and. (dabs(accu_d-dble(n_real_eigv))/dble(n_real_eigv) .lt. thr_d) ) then - !print *, ' lapack vectors are normalized and bi-orthogonalized' + print *, ' lapack vectors are normalized and bi-orthogonalized' deallocate(S) return ! accu_nd is modified after adding the normalization - !elseif( (accu_nd .lt. thr_nd) .and. (dabs(accu_d-dble(n_real_eigv))/dble(n_real_eigv) .gt. thr_d) ) then + elseif( (accu_nd .lt. thr_nd) .and. (dabs(accu_d-dble(n_real_eigv))/dble(n_real_eigv) .gt. thr_d) ) then - ! print *, ' lapack vectors are not normalized but bi-orthogonalized' - ! call check_biorthog_binormalize(n, n_real_eigv, leigvec, reigvec, thr_d, thr_nd, .true.) + print *, ' lapack vectors are not normalized but bi-orthogonalized' + call check_biorthog_binormalize(n, n_real_eigv, leigvec, reigvec, thr_d, thr_nd, .true.) - ! call check_EIGVEC(n, n, A, eigval, leigvec, reigvec, thr_diag, thr_norm, .true.) + call check_biorthog(n, n_real_eigv, leigvec, reigvec, accu_d, accu_nd, S, thr_d, thr_nd, .true.) + call check_EIGVEC(n, n, A, eigval, leigvec, reigvec, thr_diag, thr_norm, .true.) - ! deallocate(S) - ! return + deallocate(S) + return else - !print *, ' lapack vectors are not normalized neither bi-orthogonalized' + print *, ' lapack vectors are not normalized neither bi-orthogonalized' ! --- -! call impose_orthog_degen_eigvec(n, eigval, reigvec) -! call impose_orthog_degen_eigvec(n, eigval, leigvec) - - call impose_biorthog_degen_eigvec(n, eigval, leigvec, reigvec) - - - !call impose_orthog_biorthog_degen_eigvec(n, thr_d, thr_nd, eigval, leigvec, reigvec) - - !call impose_unique_biorthog_degen_eigvec(n, eigval, mo_coef, ao_overlap, leigvec, reigvec) - - ! --- + allocate(deg_num(n)) + call reorder_degen_eigvec(n, deg_num, eigval, leigvec, reigvec) + call impose_biorthog_degen_eigvec(n, deg_num, eigval, leigvec, reigvec) + deallocate(deg_num) call check_biorthog(n, n_real_eigv, leigvec, reigvec, accu_d, accu_nd, S, thr_d, thr_nd, .false.) if( (accu_nd .lt. thr_nd) .and. (dabs(accu_d-dble(n_real_eigv)) .gt. thr_d) ) then @@ -444,12 +508,7 @@ subroutine non_hrmt_bieig(n, A, thr_d, thr_nd, leigvec, reigvec, n_real_eigv, ei endif call check_biorthog(n, n_real_eigv, leigvec, reigvec, accu_d, accu_nd, S, thr_d, thr_nd, .true.) - !call impose_biorthog_qr(n, n_real_eigv, thr_d, thr_nd, leigvec, reigvec) - !call impose_biorthog_lu(n, n_real_eigv, thr_d, thr_nd, leigvec, reigvec) - - ! --- - - call check_EIGVEC(n, n, A, eigval, leigvec, reigvec, thr_diag, thr_norm, .true.) + !call check_EIGVEC(n, n, A, eigval, leigvec, reigvec, thr_diag, thr_norm, .true.) deallocate(S) @@ -460,7 +519,7 @@ subroutine non_hrmt_bieig(n, A, thr_d, thr_nd, leigvec, reigvec, n_real_eigv, ei return -end subroutine non_hrmt_bieig +end ! --- @@ -633,7 +692,7 @@ subroutine non_hrmt_bieig_random_diag(n, A, leigvec, reigvec, n_real_eigv, eigva return -end subroutine non_hrmt_bieig_random_diag +end ! --- @@ -742,7 +801,7 @@ subroutine non_hrmt_real_im(n, A, leigvec, reigvec, n_real_eigv, eigval) deallocate( S ) -end subroutine non_hrmt_real_im +end ! --- @@ -847,7 +906,7 @@ subroutine non_hrmt_generalized_real_im(n, A, B, leigvec, reigvec, n_real_eigv, deallocate( S ) -end subroutine non_hrmt_generalized_real_im +end ! --- @@ -983,7 +1042,7 @@ subroutine non_hrmt_bieig_fullvect(n, A, leigvec, reigvec, n_real_eigv, eigval) return -end subroutine non_hrmt_bieig_fullvect +end ! --- diff --git a/src/non_hermit_dav/gram_schmit.irp.f b/plugins/local/non_hermit_dav/gram_schmit.irp.f similarity index 100% rename from src/non_hermit_dav/gram_schmit.irp.f rename to plugins/local/non_hermit_dav/gram_schmit.irp.f diff --git a/src/non_hermit_dav/htilde_mat.irp.f b/plugins/local/non_hermit_dav/htilde_mat.irp.f similarity index 100% rename from src/non_hermit_dav/htilde_mat.irp.f rename to plugins/local/non_hermit_dav/htilde_mat.irp.f diff --git a/src/non_hermit_dav/lapack_diag_non_hermit.irp.f b/plugins/local/non_hermit_dav/lapack_diag_non_hermit.irp.f similarity index 92% rename from src/non_hermit_dav/lapack_diag_non_hermit.irp.f rename to plugins/local/non_hermit_dav/lapack_diag_non_hermit.irp.f index 0d652af4..cb38347e 100644 --- a/src/non_hermit_dav/lapack_diag_non_hermit.irp.f +++ b/plugins/local/non_hermit_dav/lapack_diag_non_hermit.irp.f @@ -54,7 +54,7 @@ subroutine lapack_diag_non_sym(n, A, WR, WI, VL, VR) deallocate(Atmp, WORK) -end subroutine lapack_diag_non_sym +end subroutine non_sym_diag_inv_right(n,A,leigvec,reigvec,n_real_eigv,eigval) @@ -269,7 +269,7 @@ subroutine lapack_diag_non_sym_new(n, A, WR, WI, VL, VR) deallocate( Atmp ) deallocate( WORK, SCALE_array, RCONDE, RCONDV, IWORK ) -end subroutine lapack_diag_non_sym_new +end ! --- @@ -323,7 +323,7 @@ subroutine lapack_diag_non_sym_right(n, A, WR, WI, VR) ! write(*, '(1000(F16.10,X))') VR(:,i) ! enddo -end subroutine lapack_diag_non_sym_right +end ! --- @@ -437,7 +437,7 @@ subroutine non_hrmt_real_diag(n, A, leigvec, reigvec, n_real_eigv, eigval) print*, ' Notice that if you are interested in ground state it is not a problem :)' endif -end subroutine non_hrmt_real_diag +end ! --- @@ -495,7 +495,7 @@ subroutine lapack_diag_general_non_sym(n, A, B, WR, WI, VL, VR) deallocate( WORK, Atmp ) -end subroutine lapack_diag_general_non_sym +end ! --- @@ -570,7 +570,7 @@ subroutine non_hrmt_general_real_diag(n, A, B, reigvec, leigvec, n_real_eigv, ei enddo enddo -end subroutine non_hrmt_general_real_diag +end ! --- @@ -727,7 +727,7 @@ subroutine impose_biorthog_qr(m, n, thr_d, thr_nd, Vl, Vr) deallocate(tmp) return -end subroutine impose_biorthog_qr +end ! --- @@ -890,7 +890,7 @@ subroutine impose_biorthog_lu(m, n, Vl, Vr, S) !stop return -end subroutine impose_biorthog_lu +end ! --- @@ -996,7 +996,7 @@ subroutine check_EIGVEC(n, m, A, eigval, leigvec, reigvec, thr_diag, thr_norm, s deallocate( Mtmp ) -end subroutine check_EIGVEC +end ! --- @@ -1066,7 +1066,7 @@ subroutine check_degen(n, m, eigval, leigvec, reigvec) stop endif -end subroutine check_degen +end ! --- @@ -1169,7 +1169,7 @@ subroutine impose_weighted_orthog_svd(n, m, W, C) ! --- -end subroutine impose_weighted_orthog_svd +end ! --- @@ -1266,7 +1266,7 @@ subroutine impose_orthog_svd(n, m, C) ! --- -end subroutine impose_orthog_svd +end ! --- @@ -1365,7 +1365,7 @@ subroutine impose_orthog_svd_overlap(n, m, C, overlap) !enddo deallocate(S) -end subroutine impose_orthog_svd_overlap +end ! --- @@ -1442,7 +1442,7 @@ subroutine impose_orthog_GramSchmidt(n, m, C) ! --- -end subroutine impose_orthog_GramSchmidt +end ! --- @@ -1484,7 +1484,7 @@ subroutine impose_orthog_ones(n, deg_num, C) endif enddo -end subroutine impose_orthog_ones +end ! --- @@ -1577,7 +1577,7 @@ subroutine impose_orthog_degen_eigvec(n, e0, C0) endif enddo -end subroutine impose_orthog_degen_eigvec +end ! --- @@ -1661,7 +1661,7 @@ subroutine get_halfinv_svd(n, S) deallocate(S0, Stmp, Stmp2) -end subroutine get_halfinv_svd +end ! --- @@ -1776,7 +1776,7 @@ subroutine check_biorthog_binormalize(n, m, Vl, Vr, thr_d, thr_nd, stop_ifnot) stop endif -end subroutine check_biorthog_binormalize +end ! --- @@ -1840,7 +1840,7 @@ subroutine check_weighted_biorthog(n, m, W, Vl, Vr, thr_d, thr_nd, accu_d, accu_ stop endif -end subroutine check_weighted_biorthog +end ! --- @@ -1857,7 +1857,7 @@ subroutine check_biorthog(n, m, Vl, Vr, accu_d, accu_nd, S, thr_d, thr_nd, stop_ integer :: i, j double precision, allocatable :: SS(:,:) - !print *, ' check bi-orthogonality' + print *, ' check bi-orthogonality' ! --- @@ -1865,6 +1865,7 @@ subroutine check_biorthog(n, m, Vl, Vr, accu_d, accu_nd, S, thr_d, thr_nd, stop_ , Vl, size(Vl, 1), Vr, size(Vr, 1) & , 0.d0, S, size(S, 1) ) + ! print S s'il y a besoin !print *, ' overlap matrix:' !do i = 1, m ! write(*,'(1000(F16.10,X))') S(i,:) @@ -1876,15 +1877,22 @@ subroutine check_biorthog(n, m, Vl, Vr, accu_d, accu_nd, S, thr_d, thr_nd, stop_ do j = 1, m if(i==j) then accu_d = accu_d + dabs(S(i,i)) + !print*, i, S(i,i) else accu_nd = accu_nd + S(j,i) * S(j,i) endif enddo enddo + !accu_nd = dsqrt(accu_nd) / dble(m*m) accu_nd = dsqrt(accu_nd) / dble(m) - !print *, ' accu_nd = ', accu_nd - !print *, ' accu_d = ', dabs(accu_d-dble(m))/dble(m) + if((accu_nd .gt. thr_nd) .or. dabs(accu_d-dble(m))/dble(m) .gt. thr_d) then + print *, ' non bi-orthogonal vectors !' + print *, ' accu_nd = ', accu_nd + print *, ' accu_d = ', dabs(accu_d-dble(m))/dble(m) + else + print *, ' vectors are bi-orthogonals' + endif ! --- @@ -1899,7 +1907,7 @@ subroutine check_biorthog(n, m, Vl, Vr, accu_d, accu_nd, S, thr_d, thr_nd, stop_ stop endif -end subroutine check_biorthog +end ! --- @@ -1941,28 +1949,25 @@ subroutine check_orthog(n, m, V, accu_d, accu_nd, S) !print*, ' diag acc: ', accu_d !print*, ' nondiag acc: ', accu_nd -end subroutine check_orthog +end ! --- -subroutine impose_biorthog_degen_eigvec(n, e0, L0, R0) +subroutine reorder_degen_eigvec(n, deg_num, e0, L0, R0) implicit none integer, intent(in) :: n - double precision, intent(in) :: e0(n) - double precision, intent(inout) :: L0(n,n), R0(n,n) + double precision, intent(inout) :: e0(n), L0(n,n), R0(n,n) + integer, intent(out) :: deg_num(n) logical :: complex_root - integer :: i, j, k, m + integer :: i, j, k, m, ii, j_tmp double precision :: ei, ej, de, de_thr double precision :: accu_d, accu_nd - integer, allocatable :: deg_num(:) + double precision :: e0_tmp, L0_tmp(n), R0_tmp(n) double precision, allocatable :: L(:,:), R(:,:), S(:,:), S_inv_half(:,:) - ! --- - - allocate( deg_num(n) ) do i = 1, n deg_num(i) = 1 enddo @@ -1973,20 +1978,113 @@ subroutine impose_biorthog_degen_eigvec(n, e0, L0, R0) ei = e0(i) ! already considered in degen vectors - if(deg_num(i).eq.0) cycle + if(deg_num(i) .eq. 0) cycle + ii = 0 do j = i+1, n ej = e0(j) de = dabs(ei - ej) if(de .lt. de_thr) then - deg_num(i) = deg_num(i) + 1 - deg_num(j) = 0 - endif + ii = ii + 1 + + j_tmp = i + ii + deg_num(j_tmp) = 0 + + e0_tmp = e0(j_tmp) + e0(j_tmp) = e0(j) + e0(j) = e0_tmp + + L0_tmp(1:n) = L0(1:n,j_tmp) + L0(1:n,j_tmp) = L0(1:n,j) + L0(1:n,j) = L0_tmp(1:n) + + R0_tmp(1:n) = R0(1:n,j_tmp) + R0(1:n,j_tmp) = R0(1:n,j) + R0(1:n,j) = R0_tmp(1:n) + endif enddo + + deg_num(i) = ii + 1 enddo + ii = 0 + do i = 1, n + if(deg_num(i) .gt. 1) then + !print *, ' degen on', i, deg_num(i), e0(i) + ii = ii + 1 + endif + enddo + + if(ii .eq. 0) then + print*, ' WARNING: bi-orthogonality is lost but there is no degeneracies' + print*, ' rotations may change energy' + stop + endif + + print *, ii, ' type of degeneracies' + + ! --- + +! do i = 1, n +! m = deg_num(i) +! +! if(m .gt. 1) then +! +! allocate(L(n,m)) +! allocate(R(n,m),S(m,m)) +! +! do j = 1, m +! L(1:n,j) = L0(1:n,i+j-1) +! R(1:n,j) = R0(1:n,i+j-1) +! enddo +! +! !call dgemm( 'T', 'N', m, m, n, 1.d0 & +! ! , L, size(L, 1), R, size(R, 1) & +! ! , 0.d0, S, size(S, 1) ) +! !print*, 'Overlap matrix ' +! !accu_nd = 0.d0 +! !do j = 1, m +! ! write(*,'(100(F16.10,X))') S(1:m,j) +! ! do k = 1, m +! ! if(j==k) cycle +! ! accu_nd += dabs(S(j,k)) +! ! enddo +! !enddo +! !print*,'accu_nd = ',accu_nd +!! if(accu_nd .gt.1.d-10) then +!! stop +!! endif +! +! do j = 1, m +! L0(1:n,i+j-1) = L(1:n,j) +! R0(1:n,i+j-1) = R(1:n,j) +! enddo +! +! deallocate(L, R, S) +! +! endif +! enddo +! +end + +! --- + +subroutine impose_biorthog_degen_eigvec(n, deg_num, e0, L0, R0) + + implicit none + + integer, intent(in) :: n, deg_num(n) + double precision, intent(in) :: e0(n) + double precision, intent(inout) :: L0(n,n), R0(n,n) + + logical :: complex_root + integer :: i, j, k, m + double precision :: ei, ej, de, de_thr + double precision :: accu_d, accu_nd + double precision, allocatable :: L(:,:), R(:,:), S(:,:), S_inv_half(:,:) + !do i = 1, n ! if(deg_num(i) .gt. 1) then ! print *, ' degen on', i, deg_num(i), e0(i) @@ -2000,8 +2098,7 @@ subroutine impose_biorthog_degen_eigvec(n, e0, L0, R0) if(m .gt. 1) then - allocate(L(n,m)) - allocate(R(n,m)) + allocate(L(n,m), R(n,m), S(m,m)) do j = 1, m L(1:n,j) = L0(1:n,i+j-1) @@ -2010,8 +2107,53 @@ subroutine impose_biorthog_degen_eigvec(n, e0, L0, R0) ! --- - call impose_orthog_svd(n, m, L) - call impose_orthog_svd(n, m, R) + !print*, 'Overlap matrix before' + call dgemm( 'T', 'N', m, m, n, 1.d0 & + , L, size(L, 1), R, size(R, 1) & + , 0.d0, S, size(S, 1) ) + + accu_nd = 0.d0 + do j = 1, m + !write(*,'(100(F16.10,X))') S(1:m,j) + do k = 1, m + if(j==k) cycle + accu_nd += dabs(S(j,k)) + enddo + enddo + + if(accu_nd .lt. 1d-12) then + deallocate(S, L, R) + cycle + endif + + !print*, ' accu_nd before = ', accu_nd + + call impose_biorthog_svd(n, m, L, R) + + !print*, 'Overlap matrix after' + call dgemm( 'T', 'N', m, m, n, 1.d0 & + , L, size(L, 1), R, size(R, 1) & + , 0.d0, S, size(S, 1) ) + accu_nd = 0.d0 + do j = 1, m + !write(*,'(100(F16.10,X))') S(1:m,j) + do k = 1, m + if(j==k) cycle + accu_nd += dabs(S(j,k)) + enddo + enddo + !print*,' accu_nd after = ', accu_nd + if(accu_nd .gt. 1d-12) then + print*, ' your strategy for degenerates orbitals failed !' + print*, m, 'deg on', i + stop + endif + + deallocate(S) + + ! --- + + !call impose_orthog_svd(n, m, L) !call impose_orthog_GramSchmidt(n, m, L) !call impose_orthog_GramSchmidt(n, m, R) @@ -2030,7 +2172,7 @@ subroutine impose_biorthog_degen_eigvec(n, e0, L0, R0) !call bi_ortho_s_inv_half(m, L, R, S_inv_half) !deallocate(S, S_inv_half) - call impose_biorthog_svd(n, m, L, R) + !call impose_biorthog_inverse(n, m, L, R) !call impose_biorthog_qr(n, m, thr_d, thr_nd, L, R) @@ -2046,7 +2188,7 @@ subroutine impose_biorthog_degen_eigvec(n, e0, L0, R0) endif enddo -end subroutine impose_biorthog_degen_eigvec +end ! --- @@ -2140,7 +2282,7 @@ subroutine impose_orthog_biorthog_degen_eigvec(n, thr_d, thr_nd, e0, L0, R0) endif enddo -end subroutine impose_orthog_biorthog_degen_eigvec +end ! --- @@ -2278,7 +2420,7 @@ subroutine impose_unique_biorthog_degen_eigvec(n, thr_d, thr_nd, e0, C0, W0, L0, endif enddo -end subroutine impose_unique_biorthog_degen_eigvec +end ! --- @@ -2361,7 +2503,7 @@ subroutine max_overlap_qr(m, n, S0, V) ! --- return -end subroutine max_overlap_qr +end ! --- @@ -2396,7 +2538,7 @@ subroutine max_overlap_invprod(n, m, S, V) deallocate(tmp, invS) return -end subroutine max_overlap_invprod +end ! --- @@ -2412,8 +2554,6 @@ subroutine impose_biorthog_svd(n, m, L, R) double precision, allocatable :: S(:,:), tmp(:,:) double precision, allocatable :: U(:,:), V(:,:), Vt(:,:), D(:) - ! --- - allocate(S(m,m)) call dgemm( 'T', 'N', m, m, n, 1.d0 & @@ -2460,51 +2600,75 @@ subroutine impose_biorthog_svd(n, m, L, R) ! --- + ! R <-- R x V x D^{-0.5} + ! L <-- L x U x D^{-0.5} + + do i = 1, m + do j = 1, m + V(j,i) = V(j,i) * D(i) + U(j,i) = U(j,i) * D(i) + enddo + enddo + allocate(tmp(n,m)) + tmp(:,:) = R(:,:) + call dgemm( 'N', 'N', n, m, m, 1.d0 & + , tmp, size(tmp, 1), V, size(V, 1) & + , 0.d0, R, size(R, 1)) - ! tmp <-- R x V - call dgemm( 'N', 'N', n, m, m, 1.d0 & - , R, size(R, 1), V, size(V, 1) & - , 0.d0, tmp, size(tmp, 1) ) - deallocate(V) - ! R <-- tmp x sigma^-0.5 - do j = 1, m - do i = 1, n - R(i,j) = tmp(i,j) * D(j) - enddo - enddo + tmp(:,:) = L(:,:) + call dgemm( 'N', 'N', n, m, m, 1.d0 & + , tmp, size(tmp, 1), U, size(U, 1) & + , 0.d0, L, size(L, 1)) - ! tmp <-- L x U - call dgemm( 'N', 'N', n, m, m, 1.d0 & - , L, size(L, 1), U, size(U, 1) & - , 0.d0, tmp, size(tmp, 1) ) - deallocate(U) - ! L <-- tmp x sigma^-0.5 - do j = 1, m - do i = 1, n - L(i,j) = tmp(i,j) * D(j) - enddo - enddo + deallocate(tmp, U, V, D) - deallocate(D, tmp) +end - ! --- +! --- +subroutine impose_biorthog_inverse(n, m, L, R) + + implicit none + + integer, intent(in) :: n, m + double precision, intent(inout) :: L(n,m) + double precision, intent(in) :: R(n,m) + double precision, allocatable :: Lt(:,:),S(:,:) + integer :: i,j + allocate(Lt(m,n)) allocate(S(m,m)) + call dgemm( 'T', 'N', m, m, n, 1.d0 & , L, size(L, 1), R, size(R, 1) & , 0.d0, S, size(S, 1) ) - !print *, ' overlap aft SVD: ' - !do i = 1, m - ! write(*, '(1000(F16.10,X))') S(i,:) - !enddo - - deallocate(S) + print *, ' overlap bef SVD: ' + do i = 1, m + write(*, '(1000(F16.10,X))') S(i,:) + enddo + call get_pseudo_inverse(R,n,n,m,Lt,m,1.d-6) + do i = 1, m + do j = 1, n + L(j,i) = Lt(i,j) + enddo + enddo ! --- -end subroutine impose_biorthog_svd + call dgemm( 'T', 'N', m, m, n, 1.d0 & + , L, size(L, 1), R, size(R, 1) & + , 0.d0, S, size(S, 1) ) + + print *, ' overlap aft SVD: ' + do i = 1, m + write(*, '(1000(F16.10,X))') S(i,:) + enddo + + deallocate(S,Lt) + + +end ! --- @@ -2666,7 +2830,7 @@ subroutine impose_weighted_biorthog_qr(m, n, thr_d, thr_nd, Vl, W, Vr) call check_weighted_biorthog_binormalize(m, n, Vl, W, Vr, thr_d, thr_nd, .false.) return -end subroutine impose_weighted_biorthog_qr +end ! --- @@ -2783,7 +2947,7 @@ subroutine check_weighted_biorthog_binormalize(n, m, Vl, W, Vr, thr_d, thr_nd, s stop endif -end subroutine check_weighted_biorthog_binormalize +end ! --- @@ -2901,7 +3065,7 @@ subroutine impose_weighted_biorthog_svd(n, m, overlap, L, R) deallocate(S) return -end subroutine impose_weighted_biorthog_svd +end ! --- diff --git a/src/non_hermit_dav/new_routines.irp.f b/plugins/local/non_hermit_dav/new_routines.irp.f similarity index 100% rename from src/non_hermit_dav/new_routines.irp.f rename to plugins/local/non_hermit_dav/new_routines.irp.f diff --git a/src/non_hermit_dav/project.irp.f b/plugins/local/non_hermit_dav/project.irp.f similarity index 100% rename from src/non_hermit_dav/project.irp.f rename to plugins/local/non_hermit_dav/project.irp.f diff --git a/src/non_hermit_dav/utils.irp.f b/plugins/local/non_hermit_dav/utils.irp.f similarity index 100% rename from src/non_hermit_dav/utils.irp.f rename to plugins/local/non_hermit_dav/utils.irp.f diff --git a/src/ortho_three_e_ints/NEED b/plugins/local/ortho_three_e_ints/NEED similarity index 100% rename from src/ortho_three_e_ints/NEED rename to plugins/local/ortho_three_e_ints/NEED diff --git a/src/ortho_three_e_ints/io_6_index_tensor.irp.f b/plugins/local/ortho_three_e_ints/io_6_index_tensor.irp.f similarity index 100% rename from src/ortho_three_e_ints/io_6_index_tensor.irp.f rename to plugins/local/ortho_three_e_ints/io_6_index_tensor.irp.f diff --git a/src/ortho_three_e_ints/mu_j_ints_usual_mos.irp.f b/plugins/local/ortho_three_e_ints/mu_j_ints_usual_mos.irp.f similarity index 100% rename from src/ortho_three_e_ints/mu_j_ints_usual_mos.irp.f rename to plugins/local/ortho_three_e_ints/mu_j_ints_usual_mos.irp.f diff --git a/src/qmckl/LIB b/plugins/local/qmckl/LIB similarity index 100% rename from src/qmckl/LIB rename to plugins/local/qmckl/LIB diff --git a/src/qmckl/NEED b/plugins/local/qmckl/NEED similarity index 100% rename from src/qmckl/NEED rename to plugins/local/qmckl/NEED diff --git a/src/qmckl/README.md b/plugins/local/qmckl/README.md similarity index 100% rename from src/qmckl/README.md rename to plugins/local/qmckl/README.md diff --git a/src/qmckl/qmckl.F90 b/plugins/local/qmckl/qmckl.F90 similarity index 100% rename from src/qmckl/qmckl.F90 rename to plugins/local/qmckl/qmckl.F90 diff --git a/src/tc_bi_ortho/31.tc_bi_ortho.bats b/plugins/local/tc_bi_ortho/31.tc_bi_ortho.bats similarity index 100% rename from src/tc_bi_ortho/31.tc_bi_ortho.bats rename to plugins/local/tc_bi_ortho/31.tc_bi_ortho.bats diff --git a/src/tc_bi_ortho/EZFIO.cfg b/plugins/local/tc_bi_ortho/EZFIO.cfg similarity index 100% rename from src/tc_bi_ortho/EZFIO.cfg rename to plugins/local/tc_bi_ortho/EZFIO.cfg diff --git a/src/tc_bi_ortho/NEED b/plugins/local/tc_bi_ortho/NEED similarity index 100% rename from src/tc_bi_ortho/NEED rename to plugins/local/tc_bi_ortho/NEED diff --git a/src/tc_bi_ortho/compute_deltamu_right.irp.f b/plugins/local/tc_bi_ortho/compute_deltamu_right.irp.f similarity index 91% rename from src/tc_bi_ortho/compute_deltamu_right.irp.f rename to plugins/local/tc_bi_ortho/compute_deltamu_right.irp.f index ab9dc093..1142658d 100644 --- a/src/tc_bi_ortho/compute_deltamu_right.irp.f +++ b/plugins/local/tc_bi_ortho/compute_deltamu_right.irp.f @@ -24,10 +24,6 @@ subroutine delta_right() integer :: k double precision, allocatable :: delta(:,:) - print *, j1b_type - print *, j1b_pen - print *, mu_erf - allocate( delta(N_det,N_states) ) delta = 0.d0 @@ -48,7 +44,7 @@ subroutine delta_right() deallocate(delta) return -end subroutine delta_right +end ! --- diff --git a/src/tc_bi_ortho/dav_h_tc_s2.irp.f b/plugins/local/tc_bi_ortho/dav_h_tc_s2.irp.f similarity index 100% rename from src/tc_bi_ortho/dav_h_tc_s2.irp.f rename to plugins/local/tc_bi_ortho/dav_h_tc_s2.irp.f diff --git a/src/tc_bi_ortho/dressing_vectors_lr.irp.f b/plugins/local/tc_bi_ortho/dressing_vectors_lr.irp.f similarity index 100% rename from src/tc_bi_ortho/dressing_vectors_lr.irp.f rename to plugins/local/tc_bi_ortho/dressing_vectors_lr.irp.f diff --git a/src/tc_bi_ortho/e_corr_bi_ortho.irp.f b/plugins/local/tc_bi_ortho/e_corr_bi_ortho.irp.f similarity index 100% rename from src/tc_bi_ortho/e_corr_bi_ortho.irp.f rename to plugins/local/tc_bi_ortho/e_corr_bi_ortho.irp.f diff --git a/src/tc_bi_ortho/h_biortho.irp.f b/plugins/local/tc_bi_ortho/h_biortho.irp.f similarity index 100% rename from src/tc_bi_ortho/h_biortho.irp.f rename to plugins/local/tc_bi_ortho/h_biortho.irp.f diff --git a/src/tc_bi_ortho/h_mat_triple.irp.f b/plugins/local/tc_bi_ortho/h_mat_triple.irp.f similarity index 99% rename from src/tc_bi_ortho/h_mat_triple.irp.f rename to plugins/local/tc_bi_ortho/h_mat_triple.irp.f index 4c8c107a..6f5697a2 100644 --- a/src/tc_bi_ortho/h_mat_triple.irp.f +++ b/plugins/local/tc_bi_ortho/h_mat_triple.irp.f @@ -325,7 +325,7 @@ end subroutine triple_htilde_mu_mat_fock_bi_ortho(Nint, key_j, key_i, hmono, htwoe, hthree, htot) use bitmasks BEGIN_DOC -! for triple excitation +! for triple excitation !! !! WARNING !! ! diff --git a/src/tc_bi_ortho/h_tc_bi_ortho_psi.irp.f b/plugins/local/tc_bi_ortho/h_tc_bi_ortho_psi.irp.f similarity index 100% rename from src/tc_bi_ortho/h_tc_bi_ortho_psi.irp.f rename to plugins/local/tc_bi_ortho/h_tc_bi_ortho_psi.irp.f diff --git a/src/tc_bi_ortho/h_tc_s2_u0.irp.f b/plugins/local/tc_bi_ortho/h_tc_s2_u0.irp.f similarity index 100% rename from src/tc_bi_ortho/h_tc_s2_u0.irp.f rename to plugins/local/tc_bi_ortho/h_tc_s2_u0.irp.f diff --git a/src/tc_bi_ortho/h_tc_u0.irp.f b/plugins/local/tc_bi_ortho/h_tc_u0.irp.f similarity index 100% rename from src/tc_bi_ortho/h_tc_u0.irp.f rename to plugins/local/tc_bi_ortho/h_tc_u0.irp.f diff --git a/src/tc_bi_ortho/normal_ordered.irp.f b/plugins/local/tc_bi_ortho/normal_ordered.irp.f similarity index 100% rename from src/tc_bi_ortho/normal_ordered.irp.f rename to plugins/local/tc_bi_ortho/normal_ordered.irp.f diff --git a/src/tc_bi_ortho/normal_ordered_contractions.irp.f b/plugins/local/tc_bi_ortho/normal_ordered_contractions.irp.f similarity index 100% rename from src/tc_bi_ortho/normal_ordered_contractions.irp.f rename to plugins/local/tc_bi_ortho/normal_ordered_contractions.irp.f diff --git a/src/tc_bi_ortho/normal_ordered_old.irp.f b/plugins/local/tc_bi_ortho/normal_ordered_old.irp.f similarity index 100% rename from src/tc_bi_ortho/normal_ordered_old.irp.f rename to plugins/local/tc_bi_ortho/normal_ordered_old.irp.f diff --git a/src/tc_bi_ortho/normal_ordered_v0.irp.f b/plugins/local/tc_bi_ortho/normal_ordered_v0.irp.f similarity index 100% rename from src/tc_bi_ortho/normal_ordered_v0.irp.f rename to plugins/local/tc_bi_ortho/normal_ordered_v0.irp.f diff --git a/src/tc_bi_ortho/print_he_tc_energy.irp.f b/plugins/local/tc_bi_ortho/print_he_tc_energy.irp.f similarity index 100% rename from src/tc_bi_ortho/print_he_tc_energy.irp.f rename to plugins/local/tc_bi_ortho/print_he_tc_energy.irp.f diff --git a/src/tc_bi_ortho/print_tc_dump.irp.f b/plugins/local/tc_bi_ortho/print_tc_dump.irp.f similarity index 100% rename from src/tc_bi_ortho/print_tc_dump.irp.f rename to plugins/local/tc_bi_ortho/print_tc_dump.irp.f diff --git a/src/tc_bi_ortho/print_tc_energy.irp.f b/plugins/local/tc_bi_ortho/print_tc_energy.irp.f similarity index 69% rename from src/tc_bi_ortho/print_tc_energy.irp.f rename to plugins/local/tc_bi_ortho/print_tc_energy.irp.f index 7bca72a1..ef38cbcc 100644 --- a/src/tc_bi_ortho/print_tc_energy.irp.f +++ b/plugins/local/tc_bi_ortho/print_tc_energy.irp.f @@ -17,8 +17,14 @@ program print_tc_energy read_wf = .True. touch read_wf - PROVIDE j1b_type - print*, 'j1b_type = ', j1b_type + + PROVIDE j2e_type + PROVIDE j1e_type + PROVIDE env_type + + print *, ' j2e_type = ', j2e_type + print *, ' j1e_type = ', j1e_type + print *, ' env_type = ', env_type call write_tc_energy() diff --git a/src/tc_bi_ortho/print_tc_spin_dens.irp.f b/plugins/local/tc_bi_ortho/print_tc_spin_dens.irp.f similarity index 100% rename from src/tc_bi_ortho/print_tc_spin_dens.irp.f rename to plugins/local/tc_bi_ortho/print_tc_spin_dens.irp.f diff --git a/src/tc_bi_ortho/print_tc_var.irp.f b/plugins/local/tc_bi_ortho/print_tc_var.irp.f similarity index 100% rename from src/tc_bi_ortho/print_tc_var.irp.f rename to plugins/local/tc_bi_ortho/print_tc_var.irp.f diff --git a/src/tc_bi_ortho/print_tc_wf.irp.f b/plugins/local/tc_bi_ortho/print_tc_wf.irp.f similarity index 100% rename from src/tc_bi_ortho/print_tc_wf.irp.f rename to plugins/local/tc_bi_ortho/print_tc_wf.irp.f diff --git a/src/tc_bi_ortho/psi_det_tc_sorted.irp.f b/plugins/local/tc_bi_ortho/psi_det_tc_sorted.irp.f similarity index 100% rename from src/tc_bi_ortho/psi_det_tc_sorted.irp.f rename to plugins/local/tc_bi_ortho/psi_det_tc_sorted.irp.f diff --git a/src/tc_bi_ortho/psi_left_qmc.irp.f b/plugins/local/tc_bi_ortho/psi_left_qmc.irp.f similarity index 100% rename from src/tc_bi_ortho/psi_left_qmc.irp.f rename to plugins/local/tc_bi_ortho/psi_left_qmc.irp.f diff --git a/src/tc_bi_ortho/psi_r_l_prov.irp.f b/plugins/local/tc_bi_ortho/psi_r_l_prov.irp.f similarity index 100% rename from src/tc_bi_ortho/psi_r_l_prov.irp.f rename to plugins/local/tc_bi_ortho/psi_r_l_prov.irp.f diff --git a/src/tc_bi_ortho/pt2_tc_cisd.irp.f b/plugins/local/tc_bi_ortho/pt2_tc_cisd.irp.f similarity index 100% rename from src/tc_bi_ortho/pt2_tc_cisd.irp.f rename to plugins/local/tc_bi_ortho/pt2_tc_cisd.irp.f diff --git a/src/tc_bi_ortho/save_bitcpsileft_for_qmcchem.irp.f b/plugins/local/tc_bi_ortho/save_bitcpsileft_for_qmcchem.irp.f similarity index 100% rename from src/tc_bi_ortho/save_bitcpsileft_for_qmcchem.irp.f rename to plugins/local/tc_bi_ortho/save_bitcpsileft_for_qmcchem.irp.f diff --git a/src/tc_bi_ortho/save_tc_bi_ortho_nat.irp.f b/plugins/local/tc_bi_ortho/save_tc_bi_ortho_nat.irp.f similarity index 55% rename from src/tc_bi_ortho/save_tc_bi_ortho_nat.irp.f rename to plugins/local/tc_bi_ortho/save_tc_bi_ortho_nat.irp.f index 47ade8df..6b3acce6 100644 --- a/src/tc_bi_ortho/save_tc_bi_ortho_nat.irp.f +++ b/plugins/local/tc_bi_ortho/save_tc_bi_ortho_nat.irp.f @@ -15,13 +15,27 @@ program tc_natorb_bi_ortho PROVIDE tc_grid1_a tc_grid1_r my_n_pt_r_grid = tc_grid1_r my_n_pt_a_grid = tc_grid1_a - touch my_grid_becke my_n_pt_r_grid my_n_pt_a_grid + touch my_grid_becke my_n_pt_r_grid my_n_pt_a_grid + + if(tc_integ_type .eq. "numeric") then + my_extra_grid_becke = .True. + PROVIDE tc_grid2_a tc_grid2_r + my_n_pt_r_extra_grid = tc_grid2_r + my_n_pt_a_extra_grid = tc_grid2_a + touch my_extra_grid_becke my_n_pt_r_extra_grid my_n_pt_a_extra_grid + + call write_int(6, my_n_pt_r_extra_grid, 'radial internal grid over') + call write_int(6, my_n_pt_a_extra_grid, 'angular internal grid over') + endif + + read_wf = .True. touch read_wf call print_energy_and_mos() call save_tc_natorb() + call print_angles_tc() !call minimize_tc_orb_angles() end @@ -35,9 +49,12 @@ subroutine save_tc_natorb() print*,'Saving the natorbs ' provide natorb_tc_leigvec_ao natorb_tc_reigvec_ao + mo_l_coef = natorb_tc_leigvec_ao + mo_r_coef = natorb_tc_reigvec_ao + touch mo_l_coef mo_r_coef - call ezfio_set_bi_ortho_mos_mo_l_coef(natorb_tc_leigvec_ao) - call ezfio_set_bi_ortho_mos_mo_r_coef(natorb_tc_reigvec_ao) + call ezfio_set_bi_ortho_mos_mo_l_coef(mo_l_coef) + call ezfio_set_bi_ortho_mos_mo_r_coef(mo_r_coef) call save_ref_determinant_nstates_1() call ezfio_set_determinants_read_wf(.False.) diff --git a/src/tc_bi_ortho/select_dets_bi_ortho.irp.f b/plugins/local/tc_bi_ortho/select_dets_bi_ortho.irp.f similarity index 100% rename from src/tc_bi_ortho/select_dets_bi_ortho.irp.f rename to plugins/local/tc_bi_ortho/select_dets_bi_ortho.irp.f diff --git a/src/tc_bi_ortho/slater_tc_3e_slow.irp.f b/plugins/local/tc_bi_ortho/slater_tc_3e_slow.irp.f similarity index 100% rename from src/tc_bi_ortho/slater_tc_3e_slow.irp.f rename to plugins/local/tc_bi_ortho/slater_tc_3e_slow.irp.f diff --git a/src/tc_bi_ortho/slater_tc_opt.irp.f b/plugins/local/tc_bi_ortho/slater_tc_opt.irp.f similarity index 100% rename from src/tc_bi_ortho/slater_tc_opt.irp.f rename to plugins/local/tc_bi_ortho/slater_tc_opt.irp.f diff --git a/src/tc_bi_ortho/slater_tc_opt_diag.irp.f b/plugins/local/tc_bi_ortho/slater_tc_opt_diag.irp.f similarity index 100% rename from src/tc_bi_ortho/slater_tc_opt_diag.irp.f rename to plugins/local/tc_bi_ortho/slater_tc_opt_diag.irp.f diff --git a/src/tc_bi_ortho/slater_tc_opt_double.irp.f b/plugins/local/tc_bi_ortho/slater_tc_opt_double.irp.f similarity index 100% rename from src/tc_bi_ortho/slater_tc_opt_double.irp.f rename to plugins/local/tc_bi_ortho/slater_tc_opt_double.irp.f diff --git a/src/tc_bi_ortho/slater_tc_opt_single.irp.f b/plugins/local/tc_bi_ortho/slater_tc_opt_single.irp.f similarity index 100% rename from src/tc_bi_ortho/slater_tc_opt_single.irp.f rename to plugins/local/tc_bi_ortho/slater_tc_opt_single.irp.f diff --git a/src/tc_bi_ortho/slater_tc_slow.irp.f b/plugins/local/tc_bi_ortho/slater_tc_slow.irp.f similarity index 96% rename from src/tc_bi_ortho/slater_tc_slow.irp.f rename to plugins/local/tc_bi_ortho/slater_tc_slow.irp.f index b1751069..caf7d665 100644 --- a/src/tc_bi_ortho/slater_tc_slow.irp.f +++ b/plugins/local/tc_bi_ortho/slater_tc_slow.irp.f @@ -27,7 +27,7 @@ subroutine htilde_mu_mat_bi_ortho_tot_slow(key_j, key_i, Nint, htot) call htilde_mu_mat_bi_ortho_slow(key_j, key_i, Nint, hmono, htwoe, hthree, htot) endif -end subroutine htilde_mu_mat_bi_ortho_tot_slow +end ! -- @@ -260,7 +260,6 @@ subroutine single_htilde_mu_mat_bi_ortho_slow(Nint, key_j, key_i, hmono, htwoe, ! ! PROVIDE core_bitmask core_fock_operator mo_integrals_erf_map -! PROVIDE j1b_gauss other_spin(1) = 2 other_spin(2) = 1 @@ -295,15 +294,6 @@ subroutine single_htilde_mu_mat_bi_ortho_slow(Nint, key_j, key_i, hmono, htwoe, hmono = mo_bi_ortho_tc_one_e(p1,h1) * phase -! if(j1b_gauss .eq. 1) then -! print*,'j1b not implemented for bi ortho TC' -! print*,'stopping ....' -! stop -! !hmono += ( mo_j1b_gauss_hermI (h1,p1) & -! ! + mo_j1b_gauss_hermII (h1,p1) & -! ! + mo_j1b_gauss_nonherm(h1,p1) ) * phase -! endif - ! if(core_tc_op)then ! print*,'core_tc_op not already taken into account for bi ortho' ! print*,'stopping ...' diff --git a/src/tc_bi_ortho/spin_mulliken.irp.f b/plugins/local/tc_bi_ortho/spin_mulliken.irp.f similarity index 100% rename from src/tc_bi_ortho/spin_mulliken.irp.f rename to plugins/local/tc_bi_ortho/spin_mulliken.irp.f diff --git a/src/tc_bi_ortho/symmetrized_3_e_int.irp.f b/plugins/local/tc_bi_ortho/symmetrized_3_e_int.irp.f similarity index 100% rename from src/tc_bi_ortho/symmetrized_3_e_int.irp.f rename to plugins/local/tc_bi_ortho/symmetrized_3_e_int.irp.f diff --git a/src/tc_bi_ortho/symmetrized_3_e_int_prov.irp.f b/plugins/local/tc_bi_ortho/symmetrized_3_e_int_prov.irp.f similarity index 100% rename from src/tc_bi_ortho/symmetrized_3_e_int_prov.irp.f rename to plugins/local/tc_bi_ortho/symmetrized_3_e_int_prov.irp.f diff --git a/src/tc_bi_ortho/tc_bi_ortho.irp.f b/plugins/local/tc_bi_ortho/tc_bi_ortho.irp.f similarity index 98% rename from src/tc_bi_ortho/tc_bi_ortho.irp.f rename to plugins/local/tc_bi_ortho/tc_bi_ortho.irp.f index e27672a2..64982ab6 100644 --- a/src/tc_bi_ortho/tc_bi_ortho.irp.f +++ b/plugins/local/tc_bi_ortho/tc_bi_ortho.irp.f @@ -13,7 +13,7 @@ program tc_bi_ortho my_n_pt_a_grid = tc_grid1_a touch my_grid_becke my_n_pt_r_grid my_n_pt_a_grid - if(j1b_type .ge. 100) then + if(tc_integ_type .eq. "numeric") then my_extra_grid_becke = .True. PROVIDE tc_grid2_a tc_grid2_r my_n_pt_r_extra_grid = tc_grid2_r diff --git a/src/tc_bi_ortho/tc_bi_ortho_prop.irp.f b/plugins/local/tc_bi_ortho/tc_bi_ortho_prop.irp.f similarity index 57% rename from src/tc_bi_ortho/tc_bi_ortho_prop.irp.f rename to plugins/local/tc_bi_ortho/tc_bi_ortho_prop.irp.f index 9168fb3d..a5fe9249 100644 --- a/src/tc_bi_ortho/tc_bi_ortho_prop.irp.f +++ b/plugins/local/tc_bi_ortho/tc_bi_ortho_prop.irp.f @@ -34,4 +34,19 @@ subroutine test do i= 1, 3 print*,tc_bi_ortho_dipole(i,1) enddo + integer, allocatable :: occ(:,:) + integer :: n_occ_ab(2) + allocate(occ(N_int*bit_kind_size,2)) + call bitstring_to_list_ab(ref_bitmask, occ, n_occ_ab, N_int) + integer :: ispin,j,jorb + double precision :: accu + accu = 0.d0 + do ispin=1, 2 + do i = 1, n_occ_ab(ispin) + jorb = occ(i,ispin) + accu += mo_bi_orth_bipole_z(jorb,jorb) + enddo + enddo + print*,'accu = ',accu + end diff --git a/src/tc_bi_ortho/tc_cisd_sc2.irp.f b/plugins/local/tc_bi_ortho/tc_cisd_sc2.irp.f similarity index 100% rename from src/tc_bi_ortho/tc_cisd_sc2.irp.f rename to plugins/local/tc_bi_ortho/tc_cisd_sc2.irp.f diff --git a/src/tc_bi_ortho/tc_cisd_sc2_utils.irp.f b/plugins/local/tc_bi_ortho/tc_cisd_sc2_utils.irp.f similarity index 100% rename from src/tc_bi_ortho/tc_cisd_sc2_utils.irp.f rename to plugins/local/tc_bi_ortho/tc_cisd_sc2_utils.irp.f diff --git a/src/tc_bi_ortho/tc_h_eigvectors.irp.f b/plugins/local/tc_bi_ortho/tc_h_eigvectors.irp.f similarity index 100% rename from src/tc_bi_ortho/tc_h_eigvectors.irp.f rename to plugins/local/tc_bi_ortho/tc_h_eigvectors.irp.f diff --git a/src/tc_bi_ortho/tc_hmat.irp.f b/plugins/local/tc_bi_ortho/tc_hmat.irp.f similarity index 100% rename from src/tc_bi_ortho/tc_hmat.irp.f rename to plugins/local/tc_bi_ortho/tc_hmat.irp.f diff --git a/src/tc_bi_ortho/tc_natorb.irp.f b/plugins/local/tc_bi_ortho/tc_natorb.irp.f similarity index 96% rename from src/tc_bi_ortho/tc_natorb.irp.f rename to plugins/local/tc_bi_ortho/tc_natorb.irp.f index a72d356a..b8cf5e81 100644 --- a/src/tc_bi_ortho/tc_natorb.irp.f +++ b/plugins/local/tc_bi_ortho/tc_natorb.irp.f @@ -29,9 +29,22 @@ write(*, '(100(F16.10,X))') -dm_tmp(:,i) enddo + print *, ' Transition density matrix AO' + do i = 1, ao_num + write(*, '(100(F16.10,X))') tc_transition_matrix_ao(:,i,1,1) + enddo + stop + thr_d = 1.d-6 thr_nd = 1.d-6 thr_deg = 1.d-3 + do i = 1, mo_num + do j = 1, mo_num + if(dabs(dm_tmp(j,i)).lt.thr_d)then + dm_tmp(j,i) = 0.d0 + endif + enddo + enddo ! if(n_core_orb.ne.0)then ! call diag_mat_per_fock_degen_core( fock_diag, dm_tmp, list_core, n_core_orb, mo_num, thr_d, thr_nd, thr_deg & ! , natorb_tc_leigvec_mo, natorb_tc_reigvec_mo, natorb_tc_eigval) diff --git a/src/tc_bi_ortho/tc_prop.irp.f b/plugins/local/tc_bi_ortho/tc_prop.irp.f similarity index 98% rename from src/tc_bi_ortho/tc_prop.irp.f rename to plugins/local/tc_bi_ortho/tc_prop.irp.f index a13dc9a2..3375fed6 100644 --- a/src/tc_bi_ortho/tc_prop.irp.f +++ b/plugins/local/tc_bi_ortho/tc_prop.irp.f @@ -90,6 +90,7 @@ enddo enddo enddo + print*,'tc_bi_ortho_dipole(3) elec = ',tc_bi_ortho_dipole(3,1) nuclei_part = 0.d0 do m = 1, 3 diff --git a/src/tc_bi_ortho/tc_som.irp.f b/plugins/local/tc_bi_ortho/tc_som.irp.f similarity index 91% rename from src/tc_bi_ortho/tc_som.irp.f rename to plugins/local/tc_bi_ortho/tc_som.irp.f index 427508d2..1d11c81b 100644 --- a/src/tc_bi_ortho/tc_som.irp.f +++ b/plugins/local/tc_bi_ortho/tc_som.irp.f @@ -17,12 +17,6 @@ program tc_som my_n_pt_a_grid = tc_grid1_a touch my_grid_becke my_n_pt_r_grid my_n_pt_a_grid - PROVIDE mu_erf - print *, ' mu = ', mu_erf - PROVIDE j1b_type - print *, ' j1b_type = ', j1b_type - print *, j1b_pen - read_wf = .true. touch read_wf diff --git a/src/tc_bi_ortho/tc_utils.irp.f b/plugins/local/tc_bi_ortho/tc_utils.irp.f similarity index 100% rename from src/tc_bi_ortho/tc_utils.irp.f rename to plugins/local/tc_bi_ortho/tc_utils.irp.f diff --git a/src/tc_bi_ortho/test_natorb.irp.f b/plugins/local/tc_bi_ortho/test_natorb.irp.f similarity index 100% rename from src/tc_bi_ortho/test_natorb.irp.f rename to plugins/local/tc_bi_ortho/test_natorb.irp.f diff --git a/src/tc_bi_ortho/test_normal_order.irp.f b/plugins/local/tc_bi_ortho/test_normal_order.irp.f similarity index 100% rename from src/tc_bi_ortho/test_normal_order.irp.f rename to plugins/local/tc_bi_ortho/test_normal_order.irp.f diff --git a/src/tc_bi_ortho/test_s2_tc.irp.f b/plugins/local/tc_bi_ortho/test_s2_tc.irp.f similarity index 100% rename from src/tc_bi_ortho/test_s2_tc.irp.f rename to plugins/local/tc_bi_ortho/test_s2_tc.irp.f diff --git a/src/tc_bi_ortho/test_spin_dens.irp.f b/plugins/local/tc_bi_ortho/test_spin_dens.irp.f similarity index 100% rename from src/tc_bi_ortho/test_spin_dens.irp.f rename to plugins/local/tc_bi_ortho/test_spin_dens.irp.f diff --git a/src/tc_bi_ortho/test_tc_bi_ortho.irp.f b/plugins/local/tc_bi_ortho/test_tc_bi_ortho.irp.f similarity index 100% rename from src/tc_bi_ortho/test_tc_bi_ortho.irp.f rename to plugins/local/tc_bi_ortho/test_tc_bi_ortho.irp.f diff --git a/src/tc_bi_ortho/test_tc_fock.irp.f b/plugins/local/tc_bi_ortho/test_tc_fock.irp.f similarity index 100% rename from src/tc_bi_ortho/test_tc_fock.irp.f rename to plugins/local/tc_bi_ortho/test_tc_fock.irp.f diff --git a/src/tc_bi_ortho/test_tc_two_rdm.irp.f b/plugins/local/tc_bi_ortho/test_tc_two_rdm.irp.f similarity index 100% rename from src/tc_bi_ortho/test_tc_two_rdm.irp.f rename to plugins/local/tc_bi_ortho/test_tc_two_rdm.irp.f diff --git a/src/tc_bi_ortho/two_rdm_naive.irp.f b/plugins/local/tc_bi_ortho/two_rdm_naive.irp.f similarity index 100% rename from src/tc_bi_ortho/two_rdm_naive.irp.f rename to plugins/local/tc_bi_ortho/two_rdm_naive.irp.f diff --git a/src/tc_keywords/EZFIO.cfg b/plugins/local/tc_keywords/EZFIO.cfg similarity index 89% rename from src/tc_keywords/EZFIO.cfg rename to plugins/local/tc_keywords/EZFIO.cfg index 9b9aaca8..93ff790f 100644 --- a/src/tc_keywords/EZFIO.cfg +++ b/plugins/local/tc_keywords/EZFIO.cfg @@ -130,41 +130,23 @@ doc: if +1: only positive is selected, -1: only negative is selected, :0 both po interface: ezfio,provider,ocaml default: 0 -[j1b_pen] -type: double precision -doc: exponents of the 1-body Jastrow -interface: ezfio -size: (nuclei.nucl_num) - -[j1b_pen_coef] -type: double precision -doc: coefficients of the 1-body Jastrow -interface: ezfio -size: (nuclei.nucl_num) - -[j1b_coeff] -type: double precision -doc: coeff of the 1-body Jastrow -interface: ezfio -size: (nuclei.nucl_num) - -[j1b_type] -type: integer -doc: type of 1-body Jastrow -interface: ezfio, provider, ocaml -default: 0 - [mu_r_ct] type: double precision doc: a parameter used to define mu(r) interface: ezfio, provider, ocaml -default: 6.203504908994001e-1 +default: 1.5 [beta_rho_power] type: double precision doc: a parameter used to define mu(r) interface: ezfio, provider, ocaml -default: 0.5 +default: 0.33333 + +[zeta_erf_mu_of_r] +type: double precision +doc: a parameter used to define mu(r) +interface: ezfio, provider, ocaml +default: 1. [thr_degen_tc] type: Threshold @@ -178,12 +160,6 @@ doc: If |true|, maximize the overlap between orthogonalized left- and right eige interface: ezfio,provider,ocaml default: False -[ng_fit_jast] -type: integer -doc: nb of Gaussians used to fit Jastrow fcts -interface: ezfio,provider,ocaml -default: 20 - [max_dim_diis_tcscf] type: integer doc: Maximum size of the DIIS extrapolation procedure @@ -276,7 +252,7 @@ default: True [tc_grid1_a] type: integer -doc: size of angular grid over r1 +doc: size of angular grid over r1: [ 6 | 14 | 26 | 38 | 50 | 74 | 86 | 110 | 146 | 170 | 194 | 230 | 266 | 302 | 350 | 434 | 590 | 770 | 974 | 1202 | 1454 | 1730 | 2030 | 2354 | 2702 | 3074 | 3470 | 3890 | 4334 | 4802 | 5294 | 5810 ] interface: ezfio,provider,ocaml default: 50 @@ -288,13 +264,19 @@ default: 30 [tc_grid2_a] type: integer -doc: size of angular grid over r2 +doc: size of angular grid over r2: [ 6 | 14 | 26 | 38 | 50 | 74 | 86 | 110 | 146 | 170 | 194 | 230 | 266 | 302 | 350 | 434 | 590 | 770 | 974 | 1202 | 1454 | 1730 | 2030 | 2354 | 2702 | 3074 | 3470 | 3890 | 4334 | 4802 | 5294 | 5810 ] interface: ezfio,provider,ocaml -default: 194 +default: 266 [tc_grid2_r] type: integer doc: size of radial grid over r2 interface: ezfio,provider,ocaml -default: 50 +default: 70 + +[tc_integ_type] +type: character*(32) +doc: approach used to evaluate TC integrals [ analytic | numeric | semi-analytic ] +interface: ezfio,ocaml,provider +default: semi-analytic diff --git a/src/tc_keywords/NEED b/plugins/local/tc_keywords/NEED similarity index 100% rename from src/tc_keywords/NEED rename to plugins/local/tc_keywords/NEED diff --git a/src/tc_keywords/tc_keywords.irp.f b/plugins/local/tc_keywords/tc_keywords.irp.f similarity index 100% rename from src/tc_keywords/tc_keywords.irp.f rename to plugins/local/tc_keywords/tc_keywords.irp.f diff --git a/src/tc_scf/11.tc_scf.bats b/plugins/local/tc_scf/11.tc_scf.bats similarity index 67% rename from src/tc_scf/11.tc_scf.bats rename to plugins/local/tc_scf/11.tc_scf.bats index 91b52540..b81c2f4b 100644 --- a/src/tc_scf/11.tc_scf.bats +++ b/plugins/local/tc_scf/11.tc_scf.bats @@ -8,15 +8,15 @@ function run_Ne() { rm -rf Ne_tc_scf echo Ne > Ne.xyz qp create_ezfio -b cc-pcvdz Ne.xyz -o Ne_tc_scf - qp run scf + qp run scf - qp set ao_two_e_erf_ints mu_erf 0.87 + qp set hamiltonian mu_erf 0.87 qp set tc_keywords j1b_type 3 - qp set tc_keywords j1b_pen [1.5] - qp set tc_keywords bi_ortho True + qp set tc_keywords j1b_pen [1.5] + qp set tc_keywords bi_ortho True qp set tc_keywords test_cycle_tc True - qp run tc_scf | tee ${EZFIO_FILE}.tc_scf.out + qp run tc_scf | tee ${EZFIO_FILE}.tc_scf.out eref=-128.552134 energy="$(qp get tc_scf bitc_energy)" eq $energy $eref 1e-6 @@ -24,22 +24,22 @@ function run_Ne() { @test "Ne" { - run_Ne + run_Ne } function run_C() { rm -rf C_tc_scf echo C > C.xyz qp create_ezfio -b cc-pcvdz C.xyz -o C_tc_scf -m 3 - qp run scf + qp run scf - qp set ao_two_e_erf_ints mu_erf 0.87 + qp set hamiltonian mu_erf 0.87 qp set tc_keywords j1b_type 3 - qp set tc_keywords j1b_pen [1.5] - qp set tc_keywords bi_ortho True + qp set tc_keywords j1b_pen [1.5] + qp set tc_keywords bi_ortho True qp set tc_keywords test_cycle_tc True - qp run tc_scf | tee ${EZFIO_FILE}.tc_scf.out + qp run tc_scf | tee ${EZFIO_FILE}.tc_scf.out eref=-37.691254356408791 energy="$(qp get tc_scf bitc_energy)" eq $energy $eref 1e-6 @@ -47,7 +47,7 @@ function run_C() { @test "C" { - run_C + run_C } @@ -55,15 +55,15 @@ function run_O() { rm -rf O_tc_scf echo O > O.xyz qp create_ezfio -b cc-pcvdz O.xyz -o O_tc_scf -m 3 - qp run scf + qp run scf - qp set ao_two_e_erf_ints mu_erf 0.87 + qp set hamiltonian mu_erf 0.87 qp set tc_keywords j1b_type 3 - qp set tc_keywords j1b_pen [1.5] - qp set tc_keywords bi_ortho True + qp set tc_keywords j1b_pen [1.5] + qp set tc_keywords bi_ortho True qp set tc_keywords test_cycle_tc True - qp run tc_scf | tee ${EZFIO_FILE}.tc_scf.out + qp run tc_scf | tee ${EZFIO_FILE}.tc_scf.out eref=-74.814687229354590 energy="$(qp get tc_scf bitc_energy)" eq $energy $eref 1e-6 @@ -71,7 +71,7 @@ function run_O() { @test "O" { - run_O + run_O } @@ -79,16 +79,16 @@ function run_O() { function run_ch2() { rm -rf ch2_tc_scf cp ${QP_ROOT}/tests/input/ch2.xyz . - qp create_ezfio -b "C:cc-pcvdz|H:cc-pvdz" ch2.xyz -o ch2_tc_scf - qp run scf + qp create_ezfio -b "C:cc-pcvdz|H:cc-pvdz" ch2.xyz -o ch2_tc_scf + qp run scf - qp set ao_two_e_erf_ints mu_erf 0.87 + qp set hamiltonian mu_erf 0.87 qp set tc_keywords j1b_type 3 qp set tc_keywords j1b_pen '[1.5,10000,10000]' qp set tc_keywords bi_ortho True qp set tc_keywords test_cycle_tc True - qp run tc_scf | tee ${EZFIO_FILE}.tc_scf.out + qp run tc_scf | tee ${EZFIO_FILE}.tc_scf.out eref=-38.903247818077737 energy="$(qp get tc_scf bitc_energy)" eq $energy $eref 1e-6 @@ -96,6 +96,6 @@ function run_ch2() { @test "ch2" { - run_ch2 + run_ch2 } diff --git a/src/tc_scf/EZFIO.cfg b/plugins/local/tc_scf/EZFIO.cfg similarity index 100% rename from src/tc_scf/EZFIO.cfg rename to plugins/local/tc_scf/EZFIO.cfg diff --git a/src/tc_scf/NEED b/plugins/local/tc_scf/NEED similarity index 100% rename from src/tc_scf/NEED rename to plugins/local/tc_scf/NEED diff --git a/src/tc_scf/combine_lr_tcscf.irp.f b/plugins/local/tc_scf/combine_lr_tcscf.irp.f similarity index 100% rename from src/tc_scf/combine_lr_tcscf.irp.f rename to plugins/local/tc_scf/combine_lr_tcscf.irp.f diff --git a/src/tc_scf/diago_bi_ort_tcfock.irp.f b/plugins/local/tc_scf/diago_bi_ort_tcfock.irp.f similarity index 100% rename from src/tc_scf/diago_bi_ort_tcfock.irp.f rename to plugins/local/tc_scf/diago_bi_ort_tcfock.irp.f diff --git a/src/tc_scf/diago_vartcfock.irp.f b/plugins/local/tc_scf/diago_vartcfock.irp.f similarity index 100% rename from src/tc_scf/diago_vartcfock.irp.f rename to plugins/local/tc_scf/diago_vartcfock.irp.f diff --git a/src/tc_scf/diis_tcscf.irp.f b/plugins/local/tc_scf/diis_tcscf.irp.f similarity index 100% rename from src/tc_scf/diis_tcscf.irp.f rename to plugins/local/tc_scf/diis_tcscf.irp.f diff --git a/src/tc_scf/fock_3e_bi_ortho_cs.irp.f b/plugins/local/tc_scf/fock_3e_bi_ortho_cs.irp.f similarity index 100% rename from src/tc_scf/fock_3e_bi_ortho_cs.irp.f rename to plugins/local/tc_scf/fock_3e_bi_ortho_cs.irp.f diff --git a/src/tc_scf/fock_3e_bi_ortho_os.irp.f b/plugins/local/tc_scf/fock_3e_bi_ortho_os.irp.f similarity index 100% rename from src/tc_scf/fock_3e_bi_ortho_os.irp.f rename to plugins/local/tc_scf/fock_3e_bi_ortho_os.irp.f diff --git a/src/tc_scf/fock_3e_bi_ortho_uhf.irp.f b/plugins/local/tc_scf/fock_3e_bi_ortho_uhf.irp.f similarity index 100% rename from src/tc_scf/fock_3e_bi_ortho_uhf.irp.f rename to plugins/local/tc_scf/fock_3e_bi_ortho_uhf.irp.f diff --git a/src/tc_scf/fock_3e_bi_ortho_uhf_old.irp.f b/plugins/local/tc_scf/fock_3e_bi_ortho_uhf_old.irp.f similarity index 100% rename from src/tc_scf/fock_3e_bi_ortho_uhf_old.irp.f rename to plugins/local/tc_scf/fock_3e_bi_ortho_uhf_old.irp.f diff --git a/src/tc_scf/fock_hermit.irp.f b/plugins/local/tc_scf/fock_hermit.irp.f similarity index 100% rename from src/tc_scf/fock_hermit.irp.f rename to plugins/local/tc_scf/fock_hermit.irp.f diff --git a/src/tc_scf/fock_tc.irp.f b/plugins/local/tc_scf/fock_tc.irp.f similarity index 100% rename from src/tc_scf/fock_tc.irp.f rename to plugins/local/tc_scf/fock_tc.irp.f diff --git a/src/tc_scf/fock_tc_mo_tot.irp.f b/plugins/local/tc_scf/fock_tc_mo_tot.irp.f similarity index 100% rename from src/tc_scf/fock_tc_mo_tot.irp.f rename to plugins/local/tc_scf/fock_tc_mo_tot.irp.f diff --git a/src/tc_scf/fock_three_bi_ortho.irp.f b/plugins/local/tc_scf/fock_three_bi_ortho.irp.f similarity index 100% rename from src/tc_scf/fock_three_bi_ortho.irp.f rename to plugins/local/tc_scf/fock_three_bi_ortho.irp.f diff --git a/src/tc_scf/fock_three_hermit.irp.f b/plugins/local/tc_scf/fock_three_hermit.irp.f similarity index 99% rename from src/tc_scf/fock_three_hermit.irp.f rename to plugins/local/tc_scf/fock_three_hermit.irp.f index 6c132189..00d47fae 100644 --- a/src/tc_scf/fock_three_hermit.irp.f +++ b/plugins/local/tc_scf/fock_three_hermit.irp.f @@ -95,7 +95,12 @@ BEGIN_PROVIDER [double precision, diag_three_elem_hf] if(.not. three_body_h_tc) then - diag_three_elem_hf = 0.d0 + if(noL_standard) then + PROVIDE noL_0e + diag_three_elem_hf = noL_0e + else + diag_three_elem_hf = 0.d0 + endif else diff --git a/src/tc_scf/fock_vartc.irp.f b/plugins/local/tc_scf/fock_vartc.irp.f similarity index 97% rename from src/tc_scf/fock_vartc.irp.f rename to plugins/local/tc_scf/fock_vartc.irp.f index 03899b07..2b4a57e5 100644 --- a/src/tc_scf/fock_vartc.irp.f +++ b/plugins/local/tc_scf/fock_vartc.irp.f @@ -13,9 +13,9 @@ two_e_vartc_integral_alpha = 0.d0 two_e_vartc_integral_beta = 0.d0 - !$OMP PARALLEL DEFAULT (NONE) & - !$OMP PRIVATE (i, j, k, l, density_a, density_b, density, tmp_a, tmp_b, I_coul, I_kjli) & - !$OMP SHARED (ao_num, TCSCF_density_matrix_ao_alpha, TCSCF_density_matrix_ao_beta, ao_two_e_vartc_tot, & + !$OMP PARALLEL DEFAULT (NONE) & + !$OMP PRIVATE (i, j, k, l, density_a, density_b, density, tmp_a, tmp_b, I_coul, I_kjli) & + !$OMP SHARED (ao_num, TCSCF_density_matrix_ao_alpha, TCSCF_density_matrix_ao_beta, ao_two_e_tc_tot, & !$OMP two_e_vartc_integral_alpha, two_e_vartc_integral_beta) allocate(tmp_a(ao_num,ao_num), tmp_b(ao_num,ao_num)) @@ -31,8 +31,8 @@ do i = 1, ao_num do k = 1, ao_num - I_coul = density * ao_two_e_vartc_tot(k,i,l,j) - I_kjli = ao_two_e_vartc_tot(k,j,l,i) + I_coul = density * ao_two_e_tc_tot(k,i,l,j) + I_kjli = ao_two_e_tc_tot(k,j,l,i) tmp_a(k,i) += I_coul - density_a * I_kjli tmp_b(k,i) += I_coul - density_b * I_kjli diff --git a/src/tc_scf/integrals_in_r_stuff.irp.f b/plugins/local/tc_scf/integrals_in_r_stuff.irp.f similarity index 100% rename from src/tc_scf/integrals_in_r_stuff.irp.f rename to plugins/local/tc_scf/integrals_in_r_stuff.irp.f diff --git a/src/tc_scf/minimize_tc_angles.irp.f b/plugins/local/tc_scf/minimize_tc_angles.irp.f similarity index 100% rename from src/tc_scf/minimize_tc_angles.irp.f rename to plugins/local/tc_scf/minimize_tc_angles.irp.f diff --git a/src/tc_scf/molden_lr_mos.irp.f b/plugins/local/tc_scf/molden_lr_mos.irp.f similarity index 100% rename from src/tc_scf/molden_lr_mos.irp.f rename to plugins/local/tc_scf/molden_lr_mos.irp.f diff --git a/src/tc_scf/print_fit_param.irp.f b/plugins/local/tc_scf/print_fit_param.irp.f similarity index 100% rename from src/tc_scf/print_fit_param.irp.f rename to plugins/local/tc_scf/print_fit_param.irp.f diff --git a/src/tc_scf/print_tcscf_energy.irp.f b/plugins/local/tc_scf/print_tcscf_energy.irp.f similarity index 80% rename from src/tc_scf/print_tcscf_energy.irp.f rename to plugins/local/tc_scf/print_tcscf_energy.irp.f index 05b8df23..6f9afd9a 100644 --- a/src/tc_scf/print_tcscf_energy.irp.f +++ b/plugins/local/tc_scf/print_tcscf_energy.irp.f @@ -24,11 +24,15 @@ subroutine main() implicit none double precision :: etc_tot, etc_1e, etc_2e, etc_3e - PROVIDE mu_erf - PROVIDE j1b_type + PROVIDE j2e_type mu_erf + PROVIDE j1e_type j1e_coef j1e_expo + PROVIDE env_type env_coef env_expo + + print*, ' j2e_type = ', j2e_type + print*, ' j1e_type = ', j1e_type + print*, ' env_type = ', env_type print*, ' mu_erf = ', mu_erf - print*, ' j1b_type = ', j1b_type etc_tot = TC_HF_energy etc_1e = TC_HF_one_e_energy diff --git a/src/tc_scf/rh_tcscf_diis.irp.f b/plugins/local/tc_scf/rh_tcscf_diis.irp.f similarity index 98% rename from src/tc_scf/rh_tcscf_diis.irp.f rename to plugins/local/tc_scf/rh_tcscf_diis.irp.f index c7f35451..12678500 100644 --- a/src/tc_scf/rh_tcscf_diis.irp.f +++ b/plugins/local/tc_scf/rh_tcscf_diis.irp.f @@ -71,10 +71,7 @@ subroutine rh_tcscf_diis() etc_tot = TC_HF_energy etc_1e = TC_HF_one_e_energy etc_2e = TC_HF_two_e_energy - etc_3e = 0.d0 - if(three_body_h_tc) then - etc_3e = diag_three_elem_hf - endif + etc_3e = diag_three_elem_hf !tc_grad = grad_non_hermit er_DIIS = maxval(abs(FQS_SQF_mo)) e_delta = dabs(etc_tot - e_save) @@ -202,10 +199,7 @@ subroutine rh_tcscf_diis() etc_tot = TC_HF_energy etc_1e = TC_HF_one_e_energy etc_2e = TC_HF_two_e_energy - etc_3e = 0.d0 - if(three_body_h_tc) then - etc_3e = diag_three_elem_hf - endif + etc_3e = diag_three_elem_hf !tc_grad = grad_non_hermit er_DIIS = maxval(abs(FQS_SQF_mo)) e_delta = dabs(etc_tot - e_save) diff --git a/src/tc_scf/rh_tcscf_simple.irp.f b/plugins/local/tc_scf/rh_tcscf_simple.irp.f similarity index 100% rename from src/tc_scf/rh_tcscf_simple.irp.f rename to plugins/local/tc_scf/rh_tcscf_simple.irp.f diff --git a/src/tc_scf/rh_vartcscf_simple.irp.f b/plugins/local/tc_scf/rh_vartcscf_simple.irp.f similarity index 100% rename from src/tc_scf/rh_vartcscf_simple.irp.f rename to plugins/local/tc_scf/rh_vartcscf_simple.irp.f diff --git a/src/tc_scf/rotate_tcscf_orbitals.irp.f b/plugins/local/tc_scf/rotate_tcscf_orbitals.irp.f similarity index 100% rename from src/tc_scf/rotate_tcscf_orbitals.irp.f rename to plugins/local/tc_scf/rotate_tcscf_orbitals.irp.f diff --git a/src/tc_scf/routines_rotates.irp.f b/plugins/local/tc_scf/routines_rotates.irp.f similarity index 99% rename from src/tc_scf/routines_rotates.irp.f rename to plugins/local/tc_scf/routines_rotates.irp.f index 588382b5..cc825429 100644 --- a/src/tc_scf/routines_rotates.irp.f +++ b/plugins/local/tc_scf/routines_rotates.irp.f @@ -402,6 +402,7 @@ subroutine print_energy_and_mos(good_angles) print *, ' TC energy = ', TC_HF_energy print *, ' TC SCF energy gradient = ', grad_non_hermit print *, ' Max angle Left/right = ', max_angle_left_right + call print_angles_tc() if(max_angle_left_right .lt. thresh_lr_angle) then print *, ' Maximum angle BELOW 45 degrees, everthing is OK !' diff --git a/src/tc_scf/tc_petermann_factor.irp.f b/plugins/local/tc_scf/tc_petermann_factor.irp.f similarity index 100% rename from src/tc_scf/tc_petermann_factor.irp.f rename to plugins/local/tc_scf/tc_petermann_factor.irp.f diff --git a/src/tc_scf/tc_scf.irp.f b/plugins/local/tc_scf/tc_scf.irp.f similarity index 82% rename from src/tc_scf/tc_scf.irp.f rename to plugins/local/tc_scf/tc_scf.irp.f index 22f66484..d8c5ab66 100644 --- a/src/tc_scf/tc_scf.irp.f +++ b/plugins/local/tc_scf/tc_scf.irp.f @@ -7,11 +7,20 @@ program tc_scf END_DOC implicit none + integer :: i + logical :: good_angles + + PROVIDE j1e_type + PROVIDE j2e_type + PROVIDE tcscf_algorithm + PROVIDE var_tc + + print *, ' TC-SCF with:' + print *, ' j1e_type = ', j1e_type + print *, ' j2e_type = ', j2e_type write(json_unit,json_array_open_fmt) 'tc-scf' - print *, ' starting ...' - my_grid_becke = .True. PROVIDE tc_grid1_a tc_grid1_r my_n_pt_r_grid = tc_grid1_r @@ -22,13 +31,7 @@ program tc_scf call write_int(6, my_n_pt_a_grid, 'angular external grid over') - PROVIDE mu_erf - print *, ' mu = ', mu_erf - PROVIDE j1b_type - print *, ' j1b_type = ', j1b_type - print *, j1b_pen - - if(j1b_type .ge. 100) then + if(tc_integ_type .eq. "numeric") then my_extra_grid_becke = .True. PROVIDE tc_grid2_a tc_grid2_r my_n_pt_r_extra_grid = tc_grid2_r @@ -42,8 +45,6 @@ program tc_scf !call create_guess() !call orthonormalize_mos() - PROVIDE tcscf_algorithm - PROVIDE var_tc if(var_tc) then @@ -69,7 +70,16 @@ program tc_scf stop endif - call minimize_tc_orb_angles() + PROVIDE Fock_matrix_tc_diag_mo_tot + print*, ' Eigenvalues:' + do i = 1, mo_num + print*, i, Fock_matrix_tc_diag_mo_tot(i) + enddo + + ! TODO + ! rotate angles in separate code only if necessary + !call minimize_tc_orb_angles() + call print_energy_and_mos(good_angles) endif diff --git a/src/tc_scf/tc_scf_dm.irp.f b/plugins/local/tc_scf/tc_scf_dm.irp.f similarity index 100% rename from src/tc_scf/tc_scf_dm.irp.f rename to plugins/local/tc_scf/tc_scf_dm.irp.f diff --git a/src/tc_scf/tc_scf_energy.irp.f b/plugins/local/tc_scf/tc_scf_energy.irp.f similarity index 100% rename from src/tc_scf/tc_scf_energy.irp.f rename to plugins/local/tc_scf/tc_scf_energy.irp.f diff --git a/src/tc_scf/tcscf_energy_naive.irp.f b/plugins/local/tc_scf/tcscf_energy_naive.irp.f similarity index 100% rename from src/tc_scf/tcscf_energy_naive.irp.f rename to plugins/local/tc_scf/tcscf_energy_naive.irp.f diff --git a/src/tc_scf/test_int.irp.f b/plugins/local/tc_scf/test_int.irp.f similarity index 69% rename from src/tc_scf/test_int.irp.f rename to plugins/local/tc_scf/test_int.irp.f index 4aa67d04..e135fcd8 100644 --- a/src/tc_scf/test_int.irp.f +++ b/plugins/local/tc_scf/test_int.irp.f @@ -1,7 +1,7 @@ program test_ints BEGIN_DOC -! TODO : Put the documentation of the program here + ! TODO : Put the documentation of the program here END_DOC implicit none @@ -20,41 +20,31 @@ program test_ints touch my_extra_grid_becke my_n_pt_r_extra_grid my_n_pt_a_extra_grid !! OK -! call routine_int2_u_grad1u_j1b2 +! call routine_int2_u_grad1u_env2 ! OK -! call routine_v_ij_erf_rk_cst_mu_j1b +! call routine_v_ij_erf_rk_cst_mu_env ! OK -! call routine_x_v_ij_erf_rk_cst_mu_j1b +! call routine_x_v_ij_erf_rk_cst_mu_env ! OK -! call routine_int2_u2_j1b2 +! call routine_int2_u2_env2 ! OK -! call routine_int2_u_grad1u_x_j1b2 +! call routine_int2_u_grad1u_x_env2 ! OK -! call routine_int2_grad1u2_grad2u2_j1b2 -! call routine_int2_u_grad1u_j1b2 -! call test_total_grad_lapl -! call test_total_grad_square +! call routine_int2_grad1u2_grad2u2_env2 +! call routine_int2_u_grad1u_env2 ! call test_int2_grad1_u12_ao_test -! call routine_v_ij_u_cst_mu_j1b_test -! call test_ao_tc_int_chemist +! call routine_v_ij_u_cst_mu_env_test ! call test_grid_points_ao -! call test_tc_scf !call test_int_gauss !call test_fock_3e_uhf_ao() !call test_fock_3e_uhf_mo() - !call test_tc_grad_and_lapl_ao() - !call test_tc_grad_square_ao() - !call test_two_e_tc_non_hermit_integral() -! call test_tc_grad_square_ao_test() - !!PROVIDE TC_HF_energy VARTC_HF_energy !!print *, ' TC_HF_energy = ', TC_HF_energy !!print *, ' VARTC_HF_energy = ', VARTC_HF_energy -! call test_old_ints call test_fock_3e_uhf_mo_cs() call test_fock_3e_uhf_mo_a() @@ -64,47 +54,21 @@ end ! --- -subroutine test_tc_scf - implicit none - integer :: i -! provide int2_u_grad1u_x_j1b2_test - provide x_v_ij_erf_rk_cst_mu_j1b_test -! do i = 1, ng_fit_jast -! print*,expo_gauss_1_erf_x_2(i),coef_gauss_1_erf_x_2(i) -! enddo -! provide tc_grad_square_ao_test -! provide tc_grad_and_lapl_ao_test -! provide int2_u_grad1u_x_j1b2_test -! provide x_v_ij_erf_rk_cst_mu_j1b_test -! print*,'TC_HF_energy = ',TC_HF_energy -! print*,'grad_non_hermit = ',grad_non_hermit -end - -subroutine test_ao_tc_int_chemist - implicit none - provide ao_tc_int_chemist -! provide ao_tc_int_chemist_test -! provide tc_grad_square_ao_test -! provide tc_grad_and_lapl_ao_test -end - -! --- - -subroutine routine_test_j1b +subroutine routine_test_env implicit none integer :: i,icount,j icount = 0 - do i = 1, List_all_comb_b3_size - if(dabs(List_all_comb_b3_coef(i)).gt.1.d-10)then + do i = 1, List_env1s_square_size + if(dabs(List_env1s_square_coef(i)).gt.1.d-10)then print*,'' - print*,List_all_comb_b3_expo(i),List_all_comb_b3_coef(i) - print*,List_all_comb_b3_cent(1:3,i) + print*,List_env1s_square_expo(i),List_env1s_square_coef(i) + print*,List_env1s_square_cent(1:3,i) print*,'' icount += 1 endif enddo - print*,'List_all_comb_b3_coef,icount = ',List_all_comb_b3_size,icount + print*,'List_env1s_square_coef,icount = ',List_env1s_square_size,icount do i = 1, ao_num do j = 1, ao_num do icount = 1, List_comb_thr_b3_size(j,i) @@ -116,11 +80,11 @@ subroutine routine_test_j1b ! enddo enddo enddo - print*,'max_List_comb_thr_b3_size = ',max_List_comb_thr_b3_size,List_all_comb_b3_size + print*,'max_List_comb_thr_b3_size = ',max_List_comb_thr_b3_size,List_env1s_square_size end -subroutine routine_int2_u_grad1u_j1b2 +subroutine routine_int2_u_grad1u_env2 implicit none integer :: i,j,ipoint,k,l double precision :: weight,accu_relat, accu_abs, contrib @@ -136,8 +100,8 @@ subroutine routine_int2_u_grad1u_j1b2 do l = 1, ao_num do i = 1, ao_num do j = 1, ao_num - array(j,i,l,k) += int2_u_grad1u_j1b2_test(j,i,ipoint) * aos_in_r_array(k,ipoint) * aos_in_r_array(l,ipoint) * weight - array_ref(j,i,l,k) += int2_u_grad1u_j1b2(j,i,ipoint) * aos_in_r_array(k,ipoint) * aos_in_r_array(l,ipoint) * weight + array(j,i,l,k) += int2_u_grad1u_env2_test(j,i,ipoint) * aos_in_r_array(k,ipoint) * aos_in_r_array(l,ipoint) * weight + array_ref(j,i,l,k) += int2_u_grad1u_env2(j,i,ipoint) * aos_in_r_array(k,ipoint) * aos_in_r_array(l,ipoint) * weight enddo enddo enddo @@ -160,7 +124,7 @@ subroutine routine_int2_u_grad1u_j1b2 enddo print*,'******' print*,'******' - print*,'routine_int2_u_grad1u_j1b2' + print*,'routine_int2_u_grad1u_env2' print*,'accu_abs = ',accu_abs/dble(ao_num)**4 print*,'accu_relat = ',accu_relat/dble(ao_num)**4 @@ -168,7 +132,7 @@ subroutine routine_int2_u_grad1u_j1b2 end -subroutine routine_v_ij_erf_rk_cst_mu_j1b +subroutine routine_v_ij_erf_rk_cst_mu_env implicit none integer :: i,j,ipoint,k,l double precision :: weight,accu_relat, accu_abs, contrib @@ -183,8 +147,8 @@ subroutine routine_v_ij_erf_rk_cst_mu_j1b do l = 1, ao_num do i = 1, ao_num do j = 1, ao_num - array(j,i,l,k) += v_ij_erf_rk_cst_mu_j1b_test(j,i,ipoint) * aos_in_r_array(k,ipoint) * aos_in_r_array(l,ipoint) * weight - array_ref(j,i,l,k) += v_ij_erf_rk_cst_mu_j1b(j,i,ipoint) * aos_in_r_array(k,ipoint) * aos_in_r_array(l,ipoint) * weight + array(j,i,l,k) += v_ij_erf_rk_cst_mu_env_test(j,i,ipoint) * aos_in_r_array(k,ipoint) * aos_in_r_array(l,ipoint) * weight + array_ref(j,i,l,k) += v_ij_erf_rk_cst_mu_env(j,i,ipoint) * aos_in_r_array(k,ipoint) * aos_in_r_array(l,ipoint) * weight enddo enddo enddo @@ -207,7 +171,7 @@ subroutine routine_v_ij_erf_rk_cst_mu_j1b enddo print*,'******' print*,'******' - print*,'routine_v_ij_erf_rk_cst_mu_j1b' + print*,'routine_v_ij_erf_rk_cst_mu_env' print*,'accu_abs = ',accu_abs/dble(ao_num)**4 print*,'accu_relat = ',accu_relat/dble(ao_num)**4 @@ -216,7 +180,7 @@ subroutine routine_v_ij_erf_rk_cst_mu_j1b end -subroutine routine_x_v_ij_erf_rk_cst_mu_j1b +subroutine routine_x_v_ij_erf_rk_cst_mu_env implicit none integer :: i,j,ipoint,k,l,m double precision :: weight,accu_relat, accu_abs, contrib @@ -232,8 +196,8 @@ subroutine routine_x_v_ij_erf_rk_cst_mu_j1b do i = 1, ao_num do j = 1, ao_num do m = 1, 3 - array(j,i,l,k) += x_v_ij_erf_rk_cst_mu_j1b_test(j,i,ipoint,m) * aos_grad_in_r_array_transp(m,k,ipoint) * aos_in_r_array(l,ipoint) * weight - array_ref(j,i,l,k) += x_v_ij_erf_rk_cst_mu_j1b (j,i,ipoint,m) * aos_grad_in_r_array_transp(m,k,ipoint) * aos_in_r_array(l,ipoint) * weight + array(j,i,l,k) += x_v_ij_erf_rk_cst_mu_env_test(j,i,ipoint,m) * aos_grad_in_r_array_transp(m,k,ipoint) * aos_in_r_array(l,ipoint) * weight + array_ref(j,i,l,k) += x_v_ij_erf_rk_cst_mu_env (j,i,ipoint,m) * aos_grad_in_r_array_transp(m,k,ipoint) * aos_in_r_array(l,ipoint) * weight enddo enddo enddo @@ -258,7 +222,7 @@ subroutine routine_x_v_ij_erf_rk_cst_mu_j1b print*,'******' print*,'******' - print*,'routine_x_v_ij_erf_rk_cst_mu_j1b' + print*,'routine_x_v_ij_erf_rk_cst_mu_env' print*,'accu_abs = ',accu_abs/dble(ao_num)**4 print*,'accu_relat = ',accu_relat/dble(ao_num)**4 @@ -268,7 +232,7 @@ end -subroutine routine_v_ij_u_cst_mu_j1b_test +subroutine routine_v_ij_u_cst_mu_env_test implicit none integer :: i,j,ipoint,k,l double precision :: weight,accu_relat, accu_abs, contrib @@ -283,8 +247,8 @@ subroutine routine_v_ij_u_cst_mu_j1b_test do l = 1, ao_num do i = 1, ao_num do j = 1, ao_num - array(j,i,l,k) += v_ij_u_cst_mu_j1b_test(j,i,ipoint) * aos_in_r_array(k,ipoint) * aos_in_r_array(l,ipoint) * weight - array_ref(j,i,l,k) += v_ij_u_cst_mu_j1b_fit (j,i,ipoint) * aos_in_r_array(k,ipoint) * aos_in_r_array(l,ipoint) * weight + array(j,i,l,k) += v_ij_u_cst_mu_env_test(j,i,ipoint) * aos_in_r_array(k,ipoint) * aos_in_r_array(l,ipoint) * weight + array_ref(j,i,l,k) += v_ij_u_cst_mu_env_fit (j,i,ipoint) * aos_in_r_array(k,ipoint) * aos_in_r_array(l,ipoint) * weight enddo enddo enddo @@ -307,15 +271,13 @@ subroutine routine_v_ij_u_cst_mu_j1b_test enddo print*,'******' print*,'******' - print*,'routine_v_ij_u_cst_mu_j1b_test' + print*,'routine_v_ij_u_cst_mu_env_test' print*,'accu_abs = ',accu_abs/dble(ao_num)**4 print*,'accu_relat = ',accu_relat/dble(ao_num)**4 - - end -subroutine routine_int2_grad1u2_grad2u2_j1b2 +subroutine routine_int2_grad1u2_grad2u2_env2 implicit none integer :: i,j,ipoint,k,l integer :: ii , jj @@ -341,17 +303,17 @@ subroutine routine_int2_grad1u2_grad2u2_j1b2 do l = 1, ao_num do i = 1, ao_num do j = 1, ao_num - array(j,i,l,k) += int2_grad1u2_grad2u2_j1b2_test(j,i,ipoint) * aos_in_r_array(k,ipoint) * aos_in_r_array(l,ipoint) * weight -! !array(j,i,l,k) += int2_grad1u2_grad2u2_j1b2_test(j,i,ipoint) * aos_in_r_array(k,ipoint) * aos_in_r_array(l,ipoint) * weight -! array_ref(j,i,l,k) += int2_grad1u2_grad2u2_j1b2_test(j,i,ipoint) * aos_in_r_array(k,ipoint) * aos_in_r_array(l,ipoint) * weight + array(j,i,l,k) += int2_grad1u2_grad2u2_env2_test(j,i,ipoint) * aos_in_r_array(k,ipoint) * aos_in_r_array(l,ipoint) * weight +! !array(j,i,l,k) += int2_grad1u2_grad2u2_env2_test(j,i,ipoint) * aos_in_r_array(k,ipoint) * aos_in_r_array(l,ipoint) * weight +! array_ref(j,i,l,k) += int2_grad1u2_grad2u2_env2_test(j,i,ipoint) * aos_in_r_array(k,ipoint) * aos_in_r_array(l,ipoint) * weight ! !array(j,i,l,k) += ints(j,i,ipoint) * aos_in_r_array(k,ipoint) * aos_in_r_array(l,ipoint) * weight -! array_ref(j,i,l,k) += int2_grad1u2_grad2u2_j1b2(j,i,ipoint) * aos_in_r_array(k,ipoint) * aos_in_r_array(l,ipoint) * weight +! array_ref(j,i,l,k) += int2_grad1u2_grad2u2_env2(j,i,ipoint) * aos_in_r_array(k,ipoint) * aos_in_r_array(l,ipoint) * weight array_ref(j,i,l,k) += ints(j,i,ipoint) * aos_in_r_array(k,ipoint) * aos_in_r_array(l,ipoint) * weight -! if(dabs(int2_grad1u2_grad2u2_j1b2_test(j,i,ipoint)).gt.1.d-6)then -! if(dabs(int2_grad1u2_grad2u2_j1b2_test(j,i,ipoint) - int2_grad1u2_grad2u2_j1b2_test(j,i,ipoint)).gt.1.d-6)then +! if(dabs(int2_grad1u2_grad2u2_env2_test(j,i,ipoint)).gt.1.d-6)then +! if(dabs(int2_grad1u2_grad2u2_env2_test(j,i,ipoint) - int2_grad1u2_grad2u2_env2_test(j,i,ipoint)).gt.1.d-6)then ! print*,j,i,ipoint -! print*,int2_grad1u2_grad2u2_j1b2_test(j,i,ipoint) , int2_grad1u2_grad2u2_j1b2_test(j,i,ipoint), dabs(int2_grad1u2_grad2u2_j1b2_test(j,i,ipoint) - int2_grad1u2_grad2u2_j1b2_test(j,i,ipoint)) -! print*,int2_grad1u2_grad2u2_j1b2_test(i,j,ipoint) , int2_grad1u2_grad2u2_j1b2_test(i,j,ipoint), dabs(int2_grad1u2_grad2u2_j1b2_test(i,j,ipoint) - int2_grad1u2_grad2u2_j1b2_test(i,j,ipoint)) +! print*,int2_grad1u2_grad2u2_env2_test(j,i,ipoint) , int2_grad1u2_grad2u2_env2_test(j,i,ipoint), dabs(int2_grad1u2_grad2u2_env2_test(j,i,ipoint) - int2_grad1u2_grad2u2_env2_test(j,i,ipoint)) +! print*,int2_grad1u2_grad2u2_env2_test(i,j,ipoint) , int2_grad1u2_grad2u2_env2_test(i,j,ipoint), dabs(int2_grad1u2_grad2u2_env2_test(i,j,ipoint) - int2_grad1u2_grad2u2_env2_test(i,j,ipoint)) ! stop ! endif ! endif @@ -394,7 +356,7 @@ subroutine routine_int2_grad1u2_grad2u2_j1b2 end -subroutine routine_int2_u2_j1b2 +subroutine routine_int2_u2_env2 implicit none integer :: i,j,ipoint,k,l double precision :: weight,accu_relat, accu_abs, contrib @@ -410,8 +372,8 @@ subroutine routine_int2_u2_j1b2 do l = 1, ao_num do i = 1, ao_num do j = 1, ao_num - array(j,i,l,k) += int2_u2_j1b2_test(j,i,ipoint) * aos_in_r_array(k,ipoint) * aos_in_r_array(l,ipoint) * weight - array_ref(j,i,l,k) += int2_u2_j1b2(j,i,ipoint) * aos_in_r_array(k,ipoint) * aos_in_r_array(l,ipoint) * weight + array(j,i,l,k) += int2_u2_env2_test(j,i,ipoint) * aos_in_r_array(k,ipoint) * aos_in_r_array(l,ipoint) * weight + array_ref(j,i,l,k) += int2_u2_env2(j,i,ipoint) * aos_in_r_array(k,ipoint) * aos_in_r_array(l,ipoint) * weight enddo enddo enddo @@ -434,7 +396,7 @@ subroutine routine_int2_u2_j1b2 enddo print*,'******' print*,'******' - print*,'routine_int2_u2_j1b2' + print*,'routine_int2_u2_env2' print*,'accu_abs = ',accu_abs/dble(ao_num)**4 print*,'accu_relat = ',accu_relat/dble(ao_num)**4 @@ -443,7 +405,7 @@ subroutine routine_int2_u2_j1b2 end -subroutine routine_int2_u_grad1u_x_j1b2 +subroutine routine_int2_u_grad1u_x_env2 implicit none integer :: i,j,ipoint,k,l,m double precision :: weight,accu_relat, accu_abs, contrib @@ -460,8 +422,8 @@ subroutine routine_int2_u_grad1u_x_j1b2 do i = 1, ao_num do j = 1, ao_num do m = 1, 3 - array(j,i,l,k) += int2_u_grad1u_x_j1b2_test(j,i,ipoint,m) * aos_grad_in_r_array_transp(m,k,ipoint) * aos_in_r_array(l,ipoint) * weight - array_ref(j,i,l,k) += int2_u_grad1u_x_j1b2 (j,i,ipoint,m) * aos_grad_in_r_array_transp(m,k,ipoint) * aos_in_r_array(l,ipoint) * weight + array(j,i,l,k) += int2_u_grad1u_x_env2_test(j,i,ipoint,m) * aos_grad_in_r_array_transp(m,k,ipoint) * aos_in_r_array(l,ipoint) * weight + array_ref(j,i,l,k) += int2_u_grad1u_x_env2 (j,i,ipoint,m) * aos_grad_in_r_array_transp(m,k,ipoint) * aos_in_r_array(l,ipoint) * weight enddo enddo enddo @@ -485,7 +447,7 @@ subroutine routine_int2_u_grad1u_x_j1b2 enddo print*,'******' print*,'******' - print*,'routine_int2_u_grad1u_x_j1b2' + print*,'routine_int2_u_grad1u_x_env2' print*,'accu_abs = ',accu_abs/dble(ao_num)**4 print*,'accu_relat = ',accu_relat/dble(ao_num)**4 @@ -493,7 +455,7 @@ subroutine routine_int2_u_grad1u_x_j1b2 end -subroutine routine_v_ij_u_cst_mu_j1b +subroutine routine_v_ij_u_cst_mu_env implicit none integer :: i,j,ipoint,k,l double precision :: weight,accu_relat, accu_abs, contrib @@ -509,8 +471,8 @@ subroutine routine_v_ij_u_cst_mu_j1b do l = 1, ao_num do i = 1, ao_num do j = 1, ao_num - array(j,i,l,k) += v_ij_u_cst_mu_j1b_test(j,i,ipoint) * aos_in_r_array(k,ipoint) * aos_in_r_array(l,ipoint) * weight - array_ref(j,i,l,k) += v_ij_u_cst_mu_j1b_fit (j,i,ipoint) * aos_in_r_array(k,ipoint) * aos_in_r_array(l,ipoint) * weight + array(j,i,l,k) += v_ij_u_cst_mu_env_test(j,i,ipoint) * aos_in_r_array(k,ipoint) * aos_in_r_array(l,ipoint) * weight + array_ref(j,i,l,k) += v_ij_u_cst_mu_env_fit (j,i,ipoint) * aos_in_r_array(k,ipoint) * aos_in_r_array(l,ipoint) * weight enddo enddo enddo @@ -533,7 +495,7 @@ subroutine routine_v_ij_u_cst_mu_j1b enddo print*,'******' print*,'******' - print*,'routine_v_ij_u_cst_mu_j1b' + print*,'routine_v_ij_u_cst_mu_env' print*,'accu_abs = ',accu_abs/dble(ao_num)**4 print*,'accu_relat = ',accu_relat/dble(ao_num)**4 @@ -674,66 +636,10 @@ subroutine test_fock_3e_uhf_mo() ! --- -end subroutine test_fock_3e_uhf_mo +end ! --- -subroutine test_total_grad_lapl - implicit none - integer :: i,j,ipoint,k,l - double precision :: weight,accu_relat, accu_abs, contrib - accu_relat = 0.d0 - accu_abs = 0.d0 - do k = 1, ao_num - do l = 1, ao_num - do i = 1, ao_num - do j = 1, ao_num - contrib = dabs(tc_grad_and_lapl_ao_test(j,i,l,k) - tc_grad_and_lapl_ao(j,i,l,k)) - accu_abs += contrib - if(dabs(tc_grad_and_lapl_ao(j,i,l,k)).gt.1.d-10)then - accu_relat += contrib/dabs(tc_grad_and_lapl_ao(j,i,l,k)) - endif - enddo - enddo - enddo - enddo - print*,'******' - print*,'******' - print*,' test_total_grad_lapl' - print*,'accu_abs = ',accu_abs/dble(ao_num)**4 - print*,'accu_relat = ',accu_relat/dble(ao_num)**4 - - -end - -subroutine test_total_grad_square - implicit none - integer :: i,j,ipoint,k,l - double precision :: weight,accu_relat, accu_abs, contrib - accu_relat = 0.d0 - accu_abs = 0.d0 - do k = 1, ao_num - do l = 1, ao_num - do i = 1, ao_num - do j = 1, ao_num - contrib = dabs(tc_grad_square_ao_test(j,i,l,k) - tc_grad_square_ao(j,i,l,k)) - accu_abs += contrib - if(dabs(tc_grad_square_ao(j,i,l,k)).gt.1.d-10)then - accu_relat += contrib/dabs(tc_grad_square_ao(j,i,l,k)) - endif - enddo - enddo - enddo - enddo - print*,'******' - print*,'******' - print*,'test_total_grad_square' - print*,'accu_abs = ',accu_abs/dble(ao_num)**4 - print*,'accu_relat = ',accu_relat/dble(ao_num)**4 - - -end - subroutine test_grid_points_ao implicit none integer :: i,j,ipoint,icount,icount_good, icount_bad,icount_full @@ -748,26 +654,26 @@ subroutine test_grid_points_ao icount_bad = 0 icount_full = 0 do ipoint = 1, n_points_final_grid -! if(dabs(int2_u_grad1u_x_j1b2_test(j,i,ipoint,1)) & -! + dabs(int2_u_grad1u_x_j1b2_test(j,i,ipoint,2)) & -! + dabs(int2_u_grad1u_x_j1b2_test(j,i,ipoint,3)) ) -! if(dabs(int2_u2_j1b2_test(j,i,ipoint)).gt.thr)then +! if(dabs(int2_u_grad1u_x_env2_test(j,i,ipoint,1)) & +! + dabs(int2_u_grad1u_x_env2_test(j,i,ipoint,2)) & +! + dabs(int2_u_grad1u_x_env2_test(j,i,ipoint,3)) ) +! if(dabs(int2_u2_env2_test(j,i,ipoint)).gt.thr)then ! icount += 1 ! endif - if(dabs(v_ij_u_cst_mu_j1b_ng_1_test(j,i,ipoint)).gt.thr*0.1d0)then + if(dabs(v_ij_u_cst_mu_env_ng_1_test(j,i,ipoint)).gt.thr*0.1d0)then icount_full += 1 endif - if(dabs(v_ij_u_cst_mu_j1b_test(j,i,ipoint)).gt.thr)then + if(dabs(v_ij_u_cst_mu_env_test(j,i,ipoint)).gt.thr)then icount += 1 - if(dabs(v_ij_u_cst_mu_j1b_ng_1_test(j,i,ipoint)).gt.thr*0.1d0)then + if(dabs(v_ij_u_cst_mu_env_ng_1_test(j,i,ipoint)).gt.thr*0.1d0)then icount_good += 1 else print*,j,i,ipoint - print*,dabs(v_ij_u_cst_mu_j1b_test(j,i,ipoint)),dabs(v_ij_u_cst_mu_j1b_ng_1_test(j,i,ipoint)),dabs(v_ij_u_cst_mu_j1b_ng_1_test(j,i,ipoint))/dabs(v_ij_u_cst_mu_j1b_test(j,i,ipoint)) + print*,dabs(v_ij_u_cst_mu_env_test(j,i,ipoint)), dabs(v_ij_u_cst_mu_env_ng_1_test(j,i,ipoint)),dabs(v_ij_u_cst_mu_env_ng_1_test(j,i,ipoint))/dabs(v_ij_u_cst_mu_env_test(j,i,ipoint)) icount_bad += 1 endif endif -! if(dabs(v_ij_u_cst_mu_j1b_ng_1_test(j,i,ipoint)).gt.thr)then +! if(dabs(v_ij_u_cst_mu_env_ng_1_test(j,i,ipoint)).gt.thr)then ! endif enddo print*,'' @@ -822,90 +728,6 @@ end ! --- -subroutine test_tc_grad_and_lapl_ao() - - implicit none - integer :: i, j, k, l - double precision :: diff_tot, diff, thr_ih, norm - - thr_ih = 1d-10 - - PROVIDE tc_grad_and_lapl_ao tc_grad_and_lapl_ao_loop - - norm = 0.d0 - diff_tot = 0.d0 - do i = 1, ao_num - do j = 1, ao_num - do k = 1, ao_num - do l = 1, ao_num - - diff = dabs(tc_grad_and_lapl_ao_loop(l,k,j,i) - tc_grad_and_lapl_ao(l,k,j,i)) - if(diff .gt. thr_ih) then - print *, ' difference on ', l, k, j, i - print *, ' loops : ', tc_grad_and_lapl_ao_loop(l,k,j,i) - print *, ' lapack: ', tc_grad_and_lapl_ao (l,k,j,i) - !stop - endif - - norm += dabs(tc_grad_and_lapl_ao_loop(l,k,j,i)) - diff_tot += diff - enddo - enddo - enddo - enddo - - print *, ' diff tot = ', diff_tot / norm - print *, ' norm = ', norm - print *, ' ' - - return - -end - -! --- - -subroutine test_tc_grad_square_ao() - - implicit none - integer :: i, j, k, l - double precision :: diff_tot, diff, thr_ih, norm - - thr_ih = 1d-10 - - PROVIDE tc_grad_square_ao tc_grad_square_ao_loop - - norm = 0.d0 - diff_tot = 0.d0 - do i = 1, ao_num - do j = 1, ao_num - do k = 1, ao_num - do l = 1, ao_num - - diff = dabs(tc_grad_square_ao_loop(l,k,j,i) - tc_grad_square_ao(l,k,j,i)) - if(diff .gt. thr_ih) then - print *, ' difference on ', l, k, j, i - print *, ' loops : ', tc_grad_square_ao_loop(l,k,j,i) - print *, ' lapack: ', tc_grad_square_ao (l,k,j,i) - !stop - endif - - norm += dabs(tc_grad_square_ao_loop(l,k,j,i)) - diff_tot += diff - enddo - enddo - enddo - enddo - - print *, ' diff tot = ', diff_tot / norm - print *, ' norm = ', norm - print *, ' ' - - return - -end - -! --- - subroutine test_two_e_tc_non_hermit_integral() implicit none @@ -973,88 +795,6 @@ end ! --- -subroutine test_tc_grad_square_ao_test() - - implicit none - integer :: i, j, k, l - double precision :: diff_tot, diff, thr_ih, norm - - print*, ' test_tc_grad_square_ao_test ' - - thr_ih = 1d-7 - - PROVIDE tc_grad_square_ao_test tc_grad_square_ao_test_ref - - norm = 0.d0 - diff_tot = 0.d0 - do i = 1, ao_num - do j = 1, ao_num - do k = 1, ao_num - do l = 1, ao_num - - - diff = dabs(tc_grad_square_ao_test(l,k,j,i) - tc_grad_square_ao_test_ref(l,k,j,i)) - if(diff .gt. thr_ih) then - print *, ' difference on ', l, k, j, i - print *, ' new : ', tc_grad_square_ao_test (l,k,j,i) - print *, ' ref : ', tc_grad_square_ao_test_ref(l,k,j,i) - !stop - endif - - norm += dabs(tc_grad_square_ao_test_ref(l,k,j,i)) - diff_tot += diff - enddo - enddo - enddo - enddo - - print *, ' diff tot = ', diff_tot / norm - print *, ' norm = ', norm - print *, ' ' - - return -end - -! --- - - - -subroutine test_old_ints - implicit none - integer :: i,j,k,l - double precision :: old, new, contrib, get_ao_tc_sym_two_e_pot - double precision :: integral_sym , integral_nsym,accu - PROVIDE ao_tc_sym_two_e_pot_in_map - accu = 0.d0 - do j = 1, ao_num - do l= 1, ao_num - do i = 1, ao_num - do k = 1, ao_num -! integral_sym = get_ao_tc_sym_two_e_pot(i, j, k, l, ao_tc_sym_two_e_pot_map) - ! ao_non_hermit_term_chemist(k,i,l,j) = < k l | [erf( mu r12) - 1] d/d_r12 | i j > on the AO basis -! integral_nsym = ao_non_hermit_term_chemist(k,i,l,j) -! old = integral_sym + integral_nsym -! old = tc_grad_square_ao(k,i,l,j) + tc_grad_and_lapl_ao(k,i,l,j) + ao_two_e_coul(k,i,l,j) - new = ao_tc_int_chemist_test(k,i,l,j) - old = ao_tc_int_chemist_no_cycle(k,i,l,j) - contrib = dabs(old - new) - if(contrib.gt.1.d-6)then - print*,'problem !!' - print*,i,j,k,l - print*,old, new, contrib - endif - accu += contrib - enddo - enddo - enddo - enddo - print*,'******' - print*,'******' - print*,'in test_old_ints' - print*,'accu = ',accu/dble(ao_num**4) - -end - subroutine test_int2_grad1_u12_ao_test implicit none integer :: i,j,ipoint,m,k,l @@ -1146,7 +886,7 @@ subroutine test_fock_3e_uhf_mo_cs() print *, ' diff tot (%) = ', 100.d0 * diff_tot / norm return -end subroutine test_fock_3e_uhf_mo_cs +end ! --- @@ -1185,7 +925,7 @@ subroutine test_fock_3e_uhf_mo_a() print *, ' diff tot (%) = ', 100.d0 * diff_tot / norm return -end subroutine test_fock_3e_uhf_mo_a +end ! --- @@ -1224,7 +964,7 @@ subroutine test_fock_3e_uhf_mo_b() print *, ' diff tot (%) = ', 100.d0 * diff_tot / norm return -end subroutine test_fock_3e_uhf_mo_b +end ! --- diff --git a/src/tc_scf/three_e_energy_bi_ortho.irp.f b/plugins/local/tc_scf/three_e_energy_bi_ortho.irp.f similarity index 100% rename from src/tc_scf/three_e_energy_bi_ortho.irp.f rename to plugins/local/tc_scf/three_e_energy_bi_ortho.irp.f diff --git a/src/mo_localization/org/TANGLE_org_mode.sh b/scripts/TANGLE_org_mode.sh similarity index 100% rename from src/mo_localization/org/TANGLE_org_mode.sh rename to scripts/TANGLE_org_mode.sh diff --git a/scripts/module/create_executables_list.sh b/scripts/module/create_executables_list.sh index 67e1aba2..41d8853d 100755 --- a/scripts/module/create_executables_list.sh +++ b/scripts/module/create_executables_list.sh @@ -11,7 +11,11 @@ fi cd ${QP_ROOT}/data rm -f executables +if [[ "$(uname -s)" = "Darwin" ]] ; then +EXES=$(find -L ${QP_ROOT}/src -maxdepth 2 -depth -perm +111 -type f | grep -e "${QP_ROOT}/src/[^/]*/[^/]*$" |sort ) +else EXES=$(find -L ${QP_ROOT}/src -maxdepth 2 -depth -executable -type f | grep -e "${QP_ROOT}/src/[^/]*/[^/]*$" |sort ) +fi for EXE in $EXES do diff --git a/scripts/module/module_handler.py b/scripts/module/module_handler.py index fbdee171..43030fc8 100755 --- a/scripts/module/module_handler.py +++ b/scripts/module/module_handler.py @@ -115,9 +115,7 @@ def get_l_module_descendant(d_child, l_module): except KeyError: print("Error: ", file=sys.stderr) print("`{0}` is not a submodule".format(module), file=sys.stderr) - print("Check the typo (spelling, case, '/', etc.) ", file=sys.stderr) -# pass - sys.exit(1) + raise return list(set(l)) diff --git a/scripts/qp_import_trexio.py b/scripts/qp_import_trexio.py index b3222601..9251a1b0 100755 --- a/scripts/qp_import_trexio.py +++ b/scripts/qp_import_trexio.py @@ -142,6 +142,7 @@ def write_ezfio(trexio_filename, filename): try: basis_type = trexio.read_basis_type(trexio_file) + print ("BASIS TYPE: ", basis_type.lower()) if basis_type.lower() in ["gaussian", "slater"]: shell_num = trexio.read_basis_shell_num(trexio_file) prim_num = trexio.read_basis_prim_num(trexio_file) diff --git a/src/ao_many_one_e_ints/grad2_jmu_modif_vect.irp.f b/src/ao_many_one_e_ints/grad2_jmu_modif_vect.irp.f deleted file mode 100644 index 21927371..00000000 --- a/src/ao_many_one_e_ints/grad2_jmu_modif_vect.irp.f +++ /dev/null @@ -1,453 +0,0 @@ -! -!! --- -! -!BEGIN_PROVIDER [ double precision, int2_grad1u2_grad2u2_j1b2, (ao_num, ao_num, n_points_final_grid)] -! -! BEGIN_DOC -! ! -! ! -\frac{1}{4} int dr2 phi_i(r2) phi_j(r2) 1s_j1b(r2)^2 [1 - erf(mu r12)]^2 -! ! -! END_DOC -! -! implicit none -! integer :: i, j, ipoint, i_1s, i_fit -! integer :: i_mask_grid -! double precision :: r(3), expo_fit, coef_fit -! double precision :: coef, beta, B_center(3) -! double precision :: wall0, wall1 -! -! integer, allocatable :: n_mask_grid(:) -! double precision, allocatable :: r_mask_grid(:,:) -! double precision, allocatable :: int_fit_v(:) -! -! print*, ' providing int2_grad1u2_grad2u2_j1b2' -! -! provide mu_erf final_grid_points_transp j1b_pen -! call wall_time(wall0) -! -! int2_grad1u2_grad2u2_j1b2(:,:,:) = 0.d0 -! -! !$OMP PARALLEL DEFAULT (NONE) & -! !$OMP PRIVATE (ipoint, i, j, i_1s, i_fit, r, coef, beta, B_center,& -! !$OMP coef_fit, expo_fit, int_fit_v, n_mask_grid, & -! !$OMP i_mask_grid, r_mask_grid) & -! !$OMP SHARED (n_points_final_grid, ao_num, List_all_comb_b3_size,& -! !$OMP final_grid_points_transp, n_max_fit_slat, & -! !$OMP expo_gauss_1_erf_x_2, coef_gauss_1_erf_x_2, & -! !$OMP List_all_comb_b3_coef, List_all_comb_b3_expo, & -! !$OMP List_all_comb_b3_cent, int2_grad1u2_grad2u2_j1b2, & -! !$OMP ao_overlap_abs) -! -! allocate(int_fit_v(n_points_final_grid)) -! allocate(n_mask_grid(n_points_final_grid)) -! allocate(r_mask_grid(n_points_final_grid,3)) -! -! !$OMP DO SCHEDULE(dynamic) -! do i = 1, ao_num -! do j = i, ao_num -! -! if(ao_overlap_abs(j,i) .lt. 1.d-12) then -! cycle -! endif -! -! do i_fit = 1, n_max_fit_slat -! -! expo_fit = expo_gauss_1_erf_x_2(i_fit) -! coef_fit = coef_gauss_1_erf_x_2(i_fit) * (-0.25d0) -! -! ! --- -! -! call overlap_gauss_r12_ao_v(final_grid_points_transp, n_points_final_grid, expo_fit, i, j, int_fit_v, n_points_final_grid, n_points_final_grid) -! -! i_mask_grid = 0 ! dim -! n_mask_grid = 0 ! ind -! r_mask_grid = 0.d0 ! val -! do ipoint = 1, n_points_final_grid -! -! int2_grad1u2_grad2u2_j1b2(j,i,ipoint) += coef_fit * int_fit_v(ipoint) -! -! if(dabs(int_fit_v(ipoint)) .gt. 1d-10) then -! i_mask_grid += 1 -! n_mask_grid(i_mask_grid ) = ipoint -! r_mask_grid(i_mask_grid,1) = final_grid_points_transp(ipoint,1) -! r_mask_grid(i_mask_grid,2) = final_grid_points_transp(ipoint,2) -! r_mask_grid(i_mask_grid,3) = final_grid_points_transp(ipoint,3) -! endif -! -! enddo -! -! if(i_mask_grid .eq. 0) cycle -! -! ! --- -! -! do i_1s = 2, List_all_comb_b3_size -! -! coef = List_all_comb_b3_coef (i_1s) * coef_fit -! beta = List_all_comb_b3_expo (i_1s) -! B_center(1) = List_all_comb_b3_cent(1,i_1s) -! B_center(2) = List_all_comb_b3_cent(2,i_1s) -! B_center(3) = List_all_comb_b3_cent(3,i_1s) -! -! call overlap_gauss_r12_ao_with1s_v(B_center, beta, r_mask_grid, n_points_final_grid, expo_fit, i, j, int_fit_v, n_points_final_grid, i_mask_grid) -! -! do ipoint = 1, i_mask_grid -! int2_grad1u2_grad2u2_j1b2(j,i,n_mask_grid(ipoint)) += coef * int_fit_v(ipoint) -! enddo -! -! enddo -! -! ! --- -! -! enddo -! enddo -! enddo -! !$OMP END DO -! -! deallocate(n_mask_grid) -! deallocate(r_mask_grid) -! deallocate(int_fit_v) -! -! !$OMP END PARALLEL -! -! do ipoint = 1, n_points_final_grid -! do i = 2, ao_num -! do j = 1, i-1 -! int2_grad1u2_grad2u2_j1b2(j,i,ipoint) = int2_grad1u2_grad2u2_j1b2(i,j,ipoint) -! enddo -! enddo -! enddo -! -! call wall_time(wall1) -! print*, ' wall time for int2_grad1u2_grad2u2_j1b2', wall1 - wall0 -! -!END_PROVIDER -! -!! --- -! -!BEGIN_PROVIDER [ double precision, int2_u2_j1b2, (ao_num, ao_num, n_points_final_grid)] -! -! BEGIN_DOC -! ! -! ! int dr2 phi_i(r2) phi_j(r2) 1s_j1b(r2)^2 [u_12^mu]^2 -! ! -! END_DOC -! -! implicit none -! integer :: i, j, ipoint, i_1s, i_fit -! integer :: i_mask_grid -! double precision :: r(3), expo_fit, coef_fit -! double precision :: coef, beta, B_center(3), tmp -! double precision :: wall0, wall1 -! -! integer, allocatable :: n_mask_grid(:) -! double precision, allocatable :: r_mask_grid(:,:) -! double precision, allocatable :: int_fit_v(:) -! -! print*, ' providing int2_u2_j1b2' -! -! provide mu_erf final_grid_points_transp j1b_pen -! call wall_time(wall0) -! -! int2_u2_j1b2(:,:,:) = 0.d0 -! -! !$OMP PARALLEL DEFAULT (NONE) & -! !$OMP PRIVATE (ipoint, i, j, i_1s, i_fit, r, coef, beta, B_center, & -! !$OMP coef_fit, expo_fit, int_fit_v, & -! !$OMP i_mask_grid, n_mask_grid, r_mask_grid ) & -! !$OMP SHARED (n_points_final_grid, ao_num, List_all_comb_b3_size, & -! !$OMP final_grid_points_transp, n_max_fit_slat, & -! !$OMP expo_gauss_j_mu_x_2, coef_gauss_j_mu_x_2, & -! !$OMP List_all_comb_b3_coef, List_all_comb_b3_expo, & -! !$OMP List_all_comb_b3_cent, int2_u2_j1b2) -! -! allocate(n_mask_grid(n_points_final_grid)) -! allocate(r_mask_grid(n_points_final_grid,3)) -! allocate(int_fit_v(n_points_final_grid)) -! -! !$OMP DO SCHEDULE(dynamic) -! do i = 1, ao_num -! do j = i, ao_num -! -! do i_fit = 1, n_max_fit_slat -! -! expo_fit = expo_gauss_j_mu_x_2(i_fit) -! coef_fit = coef_gauss_j_mu_x_2(i_fit) -! -! ! --- -! -! call overlap_gauss_r12_ao_v(final_grid_points_transp, n_points_final_grid, expo_fit, i, j, int_fit_v, n_points_final_grid, n_points_final_grid) -! -! i_mask_grid = 0 ! dim -! n_mask_grid = 0 ! ind -! r_mask_grid = 0.d0 ! val -! -! do ipoint = 1, n_points_final_grid -! int2_u2_j1b2(j,i,ipoint) += coef_fit * int_fit_v(ipoint) -! -! if(dabs(int_fit_v(ipoint)) .gt. 1d-10) then -! i_mask_grid += 1 -! n_mask_grid(i_mask_grid ) = ipoint -! r_mask_grid(i_mask_grid,1) = final_grid_points_transp(ipoint,1) -! r_mask_grid(i_mask_grid,2) = final_grid_points_transp(ipoint,2) -! r_mask_grid(i_mask_grid,3) = final_grid_points_transp(ipoint,3) -! endif -! enddo -! -! if(i_mask_grid .eq. 0) cycle -! -! ! --- -! -! do i_1s = 2, List_all_comb_b3_size -! -! coef = List_all_comb_b3_coef (i_1s) * coef_fit -! beta = List_all_comb_b3_expo (i_1s) -! B_center(1) = List_all_comb_b3_cent(1,i_1s) -! B_center(2) = List_all_comb_b3_cent(2,i_1s) -! B_center(3) = List_all_comb_b3_cent(3,i_1s) -! -! call overlap_gauss_r12_ao_with1s_v(B_center, beta, r_mask_grid, n_points_final_grid, expo_fit, i, j, int_fit_v, n_points_final_grid, i_mask_grid) -! -! do ipoint = 1, i_mask_grid -! int2_u2_j1b2(j,i,n_mask_grid(ipoint)) += coef * int_fit_v(ipoint) -! enddo -! -! enddo -! -! ! --- -! -! enddo -! enddo -! enddo -! !$OMP END DO -! -! deallocate(n_mask_grid) -! deallocate(r_mask_grid) -! deallocate(int_fit_v) -! -! !$OMP END PARALLEL -! -! do ipoint = 1, n_points_final_grid -! do i = 2, ao_num -! do j = 1, i-1 -! int2_u2_j1b2(j,i,ipoint) = int2_u2_j1b2(i,j,ipoint) -! enddo -! enddo -! enddo -! -! call wall_time(wall1) -! print*, ' wall time for int2_u2_j1b2', wall1 - wall0 -! -!END_PROVIDER -! -!! --- -! -!BEGIN_PROVIDER [ double precision, int2_u_grad1u_x_j1b2, (ao_num, ao_num, n_points_final_grid, 3)] -! -! BEGIN_DOC -! ! -! ! int dr2 phi_i(r2) phi_j(r2) 1s_j1b(r2)^2 u_12^mu [\grad_1 u_12^mu] r2 -! ! -! END_DOC -! -! implicit none -! -! integer :: i, j, ipoint, i_1s, i_fit -! integer :: i_mask_grid1, i_mask_grid2, i_mask_grid3, i_mask_grid(3) -! double precision :: x, y, z, expo_fit, coef_fit -! double precision :: coef, beta, B_center(3) -! double precision :: alpha_1s, alpha_1s_inv, expo_coef_1s -! double precision :: wall0, wall1 -! -! integer, allocatable :: n_mask_grid(:,:) -! double precision, allocatable :: r_mask_grid(:,:,:) -! double precision, allocatable :: int_fit_v(:,:), dist(:,:), centr_1s(:,:,:) -! -! print*, ' providing int2_u_grad1u_x_j1b2' -! -! provide mu_erf final_grid_points_transp j1b_pen -! call wall_time(wall0) -! -! int2_u_grad1u_x_j1b2(:,:,:,:) = 0.d0 -! -! !$OMP PARALLEL DEFAULT (NONE) & -! !$OMP PRIVATE (ipoint, i, j, i_1s, i_fit, x, y, z, coef, beta, & -! !$OMP coef_fit, expo_fit, int_fit_v, alpha_1s, dist, B_center,& -! !$OMP alpha_1s_inv, centr_1s, expo_coef_1s, & -! !$OMP i_mask_grid1, i_mask_grid2, i_mask_grid3, i_mask_grid, & -! !$OMP n_mask_grid, r_mask_grid) & -! !$OMP SHARED (n_points_final_grid, ao_num, List_all_comb_b3_size, & -! !$OMP final_grid_points_transp, n_max_fit_slat, & -! !$OMP expo_gauss_j_mu_1_erf, coef_gauss_j_mu_1_erf, & -! !$OMP List_all_comb_b3_coef, List_all_comb_b3_expo, & -! !$OMP List_all_comb_b3_cent, int2_u_grad1u_x_j1b2) -! -! allocate(dist(n_points_final_grid,3)) -! allocate(centr_1s(n_points_final_grid,3,3)) -! allocate(n_mask_grid(n_points_final_grid,3)) -! allocate(r_mask_grid(n_points_final_grid,3,3)) -! allocate(int_fit_v(n_points_final_grid,3)) -! -! !$OMP DO SCHEDULE(dynamic) -! do i = 1, ao_num -! do j = i, ao_num -! do i_fit = 1, n_max_fit_slat -! -! expo_fit = expo_gauss_j_mu_1_erf(i_fit) -! coef_fit = coef_gauss_j_mu_1_erf(i_fit) -! -! ! --- -! -! call NAI_pol_x_mult_erf_ao_with1s_v0(i, j, expo_fit, final_grid_points_transp, n_points_final_grid, 1.d+9, final_grid_points_transp, n_points_final_grid, int_fit_v, n_points_final_grid, n_points_final_grid) -! -! i_mask_grid1 = 0 ! dim -! i_mask_grid2 = 0 ! dim -! i_mask_grid3 = 0 ! dim -! n_mask_grid = 0 ! ind -! r_mask_grid = 0.d0 ! val -! do ipoint = 1, n_points_final_grid -! -! ! --- -! -! int2_u_grad1u_x_j1b2(j,i,ipoint,1) += coef_fit * int_fit_v(ipoint,1) -! -! if(dabs(int_fit_v(ipoint,1)) .gt. 1d-10) then -! i_mask_grid1 += 1 -! n_mask_grid(i_mask_grid1, 1) = ipoint -! r_mask_grid(i_mask_grid1,1,1) = final_grid_points_transp(ipoint,1) -! r_mask_grid(i_mask_grid1,2,1) = final_grid_points_transp(ipoint,2) -! r_mask_grid(i_mask_grid1,3,1) = final_grid_points_transp(ipoint,3) -! endif -! -! ! --- -! -! int2_u_grad1u_x_j1b2(j,i,ipoint,2) += coef_fit * int_fit_v(ipoint,2) -! -! if(dabs(int_fit_v(ipoint,2)) .gt. 1d-10) then -! i_mask_grid2 += 1 -! n_mask_grid(i_mask_grid2, 2) = ipoint -! r_mask_grid(i_mask_grid2,1,2) = final_grid_points_transp(ipoint,1) -! r_mask_grid(i_mask_grid2,2,2) = final_grid_points_transp(ipoint,2) -! r_mask_grid(i_mask_grid2,3,2) = final_grid_points_transp(ipoint,3) -! endif -! -! ! --- -! -! int2_u_grad1u_x_j1b2(j,i,ipoint,3) += coef_fit * int_fit_v(ipoint,3) -! -! if(dabs(int_fit_v(ipoint,3)) .gt. 1d-10) then -! i_mask_grid3 += 1 -! n_mask_grid(i_mask_grid3, 3) = ipoint -! r_mask_grid(i_mask_grid3,1,3) = final_grid_points_transp(ipoint,1) -! r_mask_grid(i_mask_grid3,2,3) = final_grid_points_transp(ipoint,2) -! r_mask_grid(i_mask_grid3,3,3) = final_grid_points_transp(ipoint,3) -! endif -! -! ! --- -! -! enddo -! -! if((i_mask_grid1+i_mask_grid2+i_mask_grid3) .eq. 0) cycle -! -! i_mask_grid(1) = i_mask_grid1 -! i_mask_grid(2) = i_mask_grid2 -! i_mask_grid(3) = i_mask_grid3 -! -! ! --- -! -! do i_1s = 2, List_all_comb_b3_size -! -! coef = List_all_comb_b3_coef (i_1s) * coef_fit -! beta = List_all_comb_b3_expo (i_1s) -! B_center(1) = List_all_comb_b3_cent(1,i_1s) -! B_center(2) = List_all_comb_b3_cent(2,i_1s) -! B_center(3) = List_all_comb_b3_cent(3,i_1s) -! -! alpha_1s = beta + expo_fit -! alpha_1s_inv = 1.d0 / alpha_1s -! expo_coef_1s = beta * expo_fit * alpha_1s_inv -! -! do ipoint = 1, i_mask_grid1 -! -! x = r_mask_grid(ipoint,1,1) -! y = r_mask_grid(ipoint,2,1) -! z = r_mask_grid(ipoint,3,1) -! -! centr_1s(ipoint,1,1) = alpha_1s_inv * (beta * B_center(1) + expo_fit * x) -! centr_1s(ipoint,2,1) = alpha_1s_inv * (beta * B_center(2) + expo_fit * y) -! centr_1s(ipoint,3,1) = alpha_1s_inv * (beta * B_center(3) + expo_fit * z) -! -! dist(ipoint,1) = (B_center(1) - x) * (B_center(1) - x) + (B_center(2) - y) * (B_center(2) - y) + (B_center(3) - z) * (B_center(3) - z) -! enddo -! -! do ipoint = 1, i_mask_grid2 -! -! x = r_mask_grid(ipoint,1,2) -! y = r_mask_grid(ipoint,2,2) -! z = r_mask_grid(ipoint,3,2) -! -! centr_1s(ipoint,1,2) = alpha_1s_inv * (beta * B_center(1) + expo_fit * x) -! centr_1s(ipoint,2,2) = alpha_1s_inv * (beta * B_center(2) + expo_fit * y) -! centr_1s(ipoint,3,2) = alpha_1s_inv * (beta * B_center(3) + expo_fit * z) -! -! dist(ipoint,2) = (B_center(1) - x) * (B_center(1) - x) + (B_center(2) - y) * (B_center(2) - y) + (B_center(3) - z) * (B_center(3) - z) -! enddo -! -! do ipoint = 1, i_mask_grid3 -! -! x = r_mask_grid(ipoint,1,3) -! y = r_mask_grid(ipoint,2,3) -! z = r_mask_grid(ipoint,3,3) -! -! centr_1s(ipoint,1,3) = alpha_1s_inv * (beta * B_center(1) + expo_fit * x) -! centr_1s(ipoint,2,3) = alpha_1s_inv * (beta * B_center(2) + expo_fit * y) -! centr_1s(ipoint,3,3) = alpha_1s_inv * (beta * B_center(3) + expo_fit * z) -! -! dist(ipoint,3) = (B_center(1) - x) * (B_center(1) - x) + (B_center(2) - y) * (B_center(2) - y) + (B_center(3) - z) * (B_center(3) - z) -! enddo -! -! call NAI_pol_x_mult_erf_ao_with1s_v(i, j, alpha_1s, centr_1s, n_points_final_grid, 1.d+9, r_mask_grid, n_points_final_grid, int_fit_v, n_points_final_grid, i_mask_grid) -! -! do ipoint = 1, i_mask_grid1 -! int2_u_grad1u_x_j1b2(j,i,n_mask_grid(ipoint,1),1) += coef * dexp(-expo_coef_1s * dist(ipoint,1)) * int_fit_v(ipoint,1) -! enddo -! -! do ipoint = 1, i_mask_grid2 -! int2_u_grad1u_x_j1b2(j,i,n_mask_grid(ipoint,2),2) += coef * dexp(-expo_coef_1s * dist(ipoint,2)) * int_fit_v(ipoint,2) -! enddo -! -! do ipoint = 1, i_mask_grid3 -! int2_u_grad1u_x_j1b2(j,i,n_mask_grid(ipoint,3),3) += coef * dexp(-expo_coef_1s * dist(ipoint,3)) * int_fit_v(ipoint,3) -! enddo -! -! enddo -! -! ! --- -! -! enddo -! enddo -! enddo -! !$OMP END DO -! -! deallocate(dist) -! deallocate(centr_1s) -! deallocate(n_mask_grid) -! deallocate(r_mask_grid) -! deallocate(int_fit_v) -! -! !$OMP END PARALLEL -! -! do ipoint = 1, n_points_final_grid -! do i = 2, ao_num -! do j = 1, i-1 -! int2_u_grad1u_x_j1b2(j,i,ipoint,1) = int2_u_grad1u_x_j1b2(i,j,ipoint,1) -! int2_u_grad1u_x_j1b2(j,i,ipoint,2) = int2_u_grad1u_x_j1b2(i,j,ipoint,2) -! int2_u_grad1u_x_j1b2(j,i,ipoint,3) = int2_u_grad1u_x_j1b2(i,j,ipoint,3) -! enddo -! enddo -! enddo -! -! call wall_time(wall1) -! print*, ' wall time for int2_u_grad1u_x_j1b2 =', wall1 - wall0 -! -!END_PROVIDER -! diff --git a/src/ao_many_one_e_ints/listj1b.irp.f b/src/ao_many_one_e_ints/listj1b.irp.f deleted file mode 100644 index 33ca8085..00000000 --- a/src/ao_many_one_e_ints/listj1b.irp.f +++ /dev/null @@ -1,366 +0,0 @@ - -! --- - -BEGIN_PROVIDER [integer, List_all_comb_b2_size] - - implicit none - - PROVIDE j1b_type - - if((j1b_type .eq. 3) .or. (j1b_type .eq. 103)) then - - List_all_comb_b2_size = 2**nucl_num - - elseif((j1b_type .eq. 4) .or. (j1b_type .eq. 104)) then - - List_all_comb_b2_size = nucl_num + 1 - - else - - print *, 'j1b_type = ', j1b_type, 'is not implemented' - stop - - endif - - print *, ' nb of linear terms in the envelope is ', List_all_comb_b2_size - -END_PROVIDER - -! --- - -BEGIN_PROVIDER [integer, List_all_comb_b2, (nucl_num, List_all_comb_b2_size)] - - implicit none - integer :: i, j - - if(nucl_num .gt. 32) then - print *, ' nucl_num = ', nucl_num, '> 32' - stop - endif - - List_all_comb_b2 = 0 - - do i = 0, List_all_comb_b2_size-1 - do j = 0, nucl_num-1 - if (btest(i,j)) then - List_all_comb_b2(j+1,i+1) = 1 - endif - enddo - enddo - -END_PROVIDER - -! --- - - BEGIN_PROVIDER [ double precision, List_all_comb_b2_coef, ( List_all_comb_b2_size)] -&BEGIN_PROVIDER [ double precision, List_all_comb_b2_expo, ( List_all_comb_b2_size)] -&BEGIN_PROVIDER [ double precision, List_all_comb_b2_cent, (3, List_all_comb_b2_size)] - - implicit none - integer :: i, j, k, phase - double precision :: tmp_alphaj, tmp_alphak - double precision :: tmp_cent_x, tmp_cent_y, tmp_cent_z - - provide j1b_pen - provide j1b_pen_coef - - List_all_comb_b2_coef = 0.d0 - List_all_comb_b2_expo = 0.d0 - List_all_comb_b2_cent = 0.d0 - - if((j1b_type .eq. 3) .or. (j1b_type .eq. 103)) then - - do i = 1, List_all_comb_b2_size - - tmp_cent_x = 0.d0 - tmp_cent_y = 0.d0 - tmp_cent_z = 0.d0 - do j = 1, nucl_num - tmp_alphaj = dble(List_all_comb_b2(j,i)) * j1b_pen(j) - List_all_comb_b2_expo(i) += tmp_alphaj - tmp_cent_x += tmp_alphaj * nucl_coord(j,1) - tmp_cent_y += tmp_alphaj * nucl_coord(j,2) - tmp_cent_z += tmp_alphaj * nucl_coord(j,3) - enddo - - if(List_all_comb_b2_expo(i) .lt. 1d-10) cycle - - List_all_comb_b2_cent(1,i) = tmp_cent_x / List_all_comb_b2_expo(i) - List_all_comb_b2_cent(2,i) = tmp_cent_y / List_all_comb_b2_expo(i) - List_all_comb_b2_cent(3,i) = tmp_cent_z / List_all_comb_b2_expo(i) - enddo - - ! --- - - do i = 1, List_all_comb_b2_size - - do j = 2, nucl_num, 1 - tmp_alphaj = dble(List_all_comb_b2(j,i)) * j1b_pen(j) - do k = 1, j-1, 1 - tmp_alphak = dble(List_all_comb_b2(k,i)) * j1b_pen(k) - - List_all_comb_b2_coef(i) += tmp_alphaj * tmp_alphak * ( (nucl_coord(j,1) - nucl_coord(k,1)) * (nucl_coord(j,1) - nucl_coord(k,1)) & - + (nucl_coord(j,2) - nucl_coord(k,2)) * (nucl_coord(j,2) - nucl_coord(k,2)) & - + (nucl_coord(j,3) - nucl_coord(k,3)) * (nucl_coord(j,3) - nucl_coord(k,3)) ) - enddo - enddo - - if(List_all_comb_b2_expo(i) .lt. 1d-10) cycle - - List_all_comb_b2_coef(i) = List_all_comb_b2_coef(i) / List_all_comb_b2_expo(i) - enddo - - ! --- - - do i = 1, List_all_comb_b2_size - - phase = 0 - do j = 1, nucl_num - phase += List_all_comb_b2(j,i) - enddo - - List_all_comb_b2_coef(i) = (-1.d0)**dble(phase) * dexp(-List_all_comb_b2_coef(i)) - enddo - - elseif((j1b_type .eq. 4) .or. (j1b_type .eq. 104)) then - - List_all_comb_b2_coef( 1) = 1.d0 - List_all_comb_b2_expo( 1) = 0.d0 - List_all_comb_b2_cent(1:3,1) = 0.d0 - do i = 1, nucl_num - List_all_comb_b2_coef( i+1) = -1.d0 * j1b_pen_coef(i) - List_all_comb_b2_expo( i+1) = j1b_pen(i) - List_all_comb_b2_cent(1,i+1) = nucl_coord(i,1) - List_all_comb_b2_cent(2,i+1) = nucl_coord(i,2) - List_all_comb_b2_cent(3,i+1) = nucl_coord(i,3) - enddo - - else - - print *, 'j1b_type = ', j1b_type, 'is not implemented' - stop - - endif - - !print *, ' coeff, expo & cent of list b2' - !do i = 1, List_all_comb_b2_size - ! print*, i, List_all_comb_b2_coef(i), List_all_comb_b2_expo(i) - ! print*, List_all_comb_b2_cent(1,i), List_all_comb_b2_cent(2,i), List_all_comb_b2_cent(3,i) - !enddo - -END_PROVIDER - -! --- - -BEGIN_PROVIDER [ integer, List_all_comb_b3_size] - - implicit none - double precision :: tmp - - if((j1b_type .eq. 3) .or. (j1b_type .eq. 103)) then - - List_all_comb_b3_size = 3**nucl_num - - elseif((j1b_type .eq. 4) .or. (j1b_type .eq. 104)) then - - tmp = 0.5d0 * dble(nucl_num) * (dble(nucl_num) + 3.d0) - List_all_comb_b3_size = int(tmp) + 1 - - else - - print *, 'j1b_type = ', j1b_type, 'is not implemented' - stop - - endif - - print *, ' nb of linear terms in the square of the envelope is ', List_all_comb_b3_size - -END_PROVIDER - -! --- - -BEGIN_PROVIDER [integer, List_all_comb_b3, (nucl_num, List_all_comb_b3_size)] - - implicit none - integer :: i, j, ii, jj - integer, allocatable :: M(:,:), p(:) - - if(nucl_num .gt. 32) then - print *, ' nucl_num = ', nucl_num, '> 32' - stop - endif - - List_all_comb_b3(:,:) = 0 - List_all_comb_b3(:,List_all_comb_b3_size) = 2 - - allocate(p(nucl_num)) - p = 0 - - do i = 2, List_all_comb_b3_size-1 - do j = 1, nucl_num - - ii = 0 - do jj = 1, j-1, 1 - ii = ii + p(jj) * 3**(jj-1) - enddo - p(j) = modulo(i-1-ii, 3**j) / 3**(j-1) - - List_all_comb_b3(j,i) = p(j) - enddo - enddo - -END_PROVIDER - -! --- - - BEGIN_PROVIDER [ double precision, List_all_comb_b3_coef, ( List_all_comb_b3_size)] -&BEGIN_PROVIDER [ double precision, List_all_comb_b3_expo, ( List_all_comb_b3_size)] -&BEGIN_PROVIDER [ double precision, List_all_comb_b3_cent, (3, List_all_comb_b3_size)] - - implicit none - integer :: i, j, k, phase - integer :: ii - double precision :: tmp_alphaj, tmp_alphak, facto - double precision :: tmp1, tmp2, tmp3, tmp4 - double precision :: xi, yi, zi, xj, yj, zj - double precision :: dx, dy, dz, r2 - - provide j1b_pen - provide j1b_pen_coef - - List_all_comb_b3_coef = 0.d0 - List_all_comb_b3_expo = 0.d0 - List_all_comb_b3_cent = 0.d0 - - if((j1b_type .eq. 3) .or. (j1b_type .eq. 103)) then - - do i = 1, List_all_comb_b3_size - - do j = 1, nucl_num - tmp_alphaj = dble(List_all_comb_b3(j,i)) * j1b_pen(j) - List_all_comb_b3_expo(i) += tmp_alphaj - List_all_comb_b3_cent(1,i) += tmp_alphaj * nucl_coord(j,1) - List_all_comb_b3_cent(2,i) += tmp_alphaj * nucl_coord(j,2) - List_all_comb_b3_cent(3,i) += tmp_alphaj * nucl_coord(j,3) - - enddo - - if(List_all_comb_b3_expo(i) .lt. 1d-10) cycle - ASSERT(List_all_comb_b3_expo(i) .gt. 0d0) - - List_all_comb_b3_cent(1,i) = List_all_comb_b3_cent(1,i) / List_all_comb_b3_expo(i) - List_all_comb_b3_cent(2,i) = List_all_comb_b3_cent(2,i) / List_all_comb_b3_expo(i) - List_all_comb_b3_cent(3,i) = List_all_comb_b3_cent(3,i) / List_all_comb_b3_expo(i) - enddo - - ! --- - - do i = 1, List_all_comb_b3_size - - do j = 2, nucl_num, 1 - tmp_alphaj = dble(List_all_comb_b3(j,i)) * j1b_pen(j) - do k = 1, j-1, 1 - tmp_alphak = dble(List_all_comb_b3(k,i)) * j1b_pen(k) - - List_all_comb_b3_coef(i) += tmp_alphaj * tmp_alphak * ( (nucl_coord(j,1) - nucl_coord(k,1)) * (nucl_coord(j,1) - nucl_coord(k,1)) & - + (nucl_coord(j,2) - nucl_coord(k,2)) * (nucl_coord(j,2) - nucl_coord(k,2)) & - + (nucl_coord(j,3) - nucl_coord(k,3)) * (nucl_coord(j,3) - nucl_coord(k,3)) ) - enddo - enddo - - if(List_all_comb_b3_expo(i) .lt. 1d-10) cycle - - List_all_comb_b3_coef(i) = List_all_comb_b3_coef(i) / List_all_comb_b3_expo(i) - enddo - - ! --- - - do i = 1, List_all_comb_b3_size - - facto = 1.d0 - phase = 0 - do j = 1, nucl_num - tmp_alphaj = dble(List_all_comb_b3(j,i)) - - facto *= 2.d0 / (gamma(tmp_alphaj+1.d0) * gamma(3.d0-tmp_alphaj)) - phase += List_all_comb_b3(j,i) - enddo - - List_all_comb_b3_coef(i) = (-1.d0)**dble(phase) * facto * dexp(-List_all_comb_b3_coef(i)) - enddo - - elseif((j1b_type .eq. 4) .or. (j1b_type .eq. 104)) then - - ii = 1 - List_all_comb_b3_coef( ii) = 1.d0 - List_all_comb_b3_expo( ii) = 0.d0 - List_all_comb_b3_cent(1:3,ii) = 0.d0 - - do i = 1, nucl_num - ii = ii + 1 - List_all_comb_b3_coef( ii) = -2.d0 * j1b_pen_coef(i) - List_all_comb_b3_expo( ii) = j1b_pen(i) - List_all_comb_b3_cent(1,ii) = nucl_coord(i,1) - List_all_comb_b3_cent(2,ii) = nucl_coord(i,2) - List_all_comb_b3_cent(3,ii) = nucl_coord(i,3) - enddo - - do i = 1, nucl_num - ii = ii + 1 - List_all_comb_b3_coef( ii) = 1.d0 * j1b_pen_coef(i) * j1b_pen_coef(i) - List_all_comb_b3_expo( ii) = 2.d0 * j1b_pen(i) - List_all_comb_b3_cent(1,ii) = nucl_coord(i,1) - List_all_comb_b3_cent(2,ii) = nucl_coord(i,2) - List_all_comb_b3_cent(3,ii) = nucl_coord(i,3) - enddo - - do i = 1, nucl_num-1 - - tmp1 = j1b_pen(i) - - xi = nucl_coord(i,1) - yi = nucl_coord(i,2) - zi = nucl_coord(i,3) - - do j = i+1, nucl_num - - tmp2 = j1b_pen(j) - tmp3 = tmp1 + tmp2 - tmp4 = 1.d0 / tmp3 - - xj = nucl_coord(j,1) - yj = nucl_coord(j,2) - zj = nucl_coord(j,3) - - dx = xi - xj - dy = yi - yj - dz = zi - zj - r2 = dx*dx + dy*dy + dz*dz - - ii = ii + 1 - ! x 2 to avoid doing integrals twice - List_all_comb_b3_coef( ii) = 2.d0 * dexp(-tmp1*tmp2*tmp4*r2) * j1b_pen_coef(i) * j1b_pen_coef(j) - List_all_comb_b3_expo( ii) = tmp3 - List_all_comb_b3_cent(1,ii) = tmp4 * (tmp1 * xi + tmp2 * xj) - List_all_comb_b3_cent(2,ii) = tmp4 * (tmp1 * yi + tmp2 * yj) - List_all_comb_b3_cent(3,ii) = tmp4 * (tmp1 * zi + tmp2 * zj) - enddo - enddo - - else - - print *, 'j1b_type = ', j1b_type, 'is not implemented' - stop - - endif - - !print *, ' coeff, expo & cent of list b3' - !do i = 1, List_all_comb_b3_size - ! print*, i, List_all_comb_b3_coef(i), List_all_comb_b3_expo(i) - ! print*, List_all_comb_b3_cent(1,i), List_all_comb_b3_cent(2,i), List_all_comb_b3_cent(3,i) - !enddo - -END_PROVIDER - -! --- - diff --git a/src/ao_many_one_e_ints/listj1b_sorted.irp.f b/src/ao_many_one_e_ints/listj1b_sorted.irp.f deleted file mode 100644 index 9bcce449..00000000 --- a/src/ao_many_one_e_ints/listj1b_sorted.irp.f +++ /dev/null @@ -1,181 +0,0 @@ - - BEGIN_PROVIDER [ integer, List_comb_thr_b2_size, (ao_num, ao_num)] -&BEGIN_PROVIDER [ integer, max_List_comb_thr_b2_size] - implicit none - integer :: i_1s,i,j,ipoint - double precision :: coef,beta,center(3),int_j1b - double precision :: r(3),weight,dist - List_comb_thr_b2_size = 0 - print*,'List_all_comb_b2_size = ',List_all_comb_b2_size -! pause - do i = 1, ao_num - do j = i, ao_num - do i_1s = 1, List_all_comb_b2_size - coef = List_all_comb_b2_coef (i_1s) - if(dabs(coef).lt.thrsh_cycle_tc)cycle - beta = List_all_comb_b2_expo (i_1s) - beta = max(beta,1.d-12) - center(1:3) = List_all_comb_b2_cent(1:3,i_1s) - int_j1b = 0.d0 - do ipoint = 1, n_points_extra_final_grid - r(1:3) = final_grid_points_extra(1:3,ipoint) - weight = final_weight_at_r_vector_extra(ipoint) - dist = ( center(1) - r(1) )*( center(1) - r(1) ) - dist += ( center(2) - r(2) )*( center(2) - r(2) ) - dist += ( center(3) - r(3) )*( center(3) - r(3) ) - int_j1b += dabs(aos_in_r_array_extra_transp(ipoint,i) * aos_in_r_array_extra_transp(ipoint,j))*dexp(-beta*dist) * weight - enddo - if(dabs(coef)*dabs(int_j1b).gt.thrsh_cycle_tc)then - List_comb_thr_b2_size(j,i) += 1 - endif - enddo - enddo - enddo - do i = 1, ao_num - do j = 1, i-1 - List_comb_thr_b2_size(j,i) = List_comb_thr_b2_size(i,j) - enddo - enddo - integer :: list(ao_num) - do i = 1, ao_num - list(i) = maxval(List_comb_thr_b2_size(:,i)) - enddo - max_List_comb_thr_b2_size = maxval(list) - print*,'max_List_comb_thr_b2_size = ',max_List_comb_thr_b2_size - -END_PROVIDER - - BEGIN_PROVIDER [ double precision, List_comb_thr_b2_coef, ( max_List_comb_thr_b2_size,ao_num, ao_num )] -&BEGIN_PROVIDER [ double precision, List_comb_thr_b2_expo, ( max_List_comb_thr_b2_size,ao_num, ao_num )] -&BEGIN_PROVIDER [ double precision, List_comb_thr_b2_cent, (3, max_List_comb_thr_b2_size,ao_num, ao_num )] -&BEGIN_PROVIDER [ double precision, ao_abs_comb_b2_j1b, ( max_List_comb_thr_b2_size ,ao_num, ao_num)] - implicit none - integer :: i_1s,i,j,ipoint,icount - double precision :: coef,beta,center(3),int_j1b - double precision :: r(3),weight,dist - ao_abs_comb_b2_j1b = 10000000.d0 - do i = 1, ao_num - do j = i, ao_num - icount = 0 - do i_1s = 1, List_all_comb_b2_size - coef = List_all_comb_b2_coef (i_1s) - if(dabs(coef).lt.thrsh_cycle_tc)cycle - beta = List_all_comb_b2_expo (i_1s) - center(1:3) = List_all_comb_b2_cent(1:3,i_1s) - int_j1b = 0.d0 - do ipoint = 1, n_points_extra_final_grid - r(1:3) = final_grid_points_extra(1:3,ipoint) - weight = final_weight_at_r_vector_extra(ipoint) - dist = ( center(1) - r(1) )*( center(1) - r(1) ) - dist += ( center(2) - r(2) )*( center(2) - r(2) ) - dist += ( center(3) - r(3) )*( center(3) - r(3) ) - int_j1b += dabs(aos_in_r_array_extra_transp(ipoint,i) * aos_in_r_array_extra_transp(ipoint,j))*dexp(-beta*dist) * weight - enddo - if(dabs(coef)*dabs(int_j1b).gt.thrsh_cycle_tc)then - icount += 1 - List_comb_thr_b2_coef(icount,j,i) = coef - List_comb_thr_b2_expo(icount,j,i) = beta - List_comb_thr_b2_cent(1:3,icount,j,i) = center(1:3) - ao_abs_comb_b2_j1b(icount,j,i) = int_j1b - endif - enddo - enddo - enddo - - do i = 1, ao_num - do j = 1, i-1 - do icount = 1, List_comb_thr_b2_size(j,i) - List_comb_thr_b2_coef(icount,j,i) = List_comb_thr_b2_coef(icount,i,j) - List_comb_thr_b2_expo(icount,j,i) = List_comb_thr_b2_expo(icount,i,j) - List_comb_thr_b2_cent(1:3,icount,j,i) = List_comb_thr_b2_cent(1:3,icount,i,j) - enddo - enddo - enddo - -END_PROVIDER - - - BEGIN_PROVIDER [ integer, List_comb_thr_b3_size, (ao_num, ao_num)] -&BEGIN_PROVIDER [ integer, max_List_comb_thr_b3_size] - implicit none - integer :: i_1s,i,j,ipoint - double precision :: coef,beta,center(3),int_j1b - double precision :: r(3),weight,dist - List_comb_thr_b3_size = 0 - print*,'List_all_comb_b3_size = ',List_all_comb_b3_size - do i = 1, ao_num - do j = 1, ao_num - do i_1s = 1, List_all_comb_b3_size - coef = List_all_comb_b3_coef (i_1s) - beta = List_all_comb_b3_expo (i_1s) - center(1:3) = List_all_comb_b3_cent(1:3,i_1s) - if(dabs(coef).lt.thrsh_cycle_tc)cycle - int_j1b = 0.d0 - do ipoint = 1, n_points_extra_final_grid - r(1:3) = final_grid_points_extra(1:3,ipoint) - weight = final_weight_at_r_vector_extra(ipoint) - dist = ( center(1) - r(1) )*( center(1) - r(1) ) - dist += ( center(2) - r(2) )*( center(2) - r(2) ) - dist += ( center(3) - r(3) )*( center(3) - r(3) ) - int_j1b += dabs(aos_in_r_array_extra_transp(ipoint,i) * aos_in_r_array_extra_transp(ipoint,j))*dexp(-beta*dist) * weight - enddo - if(dabs(coef)*dabs(int_j1b).gt.thrsh_cycle_tc)then - List_comb_thr_b3_size(j,i) += 1 - endif - enddo - enddo - enddo -! do i = 1, ao_num -! do j = 1, i-1 -! List_comb_thr_b3_size(j,i) = List_comb_thr_b3_size(i,j) -! enddo -! enddo - integer :: list(ao_num) - do i = 1, ao_num - list(i) = maxval(List_comb_thr_b3_size(:,i)) - enddo - max_List_comb_thr_b3_size = maxval(list) - print*,'max_List_comb_thr_b3_size = ',max_List_comb_thr_b3_size - -END_PROVIDER - - BEGIN_PROVIDER [ double precision, List_comb_thr_b3_coef, ( max_List_comb_thr_b3_size,ao_num, ao_num )] -&BEGIN_PROVIDER [ double precision, List_comb_thr_b3_expo, ( max_List_comb_thr_b3_size,ao_num, ao_num )] -&BEGIN_PROVIDER [ double precision, List_comb_thr_b3_cent, (3, max_List_comb_thr_b3_size,ao_num, ao_num )] -&BEGIN_PROVIDER [ double precision, ao_abs_comb_b3_j1b, ( max_List_comb_thr_b3_size ,ao_num, ao_num)] - implicit none - integer :: i_1s,i,j,ipoint,icount - double precision :: coef,beta,center(3),int_j1b - double precision :: r(3),weight,dist - ao_abs_comb_b3_j1b = 10000000.d0 - do i = 1, ao_num - do j = 1, ao_num - icount = 0 - do i_1s = 1, List_all_comb_b3_size - coef = List_all_comb_b3_coef (i_1s) - beta = List_all_comb_b3_expo (i_1s) - beta = max(beta,1.d-12) - center(1:3) = List_all_comb_b3_cent(1:3,i_1s) - if(dabs(coef).lt.thrsh_cycle_tc)cycle - int_j1b = 0.d0 - do ipoint = 1, n_points_extra_final_grid - r(1:3) = final_grid_points_extra(1:3,ipoint) - weight = final_weight_at_r_vector_extra(ipoint) - dist = ( center(1) - r(1) )*( center(1) - r(1) ) - dist += ( center(2) - r(2) )*( center(2) - r(2) ) - dist += ( center(3) - r(3) )*( center(3) - r(3) ) - int_j1b += dabs(aos_in_r_array_extra_transp(ipoint,i) * aos_in_r_array_extra_transp(ipoint,j))*dexp(-beta*dist) * weight - enddo - if(dabs(coef)*dabs(int_j1b).gt.thrsh_cycle_tc)then - icount += 1 - List_comb_thr_b3_coef(icount,j,i) = coef - List_comb_thr_b3_expo(icount,j,i) = beta - List_comb_thr_b3_cent(1:3,icount,j,i) = center(1:3) - ao_abs_comb_b3_j1b(icount,j,i) = int_j1b - endif - enddo - enddo - enddo - -END_PROVIDER - diff --git a/src/ao_one_e_ints/kin_ao_ints.irp.f b/src/ao_one_e_ints/kin_ao_ints.irp.f index a5ee0670..3a97d095 100644 --- a/src/ao_one_e_ints/kin_ao_ints.irp.f +++ b/src/ao_one_e_ints/kin_ao_ints.irp.f @@ -52,7 +52,7 @@ !$OMP DEFAULT(NONE) & !$OMP PRIVATE(A_center,B_center,power_A,power_B,& !$OMP overlap_y, overlap_z, overlap, & - !$OMP alpha, beta,i,j,c,d_a_2,d_2,deriv_tmp, & + !$OMP alpha, beta, n, l, i,j,c,d_a_2,d_2,deriv_tmp, & !$OMP overlap_x0,overlap_y0,overlap_z0) & !$OMP SHARED(nucl_coord,ao_power,ao_prim_num, & !$OMP ao_deriv2_x,ao_deriv2_y,ao_deriv2_z,ao_num,ao_coef_normalized_ordered_transp,ao_nucl, & diff --git a/src/ao_two_e_erf_ints/EZFIO.cfg b/src/ao_two_e_erf_ints/EZFIO.cfg deleted file mode 100644 index 0af0e1d8..00000000 --- a/src/ao_two_e_erf_ints/EZFIO.cfg +++ /dev/null @@ -1,13 +0,0 @@ -[io_ao_two_e_integrals_erf] -type: Disk_access -doc: Read/Write |AO| integrals with the long range interaction from/to disk [ Write | Read | None ] -interface: ezfio,provider,ocaml -default: None - -[mu_erf] -type: double precision -doc: cutting of the interaction in the range separated model -interface: ezfio,provider,ocaml -default: 0.5 -ezfio_name: mu_erf - diff --git a/src/ao_two_e_erf_ints/NEED b/src/ao_two_e_erf_ints/NEED deleted file mode 100644 index b30cc39d..00000000 --- a/src/ao_two_e_erf_ints/NEED +++ /dev/null @@ -1 +0,0 @@ -ao_two_e_ints diff --git a/src/ao_two_e_erf_ints/README.rst b/src/ao_two_e_erf_ints/README.rst deleted file mode 100644 index 45c72b84..00000000 --- a/src/ao_two_e_erf_ints/README.rst +++ /dev/null @@ -1,19 +0,0 @@ -====================== -ao_two_e_erf_ints -====================== - -Here, all two-electron integrals (:math:`erf(\mu r_{12})/r_{12}`) are computed. -As they have 4 indices and many are zero, they are stored in a map, as defined -in :file:`utils/map_module.f90`. - -The main parameter of this module is :option:`ao_two_e_erf_ints mu_erf` which is the range-separation parameter. - -To fetch an |AO| integral, use the -`get_ao_two_e_integral_erf(i,j,k,l,ao_integrals_erf_map)` function. - - -The conventions are: -* For |AO| integrals : (ij|kl) = (11|22) = = <12|12> - - - diff --git a/src/ao_two_e_ints/EZFIO.cfg b/src/ao_two_e_ints/EZFIO.cfg index 9c017813..ff932b0c 100644 --- a/src/ao_two_e_ints/EZFIO.cfg +++ b/src/ao_two_e_ints/EZFIO.cfg @@ -35,3 +35,15 @@ type: logical doc: Perform Cholesky decomposition of AO integrals interface: ezfio,provider,ocaml default: False + +[io_ao_two_e_integrals_erf] +type: Disk_access +doc: Read/Write |AO| erf integrals from/to disk [ Write | Read | None ] +interface: ezfio,provider,ocaml +default: None + +[use_only_lr] +type: logical +doc: If true, use only the long range part of the two-electron integrals instead of 1/r12 +interface: ezfio, provider, ocaml +default: False diff --git a/src/ao_two_e_ints/NEED b/src/ao_two_e_ints/NEED index ffc5e8be..542962ec 100644 --- a/src/ao_two_e_ints/NEED +++ b/src/ao_two_e_ints/NEED @@ -1,3 +1,4 @@ +hamiltonian ao_one_e_ints pseudo bitmask diff --git a/src/ao_two_e_erf_ints/integrals_erf_in_map_slave.irp.f b/src/ao_two_e_ints/integrals_erf_in_map_slave.irp.f similarity index 100% rename from src/ao_two_e_erf_ints/integrals_erf_in_map_slave.irp.f rename to src/ao_two_e_ints/integrals_erf_in_map_slave.irp.f diff --git a/src/ao_two_e_erf_ints/map_integrals_erf.irp.f b/src/ao_two_e_ints/map_integrals_erf.irp.f similarity index 100% rename from src/ao_two_e_erf_ints/map_integrals_erf.irp.f rename to src/ao_two_e_ints/map_integrals_erf.irp.f diff --git a/src/ao_two_e_erf_ints/providers_ao_erf.irp.f b/src/ao_two_e_ints/providers_ao_erf.irp.f similarity index 98% rename from src/ao_two_e_erf_ints/providers_ao_erf.irp.f rename to src/ao_two_e_ints/providers_ao_erf.irp.f index 293df29f..ff8c31a2 100644 --- a/src/ao_two_e_erf_ints/providers_ao_erf.irp.f +++ b/src/ao_two_e_ints/providers_ao_erf.irp.f @@ -90,7 +90,7 @@ BEGIN_PROVIDER [ logical, ao_two_e_integrals_erf_in_map ] if (write_ao_two_e_integrals_erf) then call ezfio_set_work_empty(.False.) call map_save_to_disk(trim(ezfio_filename)//'/work/ao_ints_erf',ao_integrals_erf_map) - call ezfio_set_ao_two_e_erf_ints_io_ao_two_e_integrals_erf("Read") + call ezfio_set_ao_two_e_ints_io_ao_two_e_integrals_erf('Read') endif END_PROVIDER diff --git a/src/ao_two_e_erf_ints/routines_save_integrals_erf.irp.f b/src/ao_two_e_ints/routines_save_integrals_erf.irp.f similarity index 88% rename from src/ao_two_e_erf_ints/routines_save_integrals_erf.irp.f rename to src/ao_two_e_ints/routines_save_integrals_erf.irp.f index 4b0cfad0..d980bc05 100644 --- a/src/ao_two_e_erf_ints/routines_save_integrals_erf.irp.f +++ b/src/ao_two_e_ints/routines_save_integrals_erf.irp.f @@ -4,7 +4,7 @@ subroutine save_erf_two_e_integrals_ao PROVIDE ao_two_e_integrals_erf_in_map call ezfio_set_work_empty(.False.) call map_save_to_disk(trim(ezfio_filename)//'/work/ao_ints_erf',ao_integrals_erf_map) - call ezfio_set_ao_two_e_erf_ints_io_ao_two_e_integrals_erf('Read') + call ezfio_set_ao_two_e_ints_io_ao_two_e_integrals_erf('Read') end subroutine save_erf_two_e_ints_ao_into_ints_ao diff --git a/src/ao_two_e_ints/two_e_integrals.irp.f b/src/ao_two_e_ints/two_e_integrals.irp.f index 148ebb62..b55b5f0d 100644 --- a/src/ao_two_e_ints/two_e_integrals.irp.f +++ b/src/ao_two_e_ints/two_e_integrals.irp.f @@ -21,9 +21,9 @@ double precision function ao_two_e_integral(i, j, k, l) double precision :: P_new(0:max_dim,3),P_center(3),fact_p,pp double precision :: Q_new(0:max_dim,3),Q_center(3),fact_q,qq - double precision :: ao_two_e_integral_schwartz_accel - - double precision :: ao_two_e_integral_cosgtos + double precision, external :: ao_two_e_integral_erf + double precision, external :: ao_two_e_integral_cosgtos + double precision, external :: ao_two_e_integral_schwartz_accel if(use_cosgtos) then @@ -31,13 +31,15 @@ double precision function ao_two_e_integral(i, j, k, l) ao_two_e_integral = ao_two_e_integral_cosgtos(i, j, k, l) - else + else if (use_only_lr) then - if (ao_prim_num(i) * ao_prim_num(j) * ao_prim_num(k) * ao_prim_num(l) > 1024 ) then + ao_two_e_integral = ao_two_e_integral_erf(i, j, k, l) + + else if (ao_prim_num(i) * ao_prim_num(j) * ao_prim_num(k) * ao_prim_num(l) > 1024 ) then ao_two_e_integral = ao_two_e_integral_schwartz_accel(i,j,k,l) - else + else dim1 = n_pt_max_integrals @@ -117,8 +119,6 @@ double precision function ao_two_e_integral(i, j, k, l) enddo ! q enddo ! p - endif - endif endif diff --git a/src/ao_two_e_erf_ints/two_e_integrals_erf.irp.f b/src/ao_two_e_ints/two_e_integrals_erf.irp.f similarity index 100% rename from src/ao_two_e_erf_ints/two_e_integrals_erf.irp.f rename to src/ao_two_e_ints/two_e_integrals_erf.irp.f diff --git a/src/casscf_cipsi/50.casscf.bats b/src/casscf_cipsi/50.casscf.bats index a0db725d..9f63dfe2 100644 --- a/src/casscf_cipsi/50.casscf.bats +++ b/src/casscf_cipsi/50.casscf.bats @@ -9,8 +9,8 @@ function run_stoch() { test_exe casscf || skip qp set perturbation do_pt2 True qp set determinants n_det_max $3 - qp set davidson threshold_davidson 1.e-10 - qp set davidson n_states_diag 4 + qp set davidson_keywords threshold_davidson 1.e-10 + qp set davidson_keywords n_states_diag 4 qp run casscf | tee casscf.out energy1="$(ezfio get casscf energy_pt2 | tr '[]' ' ' | cut -d ',' -f 1)" eq $energy1 $1 $thresh diff --git a/src/casscf_cipsi/EZFIO.cfg b/src/casscf_cipsi/EZFIO.cfg index 2a1f1926..18e0b6b1 100644 --- a/src/casscf_cipsi/EZFIO.cfg +++ b/src/casscf_cipsi/EZFIO.cfg @@ -73,3 +73,9 @@ type: logical doc: If |true|, the pt2_max value in the CIPSI iterations will automatically adapt, otherwise it is fixed at the value given in the EZFIO folder interface: ezfio,provider,ocaml default: True + +[small_active_space] +type: logical +doc: If |true|, the pt2_max value in the CIPSI is set to 10-10 and will not change +interface: ezfio,provider,ocaml +default: False diff --git a/src/casscf_cipsi/README.rst b/src/casscf_cipsi/README.rst index 08bfd95b..f84cde75 100644 --- a/src/casscf_cipsi/README.rst +++ b/src/casscf_cipsi/README.rst @@ -3,3 +3,45 @@ casscf ====== |CASSCF| program with the CIPSI algorithm. + +Example of inputs +----------------- + +a) Small active space : standard CASSCF +--------------------------------------- +Let's do O2 (triplet) in aug-cc-pvdz with the following geometry (xyz format, Bohr units) +3 + + O 0.0000000000 0.0000000000 -1.1408000000 + O 0.0000000000 0.0000000000 1.1408000000 + +# Create the ezfio folder +qp create_ezfio -b aug-cc-pvdz O2.xyz -m 3 -a -o O2_avdz + +# Start with an ROHF guess +qp run scf | tee ${EZFIO_FILE}.rohf.out + +# Get the ROHF energy for check +qp get hartree_fock energy # should be -149.4684509 + +# Define the full valence active space: the two 1s are doubly occupied, the other 8 valence orbitals are active +# CASSCF(12e,10orb) +qp set_mo_class -c "[1-2]" -a "[3-10]" -v "[11-46]" + +# Specify that you want an near exact CASSCF, i.e. the CIPSI selection will stop at pt2_max = 10^-10 +qp set casscf_cipsi small_active_space True +# RUN THE CASSCF +qp run casscf | tee ${EZFIO_FILE}.casscf.out +# you should find around -149.7243542 + + +b) Large active space : Exploit the selected CI in the active space +------------------------------------------------------------------- +#Let us start from the small active space calculation orbitals and add another 10 virtuals: CASSCF(12e,20orb) +qp set_mo_class -c "[1-2]" -a "[3-20]" -v "[21-46]" +# As this active space is larger, you unset the small_active_space feature +qp set casscf_cipsi small_active_space False +# As it is a large active space, the energy convergence thereshold is set to be 0.0001 +qp run casscf | tee ${EZFIO_FILE}.casscf_large.out +# you should find around -149.9046 + diff --git a/src/casscf_cipsi/casscf.irp.f b/src/casscf_cipsi/casscf.irp.f index 02954ebf..addca236 100644 --- a/src/casscf_cipsi/casscf.irp.f +++ b/src/casscf_cipsi/casscf.irp.f @@ -8,17 +8,23 @@ program casscf ! touch no_vvvv_integrals n_det_max_full = 500 touch n_det_max_full - pt2_relative_error = 0.04 + if(small_active_space)then + pt2_relative_error = 0.00001 + else + thresh_scf = 1.d-4 + pt2_relative_error = 0.04 + endif touch pt2_relative_error -! call run_stochastic_cipsi call run end subroutine run implicit none - double precision :: energy_old, energy, pt2_max_before, ept2_before,delta_E + double precision :: energy_old, energy, pt2_max_before,delta_E logical :: converged,state_following_casscf_cipsi_save - integer :: iteration + integer :: iteration,istate + double precision, allocatable :: E_PT2(:), PT2(:), Ev(:), ept2_before(:) + allocate(E_PT2(N_states), PT2(N_states), Ev(N_states), ept2_before(N_states)) converged = .False. energy = 0.d0 @@ -28,13 +34,20 @@ subroutine run state_following_casscf = .True. touch state_following_casscf ept2_before = 0.d0 - if(adaptive_pt2_max)then - pt2_max = 0.005 + if(small_active_space)then + pt2_max = 1.d-10 SOFT_TOUCH pt2_max + else + if(adaptive_pt2_max)then + pt2_max = 0.005 + SOFT_TOUCH pt2_max + endif endif do while (.not.converged) print*,'pt2_max = ',pt2_max - call run_stochastic_cipsi + call run_stochastic_cipsi(Ev,PT2) + print*,'Ev,PT2',Ev(1),PT2(1) + E_PT2(1:N_states) = Ev(1:N_states) + PT2(1:N_states) energy_old = energy energy = eone+etwo+ecore pt2_max_before = pt2_max @@ -42,15 +55,15 @@ subroutine run call write_time(6) call write_int(6,iteration,'CAS-SCF iteration = ') call write_double(6,energy,'CAS-SCF energy = ') - if(n_states == 1)then - double precision :: E_PT2, PT2 - call ezfio_get_casscf_cipsi_energy_pt2(E_PT2) - call ezfio_get_casscf_cipsi_energy(PT2) - PT2 -= E_PT2 - call write_double(6,E_PT2,'E + PT2 energy = ') - call write_double(6,PT2,' PT2 = ') +! if(n_states == 1)then +! call ezfio_get_casscf_cipsi_energy_pt2(E_PT2) +! call ezfio_get_casscf_cipsi_energy(PT2) + do istate=1,N_states + call write_double(6,E_PT2(istate),'E + PT2 energy = ') + call write_double(6,PT2(istate),' PT2 = ') + enddo call write_double(6,pt2_max,' PT2_MAX = ') - endif +! endif print*,'' call write_double(6,norm_grad_vec2,'Norm of gradients = ') @@ -65,15 +78,20 @@ subroutine run else if (criterion_casscf == "gradients")then converged = norm_grad_vec2 < thresh_scf else if (criterion_casscf == "e_pt2")then - delta_E = dabs(E_PT2 - ept2_before) + delta_E = 0.d0 + do istate = 1, N_states + delta_E += dabs(E_PT2(istate) - ept2_before(istate)) + enddo converged = dabs(delta_E) < thresh_casscf endif ept2_before = E_PT2 - if(adaptive_pt2_max)then - pt2_max = dabs(energy_improvement / (pt2_relative_error)) - pt2_max = min(pt2_max, pt2_max_before) - if(n_act_orb.ge.n_big_act_orb)then - pt2_max = max(pt2_max,pt2_min_casscf) + if(.not.small_active_space)then + if(adaptive_pt2_max)then + pt2_max = dabs(energy_improvement / (pt2_relative_error)) + pt2_max = min(pt2_max, pt2_max_before) + if(n_act_orb.ge.n_big_act_orb)then + pt2_max = max(pt2_max,pt2_min_casscf) + endif endif endif print*,'' @@ -94,8 +112,10 @@ subroutine run read_wf = .True. call clear_mo_map SOFT_TOUCH mo_coef N_det psi_det psi_coef - if(adaptive_pt2_max)then - SOFT_TOUCH pt2_max + if(.not.small_active_space)then + if(adaptive_pt2_max)then + SOFT_TOUCH pt2_max + endif endif if(iteration .gt. 3)then state_following_casscf = state_following_casscf_cipsi_save @@ -104,6 +124,25 @@ subroutine run endif enddo + integer :: i + print*,'Converged CASSCF ' + print*,'--------------------------' + write(6,*) ' occupation numbers of orbitals ' + do i=1,mo_num + write(6,*) i,occnum(i) + end do + print*,'--------------' +! +! write(6,*) +! write(6,*) ' the diagonal of the inactive effective Fock matrix ' +! write(6,'(5(i3,F12.5))') (i,Fipq(i,i),i=1,mo_num) +! write(6,*) + print*,'Fock MCSCF' + do i = 1, mo_num + write(*,*)i,mcscf_fock_diag_mo(i) +! write(*,*)mcscf_fock_alpha_mo(i,i) + enddo + end diff --git a/src/casscf_cipsi/densities.irp.f b/src/casscf_cipsi/densities.irp.f index bebcf5d7..54ff86e1 100644 --- a/src/casscf_cipsi/densities.irp.f +++ b/src/casscf_cipsi/densities.irp.f @@ -17,6 +17,35 @@ BEGIN_PROVIDER [real*8, D0tu, (n_act_orb,n_act_orb) ] END_PROVIDER + BEGIN_PROVIDER [double precision, D0tu_alpha_ao, (ao_num, ao_num)] +&BEGIN_PROVIDER [double precision, D0tu_beta_ao, (ao_num, ao_num)] + implicit none + integer :: i,ii,j,u,t,uu,tt + double precision, allocatable :: D0_tmp_alpha(:,:),D0_tmp_beta(:,:) + allocate(D0_tmp_alpha(mo_num, mo_num),D0_tmp_beta(mo_num, mo_num)) + D0_tmp_beta = 0.d0 + D0_tmp_alpha = 0.d0 + do i = 1, n_core_inact_orb + ii = list_core_inact(i) + D0_tmp_alpha(ii,ii) = 1.d0 + D0_tmp_beta(ii,ii) = 1.d0 + enddo + print*,'Diagonal elements of the 1RDM in the active space' + do u=1,n_act_orb + uu = list_act(u) + print*,uu,one_e_dm_mo_alpha_average(uu,uu),one_e_dm_mo_beta_average(uu,uu) + do t=1,n_act_orb + tt = list_act(t) + D0_tmp_alpha(tt,uu) = one_e_dm_mo_alpha_average(tt,uu) + D0_tmp_beta(tt,uu) = one_e_dm_mo_beta_average(tt,uu) + enddo + enddo + + call mo_to_ao_no_overlap(D0_tmp_alpha,mo_num,D0tu_alpha_ao,ao_num) + call mo_to_ao_no_overlap(D0_tmp_beta,mo_num,D0tu_beta_ao,ao_num) + +END_PROVIDER + BEGIN_PROVIDER [real*8, P0tuvx, (n_act_orb,n_act_orb,n_act_orb,n_act_orb) ] BEGIN_DOC ! The second-order density matrix in the basis of the starting MOs ONLY IN THE RANGE OF ACTIVE MOS diff --git a/src/casscf_cipsi/mcscf_fock.irp.f b/src/casscf_cipsi/mcscf_fock.irp.f index e4568405..0f4b7a99 100644 --- a/src/casscf_cipsi/mcscf_fock.irp.f +++ b/src/casscf_cipsi/mcscf_fock.irp.f @@ -77,4 +77,119 @@ BEGIN_PROVIDER [real*8, Fapq, (mo_num,mo_num) ] END_PROVIDER - + BEGIN_PROVIDER [ double precision, mcscf_fock_alpha_ao, (ao_num, ao_num)] +&BEGIN_PROVIDER [ double precision, mcscf_fock_beta_ao, (ao_num, ao_num)] + implicit none + BEGIN_DOC + ! mcscf_fock_alpha_ao are set to usual Fock like operator but computed with the MCSCF densities on the AO basis + END_DOC + SCF_density_matrix_ao_alpha = D0tu_alpha_ao + SCF_density_matrix_ao_beta = D0tu_beta_ao + soft_touch SCF_density_matrix_ao_alpha SCF_density_matrix_ao_beta + mcscf_fock_beta_ao = fock_matrix_ao_beta + mcscf_fock_alpha_ao = fock_matrix_ao_alpha +END_PROVIDER + + + BEGIN_PROVIDER [ double precision, mcscf_fock_alpha_mo, (mo_num, mo_num)] +&BEGIN_PROVIDER [ double precision, mcscf_fock_beta_mo, (mo_num, mo_num)] + implicit none + BEGIN_DOC + ! Mo_mcscf_fock_alpha are set to usual Fock like operator but computed with the MCSCF densities on the MO basis + END_DOC + + call ao_to_mo(mcscf_fock_alpha_ao,ao_num,mcscf_fock_alpha_mo,mo_num) + call ao_to_mo(mcscf_fock_beta_ao,ao_num,mcscf_fock_beta_mo,mo_num) + +END_PROVIDER + + BEGIN_PROVIDER [ double precision, mcscf_fock_mo, (mo_num,mo_num) ] +&BEGIN_PROVIDER [ double precision, mcscf_fock_diag_mo, (mo_num)] + implicit none + BEGIN_DOC + ! MCSF Fock matrix on the MO basis. + ! For open shells, the ROHF Fock Matrix is :: + ! + ! | Rcc | F^b | Fcv | + ! |-----------------------| + ! | F^b | Roo | F^a | + ! |-----------------------| + ! | Fcv | F^a | Rvv | + ! + ! C: Core, O: Open, V: Virtual + ! + ! Rcc = Acc Fcc^a + Bcc Fcc^b + ! Roo = Aoo Foo^a + Boo Foo^b + ! Rvv = Avv Fvv^a + Bvv Fvv^b + ! Fcv = (F^a + F^b)/2 + ! + ! F^a: Fock matrix alpha (MO), F^b: Fock matrix beta (MO) + ! A,B: Coupling parameters + ! + ! J. Chem. Phys. 133, 141102 (2010), https://doi.org/10.1063/1.3503173 + ! Coupling parameters from J. Chem. Phys. 125, 204110 (2006); https://doi.org/10.1063/1.2393223. + ! cc oo vv + ! A -0.5 0.5 1.5 + ! B 1.5 0.5 -0.5 + ! + END_DOC + integer :: i,j,n + if (elec_alpha_num == elec_beta_num) then + mcscf_fock_mo = mcscf_fock_alpha_mo + else + ! Core + do j = 1, elec_beta_num + ! Core + do i = 1, elec_beta_num + mcscf_fock_mo(i,j) = - 0.5d0 * mcscf_fock_alpha_mo(i,j) & + + 1.5d0 * mcscf_fock_beta_mo(i,j) + enddo + ! Open + do i = elec_beta_num+1, elec_alpha_num + mcscf_fock_mo(i,j) = mcscf_fock_beta_mo(i,j) + enddo + ! Virtual + do i = elec_alpha_num+1, mo_num + mcscf_fock_mo(i,j) = 0.5d0 * mcscf_fock_alpha_mo(i,j) & + + 0.5d0 * mcscf_fock_beta_mo(i,j) + enddo + enddo + ! Open + do j = elec_beta_num+1, elec_alpha_num + ! Core + do i = 1, elec_beta_num + mcscf_fock_mo(i,j) = mcscf_fock_beta_mo(i,j) + enddo + ! Open + do i = elec_beta_num+1, elec_alpha_num + mcscf_fock_mo(i,j) = 0.5d0 * mcscf_fock_alpha_mo(i,j) & + + 0.5d0 * mcscf_fock_beta_mo(i,j) + enddo + ! Virtual + do i = elec_alpha_num+1, mo_num + mcscf_fock_mo(i,j) = mcscf_fock_alpha_mo(i,j) + enddo + enddo + ! Virtual + do j = elec_alpha_num+1, mo_num + ! Core + do i = 1, elec_beta_num + mcscf_fock_mo(i,j) = 0.5d0 * mcscf_fock_alpha_mo(i,j) & + + 0.5d0 * mcscf_fock_beta_mo(i,j) + enddo + ! Open + do i = elec_beta_num+1, elec_alpha_num + mcscf_fock_mo(i,j) = mcscf_fock_alpha_mo(i,j) + enddo + ! Virtual + do i = elec_alpha_num+1, mo_num + mcscf_fock_mo(i,j) = 1.5d0 * mcscf_fock_alpha_mo(i,j) & + - 0.5d0 * mcscf_fock_beta_mo(i,j) + enddo + enddo + endif + + do i = 1, mo_num + mcscf_fock_diag_mo(i) = mcscf_fock_mo(i,i) + enddo +END_PROVIDER diff --git a/src/cipsi/stochastic_cipsi.irp.f b/src/cipsi/stochastic_cipsi.irp.f index 339f7084..289040f0 100644 --- a/src/cipsi/stochastic_cipsi.irp.f +++ b/src/cipsi/stochastic_cipsi.irp.f @@ -1,10 +1,11 @@ -subroutine run_stochastic_cipsi +subroutine run_stochastic_cipsi(Ev,PT2) use selection_types implicit none BEGIN_DOC ! Selected Full Configuration Interaction with Stochastic selection and PT2. END_DOC integer :: i,j,k + double precision, intent(out) :: Ev(N_states), PT2(N_states) double precision, allocatable :: zeros(:) integer :: to_select type(pt2_type) :: pt2_data, pt2_data_err @@ -79,12 +80,14 @@ subroutine run_stochastic_cipsi to_select = max(N_states_diag, to_select) + Ev(1:N_states) = psi_energy_with_nucl_rep(1:N_states) call pt2_dealloc(pt2_data) call pt2_dealloc(pt2_data_err) call pt2_alloc(pt2_data, N_states) call pt2_alloc(pt2_data_err, N_states) call ZMQ_pt2(psi_energy_with_nucl_rep,pt2_data,pt2_data_err,relative_error,to_select) ! Stochastic PT2 and selection + PT2(1:N_states) = pt2_data % pt2(1:N_states) correlation_energy_ratio = (psi_energy_with_nucl_rep(1) - hf_energy_ref) / & (psi_energy_with_nucl_rep(1) + pt2_data % rpt2(1) - hf_energy_ref) correlation_energy_ratio = min(1.d0,correlation_energy_ratio) diff --git a/src/cis/20.cis.bats b/src/cis/20.cis.bats index 4f255c7b..4a5c6e45 100644 --- a/src/cis/20.cis.bats +++ b/src/cis/20.cis.bats @@ -9,7 +9,7 @@ function run() { qp set_file $1 qp edit --check qp set determinants n_states 3 - qp set davidson threshold_davidson 1.e-12 + qp set davidson_keywords threshold_davidson 1.e-12 qp set mo_two_e_ints io_mo_two_e_integrals Write qp set_frozen_core qp run cis @@ -59,7 +59,7 @@ function run() { @test "ClO" { # 1.65582s 2.06465s [[ -n $TRAVIS ]] && skip - run clo.ezfio -534.263560525680 -534.256601571199 -534.062020844428 + run clo.ezfio -534.2635737789097 -534.2566081298855 -534.0620070783308 } @test "SO" { # 1.9667s 2.91234s @@ -69,7 +69,7 @@ function run() { @test "OH" { # 2.201s 2.65573s [[ -n $TRAVIS ]] && skip - run oh.ezfio -75.4314648243896 -75.4254639668256 -75.2707675632313 + run oh.ezfio -75.4314822573358 -75.4254733392003 -75.2707586997333 } @test "H2O2" { # 2.27079s 3.07875s @@ -109,7 +109,7 @@ function run() { @test "DHNO" { # 6.42976s 12.9899s [[ -n $TRAVIS ]] && skip - run dhno.ezfio -130.4472288472718 -130.3571808164850 -130.2196257046987 + run dhno.ezfio -130.447238897118 -130.357186843611 -130.219626716369 } @test "CH4" { # 6.4969s 10.9157s @@ -129,7 +129,7 @@ function run() { @test "[Cu(NH3)4]2+" { # 29.7711s 3.45478m [[ -n ${TRAVIS} ]] && skip - run cu_nh3_4_2plus.ezfio -1862.97958885180 -1862.92457657404 -1862.91134959451 + run cu_nh3_4_2plus.ezfio -1862.97958844302 -1862.92454785007 -1862.91130869967 } diff --git a/src/cisd/30.cisd.bats b/src/cisd/30.cisd.bats index 6b8fddb6..5ec11e4b 100644 --- a/src/cisd/30.cisd.bats +++ b/src/cisd/30.cisd.bats @@ -8,10 +8,9 @@ function run() { test_exe cisd || skip qp edit --check qp set determinants n_states 2 - qp set davidson threshold_davidson 1.e-12 - qp set davidson n_states_diag 24 - qp run cis - qp run cisd + qp set davidson_keywords threshold_davidson 1.e-12 + qp set davidson_keywords n_states_diag 24 + qp run cisd energy1="$(qp get cisd energy | tr '[]' ' ' | cut -d ',' -f 1)" energy2="$(qp get cisd energy | tr '[]' ' ' | cut -d ',' -f 2)" eq $energy1 $1 $thresh @@ -19,7 +18,7 @@ function run() { } -@test "B-B" { # +@test "B-B" { # qp set_file b2_stretched.ezfio qp set_frozen_core run -49.120607088648597 -49.055152453388231 @@ -34,7 +33,7 @@ function run() { @test "HBO" { # 4.42968s 19.6099s qp set_file hbo.ezfio qp set_frozen_core - run -100.2019254455993 -99.79484127741013 + run -100.2019254455993 -99.79484127741013 } @test "HCO" { # 6.6077s 28.6801s @@ -46,7 +45,7 @@ function run() { @test "H2O" { # 7.0651s 30.6642s qp set_file h2o.ezfio qp set_frozen_core - run -76.22975602077072 -75.80609108747208 + run -76.22975602077072 -75.80609108747208 } @@ -78,7 +77,7 @@ function run() { [[ -n $TRAVIS ]] && skip qp set_file oh.ezfio qp set_frozen_core - run -75.6087472926588 -75.5370393736601 + run -75.6088105201621 -75.5370802925698 } @test "CH4" { # 19.821s 1.38648m @@ -105,8 +104,9 @@ function run() { @test "DHNO" { # 24.7077s 1.46487m [[ -n $TRAVIS ]] && skip qp set_file dhno.ezfio - qp set_mo_class --core="[1-7]" --act="[8-64]" - run -130.458814562403 -130.356308303681 + qp set_mo_class --core="[1-7]" --act="[8-64]" + run -130.4659881027444 -130.2692384198501 +# run -130.458814562403 -130.356308303681 } @test "H3COH" { # 24.7248s 1.85043m @@ -120,7 +120,7 @@ function run() { [[ -n $TRAVIS ]] && skip qp set_file cu_nh3_4_2plus.ezfio qp set_mo_class --core="[1-24]" --act="[25-45]" --del="[46-87]" - run -1862.98689579931 -1862.6883044626563 + run -1862.98310702274 -1862.88506319755 } @@ -135,14 +135,14 @@ function run() { [[ -n $TRAVIS ]] && skip qp set_file c2h2.ezfio qp set_mo_class --act="[1-30]" --del="[31-36]" - run -12.3566731164213 -11.9495394759914 + run -12.3566731164213 -11.9495394759914 } @test "ClO" { # 37.6949s [[ -n $TRAVIS ]] && skip qp set_file clo.ezfio qp set_frozen_core - run -534.5404021326773 -534.3818725793897 + run -534.540464615019 -534.381904487587 } @test "F2" { # 45.2078s @@ -155,7 +155,7 @@ function run() { @test "SO2" { # 47.6922s [[ -n $TRAVIS ]] && skip qp set_file so2.ezfio - qp set_mo_class --core="[1-8]" --act="[9-87]" + qp set_mo_class --core="[1-8]" --act="[9-87]" run -41.5746738710350 -41.3800467740750 } @@ -177,7 +177,7 @@ function run() { [[ -n $TRAVIS ]] && skip qp set_file n2.ezfio qp set_mo_class --core="[1,2]" --act="[3-40]" --del="[41-60]" - run -109.275693633982 -108.757794570948 + run -109.275693633982 -108.757794570948 } @test "HCN" { # 133.8696s diff --git a/src/dav_general_mat/dav_ext_rout_nonsym_B1space.irp.f b/src/dav_general_mat/dav_ext_rout_nonsym_B1space.irp.f index 4b7b9cc9..d89aaadb 100644 --- a/src/dav_general_mat/dav_ext_rout_nonsym_B1space.irp.f +++ b/src/dav_general_mat/dav_ext_rout_nonsym_B1space.irp.f @@ -346,7 +346,7 @@ subroutine davidson_general_ext_rout_nonsym_b1space(u_in, H_jj, energies, sze, N endif if(i_omax(l) .ne. l) then - print *, ' !!! WARNONG !!!' + print *, ' !!! WARNING !!!' print *, ' index of state', l, i_omax(l) endif enddo diff --git a/src/davidson/diagonalization_hs2_dressed.irp.f b/src/davidson/diagonalization_hs2_dressed.irp.f index 7b559925..1ead9d78 100644 --- a/src/davidson/diagonalization_hs2_dressed.irp.f +++ b/src/davidson/diagonalization_hs2_dressed.irp.f @@ -286,7 +286,7 @@ subroutine davidson_diag_hjj_sjj(dets_in,u_in,H_jj,s2_out,energies,dim_in,sze,N_ ! Small h(N_st_diag*itermax,N_st_diag*itermax), & - h_p(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), & @@ -340,7 +340,10 @@ subroutine davidson_diag_hjj_sjj(dets_in,u_in,H_jj,s2_out,energies,dim_in,sze,N_ exit endif - do iter=1,itermax-1 + iter = 0 + do while (iter < itermax-1) + iter += 1 +! do iter=1,itermax-1 shift = N_st_diag*(iter-1) shift2 = N_st_diag*iter @@ -430,30 +433,30 @@ subroutine davidson_diag_hjj_sjj(dets_in,u_in,H_jj,s2_out,energies,dim_in,sze,N_ call dgemm('T','N', shift2, shift2, sze, & 1.d0, U, size(U,1), W, size(W,1), & - 0.d0, h, size(h_p,1)) + 0.d0, h, size(h,1)) call dgemm('T','N', shift2, shift2, sze, & 1.d0, U, size(U,1), U, size(U,1), & 0.d0, s_tmp, size(s_tmp,1)) - ! Penalty method - ! -------------- - - if (s2_eig) then - h_p = s_ - do k=1,shift2 - h_p(k,k) = h_p(k,k) - 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 +! ! Penalty method +! ! -------------- +! +! if (s2_eig) then +! h_p = s_ +! do k=1,shift2 +! h_p(k,k) = h_p(k,k) - 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 ! --------------- @@ -473,8 +476,10 @@ subroutine davidson_diag_hjj_sjj(dets_in,u_in,H_jj,s2_out,energies,dim_in,sze,N_ call dsygv(1,'V','U',shift2,y,size(y,1), & s_tmp,size(s_tmp,1), lambda, work,lwork,info) deallocate(work) - if (info /= 0) then - stop 'DSYGV Diagonalization failed' + if (info > 0) then + ! Numerical errors propagate. We need to reduce the number of iterations + itermax = iter-1 + exit endif ! Compute Energy for each eigenvector diff --git a/src/determinants/density_matrix.irp.f b/src/determinants/density_matrix.irp.f index ce4d96c2..6ea6b051 100644 --- a/src/determinants/density_matrix.irp.f +++ b/src/determinants/density_matrix.irp.f @@ -445,7 +445,7 @@ END_PROVIDER mo_beta = one_e_dm_mo_beta_average(j,i) ! if(dabs(dm_mo).le.1.d-10)cycle one_e_dm_ao_alpha(l,k) += mo_coef(k,i) * mo_coef(l,j) * mo_alpha - one_e_dm_ao_beta(l,k) += mo_coef(k,i) * mo_coef(l,j) * mo_beta + one_e_dm_ao_beta(l,k) += mo_coef(k,i) * mo_coef(l,j) * mo_beta enddo enddo enddo @@ -453,6 +453,36 @@ END_PROVIDER END_PROVIDER + BEGIN_PROVIDER [ double precision, one_e_dm_ao_alpha_nstates, (ao_num,ao_num,N_states) ] +&BEGIN_PROVIDER [ double precision, one_e_dm_ao_beta_nstates, (ao_num,ao_num,N_states) ] + 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,istate + double precision :: mo_alpha,mo_beta + + one_e_dm_ao_alpha_nstates = 0.d0 + one_e_dm_ao_beta_nstates = 0.d0 + do istate = 1, N_states + 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(j,i,istate) + mo_beta = one_e_dm_mo_beta(j,i,istate) + ! if(dabs(dm_mo).le.1.d-10)cycle + one_e_dm_ao_alpha_nstates(l,k,istate) += mo_coef(k,i) * mo_coef(l,j) * mo_alpha + one_e_dm_ao_beta_nstates(l,k,istate) += mo_coef(k,i) * mo_coef(l,j) * mo_beta + enddo + enddo + enddo + enddo + enddo + +END_PROVIDER + + BEGIN_PROVIDER [ double precision, one_e_dm_ao, (ao_num, ao_num)] implicit none BEGIN_DOC @@ -493,3 +523,101 @@ subroutine get_occupation_from_dets(istate,occupation) enddo end +BEGIN_PROVIDER [double precision, difference_dm, (mo_num, mo_num, N_states)] + implicit none + BEGIN_DOC +! difference_dm(i,j,istate) = dm(i,j,1) - dm(i,j,istate) + END_DOC + integer :: istate + do istate = 1, N_states + difference_dm(:,:,istate) = one_e_dm_mo_alpha(:,:,1) + one_e_dm_mo_beta(:,:,1) & + - (one_e_dm_mo_alpha(:,:,istate) + one_e_dm_mo_beta(:,:,istate)) + enddo +END_PROVIDER + + BEGIN_PROVIDER [double precision, difference_dm_eigvect, (mo_num, mo_num, N_states) ] +&BEGIN_PROVIDER [double precision, difference_dm_eigval, (mo_num, N_states) ] + implicit none + BEGIN_DOC +! eigenvalues and eigevenctors of the difference_dm + END_DOC + integer :: istate,i + do istate = 2, N_states + call lapack_diag(difference_dm_eigval(1,istate),difference_dm_eigvect(1,1,istate)& + ,difference_dm(1,1,istate),mo_num,mo_num) + print*,'Eigenvalues of difference_dm for state ',istate + do i = 1, mo_num + print*,i,difference_dm_eigval(i,istate) + enddo + enddo +END_PROVIDER + + BEGIN_PROVIDER [ integer , n_attachment, (N_states)] +&BEGIN_PROVIDER [ integer , n_dettachment, (N_states)] +&BEGIN_PROVIDER [ integer , list_attachment, (mo_num,N_states)] +&BEGIN_PROVIDER [ integer , list_dettachment, (mo_num,N_states)] + implicit none + integer :: i,istate + integer :: list_attachment_tmp(mo_num) + n_attachment = 0 + n_dettachment = 0 + do istate = 2, N_states + do i = 1, mo_num + if(difference_dm_eigval(i,istate).lt.0.d0)then ! dettachment_orbitals + n_dettachment(istate) += 1 + list_dettachment(n_dettachment(istate),istate) = i ! they are already sorted + else + n_attachment(istate) += 1 + list_attachment_tmp(n_attachment(istate)) = i ! they are not sorted + endif + enddo + ! sorting the attachment + do i = 0, n_attachment(istate) - 1 + list_attachment(i+1,istate) = list_attachment_tmp(n_attachment(istate) - i) + enddo + enddo + +END_PROVIDER + + BEGIN_PROVIDER [ double precision, attachment_numbers_sorted, (mo_num, N_states)] +&BEGIN_PROVIDER [ double precision, dettachment_numbers_sorted, (mo_num, N_states)] + implicit none + integer :: i,istate + do istate = 2, N_states + print*,'dettachment' + do i = 1, n_dettachment(istate) + dettachment_numbers_sorted(i,istate) = difference_dm_eigval(list_dettachment(i,istate),istate) + print*,i,list_dettachment(i,istate),dettachment_numbers_sorted(i,istate) + enddo + print*,'attachment' + do i = 1, n_attachment(istate) + attachment_numbers_sorted(i,istate) = difference_dm_eigval(list_attachment(i,istate),istate) + print*,i,list_attachment(i,istate),attachment_numbers_sorted(i,istate) + enddo + enddo + END_PROVIDER + + BEGIN_PROVIDER [ double precision, attachment_orbitals, (ao_num, mo_num, N_states)] +&BEGIN_PROVIDER [ double precision, dettachment_orbitals, (ao_num, mo_num, N_states)] + implicit none + integer :: i,j,k,istate + attachment_orbitals = 0.d0 + dettachment_orbitals = 0.d0 + do istate = 2, N_states + do i = 1, n_dettachment(istate) + do j = 1, mo_num + do k = 1, ao_num + dettachment_orbitals(k,list_dettachment(i,istate),istate) += mo_coef(k,j) * difference_dm_eigvect(j,list_dettachment(i,istate),istate) + enddo + enddo + enddo + do i = 1, n_attachment(istate) + do j = 1, mo_num + do k = 1, ao_num + attachment_orbitals(k,i,istate) += mo_coef(k,j) * difference_dm_eigvect(j,list_attachment(i,istate),istate) + enddo + enddo + enddo + enddo + +END_PROVIDER diff --git a/src/determinants/dipole_moments.irp.f b/src/determinants/dipole_moments.irp.f index e445c56b..dae04369 100644 --- a/src/determinants/dipole_moments.irp.f +++ b/src/determinants/dipole_moments.irp.f @@ -26,10 +26,10 @@ enddo enddo -! print*,'electron part for z_dipole = ',z_dipole_moment -! print*,'electron part for y_dipole = ',y_dipole_moment -! print*,'electron part for x_dipole = ',x_dipole_moment -! + print*,'electron part for z_dipole = ',z_dipole_moment + print*,'electron part for y_dipole = ',y_dipole_moment + print*,'electron part for x_dipole = ',x_dipole_moment + nuclei_part_z = 0.d0 nuclei_part_y = 0.d0 nuclei_part_x = 0.d0 @@ -38,10 +38,10 @@ nuclei_part_y += nucl_charge(i) * nucl_coord(i,2) nuclei_part_x += nucl_charge(i) * nucl_coord(i,1) enddo -! print*,'nuclei part for z_dipole = ',nuclei_part_z -! print*,'nuclei part for y_dipole = ',nuclei_part_y -! print*,'nuclei part for x_dipole = ',nuclei_part_x -! + print*,'nuclei part for z_dipole = ',nuclei_part_z + print*,'nuclei part for y_dipole = ',nuclei_part_y + print*,'nuclei part for x_dipole = ',nuclei_part_x + do istate = 1, N_states z_dipole_moment(istate) += nuclei_part_z y_dipole_moment(istate) += nuclei_part_y diff --git a/src/determinants/generate_cas_space.irp.f b/src/determinants/generate_cas_space.irp.f new file mode 100644 index 00000000..47a2ca30 --- /dev/null +++ b/src/determinants/generate_cas_space.irp.f @@ -0,0 +1,87 @@ +subroutine generate_cas_space + use bitmasks + implicit none + BEGIN_DOC +! Generates the CAS space + END_DOC + integer :: i, sze, ncore, n_alpha_act, n_beta_act + integer(bit_kind) :: o(N_int) + integer(bit_kind) :: u + integer :: mo_list(elec_alpha_num) + + integer :: k,n,m + integer(bit_kind) :: t, t1, t2 + + call list_to_bitstring(o, list_core_inact, n_core_inact_orb, N_int) + + ! Count number of active electrons + n_alpha_act = 0 + n_beta_act = 0 + do i=1, n_act_orb + if (list_act(i) <= elec_alpha_num) then + n_alpha_act += 1 + endif + if (list_act(i) <= elec_beta_num) then + n_beta_act += 1 + endif + enddo + if (n_act_orb > 64) then + stop 'More than 64 active MOs' + endif + + print *, '' + print *, 'CAS(', n_alpha_act+n_beta_act, ', ', n_act_orb, ')' + print *, '' + + n_det_alpha_unique = binom_int(n_act_orb, n_alpha_act) + TOUCH n_det_alpha_unique + + n = n_alpha_act + u = shiftl(1_bit_kind,n) - 1_bit_kind + + k=0 + do while (u < shiftl(1_bit_kind,n_act_orb)) + k = k+1 + call bitstring_to_list(u, mo_list, m, 1) + do i=1,m + mo_list(i) = list_act( mo_list(i) ) + enddo + call list_to_bitstring(psi_det_alpha_unique(1,k), mo_list, m, N_int) + do i=1,N_int + psi_det_alpha_unique(i,k) = ior(psi_det_alpha_unique(i,k), o(i)) + enddo + t = ior(u,u-1) + t1 = t+1 + t2 = shiftr((iand(not(t),t1)-1), trailz(u)+1) + u = ior(t1,t2) + enddo + + n_det_beta_unique = binom_int(n_act_orb, n_beta_act) + TOUCH n_det_beta_unique + + n = n_beta_act + u = shiftl(1_bit_kind,n) -1_bit_kind + + k=0 + do while (u < shiftl(1_bit_kind,n_act_orb)) + k = k+1 + call bitstring_to_list(u, mo_list, m, 1) + do i=1,m + mo_list(i) = list_act( mo_list(i) ) + enddo + call list_to_bitstring(psi_det_beta_unique(1,k), mo_list, m, N_int) + do i=1,N_int + psi_det_beta_unique(i,k) = ior(psi_det_beta_unique(i,k), o(i)) + enddo + t = ior(u,u-1) + t1 = t+1 + t2 = shiftr((iand(not(t),t1)-1), trailz(u)+1) + u = ior(t1,t2) + enddo + + call generate_all_alpha_beta_det_products + + print *, 'Ndet = ', N_det + +end + diff --git a/src/dft_one_e/NEED b/src/dft_one_e/NEED index 615ee97e..667859a5 100644 --- a/src/dft_one_e/NEED +++ b/src/dft_one_e/NEED @@ -4,6 +4,4 @@ mo_one_e_ints mo_two_e_ints ao_one_e_ints ao_two_e_ints -mo_two_e_erf_ints -ao_two_e_erf_ints mu_of_r diff --git a/src/dft_one_e/mu_erf_dft.irp.f b/src/dft_one_e/mu_erf_dft.irp.f index 0b870564..08779f0e 100644 --- a/src/dft_one_e/mu_erf_dft.irp.f +++ b/src/dft_one_e/mu_erf_dft.irp.f @@ -3,7 +3,7 @@ BEGIN_PROVIDER [double precision, mu_erf_dft] BEGIN_DOC ! range separation parameter used in RS-DFT. ! -! It is set to mu_erf in order to be consistent with the module "ao_two_e_erf_ints" +! It is set to mu_erf in order to be consistent with the module "hamiltonian" END_DOC mu_erf_dft = mu_erf diff --git a/src/dft_utils_in_r/ao_prod_mlti_pl.irp.f b/src/dft_utils_in_r/ao_prod_mlti_pl.irp.f index 39ea0cdf..dac7c1cc 100644 --- a/src/dft_utils_in_r/ao_prod_mlti_pl.irp.f +++ b/src/dft_utils_in_r/ao_prod_mlti_pl.irp.f @@ -149,7 +149,3 @@ BEGIN_PROVIDER [ double precision, ao_prod_dist_grid, (ao_num, ao_num, n_points_ END_PROVIDER -!BEGIN_PROVIDER [ double precision, ao_abs_prod_j1b, (ao_num, ao_num)] -! implicit none -! -!END_PROVIDER diff --git a/src/dummy/NEED b/src/dummy/NEED index 3d5eb1f7..1dcb7a25 100644 --- a/src/dummy/NEED +++ b/src/dummy/NEED @@ -1,6 +1,5 @@ ao_basis ao_one_e_ints -ao_two_e_erf_ints ao_two_e_ints aux_quantities becke_numerical_grid @@ -24,13 +23,13 @@ functionals generators_cas generators_full hartree_fock +hamiltonian iterations kohn_sham kohn_sham_rs mo_basis mo_guess mo_one_e_ints -mo_two_e_erf_ints mo_two_e_ints mpi nuclei diff --git a/src/ezfio_files/00.create.bats b/src/ezfio_files/00.create.bats index 49430a0b..f1751c6e 100644 --- a/src/ezfio_files/00.create.bats +++ b/src/ezfio_files/00.create.bats @@ -53,7 +53,6 @@ function run { @test "B-B" { - qp set_file b2_stretched.ezfio run b2_stretched.zmt 1 0 6-31g } diff --git a/src/ezfio_files/ezfio.irp.f b/src/ezfio_files/ezfio.irp.f index 7e414a04..02f45571 100644 --- a/src/ezfio_files/ezfio.irp.f +++ b/src/ezfio_files/ezfio.irp.f @@ -33,6 +33,8 @@ BEGIN_PROVIDER [ character*(1024), ezfio_filename ] call ezfio_set_file(ezfio_filename) +IRP_IF MACOS +IRP_ELSE ! Adjust out-of-memory killer flag such that the current process will be ! killed first by the OOM killer, allowing compute nodes to survive integer :: getpid @@ -40,6 +42,7 @@ BEGIN_PROVIDER [ character*(1024), ezfio_filename ] write(pidc,*) getpid() write(command,*) 'echo 15 > /proc//'//trim(adjustl(pidc))//'/oom_adj' call system(command) +IRP_ENDIF PROVIDE file_lock diff --git a/src/fci/fci.irp.f b/src/fci/fci.irp.f index bb2a93f8..2059a53b 100644 --- a/src/fci/fci.irp.f +++ b/src/fci/fci.irp.f @@ -41,8 +41,10 @@ program fci write(json_unit,json_array_open_fmt) 'fci' + double precision, allocatable :: Ev(:),PT2(:) + allocate(Ev(N_states), PT2(N_states)) if (do_pt2) then - call run_stochastic_cipsi + call run_stochastic_cipsi(Ev,PT2) else call run_cipsi endif diff --git a/src/hamiltonian/EZFIO.cfg b/src/hamiltonian/EZFIO.cfg new file mode 100644 index 00000000..9b51c560 --- /dev/null +++ b/src/hamiltonian/EZFIO.cfg @@ -0,0 +1,7 @@ +[mu_erf] +type: double precision +doc: cutting of the interaction in the range separated model +interface: ezfio,provider,ocaml +default: 0.5 +ezfio_name: mu_erf + diff --git a/src/hamiltonian/NEED b/src/hamiltonian/NEED new file mode 100644 index 00000000..f1c051ff --- /dev/null +++ b/src/hamiltonian/NEED @@ -0,0 +1,2 @@ +ezfio_files +nuclei diff --git a/src/hamiltonian/README.rst b/src/hamiltonian/README.rst new file mode 100644 index 00000000..c237f8d2 --- /dev/null +++ b/src/hamiltonian/README.rst @@ -0,0 +1,5 @@ +=========== +hamiltonian +=========== + +Parameters of the Hamiltonian. diff --git a/src/hartree_fock/10.hf.bats b/src/hartree_fock/10.hf.bats index 6e7d0233..b496a089 100644 --- a/src/hartree_fock/10.hf.bats +++ b/src/hartree_fock/10.hf.bats @@ -39,7 +39,7 @@ rm -rf $EZFIO qp create_ezfio -b def2-svp hcn.xyz -o $EZFIO qp run scf mv hcn_charges.xyz ${EZFIO}_point_charges.xyz -python write_pt_charges.py ${EZFIO} +python3 write_pt_charges.py ${EZFIO} qp set nuclei point_charges True qp run scf | tee ${EZFIO}.pt_charges.out energy="$(ezfio get hartree_fock energy)" diff --git a/src/hartree_fock/fock_matrix_hf.irp.f b/src/hartree_fock/fock_matrix_hf.irp.f index a5ab6a60..65b3d63c 100644 --- a/src/hartree_fock/fock_matrix_hf.irp.f +++ b/src/hartree_fock/fock_matrix_hf.irp.f @@ -174,7 +174,6 @@ END_PROVIDER allocate (X(cholesky_ao_num)) - ! X(j) = \sum_{mn} SCF_density_matrix_ao(m,n) * cholesky_ao(m,n,j) call dgemm('T','N',cholesky_ao_num,1,ao_num*ao_num,1.d0, & cholesky_ao, ao_num*ao_num, & diff --git a/src/hartree_fock/print_scf_int.irp.f b/src/hartree_fock/print_scf_int.irp.f new file mode 100644 index 00000000..ee7590f6 --- /dev/null +++ b/src/hartree_fock/print_scf_int.irp.f @@ -0,0 +1,114 @@ + +program print_scf_int + + call main() + +end + +subroutine main() + + implicit none + integer :: i, j, k, l + + print *, " Hcore:" + do j = 1, ao_num + do i = 1, ao_num + print *, i, j, ao_one_e_integrals(i,j) + enddo + enddo + + print *, " P:" + do j = 1, ao_num + do i = 1, ao_num + print *, i, j, SCF_density_matrix_ao_alpha(i,j) + enddo + enddo + + + double precision :: integ, density_a, density_b, density + double precision :: J_scf(ao_num, ao_num) + double precision :: K_scf(ao_num, ao_num) + + + double precision, external :: get_ao_two_e_integral + PROVIDE ao_integrals_map + + print *, " J:" + !do j = 1, ao_num + ! do l = 1, ao_num + ! do i = 1, ao_num + ! do k = 1, ao_num + ! ! < 1:k, 2:l | 1:i, 2:j > + ! print *, '< k l | i j >', k, l, i, j + ! print *, get_ao_two_e_integral(i, j, k, l, ao_integrals_map) + ! enddo + ! enddo + ! enddo + !enddo + + !do k = 1, ao_num + ! do i = 1, ao_num + ! do j = 1, ao_num + ! do l = 1, ao_num + ! ! ( 1:k, 1:i | 2:l, 2:j ) + ! print *, '(k i | l j)', k, i, l, j + ! print *, get_ao_two_e_integral(l, j, k, i, ao_integrals_map) + ! enddo + ! enddo + ! print *, '' + ! enddo + !enddo + + J_scf = 0.d0 + K_scf = 0.d0 + do i = 1, ao_num + do k = 1, ao_num + do j = 1, ao_num + do l = 1, ao_num + + density_a = SCF_density_matrix_ao_alpha(l,j) + density_b = SCF_density_matrix_ao_beta (l,j) + density = density_a + density_b + + integ = get_ao_two_e_integral(l, j, k, i, ao_integrals_map) + J_scf(k,i) += density * integ + integ = get_ao_two_e_integral(l, i, k, j, ao_integrals_map) + K_scf(k,i) -= density_a * integ + enddo + enddo + enddo + enddo + + print *, 'J x P' + do i = 1, ao_num + do k = 1, ao_num + print *, k, i, J_scf(k,i) + enddo + enddo + + print *, '' + print *, 'K x P' + do i = 1, ao_num + do k = 1, ao_num + print *, k, i, K_scf(k,i) + enddo + enddo + + print *, '' + print *, 'F in AO' + do i = 1, ao_num + do k = 1, ao_num + print *, k, i, Fock_matrix_ao(k,i) + enddo + enddo + + print *, '' + print *, 'F in MO' + do i = 1, ao_num + do k = 1, ao_num + print *, k, i, 2.d0 * Fock_matrix_mo_alpha(k,i) + enddo + enddo + +end + diff --git a/src/iterations/print_extrapolation.irp.f b/src/iterations/print_extrapolation.irp.f index a7f85693..24c9845f 100644 --- a/src/iterations/print_extrapolation.irp.f +++ b/src/iterations/print_extrapolation.irp.f @@ -37,7 +37,7 @@ subroutine print_extrapolated_energy write(*,*) 'minimum PT2 ', 'Extrapolated energy ', ' Excitation (a.u) ', ' Excitation (eV) ' write(*,*) '=========== ', '=================== ', '=================== ', '===================' do k=2,N_iter_p - write(*,'(F11.4,X,3(X,F18.8))') pt2_iterations(i,k), extrapolated_energy(k,i), & + write(*,'(F11.4,X,3(X,F18.8))') pt2_iterations(i,N_iter_p+1-k), extrapolated_energy(k,i), & extrapolated_energy(k,i) - extrapolated_energy(k,1), & (extrapolated_energy(k,i) - extrapolated_energy(k,1) ) * 27.211396641308d0 enddo diff --git a/src/jastrow/EZFIO.cfg b/src/jastrow/EZFIO.cfg deleted file mode 100644 index b41185a3..00000000 --- a/src/jastrow/EZFIO.cfg +++ /dev/null @@ -1,69 +0,0 @@ -[jast_type] -doc: Type of Jastrow [None| Mu | Qmckl] -type: character*(32) -interface: ezfio, provider, ocaml -default: None - -[jast_qmckl_type_nucl_num] -doc: Number of different nuclei types in QMCkl jastrow -type: integer -interface: ezfio, provider - -[jast_qmckl_type_nucl_vector] -doc: Nucleus type in QMCkl jastrow -type: integer -size: (nuclei.nucl_num) -interface: ezfio, provider - -[jast_qmckl_rescale_ee] -doc: Rescaling factor for electron-electron in QMCkl Jastrow -type: double precision -interface: ezfio, provider - -[jast_qmckl_rescale_en] -doc: Rescaling factor for electron-nucleus in QMCkl Jastrow -type: double precision -size: (jastrow.jast_qmckl_type_nucl_num) -interface: ezfio, provider - -[jast_qmckl_aord_num] -doc: Order of polynomials in e-n parameters of QMCkl jastrow -type: integer -interface: ezfio, provider - -[jast_qmckl_bord_num] -doc: Order of polynomials in e-e parameters of QMCkl jastrow -type: integer -interface: ezfio, provider - -[jast_qmckl_cord_num] -doc: Order of polynomials in e-e-n parameters of QMCkl jastrow -type: integer -interface: ezfio, provider - -[jast_qmckl_c_vector_size] -doc: Number of parameters for c_vector -type: integer -interface: ezfio, provider - -[jast_qmckl_a_vector] -doc: electron-nucleus parameters in QMCkl Jastrow -type: double precision -size: (jastrow.jast_qmckl_type_nucl_num*jastrow.jast_qmckl_aord_num+jastrow.jast_qmckl_type_nucl_num) -interface: ezfio, provider - -[jast_qmckl_b_vector] -doc: electron-electron parameters in QMCkl Jastrow -type: double precision -size: (jastrow.jast_qmckl_bord_num+1) -interface: ezfio, provider - -[jast_qmckl_c_vector] -doc: electron-electron-nucleus parameters in QMCkl Jastrow -type: double precision -size: (jastrow.jast_qmckl_c_vector_size) -interface: ezfio, provider - - - - diff --git a/src/jastrow/README.md b/src/jastrow/README.md deleted file mode 100644 index aefb6ad5..00000000 --- a/src/jastrow/README.md +++ /dev/null @@ -1,3 +0,0 @@ -# Jastrow - -Information relative to the Jastrow factor in trans-correlated calculations. diff --git a/src/kohn_sham_rs/61.rsks.bats b/src/kohn_sham_rs/61.rsks.bats index 90b82142..29d43c3b 100644 --- a/src/kohn_sham_rs/61.rsks.bats +++ b/src/kohn_sham_rs/61.rsks.bats @@ -13,7 +13,7 @@ function run() { qp set scf_utils thresh_scf 1.e-10 qp set dft_keywords exchange_functional $functional qp set dft_keywords correlation_functional $functional - qp set ao_two_e_erf_ints mu_erf 0.5 + qp set hamiltonian mu_erf 0.5 qp set becke_numerical_grid grid_type_sgn 1 qp_reset --mos $1 qp run rs_ks_scf diff --git a/src/mo_optimization/cipsi_orb_opt.irp.f b/src/mo_optimization/cipsi_orb_opt.irp.f index ae3aa1bf..7e3a79eb 100644 --- a/src/mo_optimization/cipsi_orb_opt.irp.f +++ b/src/mo_optimization/cipsi_orb_opt.irp.f @@ -11,11 +11,13 @@ subroutine run_optimization implicit none double precision :: e_cipsi, e_opt, delta_e + double precision, allocatable :: Ev(:),PT2(:) integer :: nb_iter,i logical :: not_converged character (len=100) :: filename PROVIDE psi_det psi_coef mo_two_e_integrals_in_map ao_pseudo_integrals + allocate(Ev(N_states),PT2(N_states)) not_converged = .True. nb_iter = 0 @@ -38,7 +40,7 @@ subroutine run_optimization print*,'' print*,'********** cipsi step **********' ! cispi calculation - call run_stochastic_cipsi + call run_stochastic_cipsi(Ev,PT2) ! State average energy after the cipsi step call state_average_energy(e_cipsi) diff --git a/src/mo_optimization/org/TANGLE_org_mode.sh b/src/mo_optimization/org/TANGLE_org_mode.sh deleted file mode 100755 index 059cbe7d..00000000 --- a/src/mo_optimization/org/TANGLE_org_mode.sh +++ /dev/null @@ -1,7 +0,0 @@ -#!/bin/sh - -list='ls *.org' -for element in $list -do - emacs --batch $element -f org-babel-tangle -done diff --git a/src/mo_two_e_erf_ints/EZFIO.cfg b/src/mo_two_e_erf_ints/EZFIO.cfg deleted file mode 100644 index 57137e65..00000000 --- a/src/mo_two_e_erf_ints/EZFIO.cfg +++ /dev/null @@ -1,6 +0,0 @@ -[io_mo_two_e_integrals_erf] -type: Disk_access -doc: Read/Write MO integrals with the long range interaction from/to disk [ Write | Read | None ] -interface: ezfio,provider,ocaml -default: None - diff --git a/src/mo_two_e_erf_ints/NEED b/src/mo_two_e_erf_ints/NEED deleted file mode 100644 index 7adb17a1..00000000 --- a/src/mo_two_e_erf_ints/NEED +++ /dev/null @@ -1,3 +0,0 @@ -ao_two_e_erf_ints -mo_two_e_ints -mo_basis diff --git a/src/mo_two_e_erf_ints/README.rst b/src/mo_two_e_erf_ints/README.rst deleted file mode 100644 index b118e0c7..00000000 --- a/src/mo_two_e_erf_ints/README.rst +++ /dev/null @@ -1,20 +0,0 @@ -====================== -mo_two_e_erf_ints -====================== - -Here, all two-electron integrals (:math:`erf({\mu}_{erf} * r_{12})/r_{12}`) are computed. -As they have 4 indices and many are zero, they are stored in a map, as defined -in :file:`Utils/map_module.f90`. - -The range separation parameter :math:`{\mu}_{erf}` is the variable :option:`ao_two_e_erf_ints mu_erf`. - -To fetch an |MO| integral, use -`get_mo_two_e_integral_erf(i,j,k,l,mo_integrals_map_erf)` - -The conventions are: - -* For |MO| integrals : = <12|12> - -Be aware that it might not be the same conventions for |MO| and |AO| integrals. - - diff --git a/src/mo_two_e_ints/EZFIO.cfg b/src/mo_two_e_ints/EZFIO.cfg index ea47c51c..088a2416 100644 --- a/src/mo_two_e_ints/EZFIO.cfg +++ b/src/mo_two_e_ints/EZFIO.cfg @@ -17,3 +17,10 @@ doc: If `True`, computes all integrals except for the integrals having 3 or 4 vi interface: ezfio,provider,ocaml default: false +[io_mo_two_e_integrals_erf] +type: Disk_access +doc: Read/Write MO integrals with the long range interaction from/to disk [ Write | Read | None ] +interface: ezfio,provider,ocaml +default: None + + diff --git a/src/mo_two_e_erf_ints/core_quantities_erf.irp.f b/src/mo_two_e_ints/core_quantities_erf.irp.f similarity index 100% rename from src/mo_two_e_erf_ints/core_quantities_erf.irp.f rename to src/mo_two_e_ints/core_quantities_erf.irp.f diff --git a/src/mo_two_e_erf_ints/ints_erf_3_index.irp.f b/src/mo_two_e_ints/ints_erf_3_index.irp.f similarity index 100% rename from src/mo_two_e_erf_ints/ints_erf_3_index.irp.f rename to src/mo_two_e_ints/ints_erf_3_index.irp.f diff --git a/src/mo_two_e_erf_ints/map_integrals_erf.irp.f b/src/mo_two_e_ints/map_integrals_erf.irp.f similarity index 100% rename from src/mo_two_e_erf_ints/map_integrals_erf.irp.f rename to src/mo_two_e_ints/map_integrals_erf.irp.f diff --git a/src/mo_two_e_erf_ints/mo_bi_integrals_erf.irp.f b/src/mo_two_e_ints/mo_bi_integrals_erf.irp.f similarity index 80% rename from src/mo_two_e_erf_ints/mo_bi_integrals_erf.irp.f rename to src/mo_two_e_ints/mo_bi_integrals_erf.irp.f index e009b7d9..a1910fd4 100644 --- a/src/mo_two_e_erf_ints/mo_bi_integrals_erf.irp.f +++ b/src/mo_two_e_ints/mo_bi_integrals_erf.irp.f @@ -9,27 +9,27 @@ subroutine mo_two_e_integrals_erf_index(i,j,k,l,i1) integer(key_kind) :: p,q,r,s,i2 p = min(i,k) r = max(i,k) - p = p+ishft(r*r-r,-1) + p = p+shiftr(r*r-r,1) q = min(j,l) s = max(j,l) - q = q+ishft(s*s-s,-1) + q = q+shiftr(s*s-s,1) i1 = min(p,q) i2 = max(p,q) - i1 = i1+ishft(i2*i2-i2,-1) + i1 = i1+shiftr(i2*i2-i2,1) end BEGIN_PROVIDER [ logical, mo_two_e_integrals_erf_in_map ] use map_module implicit none - integer(bit_kind) :: mask_ijkl(N_int,4) - integer(bit_kind) :: mask_ijk(N_int,3) - BEGIN_DOC ! If True, the map of MO two-electron integrals is provided END_DOC + integer(bit_kind) :: mask_ijkl(N_int,4) + integer(bit_kind) :: mask_ijk(N_int,3) + double precision :: cpu_1, cpu_2, wall_1, wall_2 - real :: map_mb + PROVIDE mo_class mo_two_e_integrals_erf_in_map = .True. if (read_mo_two_e_integrals_erf) then @@ -37,29 +37,138 @@ BEGIN_PROVIDER [ logical, mo_two_e_integrals_erf_in_map ] call map_load_from_disk(trim(ezfio_filename)//'/work/mo_ints_erf',mo_integrals_erf_map) print*, 'MO integrals_erf provided' return - else - PROVIDE ao_two_e_integrals_erf_in_map endif - ! call four_index_transform_block(ao_integrals_erf_map,mo_integrals_erf_map, & - ! mo_coef, size(mo_coef,1), & - ! 1, 1, 1, 1, ao_num, ao_num, ao_num, ao_num, & - ! 1, 1, 1, 1, mo_num, mo_num, mo_num, mo_num) - call add_integrals_to_map_erf(full_ijkl_bitmask_4) - integer*8 :: get_mo_erf_map_size, mo_erf_map_size - mo_erf_map_size = get_mo_erf_map_size() + PROVIDE ao_two_e_integrals_erf_in_map -! print*,'Molecular integrals ERF provided:' -! print*,' Size of MO ERF map ', map_mb(mo_integrals_erf_map) ,'MB' -! print*,' Number of MO ERF integrals: ', mo_erf_map_size - if (write_mo_two_e_integrals_erf) then + print *, '' + print *, 'AO -> MO ERF integrals transformation' + print *, '-------------------------------------' + print *, '' + + call wall_time(wall_1) + call cpu_time(cpu_1) + + if (dble(ao_num)**4 * 32.d-9 < dble(qp_max_mem)) then + call four_idx_dgemm_erf + else + call add_integrals_to_map_erf(full_ijkl_bitmask_4) + endif + + call wall_time(wall_2) + call cpu_time(cpu_2) + + integer*8 :: get_mo_erf_map_size, mo_erf_map_size + mo_erf_map_size = get_mo_erf_map_size() + + double precision, external :: map_mb + print*,'Molecular integrals provided:' + print*,' Size of MO map ', map_mb(mo_integrals_erf_map) ,'MB' + print*,' Number of MO integrals: ', mo_erf_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), ')' + + if (write_mo_two_e_integrals_erf.and.mpi_master) then call ezfio_set_work_empty(.False.) call map_save_to_disk(trim(ezfio_filename)//'/work/mo_ints_erf',mo_integrals_erf_map) - call ezfio_set_mo_two_e_erf_ints_io_mo_two_e_integrals_erf("Read") + call ezfio_set_mo_two_e_ints_io_mo_two_e_integrals_erf('Read') endif END_PROVIDER +subroutine four_idx_dgemm_erf + implicit none + integer :: p,q,r,s,i,j,k,l + double precision, allocatable :: a1(:,:,:,:) + double precision, allocatable :: a2(:,:,:,:) + + if (ao_num > 1289) then + print *, irp_here, ': Integer overflow in ao_num**3' + endif + + allocate (a1(ao_num,ao_num,ao_num,ao_num)) + + print *, 'Getting AOs' + !$OMP PARALLEL DO DEFAULT(SHARED) PRIVATE(q,r,s) + do s=1,ao_num + do r=1,ao_num + do q=1,ao_num + call get_ao_two_e_integrals_erf(q,r,s,ao_num,a1(1,q,r,s)) + enddo + enddo + enddo + !$OMP END PARALLEL DO + + + print *, '1st transformation' + ! 1st transformation + allocate (a2(ao_num,ao_num,ao_num,mo_num)) + call dgemm('T','N', (ao_num*ao_num*ao_num), mo_num, ao_num, 1.d0, a1, ao_num, mo_coef, ao_num, 0.d0, a2, (ao_num*ao_num*ao_num)) + + ! 2nd transformation + print *, '2nd transformation' + deallocate (a1) + allocate (a1(ao_num,ao_num,mo_num,mo_num)) + call dgemm('T','N', (ao_num*ao_num*mo_num), mo_num, ao_num, 1.d0, a2, ao_num, mo_coef, ao_num, 0.d0, a1, (ao_num*ao_num*mo_num)) + + ! 3rd transformation + print *, '3rd transformation' + deallocate (a2) + allocate (a2(ao_num,mo_num,mo_num,mo_num)) + call dgemm('T','N', (ao_num*mo_num*mo_num), mo_num, ao_num, 1.d0, a1, ao_num, mo_coef, ao_num, 0.d0, a2, (ao_num*mo_num*mo_num)) + + ! 4th transformation + print *, '4th transformation' + deallocate (a1) + allocate (a1(mo_num,mo_num,mo_num,mo_num)) + call dgemm('T','N', (mo_num*mo_num*mo_num), mo_num, ao_num, 1.d0, a2, ao_num, mo_coef, ao_num, 0.d0, a1, (mo_num*mo_num*mo_num)) + + deallocate (a2) + + integer :: n_integrals, size_buffer + integer(key_kind) , allocatable :: buffer_i(:) + real(integral_kind), allocatable :: buffer_value(:) + size_buffer = min(ao_num*ao_num*ao_num,16000000) + + !$OMP PARALLEL DEFAULT(SHARED) PRIVATE(i,j,k,l,buffer_value,buffer_i,n_integrals) + allocate ( buffer_i(size_buffer), buffer_value(size_buffer) ) + + n_integrals = 0 + !$OMP DO + do l=1,mo_num + do k=1,mo_num + do j=1,l + do i=1,k + if (abs(a1(i,j,k,l)) < mo_integrals_threshold) then + cycle + endif + n_integrals += 1 + buffer_value(n_integrals) = a1(i,j,k,l) + !DIR$ FORCEINLINE + call mo_two_e_integrals_index(i,j,k,l,buffer_i(n_integrals)) + if (n_integrals == size_buffer) then + call map_append(mo_integrals_erf_map, buffer_i, buffer_value, n_integrals) + n_integrals = 0 + endif + enddo + enddo + enddo + enddo + !$OMP END DO + + call map_append(mo_integrals_erf_map, buffer_i, buffer_value, n_integrals) + + deallocate(buffer_i, buffer_value) + !$OMP END PARALLEL + + deallocate (a1) + + call map_sort(mo_integrals_erf_map) + call map_unique(mo_integrals_erf_map) + +end subroutine + + BEGIN_PROVIDER [ double precision, mo_two_e_int_erf_jj_from_ao, (mo_num,mo_num) ] &BEGIN_PROVIDER [ double precision, mo_two_e_int_erf_jj_exchange_from_ao, (mo_num,mo_num) ] diff --git a/src/mo_two_e_erf_ints/routines_save_integrals_erf.irp.f b/src/mo_two_e_ints/routines_save_integrals_erf.irp.f similarity index 88% rename from src/mo_two_e_erf_ints/routines_save_integrals_erf.irp.f rename to src/mo_two_e_ints/routines_save_integrals_erf.irp.f index 52fb8f63..9915b206 100644 --- a/src/mo_two_e_erf_ints/routines_save_integrals_erf.irp.f +++ b/src/mo_two_e_ints/routines_save_integrals_erf.irp.f @@ -4,7 +4,7 @@ subroutine save_erf_two_e_integrals_mo PROVIDE mo_two_e_integrals_erf_in_map call ezfio_set_work_empty(.False.) call map_save_to_disk(trim(ezfio_filename)//'/work/mo_ints_erf',mo_integrals_erf_map) - call ezfio_set_mo_two_e_erf_ints_io_mo_two_e_integrals_erf('Read') + call ezfio_set_mo_two_e_ints_io_mo_two_e_integrals_erf('Read') end diff --git a/src/mu_of_r/EZFIO.cfg b/src/mu_of_r/EZFIO.cfg index c774ec82..a66b00ef 100644 --- a/src/mu_of_r/EZFIO.cfg +++ b/src/mu_of_r/EZFIO.cfg @@ -6,7 +6,7 @@ size: (becke_numerical_grid.n_points_final_grid,determinants.n_states) [mu_of_r_potential] type: character*(32) -doc: type of potential for the mu(r) interaction: can be [ hf| cas_ful | cas_truncated | pure_act] +doc: type of potential for the mu(r) interaction: can be [ hf| cas_full | cas_truncated | pure_act] interface: ezfio, provider, ocaml default: hf diff --git a/src/mu_of_r/mu_of_r_conditions.irp.f b/src/mu_of_r/mu_of_r_conditions.irp.f index f9c3b3b3..6b49b9df 100644 --- a/src/mu_of_r/mu_of_r_conditions.irp.f +++ b/src/mu_of_r/mu_of_r_conditions.irp.f @@ -26,7 +26,7 @@ do ipoint = 1, n_points_final_grid if(mu_of_r_potential.EQ."hf")then mu_of_r_prov(ipoint,istate) = mu_of_r_hf(ipoint) - else if(mu_of_r_potential.EQ."cas_ful".or.mu_of_r_potential.EQ."cas_truncated".or.mu_of_r_potential.EQ."pure_act")then + else if(mu_of_r_potential.EQ."cas_full".or.mu_of_r_potential.EQ."cas_truncated".or.mu_of_r_potential.EQ."pure_act")then mu_of_r_prov(ipoint,istate) = mu_of_r_psi_cas(ipoint,istate) else print*,'you requested the following mu_of_r_potential' @@ -128,7 +128,7 @@ BEGIN_PROVIDER [double precision, mu_average_prov, (N_states)] implicit none BEGIN_DOC - ! average value of mu(r) weighted with the total one-e density and divised by the number of electrons + ! average value of mu(r) weighted with the total one-e density and divided by the number of electrons ! ! !!!!!! WARNING !!!!!! if no_core_density == .True. then all contributions from the core orbitals ! diff --git a/src/mu_of_r/test_proj_op.irp.f b/src/mu_of_r/test_proj_op.irp.f index 1d46da5e..f9aba094 100644 --- a/src/mu_of_r/test_proj_op.irp.f +++ b/src/mu_of_r/test_proj_op.irp.f @@ -9,7 +9,7 @@ program projected_operators ! orbitals coming from core no_core_density = .True. touch no_core_density - mu_of_r_potential = "cas_ful" + mu_of_r_potential = "cas_full" touch mu_of_r_potential print*,'Using Valence Only functions' ! call test_f_HF_valence_ab diff --git a/src/non_h_ints_mu/grad_squared.irp.f b/src/non_h_ints_mu/grad_squared.irp.f deleted file mode 100644 index 8c6d35dc..00000000 --- a/src/non_h_ints_mu/grad_squared.irp.f +++ /dev/null @@ -1,486 +0,0 @@ - -! --- - -! TODO : strong optmization : write the loops in a different way -! : for each couple of AO, the gaussian product are done once for all - -BEGIN_PROVIDER [ double precision, gradu_squared_u_ij_mu, (ao_num, ao_num, n_points_final_grid) ] - - BEGIN_DOC - ! - ! if J(r1,r2) = u12: - ! - ! gradu_squared_u_ij_mu = -0.50 x \int r2 [ (grad_1 u12)^2 + (grad_2 u12^2)] \phi_i(2) \phi_j(2) - ! = -0.25 x \int r2 (1 - erf(mu*r12))^2 \phi_i(2) \phi_j(2) - ! and - ! (1 - erf(mu*r12))^2 = \sum_i coef_gauss_1_erf_x_2(i) * exp(-expo_gauss_1_erf_x_2(i) * r12^2) - ! - ! if J(r1,r2) = u12 x v1 x v2 - ! - ! gradu_squared_u_ij_mu = -0.50 x \int r2 \phi_i(2) \phi_j(2) [ v1^2 v2^2 ((grad_1 u12)^2 + (grad_2 u12^2)) + u12^2 v2^2 (grad_1 v1)^2 + 2 u12 v1 v2^2 (grad_1 u12) . (grad_1 v1) ] - ! = -0.25 x v1^2 \int r2 \phi_i(2) \phi_j(2) [1 - erf(mu r12)]^2 v2^2 - ! + -0.50 x (grad_1 v1)^2 \int r2 \phi_i(2) \phi_j(2) u12^2 v2^2 - ! + -1.00 x v1 (grad_1 v1) \int r2 \phi_i(2) \phi_j(2) (grad_1 u12) v2^2 - ! = v1^2 x int2_grad1u2_grad2u2_j1b2 - ! + -0.5 x (grad_1 v1)^2 x int2_u2_j1b2 - ! + -1.0 X V1 x (grad_1 v1) \cdot [ int2_u_grad1u_j1b2 x r - int2_u_grad1u_x_j1b ] - ! - ! - END_DOC - - implicit none - integer :: ipoint, i, j, m, igauss - double precision :: x, y, z, r(3), delta, coef - double precision :: tmp_v, tmp_x, tmp_y, tmp_z - double precision :: tmp1, tmp2, tmp3, tmp4, tmp5, tmp6, tmp7, tmp8, tmp9 - double precision :: time0, time1 - double precision, external :: overlap_gauss_r12_ao - - print*, ' providing gradu_squared_u_ij_mu ...' - call wall_time(time0) - - PROVIDE j1b_type - - if(j1b_type .eq. 3) then - - do ipoint = 1, n_points_final_grid - - x = final_grid_points(1,ipoint) - y = final_grid_points(2,ipoint) - z = final_grid_points(3,ipoint) - tmp_v = v_1b (ipoint) - tmp_x = v_1b_grad(1,ipoint) - tmp_y = v_1b_grad(2,ipoint) - tmp_z = v_1b_grad(3,ipoint) - - tmp1 = tmp_v * tmp_v - tmp2 = -0.5d0 * (tmp_x * tmp_x + tmp_y * tmp_y + tmp_z * tmp_z) - tmp3 = tmp_v * tmp_x - tmp4 = tmp_v * tmp_y - tmp5 = tmp_v * tmp_z - - tmp6 = -x * tmp3 - tmp7 = -y * tmp4 - tmp8 = -z * tmp5 - - do j = 1, ao_num - do i = 1, ao_num - - tmp9 = int2_u_grad1u_j1b2(i,j,ipoint) - - gradu_squared_u_ij_mu(i,j,ipoint) = tmp1 * int2_grad1u2_grad2u2_j1b2(i,j,ipoint) & - + tmp2 * int2_u2_j1b2 (i,j,ipoint) & - + tmp6 * tmp9 + tmp3 * int2_u_grad1u_x_j1b2(i,j,ipoint,1) & - + tmp7 * tmp9 + tmp4 * int2_u_grad1u_x_j1b2(i,j,ipoint,2) & - + tmp8 * tmp9 + tmp5 * int2_u_grad1u_x_j1b2(i,j,ipoint,3) - enddo - enddo - enddo - - else - - gradu_squared_u_ij_mu = 0.d0 - do ipoint = 1, n_points_final_grid - r(1) = final_grid_points(1,ipoint) - r(2) = final_grid_points(2,ipoint) - r(3) = final_grid_points(3,ipoint) - do j = 1, ao_num - do i = 1, ao_num - do igauss = 1, n_max_fit_slat - delta = expo_gauss_1_erf_x_2(igauss) - coef = coef_gauss_1_erf_x_2(igauss) - gradu_squared_u_ij_mu(i,j,ipoint) += -0.25d0 * coef * overlap_gauss_r12_ao(r, delta, i, j) - enddo - enddo - enddo - enddo - - endif - - call wall_time(time1) - print*, ' Wall time for gradu_squared_u_ij_mu = ', time1 - time0 - -END_PROVIDER - -! --- - -!BEGIN_PROVIDER [double precision, tc_grad_square_ao_loop, (ao_num, ao_num, ao_num, ao_num)] -! -! BEGIN_DOC -! ! -! ! tc_grad_square_ao_loop(k,i,l,j) = -1/2 -! ! -! END_DOC -! -! implicit none -! integer :: ipoint, i, j, k, l -! double precision :: weight1, ao_ik_r, ao_i_r -! double precision, allocatable :: ac_mat(:,:,:,:) -! -! allocate(ac_mat(ao_num,ao_num,ao_num,ao_num)) -! ac_mat = 0.d0 -! -! do ipoint = 1, n_points_final_grid -! weight1 = final_weight_at_r_vector(ipoint) -! -! do i = 1, ao_num -! ao_i_r = weight1 * aos_in_r_array_transp(ipoint,i) -! -! do k = 1, ao_num -! ao_ik_r = ao_i_r * aos_in_r_array_transp(ipoint,k) -! -! do j = 1, ao_num -! do l = 1, ao_num -! ac_mat(k,i,l,j) += ao_ik_r * gradu_squared_u_ij_mu(l,j,ipoint) -! enddo -! enddo -! enddo -! enddo -! enddo -! -! do j = 1, ao_num -! do l = 1, ao_num -! do i = 1, ao_num -! do k = 1, ao_num -! tc_grad_square_ao_loop(k,i,l,j) = ac_mat(k,i,l,j) + ac_mat(l,j,k,i) -! !write(11,*) tc_grad_square_ao_loop(k,i,l,j) -! enddo -! enddo -! enddo -! enddo -! -! deallocate(ac_mat) -! -!END_PROVIDER - -! --- - -BEGIN_PROVIDER [double precision, tc_grad_square_ao_loop, (ao_num, ao_num, ao_num, ao_num)] - - BEGIN_DOC - ! - ! tc_grad_square_ao_loop(k,i,l,j) = 1/2 - ! - END_DOC - - implicit none - integer :: ipoint, i, j, k, l - double precision :: weight1, ao_ik_r, ao_i_r - double precision :: time0, time1 - double precision, allocatable :: ac_mat(:,:,:,:), bc_mat(:,:,:,:) - - print*, ' providing tc_grad_square_ao_loop ...' - call wall_time(time0) - - allocate(ac_mat(ao_num,ao_num,ao_num,ao_num)) - ac_mat = 0.d0 - allocate(bc_mat(ao_num,ao_num,ao_num,ao_num)) - bc_mat = 0.d0 - - do ipoint = 1, n_points_final_grid - weight1 = final_weight_at_r_vector(ipoint) - - do i = 1, ao_num - !ao_i_r = weight1 * aos_in_r_array_transp(ipoint,i) - ao_i_r = weight1 * aos_in_r_array(i,ipoint) - - do k = 1, ao_num - !ao_ik_r = ao_i_r * aos_in_r_array_transp(ipoint,k) - ao_ik_r = ao_i_r * aos_in_r_array(k,ipoint) - - do j = 1, ao_num - do l = 1, ao_num - ac_mat(k,i,l,j) += ao_ik_r * ( u12sq_j1bsq(l,j,ipoint) + u12_grad1_u12_j1b_grad1_j1b(l,j,ipoint) ) - bc_mat(k,i,l,j) += ao_ik_r * grad12_j12(l,j,ipoint) - enddo - enddo - enddo - enddo - enddo - - do j = 1, ao_num - do l = 1, ao_num - do i = 1, ao_num - do k = 1, ao_num - tc_grad_square_ao_loop(k,i,l,j) = ac_mat(k,i,l,j) + ac_mat(l,j,k,i) + bc_mat(k,i,l,j) - enddo - enddo - enddo - enddo - - deallocate(ac_mat) - deallocate(bc_mat) - - call wall_time(time1) - print*, ' Wall time for tc_grad_square_ao_loop = ', time1 - time0 - -END_PROVIDER - -! --- - -BEGIN_PROVIDER [ double precision, grad12_j12, (ao_num, ao_num, n_points_final_grid) ] - - implicit none - integer :: ipoint, i, j, m, igauss - double precision :: r(3), delta, coef - double precision :: tmp1 - double precision :: time0, time1 - double precision, external :: overlap_gauss_r12_ao - - print*, ' providing grad12_j12 ...' - call wall_time(time0) - - PROVIDE j1b_type - PROVIDE int2_grad1u2_grad2u2_j1b2 - - do ipoint = 1, n_points_final_grid - tmp1 = v_1b(ipoint) - tmp1 = tmp1 * tmp1 - do j = 1, ao_num - do i = 1, ao_num - grad12_j12(i,j,ipoint) = tmp1 * int2_grad1u2_grad2u2_j1b2(i,j,ipoint) - enddo - enddo - enddo - - FREE int2_grad1u2_grad2u2_j1b2 - - !if(j1b_type .eq. 0) then - ! grad12_j12 = 0.d0 - ! do ipoint = 1, n_points_final_grid - ! r(1) = final_grid_points(1,ipoint) - ! r(2) = final_grid_points(2,ipoint) - ! r(3) = final_grid_points(3,ipoint) - ! do j = 1, ao_num - ! do i = 1, ao_num - ! do igauss = 1, n_max_fit_slat - ! delta = expo_gauss_1_erf_x_2(igauss) - ! coef = coef_gauss_1_erf_x_2(igauss) - ! grad12_j12(i,j,ipoint) += -0.25d0 * coef * overlap_gauss_r12_ao(r, delta, i, j) - ! enddo - ! enddo - ! enddo - ! enddo - !endif - - call wall_time(time1) - print*, ' Wall time for grad12_j12 = ', time1 - time0 - call print_memory_usage() - -END_PROVIDER - -! --- - -BEGIN_PROVIDER [double precision, u12sq_j1bsq, (ao_num, ao_num, n_points_final_grid)] - - implicit none - integer :: ipoint, i, j - double precision :: tmp_x, tmp_y, tmp_z - double precision :: tmp1 - double precision :: time0, time1 - - print*, ' providing u12sq_j1bsq ...' - call wall_time(time0) - - ! do not free here - PROVIDE int2_u2_j1b2 - - do ipoint = 1, n_points_final_grid - tmp_x = v_1b_grad(1,ipoint) - tmp_y = v_1b_grad(2,ipoint) - tmp_z = v_1b_grad(3,ipoint) - tmp1 = -0.5d0 * (tmp_x * tmp_x + tmp_y * tmp_y + tmp_z * tmp_z) - do j = 1, ao_num - do i = 1, ao_num - u12sq_j1bsq(i,j,ipoint) = tmp1 * int2_u2_j1b2(i,j,ipoint) - enddo - enddo - enddo - - call wall_time(time1) - print*, ' Wall time for u12sq_j1bsq = ', time1 - time0 - call print_memory_usage() - -END_PROVIDER - -! --- - -BEGIN_PROVIDER [ double precision, u12_grad1_u12_j1b_grad1_j1b, (ao_num, ao_num, n_points_final_grid) ] - - implicit none - integer :: ipoint, i, j, m, igauss - double precision :: x, y, z - double precision :: tmp_v, tmp_x, tmp_y, tmp_z - double precision :: tmp3, tmp4, tmp5, tmp6, tmp7, tmp8, tmp9 - double precision :: time0, time1 - double precision, external :: overlap_gauss_r12_ao - - print*, ' providing u12_grad1_u12_j1b_grad1_j1b ...' - call wall_time(time0) - - PROVIDE int2_u_grad1u_j1b2 - PROVIDE int2_u_grad1u_x_j1b2 - - do ipoint = 1, n_points_final_grid - - x = final_grid_points(1,ipoint) - y = final_grid_points(2,ipoint) - z = final_grid_points(3,ipoint) - tmp_v = v_1b (ipoint) - tmp_x = v_1b_grad(1,ipoint) - tmp_y = v_1b_grad(2,ipoint) - tmp_z = v_1b_grad(3,ipoint) - - tmp3 = tmp_v * tmp_x - tmp4 = tmp_v * tmp_y - tmp5 = tmp_v * tmp_z - - tmp6 = -x * tmp3 - tmp7 = -y * tmp4 - tmp8 = -z * tmp5 - - do j = 1, ao_num - do i = 1, ao_num - - tmp9 = int2_u_grad1u_j1b2(i,j,ipoint) - - u12_grad1_u12_j1b_grad1_j1b(i,j,ipoint) = tmp6 * tmp9 + tmp3 * int2_u_grad1u_x_j1b2(i,j,ipoint,1) & - + tmp7 * tmp9 + tmp4 * int2_u_grad1u_x_j1b2(i,j,ipoint,2) & - + tmp8 * tmp9 + tmp5 * int2_u_grad1u_x_j1b2(i,j,ipoint,3) - enddo - enddo - enddo - - FREE int2_u_grad1u_j1b2 - FREE int2_u_grad1u_x_j1b2 - - call wall_time(time1) - print*, ' Wall time for u12_grad1_u12_j1b_grad1_j1b = ', time1 - time0 - call print_memory_usage() - -END_PROVIDER - -! --- - -BEGIN_PROVIDER [double precision, tc_grad_square_ao, (ao_num, ao_num, ao_num, ao_num)] - - BEGIN_DOC - ! - ! tc_grad_square_ao(k,i,l,j) = -1/2 - ! - END_DOC - - implicit none - integer :: ipoint, i, j, k, l - double precision :: weight1, ao_k_r, ao_i_r - double precision :: der_envsq_x, der_envsq_y, der_envsq_z, lap_envsq - double precision :: time0, time1 - double precision, allocatable :: b_mat(:,:,:), tmp(:,:,:) - - print*, ' providing tc_grad_square_ao ...' - call wall_time(time0) - - if(read_tc_integ) then - - open(unit=11, form="unformatted", file=trim(ezfio_filename)//'/work/tc_grad_square_ao', action="read") - read(11) tc_grad_square_ao - close(11) - - else - - ! --- - - PROVIDE int2_grad1_u12_square_ao - - allocate(b_mat(n_points_final_grid,ao_num,ao_num)) - - b_mat = 0.d0 - !$OMP PARALLEL & - !$OMP DEFAULT (NONE) & - !$OMP PRIVATE (i, k, ipoint) & - !$OMP SHARED (aos_in_r_array_transp, b_mat, ao_num, n_points_final_grid, final_weight_at_r_vector) - !$OMP DO SCHEDULE (static) - do i = 1, ao_num - do k = 1, ao_num - do ipoint = 1, n_points_final_grid - b_mat(ipoint,k,i) = final_weight_at_r_vector(ipoint) * aos_in_r_array_transp(ipoint,i) * aos_in_r_array_transp(ipoint,k) - enddo - enddo - enddo - !$OMP END DO - !$OMP END PARALLEL - - tc_grad_square_ao = 0.d0 - call dgemm( "N", "N", ao_num*ao_num, ao_num*ao_num, n_points_final_grid, 1.d0 & - , int2_grad1_u12_square_ao(1,1,1), ao_num*ao_num, b_mat(1,1,1), n_points_final_grid & - , 0.d0, tc_grad_square_ao, ao_num*ao_num) - - FREE int2_grad1_u12_square_ao - - ! --- - - if(((j1b_type .eq. 3) .or. (j1b_type .eq. 4)) .and. use_ipp) then - - print*, " going through Manu's IPP" - - ! an additional term is added here directly instead of - ! being added in int2_grad1_u12_square_ao for performance - - PROVIDE int2_u2_j1b2 - - b_mat = 0.d0 - !$OMP PARALLEL & - !$OMP DEFAULT (NONE) & - !$OMP PRIVATE (i, k, ipoint, weight1, ao_i_r, ao_k_r) & - !$OMP SHARED (aos_in_r_array_transp, b_mat, ao_num, n_points_final_grid, final_weight_at_r_vector, & - !$OMP v_1b_square_grad, v_1b_square_lapl, aos_grad_in_r_array_transp_bis) - !$OMP DO SCHEDULE (static) - do i = 1, ao_num - do k = 1, ao_num - do ipoint = 1, n_points_final_grid - - weight1 = 0.25d0 * final_weight_at_r_vector(ipoint) - - ao_i_r = aos_in_r_array_transp(ipoint,i) - ao_k_r = aos_in_r_array_transp(ipoint,k) - - b_mat(ipoint,k,i) = weight1 * ( ao_k_r * ao_i_r * v_1b_square_lapl(ipoint) & - + (ao_k_r * aos_grad_in_r_array_transp_bis(ipoint,i,1) + ao_i_r * aos_grad_in_r_array_transp_bis(ipoint,k,1)) * v_1b_square_grad(ipoint,1) & - + (ao_k_r * aos_grad_in_r_array_transp_bis(ipoint,i,2) + ao_i_r * aos_grad_in_r_array_transp_bis(ipoint,k,2)) * v_1b_square_grad(ipoint,2) & - + (ao_k_r * aos_grad_in_r_array_transp_bis(ipoint,i,3) + ao_i_r * aos_grad_in_r_array_transp_bis(ipoint,k,3)) * v_1b_square_grad(ipoint,3) ) - enddo - enddo - enddo - !$OMP END DO - !$OMP END PARALLEL - - call dgemm( "N", "N", ao_num*ao_num, ao_num*ao_num, n_points_final_grid, 1.d0 & - , int2_u2_j1b2(1,1,1), ao_num*ao_num, b_mat(1,1,1), n_points_final_grid & - , 1.d0, tc_grad_square_ao, ao_num*ao_num) - - FREE int2_u2_j1b2 - endif - - ! --- - - deallocate(b_mat) - call sum_A_At(tc_grad_square_ao(1,1,1,1), ao_num*ao_num) - - endif - - if(write_tc_integ.and.mpi_master) then - open(unit=11, form="unformatted", file=trim(ezfio_filename)//'/work/tc_grad_square_ao', action="write") - call ezfio_set_work_empty(.False.) - write(11) tc_grad_square_ao - close(11) - call ezfio_set_tc_keywords_io_tc_integ('Read') - endif - - call wall_time(time1) - print*, ' Wall time for tc_grad_square_ao = ', time1 - time0 - call print_memory_usage() - -END_PROVIDER - -! --- - diff --git a/src/non_h_ints_mu/j12_nucl_utils.irp.f b/src/non_h_ints_mu/j12_nucl_utils.irp.f deleted file mode 100644 index 7dd13f14..00000000 --- a/src/non_h_ints_mu/j12_nucl_utils.irp.f +++ /dev/null @@ -1,773 +0,0 @@ - -! --- - -BEGIN_PROVIDER [ double precision, v_1b, (n_points_final_grid)] - - implicit none - integer :: ipoint, i, j, phase - double precision :: x, y, z, dx, dy, dz - double precision :: a, d, e, fact_r - - if(j1b_type .eq. 3) then - - ! v(r) = \Pi_{a} [1 - \exp(-\alpha_a (r - r_a)^2)] - - do ipoint = 1, n_points_final_grid - - x = final_grid_points(1,ipoint) - y = final_grid_points(2,ipoint) - z = final_grid_points(3,ipoint) - - fact_r = 1.d0 - do j = 1, nucl_num - a = j1b_pen(j) - dx = x - nucl_coord(j,1) - dy = y - nucl_coord(j,2) - dz = z - nucl_coord(j,3) - d = dx*dx + dy*dy + dz*dz - e = 1.d0 - dexp(-a*d) - - fact_r = fact_r * e - enddo - - v_1b(ipoint) = fact_r - enddo - - elseif(j1b_type .eq. 4) then - - ! v(r) = 1 - \sum_{a} \beta_a \exp(-\alpha_a (r - r_a)^2) - - do ipoint = 1, n_points_final_grid - - x = final_grid_points(1,ipoint) - y = final_grid_points(2,ipoint) - z = final_grid_points(3,ipoint) - - fact_r = 1.d0 - do j = 1, nucl_num - a = j1b_pen(j) - dx = x - nucl_coord(j,1) - dy = y - nucl_coord(j,2) - dz = z - nucl_coord(j,3) - d = dx*dx + dy*dy + dz*dz - - fact_r = fact_r - j1b_pen_coef(j) * dexp(-a*d) - enddo - - v_1b(ipoint) = fact_r - enddo - - else - - print*, 'j1b_type = ', j1b_type, 'is not implemented for v_1b' - stop - - endif - -END_PROVIDER - -! --- - -BEGIN_PROVIDER [double precision, v_1b_grad, (3, n_points_final_grid)] - - implicit none - integer :: ipoint, i, j, phase - double precision :: x, y, z, dx, dy, dz, r2 - double precision :: a, d, e - double precision :: fact_x, fact_y, fact_z - double precision :: ax_der, ay_der, az_der, a_expo - - PROVIDE j1b_type - - if(j1b_type .eq. 3) then - - ! v(r) = \Pi_{a} [1 - \exp(-\alpha_a (r - r_a)^2)] - - do ipoint = 1, n_points_final_grid - - x = final_grid_points(1,ipoint) - y = final_grid_points(2,ipoint) - z = final_grid_points(3,ipoint) - - fact_x = 0.d0 - fact_y = 0.d0 - fact_z = 0.d0 - do i = 1, List_all_comb_b2_size - - phase = 0 - a_expo = 0.d0 - ax_der = 0.d0 - ay_der = 0.d0 - az_der = 0.d0 - do j = 1, nucl_num - a = dble(List_all_comb_b2(j,i)) * j1b_pen(j) - dx = x - nucl_coord(j,1) - dy = y - nucl_coord(j,2) - dz = z - nucl_coord(j,3) - - phase += List_all_comb_b2(j,i) - a_expo += a * (dx*dx + dy*dy + dz*dz) - ax_der += a * dx - ay_der += a * dy - az_der += a * dz - enddo - e = -2.d0 * (-1.d0)**dble(phase) * dexp(-a_expo) - - fact_x += e * ax_der - fact_y += e * ay_der - fact_z += e * az_der - enddo - - v_1b_grad(1,ipoint) = fact_x - v_1b_grad(2,ipoint) = fact_y - v_1b_grad(3,ipoint) = fact_z - enddo - - elseif(j1b_type .eq. 4) then - - ! v(r) = 1 - \sum_{a} \beta_a \exp(-\alpha_a (r - r_a)^2) - - do ipoint = 1, n_points_final_grid - - x = final_grid_points(1,ipoint) - y = final_grid_points(2,ipoint) - z = final_grid_points(3,ipoint) - - ax_der = 0.d0 - ay_der = 0.d0 - az_der = 0.d0 - do j = 1, nucl_num - - dx = x - nucl_coord(j,1) - dy = y - nucl_coord(j,2) - dz = z - nucl_coord(j,3) - r2 = dx*dx + dy*dy + dz*dz - - a = j1b_pen(j) - e = a * j1b_pen_coef(j) * dexp(-a * r2) - - ax_der += e * dx - ay_der += e * dy - az_der += e * dz - enddo - - v_1b_grad(1,ipoint) = 2.d0 * ax_der - v_1b_grad(2,ipoint) = 2.d0 * ay_der - v_1b_grad(3,ipoint) = 2.d0 * az_der - enddo - - else - - print*, 'j1b_type = ', j1b_type, 'is not implemented' - stop - - endif - -END_PROVIDER - -! --- - -BEGIN_PROVIDER [ double precision, v_1b_lapl, (n_points_final_grid)] - - implicit none - integer :: ipoint, i, j, phase - double precision :: x, y, z, dx, dy, dz - double precision :: a, e, b - double precision :: fact_r - double precision :: ax_der, ay_der, az_der, a_expo - - do ipoint = 1, n_points_final_grid - - x = final_grid_points(1,ipoint) - y = final_grid_points(2,ipoint) - z = final_grid_points(3,ipoint) - - fact_r = 0.d0 - do i = 1, List_all_comb_b2_size - - phase = 0 - b = 0.d0 - a_expo = 0.d0 - ax_der = 0.d0 - ay_der = 0.d0 - az_der = 0.d0 - do j = 1, nucl_num - a = dble(List_all_comb_b2(j,i)) * j1b_pen(j) - dx = x - nucl_coord(j,1) - dy = y - nucl_coord(j,2) - dz = z - nucl_coord(j,3) - - phase += List_all_comb_b2(j,i) - b += a - a_expo += a * (dx*dx + dy*dy + dz*dz) - ax_der += a * dx - ay_der += a * dy - az_der += a * dz - enddo - - fact_r += (-1.d0)**dble(phase) * (-6.d0*b + 4.d0*(ax_der*ax_der + ay_der*ay_der + az_der*az_der) ) * dexp(-a_expo) - enddo - - v_1b_lapl(ipoint) = fact_r - enddo - -END_PROVIDER - -! --- - -BEGIN_PROVIDER [ double precision, v_1b_list_b2, (n_points_final_grid)] - - implicit none - integer :: i, ipoint - double precision :: x, y, z, coef, expo, dx, dy, dz - double precision :: fact_r - - PROVIDE List_all_comb_b2_coef List_all_comb_b2_expo List_all_comb_b2_cent - - do ipoint = 1, n_points_final_grid - - x = final_grid_points(1,ipoint) - y = final_grid_points(2,ipoint) - z = final_grid_points(3,ipoint) - - fact_r = 0.d0 - do i = 1, List_all_comb_b2_size - - coef = List_all_comb_b2_coef(i) - expo = List_all_comb_b2_expo(i) - - dx = x - List_all_comb_b2_cent(1,i) - dy = y - List_all_comb_b2_cent(2,i) - dz = z - List_all_comb_b2_cent(3,i) - - fact_r += coef * dexp(-expo * (dx*dx + dy*dy + dz*dz)) - enddo - - v_1b_list_b2(ipoint) = fact_r - enddo - -END_PROVIDER - -! --- - -BEGIN_PROVIDER [ double precision, v_1b_list_b3, (n_points_final_grid)] - - implicit none - integer :: i, ipoint - double precision :: x, y, z, coef, expo, dx, dy, dz - double precision :: fact_r - - PROVIDE List_all_comb_b3_coef List_all_comb_b3_expo List_all_comb_b3_cent - - do ipoint = 1, n_points_final_grid - - x = final_grid_points(1,ipoint) - y = final_grid_points(2,ipoint) - z = final_grid_points(3,ipoint) - - fact_r = 0.d0 - do i = 1, List_all_comb_b3_size - - coef = List_all_comb_b3_coef(i) - expo = List_all_comb_b3_expo(i) - - dx = x - List_all_comb_b3_cent(1,i) - dy = y - List_all_comb_b3_cent(2,i) - dz = z - List_all_comb_b3_cent(3,i) - - fact_r += coef * dexp(-expo * (dx*dx + dy*dy + dz*dz)) - enddo - - v_1b_list_b3(ipoint) = fact_r - enddo - -END_PROVIDER - -! --- - - BEGIN_PROVIDER [double precision, v_1b_square_grad, (n_points_final_grid,3)] -&BEGIN_PROVIDER [double precision, v_1b_square_lapl, (n_points_final_grid) ] - - implicit none - integer :: ipoint, i - double precision :: x, y, z, dx, dy, dz, r2 - double precision :: coef, expo, a_expo, tmp - double precision :: fact_x, fact_y, fact_z, fact_r - - PROVIDE List_all_comb_b3_coef List_all_comb_b3_expo List_all_comb_b3_cent - - do ipoint = 1, n_points_final_grid - - x = final_grid_points(1,ipoint) - y = final_grid_points(2,ipoint) - z = final_grid_points(3,ipoint) - - fact_x = 0.d0 - fact_y = 0.d0 - fact_z = 0.d0 - fact_r = 0.d0 - do i = 1, List_all_comb_b3_size - - coef = List_all_comb_b3_coef(i) - expo = List_all_comb_b3_expo(i) - - dx = x - List_all_comb_b3_cent(1,i) - dy = y - List_all_comb_b3_cent(2,i) - dz = z - List_all_comb_b3_cent(3,i) - r2 = dx * dx + dy * dy + dz * dz - - a_expo = expo * r2 - tmp = coef * expo * dexp(-a_expo) - - fact_x += tmp * dx - fact_y += tmp * dy - fact_z += tmp * dz - fact_r += tmp * (3.d0 - 2.d0 * a_expo) - enddo - - v_1b_square_grad(ipoint,1) = -2.d0 * fact_x - v_1b_square_grad(ipoint,2) = -2.d0 * fact_y - v_1b_square_grad(ipoint,3) = -2.d0 * fact_z - v_1b_square_lapl(ipoint) = -2.d0 * fact_r - enddo - -END_PROVIDER - -! --- - -double precision function j12_mu_r12(r12) - - include 'constants.include.F' - - implicit none - double precision, intent(in) :: r12 - double precision :: mu_r12 - - mu_r12 = mu_erf * r12 - - j12_mu_r12 = 0.5d0 * r12 * (1.d0 - derf(mu_r12)) - inv_sq_pi_2 * dexp(-mu_r12*mu_r12) / mu_erf - - return -end function j12_mu_r12 - -! --- - -double precision function jmu_modif(r1, r2) - - implicit none - double precision, intent(in) :: r1(3), r2(3) - double precision, external :: j12_mu, j12_nucl - - jmu_modif = j12_mu(r1, r2) * j12_nucl(r1, r2) - - return -end function jmu_modif - -! --- - -double precision function j12_mu_gauss(r1, r2) - - implicit none - double precision, intent(in) :: r1(3), r2(3) - integer :: i - double precision :: r12, coef, expo - - r12 = (r1(1) - r2(1)) * (r1(1) - r2(1)) & - + (r1(2) - r2(2)) * (r1(2) - r2(2)) & - + (r1(3) - r2(3)) * (r1(3) - r2(3)) - - j12_mu_gauss = 0.d0 - do i = 1, n_max_fit_slat - expo = expo_gauss_j_mu_x(i) - coef = coef_gauss_j_mu_x(i) - - j12_mu_gauss += coef * dexp(-expo*r12) - enddo - - return -end function j12_mu_gauss - -! --- - -double precision function j12_nucl(r1, r2) - - implicit none - double precision, intent(in) :: r1(3), r2(3) - double precision, external :: j1b_nucl - - j12_nucl = j1b_nucl(r1) * j1b_nucl(r2) - - return -end function j12_nucl - -! --- - -! --------------------------------------------------------------------------------------- - -double precision function grad_x_j1b_nucl_num(r) - - implicit none - double precision, intent(in) :: r(3) - double precision :: r_eps(3), eps, fp, fm, delta - double precision, external :: j1b_nucl - - eps = 1d-6 - r_eps = r - delta = max(eps, dabs(eps*r(1))) - - r_eps(1) = r_eps(1) + delta - fp = j1b_nucl(r_eps) - r_eps(1) = r_eps(1) - 2.d0 * delta - fm = j1b_nucl(r_eps) - - grad_x_j1b_nucl_num = 0.5d0 * (fp - fm) / delta - - return -end function grad_x_j1b_nucl_num - -double precision function grad_y_j1b_nucl_num(r) - - implicit none - double precision, intent(in) :: r(3) - double precision :: r_eps(3), eps, fp, fm, delta - double precision, external :: j1b_nucl - - eps = 1d-6 - r_eps = r - delta = max(eps, dabs(eps*r(2))) - - r_eps(2) = r_eps(2) + delta - fp = j1b_nucl(r_eps) - r_eps(2) = r_eps(2) - 2.d0 * delta - fm = j1b_nucl(r_eps) - - grad_y_j1b_nucl_num = 0.5d0 * (fp - fm) / delta - - return -end function grad_y_j1b_nucl_num - -double precision function grad_z_j1b_nucl_num(r) - - implicit none - double precision, intent(in) :: r(3) - double precision :: r_eps(3), eps, fp, fm, delta - double precision, external :: j1b_nucl - - eps = 1d-6 - r_eps = r - delta = max(eps, dabs(eps*r(3))) - - r_eps(3) = r_eps(3) + delta - fp = j1b_nucl(r_eps) - r_eps(3) = r_eps(3) - 2.d0 * delta - fm = j1b_nucl(r_eps) - - grad_z_j1b_nucl_num = 0.5d0 * (fp - fm) / delta - - return -end function grad_z_j1b_nucl_num - -! --------------------------------------------------------------------------------------- - -! --- - -double precision function lapl_j1b_nucl(r) - - implicit none - double precision, intent(in) :: r(3) - double precision :: r_eps(3), eps, fp, fm, delta - double precision, external :: grad_x_j1b_nucl_num - double precision, external :: grad_y_j1b_nucl_num - double precision, external :: grad_z_j1b_nucl_num - - eps = 1d-5 - r_eps = r - - lapl_j1b_nucl = 0.d0 - - ! --- - - delta = max(eps, dabs(eps*r(1))) - r_eps(1) = r_eps(1) + delta - fp = grad_x_j1b_nucl_num(r_eps) - r_eps(1) = r_eps(1) - 2.d0 * delta - fm = grad_x_j1b_nucl_num(r_eps) - r_eps(1) = r_eps(1) + delta - - lapl_j1b_nucl += 0.5d0 * (fp - fm) / delta - - ! --- - - delta = max(eps, dabs(eps*r(2))) - r_eps(2) = r_eps(2) + delta - fp = grad_y_j1b_nucl_num(r_eps) - r_eps(2) = r_eps(2) - 2.d0 * delta - fm = grad_y_j1b_nucl_num(r_eps) - r_eps(2) = r_eps(2) + delta - - lapl_j1b_nucl += 0.5d0 * (fp - fm) / delta - - ! --- - - delta = max(eps, dabs(eps*r(3))) - r_eps(3) = r_eps(3) + delta - fp = grad_z_j1b_nucl_num(r_eps) - r_eps(3) = r_eps(3) - 2.d0 * delta - fm = grad_z_j1b_nucl_num(r_eps) - r_eps(3) = r_eps(3) + delta - - lapl_j1b_nucl += 0.5d0 * (fp - fm) / delta - - ! --- - - return -end function lapl_j1b_nucl - -! --- - -! --------------------------------------------------------------------------------------- - -double precision function grad1_x_jmu_modif(r1, r2) - - implicit none - double precision, intent(in) :: r1(3), r2(3) - double precision :: r1_eps(3), eps, fp, fm, delta - double precision, external :: jmu_modif - - eps = 1d-7 - r1_eps = r1 - delta = max(eps, dabs(eps*r1(1))) - - r1_eps(1) = r1_eps(1) + delta - fp = jmu_modif(r1_eps, r2) - r1_eps(1) = r1_eps(1) - 2.d0 * delta - fm = jmu_modif(r1_eps, r2) - - grad1_x_jmu_modif = 0.5d0 * (fp - fm) / delta - - return -end function grad1_x_jmu_modif - -double precision function grad1_y_jmu_modif(r1, r2) - - implicit none - double precision, intent(in) :: r1(3), r2(3) - double precision :: r1_eps(3), eps, fp, fm, delta - double precision, external :: jmu_modif - - eps = 1d-7 - r1_eps = r1 - delta = max(eps, dabs(eps*r1(2))) - - r1_eps(2) = r1_eps(2) + delta - fp = jmu_modif(r1_eps, r2) - r1_eps(2) = r1_eps(2) - 2.d0 * delta - fm = jmu_modif(r1_eps, r2) - - grad1_y_jmu_modif = 0.5d0 * (fp - fm) / delta - - return -end function grad1_y_jmu_modif - -double precision function grad1_z_jmu_modif(r1, r2) - - implicit none - double precision, intent(in) :: r1(3), r2(3) - double precision :: r1_eps(3), eps, fp, fm, delta - double precision, external :: jmu_modif - - eps = 1d-7 - r1_eps = r1 - delta = max(eps, dabs(eps*r1(3))) - - r1_eps(3) = r1_eps(3) + delta - fp = jmu_modif(r1_eps, r2) - r1_eps(3) = r1_eps(3) - 2.d0 * delta - fm = jmu_modif(r1_eps, r2) - - grad1_z_jmu_modif = 0.5d0 * (fp - fm) / delta - - return -end function grad1_z_jmu_modif - -! --------------------------------------------------------------------------------------- - -! --- - -! --------------------------------------------------------------------------------------- - -double precision function grad1_x_j12_mu_num(r1, r2) - - implicit none - double precision, intent(in) :: r1(3), r2(3) - double precision :: r1_eps(3), eps, fp, fm, delta - double precision, external :: j12_mu - - eps = 1d-7 - r1_eps = r1 - delta = max(eps, dabs(eps*r1(1))) - - r1_eps(1) = r1_eps(1) + delta - fp = j12_mu(r1_eps, r2) - r1_eps(1) = r1_eps(1) - 2.d0 * delta - fm = j12_mu(r1_eps, r2) - - grad1_x_j12_mu_num = 0.5d0 * (fp - fm) / delta - - return -end function grad1_x_j12_mu_num - -double precision function grad1_y_j12_mu_num(r1, r2) - - implicit none - double precision, intent(in) :: r1(3), r2(3) - double precision :: r1_eps(3), eps, fp, fm, delta - double precision, external :: j12_mu - - eps = 1d-7 - r1_eps = r1 - delta = max(eps, dabs(eps*r1(2))) - - r1_eps(2) = r1_eps(2) + delta - fp = j12_mu(r1_eps, r2) - r1_eps(2) = r1_eps(2) - 2.d0 * delta - fm = j12_mu(r1_eps, r2) - - grad1_y_j12_mu_num = 0.5d0 * (fp - fm) / delta - - return -end function grad1_y_j12_mu_num - -double precision function grad1_z_j12_mu_num(r1, r2) - - implicit none - double precision, intent(in) :: r1(3), r2(3) - double precision :: r1_eps(3), eps, fp, fm, delta - double precision, external :: j12_mu - - eps = 1d-7 - r1_eps = r1 - delta = max(eps, dabs(eps*r1(3))) - - r1_eps(3) = r1_eps(3) + delta - fp = j12_mu(r1_eps, r2) - r1_eps(3) = r1_eps(3) - 2.d0 * delta - fm = j12_mu(r1_eps, r2) - - grad1_z_j12_mu_num = 0.5d0 * (fp - fm) / delta - - return -end function grad1_z_j12_mu_num - -! --------------------------------------------------------------------------------------- - -subroutine grad1_jmu_modif_num(r1, r2, grad) - - implicit none - - double precision, intent(in) :: r1(3), r2(3) - double precision, intent(out) :: grad(3) - - double precision :: tmp0, tmp1, tmp2, grad_u12(3) - - double precision, external :: j12_mu - double precision, external :: j1b_nucl - double precision, external :: grad_x_j1b_nucl_num - double precision, external :: grad_y_j1b_nucl_num - double precision, external :: grad_z_j1b_nucl_num - - call grad1_j12_mu(r1, r2, grad_u12) - - tmp0 = j1b_nucl(r1) - tmp1 = j1b_nucl(r2) - tmp2 = j12_mu(r1, r2) - - grad(1) = (tmp0 * grad_u12(1) + tmp2 * grad_x_j1b_nucl_num(r1)) * tmp1 - grad(2) = (tmp0 * grad_u12(2) + tmp2 * grad_y_j1b_nucl_num(r1)) * tmp1 - grad(3) = (tmp0 * grad_u12(3) + tmp2 * grad_z_j1b_nucl_num(r1)) * tmp1 - - return -end subroutine grad1_jmu_modif_num - -! --- - -subroutine get_tchint_rsdft_jastrow(x, y, dj) - - implicit none - double precision, intent(in) :: x(3), y(3) - double precision, intent(out) :: dj(3) - integer :: at - double precision :: a, mu_tmp, inv_sq_pi_2 - double precision :: tmp_x, tmp_y, tmp_z, tmp - double precision :: dx2, dy2, pos(3), dxy, dxy2 - double precision :: v1b_x, v1b_y - double precision :: u2b, grad1_u2b(3), grad1_v1b(3) - - PROVIDE mu_erf - - inv_sq_pi_2 = 0.5d0 / dsqrt(dacos(-1.d0)) - - dj = 0.d0 - -! double precision, external :: j12_mu, j1b_nucl -! v1b_x = j1b_nucl(x) -! v1b_y = j1b_nucl(y) -! call grad1_j1b_nucl(x, grad1_v1b) -! u2b = j12_mu(x, y) -! call grad1_j12_mu(x, y, grad1_u2b) - - ! 1b terms - v1b_x = 1.d0 - v1b_y = 1.d0 - tmp_x = 0.d0 - tmp_y = 0.d0 - tmp_z = 0.d0 - do at = 1, nucl_num - - a = j1b_pen(at) - pos(1) = nucl_coord(at,1) - pos(2) = nucl_coord(at,2) - pos(3) = nucl_coord(at,3) - - dx2 = sum((x-pos)**2) - dy2 = sum((y-pos)**2) - tmp = dexp(-a*dx2) * a - - v1b_x = v1b_x - dexp(-a*dx2) - v1b_y = v1b_y - dexp(-a*dy2) - - tmp_x = tmp_x + tmp * (x(1) - pos(1)) - tmp_y = tmp_y + tmp * (x(2) - pos(2)) - tmp_z = tmp_z + tmp * (x(3) - pos(3)) - end do - grad1_v1b(1) = 2.d0 * tmp_x - grad1_v1b(2) = 2.d0 * tmp_y - grad1_v1b(3) = 2.d0 * tmp_z - - ! 2b terms - dxy2 = sum((x-y)**2) - dxy = dsqrt(dxy2) - mu_tmp = mu_erf * dxy - u2b = 0.5d0 * dxy * (1.d0 - derf(mu_tmp)) - inv_sq_pi_2 * dexp(-mu_tmp*mu_tmp) / mu_erf - - if(dxy .lt. 1d-8) then - grad1_u2b(1) = 0.d0 - grad1_u2b(2) = 0.d0 - grad1_u2b(3) = 0.d0 - else - tmp = 0.5d0 * (1.d0 - derf(mu_tmp)) / dxy - grad1_u2b(1) = tmp * (x(1) - y(1)) - grad1_u2b(2) = tmp * (x(2) - y(2)) - grad1_u2b(3) = tmp * (x(3) - y(3)) - endif - - dj(1) = (grad1_u2b(1) * v1b_x + u2b * grad1_v1b(1)) * v1b_y - dj(2) = (grad1_u2b(2) * v1b_x + u2b * grad1_v1b(2)) * v1b_y - dj(3) = (grad1_u2b(3) * v1b_x + u2b * grad1_v1b(3)) * v1b_y - - return -end subroutine get_tchint_rsdft_jastrow - -! --- - - diff --git a/src/non_h_ints_mu/jast_deriv.irp.f b/src/non_h_ints_mu/jast_deriv.irp.f deleted file mode 100644 index 7a4717f7..00000000 --- a/src/non_h_ints_mu/jast_deriv.irp.f +++ /dev/null @@ -1,236 +0,0 @@ - -! --- - - BEGIN_PROVIDER [ double precision, grad1_u12_num, (n_points_extra_final_grid, n_points_final_grid, 3)] -&BEGIN_PROVIDER [ double precision, grad1_u12_squared_num, (n_points_extra_final_grid, n_points_final_grid)] - - BEGIN_DOC - ! - ! grad_1 u(r1,r2) - ! - ! this will be integrated numerically over r2: - ! we use grid for r1 and extra_grid for r2 - ! - ! for 99 < j1b_type < 199 - ! - ! u(r1,r2) = j12_mu(r12) x v(r1) x v(r2) - ! grad1 u(r1, r2) = [(grad1 j12_mu) v(r1) + j12_mu grad1 v(r1)] v(r2) - ! - END_DOC - - implicit none - integer :: ipoint, jpoint - double precision :: r1(3), r2(3) - double precision :: v1b_r1, v1b_r2, u2b_r12 - double precision :: grad1_v1b(3), grad1_u2b(3) - double precision :: dx, dy, dz - double precision :: time0, time1 - double precision, external :: j12_mu, j1b_nucl - - PROVIDE j1b_type - PROVIDE final_grid_points_extra - - print*, ' providing grad1_u12_num & grad1_u12_squared_num ...' - call wall_time(time0) - - grad1_u12_num = 0.d0 - grad1_u12_squared_num = 0.d0 - - if( (j1b_type .eq. 100) .or. & - (j1b_type .ge. 200) .and. (j1b_type .lt. 300) ) then - - !$OMP PARALLEL & - !$OMP DEFAULT (NONE) & - !$OMP PRIVATE (ipoint, jpoint, r1, r2, v1b_r1, v1b_r2, u2b_r12, grad1_v1b, grad1_u2b, dx, dy, dz) & - !$OMP SHARED (n_points_final_grid, n_points_extra_final_grid, final_grid_points, & - !$OMP final_grid_points_extra, grad1_u12_num, grad1_u12_squared_num) - !$OMP DO SCHEDULE (static) - do ipoint = 1, n_points_final_grid ! r1 - - r1(1) = final_grid_points(1,ipoint) - r1(2) = final_grid_points(2,ipoint) - r1(3) = final_grid_points(3,ipoint) - - do jpoint = 1, n_points_extra_final_grid ! r2 - - r2(1) = final_grid_points_extra(1,jpoint) - r2(2) = final_grid_points_extra(2,jpoint) - r2(3) = final_grid_points_extra(3,jpoint) - - call grad1_j12_mu(r1, r2, grad1_u2b) - - dx = grad1_u2b(1) - dy = grad1_u2b(2) - dz = grad1_u2b(3) - - grad1_u12_num(jpoint,ipoint,1) = dx - grad1_u12_num(jpoint,ipoint,2) = dy - grad1_u12_num(jpoint,ipoint,3) = dz - - grad1_u12_squared_num(jpoint,ipoint) = dx*dx + dy*dy + dz*dz - enddo - enddo - !$OMP END DO - !$OMP END PARALLEL - - elseif((j1b_type .gt. 100) .and. (j1b_type .lt. 200)) then - - PROVIDE final_grid_points - - !$OMP PARALLEL & - !$OMP DEFAULT (NONE) & - !$OMP PRIVATE (ipoint, jpoint, r1, r2, v1b_r1, v1b_r2, u2b_r12, grad1_v1b, grad1_u2b, dx, dy, dz) & - !$OMP SHARED (n_points_final_grid, n_points_extra_final_grid, final_grid_points, & - !$OMP final_grid_points_extra, grad1_u12_num, grad1_u12_squared_num) - !$OMP DO SCHEDULE (static) - do ipoint = 1, n_points_final_grid ! r1 - - r1(1) = final_grid_points(1,ipoint) - r1(2) = final_grid_points(2,ipoint) - r1(3) = final_grid_points(3,ipoint) - - v1b_r1 = j1b_nucl(r1) - call grad1_j1b_nucl(r1, grad1_v1b) - - do jpoint = 1, n_points_extra_final_grid ! r2 - - r2(1) = final_grid_points_extra(1,jpoint) - r2(2) = final_grid_points_extra(2,jpoint) - r2(3) = final_grid_points_extra(3,jpoint) - - v1b_r2 = j1b_nucl(r2) - u2b_r12 = j12_mu(r1, r2) - call grad1_j12_mu(r1, r2, grad1_u2b) - - dx = (grad1_u2b(1) * v1b_r1 + u2b_r12 * grad1_v1b(1)) * v1b_r2 - dy = (grad1_u2b(2) * v1b_r1 + u2b_r12 * grad1_v1b(2)) * v1b_r2 - dz = (grad1_u2b(3) * v1b_r1 + u2b_r12 * grad1_v1b(3)) * v1b_r2 - - grad1_u12_num(jpoint,ipoint,1) = dx - grad1_u12_num(jpoint,ipoint,2) = dy - grad1_u12_num(jpoint,ipoint,3) = dz - - grad1_u12_squared_num(jpoint,ipoint) = dx*dx + dy*dy + dz*dz - enddo - enddo - !$OMP END DO - !$OMP END PARALLEL - - elseif (j1b_type .eq. 1000) then - - double precision :: f - f = 1.d0 / dble(elec_num - 1) - - integer*8 :: n_points, k - n_points = n_points_extra_final_grid * n_points_final_grid - - double precision, allocatable :: rij(:,:,:) - allocate( rij(3, 2, n_points) ) - - use qmckl - integer(qmckl_exit_code) :: rc - - double precision, allocatable :: gl(:,:,:) - allocate( gl(2,4,n_points) ) - - k=0 - do ipoint = 1, n_points_final_grid ! r1 - do jpoint = 1, n_points_extra_final_grid ! r2 - k=k+1 - rij(1:3, 1, k) = final_grid_points (1:3, ipoint) - rij(1:3, 2, k) = final_grid_points_extra(1:3, jpoint) - enddo - enddo - - - rc = qmckl_set_electron_coord(qmckl_ctx_jastrow, 'N', n_points, rij, n_points*6_8) - if (rc /= QMCKL_SUCCESS) then - print *, irp_here, 'qmckl error in set_electron_coord' - rc = qmckl_check(qmckl_ctx_jastrow, rc) - stop -1 - endif - - - ! --- - ! e-e term - - rc = qmckl_get_jastrow_champ_factor_ee_gl(qmckl_ctx_jastrow, gl, 8_8*n_points) - if (rc /= QMCKL_SUCCESS) then - print *, irp_here, ' qmckl error in fact_ee_gl' - rc = qmckl_check(qmckl_ctx_jastrow, rc) - stop -1 - endif - - k=0 - do ipoint = 1, n_points_final_grid ! r1 - do jpoint = 1, n_points_extra_final_grid ! r2 - k=k+1 - grad1_u12_num(jpoint,ipoint,1) = gl(1,1,k) - grad1_u12_num(jpoint,ipoint,2) = gl(1,2,k) - grad1_u12_num(jpoint,ipoint,3) = gl(1,3,k) - enddo - enddo - - ! --- - ! e-e-n term - -! rc = qmckl_get_jastrow_champ_factor_een_gl(qmckl_ctx_jastrow, gl, 8_8*n_points) -! if (rc /= QMCKL_SUCCESS) then -! print *, irp_here, 'qmckl error in fact_een_gl' -! rc = qmckl_check(qmckl_ctx_jastrow, rc) -! stop -1 -! endif -! -! k=0 -! do ipoint = 1, n_points_final_grid ! r1 -! do jpoint = 1, n_points_extra_final_grid ! r2 -! k=k+1 -! grad1_u12_num(jpoint,ipoint,1) = grad1_u12_num(jpoint,ipoint,1) + gl(1,1,k) -! grad1_u12_num(jpoint,ipoint,2) = grad1_u12_num(jpoint,ipoint,2) + gl(1,2,k) -! grad1_u12_num(jpoint,ipoint,3) = grad1_u12_num(jpoint,ipoint,3) + gl(1,3,k) -! enddo -! enddo - - ! --- - ! e-n term - - rc = qmckl_get_jastrow_champ_factor_en_gl(qmckl_ctx_jastrow, gl, 8_8*n_points) - if (rc /= QMCKL_SUCCESS) then - print *, irp_here, 'qmckl error in fact_en_gl' - rc = qmckl_check(qmckl_ctx_jastrow, rc) - stop -1 - endif - - k=0 - do ipoint = 1, n_points_final_grid ! r1 - do jpoint = 1, n_points_extra_final_grid ! r2 - k = k+1 - grad1_u12_num(jpoint,ipoint,1) = grad1_u12_num(jpoint,ipoint,1) + f * gl(1,1,k) - grad1_u12_num(jpoint,ipoint,2) = grad1_u12_num(jpoint,ipoint,2) + f * gl(1,2,k) - grad1_u12_num(jpoint,ipoint,3) = grad1_u12_num(jpoint,ipoint,3) + f * gl(1,3,k) - enddo - - do jpoint = 1, n_points_extra_final_grid ! r2 - dx = grad1_u12_num(jpoint,ipoint,1) - dy = grad1_u12_num(jpoint,ipoint,2) - dz = grad1_u12_num(jpoint,ipoint,3) - grad1_u12_squared_num(jpoint,ipoint) = dx*dx + dy*dy + dz*dz - enddo - enddo - - deallocate(gl, rij) - - else - - print *, ' j1b_type = ', j1b_type, 'not implemented yet' - stop - - endif - - call wall_time(time1) - print*, ' Wall time for grad1_u12_num & grad1_u12_squared_num (min) =', (time1-time0)/60.d0 - -END_PROVIDER - -! --- - diff --git a/src/non_h_ints_mu/new_grad_tc.irp.f b/src/non_h_ints_mu/new_grad_tc.irp.f deleted file mode 100644 index ab3cc3be..00000000 --- a/src/non_h_ints_mu/new_grad_tc.irp.f +++ /dev/null @@ -1,171 +0,0 @@ - -! --- - -BEGIN_PROVIDER [double precision, tc_grad_and_lapl_ao_loop, (ao_num, ao_num, ao_num, ao_num)] - - BEGIN_DOC - ! - ! tc_grad_and_lapl_ao_loop(k,i,l,j) = < k l | -1/2 \Delta_1 u(r1,r2) - \grad_1 u(r1,r2) . \grad_1 | ij > - ! - ! = 1/2 \int dr1 (phi_k(r1) \grad_r1 phi_i(r1) - phi_i(r1) \grad_r1 phi_k(r1)) . \int dr2 \grad_r1 u(r1,r2) \phi_l(r2) \phi_j(r2) - ! - ! This is obtained by integration by parts. - ! - END_DOC - - implicit none - integer :: ipoint, i, j, k, l - double precision :: weight1, contrib_x, contrib_y, contrib_z, tmp_x, tmp_y, tmp_z - double precision :: ao_k_r, ao_i_r, ao_i_dx, ao_i_dy, ao_i_dz - double precision :: ao_j_r, ao_l_r, ao_l_dx, ao_l_dy, ao_l_dz - double precision :: time0, time1 - double precision, allocatable :: ac_mat(:,:,:,:) - - print*, ' providing tc_grad_and_lapl_ao_loop ...' - call wall_time(time0) - - allocate(ac_mat(ao_num,ao_num,ao_num,ao_num)) - ac_mat = 0.d0 - - ! --- - - do ipoint = 1, n_points_final_grid - weight1 = 0.5d0 * final_weight_at_r_vector(ipoint) - - do i = 1, ao_num - ao_i_r = weight1 * aos_in_r_array (i,ipoint) - ao_i_dx = weight1 * aos_grad_in_r_array(i,ipoint,1) - ao_i_dy = weight1 * aos_grad_in_r_array(i,ipoint,2) - ao_i_dz = weight1 * aos_grad_in_r_array(i,ipoint,3) - - do k = 1, ao_num - ao_k_r = aos_in_r_array(k,ipoint) - - tmp_x = ao_k_r * ao_i_dx - ao_i_r * aos_grad_in_r_array(k,ipoint,1) - tmp_y = ao_k_r * ao_i_dy - ao_i_r * aos_grad_in_r_array(k,ipoint,2) - tmp_z = ao_k_r * ao_i_dz - ao_i_r * aos_grad_in_r_array(k,ipoint,3) - - do j = 1, ao_num - do l = 1, ao_num - - contrib_x = int2_grad1_u12_ao(l,j,ipoint,1) * tmp_x - contrib_y = int2_grad1_u12_ao(l,j,ipoint,2) * tmp_y - contrib_z = int2_grad1_u12_ao(l,j,ipoint,3) * tmp_z - - ac_mat(k,i,l,j) += contrib_x + contrib_y + contrib_z - enddo - enddo - enddo - enddo - enddo - - ! --- - - do j = 1, ao_num - do l = 1, ao_num - do i = 1, ao_num - do k = 1, ao_num - tc_grad_and_lapl_ao_loop(k,i,l,j) = ac_mat(k,i,l,j) + ac_mat(l,j,k,i) - enddo - enddo - enddo - enddo - - deallocate(ac_mat) - - call wall_time(time1) - print*, ' Wall time for tc_grad_and_lapl_ao_loop = ', time1 - time0 - -END_PROVIDER - -! --- - -BEGIN_PROVIDER [double precision, tc_grad_and_lapl_ao, (ao_num, ao_num, ao_num, ao_num)] - - BEGIN_DOC - ! - ! tc_grad_and_lapl_ao(k,i,l,j) = < k l | -1/2 \Delta_1 u(r1,r2) - \grad_1 u(r1,r2) . \grad_1 | ij > - ! - ! = -1/2 \int dr1 (phi_k(r1) \grad_r1 phi_i(r1) - phi_i(r1) \grad_r1 phi_k(r1)) . \int dr2 \grad_r1 u(r1,r2) \phi_l(r2) \phi_j(r2) - ! = 1/2 \int dr1 (phi_k(r1) \grad_r1 phi_i(r1) - phi_i(r1) \grad_r1 phi_k(r1)) . \int dr2 (-1) \grad_r1 u(r1,r2) \phi_l(r2) \phi_j(r2) - ! - ! -1 in \int dr2 - ! - ! This is obtained by integration by parts. - ! - END_DOC - - implicit none - integer :: ipoint, i, j, k, l, m - double precision :: weight1, ao_k_r, ao_i_r - double precision :: time0, time1 - double precision, allocatable :: b_mat(:,:,:,:) - - print*, ' providing tc_grad_and_lapl_ao ...' - call wall_time(time0) - - if(read_tc_integ) then - - open(unit=11, form="unformatted", file=trim(ezfio_filename)//'/work/tc_grad_and_lapl_ao', action="read") - read(11) tc_grad_and_lapl_ao - close(11) - - else - - PROVIDE int2_grad1_u12_ao - - allocate(b_mat(n_points_final_grid,ao_num,ao_num,3)) - - b_mat = 0.d0 - !$OMP PARALLEL & - !$OMP DEFAULT (NONE) & - !$OMP PRIVATE (i, k, ipoint, weight1, ao_i_r, ao_k_r) & - !$OMP SHARED (aos_in_r_array_transp, aos_grad_in_r_array_transp_bis, b_mat, & - !$OMP ao_num, n_points_final_grid, final_weight_at_r_vector) - !$OMP DO SCHEDULE (static) - do i = 1, ao_num - do k = 1, ao_num - do ipoint = 1, n_points_final_grid - - weight1 = 0.5d0 * final_weight_at_r_vector(ipoint) - ao_i_r = aos_in_r_array_transp(ipoint,i) - ao_k_r = aos_in_r_array_transp(ipoint,k) - - b_mat(ipoint,k,i,1) = weight1 * (ao_k_r * aos_grad_in_r_array_transp_bis(ipoint,i,1) - ao_i_r * aos_grad_in_r_array_transp_bis(ipoint,k,1)) - b_mat(ipoint,k,i,2) = weight1 * (ao_k_r * aos_grad_in_r_array_transp_bis(ipoint,i,2) - ao_i_r * aos_grad_in_r_array_transp_bis(ipoint,k,2)) - b_mat(ipoint,k,i,3) = weight1 * (ao_k_r * aos_grad_in_r_array_transp_bis(ipoint,i,3) - ao_i_r * aos_grad_in_r_array_transp_bis(ipoint,k,3)) - enddo - enddo - enddo - !$OMP END DO - !$OMP END PARALLEL - - tc_grad_and_lapl_ao = 0.d0 - do m = 1, 3 - call dgemm( "N", "N", ao_num*ao_num, ao_num*ao_num, n_points_final_grid, 1.d0 & - , int2_grad1_u12_ao(1,1,1,m), ao_num*ao_num, b_mat(1,1,1,m), n_points_final_grid & - , 1.d0, tc_grad_and_lapl_ao, ao_num*ao_num) - enddo - deallocate(b_mat) - - call sum_A_At(tc_grad_and_lapl_ao(1,1,1,1), ao_num*ao_num) - - endif - - if(write_tc_integ.and.mpi_master) then - open(unit=11, form="unformatted", file=trim(ezfio_filename)//'/work/tc_grad_and_lapl_ao', action="write") - call ezfio_set_work_empty(.False.) - write(11) tc_grad_and_lapl_ao - close(11) - call ezfio_set_tc_keywords_io_tc_integ('Read') - endif - - call wall_time(time1) - print*, ' Wall time for tc_grad_and_lapl_ao = ', time1 - time0 - call print_memory_usage() - -END_PROVIDER - -! --- - - diff --git a/src/non_h_ints_mu/tc_integ_an.irp.f b/src/non_h_ints_mu/tc_integ_an.irp.f deleted file mode 100644 index a6459761..00000000 --- a/src/non_h_ints_mu/tc_integ_an.irp.f +++ /dev/null @@ -1,248 +0,0 @@ - -BEGIN_PROVIDER [double precision, int2_grad1_u12_ao, (ao_num, ao_num, n_points_final_grid, 3)] - - BEGIN_DOC - ! - ! TODO - ! combine with int2_grad1_u12_square_ao to avoid repeated calculation ? - ! - ! int2_grad1_u12_ao(i,j,ipoint,:) = \int dr2 [-1 * \grad_r1 J(r1,r2)] \phi_i(r2) \phi_j(r2) - ! - ! where r1 = r(ipoint) - ! - ! if J(r1,r2) = u12 (j1b_type .eq. 1) - ! - ! int2_grad1_u12_ao(i,j,ipoint,:) = 0.5 x \int dr2 [(r1 - r2) (erf(mu * r12)-1)r_12] \phi_i(r2) \phi_j(r2) - ! = 0.5 * [ v_ij_erf_rk_cst_mu(i,j,ipoint) * r(:) - x_v_ij_erf_rk_cst_mu(i,j,ipoint,:) ] - ! - ! if J(r1,r2) = u12 x v1 x v2 (j1b_type .eq. 3) - ! - ! int2_grad1_u12_ao(i,j,ipoint,:) = v1 x [ 0.5 x \int dr2 [(r1 - r2) (erf(mu * r12)-1)r_12] v2 \phi_i(r2) \phi_j(r2) ] - ! - \grad_1 v1 x [ \int dr2 u12 v2 \phi_i(r2) \phi_j(r2) ] - ! = 0.5 v_1b(ipoint) * v_ij_erf_rk_cst_mu_j1b(i,j,ipoint) * r(:) - ! - 0.5 v_1b(ipoint) * x_v_ij_erf_rk_cst_mu_j1b(i,j,ipoint,:) - ! - v_1b_grad[:,ipoint] * v_ij_u_cst_mu_j1b(i,j,ipoint) - ! - END_DOC - - implicit none - integer :: ipoint, i, j, m, jpoint - double precision :: time0, time1 - double precision :: x, y, z, w, tmp_x, tmp_y, tmp_z, tmp0, tmp1, tmp2 - - print*, ' providing int2_grad1_u12_ao ...' - call wall_time(time0) - - PROVIDE j1b_type - - if(read_tc_integ) then - - open(unit=11, form="unformatted", file=trim(ezfio_filename)//'/work/int2_grad1_u12_ao', action="read") - read(11) int2_grad1_u12_ao - - else - - if(j1b_type .eq. 0) then - - PROVIDE v_ij_erf_rk_cst_mu x_v_ij_erf_rk_cst_mu - - int2_grad1_u12_ao = 0.d0 - !$OMP PARALLEL & - !$OMP DEFAULT (NONE) & - !$OMP PRIVATE (ipoint, i, j, x, y, z, tmp1) & - !$OMP SHARED ( ao_num, n_points_final_grid, final_grid_points & - !$OMP , v_ij_erf_rk_cst_mu, x_v_ij_erf_rk_cst_mu, int2_grad1_u12_ao) - !$OMP DO SCHEDULE (static) - do ipoint = 1, n_points_final_grid - x = final_grid_points(1,ipoint) - y = final_grid_points(2,ipoint) - z = final_grid_points(3,ipoint) - do j = 1, ao_num - do i = 1, ao_num - tmp1 = v_ij_erf_rk_cst_mu(i,j,ipoint) - int2_grad1_u12_ao(i,j,ipoint,1) = 0.5d0 * (tmp1 * x - x_v_ij_erf_rk_cst_mu(i,j,ipoint,1)) - int2_grad1_u12_ao(i,j,ipoint,2) = 0.5d0 * (tmp1 * y - x_v_ij_erf_rk_cst_mu(i,j,ipoint,2)) - int2_grad1_u12_ao(i,j,ipoint,3) = 0.5d0 * (tmp1 * z - x_v_ij_erf_rk_cst_mu(i,j,ipoint,3)) - enddo - enddo - enddo - !$OMP END DO - !$OMP END PARALLEL - - elseif((j1b_type .eq. 3) .or. (j1b_type .eq. 4)) then - - PROVIDE v_1b_grad - PROVIDE v_ij_erf_rk_cst_mu_j1b v_ij_u_cst_mu_j1b_an x_v_ij_erf_rk_cst_mu_j1b - - int2_grad1_u12_ao = 0.d0 - !$OMP PARALLEL & - !$OMP DEFAULT (NONE) & - !$OMP PRIVATE (ipoint, i, j, x, y, z, tmp0, tmp1, tmp2, tmp_x, tmp_y, tmp_z) & - !$OMP SHARED ( ao_num, n_points_final_grid, final_grid_points, v_1b, v_1b_grad & - !$OMP , v_ij_erf_rk_cst_mu_j1b, v_ij_u_cst_mu_j1b_an, x_v_ij_erf_rk_cst_mu_j1b, int2_grad1_u12_ao) - !$OMP DO SCHEDULE (static) - do ipoint = 1, n_points_final_grid - x = final_grid_points(1,ipoint) - y = final_grid_points(2,ipoint) - z = final_grid_points(3,ipoint) - tmp0 = 0.5d0 * v_1b(ipoint) - tmp_x = v_1b_grad(1,ipoint) - tmp_y = v_1b_grad(2,ipoint) - tmp_z = v_1b_grad(3,ipoint) - do j = 1, ao_num - do i = 1, ao_num - tmp1 = tmp0 * v_ij_erf_rk_cst_mu_j1b(i,j,ipoint) - tmp2 = v_ij_u_cst_mu_j1b_an(i,j,ipoint) - int2_grad1_u12_ao(i,j,ipoint,1) = tmp1 * x - tmp0 * x_v_ij_erf_rk_cst_mu_j1b(i,j,ipoint,1) - tmp2 * tmp_x - int2_grad1_u12_ao(i,j,ipoint,2) = tmp1 * y - tmp0 * x_v_ij_erf_rk_cst_mu_j1b(i,j,ipoint,2) - tmp2 * tmp_y - int2_grad1_u12_ao(i,j,ipoint,3) = tmp1 * z - tmp0 * x_v_ij_erf_rk_cst_mu_j1b(i,j,ipoint,3) - tmp2 * tmp_z - enddo - enddo - enddo - !$OMP END DO - !$OMP END PARALLEL - - FREE v_ij_erf_rk_cst_mu_j1b v_ij_u_cst_mu_j1b_an x_v_ij_erf_rk_cst_mu_j1b - - elseif(j1b_type .ge. 100) then - -! PROVIDE int2_grad1_u12_ao_num -! int2_grad1_u12_ao = int2_grad1_u12_ao_num - - PROVIDE int2_grad1_u12_ao_num_1shot - int2_grad1_u12_ao = int2_grad1_u12_ao_num_1shot - - else - - print *, ' j1b_type = ', j1b_type, 'not implemented yet' - stop - - endif - endif - - if(write_tc_integ.and.mpi_master) then - open(unit=11, form="unformatted", file=trim(ezfio_filename)//'/work/int2_grad1_u12_ao', action="write") - call ezfio_set_work_empty(.False.) - write(11) int2_grad1_u12_ao - close(11) - call ezfio_set_tc_keywords_io_tc_integ('Read') - endif - - call wall_time(time1) - print*, ' wall time for int2_grad1_u12_ao =', time1-time0 - call print_memory_usage() - -END_PROVIDER - -! --- - -BEGIN_PROVIDER [double precision, int2_grad1_u12_square_ao, (ao_num, ao_num, n_points_final_grid)] - - BEGIN_DOC - ! - ! int2_grad1_u12_square_ao = -(1/2) x int dr2 chi_l(r2) chi_j(r2) [grad_1 u(r1,r2)]^2 - ! - END_DOC - - implicit none - integer :: ipoint, i, j, m, jpoint - double precision :: time0, time1 - double precision :: x, y, z, w, tmp_x, tmp_y, tmp_z, tmp0, tmp1, tmp2 - - print*, ' providing int2_grad1_u12_square_ao ...' - call wall_time(time0) - - PROVIDE j1b_type - - if(j1b_type .eq. 0) then - - PROVIDE int2_grad1u2_grad2u2 - - int2_grad1_u12_square_ao = 0.d0 - !$OMP PARALLEL & - !$OMP DEFAULT (NONE) & - !$OMP PRIVATE (i, j, ipoint) & - !$OMP SHARED (int2_grad1_u12_square_ao, ao_num, n_points_final_grid, int2_grad1u2_grad2u2) - !$OMP DO SCHEDULE (static) - do ipoint = 1, n_points_final_grid - do j = 1, ao_num - do i = 1, ao_num - int2_grad1_u12_square_ao(i,j,ipoint) = int2_grad1u2_grad2u2(i,j,ipoint) - enddo - enddo - enddo - !$OMP END DO - !$OMP END PARALLEL - - elseif((j1b_type .eq. 3) .or. (j1b_type .eq. 4)) then - - if(use_ipp) then - - ! the term u12_grad1_u12_j1b_grad1_j1b is added directly for performance - PROVIDE u12sq_j1bsq grad12_j12 - - int2_grad1_u12_square_ao = 0.d0 - !$OMP PARALLEL & - !$OMP DEFAULT (NONE) & - !$OMP PRIVATE (i, j, ipoint) & - !$OMP SHARED (int2_grad1_u12_square_ao, ao_num, n_points_final_grid, u12sq_j1bsq, grad12_j12) - !$OMP DO SCHEDULE (static) - do ipoint = 1, n_points_final_grid - do j = 1, ao_num - do i = 1, ao_num - int2_grad1_u12_square_ao(i,j,ipoint) = u12sq_j1bsq(i,j,ipoint) + 0.5d0 * grad12_j12(i,j,ipoint) - enddo - enddo - enddo - !$OMP END DO - !$OMP END PARALLEL - - FREE u12sq_j1bsq grad12_j12 - - else - - PROVIDE u12sq_j1bsq u12_grad1_u12_j1b_grad1_j1b grad12_j12 - - int2_grad1_u12_square_ao = 0.d0 - !$OMP PARALLEL & - !$OMP DEFAULT (NONE) & - !$OMP PRIVATE (i, j, ipoint) & - !$OMP SHARED (int2_grad1_u12_square_ao, ao_num, n_points_final_grid, u12sq_j1bsq, grad12_j12, u12_grad1_u12_j1b_grad1_j1b) - !$OMP DO SCHEDULE (static) - do ipoint = 1, n_points_final_grid - do j = 1, ao_num - do i = 1, ao_num - int2_grad1_u12_square_ao(i,j,ipoint) = u12sq_j1bsq(i,j,ipoint) + u12_grad1_u12_j1b_grad1_j1b(i,j,ipoint) + 0.5d0 * grad12_j12(i,j,ipoint) - enddo - enddo - enddo - !$OMP END DO - !$OMP END PARALLEL - - FREE u12sq_j1bsq u12_grad1_u12_j1b_grad1_j1b grad12_j12 - - endif - - elseif(j1b_type .ge. 100) then - - ! PROVIDE int2_grad1_u12_square_ao_num - ! int2_grad1_u12_square_ao = int2_grad1_u12_square_ao_num - - PROVIDE int2_grad1_u12_square_ao_num_1shot - int2_grad1_u12_square_ao = int2_grad1_u12_square_ao_num_1shot - - else - - print *, ' j1b_type = ', j1b_type, 'not implemented yet' - stop - - endif - - call wall_time(time1) - print*, ' wall time for int2_grad1_u12_square_ao =', time1-time0 - call print_memory_usage() - -END_PROVIDER - -! --- - diff --git a/src/non_h_ints_mu/test_non_h_ints.irp.f b/src/non_h_ints_mu/test_non_h_ints.irp.f deleted file mode 100644 index 84674fa0..00000000 --- a/src/non_h_ints_mu/test_non_h_ints.irp.f +++ /dev/null @@ -1,687 +0,0 @@ - -! --- - -program test_non_h - - implicit none - - my_grid_becke = .True. - PROVIDE tc_grid1_a tc_grid1_r - my_n_pt_r_grid = tc_grid1_r - my_n_pt_a_grid = tc_grid1_a - touch my_grid_becke my_n_pt_r_grid my_n_pt_a_grid - - if(j1b_type .ge. 100) then - my_extra_grid_becke = .True. - PROVIDE tc_grid2_a tc_grid2_r - my_n_pt_r_extra_grid = tc_grid2_r - my_n_pt_a_extra_grid = tc_grid2_a - touch my_extra_grid_becke my_n_pt_r_extra_grid my_n_pt_a_extra_grid - endif - - - !call routine_grad_squared() - !call routine_fit() - - !call test_ipp() - - !call test_v_ij_u_cst_mu_j1b_an() - - call test_int2_grad1_u12_square_ao() - call test_int2_grad1_u12_ao() -end - -! --- - -subroutine routine_lapl_grad - implicit none - integer :: i,j,k,l - double precision :: grad_lapl, get_ao_tc_sym_two_e_pot,new,accu,contrib - double precision :: ao_two_e_integral_erf,get_ao_two_e_integral,count_n,accu_relat -! !!!!!!!!!!!!!!!!!!!!! WARNING -! THIS ROUTINE MAKES SENSE ONLY IF HAND MODIFIED coef_gauss_eff_pot(1:n_max_fit_slat) = 0. to cancel (1-erf(mu*r12))^2 - accu = 0.d0 - accu_relat = 0.d0 - count_n = 0.d0 - do i = 1, ao_num - do j = 1, ao_num - do k = 1, ao_num - do l = 1, ao_num - grad_lapl = get_ao_tc_sym_two_e_pot(i,j,k,l,ao_tc_sym_two_e_pot_map) ! pure gaussian part : comes from Lapl - grad_lapl += ao_two_e_integral_erf(i, k, j, l) ! erf(mu r12)/r12 : comes from Lapl - grad_lapl += ao_non_hermit_term_chemist(k,i,l,j) ! \grad u(r12) . grad - new = tc_grad_and_lapl_ao(k,i,l,j) - new += get_ao_two_e_integral(i,j,k,l,ao_integrals_map) - contrib = dabs(new - grad_lapl) - if(dabs(grad_lapl).gt.1.d-12)then - count_n += 1.d0 - accu_relat += 2.0d0 * contrib/dabs(grad_lapl+new) - endif - if(contrib.gt.1.d-10)then - print*,i,j,k,l - print*,grad_lapl,new,contrib - print*,2.0d0*contrib/dabs(grad_lapl+new+1.d-12) - endif - accu += contrib - enddo - enddo - enddo - enddo - print*,'accu = ',accu/count_n - print*,'accu/rel = ',accu_relat/count_n - -end - -subroutine routine_grad_squared - implicit none - integer :: i,j,k,l - double precision :: grad_squared, get_ao_tc_sym_two_e_pot,new,accu,contrib - double precision :: count_n,accu_relat -! !!!!!!!!!!!!!!!!!!!!! WARNING -! THIS ROUTINE MAKES SENSE ONLY IF HAND MODIFIED coef_gauss_eff_pot(n_max_fit_slat:n_max_fit_slat+1) = 0. to cancel exp(-'mu*r12)^2) - accu = 0.d0 - accu_relat = 0.d0 - count_n = 0.d0 - do i = 1, ao_num - do j = 1, ao_num - do k = 1, ao_num - do l = 1, ao_num - grad_squared = get_ao_tc_sym_two_e_pot(i,j,k,l,ao_tc_sym_two_e_pot_map) ! pure gaussian part : comes from Lapl - new = tc_grad_square_ao(k,i,l,j) - contrib = dabs(new - grad_squared) - if(dabs(grad_squared).gt.1.d-12)then - count_n += 1.d0 - accu_relat += 2.0d0 * contrib/dabs(grad_squared+new) - endif - if(contrib.gt.1.d-10)then - print*,i,j,k,l - print*,grad_squared,new,contrib - print*,2.0d0*contrib/dabs(grad_squared+new+1.d-12) - endif - accu += contrib - enddo - enddo - enddo - enddo - print*,'accu = ',accu/count_n - print*,'accu/rel = ',accu_relat/count_n - -end - -subroutine routine_fit - implicit none - integer :: i,nx - double precision :: dx,xmax,x,j_mu,j_mu_F_x_j,j_mu_fit_gauss - nx = 500 - xmax = 5.d0 - dx = xmax/dble(nx) - x = 0.d0 - print*,'coucou',mu_erf - do i = 1, nx - write(33,'(100(F16.10,X))') x,j_mu(x),j_mu_F_x_j(x),j_mu_fit_gauss(x) - x += dx - enddo - -end - - -subroutine test_ipp() - - implicit none - integer :: i, j, k, l, ipoint - double precision :: accu, norm, diff, old, new, eps, int_num - double precision :: weight1, ao_i_r, ao_k_r - double precision, allocatable :: b_mat(:,:,:), I1(:,:,:,:), I2(:,:,:,:) - - eps = 1d-7 - - allocate(b_mat(n_points_final_grid,ao_num,ao_num)) - b_mat = 0.d0 - - ! --- - - ! first way - - allocate(I1(ao_num,ao_num,ao_num,ao_num)) - I1 = 0.d0 - - PROVIDE u12_grad1_u12_j1b_grad1_j1b - - !$OMP PARALLEL & - !$OMP DEFAULT (NONE) & - !$OMP PRIVATE (i, k, ipoint) & - !$OMP SHARED (aos_in_r_array_transp, b_mat, ao_num, n_points_final_grid, final_weight_at_r_vector) - !$OMP DO SCHEDULE (static) - do i = 1, ao_num - do k = 1, ao_num - do ipoint = 1, n_points_final_grid - b_mat(ipoint,k,i) = final_weight_at_r_vector(ipoint) * aos_in_r_array_transp(ipoint,i) * aos_in_r_array_transp(ipoint,k) - enddo - enddo - enddo - !$OMP END DO - !$OMP END PARALLEL - - call dgemm( "N", "N", ao_num*ao_num, ao_num*ao_num, n_points_final_grid, 1.d0 & - , u12_grad1_u12_j1b_grad1_j1b(1,1,1), ao_num*ao_num, b_mat(1,1,1), n_points_final_grid & - , 0.d0, I1, ao_num*ao_num) - - ! --- - - ! 2nd way - - allocate(I2(ao_num,ao_num,ao_num,ao_num)) - I2 = 0.d0 - - PROVIDE int2_u2_j1b2 - - b_mat = 0.d0 - !$OMP PARALLEL & - !$OMP DEFAULT (NONE) & - !$OMP PRIVATE (i, k, ipoint, weight1, ao_i_r, ao_k_r) & - !$OMP SHARED (aos_in_r_array_transp, b_mat, ao_num, n_points_final_grid, final_weight_at_r_vector, & - !$OMP v_1b_square_grad, v_1b_square_lapl, aos_grad_in_r_array_transp_bis) - !$OMP DO SCHEDULE (static) - do i = 1, ao_num - do k = 1, ao_num - do ipoint = 1, n_points_final_grid - - weight1 = 0.25d0 * final_weight_at_r_vector(ipoint) - - ao_i_r = aos_in_r_array_transp(ipoint,i) - ao_k_r = aos_in_r_array_transp(ipoint,k) - - b_mat(ipoint,k,i) = weight1 * ( ao_k_r * ao_i_r * v_1b_square_lapl(ipoint) & - + (ao_k_r * aos_grad_in_r_array_transp_bis(ipoint,i,1) + ao_i_r * aos_grad_in_r_array_transp_bis(ipoint,k,1)) * v_1b_square_grad(ipoint,1) & - + (ao_k_r * aos_grad_in_r_array_transp_bis(ipoint,i,2) + ao_i_r * aos_grad_in_r_array_transp_bis(ipoint,k,2)) * v_1b_square_grad(ipoint,2) & - + (ao_k_r * aos_grad_in_r_array_transp_bis(ipoint,i,3) + ao_i_r * aos_grad_in_r_array_transp_bis(ipoint,k,3)) * v_1b_square_grad(ipoint,3) ) - enddo - enddo - enddo - !$OMP END DO - !$OMP END PARALLEL - - call dgemm( "N", "N", ao_num*ao_num, ao_num*ao_num, n_points_final_grid, 1.d0 & - , int2_u2_j1b2(1,1,1), ao_num*ao_num, b_mat(1,1,1), n_points_final_grid & - , 0.d0, I2, ao_num*ao_num) - - ! --- - - deallocate(b_mat) - - accu = 0.d0 - norm = 0.d0 - do i = 1, ao_num - do k = 1, ao_num - do l = 1, ao_num - do j = 1, ao_num - - old = I1(j,l,k,i) - new = I2(j,l,k,i) - - !print*, l, k, j, i - !print*, old, new - - diff = new - old - if(dabs(diff) .gt. eps) then - print*, ' problem on :', j, l, k, i - print*, ' diff = ', diff - print*, ' old value = ', old - print*, ' new value = ', new - call I_grade_gradu_naive1(i, j, k, l, int_num) - print*, ' full num1 = ', int_num - call I_grade_gradu_naive2(i, j, k, l, int_num) - print*, ' full num2 = ', int_num - call I_grade_gradu_naive3(i, j, k, l, int_num) - print*, ' full num3 = ', int_num - call I_grade_gradu_naive4(i, j, k, l, int_num) - print*, ' full num4 = ', int_num - call I_grade_gradu_seminaive(i, j, k, l, int_num) - print*, ' semi num = ', int_num - endif - - accu += dabs(diff) - norm += dabs(old) - enddo - enddo - enddo - enddo - - deallocate(I1, I2) - - print*, ' accu = ', accu - print*, ' norm = ', norm - - return -end subroutine test_ipp - -! --- - -subroutine I_grade_gradu_naive1(i, j, k, l, int) - - implicit none - integer, intent(in) :: i, j, k, l - double precision, intent(out) :: int - integer :: ipoint, jpoint - double precision :: r1(3), r2(3) - double precision :: weight1_x, weight1_y, weight1_z - double precision :: weight2_x, weight2_y, weight2_z - double precision :: aor_i, aor_j, aor_k, aor_l - double precision :: e1_val, e2_val, e1_der(3), u12_val, u12_der(3) - double precision, external :: j1b_nucl, j12_mu - - int = 0.d0 - - do ipoint = 1, n_points_final_grid ! r1 - - r1(1) = final_grid_points(1,ipoint) - r1(2) = final_grid_points(2,ipoint) - r1(3) = final_grid_points(3,ipoint) - - aor_i = aos_in_r_array_transp(ipoint,i) - aor_k = aos_in_r_array_transp(ipoint,k) - - e1_val = j1b_nucl(r1) - call grad1_j1b_nucl(r1, e1_der) - - weight1_x = aor_i * aor_k * e1_val * final_weight_at_r_vector(ipoint) * e1_der(1) - weight1_y = aor_i * aor_k * e1_val * final_weight_at_r_vector(ipoint) * e1_der(2) - weight1_z = aor_i * aor_k * e1_val * final_weight_at_r_vector(ipoint) * e1_der(3) - - do jpoint = 1, n_points_extra_final_grid ! r2 - - r2(1) = final_grid_points_extra(1,jpoint) - r2(2) = final_grid_points_extra(2,jpoint) - r2(3) = final_grid_points_extra(3,jpoint) - - aor_j = aos_in_r_array_extra_transp(jpoint,j) - aor_l = aos_in_r_array_extra_transp(jpoint,l) - - e2_val = j1b_nucl(r2) - - u12_val = j12_mu(r1, r2) - call grad1_j12_mu(r1, r2, u12_der) - - weight2_x = aor_j * aor_l * e2_val * e2_val * u12_val * final_weight_at_r_vector_extra(jpoint) * u12_der(1) - weight2_y = aor_j * aor_l * e2_val * e2_val * u12_val * final_weight_at_r_vector_extra(jpoint) * u12_der(2) - weight2_z = aor_j * aor_l * e2_val * e2_val * u12_val * final_weight_at_r_vector_extra(jpoint) * u12_der(3) - - int = int - (weight1_x * weight2_x + weight1_y * weight2_y + weight1_z * weight2_z) - enddo - enddo - - return -end subroutine I_grade_gradu_naive1 - -! --- - -subroutine I_grade_gradu_naive2(i, j, k, l, int) - - implicit none - integer, intent(in) :: i, j, k, l - double precision, intent(out) :: int - integer :: ipoint, jpoint - double precision :: r1(3), r2(3) - double precision :: weight1_x, weight1_y, weight1_z - double precision :: weight2_x, weight2_y, weight2_z - double precision :: aor_i, aor_j, aor_k, aor_l - double precision :: e1_square_der(3), e2_val, u12_square_der(3) - double precision, external :: j1b_nucl - - int = 0.d0 - - do ipoint = 1, n_points_final_grid ! r1 - - r1(1) = final_grid_points(1,ipoint) - r1(2) = final_grid_points(2,ipoint) - r1(3) = final_grid_points(3,ipoint) - - aor_i = aos_in_r_array_transp(ipoint,i) - aor_k = aos_in_r_array_transp(ipoint,k) - - call grad1_j1b_nucl_square_num(r1, e1_square_der) - - weight1_x = aor_i * aor_k * final_weight_at_r_vector(ipoint) * e1_square_der(1) - weight1_y = aor_i * aor_k * final_weight_at_r_vector(ipoint) * e1_square_der(2) - weight1_z = aor_i * aor_k * final_weight_at_r_vector(ipoint) * e1_square_der(3) - - do jpoint = 1, n_points_extra_final_grid ! r2 - - r2(1) = final_grid_points_extra(1,jpoint) - r2(2) = final_grid_points_extra(2,jpoint) - r2(3) = final_grid_points_extra(3,jpoint) - - aor_j = aos_in_r_array_extra_transp(jpoint,j) - aor_l = aos_in_r_array_extra_transp(jpoint,l) - - e2_val = j1b_nucl(r2) - call grad1_j12_mu_square_num(r1, r2, u12_square_der) - - weight2_x = aor_j * aor_l * e2_val * e2_val * final_weight_at_r_vector_extra(jpoint) * u12_square_der(1) - weight2_y = aor_j * aor_l * e2_val * e2_val * final_weight_at_r_vector_extra(jpoint) * u12_square_der(2) - weight2_z = aor_j * aor_l * e2_val * e2_val * final_weight_at_r_vector_extra(jpoint) * u12_square_der(3) - - int = int - 0.25d0 * (weight1_x * weight2_x + weight1_y * weight2_y + weight1_z * weight2_z) - enddo - enddo - - return -end subroutine I_grade_gradu_naive2 - -! --- - -subroutine I_grade_gradu_naive3(i, j, k, l, int) - - implicit none - integer, intent(in) :: i, j, k, l - double precision, intent(out) :: int - integer :: ipoint, jpoint - double precision :: r1(3), r2(3) - double precision :: weight1, weight2 - double precision :: aor_j, aor_l - double precision :: grad(3), e2_val, u12_val - double precision, external :: j1b_nucl, j12_mu - - int = 0.d0 - - do ipoint = 1, n_points_final_grid ! r1 - - r1(1) = final_grid_points(1,ipoint) - r1(2) = final_grid_points(2,ipoint) - r1(3) = final_grid_points(3,ipoint) - - call grad1_aos_ik_grad1_esquare(i, k, r1, grad) - - weight1 = final_weight_at_r_vector(ipoint) * (grad(1) + grad(2) + grad(3)) - - do jpoint = 1, n_points_extra_final_grid ! r2 - - r2(1) = final_grid_points_extra(1,jpoint) - r2(2) = final_grid_points_extra(2,jpoint) - r2(3) = final_grid_points_extra(3,jpoint) - - aor_j = aos_in_r_array_extra_transp(jpoint,j) - aor_l = aos_in_r_array_extra_transp(jpoint,l) - - e2_val = j1b_nucl(r2) - u12_val = j12_mu(r1, r2) - - weight2 = aor_j * aor_l * e2_val * e2_val * u12_val * u12_val * final_weight_at_r_vector_extra(jpoint) - - int = int + 0.25d0 * weight1 * weight2 - enddo - enddo - - return -end subroutine I_grade_gradu_naive3 - -! --- - -subroutine I_grade_gradu_naive4(i, j, k, l, int) - - implicit none - integer, intent(in) :: i, j, k, l - double precision, intent(out) :: int - integer :: ipoint, jpoint - double precision :: r1(3), r2(3) - double precision :: weight1, weight2 - double precision :: aor_j, aor_l, aor_k, aor_i - double precision :: grad(3), e2_val, u12_val - double precision, external :: j1b_nucl, j12_mu - - int = 0.d0 - - do ipoint = 1, n_points_final_grid ! r1 - - r1(1) = final_grid_points(1,ipoint) - r1(2) = final_grid_points(2,ipoint) - r1(3) = final_grid_points(3,ipoint) - - aor_i = aos_in_r_array_transp(ipoint,i) - aor_k = aos_in_r_array_transp(ipoint,k) - - weight1 = final_weight_at_r_vector(ipoint) * ( aor_k * aor_i * v_1b_square_lapl(ipoint) & - + (aor_k * aos_grad_in_r_array_transp_bis(ipoint,i,1) + aor_i * aos_grad_in_r_array_transp_bis(ipoint,k,1)) * v_1b_square_grad(ipoint,1) & - + (aor_k * aos_grad_in_r_array_transp_bis(ipoint,i,2) + aor_i * aos_grad_in_r_array_transp_bis(ipoint,k,2)) * v_1b_square_grad(ipoint,2) & - + (aor_k * aos_grad_in_r_array_transp_bis(ipoint,i,3) + aor_i * aos_grad_in_r_array_transp_bis(ipoint,k,3)) * v_1b_square_grad(ipoint,3) ) - - do jpoint = 1, n_points_extra_final_grid ! r2 - - r2(1) = final_grid_points_extra(1,jpoint) - r2(2) = final_grid_points_extra(2,jpoint) - r2(3) = final_grid_points_extra(3,jpoint) - - aor_j = aos_in_r_array_extra_transp(jpoint,j) - aor_l = aos_in_r_array_extra_transp(jpoint,l) - - e2_val = j1b_nucl(r2) - u12_val = j12_mu(r1, r2) - - weight2 = aor_j * aor_l * e2_val * e2_val * u12_val * u12_val * final_weight_at_r_vector_extra(jpoint) - - int = int + 0.25d0 * weight1 * weight2 - enddo - enddo - - return -end subroutine I_grade_gradu_naive4 - -! --- - -subroutine I_grade_gradu_seminaive(i, j, k, l, int) - - implicit none - integer, intent(in) :: i, j, k, l - double precision, intent(out) :: int - integer :: ipoint - double precision :: r1(3) - double precision :: weight1 - double precision :: aor_i, aor_k - - int = 0.d0 - - do ipoint = 1, n_points_final_grid ! r1 - - aor_i = aos_in_r_array_transp(ipoint,i) - aor_k = aos_in_r_array_transp(ipoint,k) - - weight1 = 0.25d0 * final_weight_at_r_vector(ipoint) * ( aor_k * aor_i * v_1b_square_lapl(ipoint) & - + (aor_k * aos_grad_in_r_array_transp_bis(ipoint,i,1) + aor_i * aos_grad_in_r_array_transp_bis(ipoint,k,1)) * v_1b_square_grad(ipoint,1) & - + (aor_k * aos_grad_in_r_array_transp_bis(ipoint,i,2) + aor_i * aos_grad_in_r_array_transp_bis(ipoint,k,2)) * v_1b_square_grad(ipoint,2) & - + (aor_k * aos_grad_in_r_array_transp_bis(ipoint,i,3) + aor_i * aos_grad_in_r_array_transp_bis(ipoint,k,3)) * v_1b_square_grad(ipoint,3) ) - - int = int + weight1 * int2_u2_j1b2(j,l,ipoint) - enddo - - return -end subroutine I_grade_gradu_seminaive - -! --- - -subroutine aos_ik_grad1_esquare(i, k, r1, val) - - implicit none - integer, intent(in) :: i, k - double precision, intent(in) :: r1(3) - double precision, intent(out) :: val(3) - double precision :: tmp - double precision :: der(3), aos_array(ao_num), aos_grad_array(3,ao_num) - - call give_all_aos_and_grad_at_r(r1, aos_array, aos_grad_array) - call grad1_j1b_nucl_square_num(r1, der) - - tmp = aos_array(i) * aos_array(k) - val(1) = tmp * der(1) - val(2) = tmp * der(2) - val(3) = tmp * der(3) - - return -end subroutine phi_ik_grad1_esquare - -! --- - -subroutine grad1_aos_ik_grad1_esquare(i, k, r1, grad) - - implicit none - integer, intent(in) :: i, k - double precision, intent(in) :: r1(3) - double precision, intent(out) :: grad(3) - double precision :: r(3), eps, tmp_eps, val_p(3), val_m(3) - - eps = 1d-5 - tmp_eps = 0.5d0 / eps - - r(1:3) = r1(1:3) - - r(1) = r(1) + eps - call aos_ik_grad1_esquare(i, k, r, val_p) - r(1) = r(1) - 2.d0 * eps - call aos_ik_grad1_esquare(i, k, r, val_m) - r(1) = r(1) + eps - grad(1) = tmp_eps * (val_p(1) - val_m(1)) - - r(2) = r(2) + eps - call aos_ik_grad1_esquare(i, k, r, val_p) - r(2) = r(2) - 2.d0 * eps - call aos_ik_grad1_esquare(i, k, r, val_m) - r(2) = r(2) + eps - grad(2) = tmp_eps * (val_p(2) - val_m(2)) - - r(3) = r(3) + eps - call aos_ik_grad1_esquare(i, k, r, val_p) - r(3) = r(3) - 2.d0 * eps - call aos_ik_grad1_esquare(i, k, r, val_m) - r(3) = r(3) + eps - grad(3) = tmp_eps * (val_p(3) - val_m(3)) - - return -end subroutine grad1_aos_ik_grad1_esquare - -! --- - -subroutine test_v_ij_u_cst_mu_j1b_an() - - implicit none - integer :: i, j, ipoint - double precision :: I_old, I_new - double precision :: norm, accu, thr, diff - - PROVIDE v_ij_u_cst_mu_j1b_an_old v_ij_u_cst_mu_j1b_an - - thr = 1d-12 - norm = 0.d0 - accu = 0.d0 - do ipoint = 1, n_points_final_grid - do i = 1, ao_num - do j = 1, ao_num - - I_old = v_ij_u_cst_mu_j1b_an_old(j,i,ipoint) - I_new = v_ij_u_cst_mu_j1b_an (j,i,ipoint) - - diff = dabs(I_new-I_old) - if(diff .gt. thr) then - print *, ' problem on:', j, i, ipoint - print *, ' old value :', I_old - print *, ' new value :', I_new - stop - endif - - accu += diff - norm += dabs(I_old) - enddo - enddo - enddo - - print*, ' accuracy(%) = ', 100.d0 * accu / norm - - return -end subroutine test_v_ij_u_cst_mu_j1b_an - -! --- - -subroutine test_int2_grad1_u12_square_ao() - - implicit none - integer :: i, j, ipoint - double precision :: I_old, I_new - double precision :: norm, accu, thr, diff - - PROVIDE int2_grad1_u12_square_ao - PROVIDE int2_grad1_u12_square_ao_num_1shot - - thr = 1d-8 - norm = 0.d0 - accu = 0.d0 - do ipoint = 1, n_points_final_grid - do i = 1, ao_num - do j = 1, ao_num - - I_old = int2_grad1_u12_square_ao_num_1shot(j,i,ipoint) - I_new = int2_grad1_u12_square_ao (j,i,ipoint) - !I_new = int2_grad1_u12_square_ao_num (j,i,ipoint) - - diff = dabs(I_new-I_old) - if(diff .gt. thr) then - print *, ' problem on:', j, i, ipoint - print *, ' old value :', I_old - print *, ' new value :', I_new - !stop - endif - - accu += diff - norm += dabs(I_old) - enddo - enddo - enddo - - print*, ' accuracy(%) = ', 100.d0 * accu / norm - - return -end subroutine test_int2_grad1_u12_square_ao - -! --- - -subroutine test_int2_grad1_u12_ao() - - implicit none - integer :: i, j, ipoint, m - double precision :: I_old, I_new - double precision :: norm, accu, thr, diff - - PROVIDE int2_grad1_u12_ao - PROVIDE int2_grad1_u12_ao_num_1shot - - thr = 1d-8 - norm = 0.d0 - accu = 0.d0 - do ipoint = 1, n_points_final_grid - do i = 1, ao_num - do j = 1, ao_num - - do m = 1, 3 - I_old = int2_grad1_u12_ao_num_1shot(j,i,ipoint,m) - I_new = int2_grad1_u12_ao (j,i,ipoint,m) - !I_new = int2_grad1_u12_ao_num (j,i,ipoint,m) - - diff = dabs(I_new-I_old) - if(diff .gt. thr) then - print *, ' problem on:', j, i, ipoint, m - print *, ' old value :', I_old - print *, ' new value :', I_new - !stop - endif - - accu += diff - norm += dabs(I_old) - enddo - enddo - enddo - enddo - - print*, ' accuracy(%) = ', 100.d0 * accu / norm - - return -end subroutine test_int2_grad1_u12_ao - -! --- - diff --git a/src/non_h_ints_mu/total_tc_int.irp.f b/src/non_h_ints_mu/total_tc_int.irp.f deleted file mode 100644 index 9c19e0ac..00000000 --- a/src/non_h_ints_mu/total_tc_int.irp.f +++ /dev/null @@ -1,190 +0,0 @@ - -! --- - -BEGIN_PROVIDER [double precision, ao_vartc_int_chemist, (ao_num, ao_num, ao_num, ao_num)] - - implicit none - integer :: i, j, k, l - double precision :: wall1, wall0 - - print *, ' providing ao_vartc_int_chemist ...' - call wall_time(wall0) - - if(test_cycle_tc) then - - PROVIDE j1b_type - if(j1b_type .ne. 3) then - print*, ' TC integrals with cycle can not be used for j1b_type =', j1b_type - stop - endif - - do j = 1, ao_num - do l = 1, ao_num - do i = 1, ao_num - do k = 1, ao_num - ao_vartc_int_chemist(k,i,l,j) = tc_grad_square_ao_test(k,i,l,j) + ao_two_e_coul(k,i,l,j) - enddo - enddo - enddo - enddo - - else - - do j = 1, ao_num - do l = 1, ao_num - do i = 1, ao_num - do k = 1, ao_num - ao_vartc_int_chemist(k,i,l,j) = tc_grad_square_ao(k,i,l,j) + ao_two_e_coul(k,i,l,j) - enddo - enddo - enddo - enddo - - endif - - call wall_time(wall1) - print *, ' wall time for ao_vartc_int_chemist ', wall1 - wall0 - -END_PROVIDER - -! --- - -BEGIN_PROVIDER [double precision, ao_tc_int_chemist, (ao_num, ao_num, ao_num, ao_num)] - - implicit none - integer :: i, j, k, l - double precision :: wall1, wall0 - - PROVIDE j1b_type - - print *, ' providing ao_tc_int_chemist ...' - call wall_time(wall0) - - if(test_cycle_tc) then - - if(j1b_type .ne. 3) then - print*, ' TC integrals with cycle can not be used for j1b_type =', j1b_type - stop - endif - - ao_tc_int_chemist = ao_tc_int_chemist_test - - else - - PROVIDE tc_grad_square_ao tc_grad_and_lapl_ao ao_two_e_coul - - do j = 1, ao_num - do l = 1, ao_num - do i = 1, ao_num - do k = 1, ao_num - ao_tc_int_chemist(k,i,l,j) = tc_grad_square_ao(k,i,l,j) + tc_grad_and_lapl_ao(k,i,l,j) + ao_two_e_coul(k,i,l,j) -! ao_tc_int_chemist(k,i,l,j) = ao_two_e_coul(k,i,l,j) - enddo - enddo - enddo - enddo - endif - - FREE tc_grad_square_ao tc_grad_and_lapl_ao ao_two_e_coul - - if(j1b_type .ge. 100) then - FREE int2_grad1_u12_ao_num int2_grad1_u12_square_ao_num - endif - - - call wall_time(wall1) - print *, ' wall time for ao_tc_int_chemist ', wall1 - wall0 - call print_memory_usage() - -END_PROVIDER - -! --- - -BEGIN_PROVIDER [double precision, ao_tc_int_chemist_no_cycle, (ao_num, ao_num, ao_num, ao_num)] - - implicit none - integer :: i, j, k, l - double precision :: wall1, wall0 - - print *, ' providing ao_tc_int_chemist_no_cycle ...' - call wall_time(wall0) - - do j = 1, ao_num - do l = 1, ao_num - do i = 1, ao_num - do k = 1, ao_num - ao_tc_int_chemist_no_cycle(k,i,l,j) = tc_grad_square_ao(k,i,l,j) + tc_grad_and_lapl_ao(k,i,l,j) + ao_two_e_coul(k,i,l,j) - !ao_tc_int_chemist(k,i,l,j) = ao_two_e_coul(k,i,l,j) - enddo - enddo - enddo - enddo - - call wall_time(wall1) - print *, ' wall time for ao_tc_int_chemist_no_cycle ', wall1 - wall0 - -END_PROVIDER - -! --- - -BEGIN_PROVIDER [double precision, ao_tc_int_chemist_test, (ao_num, ao_num, ao_num, ao_num)] - - implicit none - integer :: i, j, k, l - double precision :: wall1, wall0 - - print *, ' providing ao_tc_int_chemist_test ...' - call wall_time(wall0) - - do j = 1, ao_num - do l = 1, ao_num - do i = 1, ao_num - do k = 1, ao_num - ao_tc_int_chemist_test(k,i,l,j) = tc_grad_square_ao_test(k,i,l,j) + tc_grad_and_lapl_ao_test(k,i,l,j) + ao_two_e_coul(k,i,l,j) -! ao_tc_int_chemist_test(k,i,l,j) = ao_two_e_coul(k,i,l,j) - enddo - enddo - enddo - enddo - - call wall_time(wall1) - print *, ' wall time for ao_tc_int_chemist_test ', wall1 - wall0 - -END_PROVIDER - -! --- - -BEGIN_PROVIDER [double precision, ao_two_e_coul, (ao_num, ao_num, ao_num, ao_num) ] - - BEGIN_DOC - ! - ! ao_two_e_coul(k,i,l,j) = ( k i | 1/r12 | l j ) = < l k | 1/r12 | j i > - ! - END_DOC - - integer :: i, j, k, l - double precision, external :: get_ao_two_e_integral - - PROVIDE ao_integrals_map - - !$OMP PARALLEL DEFAULT(NONE) & - !$OMP SHARED(ao_num, ao_two_e_coul, ao_integrals_map) & - !$OMP PRIVATE(i, j, k, l) - !$OMP DO - do j = 1, ao_num - do l = 1, ao_num - do i = 1, ao_num - do k = 1, ao_num - ! < 1:k, 2:l | 1:i, 2:j > - ao_two_e_coul(k,i,l,j) = get_ao_two_e_integral(i, j, k, l, ao_integrals_map) - enddo - enddo - enddo - enddo - !$OMP END DO - !$OMP END PARALLEL - -END_PROVIDER - -! --- - diff --git a/src/nuclei/write_pt_charges.py b/src/nuclei/write_pt_charges.py index 03ac859b..910f03aa 100644 --- a/src/nuclei/write_pt_charges.py +++ b/src/nuclei/write_pt_charges.py @@ -52,7 +52,7 @@ fncharges.write(" "+str(n_charges)+'\n') fncharges.close() mv_in_ezfio(EZFIO,tmp) -# Write the file containing the charges and set in EZFIO folder +# Write the file containing the charges and set in EZFIO folder tmp="pts_charge_z" fcharges = open(tmp,'w') fcharges.write(" 1\n") diff --git a/src/tc_keywords/j1b_pen.irp.f b/src/tc_keywords/j1b_pen.irp.f deleted file mode 100644 index d509fc7e..00000000 --- a/src/tc_keywords/j1b_pen.irp.f +++ /dev/null @@ -1,155 +0,0 @@ - -! --- - - BEGIN_PROVIDER [ double precision, j1b_pen , (nucl_num) ] -&BEGIN_PROVIDER [ double precision, j1b_pen_coef, (nucl_num) ] - - BEGIN_DOC - ! parameters of the 1-body Jastrow - END_DOC - - implicit none - logical :: exists - integer :: i - integer :: ierr - - PROVIDE ezfio_filename - - ! --- - - if (mpi_master) then - call ezfio_has_tc_keywords_j1b_pen(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' - call MPI_BCAST(j1b_pen, (nucl_num), MPI_DOUBLE_PRECISION, 0, MPI_COMM_WORLD, ierr) - if (ierr /= MPI_SUCCESS) then - stop 'Unable to read j1b_pen with MPI' - endif - IRP_ENDIF - - if (exists) then - if (mpi_master) then - write(6,'(A)') '.. >>>>> [ IO READ: j1b_pen ] <<<<< ..' - call ezfio_get_tc_keywords_j1b_pen(j1b_pen) - IRP_IF MPI - call MPI_BCAST(j1b_pen, (nucl_num), MPI_DOUBLE_PRECISION, 0, MPI_COMM_WORLD, ierr) - if (ierr /= MPI_SUCCESS) then - stop 'Unable to read j1b_pen with MPI' - endif - IRP_ENDIF - endif - else - do i = 1, nucl_num - j1b_pen(i) = 1d5 - enddo - endif - - ! --- - - if (mpi_master) then - call ezfio_has_tc_keywords_j1b_pen_coef(exists) - endif - - IRP_IF MPI_DEBUG - print *, irp_here, mpi_rank - call MPI_BARRIER(MPI_COMM_WORLD, ierr) - IRP_ENDIF - - IRP_IF MPI - call MPI_BCAST(j1b_pen_coef, (nucl_num), MPI_DOUBLE_PRECISION, 0, MPI_COMM_WORLD, ierr) - if (ierr /= MPI_SUCCESS) then - stop 'Unable to read j1b_pen_coef with MPI' - endif - IRP_ENDIF - - if (exists) then - if (mpi_master) then - write(6,'(A)') '.. >>>>> [ IO READ: j1b_pen_coef ] <<<<< ..' - call ezfio_get_tc_keywords_j1b_pen_coef(j1b_pen_coef) - IRP_IF MPI - call MPI_BCAST(j1b_pen_coef, (nucl_num), MPI_DOUBLE_PRECISION, 0, MPI_COMM_WORLD, ierr) - if (ierr /= MPI_SUCCESS) then - stop 'Unable to read j1b_pen_coef with MPI' - endif - IRP_ENDIF - endif - else - do i = 1, nucl_num - j1b_pen_coef(i) = 1d0 - enddo - endif - - ! --- - - print *, ' parameters for nuclei jastrow' - print *, ' i, Z, j1b_pen, j1b_pen_coef' - do i = 1, nucl_num - write(*,'(I4, 2x, 3(E15.7, 2X))') i, nucl_charge(i), j1b_pen(i), j1b_pen_coef(i) - enddo - -END_PROVIDER - -! --- - -BEGIN_PROVIDER [ double precision, j1b_coeff, (nucl_num) ] - - BEGIN_DOC - ! coefficients of the 1-body Jastrow - END_DOC - - implicit none - logical :: exists - - PROVIDE ezfio_filename - - if (mpi_master) then - call ezfio_has_tc_keywords_j1b_coeff(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(j1b_coeff, (nucl_num), MPI_DOUBLE_PRECISION, 0, MPI_COMM_WORLD, ierr) - if (ierr /= MPI_SUCCESS) then - stop 'Unable to read j1b_coeff with MPI' - endif - IRP_ENDIF - - if (exists) then - - if (mpi_master) then - write(6,'(A)') '.. >>>>> [ IO READ: j1b_coeff ] <<<<< ..' - call ezfio_get_tc_keywords_j1b_coeff(j1b_coeff) - IRP_IF MPI - call MPI_BCAST(j1b_coeff, (nucl_num), MPI_DOUBLE_PRECISION, 0, MPI_COMM_WORLD, ierr) - if (ierr /= MPI_SUCCESS) then - stop 'Unable to read j1b_coeff with MPI' - endif - IRP_ENDIF - endif - - else - - integer :: i - do i = 1, nucl_num - j1b_coeff(i) = 0d5 - enddo - - endif - -END_PROVIDER - -! --- - diff --git a/src/tools/NEED b/src/tools/NEED index 0f4e17b0..ea465e92 100644 --- a/src/tools/NEED +++ b/src/tools/NEED @@ -1,5 +1,4 @@ fci -mo_two_e_erf_ints aux_quantities hartree_fock two_body_rdm diff --git a/src/tools/attachement_orb.irp.f b/src/tools/attachement_orb.irp.f new file mode 100644 index 00000000..92a51ca8 --- /dev/null +++ b/src/tools/attachement_orb.irp.f @@ -0,0 +1,168 @@ +program molden_detachment_attachment + implicit none + read_wf=.True. + touch read_wf + call molden_attachment +end + +subroutine molden_attachment + implicit none + BEGIN_DOC + ! Produces a Molden file + END_DOC + character*(128) :: output + integer :: i_unit_output,getUnitAndOpen + integer :: i,j,k,l + double precision, parameter :: a0 = 0.529177249d0 + + PROVIDE ezfio_filename + + output=trim(ezfio_filename)//'.attachement.mol' + print*,'output = ',trim(output) + + i_unit_output = getUnitAndOpen(output,'w') + + write(i_unit_output,'(A)') '[Molden Format]' + + write(i_unit_output,'(A)') '[Atoms] Angs' + do i = 1, nucl_num + write(i_unit_output,'(A2,2X,I4,2X,I4,3(2X,F15.10))') & + trim(element_name(int(nucl_charge(i)))), & + i, & + int(nucl_charge(i)), & + nucl_coord(i,1)*a0, nucl_coord(i,2)*a0, nucl_coord(i,3)*a0 + enddo + + write(i_unit_output,'(A)') '[GTO]' + + character*(1) :: character_shell + integer :: i_shell,i_prim,i_ao + integer :: iorder(ao_num) + integer :: nsort(ao_num) + + i_shell = 0 + i_prim = 0 + do i=1,nucl_num + write(i_unit_output,*) i, 0 + do j=1,nucl_num_shell_aos(i) + i_shell +=1 + i_ao = nucl_list_shell_aos(i,j) + character_shell = trim(ao_l_char(i_ao)) + write(i_unit_output,*) character_shell, ao_prim_num(i_ao), '1.00' + do k = 1, ao_prim_num(i_ao) + i_prim +=1 + write(i_unit_output,'(ES20.10,2X,ES20.10)') ao_expo(i_ao,k), ao_coef(i_ao,k) + enddo + l = i_ao + do while ( ao_l(l) == ao_l(i_ao) ) + nsort(l) = i*10000 + j*100 + l += 1 + if (l > ao_num) exit + enddo + enddo + write(i_unit_output,*)'' + enddo + + + do i=1,ao_num + iorder(i) = i + ! p + if ((ao_power(i,1) == 1 ).and.(ao_power(i,2) == 0 ).and.(ao_power(i,3) == 0 )) then + nsort(i) += 1 + else if ((ao_power(i,1) == 0 ).and.(ao_power(i,2) == 1 ).and.(ao_power(i,3) == 0 )) then + nsort(i) += 2 + else if ((ao_power(i,1) == 0 ).and.(ao_power(i,2) == 0 ).and.(ao_power(i,3) == 1 )) then + nsort(i) += 3 + ! d + else if ((ao_power(i,1) == 2 ).and.(ao_power(i,2) == 0 ).and.(ao_power(i,3) == 0 )) then + nsort(i) += 1 + else if ((ao_power(i,1) == 0 ).and.(ao_power(i,2) == 2 ).and.(ao_power(i,3) == 0 )) then + nsort(i) += 2 + else if ((ao_power(i,1) == 0 ).and.(ao_power(i,2) == 0 ).and.(ao_power(i,3) == 2 )) then + nsort(i) += 3 + else if ((ao_power(i,1) == 1 ).and.(ao_power(i,2) == 1 ).and.(ao_power(i,3) == 0 )) then + nsort(i) += 4 + else if ((ao_power(i,1) == 1 ).and.(ao_power(i,2) == 0 ).and.(ao_power(i,3) == 1 )) then + nsort(i) += 5 + else if ((ao_power(i,1) == 0 ).and.(ao_power(i,2) == 1 ).and.(ao_power(i,3) == 1 )) then + nsort(i) += 6 + ! f + else if ((ao_power(i,1) == 3 ).and.(ao_power(i,2) == 0 ).and.(ao_power(i,3) == 0 )) then + nsort(i) += 1 + else if ((ao_power(i,1) == 0 ).and.(ao_power(i,2) == 3 ).and.(ao_power(i,3) == 0 )) then + nsort(i) += 2 + else if ((ao_power(i,1) == 0 ).and.(ao_power(i,2) == 0 ).and.(ao_power(i,3) == 3 )) then + nsort(i) += 3 + else if ((ao_power(i,1) == 1 ).and.(ao_power(i,2) == 2 ).and.(ao_power(i,3) == 0 )) then + nsort(i) += 4 + else if ((ao_power(i,1) == 2 ).and.(ao_power(i,2) == 1 ).and.(ao_power(i,3) == 0 )) then + nsort(i) += 5 + else if ((ao_power(i,1) == 2 ).and.(ao_power(i,2) == 0 ).and.(ao_power(i,3) == 1 )) then + nsort(i) += 6 + else if ((ao_power(i,1) == 1 ).and.(ao_power(i,2) == 0 ).and.(ao_power(i,3) == 2 )) then + nsort(i) += 7 + else if ((ao_power(i,1) == 0 ).and.(ao_power(i,2) == 1 ).and.(ao_power(i,3) == 2 )) then + nsort(i) += 8 + else if ((ao_power(i,1) == 0 ).and.(ao_power(i,2) == 2 ).and.(ao_power(i,3) == 1 )) then + nsort(i) += 9 + else if ((ao_power(i,1) == 1 ).and.(ao_power(i,2) == 1 ).and.(ao_power(i,3) == 1 )) then + nsort(i) += 10 + ! g + else if ((ao_power(i,1) == 4 ).and.(ao_power(i,2) == 0 ).and.(ao_power(i,3) == 0 )) then + nsort(i) += 1 + else if ((ao_power(i,1) == 0 ).and.(ao_power(i,2) == 4 ).and.(ao_power(i,3) == 0 )) then + nsort(i) += 2 + else if ((ao_power(i,1) == 0 ).and.(ao_power(i,2) == 0 ).and.(ao_power(i,3) == 4 )) then + nsort(i) += 3 + else if ((ao_power(i,1) == 3 ).and.(ao_power(i,2) == 1 ).and.(ao_power(i,3) == 0 )) then + nsort(i) += 4 + else if ((ao_power(i,1) == 3 ).and.(ao_power(i,2) == 0 ).and.(ao_power(i,3) == 1 )) then + nsort(i) += 5 + else if ((ao_power(i,1) == 1 ).and.(ao_power(i,2) == 3 ).and.(ao_power(i,3) == 0 )) then + nsort(i) += 6 + else if ((ao_power(i,1) == 0 ).and.(ao_power(i,2) == 3 ).and.(ao_power(i,3) == 1 )) then + nsort(i) += 7 + else if ((ao_power(i,1) == 1 ).and.(ao_power(i,2) == 0 ).and.(ao_power(i,3) == 3 )) then + nsort(i) += 8 + else if ((ao_power(i,1) == 0 ).and.(ao_power(i,2) == 1 ).and.(ao_power(i,3) == 3 )) then + nsort(i) += 9 + else if ((ao_power(i,1) == 2 ).and.(ao_power(i,2) == 2 ).and.(ao_power(i,3) == 0 )) then + nsort(i) += 10 + else if ((ao_power(i,1) == 2 ).and.(ao_power(i,2) == 0 ).and.(ao_power(i,3) == 2 )) then + nsort(i) += 11 + else if ((ao_power(i,1) == 0 ).and.(ao_power(i,2) == 2 ).and.(ao_power(i,3) == 2 )) then + nsort(i) += 12 + else if ((ao_power(i,1) == 2 ).and.(ao_power(i,2) == 1 ).and.(ao_power(i,3) == 1 )) then + nsort(i) += 13 + else if ((ao_power(i,1) == 1 ).and.(ao_power(i,2) == 2 ).and.(ao_power(i,3) == 1 )) then + nsort(i) += 14 + else if ((ao_power(i,1) == 1 ).and.(ao_power(i,2) == 1 ).and.(ao_power(i,3) == 2 )) then + nsort(i) += 15 + endif + enddo + + call isort(nsort,iorder,ao_num) + write(i_unit_output,'(A)') '[MO]' + integer :: istate + istate = 2 + do i=1,n_dettachment(istate) + write (i_unit_output,*) 'Sym= 1' + write (i_unit_output,*) 'Ene=', dettachment_numbers_sorted(i,istate) + write (i_unit_output,*) 'Spin= Alpha' + write (i_unit_output,*) 'Occup=', dettachment_numbers_sorted(i,istate) + do j=1,ao_num + write(i_unit_output, '(I6,2X,ES20.10)') j, dettachment_orbitals(iorder(j),i,istate) + enddo + enddo + do i=1,n_attachment(istate) + write (i_unit_output,*) 'Sym= 1' + write (i_unit_output,*) 'Ene=', attachment_numbers_sorted(i,istate) + write (i_unit_output,*) 'Spin= Alpha' + write (i_unit_output,*) 'Occup=', attachment_numbers_sorted(i,istate) + do j=1,ao_num + write(i_unit_output, '(I6,2X,ES20.10)') j, attachment_orbitals(iorder(j),i,istate) + enddo + enddo + close(i_unit_output) +end + diff --git a/src/tools/cas_complete.irp.f b/src/tools/cas_complete.irp.f new file mode 100644 index 00000000..301c9979 --- /dev/null +++ b/src/tools/cas_complete.irp.f @@ -0,0 +1,13 @@ +program cas_complete + implicit none + BEGIN_DOC +! Diagonalizes the Hamiltonian in the complete active space + END_DOC + + call generate_cas_space + call diagonalize_ci + call save_wavefunction + +end + + diff --git a/src/tools/print_sorted_wf_coef.irp.f b/src/tools/print_sorted_wf_coef.irp.f index fa0f1eab..b3c0cb34 100644 --- a/src/tools/print_sorted_wf_coef.irp.f +++ b/src/tools/print_sorted_wf_coef.irp.f @@ -13,7 +13,7 @@ subroutine routine output=trim(ezfio_filename)//'.wf_sorted' i_unit_output = getUnitAndOpen(output,'w') do i= 1, N_det - write(i_unit_output,*)i,dabs(psi_coef_sorted(i,1)) + write(i_unit_output,*)i,dabs(psi_coef_sorted(i,1)),dabs(psi_coef_sorted(i,1)/psi_coef_sorted(1,1)) enddo end diff --git a/src/trexio/EZFIO.cfg b/src/trexio/EZFIO.cfg index 8c11478e..88828520 100644 --- a/src/trexio/EZFIO.cfg +++ b/src/trexio/EZFIO.cfg @@ -18,7 +18,7 @@ default: True [export_mos] type: logical -doc: If True, export basis set and AOs +doc: If True, export MO coefficients interface: ezfio, ocaml, provider default: True diff --git a/src/two_body_rdm/state_av_act_2rdm.irp.f b/src/two_body_rdm/state_av_act_2rdm.irp.f index ea636212..e1bd6439 100644 --- a/src/two_body_rdm/state_av_act_2rdm.irp.f +++ b/src/two_body_rdm/state_av_act_2rdm.irp.f @@ -123,7 +123,7 @@ state_av_act_2_rdm_spin_trace_mo = state_av_act_2_rdm_ab_mo & + state_av_act_2_rdm_aa_mo & + state_av_act_2_rdm_bb_mo - +! ! call orb_range_2_rdm_state_av_openmp(state_av_act_2_rdm_spin_trace_mo,n_act_orb,n_act_orb,list_act,state_weights,ispin,psi_coef,size(psi_coef,2),size(psi_coef,1)) call wall_time(wall_2) diff --git a/src/two_body_rdm/state_av_full_orb_2_rdm.irp.f b/src/two_body_rdm/state_av_full_orb_2_rdm.irp.f index 5fb9e475..851e6b24 100644 --- a/src/two_body_rdm/state_av_full_orb_2_rdm.irp.f +++ b/src/two_body_rdm/state_av_full_orb_2_rdm.irp.f @@ -8,7 +8,7 @@ ! ! = \sum_{istate} w(istate) * ! -! WHERE ALL ORBITALS (i,j,k,l) BELONGS TO ALL OCCUPIED ORBITALS : core, inactive and active +! WHERE ALL ORBITALS (i,j,k,l) BELONG TO ALL OCCUPIED ORBITALS : core, inactive and active ! ! THE NORMALIZATION (i.e. sum of diagonal elements) IS SET TO N_{\alpha} * N_{\beta} * 2 ! @@ -149,7 +149,7 @@ ! ! = \sum_{istate} w(istate) * ! -! WHERE ALL ORBITALS (i,j,k,l) BELONGS TO ALL OCCUPIED ORBITALS : core, inactive and active +! WHERE ALL ORBITALS (i,j,k,l) BELONG TO ALL OCCUPIED ORBITALS : core, inactive and active ! ! THE NORMALIZATION (i.e. sum of diagonal elements) IS SET TO N_{\alpha} * (N_{\alpha} - 1) ! @@ -262,7 +262,7 @@ ! ! = \sum_{istate} w(istate) * ! -! WHERE ALL ORBITALS (i,j,k,l) BELONGS TO ALL OCCUPIED ORBITALS : core, inactive and active +! WHERE ALL ORBITALS (i,j,k,l) BELONG TO ALL OCCUPIED ORBITALS : core, inactive and active ! ! THE NORMALIZATION (i.e. sum of diagonal elements) IS SET TO N_{\beta} * (N_{\beta} - 1) ! @@ -376,7 +376,7 @@ ! = \sum_{istate} w(istate) * \sum_{sigma,sigma'} ! ! -! WHERE ALL ORBITALS (i,j,k,l) BELONGS TO ALL OCCUPIED ORBITALS : core, inactive and active +! WHERE ALL ORBITALS (i,j,k,l) BELONG TO ALL OCCUPIED ORBITALS : core, inactive and active ! ! THE NORMALIZATION (i.e. sum of diagonal elements) IS SET TO N_{elec} * (N_{elec} - 1) ! @@ -619,3 +619,4 @@ !$OMP END PARALLEL END_PROVIDER + diff --git a/src/two_body_rdm/test_2_rdm.irp.f b/src/two_body_rdm/test_2_rdm.irp.f index 4eb8f9f0..123261d8 100644 --- a/src/two_body_rdm/test_2_rdm.irp.f +++ b/src/two_body_rdm/test_2_rdm.irp.f @@ -2,7 +2,7 @@ program test_2_rdm implicit none read_wf = .True. touch read_wf -! call routine_active_only + call routine_active_only call routine_full_mos end diff --git a/src/utils/constants.include.F b/src/utils/constants.include.F index d1727701..422eff95 100644 --- a/src/utils/constants.include.F +++ b/src/utils/constants.include.F @@ -1,6 +1,6 @@ integer, parameter :: max_dim = 511 integer, parameter :: SIMD_vector = 32 -integer, parameter :: N_int_max = 32 +integer, parameter :: N_int_max = 128 double precision, parameter :: pi = dacos(-1.d0) double precision, parameter :: inv_pi = 1.d0/dacos(-1.d0) diff --git a/src/utils/memory.irp.f b/src/utils/memory.irp.f index 41ec0428..ab85c21b 100644 --- a/src/utils/memory.irp.f +++ b/src/utils/memory.irp.f @@ -33,6 +33,8 @@ subroutine resident_memory(value) call usleep(10) value = 0.d0 +IRP_IF MACOS +IRP_ELSE iunit = getUnitAndOpen('/proc/self/status','r') do read(iunit,*,err=10,end=20) key, value @@ -43,6 +45,7 @@ subroutine resident_memory(value) end do 20 continue close(iunit) +IRP_ENDIF value = value / (1024.d0*1024.d0) call unlock_io() end function @@ -58,6 +61,9 @@ subroutine total_memory(value) double precision, intent(out) :: value call lock_io() + value = 0.d0 +IRP_IF MACOS +IRP_ELSE iunit = getUnitAndOpen('/proc/self/status','r') do read(iunit,*,err=10,end=20) key, value @@ -68,6 +74,7 @@ subroutine total_memory(value) end do 20 continue close(iunit) +IRP_ENDIF value = value / (1024.d0*1024.d0) call unlock_io() end function diff --git a/src/utils/util.irp.f b/src/utils/util.irp.f index ebb13781..97cbde67 100644 --- a/src/utils/util.irp.f +++ b/src/utils/util.irp.f @@ -579,5 +579,64 @@ logical function is_same_spin(sigma_1, sigma_2) end function is_same_spin ! --- + +function Kronecker_delta(i, j) result(delta) + + BEGIN_DOC + ! Kronecker Delta + END_DOC + + implicit none + integer, intent(in) :: i, j + double precision :: delta + + if(i == j) then + delta = 1.d0 + else + delta = 0.d0 + endif + +end function Kronecker_delta + +! --- + +subroutine diagonalize_sym_matrix(N, A, e) + + BEGIN_DOC + ! + ! Diagonalize a symmetric matrix + ! + END_DOC + + implicit none + + integer, intent(in) :: N + double precision, intent(inout) :: A(N,N) + double precision, intent(out) :: e(N) + + integer :: lwork, info + double precision, allocatable :: work(:) + + allocate(work(1)) + + lwork = -1 + call dsyev('V', 'U', N, A, N, e, work, lwork, info) + lwork = int(work(1)) + + deallocate(work) + + allocate(work(lwork)) + + call dsyev('V', 'U', N, A, N, e, work, lwork, info) + deallocate(work) + + if(info /= 0) then + print*,'Problem in diagonalize_sym_matrix (dsyev)!!' + endif + +end subroutine diagonalize_sym_matrix + +! --- + diff --git a/src/utils_cc/org/TANGLE_org_mode.sh b/src/utils_cc/org/TANGLE_org_mode.sh deleted file mode 100755 index 059cbe7d..00000000 --- a/src/utils_cc/org/TANGLE_org_mode.sh +++ /dev/null @@ -1,7 +0,0 @@ -#!/bin/sh - -list='ls *.org' -for element in $list -do - emacs --batch $element -f org-babel-tangle -done diff --git a/src/utils_trust_region/org/TANGLE_org_mode.sh b/src/utils_trust_region/org/TANGLE_org_mode.sh deleted file mode 100755 index 059cbe7d..00000000 --- a/src/utils_trust_region/org/TANGLE_org_mode.sh +++ /dev/null @@ -1,7 +0,0 @@ -#!/bin/sh - -list='ls *.org' -for element in $list -do - emacs --batch $element -f org-babel-tangle -done