mirror of
https://github.com/QuantumPackage/qp2.git
synced 2024-06-01 02:05:18 +02:00
Merge branch 'dev' of https://github.com/QuantumPackage/qp2 into dev
Some checks failed
continuous-integration/drone/push Build is failing
Some checks failed
continuous-integration/drone/push Build is failing
This commit is contained in:
commit
030dc9acf6
68
config/cray_gfortran.cfg
Normal file
68
config/cray_gfortran.cfg
Normal file
|
@ -0,0 +1,68 @@
|
|||
# On LUMI
|
||||
#
|
||||
# export SPACK_USER_PREFIX=$HOME/spack
|
||||
# module swap PrgEnv-cray/8.3.3 PrgEnv-gnu/8.3.3
|
||||
# module load spack/22.08
|
||||
# module load openblas/0.3.17-gcc-omp-xi
|
||||
# Common flags
|
||||
##############
|
||||
#
|
||||
# -ffree-line-length-none : Needed for IRPF90 which produces long lines
|
||||
# -lblas -llapack : Link with libblas and liblapack libraries provided by the system
|
||||
# -I . : Include the curent directory (Mandatory)
|
||||
#
|
||||
# --ninja : Allow the utilisation of ninja. (Mandatory)
|
||||
# --align=32 : Align all provided arrays on a 32-byte boundary
|
||||
#
|
||||
#
|
||||
[COMMON]
|
||||
FC : gfortran -ffree-line-length-none -I . -mavx -g -fPIC
|
||||
LAPACK_LIB : -L/appl/lumi/spack/22.08/0.18.1/opt/spack/openblas-0.3.17-xinceno/lib -lopenblas
|
||||
IRPF90 : irpf90
|
||||
IRPF90_FLAGS : --ninja --align=32 -DSET_NESTED
|
||||
|
||||
# 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
|
||||
|
|
@ -10,7 +10,7 @@
|
|||
#
|
||||
#
|
||||
[COMMON]
|
||||
FC : gfortran -g -ffree-line-length-none -I . -fPIC
|
||||
FC : gfortran -g -ffree-line-length-none -I . -fPIC -march=native
|
||||
LAPACK_LIB : -lblas -llapack
|
||||
IRPF90 : irpf90
|
||||
IRPF90_FLAGS : --ninja --align=32 --assert -DSET_NESTED
|
||||
|
@ -22,7 +22,7 @@ IRPF90_FLAGS : --ninja --align=32 --assert -DSET_NESTED
|
|||
# 0 : Deactivate
|
||||
#
|
||||
[OPTION]
|
||||
MODE : DEBUG ; [ OPT | PROFILE | DEBUG ] : Chooses the section below
|
||||
MODE : OPT ; [ OPT | PROFILE | DEBUG ] : Chooses the section below
|
||||
CACHE : 0 ; Enable cache_compile.py
|
||||
OPENMP : 1 ; Append OpenMP flags
|
||||
|
||||
|
|
65
config/gfortran_armpl.cfg
Normal file
65
config/gfortran_armpl.cfg
Normal file
|
@ -0,0 +1,65 @@
|
|||
# Common flags
|
||||
##############
|
||||
# module load arm
|
||||
# module load gnu
|
||||
# module load acfl
|
||||
#
|
||||
# -ffree-line-length-none : Needed for IRPF90 which produces long lines
|
||||
# -lblas -llapack : Link with libblas and liblapack libraries provided by the system
|
||||
# -I . : Include the curent directory (Mandatory)
|
||||
#
|
||||
# --ninja : Allow the utilisation of ninja. (Mandatory)
|
||||
# --align=32 : Align all provided arrays on a 32-byte boundary
|
||||
#
|
||||
#
|
||||
[COMMON]
|
||||
FC : gfortran -g -ffree-line-length-none -I . -fPIC -march=native
|
||||
LAPACK_LIB : -larmpl_lp64
|
||||
IRPF90 : irpf90
|
||||
IRPF90_FLAGS : --ninja --align=32 --assert -DSET_NESTED
|
||||
|
||||
# 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
|
||||
|
||||
# Profiling flags
|
||||
#################
|
||||
#
|
||||
[PROFILE]
|
||||
FC : -p -g
|
||||
FCFLAGS : -Ofast
|
||||
|
||||
# Debugging flags
|
||||
#################
|
||||
#
|
||||
# -fcheck=all : Checks uninitialized variables, array subscripts, etc...
|
||||
# -g : Extra debugging information
|
||||
#
|
||||
[DEBUG]
|
||||
FCFLAGS : -g -march=native -fcheck=all -Waliasing -Wampersand -Wconversion -Wsurprising -Wintrinsics-std -Wno-tabs -Wintrinsic-shadow -Wline-truncation -Wreal-q-constant -Wuninitialized -fbacktrace -ffpe-trap=zero,overflow,underflow -finit-real=nan
|
||||
|
||||
# OpenMP flags
|
||||
#################
|
||||
#
|
||||
[OPENMP]
|
||||
FC : -fopenmp
|
||||
IRPF90_FLAGS : --openmp
|
||||
|
62
config/gfortran_openblas.cfg
Normal file
62
config/gfortran_openblas.cfg
Normal file
|
@ -0,0 +1,62 @@
|
|||
# Common flags
|
||||
##############
|
||||
#
|
||||
# -ffree-line-length-none : Needed for IRPF90 which produces long lines
|
||||
# -lblas -llapack : Link with libblas and liblapack libraries provided by the system
|
||||
# -I . : Include the curent directory (Mandatory)
|
||||
#
|
||||
# --ninja : Allow the utilisation of ninja. (Mandatory)
|
||||
# --align=32 : Align all provided arrays on a 32-byte boundary
|
||||
#
|
||||
#
|
||||
[COMMON]
|
||||
FC : gfortran -g -ffree-line-length-none -I . -fPIC -march=native
|
||||
LAPACK_LIB : -lopenblas
|
||||
IRPF90 : irpf90
|
||||
IRPF90_FLAGS : --ninja --align=32 --assert -DSET_NESTED
|
||||
|
||||
# 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
|
||||
|
||||
# Profiling flags
|
||||
#################
|
||||
#
|
||||
[PROFILE]
|
||||
FC : -p -g
|
||||
FCFLAGS : -Ofast
|
||||
|
||||
# Debugging flags
|
||||
#################
|
||||
#
|
||||
# -fcheck=all : Checks uninitialized variables, array subscripts, etc...
|
||||
# -g : Extra debugging information
|
||||
#
|
||||
[DEBUG]
|
||||
FCFLAGS : -g -march=native -fcheck=all -Waliasing -Wampersand -Wconversion -Wsurprising -Wintrinsics-std -Wno-tabs -Wintrinsic-shadow -Wline-truncation -Wreal-q-constant -Wuninitialized -fbacktrace -ffpe-trap=zero,overflow,underflow -finit-real=nan
|
||||
|
||||
# OpenMP flags
|
||||
#################
|
||||
#
|
||||
[OPENMP]
|
||||
FC : -fopenmp
|
||||
IRPF90_FLAGS : --openmp
|
||||
|
66
config/ifort_2019_debug.cfg
Normal file
66
config/ifort_2019_debug.cfg
Normal file
|
@ -0,0 +1,66 @@
|
|||
# Common flags
|
||||
##############
|
||||
#
|
||||
# -mkl=[parallel|sequential] : Use the MKL library
|
||||
# --ninja : Allow the utilisation of ninja. It is mandatory !
|
||||
# --align=32 : Align all provided arrays on a 32-byte boundary
|
||||
#
|
||||
[COMMON]
|
||||
FC : ifort -fpic
|
||||
LAPACK_LIB : -mkl=parallel -lirc -lsvml -limf -lipps
|
||||
IRPF90 : irpf90
|
||||
IRPF90_FLAGS : --ninja --align=32 --assert -DINTEL -DSET_NESTED
|
||||
|
||||
# Global options
|
||||
################
|
||||
#
|
||||
# 1 : Activate
|
||||
# 0 : Deactivate
|
||||
#
|
||||
[OPTION]
|
||||
MODE : DEBUG ; [ OPT | PROFILE | DEBUG ] : Chooses the section below
|
||||
CACHE : 0 ; Enable cache_compile.py
|
||||
OPENMP : 1 ; Append OpenMP flags
|
||||
|
||||
# Optimization flags
|
||||
####################
|
||||
#
|
||||
# -xHost : Compile a binary optimized for the current architecture
|
||||
# -O2 : O3 not better than O2.
|
||||
# -ip : Inter-procedural optimizations
|
||||
# -ftz : Flushes denormal results to zero
|
||||
#
|
||||
[OPT]
|
||||
FC : -traceback
|
||||
FCFLAGS : -msse4.2 -O2 -ip -ftz -g
|
||||
|
||||
|
||||
# Profiling flags
|
||||
#################
|
||||
#
|
||||
[PROFILE]
|
||||
FC : -p -g
|
||||
FCFLAGS : -msse4.2 -O2 -ip -ftz
|
||||
|
||||
|
||||
# Debugging flags
|
||||
#################
|
||||
#
|
||||
# -traceback : Activate backtrace on runtime
|
||||
# -fpe0 : All floating point exaceptions
|
||||
# -C : Checks uninitialized variables, array subscripts, etc...
|
||||
# -g : Extra debugging information
|
||||
# -msse4.2 : Valgrind needs a very simple x86 executable
|
||||
#
|
||||
[DEBUG]
|
||||
FC : -g -traceback
|
||||
FCFLAGS : -msse4.2 -check all -debug all -fpe-all=0 -implicitnone
|
||||
|
||||
|
||||
# OpenMP flags
|
||||
#################
|
||||
#
|
||||
[OPENMP]
|
||||
FC : -qopenmp
|
||||
IRPF90_FLAGS : --openmp
|
||||
|
30
configure
vendored
30
configure
vendored
|
@ -16,6 +16,25 @@ export CC=gcc
|
|||
git submodule init
|
||||
git submodule update
|
||||
|
||||
# Update ARM or x86 dependencies
|
||||
ARCHITECTURE=$(uname -m)
|
||||
cd ${QP_ROOT}/external/qp2-dependencies
|
||||
echo "Architecture: $ARCHITECTURE"
|
||||
case $ARCHITECTURE in
|
||||
aarch64)
|
||||
git checkout arm64
|
||||
;;
|
||||
x86_64)
|
||||
git checkout x86
|
||||
;;
|
||||
*)
|
||||
echo "Unknown architecture. Using x86_64."
|
||||
git checkout x86
|
||||
;;
|
||||
esac
|
||||
cd ${QP_ROOT}
|
||||
|
||||
|
||||
function help()
|
||||
{
|
||||
cat <<EOF
|
||||
|
@ -99,7 +118,7 @@ PACKAGES=$(echo $PACKAGES | xargs)
|
|||
|
||||
echo "export QP_ROOT=\"$QP_ROOT\"" > ${QP_ROOT}/etc/00.qp_root.rc
|
||||
|
||||
source quantum_package.rc
|
||||
source ${QP_ROOT}/quantum_package.rc
|
||||
|
||||
|
||||
|
||||
|
@ -235,10 +254,9 @@ EOF
|
|||
execute <<EOF
|
||||
source "${QP_ROOT}"/quantum_package.rc
|
||||
cd "${QP_ROOT}"/external/
|
||||
tar --gunzip --extract --file qp2-dependencies/ocaml-bundle_x86.tar.gz
|
||||
echo "" | ./ocaml-bundle/bootstrap.sh "${QP_ROOT}"
|
||||
./ocaml-bundle/configure.sh "${QP_ROOT}"
|
||||
echo "" | ./ocaml-bundle/compile.sh "${QP_ROOT}"
|
||||
tar --gunzip --extract --file qp2-dependencies/opampack.tar.gz
|
||||
cd "${QP_ROOT}"/external/opampack
|
||||
./install.sh
|
||||
EOF
|
||||
|
||||
elif [[ ${PACKAGE} = bse ]] ; then
|
||||
|
@ -293,7 +311,7 @@ EOF
|
|||
|
||||
done
|
||||
|
||||
source quantum_package.rc
|
||||
source ${QP_ROOT}/quantum_package.rc
|
||||
|
||||
NINJA=$(find_exe ninja)
|
||||
if [[ ${NINJA} = $(not_found) ]] ; then
|
||||
|
|
|
@ -991,4 +991,266 @@ D 1
|
|||
1 1.3743000 1.0000000
|
||||
D 1
|
||||
1 0.0537000 1.00000000
|
||||
$END
|
||||
|
||||
COPPER
|
||||
S 20
|
||||
1 5.430321E+06 7.801026E-06
|
||||
2 8.131665E+05 6.065666E-05
|
||||
3 1.850544E+05 3.188964E-04
|
||||
4 5.241466E+04 1.344687E-03
|
||||
5 1.709868E+04 4.869050E-03
|
||||
6 6.171994E+03 1.561013E-02
|
||||
7 2.406481E+03 4.452077E-02
|
||||
8 9.972584E+02 1.103111E-01
|
||||
9 4.339289E+02 2.220342E-01
|
||||
10 1.962869E+02 3.133739E-01
|
||||
11 9.104280E+01 2.315121E-01
|
||||
12 4.138425E+01 7.640920E-02
|
||||
13 1.993278E+01 1.103818E-01
|
||||
14 9.581891E+00 1.094372E-01
|
||||
15 4.234516E+00 1.836311E-02
|
||||
16 1.985814E+00 -6.043084E-04
|
||||
17 8.670830E-01 5.092245E-05
|
||||
18 1.813390E-01 -5.540730E-05
|
||||
19 8.365700E-02 3.969482E-05
|
||||
20 3.626700E-02 -1.269538E-05
|
||||
S 20
|
||||
1 5.430321E+06 -4.404706E-06
|
||||
2 8.131665E+05 -3.424801E-05
|
||||
3 1.850544E+05 -1.801238E-04
|
||||
4 5.241466E+04 -7.600455E-04
|
||||
5 1.709868E+04 -2.759348E-03
|
||||
6 6.171994E+03 -8.900970E-03
|
||||
7 2.406481E+03 -2.579378E-02
|
||||
8 9.972584E+02 -6.623861E-02
|
||||
9 4.339289E+02 -1.445927E-01
|
||||
10 1.962869E+02 -2.440110E-01
|
||||
11 9.104280E+01 -2.504837E-01
|
||||
12 4.138425E+01 2.852577E-02
|
||||
13 1.993278E+01 5.115874E-01
|
||||
14 9.581891E+00 4.928061E-01
|
||||
15 4.234516E+00 8.788437E-02
|
||||
16 1.985814E+00 -5.820281E-03
|
||||
17 8.670830E-01 2.013508E-04
|
||||
18 1.813390E-01 -5.182553E-04
|
||||
19 8.365700E-02 3.731503E-04
|
||||
20 3.626700E-02 -1.193171E-04
|
||||
S 20
|
||||
1 5.430321E+06 9.704682E-07
|
||||
2 8.131665E+05 7.549245E-06
|
||||
3 1.850544E+05 3.968892E-05
|
||||
4 5.241466E+04 1.677200E-04
|
||||
5 1.709868E+04 6.095101E-04
|
||||
6 6.171994E+03 1.978846E-03
|
||||
7 2.406481E+03 5.798049E-03
|
||||
8 9.972584E+02 1.534158E-02
|
||||
9 4.339289E+02 3.540484E-02
|
||||
10 1.962869E+02 6.702098E-02
|
||||
11 9.104280E+01 8.026945E-02
|
||||
12 4.138425E+01 -1.927231E-02
|
||||
13 1.993278E+01 -3.160129E-01
|
||||
14 9.581891E+00 -4.573162E-01
|
||||
15 4.234516E+00 1.550841E-01
|
||||
16 1.985814E+00 7.202872E-01
|
||||
17 8.670830E-01 3.885122E-01
|
||||
18 1.813390E-01 1.924326E-02
|
||||
19 8.365700E-02 -7.103807E-03
|
||||
20 3.626700E-02 3.272906E-03
|
||||
S 20
|
||||
1 5.430321E+06 -1.959354E-07
|
||||
2 8.131665E+05 -1.523472E-06
|
||||
3 1.850544E+05 -8.014808E-06
|
||||
4 5.241466E+04 -3.383992E-05
|
||||
5 1.709868E+04 -1.231191E-04
|
||||
6 6.171994E+03 -3.992085E-04
|
||||
7 2.406481E+03 -1.171900E-03
|
||||
8 9.972584E+02 -3.096141E-03
|
||||
9 4.339289E+02 -7.171993E-03
|
||||
10 1.962869E+02 -1.356621E-02
|
||||
11 9.104280E+01 -1.643989E-02
|
||||
12 4.138425E+01 4.107628E-03
|
||||
13 1.993278E+01 6.693964E-02
|
||||
14 9.581891E+00 1.028221E-01
|
||||
15 4.234516E+00 -4.422945E-02
|
||||
16 1.985814E+00 -2.031191E-01
|
||||
17 8.670830E-01 -2.230022E-01
|
||||
18 1.813390E-01 2.517975E-01
|
||||
19 8.365700E-02 5.650091E-01
|
||||
20 3.626700E-02 3.247243E-01
|
||||
S 20
|
||||
1 5.430321E+06 -7.508267E-07
|
||||
2 8.131665E+05 -5.972018E-06
|
||||
3 1.850544E+05 -3.039682E-05
|
||||
4 5.241466E+04 -1.340405E-04
|
||||
5 1.709868E+04 -4.615778E-04
|
||||
6 6.171994E+03 -1.601064E-03
|
||||
7 2.406481E+03 -4.330942E-03
|
||||
8 9.972584E+02 -1.265434E-02
|
||||
9 4.339289E+02 -2.586864E-02
|
||||
10 1.962869E+02 -5.835428E-02
|
||||
11 9.104280E+01 -5.132322E-02
|
||||
12 4.138425E+01 -1.908953E-02
|
||||
13 1.993278E+01 3.586116E-01
|
||||
14 9.581891E+00 3.885818E-01
|
||||
15 4.234516E+00 -3.057106E-01
|
||||
16 1.985814E+00 -2.069896E+00
|
||||
17 8.670830E-01 2.431774E+00
|
||||
18 1.813390E-01 -2.121974E-02
|
||||
19 8.365700E-02 -1.820251E+00
|
||||
20 3.626700E-02 1.434585E+00
|
||||
S 20
|
||||
1 5.430321E+06 -3.532229E-07
|
||||
2 8.131665E+05 -2.798812E-06
|
||||
3 1.850544E+05 -1.432517E-05
|
||||
4 5.241466E+04 -6.270946E-05
|
||||
5 1.709868E+04 -2.179490E-04
|
||||
6 6.171994E+03 -7.474316E-04
|
||||
7 2.406481E+03 -2.049271E-03
|
||||
8 9.972584E+02 -5.885203E-03
|
||||
9 4.339289E+02 -1.226885E-02
|
||||
10 1.962869E+02 -2.683147E-02
|
||||
11 9.104280E+01 -2.479261E-02
|
||||
12 4.138425E+01 -5.984746E-03
|
||||
13 1.993278E+01 1.557124E-01
|
||||
14 9.581891E+00 1.436683E-01
|
||||
15 4.234516E+00 8.374103E-03
|
||||
16 1.985814E+00 -7.460711E-01
|
||||
17 8.670830E-01 1.244367E-01
|
||||
18 1.813390E-01 1.510110E+00
|
||||
19 8.365700E-02 -3.477122E-01
|
||||
20 3.626700E-02 -9.774169E-01
|
||||
S 1
|
||||
1 3.626700E-02 1.000000E+00
|
||||
S 1
|
||||
1 0.0157200 1.0000000
|
||||
P 16
|
||||
1 2.276057E+04 4.000000E-05
|
||||
2 5.387679E+03 3.610000E-04
|
||||
3 1.749945E+03 2.083000E-03
|
||||
4 6.696653E+02 9.197000E-03
|
||||
5 2.841948E+02 3.266000E-02
|
||||
6 1.296077E+02 9.379500E-02
|
||||
7 6.225415E+01 2.082740E-01
|
||||
8 3.092964E+01 3.339930E-01
|
||||
9 1.575827E+01 3.324930E-01
|
||||
10 8.094211E+00 1.547280E-01
|
||||
11 4.046921E+00 2.127100E-02
|
||||
12 1.967869E+00 -1.690000E-03
|
||||
13 9.252950E-01 -1.516000E-03
|
||||
14 3.529920E-01 -2.420000E-04
|
||||
15 1.273070E-01 2.300000E-05
|
||||
16 4.435600E-02 -9.000000E-06
|
||||
P 16
|
||||
1 2.276057E+04 -1.500000E-05
|
||||
2 5.387679E+03 -1.310000E-04
|
||||
3 1.749945E+03 -7.550000E-04
|
||||
4 6.696653E+02 -3.359000E-03
|
||||
5 2.841948E+02 -1.208100E-02
|
||||
6 1.296077E+02 -3.570300E-02
|
||||
7 6.225415E+01 -8.250200E-02
|
||||
8 3.092964E+01 -1.398900E-01
|
||||
9 1.575827E+01 -1.407290E-01
|
||||
10 8.094211E+00 3.876600E-02
|
||||
11 4.046921E+00 3.426950E-01
|
||||
12 1.967869E+00 4.523100E-01
|
||||
13 9.252950E-01 2.770540E-01
|
||||
14 3.529920E-01 4.388500E-02
|
||||
15 1.273070E-01 -2.802000E-03
|
||||
16 4.435600E-02 1.152000E-03
|
||||
P 16
|
||||
1 2.276057E+04 5.000000E-06
|
||||
2 5.387679E+03 4.900000E-05
|
||||
3 1.749945E+03 2.780000E-04
|
||||
4 6.696653E+02 1.253000E-03
|
||||
5 2.841948E+02 4.447000E-03
|
||||
6 1.296077E+02 1.337000E-02
|
||||
7 6.225415E+01 3.046900E-02
|
||||
8 3.092964E+01 5.344700E-02
|
||||
9 1.575827E+01 5.263900E-02
|
||||
10 8.094211E+00 -1.688100E-02
|
||||
11 4.046921E+00 -1.794480E-01
|
||||
12 1.967869E+00 -2.095880E-01
|
||||
13 9.252950E-01 -3.963300E-02
|
||||
14 3.529920E-01 5.021300E-01
|
||||
15 1.273070E-01 5.811110E-01
|
||||
16 4.435600E-02 4.566600E-02
|
||||
P 16
|
||||
1 2.276057E+04 1.100000E-05
|
||||
2 5.387679E+03 9.600000E-05
|
||||
3 1.749945E+03 5.900000E-04
|
||||
4 6.696653E+02 2.484000E-03
|
||||
5 2.841948E+02 9.463000E-03
|
||||
6 1.296077E+02 2.645300E-02
|
||||
7 6.225415E+01 6.568900E-02
|
||||
8 3.092964E+01 1.027320E-01
|
||||
9 1.575827E+01 1.370410E-01
|
||||
10 8.094211E+00 -7.096100E-02
|
||||
11 4.046921E+00 -5.047080E-01
|
||||
12 1.967869E+00 -4.780560E-01
|
||||
13 9.252950E-01 9.428920E-01
|
||||
14 3.529920E-01 5.446990E-01
|
||||
15 1.273070E-01 -8.327660E-01
|
||||
16 4.435600E-02 -1.084160E-01
|
||||
P 16
|
||||
1 2.276057E+04 3.000000E-06
|
||||
2 5.387679E+03 2.500000E-05
|
||||
3 1.749945E+03 1.470000E-04
|
||||
4 6.696653E+02 6.560000E-04
|
||||
5 2.841948E+02 2.351000E-03
|
||||
6 1.296077E+02 7.004000E-03
|
||||
7 6.225415E+01 1.613100E-02
|
||||
8 3.092964E+01 2.777000E-02
|
||||
9 1.575827E+01 2.756700E-02
|
||||
10 8.094211E+00 -1.011500E-02
|
||||
11 4.046921E+00 -8.100900E-02
|
||||
12 1.967869E+00 -1.104090E-01
|
||||
13 9.252950E-01 -7.173200E-02
|
||||
14 3.529920E-01 1.879300E-01
|
||||
15 1.273070E-01 5.646290E-01
|
||||
16 4.435600E-02 4.070000E-01
|
||||
P 1
|
||||
1 4.435600E-02 1.000000E+00
|
||||
P 1
|
||||
1 0.0154500 1.0000000
|
||||
D 8
|
||||
1 1.738970E+02 2.700000E-03
|
||||
2 5.188690E+01 2.090900E-02
|
||||
3 1.934190E+01 8.440800E-02
|
||||
4 7.975720E+00 2.139990E-01
|
||||
5 3.398230E+00 3.359800E-01
|
||||
6 1.409320E+00 3.573010E-01
|
||||
7 5.488580E-01 2.645780E-01
|
||||
8 1.901990E-01 1.039720E-01
|
||||
D 8
|
||||
1 1.738970E+02 -3.363000E-03
|
||||
2 5.188690E+01 -2.607900E-02
|
||||
3 1.934190E+01 -1.082310E-01
|
||||
4 7.975720E+00 -2.822170E-01
|
||||
5 3.398230E+00 -3.471900E-01
|
||||
6 1.409320E+00 2.671100E-02
|
||||
7 5.488580E-01 4.920470E-01
|
||||
8 1.901990E-01 4.384220E-01
|
||||
D 8
|
||||
1 1.738970E+02 4.133000E-03
|
||||
2 5.188690E+01 3.308500E-02
|
||||
3 1.934190E+01 1.383360E-01
|
||||
4 7.975720E+00 3.901660E-01
|
||||
5 3.398230E+00 1.698420E-01
|
||||
6 1.409320E+00 -6.830180E-01
|
||||
7 5.488580E-01 -2.657970E-01
|
||||
8 1.901990E-01 8.380630E-01
|
||||
D 1
|
||||
1 1.901990E-01 1.000000E+00
|
||||
D 1
|
||||
1 0.0659100 1.0000000
|
||||
F 1
|
||||
1 5.082100E+00 1.000000E+00
|
||||
F 1
|
||||
1 1.279700E+00 1.000000E+00
|
||||
F 1
|
||||
1 0.4617200 1.0000000
|
||||
G 1
|
||||
1 3.483500E+00 1.0000000
|
||||
G 1
|
||||
1 1.4597900 1.0000000
|
||||
$END
|
||||
|
|
|
@ -25,7 +25,7 @@ Usage
|
|||
|
||||
.. note::
|
||||
|
||||
All the parameters of the wave functgion need to be presente in the
|
||||
All the parameters of the wave function need to be present in the
|
||||
output file : complete description of the |AO| basis set, full set of
|
||||
molecular orbitals, etc.
|
||||
|
||||
|
|
|
@ -2,11 +2,9 @@
|
|||
|
||||
if [[ -z $OPAMROOT ]]
|
||||
then
|
||||
|
||||
# Comment these lines if you have a system-wide OCaml installation
|
||||
export PATH="${QP_ROOT}/external/ocaml-bundle/bootstrap/bin:$PATH"
|
||||
if [[ -f "${QP_ROOT}/external/ocaml-bundle/bootstrap/bin/opam" ]] ; then
|
||||
eval $(opam env --root "${QP_ROOT}/external/ocaml-bundle/opam" --set-root)
|
||||
export PATH="${QP_ROOT}/external/opampack/:$PATH"
|
||||
if [[ -f "${QP_ROOT}/external/opampack/opam" ]] ; then
|
||||
eval $("${QP_ROOT}/external/opampack/opam" env --root "${QP_ROOT}/external/opampack/opamroot" --set-root)
|
||||
fi
|
||||
fi
|
||||
source ${OPAMROOT}/opam-init/init.sh > /dev/null 2> /dev/null || true
|
||||
|
|
|
@ -57,13 +57,13 @@ default: false
|
|||
|
||||
[ao_normalized]
|
||||
type: logical
|
||||
doc: Use normalized basis functions
|
||||
doc: Normalize the atomic orbitals
|
||||
interface: ezfio, provider
|
||||
default: true
|
||||
default: false
|
||||
|
||||
[primitives_normalized]
|
||||
type: logical
|
||||
doc: Use normalized primitive functions
|
||||
doc: Normalize the primitive basis functions
|
||||
interface: ezfio, provider
|
||||
default: true
|
||||
|
||||
|
|
|
@ -63,15 +63,14 @@ END_PROVIDER
|
|||
! Coefficients including the |AO| normalization
|
||||
END_DOC
|
||||
|
||||
do i=1,ao_num
|
||||
l = ao_shell(i)
|
||||
ao_coef_normalized(i,:) = shell_coef(l,:) * shell_normalization_factor(l)
|
||||
end do
|
||||
|
||||
double precision :: norm,overlap_x,overlap_y,overlap_z,C_A(3), c
|
||||
integer :: l, powA(3), nz
|
||||
integer :: l, powA(3)
|
||||
integer, parameter :: nz=100
|
||||
integer :: i,j,k
|
||||
nz=100
|
||||
|
||||
ao_coef_normalized(:,:) = ao_coef(:,:)
|
||||
|
||||
C_A = 0.d0
|
||||
|
||||
do i=1,ao_num
|
||||
|
@ -80,7 +79,7 @@ END_PROVIDER
|
|||
powA(2) = ao_power(i,2)
|
||||
powA(3) = ao_power(i,3)
|
||||
|
||||
! Normalization of the primitives
|
||||
! GAMESS-type normalization of the primitives
|
||||
if (primitives_normalized) then
|
||||
do j=1,ao_prim_num(i)
|
||||
call overlap_gaussian_xyz(C_A,C_A,ao_expo(i,j),ao_expo(i,j), &
|
||||
|
@ -91,6 +90,7 @@ END_PROVIDER
|
|||
! Normalization of the contracted basis functions
|
||||
if (ao_normalized) then
|
||||
norm = 0.d0
|
||||
l = ao_shell(i)
|
||||
do j=1,ao_prim_num(i)
|
||||
do k=1,ao_prim_num(i)
|
||||
call overlap_gaussian_xyz(C_A,C_A,ao_expo(i,j),ao_expo(i,k),powA,powA,overlap_x,overlap_y,overlap_z,c,nz)
|
||||
|
@ -98,6 +98,7 @@ END_PROVIDER
|
|||
enddo
|
||||
enddo
|
||||
ao_coef_normalization_factor(i) = 1.d0/dsqrt(norm)
|
||||
ao_coef_normalized(i,:) *= ao_coef_normalization_factor(i)
|
||||
else
|
||||
ao_coef_normalization_factor(i) = 1.d0
|
||||
endif
|
||||
|
|
|
@ -156,6 +156,53 @@ end function overlap_gauss_r12_ao
|
|||
|
||||
! --
|
||||
|
||||
double precision function overlap_abs_gauss_r12_ao(D_center, delta, i, j)
|
||||
|
||||
BEGIN_DOC
|
||||
! \int dr AO_i(r) AO_j(r) e^{-delta |r-D_center|^2}
|
||||
END_DOC
|
||||
|
||||
implicit none
|
||||
integer, intent(in) :: i, j
|
||||
double precision, intent(in) :: D_center(3), delta
|
||||
|
||||
integer :: power_A(3), power_B(3), l, k
|
||||
double precision :: A_center(3), B_center(3), alpha, beta, coef, coef1, analytical_j
|
||||
|
||||
double precision, external :: overlap_abs_gauss_r12
|
||||
|
||||
overlap_abs_gauss_r12_ao = 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
|
||||
|
||||
analytical_j = overlap_abs_gauss_r12(D_center, delta, A_center, B_center, power_A, power_B, alpha, beta)
|
||||
|
||||
overlap_abs_gauss_r12_ao += dabs(coef * analytical_j)
|
||||
enddo
|
||||
enddo
|
||||
|
||||
end function overlap_gauss_r12_ao
|
||||
|
||||
! --
|
||||
|
||||
subroutine overlap_gauss_r12_ao_v(D_center, LD_D, delta, i, j, resv, LD_resv, n_points)
|
||||
|
||||
BEGIN_DOC
|
||||
|
@ -177,7 +224,7 @@ subroutine overlap_gauss_r12_ao_v(D_center, LD_D, delta, i, j, resv, LD_resv, n_
|
|||
double precision, allocatable :: analytical_j(:)
|
||||
|
||||
resv(:) = 0.d0
|
||||
if(ao_overlap_abs(j,i).lt.1.d-12) then
|
||||
if(ao_overlap_abs(j,i) .lt. 1.d-12) then
|
||||
return
|
||||
endif
|
||||
|
||||
|
@ -313,9 +360,7 @@ subroutine overlap_gauss_r12_ao_with1s_v(B_center, beta, D_center, LD_D, delta,
|
|||
ASSERT(beta .gt. 0.d0)
|
||||
|
||||
if(beta .lt. 1d-10) then
|
||||
|
||||
call overlap_gauss_r12_ao_v(D_center, LD_D, delta, i, j, resv, LD_resv, n_points)
|
||||
|
||||
return
|
||||
endif
|
||||
|
||||
|
@ -332,19 +377,20 @@ subroutine overlap_gauss_r12_ao_with1s_v(B_center, beta, D_center, LD_D, delta,
|
|||
A1_center(1:3) = nucl_coord(ao_nucl(i),1:3)
|
||||
A2_center(1:3) = nucl_coord(ao_nucl(j),1:3)
|
||||
|
||||
allocate (fact_g(n_points), G_center(n_points,3), analytical_j(n_points) )
|
||||
allocate(fact_g(n_points), G_center(n_points,3), analytical_j(n_points))
|
||||
|
||||
bg = beta * gama_inv
|
||||
dg = delta * gama_inv
|
||||
bdg = bg * delta
|
||||
do ipoint=1,n_points
|
||||
|
||||
do ipoint = 1, n_points
|
||||
|
||||
G_center(ipoint,1) = bg * B_center(1) + dg * D_center(ipoint,1)
|
||||
G_center(ipoint,2) = bg * B_center(2) + dg * D_center(ipoint,2)
|
||||
G_center(ipoint,3) = bg * B_center(3) + dg * D_center(ipoint,3)
|
||||
fact_g(ipoint) = bdg * ( &
|
||||
(B_center(1) - D_center(ipoint,1)) * (B_center(1) - D_center(ipoint,1)) &
|
||||
+ (B_center(2) - D_center(ipoint,2)) * (B_center(2) - D_center(ipoint,2)) &
|
||||
+ (B_center(3) - D_center(ipoint,3)) * (B_center(3) - D_center(ipoint,3)) )
|
||||
fact_g(ipoint) = bdg * ( (B_center(1) - D_center(ipoint,1)) * (B_center(1) - D_center(ipoint,1)) &
|
||||
+ (B_center(2) - D_center(ipoint,2)) * (B_center(2) - D_center(ipoint,2)) &
|
||||
+ (B_center(3) - D_center(ipoint,3)) * (B_center(3) - D_center(ipoint,3)) )
|
||||
|
||||
if(fact_g(ipoint) < 10d0) then
|
||||
fact_g(ipoint) = dexp(-fact_g(ipoint))
|
||||
|
@ -368,8 +414,7 @@ subroutine overlap_gauss_r12_ao_with1s_v(B_center, beta, D_center, LD_D, delta,
|
|||
do ipoint = 1, n_points
|
||||
coef12f = coef12 * fact_g(ipoint)
|
||||
resv(ipoint) += coef12f * analytical_j(ipoint)
|
||||
end do
|
||||
|
||||
enddo
|
||||
enddo
|
||||
enddo
|
||||
|
||||
|
|
517
src/ao_many_one_e_ints/grad2_jmu_manu.irp.f
Normal file
517
src/ao_many_one_e_ints/grad2_jmu_manu.irp.f
Normal file
|
@ -0,0 +1,517 @@
|
|||
|
||||
! ---
|
||||
|
||||
BEGIN_PROVIDER [ double precision, int2_grad1u2_grad2u2_j1b2_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
|
||||
!
|
||||
END_DOC
|
||||
|
||||
implicit none
|
||||
integer :: i, j, ipoint, i_1s, i_fit
|
||||
double precision :: r(3), expo_fit, coef_fit
|
||||
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 :: 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_with1s
|
||||
|
||||
print*, ' providing int2_grad1u2_grad2u2_j1b2_test ...'
|
||||
|
||||
sq_pi_3_2 = (dacos(-1.d0))**(1.5d0)
|
||||
|
||||
provide mu_erf final_grid_points_transp j1b_pen List_comb_thr_b3_coef
|
||||
call wall_time(wall0)
|
||||
|
||||
int2_grad1u2_grad2u2_j1b2_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)
|
||||
!$OMP DO SCHEDULE(dynamic)
|
||||
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
|
||||
if(ao_overlap_abs(j,i) .lt. 1.d-12) then
|
||||
cycle
|
||||
endif
|
||||
|
||||
do i_1s = 1, List_comb_thr_b3_size(j,i)
|
||||
|
||||
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)
|
||||
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)
|
||||
|
||||
do i_fit = 1, ng_fit_jast
|
||||
|
||||
expo_fit = expo_gauss_1_erf_x_2(i_fit)
|
||||
!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).lt.1.d-10)cycle ! old version
|
||||
if(dabs(coef_fit*factor_ij_1s*int_j1b*sq_pi_3_2*(beta_ij)**(-1.5d0)).lt.1.d-10)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
|
||||
|
||||
enddo
|
||||
enddo
|
||||
enddo
|
||||
enddo
|
||||
enddo
|
||||
|
||||
!$OMP END DO
|
||||
!$OMP END PARALLEL
|
||||
|
||||
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)
|
||||
enddo
|
||||
enddo
|
||||
enddo
|
||||
|
||||
call wall_time(wall1)
|
||||
print*, ' wall time for int2_grad1u2_grad2u2_j1b2_test', wall1 - wall0
|
||||
|
||||
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
|
||||
!
|
||||
implicit none
|
||||
integer :: i, j, ipoint, i_1s, i_fit
|
||||
double precision :: r(3), expo_fit, coef_fit
|
||||
double precision :: coef, beta, B_center(3)
|
||||
double precision :: tmp
|
||||
double precision :: wall0, wall1
|
||||
|
||||
double precision, allocatable :: int_fit_v(:),big_array(:,:,:)
|
||||
double precision, external :: overlap_gauss_r12_ao_with1s
|
||||
|
||||
print*, ' providing int2_grad1u2_grad2u2_j1b2_test_v ...'
|
||||
|
||||
provide mu_erf final_grid_points_transp j1b_pen
|
||||
call wall_time(wall0)
|
||||
|
||||
double precision :: int_j1b
|
||||
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)
|
||||
!
|
||||
allocate(int_fit_v(n_points_final_grid))
|
||||
!$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_1s = 1, List_comb_thr_b3_size(j,i)
|
||||
|
||||
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.1.d-15)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)
|
||||
|
||||
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) * coef
|
||||
|
||||
call overlap_gauss_r12_ao_with1s_v(B_center, beta, final_grid_points_transp, size(final_grid_points_transp,1),&
|
||||
expo_fit, i, j, int_fit_v, size(int_fit_v,1),n_points_final_grid)
|
||||
|
||||
do ipoint = 1, n_points_final_grid
|
||||
big_array(ipoint,j,i) += coef_fit * int_fit_v(ipoint)
|
||||
enddo
|
||||
|
||||
enddo
|
||||
|
||||
enddo
|
||||
enddo
|
||||
enddo
|
||||
!$OMP END DO
|
||||
deallocate(int_fit_v)
|
||||
!$OMP END PARALLEL
|
||||
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)
|
||||
enddo
|
||||
enddo
|
||||
enddo
|
||||
|
||||
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)
|
||||
enddo
|
||||
enddo
|
||||
enddo
|
||||
|
||||
call wall_time(wall1)
|
||||
print*, ' wall time for int2_grad1u2_grad2u2_j1b2_test_v', wall1 - wall0
|
||||
|
||||
END_PROVIDER
|
||||
|
||||
! ---
|
||||
|
||||
BEGIN_PROVIDER [ double precision, int2_u2_j1b2_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
|
||||
!
|
||||
END_DOC
|
||||
|
||||
implicit none
|
||||
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, 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 ...'
|
||||
|
||||
sq_pi_3_2 = (dacos(-1.d0))**(1.5d0)
|
||||
|
||||
provide mu_erf final_grid_points j1b_pen
|
||||
call wall_time(wall0)
|
||||
|
||||
int2_u2_j1b2_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 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)
|
||||
!$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 = 0.d0
|
||||
do i_1s = 1, List_comb_thr_b3_size(j,i)
|
||||
|
||||
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.1.d-10)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)
|
||||
|
||||
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)
|
||||
!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).lt.1.d-10)cycle ! old version
|
||||
if(dabs(coef_fit*coef*factor_ij_1s*int_j1b*sq_pi_3_2*(beta_ij)**(-1.5d0)).lt.1.d-10)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
|
||||
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
|
||||
int2_u2_j1b2_test(j,i,ipoint) = int2_u2_j1b2_test(i,j,ipoint)
|
||||
enddo
|
||||
enddo
|
||||
enddo
|
||||
|
||||
call wall_time(wall1)
|
||||
print*, ' wall time for int2_u2_j1b2_test', wall1 - wall0
|
||||
|
||||
END_PROVIDER
|
||||
|
||||
! ---
|
||||
|
||||
BEGIN_PROVIDER [ double precision, int2_u_grad1u_x_j1b2_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
|
||||
!
|
||||
END_DOC
|
||||
|
||||
implicit none
|
||||
integer :: i, j, ipoint, i_1s, i_fit
|
||||
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 :: wall0, wall1, sq_pi_3_2,sq_alpha
|
||||
|
||||
print*, ' providing int2_u_grad1u_x_j1b2_test ...'
|
||||
|
||||
sq_pi_3_2 = dacos(-1.D0)**(1.d0)
|
||||
provide mu_erf final_grid_points j1b_pen
|
||||
call wall_time(wall0)
|
||||
|
||||
int2_u_grad1u_x_j1b2_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 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)
|
||||
!$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_x = 0.d0
|
||||
tmp_y = 0.d0
|
||||
tmp_z = 0.d0
|
||||
do i_1s = 1, List_comb_thr_b3_size(j,i)
|
||||
|
||||
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.1.d-10)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)
|
||||
do i_fit = 1, ng_fit_jast
|
||||
|
||||
expo_fit = expo_gauss_j_mu_1_erf(i_fit)
|
||||
coef_fit = coef_gauss_j_mu_1_erf(i_fit)
|
||||
|
||||
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))
|
||||
|
||||
alpha_1s = beta + expo_fit
|
||||
alpha_1s_inv = 1.d0 / alpha_1s
|
||||
|
||||
centr_1s(1) = alpha_1s_inv * (beta * B_center(1) + expo_fit * r(1))
|
||||
centr_1s(2) = alpha_1s_inv * (beta * B_center(2) + expo_fit * r(2))
|
||||
centr_1s(3) = alpha_1s_inv * (beta * B_center(3) + expo_fit * r(3))
|
||||
|
||||
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) .lt. 1d-10) cycle ! old version
|
||||
if(dabs(coef_tmp*int_j1b*sq_pi_3_2*sq_alpha) .lt. 1d-10) cycle
|
||||
|
||||
call NAI_pol_x_mult_erf_ao_with1s(i, j, alpha_1s, centr_1s, 1.d+9, r, int_fit)
|
||||
|
||||
tmp_x += coef_tmp * int_fit(1)
|
||||
tmp_y += coef_tmp * int_fit(2)
|
||||
tmp_z += coef_tmp * int_fit(3)
|
||||
enddo
|
||||
|
||||
! ---
|
||||
|
||||
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
|
||||
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
|
||||
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)
|
||||
enddo
|
||||
enddo
|
||||
enddo
|
||||
|
||||
call wall_time(wall1)
|
||||
print*, ' wall time for int2_u_grad1u_x_j1b2_test', wall1 - wall0
|
||||
|
||||
END_PROVIDER
|
||||
|
||||
|
||||
BEGIN_PROVIDER [ double precision, int2_u_grad1u_j1b2_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]
|
||||
!
|
||||
END_DOC
|
||||
|
||||
implicit none
|
||||
integer :: i, j, ipoint, i_1s, i_fit
|
||||
double precision :: r(3), int_fit, expo_fit, coef_fit, coef_tmp
|
||||
double precision :: coef, beta, B_center(3), dist
|
||||
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 :: 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 ...'
|
||||
|
||||
dsqpi_3_2 = (dacos(-1.d0))**(1.5d0)
|
||||
|
||||
provide mu_erf final_grid_points j1b_pen ao_overlap_abs List_comb_thr_b3_cent
|
||||
call wall_time(wall0)
|
||||
|
||||
|
||||
int2_u_grad1u_j1b2_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 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)
|
||||
!$OMP DO
|
||||
do ipoint = 1, n_points_final_grid
|
||||
do i = 1, ao_num
|
||||
do j = i, ao_num
|
||||
if(dabs(ao_overlap_abs_grid(j,i)).lt.1.d-10)cycle
|
||||
r(1) = final_grid_points(1,ipoint)
|
||||
r(2) = final_grid_points(2,ipoint)
|
||||
r(3) = final_grid_points(3,ipoint)
|
||||
|
||||
tmp = 0.d0
|
||||
do i_1s = 1, List_comb_thr_b3_size(j,i)
|
||||
|
||||
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.1.d-10)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)
|
||||
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))
|
||||
|
||||
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.1.d-15)cycle
|
||||
coef_fit = coef_gauss_j_mu_1_erf(i_fit)
|
||||
|
||||
alpha_1s = beta + expo_fit
|
||||
alpha_1s_inv = 1.d0 / alpha_1s
|
||||
centr_1s(1) = alpha_1s_inv * (beta * B_center(1) + expo_fit * r(1))
|
||||
centr_1s(2) = alpha_1s_inv * (beta * B_center(2) + expo_fit * r(2))
|
||||
centr_1s(3) = alpha_1s_inv * (beta * B_center(3) + expo_fit * r(3))
|
||||
|
||||
expo_coef_1s = beta * expo_fit * alpha_1s_inv * dist
|
||||
if(expo_coef_1s .gt. 20.d0) cycle
|
||||
coef_tmp = coef * coef_fit * dexp(-expo_coef_1s)
|
||||
if(dabs(coef_tmp) .lt. 1d-08) cycle
|
||||
|
||||
int_fit = NAI_pol_mult_erf_ao_with1s(i, j, alpha_1s, centr_1s, 1.d+9, r)
|
||||
|
||||
tmp += coef_tmp * int_fit
|
||||
enddo
|
||||
enddo
|
||||
|
||||
int2_u_grad1u_j1b2_test(j,i,ipoint) = tmp
|
||||
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
|
||||
int2_u_grad1u_j1b2_test(j,i,ipoint) = int2_u_grad1u_j1b2_test(i,j,ipoint)
|
||||
enddo
|
||||
enddo
|
||||
enddo
|
||||
|
||||
call wall_time(wall1)
|
||||
print*, ' wall time for int2_u_grad1u_j1b2_test', wall1 - wall0
|
||||
|
||||
END_PROVIDER
|
||||
|
||||
! ---
|
|
@ -19,9 +19,11 @@ 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
|
||||
|
||||
provide mu_erf final_grid_points j1b_pen
|
||||
print*, ' providing int2_grad1u2_grad2u2_j1b2 ...'
|
||||
call wall_time(wall0)
|
||||
|
||||
provide mu_erf final_grid_points j1b_pen
|
||||
|
||||
int2_grad1u2_grad2u2_j1b2 = 0.d0
|
||||
|
||||
!$OMP PARALLEL DEFAULT (NONE) &
|
||||
|
@ -51,7 +53,7 @@ BEGIN_PROVIDER [ double precision, int2_grad1u2_grad2u2_j1b2, (ao_num, ao_num, n
|
|||
|
||||
int_fit = overlap_gauss_r12_ao(r, expo_fit, i, j)
|
||||
tmp += -0.25d0 * coef_fit * int_fit
|
||||
if(dabs(int_fit) .lt. 1d-10) cycle
|
||||
! if(dabs(coef_fit*int_fit) .lt. 1d-12) cycle
|
||||
|
||||
! ---
|
||||
|
||||
|
@ -88,7 +90,7 @@ BEGIN_PROVIDER [ double precision, int2_grad1u2_grad2u2_j1b2, (ao_num, ao_num, n
|
|||
enddo
|
||||
|
||||
call wall_time(wall1)
|
||||
print*, ' wall time for int2_grad1u2_grad2u2_j1b2', wall1 - wall0
|
||||
print*, ' wall time for int2_grad1u2_grad2u2_j1b2 =', wall1 - wall0
|
||||
|
||||
END_PROVIDER
|
||||
|
||||
|
@ -111,9 +113,11 @@ 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
|
||||
|
||||
provide mu_erf final_grid_points j1b_pen
|
||||
print*, ' providing int2_u2_j1b2 ...'
|
||||
call wall_time(wall0)
|
||||
|
||||
provide mu_erf final_grid_points j1b_pen
|
||||
|
||||
int2_u2_j1b2 = 0.d0
|
||||
|
||||
!$OMP PARALLEL DEFAULT (NONE) &
|
||||
|
@ -143,7 +147,7 @@ BEGIN_PROVIDER [ double precision, int2_u2_j1b2, (ao_num, ao_num, n_points_final
|
|||
|
||||
int_fit = overlap_gauss_r12_ao(r, expo_fit, i, j)
|
||||
tmp += coef_fit * int_fit
|
||||
if(dabs(int_fit) .lt. 1d-10) cycle
|
||||
! if(dabs(coef_fit*int_fit) .lt. 1d-12) cycle
|
||||
|
||||
! ---
|
||||
|
||||
|
@ -186,7 +190,7 @@ END_PROVIDER
|
|||
|
||||
! ---
|
||||
|
||||
BEGIN_PROVIDER [ double precision, int2_u_grad1u_x_j1b2, (3, ao_num, ao_num, n_points_final_grid)]
|
||||
BEGIN_PROVIDER [ double precision, int2_u_grad1u_x_j1b2, (ao_num, ao_num, n_points_final_grid, 3)]
|
||||
|
||||
BEGIN_DOC
|
||||
!
|
||||
|
@ -202,9 +206,11 @@ BEGIN_PROVIDER [ double precision, int2_u_grad1u_x_j1b2, (3, ao_num, ao_num, n_p
|
|||
double precision :: tmp_x, tmp_y, tmp_z
|
||||
double precision :: wall0, wall1
|
||||
|
||||
provide mu_erf final_grid_points j1b_pen
|
||||
print*, ' providing int2_u_grad1u_x_j1b2 ...'
|
||||
call wall_time(wall0)
|
||||
|
||||
provide mu_erf final_grid_points j1b_pen
|
||||
|
||||
int2_u_grad1u_x_j1b2 = 0.d0
|
||||
|
||||
!$OMP PARALLEL DEFAULT (NONE) &
|
||||
|
@ -241,7 +247,7 @@ BEGIN_PROVIDER [ double precision, int2_u_grad1u_x_j1b2, (3, ao_num, ao_num, n_p
|
|||
tmp_x += coef_fit * int_fit(1)
|
||||
tmp_y += coef_fit * int_fit(2)
|
||||
tmp_z += coef_fit * int_fit(3)
|
||||
if( (dabs(int_fit(1)) + dabs(int_fit(2)) + dabs(int_fit(3))) .lt. 3d-10 ) cycle
|
||||
! if( dabs(coef_fit)*(dabs(int_fit(1)) + dabs(int_fit(2)) + dabs(int_fit(3))) .lt. 3d-10 ) cycle
|
||||
|
||||
! ---
|
||||
|
||||
|
@ -265,7 +271,7 @@ BEGIN_PROVIDER [ double precision, int2_u_grad1u_x_j1b2, (3, ao_num, ao_num, n_p
|
|||
|
||||
expo_coef_1s = beta * expo_fit * alpha_1s_inv * dist
|
||||
coef_tmp = coef * coef_fit * dexp(-expo_coef_1s)
|
||||
if(dabs(coef_tmp) .lt. 1d-10) cycle
|
||||
! if(dabs(coef_tmp) .lt. 1d-12) cycle
|
||||
|
||||
call NAI_pol_x_mult_erf_ao_with1s(i, j, alpha_1s, centr_1s, 1.d+9, r, int_fit)
|
||||
|
||||
|
@ -278,9 +284,9 @@ BEGIN_PROVIDER [ double precision, int2_u_grad1u_x_j1b2, (3, ao_num, ao_num, n_p
|
|||
|
||||
enddo
|
||||
|
||||
int2_u_grad1u_x_j1b2(1,j,i,ipoint) = tmp_x
|
||||
int2_u_grad1u_x_j1b2(2,j,i,ipoint) = tmp_y
|
||||
int2_u_grad1u_x_j1b2(3,j,i,ipoint) = tmp_z
|
||||
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
|
||||
enddo
|
||||
enddo
|
||||
enddo
|
||||
|
@ -290,15 +296,15 @@ BEGIN_PROVIDER [ double precision, int2_u_grad1u_x_j1b2, (3, 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_x_j1b2(1,j,i,ipoint) = int2_u_grad1u_x_j1b2(1,i,j,ipoint)
|
||||
int2_u_grad1u_x_j1b2(2,j,i,ipoint) = int2_u_grad1u_x_j1b2(2,i,j,ipoint)
|
||||
int2_u_grad1u_x_j1b2(3,j,i,ipoint) = int2_u_grad1u_x_j1b2(3,i,j,ipoint)
|
||||
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
|
||||
print*, ' wall time for int2_u_grad1u_x_j1b2 = ', wall1 - wall0
|
||||
|
||||
END_PROVIDER
|
||||
|
||||
|
@ -320,9 +326,11 @@ 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
|
||||
|
||||
provide mu_erf final_grid_points j1b_pen
|
||||
print*, ' providing int2_u_grad1u_j1b2 ...'
|
||||
call wall_time(wall0)
|
||||
|
||||
provide mu_erf final_grid_points j1b_pen
|
||||
|
||||
int2_u_grad1u_j1b2 = 0.d0
|
||||
|
||||
!$OMP PARALLEL DEFAULT (NONE) &
|
||||
|
@ -351,7 +359,7 @@ BEGIN_PROVIDER [ double precision, int2_u_grad1u_j1b2, (ao_num, ao_num, n_points
|
|||
! ---
|
||||
|
||||
int_fit = NAI_pol_mult_erf_ao_with1s(i, j, expo_fit, r, 1.d+9, r)
|
||||
if(dabs(int_fit) .lt. 1d-10) cycle
|
||||
! if(dabs(coef_fit)*dabs(int_fit) .lt. 1d-12) cycle
|
||||
|
||||
tmp += coef_fit * int_fit
|
||||
|
||||
|
@ -375,9 +383,10 @@ BEGIN_PROVIDER [ double precision, int2_u_grad1u_j1b2, (ao_num, ao_num, n_points
|
|||
centr_1s(3) = alpha_1s_inv * (beta * B_center(3) + expo_fit * r(3))
|
||||
|
||||
expo_coef_1s = beta * expo_fit * alpha_1s_inv * dist
|
||||
if(expo_coef_1s .gt. 80.d0) cycle
|
||||
coef_tmp = coef * coef_fit * dexp(-expo_coef_1s)
|
||||
if(dabs(coef_tmp) .lt. 1d-10) cycle
|
||||
|
||||
if(dabs(coef_tmp) .lt. 1d-12) cycle
|
||||
|
||||
int_fit = NAI_pol_mult_erf_ao_with1s(i, j, alpha_1s, centr_1s, 1.d+9, r)
|
||||
|
||||
tmp += coef_tmp * int_fit
|
||||
|
|
|
@ -241,7 +241,7 @@
|
|||
!
|
||||
!! ---
|
||||
!
|
||||
!BEGIN_PROVIDER [ double precision, int2_u_grad1u_x_j1b2, (3, ao_num, ao_num, n_points_final_grid)]
|
||||
!BEGIN_PROVIDER [ double precision, int2_u_grad1u_x_j1b2, (ao_num, ao_num, n_points_final_grid, 3)]
|
||||
!
|
||||
! BEGIN_DOC
|
||||
! !
|
||||
|
@ -308,7 +308,7 @@
|
|||
!
|
||||
! ! ---
|
||||
!
|
||||
! int2_u_grad1u_x_j1b2(1,j,i,ipoint) += coef_fit * int_fit_v(ipoint,1)
|
||||
! 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
|
||||
|
@ -320,7 +320,7 @@
|
|||
!
|
||||
! ! ---
|
||||
!
|
||||
! int2_u_grad1u_x_j1b2(2,j,i,ipoint) += coef_fit * int_fit_v(ipoint,2)
|
||||
! 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
|
||||
|
@ -332,7 +332,7 @@
|
|||
!
|
||||
! ! ---
|
||||
!
|
||||
! int2_u_grad1u_x_j1b2(3,j,i,ipoint) += coef_fit * int_fit_v(ipoint,3)
|
||||
! 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
|
||||
|
@ -408,15 +408,15 @@
|
|||
! 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(1,j,i,n_mask_grid(ipoint,1)) += coef * dexp(-expo_coef_1s * dist(ipoint,1)) * int_fit_v(ipoint,1)
|
||||
! 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(2,j,i,n_mask_grid(ipoint,2)) += coef * dexp(-expo_coef_1s * dist(ipoint,2)) * int_fit_v(ipoint,2)
|
||||
! 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(3,j,i,n_mask_grid(ipoint,3)) += coef * dexp(-expo_coef_1s * dist(ipoint,3)) * int_fit_v(ipoint,3)
|
||||
! 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
|
||||
|
@ -439,15 +439,15 @@
|
|||
! do ipoint = 1, n_points_final_grid
|
||||
! do i = 2, ao_num
|
||||
! do j = 1, i-1
|
||||
! int2_u_grad1u_x_j1b2(1,j,i,ipoint) = int2_u_grad1u_x_j1b2(1,i,j,ipoint)
|
||||
! int2_u_grad1u_x_j1b2(2,j,i,ipoint) = int2_u_grad1u_x_j1b2(2,i,j,ipoint)
|
||||
! int2_u_grad1u_x_j1b2(3,j,i,ipoint) = int2_u_grad1u_x_j1b2(3,i,j,ipoint)
|
||||
! 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
|
||||
! print*, ' wall time for int2_u_grad1u_x_j1b2 =', wall1 - wall0
|
||||
!
|
||||
!END_PROVIDER
|
||||
!
|
||||
|
|
369
src/ao_many_one_e_ints/grad_lapl_jmu_manu.irp.f
Normal file
369
src/ao_many_one_e_ints/grad_lapl_jmu_manu.irp.f
Normal file
|
@ -0,0 +1,369 @@
|
|||
|
||||
! ---
|
||||
|
||||
BEGIN_PROVIDER [ double precision, v_ij_erf_rk_cst_mu_j1b_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|
|
||||
!
|
||||
END_DOC
|
||||
|
||||
implicit none
|
||||
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 :: 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 ...'
|
||||
|
||||
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
|
||||
|
||||
!$OMP PARALLEL DEFAULT (NONE) &
|
||||
!$OMP PRIVATE (ipoint, i, j, i_1s, r, coef, beta, B_center, int_mu, int_coulomb, tmp, int_j1b)&
|
||||
!$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 ao_overlap_abs_grid,ao_prod_center,ao_prod_sigma,dsqpi_3_2)
|
||||
!$OMP DO
|
||||
!do ipoint = 1, 10
|
||||
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
|
||||
if(dabs(ao_overlap_abs_grid(j,i)).lt.1.d-20)cycle
|
||||
|
||||
tmp = 0.d0
|
||||
do i_1s = 1, 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.1.d-10)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)
|
||||
! TODO :: cycle on the 1 - erf(mur12)
|
||||
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)
|
||||
|
||||
tmp += coef * (int_mu - int_coulomb)
|
||||
enddo
|
||||
|
||||
v_ij_erf_rk_cst_mu_j1b_test(j,i,ipoint) = tmp
|
||||
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
|
||||
v_ij_erf_rk_cst_mu_j1b_test(j,i,ipoint) = v_ij_erf_rk_cst_mu_j1b_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
|
||||
|
||||
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_DOC
|
||||
! int dr x phi_i(r) phi_j(r) 1s_j1b(r) (erf(mu(R) |r - R|) - 1)/|r - R|
|
||||
END_DOC
|
||||
|
||||
implicit none
|
||||
integer :: i, j, ipoint, i_1s
|
||||
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
|
||||
|
||||
print*, ' providing x_v_ij_erf_rk_cst_mu_j1b_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
|
||||
|
||||
!$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 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 ao_overlap_abs_grid,ao_prod_center,ao_prod_sigma)
|
||||
! !$OMP ao_overlap_abs_grid,ao_prod_center,ao_prod_sigma,dsqpi_3_2,expo_erfc_mu_gauss)
|
||||
!$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
|
||||
if(dabs(ao_overlap_abs_grid(j,i)).lt.1.d-10)cycle
|
||||
|
||||
tmp_x = 0.d0
|
||||
tmp_y = 0.d0
|
||||
tmp_z = 0.d0
|
||||
do i_1s = 1, 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.1.d-10)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)
|
||||
|
||||
! if(ao_prod_center(1,j,i).ne.10000.d0)then
|
||||
! ! approximate 1 - erf(mu r12) by a gaussian * 10
|
||||
! !DIR$ FORCEINLINE
|
||||
! call gaussian_product(expo_erfc_mu_gauss,r, &
|
||||
! ao_prod_sigma(j,i),ao_prod_center(1,j,i), &
|
||||
! factor_ij_1s,beta_ij,center_ij_1s)
|
||||
! if(dabs(coef * factor_ij_1s*int_j1b*10.d0 * dsqpi_3_2 * beta_ij**(-1.5d0)).lt.1.d-10)cycle
|
||||
! endif
|
||||
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)
|
||||
|
||||
tmp_x += coef * (ints(1) - ints_coulomb(1))
|
||||
tmp_y += coef * (ints(2) - ints_coulomb(2))
|
||||
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
|
||||
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
|
||||
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)
|
||||
enddo
|
||||
enddo
|
||||
enddo
|
||||
|
||||
call wall_time(wall1)
|
||||
print*, ' wall time for x_v_ij_erf_rk_cst_mu_j1b_test', wall1 - wall0
|
||||
|
||||
END_PROVIDER
|
||||
|
||||
! ---
|
||||
|
||||
! TODO analytically
|
||||
BEGIN_PROVIDER [ double precision, v_ij_u_cst_mu_j1b_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)
|
||||
!
|
||||
END_DOC
|
||||
|
||||
implicit none
|
||||
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)
|
||||
double precision :: tmp
|
||||
double precision :: wall0, wall1
|
||||
|
||||
double precision, external :: overlap_gauss_r12_ao_with1s
|
||||
double precision :: sigma_ij,dist_ij_ipoint,dsqpi_3_2,int_j1b
|
||||
|
||||
print*, ' providing v_ij_u_cst_mu_j1b_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
|
||||
|
||||
!$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 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 ao_overlap_abs_grid,ao_prod_center,ao_prod_sigma,dsqpi_3_2)
|
||||
!$OMP DO
|
||||
!do ipoint = 1, 10
|
||||
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
|
||||
if(dabs(ao_overlap_abs_grid(j,i)).lt.1.d-20)cycle
|
||||
|
||||
tmp = 0.d0
|
||||
do i_1s = 1, 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.1.d-10)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)
|
||||
|
||||
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)
|
||||
coeftot = coef * coef_fit
|
||||
if(dabs(coeftot).lt.1.d-15)cycle
|
||||
double precision :: beta_ij_u, factor_ij_1s_u, center_ij_1s_u(3),coeftot
|
||||
call gaussian_product(beta,B_center,expo_fit,r,factor_ij_1s_u,beta_ij_u,center_ij_1s_u)
|
||||
if(factor_ij_1s_u*ao_overlap_abs_grid(j,i).lt.1.d-15)cycle
|
||||
int_fit = overlap_gauss_r12_ao_with1s(B_center, beta, r, expo_fit, i, j)
|
||||
|
||||
tmp += coef * coef_fit * int_fit
|
||||
enddo
|
||||
enddo
|
||||
|
||||
v_ij_u_cst_mu_j1b_test(j,i,ipoint) = tmp
|
||||
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
|
||||
v_ij_u_cst_mu_j1b_test(j,i,ipoint) = v_ij_u_cst_mu_j1b_test(i,j,ipoint)
|
||||
enddo
|
||||
enddo
|
||||
enddo
|
||||
|
||||
call wall_time(wall1)
|
||||
print*, ' wall time for v_ij_u_cst_mu_j1b_test', wall1 - wall0
|
||||
|
||||
END_PROVIDER
|
||||
|
||||
! ---
|
||||
|
||||
BEGIN_PROVIDER [ double precision, v_ij_u_cst_mu_j1b_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}
|
||||
!
|
||||
END_DOC
|
||||
|
||||
implicit none
|
||||
integer :: i, j, ipoint, i_1s
|
||||
double precision :: r(3), int_fit, expo_fit, coef_fit
|
||||
double precision :: coef, beta, B_center(3)
|
||||
double precision :: tmp
|
||||
double precision :: wall0, wall1
|
||||
|
||||
double precision, external :: overlap_gauss_r12_ao_with1s
|
||||
double precision :: sigma_ij,dist_ij_ipoint,dsqpi_3_2,int_j1b
|
||||
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
|
||||
|
||||
!$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 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 ao_overlap_abs_grid,ao_prod_center,ao_prod_sigma,dsqpi_3_2)
|
||||
!$OMP DO
|
||||
!do ipoint = 1, 10
|
||||
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
|
||||
if(dabs(ao_overlap_abs_grid(j,i)).lt.1.d-20)cycle
|
||||
|
||||
tmp = 0.d0
|
||||
do i_1s = 1, 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.1.d-10)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)
|
||||
|
||||
! do i_fit = 1, ng_fit_jast
|
||||
|
||||
expo_fit = expo_good_j_mu_1gauss
|
||||
coef_fit = 1.d0
|
||||
coeftot = coef * coef_fit
|
||||
if(dabs(coeftot).lt.1.d-15)cycle
|
||||
double precision :: beta_ij_u, factor_ij_1s_u, center_ij_1s_u(3),coeftot
|
||||
call gaussian_product(beta,B_center,expo_fit,r,factor_ij_1s_u,beta_ij_u,center_ij_1s_u)
|
||||
if(factor_ij_1s_u*ao_overlap_abs_grid(j,i).lt.1.d-15)cycle
|
||||
int_fit = overlap_gauss_r12_ao_with1s(B_center, beta, r, expo_fit, i, j)
|
||||
|
||||
tmp += coef * coef_fit * int_fit
|
||||
! enddo
|
||||
enddo
|
||||
|
||||
v_ij_u_cst_mu_j1b_ng_1_test(j,i,ipoint) = tmp
|
||||
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
|
||||
v_ij_u_cst_mu_j1b_ng_1_test(j,i,ipoint) = v_ij_u_cst_mu_j1b_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
|
||||
|
||||
END_PROVIDER
|
||||
|
||||
! ---
|
||||
|
|
@ -17,9 +17,11 @@ 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
|
||||
|
||||
provide mu_erf final_grid_points j1b_pen
|
||||
print *, ' providing v_ij_erf_rk_cst_mu_j1b ...'
|
||||
call wall_time(wall0)
|
||||
|
||||
provide mu_erf final_grid_points j1b_pen
|
||||
|
||||
v_ij_erf_rk_cst_mu_j1b = 0.d0
|
||||
|
||||
!$OMP PARALLEL DEFAULT (NONE) &
|
||||
|
@ -49,7 +51,7 @@ BEGIN_PROVIDER [ double precision, v_ij_erf_rk_cst_mu_j1b, (ao_num, ao_num, n_po
|
|||
|
||||
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(int_mu - int_coulomb) .lt. 1d-10) cycle
|
||||
! if(dabs(coef)*dabs(int_mu - int_coulomb) .lt. 1d-12) cycle
|
||||
|
||||
tmp += coef * (int_mu - int_coulomb)
|
||||
|
||||
|
@ -99,51 +101,23 @@ BEGIN_PROVIDER [ double precision, x_v_ij_erf_rk_cst_mu_j1b, (ao_num, ao_num, n_
|
|||
! int dr x phi_i(r) phi_j(r) 1s_j1b(r) (erf(mu(R) |r - R|) - 1)/|r - R|
|
||||
END_DOC
|
||||
|
||||
implicit none
|
||||
integer :: i, j, ipoint
|
||||
double precision :: wall0, wall1
|
||||
|
||||
call wall_time(wall0)
|
||||
|
||||
do ipoint = 1, n_points_final_grid
|
||||
do i = 1, ao_num
|
||||
do j = 1, ao_num
|
||||
x_v_ij_erf_rk_cst_mu_j1b(j,i,ipoint,1) = x_v_ij_erf_rk_cst_mu_tmp_j1b(1,j,i,ipoint)
|
||||
x_v_ij_erf_rk_cst_mu_j1b(j,i,ipoint,2) = x_v_ij_erf_rk_cst_mu_tmp_j1b(2,j,i,ipoint)
|
||||
x_v_ij_erf_rk_cst_mu_j1b(j,i,ipoint,3) = x_v_ij_erf_rk_cst_mu_tmp_j1b(3,j,i,ipoint)
|
||||
enddo
|
||||
enddo
|
||||
enddo
|
||||
|
||||
call wall_time(wall1)
|
||||
print*, ' wall time for x_v_ij_erf_rk_cst_mu_j1b', wall1 - wall0
|
||||
|
||||
END_PROVIDER
|
||||
|
||||
! ---
|
||||
|
||||
BEGIN_PROVIDER [ double precision, x_v_ij_erf_rk_cst_mu_tmp_j1b, (3, ao_num, ao_num, n_points_final_grid)]
|
||||
|
||||
BEGIN_DOC
|
||||
! int dr x phi_i(r) phi_j(r) 1s_j1b(r) (erf(mu(R) |r - R|) - 1)/|r - R|
|
||||
END_DOC
|
||||
|
||||
implicit none
|
||||
integer :: i, j, ipoint, i_1s
|
||||
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
|
||||
|
||||
print*, ' providing x_v_ij_erf_rk_cst_mu_j1b ...'
|
||||
call wall_time(wall0)
|
||||
|
||||
x_v_ij_erf_rk_cst_mu_tmp_j1b = 0.d0
|
||||
x_v_ij_erf_rk_cst_mu_j1b = 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_tmp_j1b, mu_erf)
|
||||
!$OMP x_v_ij_erf_rk_cst_mu_j1b, mu_erf)
|
||||
!$OMP DO
|
||||
!do ipoint = 1, 10
|
||||
do ipoint = 1, n_points_final_grid
|
||||
|
@ -169,7 +143,7 @@ BEGIN_PROVIDER [ double precision, x_v_ij_erf_rk_cst_mu_tmp_j1b, (3, ao_num, ao_
|
|||
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)
|
||||
|
||||
if( (dabs(ints(1)-ints_coulomb(1)) + dabs(ints(2)-ints_coulomb(2)) + dabs(ints(3)-ints_coulomb(3))) .lt. 3d-10) cycle
|
||||
! if( dabs(coef)*(dabs(ints(1)-ints_coulomb(1)) + dabs(ints(2)-ints_coulomb(2)) + dabs(ints(3)-ints_coulomb(3))) .lt. 3d-10) cycle
|
||||
|
||||
tmp_x += coef * (ints(1) - ints_coulomb(1))
|
||||
tmp_y += coef * (ints(2) - ints_coulomb(2))
|
||||
|
@ -195,9 +169,9 @@ BEGIN_PROVIDER [ double precision, x_v_ij_erf_rk_cst_mu_tmp_j1b, (3, ao_num, ao_
|
|||
|
||||
! ---
|
||||
|
||||
x_v_ij_erf_rk_cst_mu_tmp_j1b(1,j,i,ipoint) = tmp_x
|
||||
x_v_ij_erf_rk_cst_mu_tmp_j1b(2,j,i,ipoint) = tmp_y
|
||||
x_v_ij_erf_rk_cst_mu_tmp_j1b(3,j,i,ipoint) = tmp_z
|
||||
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
|
||||
enddo
|
||||
enddo
|
||||
enddo
|
||||
|
@ -207,15 +181,15 @@ BEGIN_PROVIDER [ double precision, x_v_ij_erf_rk_cst_mu_tmp_j1b, (3, ao_num, ao_
|
|||
do ipoint = 1, n_points_final_grid
|
||||
do i = 2, ao_num
|
||||
do j = 1, i-1
|
||||
x_v_ij_erf_rk_cst_mu_tmp_j1b(1,j,i,ipoint) = x_v_ij_erf_rk_cst_mu_tmp_j1b(1,i,j,ipoint)
|
||||
x_v_ij_erf_rk_cst_mu_tmp_j1b(2,j,i,ipoint) = x_v_ij_erf_rk_cst_mu_tmp_j1b(2,i,j,ipoint)
|
||||
x_v_ij_erf_rk_cst_mu_tmp_j1b(3,j,i,ipoint) = x_v_ij_erf_rk_cst_mu_tmp_j1b(3,i,j,ipoint)
|
||||
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)
|
||||
enddo
|
||||
enddo
|
||||
enddo
|
||||
|
||||
call wall_time(wall1)
|
||||
print*, ' wall time for x_v_ij_erf_rk_cst_mu_tmp_j1b', wall1 - wall0
|
||||
print*, ' wall time for x_v_ij_erf_rk_cst_mu_j1b =', wall1 - wall0
|
||||
|
||||
END_PROVIDER
|
||||
|
||||
|
@ -239,9 +213,11 @@ BEGIN_PROVIDER [ double precision, v_ij_u_cst_mu_j1b, (ao_num, ao_num, n_points_
|
|||
|
||||
double precision, external :: overlap_gauss_r12_ao_with1s
|
||||
|
||||
provide mu_erf final_grid_points j1b_pen
|
||||
print*, ' providing v_ij_u_cst_mu_j1b ...'
|
||||
call wall_time(wall0)
|
||||
|
||||
provide mu_erf final_grid_points j1b_pen
|
||||
|
||||
v_ij_u_cst_mu_j1b = 0.d0
|
||||
|
||||
!$OMP PARALLEL DEFAULT (NONE) &
|
||||
|
@ -277,7 +253,7 @@ BEGIN_PROVIDER [ double precision, v_ij_u_cst_mu_j1b, (ao_num, ao_num, n_points_
|
|||
B_center(3) = List_all_comb_b2_cent(3,1)
|
||||
|
||||
int_fit = overlap_gauss_r12_ao_with1s(B_center, beta, r, expo_fit, i, j)
|
||||
if(dabs(int_fit) .lt. 1d-10) cycle
|
||||
! if(dabs(int_fit*coef) .lt. 1d-12) cycle
|
||||
|
||||
tmp += coef * coef_fit * int_fit
|
||||
|
||||
|
|
|
@ -17,6 +17,8 @@ BEGIN_PROVIDER [ double precision, v_ij_erf_rk_cst_mu, (ao_num, ao_num, n_points
|
|||
|
||||
double precision :: NAI_pol_mult_erf_ao
|
||||
|
||||
print*, ' providing v_ij_erf_rk_cst_mu ...'
|
||||
|
||||
provide mu_erf final_grid_points
|
||||
call wall_time(wall0)
|
||||
|
||||
|
@ -54,7 +56,7 @@ BEGIN_PROVIDER [ double precision, v_ij_erf_rk_cst_mu, (ao_num, ao_num, n_points
|
|||
enddo
|
||||
|
||||
call wall_time(wall1)
|
||||
print*, ' wall time for v_ij_erf_rk_cst_mu ', wall1 - wall0
|
||||
print*, ' wall time for v_ij_erf_rk_cst_mu = ', wall1 - wall0
|
||||
|
||||
END_PROVIDER
|
||||
|
||||
|
@ -73,6 +75,8 @@ BEGIN_PROVIDER [ double precision, v_ij_erf_rk_cst_mu_transp, (n_points_final_gr
|
|||
double precision :: wall0, wall1
|
||||
double precision :: NAI_pol_mult_erf_ao
|
||||
|
||||
print *, ' providing v_ij_erf_rk_cst_mu_transp ...'
|
||||
|
||||
provide mu_erf final_grid_points
|
||||
call wall_time(wall0)
|
||||
|
||||
|
@ -107,7 +111,7 @@ BEGIN_PROVIDER [ double precision, v_ij_erf_rk_cst_mu_transp, (n_points_final_gr
|
|||
enddo
|
||||
|
||||
call wall_time(wall1)
|
||||
print *, ' wall time for v_ij_erf_rk_cst_mu_transp ', wall1 - wall0
|
||||
print *, ' wall time for v_ij_erf_rk_cst_mu_transp = ', wall1 - wall0
|
||||
|
||||
END_PROVIDER
|
||||
|
||||
|
@ -124,6 +128,8 @@ BEGIN_PROVIDER [ double precision, x_v_ij_erf_rk_cst_mu_tmp, (3, ao_num, ao_num,
|
|||
double precision :: r(3), ints(3), ints_coulomb(3)
|
||||
double precision :: wall0, wall1
|
||||
|
||||
print*, ' providing x_v_ij_erf_rk_cst_mu_tmp ...'
|
||||
|
||||
call wall_time(wall0)
|
||||
|
||||
!$OMP PARALLEL &
|
||||
|
@ -162,13 +168,13 @@ BEGIN_PROVIDER [ double precision, x_v_ij_erf_rk_cst_mu_tmp, (3, ao_num, ao_num,
|
|||
enddo
|
||||
|
||||
call wall_time(wall1)
|
||||
print*, ' wall time for x_v_ij_erf_rk_cst_mu_tmp', wall1 - wall0
|
||||
print *, ' wall time for x_v_ij_erf_rk_cst_mu_tmp = ', wall1 - wall0
|
||||
|
||||
END_PROVIDER
|
||||
|
||||
! ---
|
||||
|
||||
BEGIN_PROVIDER [ double precision, x_v_ij_erf_rk_cst_mu, (ao_num, ao_num,n_points_final_grid,3)]
|
||||
BEGIN_PROVIDER [ double precision, x_v_ij_erf_rk_cst_mu, (ao_num, ao_num, n_points_final_grid, 3)]
|
||||
|
||||
BEGIN_DOC
|
||||
! int dr x * phi_i(r) phi_j(r) (erf(mu(R) |r - R|) - 1)/|r - R|
|
||||
|
@ -178,6 +184,8 @@ BEGIN_PROVIDER [ double precision, x_v_ij_erf_rk_cst_mu, (ao_num, ao_num,n_point
|
|||
integer :: i, j, ipoint
|
||||
double precision :: wall0, wall1
|
||||
|
||||
print *, ' providing x_v_ij_erf_rk_cst_mu ...'
|
||||
|
||||
call wall_time(wall0)
|
||||
|
||||
do ipoint = 1, n_points_final_grid
|
||||
|
@ -191,7 +199,7 @@ BEGIN_PROVIDER [ double precision, x_v_ij_erf_rk_cst_mu, (ao_num, ao_num,n_point
|
|||
enddo
|
||||
|
||||
call wall_time(wall1)
|
||||
print *, ' wall time for x_v_ij_erf_rk_cst_mu', wall1 - wall0
|
||||
print *, ' wall time for x_v_ij_erf_rk_cst_mu = ', wall1 - wall0
|
||||
|
||||
END_PROVIDER
|
||||
|
||||
|
@ -207,6 +215,8 @@ BEGIN_PROVIDER [ double precision, x_v_ij_erf_rk_cst_mu_transp, (ao_num, ao_num,
|
|||
integer :: i, j, ipoint
|
||||
double precision :: wall0, wall1
|
||||
|
||||
print *, ' providing x_v_ij_erf_rk_cst_mu_transp ...'
|
||||
|
||||
call wall_time(wall0)
|
||||
|
||||
do ipoint = 1, n_points_final_grid
|
||||
|
@ -220,13 +230,13 @@ BEGIN_PROVIDER [ double precision, x_v_ij_erf_rk_cst_mu_transp, (ao_num, ao_num,
|
|||
enddo
|
||||
|
||||
call wall_time(wall1)
|
||||
print *, ' wall time for x_v_ij_erf_rk_cst_mu_transp', wall1 - wall0
|
||||
print *, ' wall time for x_v_ij_erf_rk_cst_mu_transp = ', wall1 - wall0
|
||||
|
||||
END_PROVIDER
|
||||
|
||||
! ---
|
||||
|
||||
BEGIN_PROVIDER [ double precision, x_v_ij_erf_rk_cst_mu_transp_bis, (n_points_final_grid,ao_num, ao_num,3)]
|
||||
BEGIN_PROVIDER [ double precision, x_v_ij_erf_rk_cst_mu_transp_bis, (n_points_final_grid, ao_num, ao_num, 3)]
|
||||
|
||||
BEGIN_DOC
|
||||
! int dr x * phi_i(r) phi_j(r) (erf(mu(R) |r - R|) - 1)/|r - R|
|
||||
|
@ -236,6 +246,8 @@ BEGIN_PROVIDER [ double precision, x_v_ij_erf_rk_cst_mu_transp_bis, (n_points_fi
|
|||
integer :: i, j, ipoint
|
||||
double precision :: wall0, wall1
|
||||
|
||||
print *, ' providing x_v_ij_erf_rk_cst_mu_transp_bis ...'
|
||||
|
||||
call wall_time(wall0)
|
||||
|
||||
do i = 1, ao_num
|
||||
|
@ -249,7 +261,7 @@ BEGIN_PROVIDER [ double precision, x_v_ij_erf_rk_cst_mu_transp_bis, (n_points_fi
|
|||
enddo
|
||||
|
||||
call wall_time(wall1)
|
||||
print *, ' wall time for x_v_ij_erf_rk_cst_mu_transp_bis', wall1 - wall0
|
||||
print *, ' wall time for x_v_ij_erf_rk_cst_mu_transp_bis = ', wall1 - wall0
|
||||
|
||||
END_PROVIDER
|
||||
|
||||
|
@ -268,7 +280,9 @@ BEGIN_PROVIDER [ double precision, d_dx_v_ij_erf_rk_cst_mu_tmp, (3, n_points_fin
|
|||
double precision :: r(3), ints(3), ints_coulomb(3)
|
||||
double precision :: wall0, wall1
|
||||
|
||||
call wall_time(wall0)
|
||||
print *, ' providing d_dx_v_ij_erf_rk_cst_mu_tmp ...'
|
||||
|
||||
call wall_time(wall0)
|
||||
|
||||
!$OMP PARALLEL &
|
||||
!$OMP DEFAULT (NONE) &
|
||||
|
@ -295,7 +309,7 @@ BEGIN_PROVIDER [ double precision, d_dx_v_ij_erf_rk_cst_mu_tmp, (3, n_points_fin
|
|||
!$OMP END PARALLEL
|
||||
|
||||
call wall_time(wall1)
|
||||
print *, ' wall time for d_dx_v_ij_erf_rk_cst_mu_tmp', wall1 - wall0
|
||||
print *, ' wall time for d_dx_v_ij_erf_rk_cst_mu_tmp = ', wall1 - wall0
|
||||
|
||||
END_PROVIDER
|
||||
|
||||
|
@ -315,6 +329,8 @@ BEGIN_PROVIDER [ double precision, d_dx_v_ij_erf_rk_cst_mu, (n_points_final_grid
|
|||
integer :: i, j, ipoint
|
||||
double precision :: wall0, wall1
|
||||
|
||||
print *, ' providing d_dx_v_ij_erf_rk_cst_mu ...'
|
||||
|
||||
call wall_time(wall0)
|
||||
do i = 1, ao_num
|
||||
do j = 1, ao_num
|
||||
|
@ -327,7 +343,7 @@ BEGIN_PROVIDER [ double precision, d_dx_v_ij_erf_rk_cst_mu, (n_points_final_grid
|
|||
enddo
|
||||
|
||||
call wall_time(wall1)
|
||||
print *, ' wall time for d_dx_v_ij_erf_rk_cst_mu', wall1 - wall0
|
||||
print *, ' wall time for d_dx_v_ij_erf_rk_cst_mu = ', wall1 - wall0
|
||||
|
||||
END_PROVIDER
|
||||
|
||||
|
@ -348,6 +364,8 @@ BEGIN_PROVIDER [ double precision, x_d_dx_v_ij_erf_rk_cst_mu_tmp, (3, n_points_f
|
|||
double precision :: r(3), ints(3), ints_coulomb(3)
|
||||
double precision :: wall0, wall1
|
||||
|
||||
print *, ' providing x_d_dx_v_ij_erf_rk_cst_mu_tmp ...'
|
||||
|
||||
call wall_time(wall0)
|
||||
|
||||
!$OMP PARALLEL &
|
||||
|
@ -375,7 +393,7 @@ BEGIN_PROVIDER [ double precision, x_d_dx_v_ij_erf_rk_cst_mu_tmp, (3, n_points_f
|
|||
!$OMP END PARALLEL
|
||||
|
||||
call wall_time(wall1)
|
||||
print *, ' wall time for x_d_dx_v_ij_erf_rk_cst_mu_tmp', wall1 - wall0
|
||||
print *, ' wall time for x_d_dx_v_ij_erf_rk_cst_mu_tmp = ', wall1 - wall0
|
||||
|
||||
END_PROVIDER
|
||||
|
||||
|
@ -395,6 +413,8 @@ BEGIN_PROVIDER [ double precision, x_d_dx_v_ij_erf_rk_cst_mu, (n_points_final_gr
|
|||
integer :: i, j, ipoint
|
||||
double precision :: wall0, wall1
|
||||
|
||||
print *, ' providing x_d_dx_v_ij_erf_rk_cst_mu ...'
|
||||
|
||||
call wall_time(wall0)
|
||||
|
||||
do i = 1, ao_num
|
||||
|
@ -408,7 +428,7 @@ BEGIN_PROVIDER [ double precision, x_d_dx_v_ij_erf_rk_cst_mu, (n_points_final_gr
|
|||
enddo
|
||||
|
||||
call wall_time(wall1)
|
||||
print *, ' wall time for x_d_dx_v_ij_erf_rk_cst_mu', wall1 - wall0
|
||||
print *, ' wall time for x_d_dx_v_ij_erf_rk_cst_mu = ', wall1 - wall0
|
||||
|
||||
END_PROVIDER
|
||||
|
||||
|
|
59
src/ao_many_one_e_ints/list_grid.irp.f
Normal file
59
src/ao_many_one_e_ints/list_grid.irp.f
Normal file
|
@ -0,0 +1,59 @@
|
|||
BEGIN_PROVIDER [ integer, n_pts_grid_ao_prod, (ao_num, ao_num)]
|
||||
&BEGIN_PROVIDER [ integer, max_n_pts_grid_ao_prod]
|
||||
implicit none
|
||||
integer :: i,j,ipoint
|
||||
double precision :: overlap, r(3),thr, overlap_abs_gauss_r12_ao,overlap_gauss_r12_ao
|
||||
double precision :: sigma,dist,center_ij(3),fact_gauss, alpha, center(3)
|
||||
n_pts_grid_ao_prod = 0
|
||||
thr = 1.d-11
|
||||
print*,' expo_good_j_mu_1gauss = ',expo_good_j_mu_1gauss
|
||||
!$OMP PARALLEL DEFAULT (NONE) &
|
||||
!$OMP PRIVATE (ipoint, i, j, r, overlap, thr,fact_gauss, alpha, center,dist,sigma,center_ij) &
|
||||
!$OMP SHARED (n_points_final_grid, ao_num, ao_overlap_abs_grid,n_pts_grid_ao_prod,expo_good_j_mu_1gauss,&
|
||||
!$OMP final_grid_points,ao_prod_center,ao_prod_sigma,ao_nucl)
|
||||
!$OMP DO
|
||||
do i = 1, ao_num
|
||||
! do i = 3,3
|
||||
do j = 1, ao_num
|
||||
! do i = 22,22
|
||||
! do j = 9,9
|
||||
center_ij(1:3) = ao_prod_center(1:3,j,i)
|
||||
sigma = ao_prod_sigma(j,i)
|
||||
sigma *= sigma
|
||||
sigma = 0.5d0 /sigma
|
||||
! if(dabs(ao_overlap_abs_grid(j,i)).lt.1.d-10)cycle
|
||||
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)
|
||||
dist = (center_ij(1) - r(1))*(center_ij(1) - r(1))
|
||||
dist += (center_ij(2) - r(2))*(center_ij(2) - r(2))
|
||||
dist += (center_ij(3) - r(3))*(center_ij(3) - r(3))
|
||||
dist = dsqrt(dist)
|
||||
call gaussian_product(sigma, center_ij, expo_good_j_mu_1gauss, r, fact_gauss, alpha, center)
|
||||
! print*,''
|
||||
! print*,j,i,ao_overlap_abs_grid(j,i),ao_overlap_abs(j,i)
|
||||
! print*,r
|
||||
! print*,dist,sigma
|
||||
! print*,fact_gauss
|
||||
if( fact_gauss*ao_overlap_abs_grid(j,i).lt.1.d-11)cycle
|
||||
if(ao_nucl(i) == ao_nucl(j))then
|
||||
overlap = overlap_abs_gauss_r12_ao(r, expo_good_j_mu_1gauss, i, j)
|
||||
else
|
||||
overlap = overlap_gauss_r12_ao(r, expo_good_j_mu_1gauss, i, j)
|
||||
endif
|
||||
! print*,overlap
|
||||
if(dabs(overlap).lt.thr)cycle
|
||||
n_pts_grid_ao_prod(j,i) += 1
|
||||
enddo
|
||||
enddo
|
||||
enddo
|
||||
!$OMP END DO
|
||||
!$OMP END PARALLEL
|
||||
|
||||
integer :: list(ao_num)
|
||||
do i = 1, ao_num
|
||||
list(i) = maxval(n_pts_grid_ao_prod(:,i))
|
||||
enddo
|
||||
max_n_pts_grid_ao_prod = maxval(list)
|
||||
END_PROVIDER
|
|
@ -102,6 +102,12 @@ END_PROVIDER
|
|||
List_all_comb_b2_coef(i) = (-1.d0)**dble(phase) * dexp(-List_all_comb_b2_coef(i))
|
||||
enddo
|
||||
|
||||
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
|
||||
|
||||
! ---
|
||||
|
@ -168,7 +174,6 @@ END_PROVIDER
|
|||
|
||||
do j = 1, nucl_num
|
||||
tmp_alphaj = dble(List_all_comb_b3(j,i)) * j1b_pen(j)
|
||||
!print*, 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)
|
||||
|
@ -220,9 +225,11 @@ END_PROVIDER
|
|||
List_all_comb_b3_coef(i) = (-1.d0)**dble(phase) * facto * dexp(-List_all_comb_b3_coef(i))
|
||||
enddo
|
||||
|
||||
print *, ' 1st coeff & expo of lists'
|
||||
print*, List_all_comb_b2_coef(1), List_all_comb_b2_expo(1)
|
||||
print*, List_all_comb_b3_coef(1), List_all_comb_b3_expo(1)
|
||||
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
|
||||
|
||||
|
|
191
src/ao_many_one_e_ints/listj1b_sorted.irp.f
Normal file
191
src/ao_many_one_e_ints/listj1b_sorted.irp.f
Normal file
|
@ -0,0 +1,191 @@
|
|||
|
||||
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,thr
|
||||
double precision :: r(3),weight,dist
|
||||
thr = 1.d-15
|
||||
List_comb_thr_b2_size = 0
|
||||
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.1.d-15)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.thr)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)
|
||||
|
||||
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,thr
|
||||
double precision :: r(3),weight,dist
|
||||
thr = 1.d-15
|
||||
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.1.d-12)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.thr)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,thr
|
||||
double precision :: r(3),weight,dist
|
||||
thr = 1.d-15
|
||||
List_comb_thr_b3_size = 0
|
||||
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.thr)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.thr)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,thr
|
||||
double precision :: r(3),weight,dist
|
||||
thr = 1.d-15
|
||||
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.thr)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.thr)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
|
||||
|
||||
! do i = 1, ao_num
|
||||
! do j = 1, i-1
|
||||
! do icount = 1, List_comb_thr_b3_size(j,i)
|
||||
! List_comb_thr_b3_coef(icount,j,i) = List_comb_thr_b3_coef(icount,i,j)
|
||||
! List_comb_thr_b3_expo(icount,j,i) = List_comb_thr_b3_expo(icount,i,j)
|
||||
! List_comb_thr_b3_cent(1:3,icount,j,i) = List_comb_thr_b3_cent(1:3,icount,i,j)
|
||||
! enddo
|
||||
! enddo
|
||||
! enddo
|
||||
|
||||
END_PROVIDER
|
||||
|
|
@ -1,5 +1,9 @@
|
|||
double precision function overlap_gauss_r12(D_center,delta,A_center,B_center,power_A,power_B,alpha,beta)
|
||||
! ---
|
||||
|
||||
double precision function overlap_gauss_r12(D_center, delta, A_center, B_center, power_A, power_B, alpha, beta)
|
||||
|
||||
BEGIN_DOC
|
||||
!
|
||||
! Computes the following integral :
|
||||
!
|
||||
! .. math ::
|
||||
|
@ -8,6 +12,72 @@ double precision function overlap_gauss_r12(D_center,delta,A_center,B_center,pow
|
|||
!
|
||||
END_DOC
|
||||
|
||||
include 'constants.include.F'
|
||||
|
||||
implicit none
|
||||
double precision, intent(in) :: D_center(3), delta ! pure gaussian "D"
|
||||
double precision, intent(in) :: A_center(3),B_center(3),alpha,beta ! gaussian/polynoms "A" and "B"
|
||||
integer, intent(in) :: power_A(3),power_B(3)
|
||||
|
||||
double precision :: overlap_x,overlap_y,overlap_z,overlap
|
||||
! First you multiply the usual gaussian "A" with the gaussian exp(-delta (r - D)^2 )
|
||||
double precision :: A_new(0:max_dim,3)! new polynom
|
||||
double precision :: A_center_new(3) ! new center
|
||||
integer :: iorder_a_new(3) ! i_order(i) = order of the new polynom ==> should be equal to power_A
|
||||
double precision :: alpha_new ! new exponent
|
||||
double precision :: fact_a_new ! constant factor
|
||||
double precision :: accu, coefx, coefy, coefz, coefxy, coefxyz, thr
|
||||
integer :: d(3), i, lx, ly, lz, iorder_tmp(3), dim1
|
||||
|
||||
dim1 = 100
|
||||
thr = 1.d-10
|
||||
d(:) = 0 ! order of the polynom for the gaussian exp(-delta (r - D)^2 ) == 0
|
||||
overlap_gauss_r12 = 0.d0
|
||||
|
||||
! New gaussian/polynom defined by :: new pol new center new expo cst fact new order
|
||||
call give_explicit_poly_and_gaussian(A_new , A_center_new , alpha_new, fact_a_new , iorder_a_new ,&
|
||||
delta,alpha,d,power_A,D_center,A_center,n_pt_max_integrals)
|
||||
if(fact_a_new.lt.thr)return
|
||||
! The new gaussian exp(-delta (r - D)^2 ) (x-A_x)^a \exp(-\alpha (x-A_x)^2
|
||||
accu = 0.d0
|
||||
do lx = 0, iorder_a_new(1)
|
||||
coefx = A_new(lx,1)*fact_a_new
|
||||
if(dabs(coefx).lt.thr)cycle
|
||||
iorder_tmp(1) = lx
|
||||
|
||||
do ly = 0, iorder_a_new(2)
|
||||
coefy = A_new(ly,2)
|
||||
coefxy = coefx * coefy
|
||||
if(dabs(coefxy) .lt. thr) cycle
|
||||
iorder_tmp(2) = ly
|
||||
|
||||
do lz = 0, iorder_a_new(3)
|
||||
coefz = A_new(lz,3)
|
||||
coefxyz = coefxy * coefz
|
||||
if(dabs(coefxyz) .lt. thr) cycle
|
||||
iorder_tmp(3) = lz
|
||||
|
||||
call overlap_gaussian_xyz( A_center_new, B_center, alpha_new, beta, iorder_tmp, power_B &
|
||||
, overlap_x, overlap_y, overlap_z, overlap, dim1)
|
||||
|
||||
accu += coefxyz * overlap
|
||||
enddo
|
||||
enddo
|
||||
enddo
|
||||
overlap_gauss_r12 = accu
|
||||
end
|
||||
|
||||
!---
|
||||
double precision function overlap_abs_gauss_r12(D_center,delta,A_center,B_center,power_A,power_B,alpha,beta)
|
||||
BEGIN_DOC
|
||||
! Computes the following integral :
|
||||
!
|
||||
! .. math ::
|
||||
!
|
||||
! \int dr exp(-delta (r - D)^2 ) |(x-A_x)^a (x-B_x)^b \exp(-\alpha (x-A_x)^2 - \beta (x-B_x)^2 )|
|
||||
!
|
||||
END_DOC
|
||||
|
||||
implicit none
|
||||
include 'constants.include.F'
|
||||
double precision, intent(in) :: D_center(3), delta ! pure gaussian "D"
|
||||
|
@ -21,20 +91,23 @@ double precision function overlap_gauss_r12(D_center,delta,A_center,B_center,pow
|
|||
integer :: iorder_a_new(3) ! i_order(i) = order of the new polynom ==> should be equal to power_A
|
||||
double precision :: alpha_new ! new exponent
|
||||
double precision :: fact_a_new ! constant factor
|
||||
double precision :: accu,coefx,coefy,coefz,coefxy,coefxyz,thr
|
||||
double precision :: accu,coefx,coefy,coefz,coefxy,coefxyz,thr,dx,lower_exp_val
|
||||
integer :: d(3),i,lx,ly,lz,iorder_tmp(3),dim1
|
||||
dim1=100
|
||||
thr = 1.d-10
|
||||
dim1=50
|
||||
lower_exp_val = 40.d0
|
||||
thr = 1.d-12
|
||||
d(:) = 0 ! order of the polynom for the gaussian exp(-delta (r - D)^2 ) == 0
|
||||
overlap_abs_gauss_r12 = 0.d0
|
||||
|
||||
! New gaussian/polynom defined by :: new pol new center new expo cst fact new order
|
||||
call give_explicit_poly_and_gaussian(A_new , A_center_new , alpha_new, fact_a_new , iorder_a_new ,&
|
||||
delta,alpha,d,power_A,D_center,A_center,n_pt_max_integrals)
|
||||
if(fact_a_new.lt.thr)return
|
||||
! The new gaussian exp(-delta (r - D)^2 ) (x-A_x)^a \exp(-\alpha (x-A_x)^2
|
||||
accu = 0.d0
|
||||
do lx = 0, iorder_a_new(1)
|
||||
coefx = A_new(lx,1)
|
||||
if(dabs(coefx).lt.thr)cycle
|
||||
coefx = A_new(lx,1)*fact_a_new
|
||||
! if(dabs(coefx).lt.thr)cycle
|
||||
iorder_tmp(1) = lx
|
||||
do ly = 0, iorder_a_new(2)
|
||||
coefy = A_new(ly,2)
|
||||
|
@ -46,12 +119,14 @@ double precision function overlap_gauss_r12(D_center,delta,A_center,B_center,pow
|
|||
coefxyz = coefxy * coefz
|
||||
if(dabs(coefxyz).lt.thr)cycle
|
||||
iorder_tmp(3) = lz
|
||||
call overlap_gaussian_xyz(A_center_new,B_center,alpha_new,beta,iorder_tmp,power_B,overlap_x,overlap_y,overlap_z,overlap,dim1)
|
||||
accu += coefxyz * overlap
|
||||
call overlap_x_abs(A_center_new(1),B_center(1),alpha_new,beta,iorder_tmp(1),power_B(1),overlap_x,lower_exp_val,dx,dim1)
|
||||
call overlap_x_abs(A_center_new(2),B_center(2),alpha_new,beta,iorder_tmp(2),power_B(2),overlap_y,lower_exp_val,dx,dim1)
|
||||
call overlap_x_abs(A_center_new(3),B_center(3),alpha_new,beta,iorder_tmp(3),power_B(3),overlap_z,lower_exp_val,dx,dim1)
|
||||
accu += dabs(coefxyz * overlap_x * overlap_y * overlap_z)
|
||||
enddo
|
||||
enddo
|
||||
enddo
|
||||
overlap_gauss_r12 = fact_a_new * accu
|
||||
overlap_abs_gauss_r12= accu
|
||||
end
|
||||
|
||||
!---
|
||||
|
@ -95,11 +170,9 @@ subroutine overlap_gauss_r12_v(D_center, LD_D, delta, A_center, B_center, power_
|
|||
|
||||
maxab = maxval(power_A(1:3))
|
||||
|
||||
allocate(A_new(n_points, 0:maxab, 3), A_center_new(n_points, 3), fact_a_new(n_points), iorder_a_new(3), overlap(n_points))
|
||||
allocate(A_new(n_points,0:maxab,3), A_center_new(n_points,3), fact_a_new(n_points), iorder_a_new(3), overlap(n_points))
|
||||
|
||||
call give_explicit_poly_and_gaussian_v(A_new, maxab, A_center_new, &
|
||||
alpha_new, fact_a_new, iorder_a_new, delta, alpha, d, power_A, &
|
||||
D_center, LD_D, A_center, n_points)
|
||||
call give_explicit_poly_and_gaussian_v(A_new, maxab, A_center_new, alpha_new, fact_a_new, iorder_a_new, delta, alpha, d, power_A, D_center, LD_D, A_center, n_points)
|
||||
|
||||
rvec(:) = 0.d0
|
||||
|
||||
|
|
|
@ -18,6 +18,8 @@ BEGIN_PROVIDER [ double precision, ao_integrals_n_e, (ao_num,ao_num)]
|
|||
double precision :: A_center(3),B_center(3),C_center(3)
|
||||
double precision :: overlap_x,overlap_y,overlap_z,overlap,dx,NAI_pol_mult
|
||||
|
||||
ao_integrals_n_e = 0.d0
|
||||
|
||||
if (read_ao_integrals_n_e) then
|
||||
|
||||
call ezfio_get_ao_one_e_ints_ao_integrals_n_e(ao_integrals_n_e)
|
||||
|
@ -36,8 +38,6 @@ BEGIN_PROVIDER [ double precision, ao_integrals_n_e, (ao_num,ao_num)]
|
|||
|
||||
else
|
||||
|
||||
ao_integrals_n_e = 0.d0
|
||||
|
||||
!$OMP PARALLEL &
|
||||
!$OMP DEFAULT (NONE) &
|
||||
!$OMP PRIVATE (i,j,k,l,m,alpha,beta,A_center,B_center,C_center,power_A,power_B,&
|
||||
|
@ -104,6 +104,9 @@ BEGIN_PROVIDER [ double precision, ao_integrals_n_e, (ao_num,ao_num)]
|
|||
IF(do_pseudo) THEN
|
||||
ao_integrals_n_e += ao_pseudo_integrals
|
||||
ENDIF
|
||||
IF(point_charges) THEN
|
||||
ao_integrals_n_e += ao_integrals_pt_chrg
|
||||
ENDIF
|
||||
|
||||
endif
|
||||
|
||||
|
|
108
src/ao_one_e_ints/pot_pt_charges.irp.f
Normal file
108
src/ao_one_e_ints/pot_pt_charges.irp.f
Normal file
|
@ -0,0 +1,108 @@
|
|||
|
||||
BEGIN_PROVIDER [ double precision, ao_integrals_pt_chrg, (ao_num,ao_num)]
|
||||
|
||||
BEGIN_DOC
|
||||
! Point charge-electron interaction, in the |AO| basis set.
|
||||
!
|
||||
! :math:`\langle \chi_i | -\sum_charge charge * \frac{1}{|r-R_charge|} | \chi_j \rangle`
|
||||
!
|
||||
! Notice the minus sign convention as it is supposed to be for electrons.
|
||||
END_DOC
|
||||
|
||||
implicit none
|
||||
integer :: num_A, num_B, power_A(3), power_B(3)
|
||||
integer :: i, j, k, l, n_pt_in, m
|
||||
double precision :: alpha, beta
|
||||
double precision :: A_center(3),B_center(3),C_center(3)
|
||||
double precision :: overlap_x,overlap_y,overlap_z,overlap,dx,NAI_pol_mult
|
||||
|
||||
ao_integrals_pt_chrg = 0.d0
|
||||
|
||||
! if (read_ao_integrals_pt_chrg) then
|
||||
!
|
||||
! call ezfio_get_ao_one_e_ints_ao_integrals_pt_chrg(ao_integrals_pt_chrg)
|
||||
! print *, 'AO N-e integrals read from disk'
|
||||
!
|
||||
! else
|
||||
|
||||
! if(use_cosgtos) then
|
||||
! !print *, " use_cosgtos for ao_integrals_pt_chrg ?", use_cosgtos
|
||||
!
|
||||
! do j = 1, ao_num
|
||||
! do i = 1, ao_num
|
||||
! ao_integrals_pt_chrg(i,j) = ao_integrals_pt_chrg_cosgtos(i,j)
|
||||
! enddo
|
||||
! enddo
|
||||
!
|
||||
! else
|
||||
|
||||
!$OMP PARALLEL &
|
||||
!$OMP DEFAULT (NONE) &
|
||||
!$OMP PRIVATE (i,j,k,l,m,alpha,beta,A_center,B_center,C_center,power_A,power_B,&
|
||||
!$OMP num_A,num_B,Z,c,c1,n_pt_in) &
|
||||
!$OMP SHARED (ao_num,ao_prim_num,ao_expo_ordered_transp,ao_power,ao_nucl,pts_charge_coord,ao_coef_normalized_ordered_transp,nucl_coord,&
|
||||
!$OMP n_pt_max_integrals,ao_integrals_pt_chrg,n_pts_charge,pts_charge_z)
|
||||
|
||||
n_pt_in = n_pt_max_integrals
|
||||
|
||||
!$OMP DO SCHEDULE (dynamic)
|
||||
|
||||
do j = 1, ao_num
|
||||
num_A = ao_nucl(j)
|
||||
power_A(1:3)= ao_power(j,1:3)
|
||||
A_center(1:3) = nucl_coord(num_A,1:3)
|
||||
|
||||
do i = 1, ao_num
|
||||
|
||||
num_B = ao_nucl(i)
|
||||
power_B(1:3)= ao_power(i,1:3)
|
||||
B_center(1:3) = nucl_coord(num_B,1:3)
|
||||
|
||||
do l=1,ao_prim_num(j)
|
||||
alpha = ao_expo_ordered_transp(l,j)
|
||||
|
||||
do m=1,ao_prim_num(i)
|
||||
beta = ao_expo_ordered_transp(m,i)
|
||||
|
||||
double precision :: c, c1
|
||||
c = 0.d0
|
||||
|
||||
do k = 1, n_pts_charge
|
||||
double precision :: Z
|
||||
Z = pts_charge_z(k)
|
||||
|
||||
C_center(1:3) = pts_charge_coord(k,1:3)
|
||||
|
||||
c1 = NAI_pol_mult( A_center, B_center, power_A, power_B &
|
||||
, alpha, beta, C_center, n_pt_in )
|
||||
|
||||
c = c - Z * c1
|
||||
|
||||
enddo
|
||||
ao_integrals_pt_chrg(i,j) = ao_integrals_pt_chrg(i,j) &
|
||||
+ ao_coef_normalized_ordered_transp(l,j) &
|
||||
* ao_coef_normalized_ordered_transp(m,i) * c
|
||||
enddo
|
||||
enddo
|
||||
enddo
|
||||
enddo
|
||||
|
||||
!$OMP END DO
|
||||
!$OMP END PARALLEL
|
||||
|
||||
! endif
|
||||
|
||||
|
||||
! IF(do_pseudo) THEN
|
||||
! ao_integrals_pt_chrg += ao_pseudo_integrals
|
||||
! ENDIF
|
||||
|
||||
! endif
|
||||
|
||||
|
||||
! if (write_ao_integrals_pt_chrg) then
|
||||
! call ezfio_set_ao_one_e_ints_ao_integrals_pt_chrg(ao_integrals_pt_chrg)
|
||||
! print *, 'AO N-e integrals written to disk'
|
||||
! endif
|
||||
|
||||
END_PROVIDER
|
|
@ -1950,26 +1950,26 @@ xq(17)=-3.34785456738322
|
|||
xq(18)=-3.94476404011563
|
||||
xq(19)=-4.60368244955074
|
||||
xq(20)=-5.38748089001123
|
||||
wq(1)= 2.229393645534151E-013
|
||||
wq(2)= 4.399340992273176E-010
|
||||
wq(3)= 1.086069370769280E-007
|
||||
wq(4)= 7.802556478532063E-006
|
||||
wq(5)= 2.283386360163528E-004
|
||||
wq(6)= 3.243773342237853E-003
|
||||
wq(7)= 2.481052088746362E-002
|
||||
wq(1)= 2.229393645534151D-013
|
||||
wq(2)= 4.399340992273176D-010
|
||||
wq(3)= 1.086069370769280D-007
|
||||
wq(4)= 7.802556478532063D-006
|
||||
wq(5)= 2.283386360163528D-004
|
||||
wq(6)= 3.243773342237853D-003
|
||||
wq(7)= 2.481052088746362D-002
|
||||
wq(8)= 0.109017206020022
|
||||
wq(9)= 0.286675505362834
|
||||
wq(10)= 0.462243669600610
|
||||
wq(11)= 0.462243669600610
|
||||
wq(12)= 0.286675505362834
|
||||
wq(13)= 0.109017206020022
|
||||
wq(14)= 2.481052088746362E-002
|
||||
wq(15)= 3.243773342237853E-003
|
||||
wq(16)= 2.283386360163528E-004
|
||||
wq(17)= 7.802556478532063E-006
|
||||
wq(18)= 1.086069370769280E-007
|
||||
wq(19)= 4.399340992273176E-010
|
||||
wq(20)= 2.229393645534151E-013
|
||||
wq(14)= 2.481052088746362D-002
|
||||
wq(15)= 3.243773342237853D-003
|
||||
wq(16)= 2.283386360163528D-004
|
||||
wq(17)= 7.802556478532063D-006
|
||||
wq(18)= 1.086069370769280D-007
|
||||
wq(19)= 4.399340992273176D-010
|
||||
wq(20)= 2.229393645534151D-013
|
||||
|
||||
npts=20
|
||||
! call gauher(xq,wq,npts)
|
||||
|
|
|
@ -1,5 +1,40 @@
|
|||
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
|
||||
END_PROVIDER
|
||||
|
||||
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 ]
|
||||
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) ]
|
||||
implicit none
|
||||
BEGIN_DOC
|
||||
|
@ -88,6 +123,36 @@ END_PROVIDER
|
|||
expo_gauss_j_mu_x(i) = tmp * expo_gauss_j_mu_x(i)
|
||||
enddo
|
||||
|
||||
elseif(ng_fit_jast .eq. 7) then
|
||||
|
||||
coef_gauss_j_mu_x = (/ -0.01756495d0 , -0.01023623d0 , -0.06548959d0 , -0.03539446d0 , -0.17150646d0 , -0.15071096d0 , -0.11326834d0 /)
|
||||
expo_gauss_j_mu_x = (/ 9.88572565d+02, 1.21363371d+04, 3.69794870d+01, 1.67364529d+02, 3.03962934d+00, 1.27854005d+00, 9.76383343d+00 /)
|
||||
|
||||
tmp = mu_erf * mu_erf
|
||||
do i = 1, ng_fit_jast
|
||||
expo_gauss_j_mu_x(i) = tmp * expo_gauss_j_mu_x(i)
|
||||
enddo
|
||||
|
||||
elseif(ng_fit_jast .eq. 8) then
|
||||
|
||||
coef_gauss_j_mu_x = (/ -0.11489205d0 , -0.16008968d0 , -0.12892456d0 , -0.04250838d0 , -0.0718451d0 , -0.02394051d0 , -0.00913353d0 , -0.01285182d0 /)
|
||||
expo_gauss_j_mu_x = (/ 6.97632442d+00, 2.56010878d+00, 1.22760977d+00, 7.47697124d+01, 2.16104215d+01, 2.96549728d+02, 1.40773328d+04, 1.43335159d+03 /)
|
||||
|
||||
tmp = mu_erf * mu_erf
|
||||
do i = 1, ng_fit_jast
|
||||
expo_gauss_j_mu_x(i) = tmp * expo_gauss_j_mu_x(i)
|
||||
enddo
|
||||
|
||||
!elseif(ng_fit_jast .eq. 9) then
|
||||
|
||||
! coef_gauss_j_mu_x = (/ /)
|
||||
! expo_gauss_j_mu_x = (/ /)
|
||||
|
||||
! tmp = mu_erf * mu_erf
|
||||
! do i = 1, ng_fit_jast
|
||||
! expo_gauss_j_mu_x(i) = tmp * expo_gauss_j_mu_x(i)
|
||||
! enddo
|
||||
|
||||
elseif(ng_fit_jast .eq. 20) then
|
||||
|
||||
ASSERT(n_max_fit_slat == 20)
|
||||
|
@ -189,6 +254,36 @@ END_PROVIDER
|
|||
expo_gauss_j_mu_x_2(i) = tmp * expo_gauss_j_mu_x_2(i)
|
||||
enddo
|
||||
|
||||
elseif(ng_fit_jast .eq. 7) then
|
||||
|
||||
coef_gauss_j_mu_x_2 = (/ 0.05202849d0 , 0.01031081d0 , 0.04699157d0 , 0.01451002d0 , 0.07442576d0 , 0.02692033d0 , 0.09311842d0 /)
|
||||
expo_gauss_j_mu_x_2 = (/ 3.04469415d+00, 1.40682034d+04, 7.45960945d+01, 1.43067466d+03, 2.16815661d+01, 2.95750306d+02, 7.23471236d+00 /)
|
||||
|
||||
tmp = mu_erf * mu_erf
|
||||
do i = 1, ng_fit_jast
|
||||
expo_gauss_j_mu_x_2(i) = tmp * expo_gauss_j_mu_x_2(i)
|
||||
enddo
|
||||
|
||||
elseif(ng_fit_jast .eq. 8) then
|
||||
|
||||
coef_gauss_j_mu_x_2 = (/ 0.00942115d0 , 0.07332421d0 , 0.0508308d0 , 0.08204949d0 , 0.0404099d0 , 0.03201288d0 , 0.01911313d0 , 0.01114732d0 /)
|
||||
expo_gauss_j_mu_x_2 = (/ 1.56957321d+04, 1.52867810d+01, 4.36016903d+01, 5.96818956d+00, 2.85535269d+00, 1.36064008d+02, 4.71968910d+02, 1.92022350d+03 /)
|
||||
|
||||
tmp = mu_erf * mu_erf
|
||||
do i = 1, ng_fit_jast
|
||||
expo_gauss_j_mu_x_2(i) = tmp * expo_gauss_j_mu_x_2(i)
|
||||
enddo
|
||||
|
||||
!elseif(ng_fit_jast .eq. 9) then
|
||||
|
||||
! coef_gauss_j_mu_x_2 = (/ /)
|
||||
! expo_gauss_j_mu_x_2 = (/ /)
|
||||
!
|
||||
! tmp = mu_erf * mu_erf
|
||||
! do i = 1, ng_fit_jast
|
||||
! expo_gauss_j_mu_x_2(i) = tmp * expo_gauss_j_mu_x_2(i)
|
||||
! enddo
|
||||
|
||||
elseif(ng_fit_jast .eq. 20) then
|
||||
|
||||
ASSERT(n_max_fit_slat == 20)
|
||||
|
@ -293,6 +388,36 @@ END_PROVIDER
|
|||
expo_gauss_j_mu_1_erf(i) = tmp * expo_gauss_j_mu_1_erf(i)
|
||||
enddo
|
||||
|
||||
elseif(ng_fit_jast .eq. 7) then
|
||||
|
||||
coef_gauss_j_mu_1_erf = (/ -0.11853067d0 , -0.01522824d0 , -0.07419098d0 , -0.022202d0 , -0.12242283d0 , -0.04177571d0 , -0.16983107d0 /)
|
||||
expo_gauss_j_mu_1_erf = (/ 2.74057056d+00, 1.37626591d+04, 6.65578663d+01, 1.34693031d+03, 1.90547699d+01, 2.69445390d+02, 6.31845879d+00/)
|
||||
|
||||
tmp = mu_erf * mu_erf
|
||||
do i = 1, ng_fit_jast
|
||||
expo_gauss_j_mu_1_erf(i) = tmp * expo_gauss_j_mu_1_erf(i)
|
||||
enddo
|
||||
|
||||
elseif(ng_fit_jast .eq. 8) then
|
||||
|
||||
coef_gauss_j_mu_1_erf = (/ -0.12263328d0 , -0.04965255d0 , -0.15463564d0 , -0.09675781d0 , -0.0807023d0 , -0.02923298d0 , -0.01381381d0 , -0.01675923d0 /)
|
||||
expo_gauss_j_mu_1_erf = (/ 1.36101994d+01, 1.24908367d+02, 5.29061388d+00, 2.60692516d+00, 3.93396935d+01, 4.43071610d+02, 1.54902240d+04, 1.85170446d+03 /)
|
||||
|
||||
tmp = mu_erf * mu_erf
|
||||
do i = 1, ng_fit_jast
|
||||
expo_gauss_j_mu_1_erf(i) = tmp * expo_gauss_j_mu_1_erf(i)
|
||||
enddo
|
||||
|
||||
!elseif(ng_fit_jast .eq. 9) then
|
||||
|
||||
! coef_gauss_j_mu_1_erf = (/ /)
|
||||
! expo_gauss_j_mu_1_erf = (/ /)
|
||||
|
||||
! tmp = mu_erf * mu_erf
|
||||
! do i = 1, ng_fit_jast
|
||||
! expo_gauss_j_mu_1_erf(i) = tmp * expo_gauss_j_mu_1_erf(i)
|
||||
! enddo
|
||||
|
||||
elseif(ng_fit_jast .eq. 20) then
|
||||
|
||||
ASSERT(n_max_fit_slat == 20)
|
||||
|
|
|
@ -1,59 +1,79 @@
|
|||
! ---
|
||||
|
||||
BEGIN_PROVIDER [integer, n_gauss_eff_pot]
|
||||
implicit none
|
||||
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
|
||||
n_gauss_eff_pot = n_max_fit_slat + 1
|
||||
|
||||
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
|
||||
|
||||
n_gauss_eff_pot = ng_fit_jast + 1
|
||||
|
||||
END_PROVIDER
|
||||
|
||||
! ---
|
||||
|
||||
BEGIN_PROVIDER [integer, n_gauss_eff_pot_deriv]
|
||||
implicit none
|
||||
BEGIN_DOC
|
||||
! V(r12) = -(1 - erf(mu*r12))^2 is expanded in Gaussians as Eqs A11-A20 in JCP 154, 084119 (2021)
|
||||
END_DOC
|
||||
n_gauss_eff_pot_deriv = n_max_fit_slat
|
||||
|
||||
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
|
||||
|
||||
! ---
|
||||
|
||||
BEGIN_PROVIDER [double precision, expo_gauss_eff_pot, (n_gauss_eff_pot)]
|
||||
&BEGIN_PROVIDER [double precision, coef_gauss_eff_pot, (n_gauss_eff_pot)]
|
||||
implicit none
|
||||
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'
|
||||
|
||||
integer :: i
|
||||
! fit of the -0.25 * (1 - erf(mu*x))^2 with n_max_fit_slat gaussians
|
||||
do i = 1, n_max_fit_slat
|
||||
expo_gauss_eff_pot(i) = expo_gauss_1_erf_x_2(i)
|
||||
coef_gauss_eff_pot(i) = -0.25d0 * coef_gauss_1_erf_x_2(i) ! -1/4 * (1 - erf(mu*x))^2
|
||||
enddo
|
||||
! Analytical Gaussian part of the potential: + 1/(\sqrt(pi)mu) * exp(-(mu*x)^2)
|
||||
expo_gauss_eff_pot(n_max_fit_slat+1) = mu_erf * mu_erf
|
||||
coef_gauss_eff_pot(n_max_fit_slat+1) = 1.d0 * mu_erf * inv_sq_pi
|
||||
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'
|
||||
|
||||
implicit none
|
||||
integer :: i
|
||||
|
||||
! fit of the -0.25 * (1 - erf(mu*x))^2 with n_max_fit_slat gaussians
|
||||
do i = 1, ng_fit_jast
|
||||
expo_gauss_eff_pot(i) = expo_gauss_1_erf_x_2(i)
|
||||
coef_gauss_eff_pot(i) = -0.25d0 * coef_gauss_1_erf_x_2(i) ! -1/4 * (1 - erf(mu*x))^2
|
||||
enddo
|
||||
|
||||
! Analytical Gaussian part of the potential: + 1/(\sqrt(pi)mu) * exp(-(mu*x)^2)
|
||||
expo_gauss_eff_pot(ng_fit_jast+1) = mu_erf * mu_erf
|
||||
coef_gauss_eff_pot(ng_fit_jast+1) = 1.d0 * mu_erf * inv_sq_pi
|
||||
|
||||
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
|
||||
double precision, intent(in) :: x, mu
|
||||
|
||||
eff_pot_gauss = mu/dsqrt(dacos(-1.d0)) * dexp(-mu*mu*x*x) - 0.25d0 * (1.d0 - derf(mu*x))**2.d0
|
||||
|
||||
double precision function eff_pot_gauss(x,mu)
|
||||
implicit none
|
||||
BEGIN_DOC
|
||||
! V(mu,r12) = -0.25 * (1 - erf(mu*r12))^2 + 1/(\sqrt(pi)mu) * exp(-(mu*r12)^2)
|
||||
END_DOC
|
||||
double precision, intent(in) :: x,mu
|
||||
eff_pot_gauss = mu/dsqrt(dacos(-1.d0)) * dexp(-mu*mu*x*x) - 0.25d0 * (1.d0 - derf(mu*x))**2.d0
|
||||
end
|
||||
|
||||
|
||||
|
||||
! -------------------------------------------------------------------------------------------------
|
||||
! ---
|
||||
|
||||
|
@ -129,16 +149,19 @@ END_PROVIDER
|
|||
! ---
|
||||
|
||||
double precision function fit_1_erf_x(x)
|
||||
implicit none
|
||||
double precision, intent(in) :: x
|
||||
BEGIN_DOC
|
||||
! fit_1_erf_x(x) = \sum_i c_i exp (-alpha_i x^2) \approx (1 - erf(mu*x))
|
||||
END_DOC
|
||||
integer :: i
|
||||
fit_1_erf_x = 0.d0
|
||||
do i = 1, n_max_fit_slat
|
||||
fit_1_erf_x += dexp(-expo_gauss_1_erf_x(i) *x*x) * coef_gauss_1_erf_x(i)
|
||||
enddo
|
||||
|
||||
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
|
||||
|
||||
fit_1_erf_x = 0.d0
|
||||
do i = 1, n_max_fit_slat
|
||||
fit_1_erf_x += dexp(-expo_gauss_1_erf_x(i) *x*x) * coef_gauss_1_erf_x(i)
|
||||
enddo
|
||||
|
||||
end
|
||||
|
||||
|
@ -165,7 +188,7 @@ end
|
|||
expo_gauss_1_erf_x_2 = (/ 6.23519457d0 /)
|
||||
|
||||
tmp = mu_erf * mu_erf
|
||||
do i = 1, n_max_fit_slat
|
||||
do i = 1, ng_fit_jast
|
||||
expo_gauss_1_erf_x_2(i) = tmp * expo_gauss_1_erf_x_2(i)
|
||||
enddo
|
||||
|
||||
|
@ -175,7 +198,7 @@ end
|
|||
expo_gauss_1_erf_x_2 = (/ 55.39184787d0, 3.92151407d0 /)
|
||||
|
||||
tmp = mu_erf * mu_erf
|
||||
do i = 1, n_max_fit_slat
|
||||
do i = 1, ng_fit_jast
|
||||
expo_gauss_1_erf_x_2(i) = tmp * expo_gauss_1_erf_x_2(i)
|
||||
enddo
|
||||
|
||||
|
@ -185,7 +208,7 @@ end
|
|||
expo_gauss_1_erf_x_2 = (/ 19.90272209d0, 3.2671671d0 , 336.47320445d0 /)
|
||||
|
||||
tmp = mu_erf * mu_erf
|
||||
do i = 1, n_max_fit_slat
|
||||
do i = 1, ng_fit_jast
|
||||
expo_gauss_1_erf_x_2(i) = tmp * expo_gauss_1_erf_x_2(i)
|
||||
enddo
|
||||
|
||||
|
@ -195,7 +218,7 @@ end
|
|||
expo_gauss_1_erf_x_2 = (/ 6467.28126d0, 46.9071990d0, 9.09617721d0, 2.76883328d0, 360.367093d0 /)
|
||||
|
||||
tmp = mu_erf * mu_erf
|
||||
do i = 1, n_max_fit_slat
|
||||
do i = 1, ng_fit_jast
|
||||
expo_gauss_1_erf_x_2(i) = tmp * expo_gauss_1_erf_x_2(i)
|
||||
enddo
|
||||
|
||||
|
@ -205,10 +228,40 @@ end
|
|||
expo_gauss_1_erf_x_2 = (/ 2.54293498d+01, 1.40317872d+02, 7.14630801d+00, 2.65517675d+00, 1.45142619d+03, 1.00000000d+04 /)
|
||||
|
||||
tmp = mu_erf * mu_erf
|
||||
do i = 1, n_max_fit_slat
|
||||
do i = 1, ng_fit_jast
|
||||
expo_gauss_1_erf_x_2(i) = tmp * expo_gauss_1_erf_x_2(i)
|
||||
enddo
|
||||
|
||||
elseif(ng_fit_jast .eq. 7) then
|
||||
|
||||
coef_gauss_1_erf_x_2 = (/ 0.0213619d0 , 0.03221511d0 , 0.29966689d0 , 0.19178934d0 , 0.06154732d0 , 0.28214555d0 , 0.11125985d0 /)
|
||||
expo_gauss_1_erf_x_2 = (/ 1.34727067d+04, 1.27166613d+03, 5.52584567d+00, 1.67753218d+01, 2.46145691d+02, 2.47971820d+00, 5.95141293d+01 /)
|
||||
|
||||
tmp = mu_erf * mu_erf
|
||||
do i = 1, ng_fit_jast
|
||||
expo_gauss_1_erf_x_2(i) = tmp * expo_gauss_1_erf_x_2(i)
|
||||
enddo
|
||||
|
||||
elseif(ng_fit_jast .eq. 8) then
|
||||
|
||||
coef_gauss_1_erf_x_2 = (/ 0.28189124d0 , 0.19518669d0 , 0.12161735d0 , 0.24257438d0 , 0.07309656d0 , 0.042435d0 , 0.01926109d0 , 0.02393415d0 /)
|
||||
expo_gauss_1_erf_x_2 = (/ 4.69795903d+00, 1.21379451d+01, 3.55527053d+01, 2.39227172d+00, 1.14827721d+02, 4.16320213d+02, 1.52813587d+04, 1.78516557d+03 /)
|
||||
|
||||
tmp = mu_erf * mu_erf
|
||||
do i = 1, ng_fit_jast
|
||||
expo_gauss_1_erf_x_2(i) = tmp * expo_gauss_1_erf_x_2(i)
|
||||
enddo
|
||||
|
||||
!elseif(ng_fit_jast .eq. 9) then
|
||||
|
||||
! coef_gauss_1_erf_x_2 = (/ /)
|
||||
! expo_gauss_1_erf_x_2 = (/ /)
|
||||
|
||||
! tmp = mu_erf * mu_erf
|
||||
! do i = 1, ng_fit_jast
|
||||
! expo_gauss_1_erf_x_2(i) = tmp * expo_gauss_1_erf_x_2(i)
|
||||
! enddo
|
||||
|
||||
elseif(ng_fit_jast .eq. 20) then
|
||||
|
||||
ASSERT(n_max_fit_slat == 20)
|
||||
|
|
|
@ -107,50 +107,69 @@ BEGIN_PROVIDER [ double precision, int2_grad1_u12_ao_transp, (ao_num, ao_num, 3,
|
|||
integer :: i, j, ipoint
|
||||
double precision :: wall0, wall1
|
||||
|
||||
print *, ' providing int2_grad1_u12_ao_transp ...'
|
||||
call wall_time(wall0)
|
||||
do ipoint = 1, n_points_final_grid
|
||||
do i = 1, ao_num
|
||||
do j = 1, ao_num
|
||||
int2_grad1_u12_ao_transp(j,i,1,ipoint) = int2_grad1_u12_ao(1,j,i,ipoint)
|
||||
int2_grad1_u12_ao_transp(j,i,2,ipoint) = int2_grad1_u12_ao(2,j,i,ipoint)
|
||||
int2_grad1_u12_ao_transp(j,i,3,ipoint) = int2_grad1_u12_ao(3,j,i,ipoint)
|
||||
enddo
|
||||
enddo
|
||||
enddo
|
||||
|
||||
if(test_cycle_tc)then
|
||||
do ipoint = 1, n_points_final_grid
|
||||
do i = 1, ao_num
|
||||
do j = 1, ao_num
|
||||
int2_grad1_u12_ao_transp(j,i,1,ipoint) = int2_grad1_u12_ao_test(j,i,ipoint,1)
|
||||
int2_grad1_u12_ao_transp(j,i,2,ipoint) = int2_grad1_u12_ao_test(j,i,ipoint,2)
|
||||
int2_grad1_u12_ao_transp(j,i,3,ipoint) = int2_grad1_u12_ao_test(j,i,ipoint,3)
|
||||
enddo
|
||||
enddo
|
||||
enddo
|
||||
else
|
||||
do ipoint = 1, n_points_final_grid
|
||||
do i = 1, ao_num
|
||||
do j = 1, ao_num
|
||||
int2_grad1_u12_ao_transp(j,i,1,ipoint) = int2_grad1_u12_ao(j,i,ipoint,1)
|
||||
int2_grad1_u12_ao_transp(j,i,2,ipoint) = int2_grad1_u12_ao(j,i,ipoint,2)
|
||||
int2_grad1_u12_ao_transp(j,i,3,ipoint) = int2_grad1_u12_ao(j,i,ipoint,3)
|
||||
enddo
|
||||
enddo
|
||||
enddo
|
||||
endif
|
||||
call wall_time(wall1)
|
||||
print *, ' wall time for int2_grad1_u12_ao_transp ', wall1 - wall0
|
||||
|
||||
END_PROVIDER
|
||||
|
||||
! ---
|
||||
|
||||
BEGIN_PROVIDER [ double precision, int2_grad1_u12_bimo_transp, (mo_num, mo_num, 3, n_points_final_grid)]
|
||||
|
||||
implicit none
|
||||
integer :: ipoint
|
||||
double precision :: wall0, wall1
|
||||
|
||||
print*,'providing int2_grad1_u12_bimo_transp'
|
||||
double precision :: wall0, wall1
|
||||
call wall_time(wall0)
|
||||
!$OMP PARALLEL &
|
||||
!$OMP DEFAULT (NONE) &
|
||||
!$OMP PRIVATE (ipoint) &
|
||||
!$OMP SHARED (n_points_final_grid,int2_grad1_u12_ao_transp,int2_grad1_u12_bimo_transp)
|
||||
!$OMP DO SCHEDULE (dynamic)
|
||||
do ipoint = 1, n_points_final_grid
|
||||
call ao_to_mo_bi_ortho( int2_grad1_u12_ao_transp (1,1,1,ipoint), size(int2_grad1_u12_ao_transp , 1) &
|
||||
, int2_grad1_u12_bimo_transp(1,1,1,ipoint), size(int2_grad1_u12_bimo_transp, 1) )
|
||||
call ao_to_mo_bi_ortho( int2_grad1_u12_ao_transp (1,1,2,ipoint), size(int2_grad1_u12_ao_transp , 1) &
|
||||
, int2_grad1_u12_bimo_transp(1,1,2,ipoint), size(int2_grad1_u12_bimo_transp, 1) )
|
||||
call ao_to_mo_bi_ortho( int2_grad1_u12_ao_transp (1,1,3,ipoint), size(int2_grad1_u12_ao_transp , 1) &
|
||||
, int2_grad1_u12_bimo_transp(1,1,3,ipoint), size(int2_grad1_u12_bimo_transp, 1) )
|
||||
enddo
|
||||
!$OMP END DO
|
||||
!$OMP END PARALLEL
|
||||
call wall_time(wall1)
|
||||
print*,'Wall time for providing int2_grad1_u12_bimo_transp',wall1 - wall0
|
||||
!print *, ' providing int2_grad1_u12_bimo_transp'
|
||||
|
||||
call wall_time(wall0)
|
||||
!$OMP PARALLEL &
|
||||
!$OMP DEFAULT (NONE) &
|
||||
!$OMP PRIVATE (ipoint) &
|
||||
!$OMP SHARED (n_points_final_grid,int2_grad1_u12_ao_transp,int2_grad1_u12_bimo_transp)
|
||||
!$OMP DO SCHEDULE (dynamic)
|
||||
do ipoint = 1, n_points_final_grid
|
||||
call ao_to_mo_bi_ortho( int2_grad1_u12_ao_transp (1,1,1,ipoint), size(int2_grad1_u12_ao_transp , 1) &
|
||||
, int2_grad1_u12_bimo_transp(1,1,1,ipoint), size(int2_grad1_u12_bimo_transp, 1) )
|
||||
call ao_to_mo_bi_ortho( int2_grad1_u12_ao_transp (1,1,2,ipoint), size(int2_grad1_u12_ao_transp , 1) &
|
||||
, int2_grad1_u12_bimo_transp(1,1,2,ipoint), size(int2_grad1_u12_bimo_transp, 1) )
|
||||
call ao_to_mo_bi_ortho( int2_grad1_u12_ao_transp (1,1,3,ipoint), size(int2_grad1_u12_ao_transp , 1) &
|
||||
, int2_grad1_u12_bimo_transp(1,1,3,ipoint), size(int2_grad1_u12_bimo_transp, 1) )
|
||||
enddo
|
||||
!$OMP END DO
|
||||
!$OMP END PARALLEL
|
||||
|
||||
call wall_time(wall1)
|
||||
!print *, ' Wall time for providing int2_grad1_u12_bimo_transp',wall1 - wall0
|
||||
|
||||
END_PROVIDER
|
||||
|
||||
! ---
|
||||
|
||||
BEGIN_PROVIDER [ double precision, int2_grad1_u12_bimo_t, (n_points_final_grid,3, mo_num, mo_num )]
|
||||
implicit none
|
||||
integer :: i, j, ipoint
|
||||
|
@ -165,35 +184,22 @@ BEGIN_PROVIDER [ double precision, int2_grad1_u12_bimo_t, (n_points_final_grid,3
|
|||
enddo
|
||||
END_PROVIDER
|
||||
|
||||
BEGIN_PROVIDER [ double precision, int2_grad1_u12_bimo, (3, mo_num, mo_num, n_points_final_grid)]
|
||||
! ---
|
||||
|
||||
BEGIN_DOC
|
||||
!
|
||||
! int2_grad1_u12_bimo(:,k,i,ipoint) = \int dr2 [-1 * \grad_r1 J(r1,r2)] \chi_k(r2) \phi_i(r2)
|
||||
!
|
||||
END_DOC
|
||||
BEGIN_PROVIDER [ double precision, int2_grad1_u12_ao_t, (n_points_final_grid, 3, ao_num, ao_num)]
|
||||
|
||||
implicit none
|
||||
integer :: ipoint
|
||||
print*,'Wrong !!'
|
||||
stop
|
||||
!$OMP PARALLEL &
|
||||
!$OMP DEFAULT (NONE) &
|
||||
!$OMP PRIVATE (ipoint) &
|
||||
!$OMP SHARED (n_points_final_grid,int2_grad1_u12_ao,int2_grad1_u12_bimo)
|
||||
!$OMP DO SCHEDULE (dynamic)
|
||||
integer :: i, j, ipoint
|
||||
|
||||
do ipoint = 1, n_points_final_grid
|
||||
|
||||
call ao_to_mo_bi_ortho( int2_grad1_u12_ao (1,1,1,ipoint), size(int2_grad1_u12_ao , 2) &
|
||||
, int2_grad1_u12_bimo(1,1,1,ipoint), size(int2_grad1_u12_bimo, 2) )
|
||||
call ao_to_mo_bi_ortho( int2_grad1_u12_ao (2,1,1,ipoint), size(int2_grad1_u12_ao , 2) &
|
||||
, int2_grad1_u12_bimo(2,1,1,ipoint), size(int2_grad1_u12_bimo, 2) )
|
||||
call ao_to_mo_bi_ortho( int2_grad1_u12_ao (3,1,1,ipoint), size(int2_grad1_u12_ao , 2) &
|
||||
, int2_grad1_u12_bimo(3,1,1,ipoint), size(int2_grad1_u12_bimo, 2) )
|
||||
|
||||
do i = 1, ao_num
|
||||
do j = 1, ao_num
|
||||
int2_grad1_u12_ao_t(ipoint,1,j,i) = int2_grad1_u12_ao(j,i,ipoint,1)
|
||||
int2_grad1_u12_ao_t(ipoint,2,j,i) = int2_grad1_u12_ao(j,i,ipoint,2)
|
||||
int2_grad1_u12_ao_t(ipoint,3,j,i) = int2_grad1_u12_ao(j,i,ipoint,3)
|
||||
enddo
|
||||
enddo
|
||||
enddo
|
||||
!$OMP END DO
|
||||
!$OMP END PARALLEL
|
||||
|
||||
END_PROVIDER
|
||||
|
||||
|
|
|
@ -60,7 +60,7 @@ BEGIN_PROVIDER [ double precision, three_e_3_idx_cycle_1_bi_ort, (mo_num, mo_num
|
|||
!
|
||||
! matrix element of the -L three-body operator ON A BI ORTHONORMAL BASIS for the first cyclic permutation
|
||||
!
|
||||
! three_e_3_idx_direct_bi_ort(m,j,i) = <mji|-L|jim>
|
||||
! three_e_3_idx_cycle_1_bi_ort(m,j,i) = <mji|-L|jim>
|
||||
!
|
||||
! notice the -1 sign: in this way three_e_3_idx_direct_bi_ort can be directly used to compute Slater rules with a + sign
|
||||
!
|
||||
|
|
|
@ -195,7 +195,7 @@ BEGIN_PROVIDER [ double precision, three_e_4_idx_exch13_bi_ort, (mo_num, mo_num,
|
|||
!
|
||||
! matrix element of the -L three-body operator FOR THE DIRECT TERMS OF SINGLE EXCITATIONS AND BI ORTHO MOs
|
||||
!
|
||||
! three_e_4_idx_exch13_bi_ort(m,j,k,i) = <mjk|-L|jmi> ::: notice that i is the RIGHT MO and k is the LEFT MO
|
||||
! three_e_4_idx_exch13_bi_ort(m,j,k,i) = <mjk|-L|ijm> ::: notice that i is the RIGHT MO and k is the LEFT MO
|
||||
!
|
||||
! notice the -1 sign: in this way three_e_3_idx_direct_bi_ort can be directly used to compute Slater rules with a + sign
|
||||
END_DOC
|
||||
|
@ -241,7 +241,7 @@ BEGIN_PROVIDER [ double precision, three_e_4_idx_exch12_bi_ort, (mo_num, mo_num,
|
|||
!
|
||||
! matrix element of the -L three-body operator FOR THE DIRECT TERMS OF SINGLE EXCITATIONS AND BI ORTHO MOs
|
||||
!
|
||||
! three_e_4_idx_exch12_bi_ort(m,j,k,i) = <mjk|-L|jmi> ::: notice that i is the RIGHT MO and k is the LEFT MO
|
||||
! three_e_4_idx_exch12_bi_ort(m,j,k,i) = <mjk|-L|mij> ::: notice that i is the RIGHT MO and k is the LEFT MO
|
||||
!
|
||||
! notice the -1 sign: in this way three_e_3_idx_direct_bi_ort can be directly used to compute Slater rules with a + sign
|
||||
!
|
||||
|
|
|
@ -7,7 +7,7 @@ BEGIN_PROVIDER [ double precision, three_e_5_idx_direct_bi_ort, (mo_num, mo_num,
|
|||
!
|
||||
! matrix element of the -L three-body operator FOR THE DIRECT TERMS OF DOUBLE EXCITATIONS AND BI ORTHO MOs
|
||||
!
|
||||
! three_e_5_idx_direct_bi_ort(m,l,j,k,i) = <mjk|-L|mji> ::: notice that i is the RIGHT MO and k is the LEFT MO
|
||||
! three_e_5_idx_direct_bi_ort(m,l,j,k,i) = <mlk|-L|mji> ::: notice that i is the RIGHT MO and k is the LEFT MO
|
||||
!
|
||||
! notice the -1 sign: in this way three_e_3_idx_direct_bi_ort can be directly used to compute Slater rules with a + sign
|
||||
END_DOC
|
||||
|
@ -202,7 +202,7 @@ BEGIN_PROVIDER [ double precision, three_e_5_idx_exch13_bi_ort, (mo_num, mo_num,
|
|||
!
|
||||
! matrix element of the -L three-body operator FOR THE DIRECT TERMS OF DOUBLE EXCITATIONS AND BI ORTHO MOs
|
||||
!
|
||||
! three_e_5_idx_exch13_bi_ort(m,l,j,k,i) = <mlk|-L|jmi> ::: notice that i is the RIGHT MO and k is the LEFT MO
|
||||
! three_e_5_idx_exch13_bi_ort(m,l,j,k,i) = <mlk|-L|ijm> ::: notice that i is the RIGHT MO and k is the LEFT MO
|
||||
!
|
||||
! notice the -1 sign: in this way three_e_3_idx_direct_bi_ort can be directly used to compute Slater rules with a + sign
|
||||
!
|
||||
|
@ -251,7 +251,7 @@ BEGIN_PROVIDER [ double precision, three_e_5_idx_exch12_bi_ort, (mo_num, mo_num,
|
|||
!
|
||||
! matrix element of the -L three-body operator FOR THE DIRECT TERMS OF DOUBLE EXCITATIONS AND BI ORTHO MOs
|
||||
!
|
||||
! three_e_5_idx_exch12_bi_ort(m,l,j,k,i) = <mlk|-L|jmi> ::: notice that i is the RIGHT MO and k is the LEFT MO
|
||||
! three_e_5_idx_exch12_bi_ort(m,l,j,k,i) = <mlk|-L|mij> ::: notice that i is the RIGHT MO and k is the LEFT MO
|
||||
!
|
||||
! notice the -1 sign: in this way three_e_3_idx_direct_bi_ort can be directly used to compute Slater rules with a + sign
|
||||
!
|
||||
|
|
|
@ -15,7 +15,7 @@ BEGIN_PROVIDER [ double precision, three_body_ints_bi_ort, (mo_num, mo_num, mo_n
|
|||
character*(128) :: name_file
|
||||
|
||||
three_body_ints_bi_ort = 0.d0
|
||||
print*,'Providing the three_body_ints_bi_ort ...'
|
||||
print *, ' Providing the three_body_ints_bi_ort ...'
|
||||
call wall_time(wall0)
|
||||
name_file = 'six_index_tensor'
|
||||
|
||||
|
@ -71,7 +71,7 @@ subroutine give_integrals_3_body_bi_ort(n, l, k, m, j, i, integral)
|
|||
|
||||
BEGIN_DOC
|
||||
!
|
||||
! < n l k | -L | m j i > with a BI-ORTHONORMAL ORBITALS
|
||||
! < n l k | -L | m j i > with a BI-ORTHONORMAL MOLECULAR ORBITALS
|
||||
!
|
||||
END_DOC
|
||||
|
||||
|
@ -104,12 +104,11 @@ end subroutine give_integrals_3_body_bi_ort
|
|||
|
||||
! ---
|
||||
|
||||
|
||||
subroutine give_integrals_3_body_bi_ort_old(n, l, k, m, j, i, integral)
|
||||
|
||||
BEGIN_DOC
|
||||
!
|
||||
! < n l k | -L | m j i > with a BI-ORTHONORMAL ORBITALS
|
||||
! < n l k | -L | m j i > with a BI-ORTHONORMAL MOLECULAR ORBITALS
|
||||
!
|
||||
END_DOC
|
||||
|
||||
|
@ -170,3 +169,39 @@ end subroutine give_integrals_3_body_bi_ort_old
|
|||
|
||||
! ---
|
||||
|
||||
subroutine give_integrals_3_body_bi_ort_ao(n, l, k, m, j, i, integral)
|
||||
|
||||
BEGIN_DOC
|
||||
!
|
||||
! < n l k | -L | m j i > with a BI-ORTHONORMAL ATOMIC ORBITALS
|
||||
!
|
||||
END_DOC
|
||||
|
||||
implicit none
|
||||
integer, intent(in) :: n, l, k, m, j, i
|
||||
double precision, intent(out) :: integral
|
||||
integer :: ipoint
|
||||
double precision :: weight
|
||||
|
||||
integral = 0.d0
|
||||
do ipoint = 1, n_points_final_grid
|
||||
weight = final_weight_at_r_vector(ipoint)
|
||||
|
||||
integral += weight * aos_in_r_array_transp(ipoint,k) * aos_in_r_array_transp(ipoint,i) &
|
||||
* ( int2_grad1_u12_ao_t(ipoint,1,n,m) * int2_grad1_u12_ao_t(ipoint,1,l,j) &
|
||||
+ int2_grad1_u12_ao_t(ipoint,2,n,m) * int2_grad1_u12_ao_t(ipoint,2,l,j) &
|
||||
+ int2_grad1_u12_ao_t(ipoint,3,n,m) * int2_grad1_u12_ao_t(ipoint,3,l,j) )
|
||||
integral += weight * aos_in_r_array_transp(ipoint,l) * aos_in_r_array_transp(ipoint,j) &
|
||||
* ( int2_grad1_u12_ao_t(ipoint,1,n,m) * int2_grad1_u12_ao_t(ipoint,1,k,i) &
|
||||
+ int2_grad1_u12_ao_t(ipoint,2,n,m) * int2_grad1_u12_ao_t(ipoint,2,k,i) &
|
||||
+ int2_grad1_u12_ao_t(ipoint,3,n,m) * int2_grad1_u12_ao_t(ipoint,3,k,i) )
|
||||
integral += weight * aos_in_r_array_transp(ipoint,n) * aos_in_r_array_transp(ipoint,m) &
|
||||
* ( int2_grad1_u12_ao_t(ipoint,1,l,j) * int2_grad1_u12_ao_t(ipoint,1,k,i) &
|
||||
+ int2_grad1_u12_ao_t(ipoint,2,l,j) * int2_grad1_u12_ao_t(ipoint,2,k,i) &
|
||||
+ int2_grad1_u12_ao_t(ipoint,3,l,j) * int2_grad1_u12_ao_t(ipoint,3,k,i) )
|
||||
|
||||
enddo
|
||||
|
||||
end subroutine give_integrals_3_body_bi_ort_ao
|
||||
|
||||
! ---
|
||||
|
|
|
@ -199,3 +199,52 @@ 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) ]
|
||||
implicit none
|
||||
BEGIN_DOC
|
||||
! mo_bi_ortho_tc_two_e_jj(i,j) = J_ij = <ji|W-K|ji>
|
||||
! mo_bi_ortho_tc_two_e_jj_exchange(i,j) = K_ij = <ij|W-K|ji>
|
||||
! mo_bi_ortho_tc_two_e_jj_anti(i,j) = J_ij - K_ij
|
||||
END_DOC
|
||||
|
||||
integer :: i,j
|
||||
double precision :: get_two_e_integral
|
||||
|
||||
mo_bi_ortho_tc_two_e_jj = 0.d0
|
||||
mo_bi_ortho_tc_two_e_jj_exchange = 0.d0
|
||||
|
||||
do i=1,mo_num
|
||||
do j=1,mo_num
|
||||
mo_bi_ortho_tc_two_e_jj(i,j) = mo_bi_ortho_tc_two_e(j,i,j,i)
|
||||
mo_bi_ortho_tc_two_e_jj_exchange(i,j) = mo_bi_ortho_tc_two_e(i,j,j,i)
|
||||
mo_bi_ortho_tc_two_e_jj_anti(i,j) = mo_bi_ortho_tc_two_e_jj(i,j) - mo_bi_ortho_tc_two_e_jj_exchange(i,j)
|
||||
enddo
|
||||
enddo
|
||||
|
||||
END_PROVIDER
|
||||
|
||||
BEGIN_PROVIDER [double precision, tc_2e_3idx_coulomb_integrals, (mo_num,mo_num, mo_num)]
|
||||
&BEGIN_PROVIDER [double precision, tc_2e_3idx_exchange_integrals,(mo_num,mo_num, mo_num)]
|
||||
implicit none
|
||||
BEGIN_DOC
|
||||
! tc_2e_3idx_coulomb_integrals(j,k,i) = <jk|ji>
|
||||
!
|
||||
! tc_2e_3idx_exchange_integrals(j,k,i) = <kj|ji>
|
||||
END_DOC
|
||||
integer :: i,j,k,l
|
||||
double precision :: get_two_e_integral
|
||||
double precision :: integral
|
||||
|
||||
do i = 1, mo_num
|
||||
do k = 1, mo_num
|
||||
do j = 1, mo_num
|
||||
tc_2e_3idx_coulomb_integrals(j, k,i) = mo_bi_ortho_tc_two_e(j ,k ,j ,i )
|
||||
tc_2e_3idx_exchange_integrals(j,k,i) = mo_bi_ortho_tc_two_e(k ,j ,j ,i )
|
||||
enddo
|
||||
enddo
|
||||
enddo
|
||||
|
||||
END_PROVIDER
|
||||
|
|
|
@ -2,47 +2,68 @@
|
|||
! ---
|
||||
|
||||
BEGIN_PROVIDER [double precision, TCSCF_bi_ort_dm_ao_alpha, (ao_num, ao_num) ]
|
||||
|
||||
BEGIN_DOC
|
||||
! TCSCF_bi_ort_dm_ao_alpha(i,j) = <Chi_0| a^dagger_i,alpha a_j,alpha |Phi_0> where i,j are AO basis.
|
||||
!
|
||||
! This is the equivalent of the alpha density of the HF Slater determinant, but with a couple of bi-orthonormal Slater determinant |Chi_0> and |Phi_0>
|
||||
END_DOC
|
||||
|
||||
implicit none
|
||||
BEGIN_DOC
|
||||
! TCSCF_bi_ort_dm_ao_alpha(i,j) = <Chi_0| a^dagger_i,alpha a_j,alpha |Phi_0> where i,j are AO basis.
|
||||
!
|
||||
! This is the equivalent of the alpha density of the HF Slater determinant, but with a couple of bi-orthonormal Slater determinant |Chi_0> and |Phi_0>
|
||||
END_DOC
|
||||
|
||||
PROVIDE mo_l_coef mo_r_coef
|
||||
|
||||
call dgemm( 'N', 'T', ao_num, ao_num, elec_alpha_num, 1.d0 &
|
||||
, mo_l_coef, size(mo_l_coef, 1), mo_r_coef, size(mo_r_coef, 1) &
|
||||
!, mo_r_coef, size(mo_r_coef, 1), mo_l_coef, size(mo_l_coef, 1) &
|
||||
, 0.d0, TCSCF_bi_ort_dm_ao_alpha, size(TCSCF_bi_ort_dm_ao_alpha, 1) )
|
||||
|
||||
END_PROVIDER
|
||||
|
||||
! ---
|
||||
|
||||
BEGIN_PROVIDER [ double precision, TCSCF_bi_ort_dm_ao_beta, (ao_num, ao_num) ]
|
||||
|
||||
BEGIN_DOC
|
||||
! TCSCF_bi_ort_dm_ao_beta(i,j) = <Chi_0| a^dagger_i,beta a_j,beta |Phi_0> where i,j are AO basis.
|
||||
!
|
||||
! This is the equivalent of the beta density of the HF Slater determinant, but with a couple of bi-orthonormal Slater determinant |Chi_0> and |Phi_0>
|
||||
END_DOC
|
||||
|
||||
implicit none
|
||||
BEGIN_DOC
|
||||
! TCSCF_bi_ort_dm_ao_beta(i,j) = <Chi_0| a^dagger_i,beta a_j,beta |Phi_0> where i,j are AO basis.
|
||||
!
|
||||
! This is the equivalent of the beta density of the HF Slater determinant, but with a couple of bi-orthonormal Slater determinant |Chi_0> and |Phi_0>
|
||||
END_DOC
|
||||
call dgemm( 'N', 'T', ao_num, ao_num, elec_beta_num, 1.d0 &
|
||||
|
||||
PROVIDE mo_l_coef mo_r_coef
|
||||
|
||||
call dgemm( 'N', 'T', ao_num, ao_num, elec_beta_num, 1.d0 &
|
||||
, mo_l_coef, size(mo_l_coef, 1), mo_r_coef, size(mo_r_coef, 1) &
|
||||
!, mo_r_coef, size(mo_r_coef, 1), mo_l_coef, size(mo_l_coef, 1) &
|
||||
, 0.d0, TCSCF_bi_ort_dm_ao_beta, size(TCSCF_bi_ort_dm_ao_beta, 1) )
|
||||
|
||||
END_PROVIDER
|
||||
|
||||
! ---
|
||||
|
||||
BEGIN_PROVIDER [ double precision, TCSCF_bi_ort_dm_ao, (ao_num, ao_num) ]
|
||||
|
||||
BEGIN_DOC
|
||||
! TCSCF_bi_ort_dm_ao(i,j) = <Chi_0| a^dagger_i,beta+alpha a_j,beta+alpha |Phi_0> where i,j are AO basis.
|
||||
!
|
||||
! This is the equivalent of the total electronic density of the HF Slater determinant, but with a couple of bi-orthonormal Slater determinant |Chi_0> and |Phi_0>
|
||||
END_DOC
|
||||
|
||||
implicit none
|
||||
BEGIN_DOC
|
||||
! TCSCF_bi_ort_dm_ao(i,j) = <Chi_0| a^dagger_i,beta+alpha a_j,beta+alpha |Phi_0> where i,j are AO basis.
|
||||
!
|
||||
! This is the equivalent of the total electronic density of the HF Slater determinant, but with a couple of bi-orthonormal Slater determinant |Chi_0> and |Phi_0>
|
||||
END_DOC
|
||||
ASSERT ( size(TCSCF_bi_ort_dm_ao, 1) == size(TCSCF_bi_ort_dm_ao_alpha, 1) )
|
||||
if( elec_alpha_num==elec_beta_num ) then
|
||||
|
||||
PROVIDE mo_l_coef mo_r_coef
|
||||
|
||||
ASSERT(size(TCSCF_bi_ort_dm_ao, 1) == size(TCSCF_bi_ort_dm_ao_alpha, 1))
|
||||
|
||||
if(elec_alpha_num==elec_beta_num) then
|
||||
TCSCF_bi_ort_dm_ao = TCSCF_bi_ort_dm_ao_alpha + TCSCF_bi_ort_dm_ao_alpha
|
||||
else
|
||||
ASSERT ( size(TCSCF_bi_ort_dm_ao, 1) == size(TCSCF_bi_ort_dm_ao_beta, 1))
|
||||
ASSERT(size(TCSCF_bi_ort_dm_ao, 1) == size(TCSCF_bi_ort_dm_ao_beta, 1))
|
||||
TCSCF_bi_ort_dm_ao = TCSCF_bi_ort_dm_ao_alpha + TCSCF_bi_ort_dm_ao_beta
|
||||
endif
|
||||
|
||||
END_PROVIDER
|
||||
|
||||
! ---
|
||||
|
|
|
@ -37,6 +37,52 @@ end subroutine ao_to_mo_bi_ortho
|
|||
|
||||
! ---
|
||||
|
||||
subroutine mo_to_ao_bi_ortho(A_mo, LDA_mo, A_ao, LDA_ao)
|
||||
|
||||
BEGIN_DOC
|
||||
!
|
||||
! mo_l_coef.T x A_ao x mo_r_coef = A_mo
|
||||
! mo_l_coef.T x ao_overlap x mo_r_coef = I
|
||||
!
|
||||
! ==> A_ao = (ao_overlap x mo_r_coef) x A_mo x (ao_overlap x mo_l_coef).T
|
||||
!
|
||||
END_DOC
|
||||
|
||||
implicit none
|
||||
integer, intent(in) :: LDA_ao, LDA_mo
|
||||
double precision, intent(in) :: A_mo(LDA_mo,mo_num)
|
||||
double precision, intent(out) :: A_ao(LDA_ao,ao_num)
|
||||
double precision, allocatable :: tmp_1(:,:), tmp_2(:,:)
|
||||
|
||||
! ao_overlap x mo_r_coef
|
||||
allocate( tmp_1(ao_num,mo_num) )
|
||||
call dgemm( 'N', 'N', ao_num, mo_num, ao_num, 1.d0 &
|
||||
, ao_overlap, size(ao_overlap, 1), mo_r_coef, size(mo_r_coef, 1) &
|
||||
, 0.d0, tmp_1, size(tmp_1, 1) )
|
||||
|
||||
! (ao_overlap x mo_r_coef) x A_mo
|
||||
allocate( tmp_2(ao_num,mo_num) )
|
||||
call dgemm( 'N', 'N', ao_num, mo_num, mo_num, 1.d0 &
|
||||
, tmp_1, size(tmp_1, 1), A_mo, LDA_mo &
|
||||
, 0.d0, tmp_2, size(tmp_2, 1) )
|
||||
|
||||
! ao_overlap x mo_l_coef
|
||||
tmp_1 = 0.d0
|
||||
call dgemm( 'N', 'N', ao_num, mo_num, ao_num, 1.d0 &
|
||||
, ao_overlap, size(ao_overlap, 1), mo_l_coef, size(mo_l_coef, 1) &
|
||||
, 0.d0, tmp_1, size(tmp_1, 1) )
|
||||
|
||||
! (ao_overlap x mo_r_coef) x A_mo x (ao_overlap x mo_l_coef).T
|
||||
call dgemm( 'N', 'T', ao_num, ao_num, mo_num, 1.d0 &
|
||||
, tmp_2, size(tmp_2, 1), tmp_1, size(tmp_1, 1) &
|
||||
, 0.d0, A_ao, LDA_ao )
|
||||
|
||||
deallocate(tmp_1, tmp_2)
|
||||
|
||||
end subroutine mo_to_ao_bi_ortho
|
||||
|
||||
! ---
|
||||
|
||||
BEGIN_PROVIDER [ double precision, mo_r_coef, (ao_num, mo_num) ]
|
||||
|
||||
BEGIN_DOC
|
||||
|
@ -175,3 +221,4 @@ END_PROVIDER
|
|||
|
||||
! ---
|
||||
|
||||
|
||||
|
|
|
@ -132,7 +132,7 @@ end
|
|||
subroutine give_n2_cas(r1,r2,istate,n2_psi)
|
||||
implicit none
|
||||
BEGIN_DOC
|
||||
! returns mu(r), f_psi, n2_psi for a general cas wave function
|
||||
! returns n2_psi for a general cas wave function
|
||||
END_DOC
|
||||
integer, intent(in) :: istate
|
||||
double precision, intent(in) :: r1(3),r2(3)
|
||||
|
|
95
src/cipsi_tc_bi_ortho/fock_diag.irp.f
Normal file
95
src/cipsi_tc_bi_ortho/fock_diag.irp.f
Normal file
|
@ -0,0 +1,95 @@
|
|||
subroutine build_fock_tmp_tc(fock_diag_tmp,det_ref,Nint)
|
||||
use bitmasks
|
||||
implicit none
|
||||
BEGIN_DOC
|
||||
! Build the diagonal of the Fock matrix corresponding to a generator
|
||||
! determinant. $F_{00}$ is $\langle i|H|i \rangle = E_0$.
|
||||
END_DOC
|
||||
integer, intent(in) :: Nint
|
||||
integer(bit_kind), intent(in) :: det_ref(Nint,2)
|
||||
double precision, intent(out) :: fock_diag_tmp(2,mo_num+1)
|
||||
|
||||
integer :: occ(Nint*bit_kind_size,2)
|
||||
integer :: ne(2), i, j, ii, jj
|
||||
double precision :: E0
|
||||
|
||||
! Compute Fock matrix diagonal elements
|
||||
call bitstring_to_list_ab(det_ref,occ,Ne,Nint)
|
||||
|
||||
fock_diag_tmp = 0.d0
|
||||
E0 = 0.d0
|
||||
|
||||
if (Ne(1) /= elec_alpha_num) then
|
||||
print *, 'Error in build_fock_tmp_tc (alpha)', Ne(1), Ne(2)
|
||||
call debug_det(det_ref,N_int)
|
||||
stop -1
|
||||
endif
|
||||
if (Ne(2) /= elec_beta_num) then
|
||||
print *, 'Error in build_fock_tmp_tc (beta)', Ne(1), Ne(2)
|
||||
call debug_det(det_ref,N_int)
|
||||
stop -1
|
||||
endif
|
||||
|
||||
! Occupied MOs
|
||||
do ii=1,elec_alpha_num
|
||||
i = occ(ii,1)
|
||||
fock_diag_tmp(1,i) = fock_diag_tmp(1,i) + mo_one_e_integrals(i,i)
|
||||
E0 = E0 + mo_one_e_integrals(i,i)
|
||||
do jj=1,elec_alpha_num
|
||||
j = occ(jj,1)
|
||||
if (i==j) cycle
|
||||
fock_diag_tmp(1,i) = fock_diag_tmp(1,i) + mo_two_e_integrals_jj_anti(i,j)
|
||||
E0 = E0 + 0.5d0*mo_two_e_integrals_jj_anti(i,j)
|
||||
enddo
|
||||
do jj=1,elec_beta_num
|
||||
j = occ(jj,2)
|
||||
fock_diag_tmp(1,i) = fock_diag_tmp(1,i) + mo_two_e_integrals_jj(i,j)
|
||||
E0 = E0 + mo_two_e_integrals_jj(i,j)
|
||||
enddo
|
||||
enddo
|
||||
do ii=1,elec_beta_num
|
||||
i = occ(ii,2)
|
||||
fock_diag_tmp(2,i) = fock_diag_tmp(2,i) + mo_one_e_integrals(i,i)
|
||||
E0 = E0 + mo_one_e_integrals(i,i)
|
||||
do jj=1,elec_beta_num
|
||||
j = occ(jj,2)
|
||||
if (i==j) cycle
|
||||
fock_diag_tmp(2,i) = fock_diag_tmp(2,i) + mo_two_e_integrals_jj_anti(i,j)
|
||||
E0 = E0 + 0.5d0*mo_two_e_integrals_jj_anti(i,j)
|
||||
enddo
|
||||
do jj=1,elec_alpha_num
|
||||
j = occ(jj,1)
|
||||
fock_diag_tmp(2,i) = fock_diag_tmp(2,i) + mo_two_e_integrals_jj(i,j)
|
||||
enddo
|
||||
enddo
|
||||
|
||||
! Virtual MOs
|
||||
do i=1,mo_num
|
||||
if (fock_diag_tmp(1,i) /= 0.d0) cycle
|
||||
fock_diag_tmp(1,i) = fock_diag_tmp(1,i) + mo_one_e_integrals(i,i)
|
||||
do jj=1,elec_alpha_num
|
||||
j = occ(jj,1)
|
||||
fock_diag_tmp(1,i) = fock_diag_tmp(1,i) + mo_two_e_integrals_jj_anti(i,j)
|
||||
enddo
|
||||
do jj=1,elec_beta_num
|
||||
j = occ(jj,2)
|
||||
fock_diag_tmp(1,i) = fock_diag_tmp(1,i) + mo_two_e_integrals_jj(i,j)
|
||||
enddo
|
||||
enddo
|
||||
do i=1,mo_num
|
||||
if (fock_diag_tmp(2,i) /= 0.d0) cycle
|
||||
fock_diag_tmp(2,i) = fock_diag_tmp(2,i) + mo_one_e_integrals(i,i)
|
||||
do jj=1,elec_beta_num
|
||||
j = occ(jj,2)
|
||||
fock_diag_tmp(2,i) = fock_diag_tmp(2,i) + mo_two_e_integrals_jj_anti(i,j)
|
||||
enddo
|
||||
do jj=1,elec_alpha_num
|
||||
j = occ(jj,1)
|
||||
fock_diag_tmp(2,i) = fock_diag_tmp(2,i) + mo_two_e_integrals_jj(i,j)
|
||||
enddo
|
||||
enddo
|
||||
|
||||
fock_diag_tmp(1,mo_num+1) = E0
|
||||
fock_diag_tmp(2,mo_num+1) = E0
|
||||
|
||||
end
|
File diff suppressed because it is too large
Load Diff
|
@ -130,7 +130,7 @@ subroutine ZMQ_pt2(E, pt2_data, pt2_data_err, relative_error, N_in)
|
|||
PROVIDE psi_bilinear_matrix_columns_loc psi_det_alpha_unique psi_det_beta_unique
|
||||
PROVIDE psi_bilinear_matrix_rows psi_det_sorted_tc_order psi_bilinear_matrix_order
|
||||
PROVIDE psi_bilinear_matrix_transp_rows_loc psi_bilinear_matrix_transp_columns
|
||||
PROVIDE psi_bilinear_matrix_transp_order psi_selectors_coef_transp psi_det_sorted_tc
|
||||
PROVIDE psi_bilinear_matrix_transp_order psi_selectors_coef_transp_tc psi_det_sorted_tc
|
||||
PROVIDE psi_det_hii selection_weight pseudo_sym
|
||||
PROVIDE n_act_orb n_inact_orb n_core_orb n_virt_orb n_del_orb seniority_max
|
||||
PROVIDE excitation_beta_max excitation_alpha_max excitation_max
|
||||
|
|
|
@ -23,7 +23,7 @@ subroutine run_selection_slave(thread, iproc, energy)
|
|||
PROVIDE psi_bilinear_matrix_rows psi_det_sorted_tc_order psi_bilinear_matrix_order
|
||||
PROVIDE psi_bilinear_matrix_transp_rows_loc psi_bilinear_matrix_transp_columns
|
||||
PROVIDE psi_bilinear_matrix_transp_order N_int pt2_F pseudo_sym
|
||||
PROVIDE psi_selectors_coef_transp psi_det_sorted_tc weight_selection
|
||||
PROVIDE psi_selectors_coef_transp_tc psi_det_sorted_tc weight_selection
|
||||
|
||||
call pt2_alloc(pt2_data,N_states)
|
||||
|
||||
|
|
|
@ -19,7 +19,7 @@ subroutine select_connected(i_generator, E0, pt2_data, b, subset, csubset)
|
|||
|
||||
allocate(fock_diag_tmp(2,mo_num+1))
|
||||
|
||||
call build_fock_tmp(fock_diag_tmp, psi_det_generators(1,1,i_generator), N_int)
|
||||
call build_fock_tmp_tc(fock_diag_tmp, psi_det_generators(1,1,i_generator), N_int)
|
||||
|
||||
do k = 1, N_int
|
||||
hole_mask(k,1) = iand(generators_bitmask(k,1,s_hole), psi_det_generators(k,1,i_generator))
|
||||
|
@ -81,7 +81,7 @@ subroutine select_singles_and_doubles(i_generator, hole_mask,particle_mask, fock
|
|||
PROVIDE psi_bilinear_matrix_columns_loc psi_det_alpha_unique psi_det_beta_unique
|
||||
PROVIDE psi_bilinear_matrix_rows psi_det_sorted_tc_order psi_bilinear_matrix_order
|
||||
PROVIDE psi_bilinear_matrix_transp_rows_loc psi_bilinear_matrix_transp_columns
|
||||
PROVIDE psi_bilinear_matrix_transp_order psi_selectors_coef_transp
|
||||
PROVIDE psi_bilinear_matrix_transp_order psi_selectors_coef_transp_tc
|
||||
PROVIDE psi_selectors_rcoef_bi_orth_transp psi_selectors_lcoef_bi_orth_transp
|
||||
|
||||
PROVIDE banned_excitation
|
||||
|
@ -511,7 +511,7 @@ subroutine splash_pq(mask, sp, det, i_gen, N_sel, bannedOrb, banned, mat, intere
|
|||
integer(bit_kind) :: phasemask(N_int,2)
|
||||
|
||||
|
||||
PROVIDE psi_selectors_coef_transp psi_det_sorted_tc
|
||||
PROVIDE psi_selectors_coef_transp_tc psi_det_sorted_tc
|
||||
PROVIDE psi_selectors_rcoef_bi_orth_transp psi_selectors_lcoef_bi_orth_transp
|
||||
|
||||
|
||||
|
@ -564,29 +564,30 @@ subroutine splash_pq(mask, sp, det, i_gen, N_sel, bannedOrb, banned, mat, intere
|
|||
call bitstring_to_list_in_selection(mobMask(1,1), p(1,1), p(0,1), N_int)
|
||||
call bitstring_to_list_in_selection(mobMask(1,2), p(1,2), p(0,2), N_int)
|
||||
|
||||
call get_d3_h ( det(1,1,i), bannedOrb, banned, mat , mask, p, sp, psi_selectors_coef_transp (1, interesting(i)) )
|
||||
call get_d3_htc( det(1,1,i), bannedOrb, banned, mat_m, mat_p, mask, p, sp, psi_selectors_rcoef_bi_orth_transp(1, interesting(i)) &
|
||||
, psi_selectors_lcoef_bi_orth_transp(1, interesting(i)) )
|
||||
perMask(1,1) = iand(mask(1,1), not(det(1,1,i)))
|
||||
perMask(1,2) = iand(mask(1,2), not(det(1,2,i)))
|
||||
do j=2,N_int
|
||||
perMask(j,1) = iand(mask(j,1), not(det(j,1,i)))
|
||||
perMask(j,2) = iand(mask(j,2), not(det(j,2,i)))
|
||||
end do
|
||||
! call get_d3_h ( det(1,1,i), bannedOrb, banned, mat , mask, p, sp, psi_selectors_coef_transp_tc (1, interesting(i)) )
|
||||
! call get_d3_htc( det(1,1,i), bannedOrb, banned, mat_m, mat_p, mask, p, sp, psi_selectors_rcoef_bi_orth_transp(1, interesting(i)) &
|
||||
! , psi_selectors_lcoef_bi_orth_transp(1, interesting(i)) )
|
||||
|
||||
!perMask(1,1) = iand(mask(1,1), not(det(1,1,i)))
|
||||
!perMask(1,2) = iand(mask(1,2), not(det(1,2,i)))
|
||||
!do j=2,N_int
|
||||
! perMask(j,1) = iand(mask(j,1), not(det(j,1,i)))
|
||||
! perMask(j,2) = iand(mask(j,2), not(det(j,2,i)))
|
||||
!end do
|
||||
!call bitstring_to_list_in_selection(perMask(1,1), h(1,1), h(0,1), N_int)
|
||||
!call bitstring_to_list_in_selection(perMask(1,2), h(1,2), h(0,2), N_int)
|
||||
!call get_mask_phase(psi_det_sorted_tc(1,1,interesting(i)), phasemask,N_int)
|
||||
!if(nt == 4) then
|
||||
! call get_d2 (det(1,1,i), phasemask, bannedOrb, banned, mat, mask, h, p, sp, psi_selectors_coef_transp(1, interesting(i)))
|
||||
! call get_pm2(det(1,1,i), phasemask, bannedOrb, banned, mat_p, mat_m, mask, h, p, sp, psi_selectors_coef_transp(1, interesting(i)))
|
||||
!elseif(nt == 3) then
|
||||
! call get_d1 (det(1,1,i), phasemask, bannedOrb, banned, mat , mask, h, p, sp, psi_selectors_coef_transp(1, interesting(i)))
|
||||
! call get_pm1(det(1,1,i), phasemask, bannedOrb, banned, mat_p, mat_m, mask, h, p, sp, psi_selectors_coef_transp(1, interesting(i)))
|
||||
!else
|
||||
! call get_d0 (det(1,1,i), phasemask, bannedOrb, banned, mat , mask, h, p, sp, psi_selectors_coef_transp(1, interesting(i)))
|
||||
! call get_pm0(det(1,1,i), phasemask, bannedOrb, banned, mat_p, mat_m, mask, h, p, sp, psi_selectors_coef_transp(1, interesting(i)))
|
||||
!endif
|
||||
call bitstring_to_list_in_selection(perMask(1,1), h(1,1), h(0,1), N_int)
|
||||
call bitstring_to_list_in_selection(perMask(1,2), h(1,2), h(0,2), N_int)
|
||||
|
||||
call get_mask_phase(psi_det_sorted_tc(1,1,interesting(i)), phasemask,N_int)
|
||||
if(nt == 4) then
|
||||
call get_d2 (det(1,1,i), phasemask, bannedOrb, banned, mat_p, mat_m, mask, h, p, sp, psi_selectors_coef_transp_tc(1, 1, interesting(i)))
|
||||
! call get_pm2(det(1,1,i), phasemask, bannedOrb, banned, mat_p, mat_m, mask, h, p, sp, psi_selectors_coef_transp_tc(1, interesting(i)))
|
||||
elseif(nt == 3) then
|
||||
call get_d1 (det(1,1,i), phasemask, bannedOrb, banned, mat_p, mat_m, mask, h, p, sp, psi_selectors_coef_transp_tc(1, 1, interesting(i)))
|
||||
! call get_pm1(det(1,1,i), phasemask, bannedOrb, banned, mat_p, mat_m, mask, h, p, sp, psi_selectors_coef_transp_tc(1, interesting(i)))
|
||||
else
|
||||
call get_d0 (det(1,1,i), phasemask, bannedOrb, banned, mat_p, mat_m, mask, h, p, sp, psi_selectors_coef_transp_tc(1, 1, interesting(i)))
|
||||
! call get_pm0(det(1,1,i), phasemask, bannedOrb, banned, mat_p, mat_m, mask, h, p, sp, psi_selectors_coef_transp_tc(1, interesting(i)))
|
||||
endif
|
||||
elseif(nt == 4) then
|
||||
call bitstring_to_list_in_selection(mobMask(1,1), p(1,1), p(0,1), N_int)
|
||||
call bitstring_to_list_in_selection(mobMask(1,2), p(1,2), p(0,2), N_int)
|
||||
|
@ -775,17 +776,63 @@ subroutine fill_buffer_double(i_generator, sp, h1, h2, bannedOrb, banned, fock_d
|
|||
|
||||
! call get_excitation_degree( HF_bitmask, det, degree, N_int)
|
||||
|
||||
! psi_h_alpha = mat_m(istate, p1, p2)
|
||||
! alpha_h_psi = mat_p(istate, p1, p2)
|
||||
double precision :: alpha_h_psi_tmp, psi_h_alpha_tmp
|
||||
psi_h_alpha_tmp = mat_m(istate, p1, p2)
|
||||
alpha_h_psi_tmp = mat_p(istate, p1, p2)
|
||||
!
|
||||
psi_h_alpha = 0.d0
|
||||
alpha_h_psi = 0.d0
|
||||
do iii = 1, N_det
|
||||
call htilde_mu_mat_bi_ortho_tot(psi_det(1,1,iii), det, N_int, i_h_alpha)
|
||||
call htilde_mu_mat_bi_ortho_tot(det, psi_det(1,1,iii), N_int, alpha_h_i)
|
||||
psi_h_alpha += i_h_alpha * leigvec_tc_bi_orth(iii,1)
|
||||
alpha_h_psi += alpha_h_i * reigvec_tc_bi_orth(iii,1)
|
||||
! psi_h_alpha += i_h_alpha * leigvec_tc_bi_orth(iii,1)
|
||||
! alpha_h_psi += alpha_h_i * reigvec_tc_bi_orth(iii,1)
|
||||
psi_h_alpha += i_h_alpha * 1.d0
|
||||
alpha_h_psi += alpha_h_i * 1.d0
|
||||
enddo
|
||||
! print*,'---',p1,p2
|
||||
! call debug_det(det,N_int)
|
||||
! print*,psi_h_alpha *alpha_h_psi, psi_h_alpha, alpha_h_psi
|
||||
! print*,psi_h_alpha_tmp*alpha_h_psi_tmp,psi_h_alpha_tmp,alpha_h_psi_tmp
|
||||
! if(dabs(psi_h_alpha - psi_h_alpha_tmp).gt.1.d-10 .or. dabs(alpha_h_psi - alpha_h_psi_tmp).gt.1.d-10)then
|
||||
! if(dabs(psi_h_alpha_tmp*alpha_h_psi_tmp).gt.1.d+10)then
|
||||
if(dabs(psi_h_alpha*alpha_h_psi - psi_h_alpha_tmp*alpha_h_psi_tmp).gt.1.d-10)then
|
||||
! print*,'---'
|
||||
! print*,psi_h_alpha *alpha_h_psi, psi_h_alpha, alpha_h_psi
|
||||
! print*,psi_h_alpha_tmp*alpha_h_psi_tmp,psi_h_alpha_tmp,alpha_h_psi_tmp
|
||||
call debug_det(det,N_int)
|
||||
print*,dabs(psi_h_alpha*alpha_h_psi - psi_h_alpha_tmp*alpha_h_psi_tmp),psi_h_alpha *alpha_h_psi,psi_h_alpha_tmp*alpha_h_psi_tmp
|
||||
print*,'-- Good '
|
||||
print*, psi_h_alpha, alpha_h_psi
|
||||
print*,'-- bad '
|
||||
print*,psi_h_alpha_tmp,alpha_h_psi_tmp
|
||||
print*,'-- details good'
|
||||
double precision :: accu_1, accu_2
|
||||
accu_1 = 0.d0
|
||||
accu_2 = 0.d0
|
||||
do iii = 1, N_det
|
||||
call get_excitation_degree( psi_det(1,1,iii), det, degree, N_int)
|
||||
call htilde_mu_mat_bi_ortho_tot(psi_det(1,1,iii), det, N_int, i_h_alpha)
|
||||
call htilde_mu_mat_bi_ortho_tot(det, psi_det(1,1,iii), N_int, alpha_h_i)
|
||||
print*,iii,degree,i_h_alpha,alpha_h_i
|
||||
accu_1 += i_h_alpha
|
||||
accu_2 += alpha_h_i
|
||||
print*,accu_1,accu_2
|
||||
|
||||
enddo
|
||||
! if(dabs(psi_h_alpha*alpha_h_psi).gt.1.d-10)then
|
||||
! print*,p1,p2
|
||||
! print*,det(1,1), det(1,2)
|
||||
! call debug_det(det,N_int)
|
||||
! print*,psi_h_alpha *alpha_h_psi, psi_h_alpha, alpha_h_psi
|
||||
! print*,psi_h_alpha_tmp*alpha_h_psi_tmp,psi_h_alpha_tmp,alpha_h_psi_tmp
|
||||
! print*, dabs(psi_h_alpha*alpha_h_psi - psi_h_alpha_tmp*alpha_h_psi_tmp),&
|
||||
! psi_h_alpha *alpha_h_psi,psi_h_alpha_tmp*alpha_h_psi_tmp
|
||||
stop
|
||||
endif
|
||||
! endif
|
||||
! stop
|
||||
! endif
|
||||
|
||||
!if(alpha_h_psi*psi_h_alpha/delta_E.gt.1.d-10)then
|
||||
! print*, 'E0,Hii,E_shift'
|
||||
|
|
|
@ -44,9 +44,10 @@ subroutine run_stochastic_cipsi
|
|||
pt2_data % overlap= 0.d0
|
||||
pt2_data % variance = huge(1.e0)
|
||||
|
||||
if (s2_eig) then
|
||||
call make_s2_eigenfunction
|
||||
endif
|
||||
!!!! WARNING !!!! SEEMS TO BE PROBLEM WTH make_s2_eigenfunction !!!! THE DETERMINANTS CAN APPEAR TWICE IN THE WFT DURING SELECTION
|
||||
! if (s2_eig) then
|
||||
! call make_s2_eigenfunction
|
||||
! endif
|
||||
print_pt2 = .False.
|
||||
call diagonalize_CI_tc_bi_ortho(ndet, E_tc,norm,pt2_data,print_pt2)
|
||||
! call routine_save_right
|
||||
|
@ -89,6 +90,7 @@ subroutine run_stochastic_cipsi
|
|||
call pt2_alloc(pt2_data, N_states)
|
||||
call pt2_alloc(pt2_data_err, N_states)
|
||||
call ZMQ_pt2(E_denom, pt2_data, pt2_data_err, relative_error,to_select) ! Stochastic PT2 and selection
|
||||
stop
|
||||
|
||||
N_iter += 1
|
||||
|
||||
|
|
|
@ -47,6 +47,36 @@ program cisd
|
|||
PROVIDE N_states
|
||||
read_wf = .False.
|
||||
SOFT_TOUCH read_wf
|
||||
!
|
||||
! integer :: i,k
|
||||
!
|
||||
! if(pseudo_sym)then
|
||||
! call H_apply_cisd_sym
|
||||
! else
|
||||
! call H_apply_cisd
|
||||
! endif
|
||||
! double precision :: r1, r2
|
||||
! double precision, allocatable :: U_csf(:,:)
|
||||
!
|
||||
! allocate(U_csf(N_csf,N_states))
|
||||
! U_csf = 0.d0
|
||||
! do k=1,N_states
|
||||
! do i=1,N_csf
|
||||
! call random_number(r1)
|
||||
! call random_number(r2)
|
||||
! r1 = dsqrt(-2.d0*dlog(r1))
|
||||
! r2 = dacos(-1.d0)*2.d0*r2
|
||||
! U_csf(i,k) = r1*dcos(r2)
|
||||
! enddo
|
||||
! U_csf(k,k) = U_csf(k,k) +10000.d0
|
||||
! enddo
|
||||
! do k=1,N_states
|
||||
! call normalize(U_csf(1,k),N_csf)
|
||||
! enddo
|
||||
! call convertWFfromCSFtoDET(N_states,U_csf(1,1),psi_coef(1,1))
|
||||
! deallocate(U_csf)
|
||||
! SOFT_TOUCH psi_coef
|
||||
|
||||
call run
|
||||
end
|
||||
|
||||
|
@ -69,7 +99,9 @@ subroutine run
|
|||
do i = 1,N_states
|
||||
k = maxloc(dabs(psi_coef_sorted(1:N_det,i)),dim=1)
|
||||
delta_E = CI_electronic_energy(i) - diag_h_mat_elem(psi_det_sorted(1,1,k),N_int)
|
||||
cisdq(i) = CI_energy(i) + delta_E * (1.d0 - psi_coef_sorted(k,i)**2)
|
||||
if (elec_alpha_num + elec_beta_num >= 4) then
|
||||
cisdq(i) = CI_energy(i) + delta_E * (1.d0 - psi_coef_sorted(k,i)**2)
|
||||
endif
|
||||
enddo
|
||||
print *, 'N_det = ', N_det
|
||||
print*,''
|
||||
|
@ -78,26 +110,43 @@ subroutine run
|
|||
do i = 1,N_states
|
||||
print *, i, CI_energy(i)
|
||||
enddo
|
||||
print*,''
|
||||
print*,'******************************'
|
||||
print *, 'CISD+Q Energies'
|
||||
do i = 1,N_states
|
||||
print *, i, cisdq(i)
|
||||
enddo
|
||||
if (elec_alpha_num + elec_beta_num >= 4) then
|
||||
print*,''
|
||||
print*,'******************************'
|
||||
print *, 'CISD+Q Energies'
|
||||
do i = 1,N_states
|
||||
print *, i, cisdq(i)
|
||||
enddo
|
||||
endif
|
||||
if (N_states > 1) then
|
||||
print*,''
|
||||
print*,'******************************'
|
||||
print*,'Excitation energies (au) (CISD+Q)'
|
||||
do i = 2, N_states
|
||||
print*, i ,CI_energy(i) - CI_energy(1), cisdq(i) - cisdq(1)
|
||||
enddo
|
||||
print*,''
|
||||
print*,'******************************'
|
||||
print*,'Excitation energies (eV) (CISD+Q)'
|
||||
do i = 2, N_states
|
||||
print*, i ,(CI_energy(i) - CI_energy(1))/0.0367502d0, &
|
||||
(cisdq(i) - cisdq(1)) / 0.0367502d0
|
||||
enddo
|
||||
if (elec_alpha_num + elec_beta_num >= 4) then
|
||||
print*,''
|
||||
print*,'******************************'
|
||||
print*,'Excitation energies (au) (CISD+Q)'
|
||||
do i = 2, N_states
|
||||
print*, i ,CI_energy(i) - CI_energy(1), cisdq(i) - cisdq(1)
|
||||
enddo
|
||||
print*,''
|
||||
print*,'******************************'
|
||||
print*,'Excitation energies (eV) (CISD+Q)'
|
||||
do i = 2, N_states
|
||||
print*, i ,(CI_energy(i) - CI_energy(1)) * ha_to_ev, &
|
||||
(cisdq(i) - cisdq(1)) * ha_to_ev
|
||||
enddo
|
||||
else
|
||||
print*,''
|
||||
print*,'******************************'
|
||||
print*,'Excitation energies (au) (CISD)'
|
||||
do i = 2, N_states
|
||||
print*, i ,CI_energy(i) - CI_energy(1)
|
||||
enddo
|
||||
print*,''
|
||||
print*,'******************************'
|
||||
print*,'Excitation energies (eV) (CISD)'
|
||||
do i = 2, N_states
|
||||
print*, i ,(CI_energy(i) - CI_energy(1)) * ha_to_ev
|
||||
enddo
|
||||
endif
|
||||
endif
|
||||
|
||||
end
|
||||
|
|
|
@ -1155,7 +1155,7 @@ END_PROVIDER
|
|||
!end do
|
||||
|
||||
if(.NOT. pqExistsQ) then
|
||||
tableUniqueAlphas(p,q) = .TRUE.
|
||||
tableUniqueAlphas(pp,qq) = .TRUE.
|
||||
!print *,p,q
|
||||
!call debug_spindet(Jsomo,1)
|
||||
!call debug_spindet(Jdomo,1)
|
||||
|
|
|
@ -264,29 +264,20 @@ subroutine davidson_diag_csf_hjj(dets_in,u_in,H_jj,energies,dim_in,sze,sze_csf,N
|
|||
! ===================
|
||||
|
||||
converged = .False.
|
||||
|
||||
call convertWFfromDETtoCSF(N_st_diag,u_in(1,1),U_csf(1,1))
|
||||
do k=N_st+1,N_st_diag
|
||||
do i=1,sze
|
||||
do i=1,sze_csf
|
||||
call random_number(r1)
|
||||
call random_number(r2)
|
||||
r1 = dsqrt(-2.d0*dlog(r1))
|
||||
r2 = dtwo_pi*r2
|
||||
u_in(i,k) = r1*dcos(r2) * u_in(i,k-N_st)
|
||||
U_csf(i,k) = r1*dcos(r2) * u_csf(i,k-N_st)
|
||||
enddo
|
||||
u_in(k,k) = u_in(k,k) + 10.d0
|
||||
U_csf(k,k) = u_csf(k,k) + 10.d0
|
||||
enddo
|
||||
do k=1,N_st_diag
|
||||
call normalize(u_in(1,k),sze)
|
||||
call normalize(U_csf(1,k),sze_csf)
|
||||
enddo
|
||||
|
||||
do k=1,N_st_diag
|
||||
do i=1,sze
|
||||
U(i,k) = u_in(i,k)
|
||||
enddo
|
||||
enddo
|
||||
|
||||
! Make random verctors eigenstates of S2
|
||||
call convertWFfromDETtoCSF(N_st_diag,U(1,1),U_csf(1,1))
|
||||
call convertWFfromCSFtoDET(N_st_diag,U_csf(1,1),U(1,1))
|
||||
|
||||
do while (.not.converged)
|
||||
|
|
|
@ -77,14 +77,18 @@ BEGIN_PROVIDER [ integer, psi_det_size ]
|
|||
END_DOC
|
||||
PROVIDE ezfio_filename
|
||||
logical :: exists
|
||||
if (mpi_master) then
|
||||
call ezfio_has_determinants_n_det(exists)
|
||||
if (exists) then
|
||||
call ezfio_get_determinants_n_det(psi_det_size)
|
||||
else
|
||||
psi_det_size = 1
|
||||
psi_det_size = N_states
|
||||
PROVIDE mpi_master
|
||||
if (read_wf) then
|
||||
if (mpi_master) then
|
||||
call ezfio_has_determinants_n_det(exists)
|
||||
if (exists) then
|
||||
call ezfio_get_determinants_n_det(psi_det_size)
|
||||
else
|
||||
psi_det_size = N_states
|
||||
endif
|
||||
call write_int(6,psi_det_size,'Dimension of the psi arrays')
|
||||
endif
|
||||
call write_int(6,psi_det_size,'Dimension of the psi arrays')
|
||||
endif
|
||||
IRP_IF MPI_DEBUG
|
||||
print *, irp_here, mpi_rank
|
||||
|
|
|
@ -96,7 +96,6 @@ subroutine filter_not_connected(key1,key2,Nint,sze,idx)
|
|||
idx(0) = l-1
|
||||
end
|
||||
|
||||
|
||||
subroutine filter_connected(key1,key2,Nint,sze,idx)
|
||||
use bitmasks
|
||||
implicit none
|
||||
|
|
|
@ -28,7 +28,7 @@ BEGIN_PROVIDER [double precision, fock_operator_closed_shell_ref_bitmask, (mo_nu
|
|||
integer :: occ_virt(N_int*bit_kind_size,2)
|
||||
integer(bit_kind) :: key_test(N_int)
|
||||
integer(bit_kind) :: key_virt(N_int,2)
|
||||
|
||||
fock_operator_closed_shell_ref_bitmask = 0.d0
|
||||
call bitstring_to_list_ab(ref_closed_shell_bitmask, occ, n_occ_ab, N_int)
|
||||
do i = 1, N_int
|
||||
key_virt(i,1) = full_ijkl_bitmask(i)
|
||||
|
|
|
@ -3,8 +3,27 @@ subroutine get_excitation_degree(key1,key2,degree,Nint)
|
|||
include 'utils/constants.include.F'
|
||||
implicit none
|
||||
BEGIN_DOC
|
||||
! Returns the excitation degree between two determinants.
|
||||
! This function calculates the excitation degree between two
|
||||
! determinants, which is half the number of bits that are different between the two
|
||||
! determinants. The function takes four arguments:
|
||||
!
|
||||
! * key1: An integer array of length Nint*2, representing the first determinant.
|
||||
!
|
||||
! * key2: An integer array of length Nint*2, representing the second determinant.
|
||||
!
|
||||
! * degree: An integer, passed by reference, that will store the calculated excitation degree.
|
||||
!
|
||||
! * Nint: An integer representing the number of integers in each of the key1 and key2 arrays.
|
||||
!
|
||||
! It starts a select case block that depends on the value of Nint.
|
||||
! In each case, the function first calculates the bitwise XOR of each
|
||||
! corresponding pair of elements in key1 and key2, storing the results in the
|
||||
! xorvec array. It then calculates the number of bits set (using the popcnt
|
||||
! function) for each element in xorvec, and sums these counts up. This sum is
|
||||
! stored in the degree variable.
|
||||
! Finally, the degree variable is right-shifted by 1 bit to divide the result by 2.
|
||||
END_DOC
|
||||
|
||||
integer, intent(in) :: Nint
|
||||
integer(bit_kind), intent(in) :: key1(Nint*2)
|
||||
integer(bit_kind), intent(in) :: key2(Nint*2)
|
||||
|
@ -107,6 +126,8 @@ subroutine get_excitation(det1,det2,exc,degree,phase,Nint)
|
|||
return
|
||||
|
||||
case(0)
|
||||
! Avoid uninitialized phase
|
||||
phase = 1d0
|
||||
return
|
||||
|
||||
end select
|
||||
|
@ -1790,12 +1811,12 @@ double precision function diag_H_mat_elem(det_in,Nint)
|
|||
integer :: tmp(2)
|
||||
!DIR$ FORCEINLINE
|
||||
call bitstring_to_list_ab(particle, occ_particle, tmp, Nint)
|
||||
ASSERT (tmp(1) == nexc(1))
|
||||
ASSERT (tmp(2) == nexc(2))
|
||||
ASSERT (tmp(1) == nexc(1)) ! Number of particles alpha
|
||||
ASSERT (tmp(2) == nexc(2)) ! Number of particle beta
|
||||
!DIR$ FORCEINLINE
|
||||
call bitstring_to_list_ab(hole, occ_hole, tmp, Nint)
|
||||
ASSERT (tmp(1) == nexc(1))
|
||||
ASSERT (tmp(2) == nexc(2))
|
||||
ASSERT (tmp(1) == nexc(1)) ! Number of holes alpha
|
||||
ASSERT (tmp(2) == nexc(2)) ! Number of holes beta
|
||||
|
||||
det_tmp = ref_bitmask
|
||||
do ispin=1,2
|
||||
|
|
164
src/determinants/sparse_mat.irp.f
Normal file
164
src/determinants/sparse_mat.irp.f
Normal file
|
@ -0,0 +1,164 @@
|
|||
use bitmasks
|
||||
|
||||
subroutine filter_connected_array(key1,key2,ld,Nint,sze,idx)
|
||||
use bitmasks
|
||||
implicit none
|
||||
BEGIN_DOC
|
||||
! Filters out the determinants that are not connected by H
|
||||
!
|
||||
! returns the array idx which contains the index of the
|
||||
!
|
||||
! determinants in the array key1 that interact
|
||||
!
|
||||
! via the H operator with key2.
|
||||
!
|
||||
! idx(0) is the number of determinants that interact with key1
|
||||
END_DOC
|
||||
integer, intent(in) :: Nint, ld,sze
|
||||
integer(bit_kind), intent(in) :: key1(Nint,2,ld)
|
||||
integer(bit_kind), intent(in) :: key2(Nint,2)
|
||||
integer, intent(out) :: idx(0:sze)
|
||||
|
||||
integer :: i,j,l
|
||||
integer :: degree_x2
|
||||
|
||||
ASSERT (Nint > 0)
|
||||
ASSERT (sze >= 0)
|
||||
|
||||
l=1
|
||||
|
||||
if (Nint==1) then
|
||||
|
||||
!DIR$ LOOP COUNT (1000)
|
||||
do i=1,sze
|
||||
degree_x2 = popcnt( xor( key1(1,1,i), key2(1,1))) &
|
||||
+ popcnt( xor( key1(1,2,i), key2(1,2)))
|
||||
! print*,degree_x2
|
||||
if (degree_x2 > 4) then
|
||||
cycle
|
||||
else
|
||||
idx(l) = i
|
||||
l = l+1
|
||||
endif
|
||||
enddo
|
||||
|
||||
else if (Nint==2) then
|
||||
|
||||
!DIR$ LOOP COUNT (1000)
|
||||
do i=1,sze
|
||||
degree_x2 = popcnt(xor( key1(1,1,i), key2(1,1))) + &
|
||||
popcnt(xor( key1(2,1,i), key2(2,1))) + &
|
||||
popcnt(xor( key1(1,2,i), key2(1,2))) + &
|
||||
popcnt(xor( key1(2,2,i), key2(2,2)))
|
||||
if (degree_x2 > 4) then
|
||||
cycle
|
||||
else
|
||||
idx(l) = i
|
||||
l = l+1
|
||||
endif
|
||||
enddo
|
||||
|
||||
else if (Nint==3) then
|
||||
|
||||
!DIR$ LOOP COUNT (1000)
|
||||
do i=1,sze
|
||||
degree_x2 = popcnt(xor( key1(1,1,i), key2(1,1))) + &
|
||||
popcnt(xor( key1(1,2,i), key2(1,2))) + &
|
||||
popcnt(xor( key1(2,1,i), key2(2,1))) + &
|
||||
popcnt(xor( key1(2,2,i), key2(2,2))) + &
|
||||
popcnt(xor( key1(3,1,i), key2(3,1))) + &
|
||||
popcnt(xor( key1(3,2,i), key2(3,2)))
|
||||
if (degree_x2 > 4) then
|
||||
cycle
|
||||
else
|
||||
idx(l) = i
|
||||
l = l+1
|
||||
endif
|
||||
enddo
|
||||
|
||||
else
|
||||
|
||||
!DIR$ LOOP COUNT (1000)
|
||||
do i=1,sze
|
||||
degree_x2 = 0
|
||||
!DIR$ LOOP COUNT MIN(4)
|
||||
do j=1,Nint
|
||||
degree_x2 = degree_x2+ popcnt(xor( key1(j,1,i), key2(j,1))) +&
|
||||
popcnt(xor( key1(j,2,i), key2(j,2)))
|
||||
if (degree_x2 > 4) then
|
||||
exit
|
||||
endif
|
||||
enddo
|
||||
if (degree_x2 <= 5) then
|
||||
idx(l) = i
|
||||
l = l+1
|
||||
endif
|
||||
enddo
|
||||
|
||||
endif
|
||||
idx(0) = l-1
|
||||
! print*,'idx(0) = ',idx(0)
|
||||
end
|
||||
|
||||
|
||||
BEGIN_PROVIDER [ integer, n_sparse_mat]
|
||||
&BEGIN_PROVIDER [ integer, n_connected_per_det, (N_det)]
|
||||
&BEGIN_PROVIDER [ integer, n_max_connected_per_det]
|
||||
implicit none
|
||||
BEGIN_DOC
|
||||
! n_sparse_mat = total number of connections in the CI matrix
|
||||
!
|
||||
! n_connected_per_det(i) = number of connected determinants to the determinant psi_det(1,1,i)
|
||||
!
|
||||
! n_max_connected_per_det = maximum number of connected determinants
|
||||
END_DOC
|
||||
integer, allocatable :: idx(:)
|
||||
allocate(idx(0:N_det))
|
||||
integer :: i
|
||||
n_sparse_mat = 0
|
||||
do i = 1, N_det
|
||||
call filter_connected_array(psi_det_sorted,psi_det_sorted(1,1,i),psi_det_size,N_int,N_det,idx)
|
||||
n_connected_per_det(i) = idx(0)
|
||||
n_sparse_mat += idx(0)
|
||||
enddo
|
||||
n_max_connected_per_det = maxval(n_connected_per_det)
|
||||
END_PROVIDER
|
||||
|
||||
BEGIN_PROVIDER [ integer(bit_kind), connected_det_per_det, (N_int,2,n_max_connected_per_det,N_det)]
|
||||
&BEGIN_PROVIDER [ integer(bit_kind), list_connected_det_per_det, (n_max_connected_per_det,N_det)]
|
||||
implicit none
|
||||
BEGIN_DOC
|
||||
! connected_det_per_det(:,:,j,i) = jth connected determinant to the determinant psi_det(:,:,i)
|
||||
!
|
||||
! list_connected_det_per_det(j,i) = index of jth determinant in psi_det which is connected to psi_det(:,:,i)
|
||||
END_DOC
|
||||
integer, allocatable :: idx(:)
|
||||
allocate(idx(0:N_det))
|
||||
integer :: i,j
|
||||
do i = 1, N_det
|
||||
call filter_connected_array(psi_det_sorted,psi_det_sorted(1,1,i),psi_det_size,N_int,N_det,idx)
|
||||
do j = 1, idx(0)
|
||||
connected_det_per_det(1:N_int,1:2,j,i) = psi_det_sorted(1:N_int,1:2,idx(j))
|
||||
list_connected_det_per_det(j,i) = idx(j)
|
||||
enddo
|
||||
enddo
|
||||
END_PROVIDER
|
||||
|
||||
BEGIN_PROVIDER [ double precision, sparse_h_mat, (n_max_connected_per_det, N_det)]
|
||||
implicit none
|
||||
BEGIN_DOC
|
||||
! sparse matrix format
|
||||
!
|
||||
! sparse_h_mat(j,i) = matrix element between the jth connected determinant and psi_det(:,:,i)
|
||||
END_DOC
|
||||
integer :: i,j
|
||||
double precision :: hij
|
||||
do i = 1, N_det
|
||||
do j = 1, n_connected_per_det(i)
|
||||
call i_H_j(psi_det(1,1,i),connected_det_per_det(1,1,j,i),N_int,hij)
|
||||
sparse_h_mat(j,i) = hij
|
||||
enddo
|
||||
enddo
|
||||
|
||||
END_PROVIDER
|
||||
|
|
@ -40,6 +40,47 @@
|
|||
END_PROVIDER
|
||||
|
||||
|
||||
BEGIN_PROVIDER[double precision, aos_in_r_array_extra, (ao_num,n_points_extra_final_grid)]
|
||||
implicit none
|
||||
BEGIN_DOC
|
||||
! aos_in_r_array_extra(i,j) = value of the ith ao on the jth grid point
|
||||
END_DOC
|
||||
integer :: i,j
|
||||
double precision :: aos_array(ao_num), r(3)
|
||||
!$OMP PARALLEL DO &
|
||||
!$OMP DEFAULT (NONE) &
|
||||
!$OMP PRIVATE (i,r,aos_array,j) &
|
||||
!$OMP SHARED(aos_in_r_array_extra,n_points_extra_final_grid,ao_num,final_grid_points_extra)
|
||||
do i = 1, n_points_extra_final_grid
|
||||
r(1) = final_grid_points_extra(1,i)
|
||||
r(2) = final_grid_points_extra(2,i)
|
||||
r(3) = final_grid_points_extra(3,i)
|
||||
call give_all_aos_at_r(r,aos_array)
|
||||
do j = 1, ao_num
|
||||
aos_in_r_array_extra(j,i) = aos_array(j)
|
||||
enddo
|
||||
enddo
|
||||
!$OMP END PARALLEL DO
|
||||
|
||||
END_PROVIDER
|
||||
|
||||
|
||||
BEGIN_PROVIDER[double precision, aos_in_r_array_extra_transp, (n_points_extra_final_grid,ao_num)]
|
||||
implicit none
|
||||
BEGIN_DOC
|
||||
! aos_in_r_array_extra_transp(i,j) = value of the jth ao on the ith grid point
|
||||
END_DOC
|
||||
integer :: i,j
|
||||
double precision :: aos_array(ao_num), r(3)
|
||||
do i = 1, n_points_extra_final_grid
|
||||
do j = 1, ao_num
|
||||
aos_in_r_array_extra_transp(i,j) = aos_in_r_array_extra(j,i)
|
||||
enddo
|
||||
enddo
|
||||
|
||||
END_PROVIDER
|
||||
|
||||
|
||||
|
||||
BEGIN_PROVIDER[double precision, aos_grad_in_r_array, (ao_num,n_points_final_grid,3)]
|
||||
implicit none
|
||||
|
|
155
src/dft_utils_in_r/ao_prod_mlti_pl.irp.f
Normal file
155
src/dft_utils_in_r/ao_prod_mlti_pl.irp.f
Normal file
|
@ -0,0 +1,155 @@
|
|||
|
||||
BEGIN_PROVIDER [ double precision, ao_abs_int_grid, (ao_num)]
|
||||
implicit none
|
||||
BEGIN_DOC
|
||||
! ao_abs_int_grid(i) = \int dr |phi_i(r) |
|
||||
END_DOC
|
||||
integer :: i,j,ipoint
|
||||
double precision :: contrib, weight,r(3)
|
||||
ao_abs_int_grid = 0.D0
|
||||
do ipoint = 1,n_points_final_grid
|
||||
r(:) = final_grid_points(:,ipoint)
|
||||
weight = final_weight_at_r_vector(ipoint)
|
||||
do i = 1, ao_num
|
||||
contrib = dabs(aos_in_r_array(i,ipoint)) * weight
|
||||
ao_abs_int_grid(i) += contrib
|
||||
enddo
|
||||
enddo
|
||||
|
||||
END_PROVIDER
|
||||
|
||||
BEGIN_PROVIDER [ double precision, ao_overlap_abs_grid, (ao_num, ao_num)]
|
||||
implicit none
|
||||
BEGIN_DOC
|
||||
! ao_overlap_abs_grid(j,i) = \int dr |phi_i(r) phi_j(r)|
|
||||
END_DOC
|
||||
integer :: i,j,ipoint
|
||||
double precision :: contrib, weight,r(3)
|
||||
ao_overlap_abs_grid = 0.D0
|
||||
do ipoint = 1,n_points_final_grid
|
||||
r(:) = final_grid_points(:,ipoint)
|
||||
weight = final_weight_at_r_vector(ipoint)
|
||||
do i = 1, ao_num
|
||||
do j = 1, ao_num
|
||||
contrib = dabs(aos_in_r_array(j,ipoint) * aos_in_r_array(i,ipoint)) * weight
|
||||
ao_overlap_abs_grid(j,i) += contrib
|
||||
enddo
|
||||
enddo
|
||||
enddo
|
||||
|
||||
END_PROVIDER
|
||||
|
||||
BEGIN_PROVIDER [ double precision, ao_prod_center, (3, ao_num, ao_num)]
|
||||
implicit none
|
||||
BEGIN_DOC
|
||||
! ao_prod_center(1:3,j,i) = \int dr |phi_i(r) phi_j(r)| x/y/z / \int |phi_i(r) phi_j(r)|
|
||||
!
|
||||
! if \int |phi_i(r) phi_j(r)| < 1.d-10 then ao_prod_center = 10000.
|
||||
END_DOC
|
||||
integer :: i,j,m,ipoint
|
||||
double precision :: contrib, weight,r(3)
|
||||
ao_prod_center = 0.D0
|
||||
do ipoint = 1,n_points_final_grid
|
||||
r(:) = final_grid_points(:,ipoint)
|
||||
weight = final_weight_at_r_vector(ipoint)
|
||||
do i = 1, ao_num
|
||||
do j = 1, ao_num
|
||||
contrib = dabs(aos_in_r_array(j,ipoint) * aos_in_r_array(i,ipoint)) * weight
|
||||
do m = 1, 3
|
||||
ao_prod_center(m,j,i) += contrib * r(m)
|
||||
enddo
|
||||
enddo
|
||||
enddo
|
||||
enddo
|
||||
do i = 1, ao_num
|
||||
do j = 1, ao_num
|
||||
if(dabs(ao_overlap_abs_grid(j,i)).gt.1.d-10)then
|
||||
do m = 1, 3
|
||||
ao_prod_center(m,j,i) *= 1.d0/ao_overlap_abs_grid(j,i)
|
||||
enddo
|
||||
else
|
||||
do m = 1, 3
|
||||
ao_prod_center(m,j,i) = 10000.d0
|
||||
enddo
|
||||
endif
|
||||
enddo
|
||||
enddo
|
||||
|
||||
END_PROVIDER
|
||||
|
||||
BEGIN_PROVIDER [ double precision, ao_prod_abs_r, (ao_num, ao_num)]
|
||||
implicit none
|
||||
BEGIN_DOC
|
||||
! ao_prod_abs_r(i,j) = \int |phi_i(r) phi_j(r)| dsqrt((x - <|i|x|j|>)^2 + (y - <|i|y|j|>)^2 +(z - <|i|z|j|>)^2) / \int |phi_i(r) phi_j(r)|
|
||||
!
|
||||
END_DOC
|
||||
ao_prod_abs_r = 0.d0
|
||||
integer :: i,j,m,ipoint
|
||||
double precision :: contrib, weight,r(3),contrib_x2
|
||||
do ipoint = 1,n_points_final_grid
|
||||
r(:) = final_grid_points(:,ipoint)
|
||||
weight = final_weight_at_r_vector(ipoint)
|
||||
do i = 1, ao_num
|
||||
do j = 1, ao_num
|
||||
contrib = dabs(aos_in_r_array(j,ipoint) * aos_in_r_array(i,ipoint)) * weight
|
||||
contrib_x2 = 0.d0
|
||||
do m = 1, 3
|
||||
contrib_x2 += (r(m) - ao_prod_center(m,j,i)) * (r(m) - ao_prod_center(m,j,i))
|
||||
enddo
|
||||
contrib_x2 = dsqrt(contrib_x2)
|
||||
ao_prod_abs_r(j,i) += contrib * contrib_x2
|
||||
enddo
|
||||
enddo
|
||||
enddo
|
||||
|
||||
|
||||
END_PROVIDER
|
||||
|
||||
BEGIN_PROVIDER [double precision, ao_prod_sigma, (ao_num, ao_num)]
|
||||
implicit none
|
||||
BEGIN_DOC
|
||||
! Gaussian exponent reproducing the product |chi_i(r) chi_j(r)|
|
||||
!
|
||||
! Therefore |chi_i(r) chi_j(r)| \approx e^{-ao_prod_sigma(j,i) (r - ao_prod_center(1:3,j,i))**2}
|
||||
END_DOC
|
||||
integer :: i,j
|
||||
double precision :: pi,alpha
|
||||
pi = dacos(-1.d0)
|
||||
do i = 1, ao_num
|
||||
do j = 1, ao_num
|
||||
! if(dabs(ao_overlap_abs_grid(j,i)).gt.1.d-5)then
|
||||
alpha = 1.d0/pi * (2.d0*ao_overlap_abs_grid(j,i)/ao_prod_abs_r(j,i))**2
|
||||
ao_prod_sigma(j,i) = alpha
|
||||
! endif
|
||||
enddo
|
||||
enddo
|
||||
END_PROVIDER
|
||||
|
||||
BEGIN_PROVIDER [ double precision, ao_prod_dist_grid, (ao_num, ao_num, n_points_final_grid)]
|
||||
implicit none
|
||||
BEGIN_DOC
|
||||
! ao_prod_dist_grid(j,i,ipoint) = distance between the center of |phi_i(r) phi_j(r)| and the grid point r(ipoint)
|
||||
END_DOC
|
||||
integer :: i,j,m,ipoint
|
||||
double precision :: distance,r(3)
|
||||
do ipoint = 1, n_points_final_grid
|
||||
r(:) = final_grid_points(:,ipoint)
|
||||
do i = 1, ao_num
|
||||
do j = 1, ao_num
|
||||
distance = 0.d0
|
||||
do m = 1, 3
|
||||
distance += (ao_prod_center(m,j,i) - r(m))*(ao_prod_center(m,j,i) - r(m))
|
||||
enddo
|
||||
distance = dsqrt(distance)
|
||||
ao_prod_dist_grid(j,i,ipoint) = distance
|
||||
enddo
|
||||
enddo
|
||||
enddo
|
||||
|
||||
END_PROVIDER
|
||||
|
||||
|
||||
!BEGIN_PROVIDER [ double precision, ao_abs_prod_j1b, (ao_num, ao_num)]
|
||||
! implicit none
|
||||
!
|
||||
!END_PROVIDER
|
|
@ -32,6 +32,7 @@ END_PROVIDER
|
|||
|
||||
BEGIN_PROVIDER [ integer(bit_kind), psi_selectors, (N_int,2,psi_selectors_size) ]
|
||||
&BEGIN_PROVIDER [ double precision, psi_selectors_coef, (psi_selectors_size,N_states) ]
|
||||
&BEGIN_PROVIDER [ double precision, psi_selectors_coef_tc, (psi_selectors_size,2,N_states) ]
|
||||
implicit none
|
||||
BEGIN_DOC
|
||||
! Determinants on which we apply <i|H|psi> for perturbation.
|
||||
|
@ -47,12 +48,17 @@ END_PROVIDER
|
|||
do k=1,N_states
|
||||
do i=1,N_det_selectors
|
||||
psi_selectors_coef(i,k) = psi_coef_sorted_tc_gen(i,k)
|
||||
! psi_selectors_coef_tc(i,1,k) = psi_r_coef_sorted_bi_ortho(i,k)
|
||||
! psi_selectors_coef_tc(i,2,k) = psi_l_coef_sorted_bi_ortho(i,k)
|
||||
psi_selectors_coef_tc(i,1,k) = 1.d0
|
||||
psi_selectors_coef_tc(i,2,k) = 1.d0
|
||||
enddo
|
||||
enddo
|
||||
|
||||
END_PROVIDER
|
||||
|
||||
BEGIN_PROVIDER [ double precision, psi_selectors_coef_transp, (N_states,psi_selectors_size) ]
|
||||
BEGIN_PROVIDER [ double precision, psi_selectors_coef_transp, (N_states,psi_selectors_size) ]
|
||||
&BEGIN_PROVIDER [ double precision, psi_selectors_coef_transp_tc, (N_states,2,psi_selectors_size) ]
|
||||
implicit none
|
||||
BEGIN_DOC
|
||||
! Transposed psi_selectors
|
||||
|
@ -62,6 +68,8 @@ BEGIN_PROVIDER [ double precision, psi_selectors_coef_transp, (N_states,psi_sele
|
|||
do i=1,N_det_selectors
|
||||
do k=1,N_states
|
||||
psi_selectors_coef_transp(k,i) = psi_selectors_coef(i,k)
|
||||
psi_selectors_coef_transp_tc(k,1,i) = psi_selectors_coef_tc(i,1,k)
|
||||
psi_selectors_coef_transp_tc(k,2,i) = psi_selectors_coef_tc(i,2,k)
|
||||
enddo
|
||||
enddo
|
||||
END_PROVIDER
|
||||
|
|
|
@ -1,12 +1,27 @@
|
|||
! ---
|
||||
|
||||
BEGIN_PROVIDER [ double precision, ao_two_e_integral_alpha, (ao_num, ao_num) ]
|
||||
&BEGIN_PROVIDER [ double precision, ao_two_e_integral_beta , (ao_num, ao_num) ]
|
||||
use map_module
|
||||
implicit none
|
||||
&BEGIN_PROVIDER [ double precision, ao_two_e_integral_beta , (ao_num, ao_num) ]
|
||||
|
||||
BEGIN_DOC
|
||||
! Alpha and Beta Fock matrices in AO basis set
|
||||
!
|
||||
! 2-e part of alpha and beta Fock matrices (F^{a} & F^{b}) in AO basis set
|
||||
!
|
||||
! F^{a} = h + G^{a}
|
||||
! F^{b} = h + G^{b}
|
||||
!
|
||||
! where :
|
||||
! F^{a} = J^{a} + J^{b} - K^{a} ==> G_{ij}^{a} = \sum_{k,l} P_{kl} (kl|ij) - P_{kl}^{a} (ki|lj)
|
||||
! F^{b} = J^{a} + J^{b} - K^{b} ==> G_{ij}^{b} = \sum_{k,l} P_{kl} (kl|ij) - P_{kl}^{b} (ki|lj)
|
||||
!
|
||||
! and P_{kl} = P_{kl}^{a} + P_{kl}^{b}
|
||||
!
|
||||
END_DOC
|
||||
|
||||
use map_module
|
||||
|
||||
implicit none
|
||||
|
||||
integer :: i,j,k,l,k1,r,s
|
||||
integer :: i0,j0,k0,l0
|
||||
integer*8 :: p,q
|
||||
|
@ -153,6 +168,8 @@
|
|||
|
||||
END_PROVIDER
|
||||
|
||||
! ---
|
||||
|
||||
BEGIN_PROVIDER [ double precision, Fock_matrix_ao_alpha, (ao_num, ao_num) ]
|
||||
&BEGIN_PROVIDER [ double precision, Fock_matrix_ao_beta, (ao_num, ao_num) ]
|
||||
implicit none
|
||||
|
|
|
@ -68,20 +68,29 @@ subroutine create_guess
|
|||
endif
|
||||
end
|
||||
|
||||
subroutine run
|
||||
! ---
|
||||
|
||||
subroutine run()
|
||||
|
||||
BEGIN_DOC
|
||||
! Run SCF calculation
|
||||
! Run SCF calculation
|
||||
END_DOC
|
||||
|
||||
use bitmasks
|
||||
implicit none
|
||||
|
||||
integer :: i_it, i, j, k
|
||||
|
||||
mo_label = 'Orthonormalized'
|
||||
|
||||
call Roothaan_Hall_SCF
|
||||
PROVIDE scf_algorithm
|
||||
|
||||
if(scf_algorithm .eq. "DIIS") then
|
||||
call Roothaan_Hall_SCF()
|
||||
elseif(scf_algorithm .eq. "Simple") then
|
||||
call Roothaan_Hall_SCF_Simple()
|
||||
else
|
||||
print *, scf_algorithm, ' not implemented yet'
|
||||
endif
|
||||
|
||||
call ezfio_set_hartree_fock_energy(SCF_energy)
|
||||
|
||||
end
|
||||
|
|
|
@ -38,7 +38,7 @@ BEGIN_PROVIDER [ logical, mo_two_e_integrals_in_map ]
|
|||
print*, 'MO integrals provided'
|
||||
return
|
||||
else
|
||||
PROVIDE ao_two_e_integrals_in_map
|
||||
PROVIDE ao_two_e_integrals_in_map
|
||||
endif
|
||||
|
||||
print *, ''
|
||||
|
@ -245,18 +245,16 @@ subroutine add_integrals_to_map(mask_ijkl)
|
|||
return
|
||||
endif
|
||||
|
||||
double precision :: accu_bis
|
||||
accu_bis = 0.d0
|
||||
call wall_time(wall_1)
|
||||
|
||||
size_buffer = min( (qp_max_mem/(nproc*5)),mo_num*mo_num*mo_num)
|
||||
size_buffer = min(mo_num*mo_num*mo_num,8000000)
|
||||
print*, 'Buffers : ', 8.*(mo_num*(n_j)*(n_k+1) + mo_num+&
|
||||
ao_num+ao_num*ao_num+ size_buffer*3)/(1024*1024), 'MB / core'
|
||||
|
||||
!$OMP PARALLEL PRIVATE(l1,k1,j1,i1,i2,i3,i4,i,j,k,l,c, ii1,kmax, &
|
||||
!$OMP two_e_tmp_0_idx, two_e_tmp_0, two_e_tmp_1,two_e_tmp_2,two_e_tmp_3,&
|
||||
!$OMP buffer_i,buffer_value,n_integrals,wall_2,i0,j0,k0,l0, &
|
||||
!$OMP wall_0,thread_num,accu_bis) &
|
||||
!$OMP wall_0,thread_num) &
|
||||
!$OMP DEFAULT(NONE) &
|
||||
!$OMP SHARED(size_buffer,ao_num,mo_num,n_i,n_j,n_k,n_l, &
|
||||
!$OMP mo_coef_transp, &
|
||||
|
@ -434,10 +432,10 @@ subroutine add_integrals_to_map(mask_ijkl)
|
|||
!$OMP END DO NOWAIT
|
||||
deallocate (two_e_tmp_1,two_e_tmp_2,two_e_tmp_3)
|
||||
|
||||
integer :: index_needed
|
||||
|
||||
call insert_into_mo_integrals_map(n_integrals,buffer_i,buffer_value,&
|
||||
real(mo_integrals_threshold,integral_kind))
|
||||
if (n_integrals > 0) then
|
||||
call insert_into_mo_integrals_map(n_integrals,buffer_i,buffer_value,&
|
||||
real(mo_integrals_threshold,integral_kind))
|
||||
endif
|
||||
deallocate(buffer_i, buffer_value)
|
||||
!$OMP END PARALLEL
|
||||
call map_merge(mo_integrals_map)
|
||||
|
@ -527,12 +525,10 @@ subroutine add_integrals_to_map_three_indices(mask_ijk)
|
|||
|
||||
call wall_time(wall_1)
|
||||
call cpu_time(cpu_1)
|
||||
double precision :: accu_bis
|
||||
accu_bis = 0.d0
|
||||
!$OMP PARALLEL PRIVATE(m,l1,k1,j1,i1,i2,i3,i4,i,j,k,l,c, ii1,kmax, &
|
||||
!$OMP two_e_tmp_0_idx, two_e_tmp_0, two_e_tmp_1,two_e_tmp_2,two_e_tmp_3,&
|
||||
!$OMP buffer_i,buffer_value,n_integrals,wall_2,i0,j0,k0,l0, &
|
||||
!$OMP wall_0,thread_num,accu_bis) &
|
||||
!$OMP wall_0,thread_num) &
|
||||
!$OMP DEFAULT(NONE) &
|
||||
!$OMP SHARED(size_buffer,ao_num,mo_num,n_i,n_j,n_k, &
|
||||
!$OMP mo_coef_transp, &
|
||||
|
@ -730,8 +726,6 @@ subroutine add_integrals_to_map_three_indices(mask_ijk)
|
|||
!$OMP END DO NOWAIT
|
||||
deallocate (two_e_tmp_1,two_e_tmp_2,two_e_tmp_3)
|
||||
|
||||
integer :: index_needed
|
||||
|
||||
call insert_into_mo_integrals_map(n_integrals,buffer_i,buffer_value,&
|
||||
real(mo_integrals_threshold,integral_kind))
|
||||
deallocate(buffer_i, buffer_value)
|
||||
|
|
|
@ -17,7 +17,7 @@ program debug_integ_jmu_modif
|
|||
|
||||
PROVIDE mu_erf j1b_pen
|
||||
|
||||
call test_v_ij_u_cst_mu_j1b()
|
||||
! 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()
|
||||
|
@ -31,6 +31,9 @@ program debug_integ_jmu_modif
|
|||
! call test_u12_grad1_u12_j1b_grad1_j1b()
|
||||
! !call test_gradu_squared_u_ij_mu()
|
||||
|
||||
!call test_vect_overlap_gauss_r12_ao()
|
||||
call test_vect_overlap_gauss_r12_ao_with1s()
|
||||
|
||||
end
|
||||
|
||||
! ---
|
||||
|
@ -303,7 +306,7 @@ subroutine test_int2_grad1_u12_ao()
|
|||
|
||||
call num_int2_grad1_u12_ao(i, j, ipoint, integ)
|
||||
|
||||
i_exc = int2_grad1_u12_ao(1,i,j,ipoint)
|
||||
i_exc = int2_grad1_u12_ao(i,j,ipoint,1)
|
||||
i_num = integ(1)
|
||||
acc_ij = dabs(i_exc - i_num)
|
||||
if(acc_ij .gt. eps_ij) then
|
||||
|
@ -315,7 +318,7 @@ subroutine test_int2_grad1_u12_ao()
|
|||
acc_tot += acc_ij
|
||||
normalz += dabs(i_num)
|
||||
|
||||
i_exc = int2_grad1_u12_ao(2,i,j,ipoint)
|
||||
i_exc = int2_grad1_u12_ao(i,j,ipoint,2)
|
||||
i_num = integ(2)
|
||||
acc_ij = dabs(i_exc - i_num)
|
||||
if(acc_ij .gt. eps_ij) then
|
||||
|
@ -327,7 +330,7 @@ subroutine test_int2_grad1_u12_ao()
|
|||
acc_tot += acc_ij
|
||||
normalz += dabs(i_num)
|
||||
|
||||
i_exc = int2_grad1_u12_ao(3,i,j,ipoint)
|
||||
i_exc = int2_grad1_u12_ao(i,j,ipoint,3)
|
||||
i_num = integ(3)
|
||||
acc_ij = dabs(i_exc - i_num)
|
||||
if(acc_ij .gt. eps_ij) then
|
||||
|
@ -379,7 +382,7 @@ subroutine test_int2_u_grad1u_total_j1b2()
|
|||
|
||||
call num_int2_u_grad1u_total_j1b2(i, j, ipoint, integ)
|
||||
|
||||
i_exc = x * int2_u_grad1u_j1b2(i,j,ipoint) - int2_u_grad1u_x_j1b2(1,i,j,ipoint)
|
||||
i_exc = x * int2_u_grad1u_j1b2(i,j,ipoint) - int2_u_grad1u_x_j1b2(i,j,ipoint,1)
|
||||
i_num = integ(1)
|
||||
acc_ij = dabs(i_exc - i_num)
|
||||
if(acc_ij .gt. eps_ij) then
|
||||
|
@ -391,7 +394,7 @@ 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(2,i,j,ipoint)
|
||||
i_exc = y * int2_u_grad1u_j1b2(i,j,ipoint) - int2_u_grad1u_x_j1b2(i,j,ipoint,2)
|
||||
i_num = integ(2)
|
||||
acc_ij = dabs(i_exc - i_num)
|
||||
if(acc_ij .gt. eps_ij) then
|
||||
|
@ -403,7 +406,7 @@ 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(3,i,j,ipoint)
|
||||
i_exc = z * int2_u_grad1u_j1b2(i,j,ipoint) - int2_u_grad1u_x_j1b2(i,j,ipoint,3)
|
||||
i_num = integ(3)
|
||||
acc_ij = dabs(i_exc - i_num)
|
||||
if(acc_ij .gt. eps_ij) then
|
||||
|
@ -595,7 +598,183 @@ subroutine test_u12_grad1_u12_j1b_grad1_j1b()
|
|||
print*, ' normalz = ', normalz
|
||||
|
||||
return
|
||||
end subroutine test_u12_grad1_u12_j1b_grad1_j1b,
|
||||
end subroutine test_u12_grad1_u12_j1b_grad1_j1b
|
||||
|
||||
! ---
|
||||
|
||||
subroutine test_vect_overlap_gauss_r12_ao()
|
||||
|
||||
implicit none
|
||||
|
||||
integer :: i, j, ipoint
|
||||
double precision :: acc_ij, acc_tot, eps_ij, i_exc, i_num, normalz
|
||||
double precision :: expo_fit, r(3)
|
||||
double precision, allocatable :: I_vec(:,:,:), I_ref(:,:,:), int_fit_v(:)
|
||||
|
||||
double precision, external :: overlap_gauss_r12_ao
|
||||
|
||||
print *, ' test_vect_overlap_gauss_r12_ao ...'
|
||||
|
||||
provide mu_erf final_grid_points_transp j1b_pen
|
||||
|
||||
expo_fit = expo_gauss_j_mu_x_2(1)
|
||||
|
||||
! ---
|
||||
|
||||
allocate(int_fit_v(n_points_final_grid))
|
||||
allocate(I_vec(ao_num,ao_num,n_points_final_grid))
|
||||
|
||||
I_vec = 0.d0
|
||||
do i = 1, ao_num
|
||||
do j = 1, ao_num
|
||||
|
||||
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)
|
||||
|
||||
do ipoint = 1, n_points_final_grid
|
||||
I_vec(j,i,ipoint) = int_fit_v(ipoint)
|
||||
enddo
|
||||
enddo
|
||||
enddo
|
||||
|
||||
! ---
|
||||
|
||||
allocate(I_ref(ao_num,ao_num,n_points_final_grid))
|
||||
|
||||
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 = 1, ao_num
|
||||
|
||||
I_ref(j,i,ipoint) = overlap_gauss_r12_ao(r, expo_fit, i, j)
|
||||
enddo
|
||||
enddo
|
||||
enddo
|
||||
|
||||
! ---
|
||||
|
||||
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 = I_ref(i,j,ipoint)
|
||||
i_num = I_vec(i,j,ipoint)
|
||||
acc_ij = dabs(i_exc - i_num)
|
||||
!acc_ij = dabs(i_exc - i_num) / dabs(i_exc)
|
||||
if(acc_ij .gt. eps_ij) then
|
||||
print *, ' problem in overlap_gauss_r12_ao_v on', i, j, ipoint
|
||||
print *, ' analyt integ = ', i_exc
|
||||
print *, ' numeri integ = ', i_num
|
||||
print *, ' diff = ', acc_ij
|
||||
stop
|
||||
endif
|
||||
|
||||
acc_tot += acc_ij
|
||||
normalz += dabs(i_num)
|
||||
enddo
|
||||
enddo
|
||||
enddo
|
||||
|
||||
print*, ' acc_tot = ', acc_tot
|
||||
print*, ' normalz = ', normalz
|
||||
|
||||
return
|
||||
end subroutine test_vect_overlap_gauss_r12_ao
|
||||
|
||||
! ---
|
||||
|
||||
subroutine test_vect_overlap_gauss_r12_ao_with1s()
|
||||
|
||||
implicit none
|
||||
|
||||
integer :: i, j, ipoint
|
||||
double precision :: acc_ij, acc_tot, eps_ij, i_exc, i_num, normalz
|
||||
double precision :: expo_fit, r(3), beta, B_center(3)
|
||||
double precision, allocatable :: I_vec(:,:,:), I_ref(:,:,:), int_fit_v(:)
|
||||
|
||||
double precision, external :: overlap_gauss_r12_ao_with1s
|
||||
|
||||
print *, ' test_vect_overlap_gauss_r12_ao_with1s ...'
|
||||
|
||||
provide mu_erf final_grid_points_transp j1b_pen
|
||||
|
||||
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)
|
||||
|
||||
! ---
|
||||
|
||||
allocate(int_fit_v(n_points_final_grid))
|
||||
allocate(I_vec(ao_num,ao_num,n_points_final_grid))
|
||||
|
||||
I_vec = 0.d0
|
||||
do i = 1, ao_num
|
||||
do j = 1, ao_num
|
||||
|
||||
call overlap_gauss_r12_ao_with1s_v(B_center, beta, final_grid_points_transp, n_points_final_grid, expo_fit, i, j, int_fit_v, n_points_final_grid, n_points_final_grid)
|
||||
|
||||
do ipoint = 1, n_points_final_grid
|
||||
I_vec(j,i,ipoint) = int_fit_v(ipoint)
|
||||
enddo
|
||||
enddo
|
||||
enddo
|
||||
|
||||
! ---
|
||||
|
||||
allocate(I_ref(ao_num,ao_num,n_points_final_grid))
|
||||
|
||||
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 = 1, ao_num
|
||||
|
||||
I_ref(j,i,ipoint) = overlap_gauss_r12_ao_with1s(B_center, beta, r, expo_fit, i, j)
|
||||
enddo
|
||||
enddo
|
||||
enddo
|
||||
|
||||
! ---
|
||||
|
||||
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 = I_ref(i,j,ipoint)
|
||||
i_num = I_vec(i,j,ipoint)
|
||||
acc_ij = dabs(i_exc - i_num)
|
||||
!acc_ij = dabs(i_exc - i_num) / dabs(i_exc)
|
||||
if(acc_ij .gt. eps_ij) then
|
||||
print *, ' problem in overlap_gauss_r12_ao_v on', i, j, ipoint
|
||||
print *, ' analyt integ = ', i_exc
|
||||
print *, ' numeri integ = ', i_num
|
||||
print *, ' diff = ', acc_ij
|
||||
stop
|
||||
endif
|
||||
|
||||
acc_tot += acc_ij
|
||||
normalz += dabs(i_num)
|
||||
enddo
|
||||
enddo
|
||||
enddo
|
||||
|
||||
print*, ' acc_tot = ', acc_tot
|
||||
print*, ' normalz = ', normalz
|
||||
|
||||
return
|
||||
end subroutine test_vect_overlap_gauss_r12_ao
|
||||
|
||||
|
|
|
@ -70,9 +70,9 @@ BEGIN_PROVIDER [ double precision, gradu_squared_u_ij_mu, (ao_num, ao_num, n_poi
|
|||
|
||||
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(1,i,j,ipoint) &
|
||||
+ tmp7 * tmp9 + tmp4 * int2_u_grad1u_x_j1b2(2,i,j,ipoint) &
|
||||
+ tmp8 * tmp9 + tmp5 * int2_u_grad1u_x_j1b2(3,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
|
||||
|
@ -104,11 +104,11 @@ END_PROVIDER
|
|||
|
||||
! ---
|
||||
|
||||
!BEGIN_PROVIDER [double precision, tc_grad_square_ao, (ao_num, ao_num, ao_num, ao_num)]
|
||||
!BEGIN_PROVIDER [double precision, tc_grad_square_ao_loop, (ao_num, ao_num, ao_num, ao_num)]
|
||||
!
|
||||
! BEGIN_DOC
|
||||
! !
|
||||
! ! tc_grad_square_ao(k,i,l,j) = -1/2 <kl | |\grad_1 u(r1,r2)|^2 + |\grad_1 u(r1,r2)|^2 | ij>
|
||||
! ! tc_grad_square_ao_loop(k,i,l,j) = -1/2 <kl | |\grad_1 u(r1,r2)|^2 + |\grad_1 u(r1,r2)|^2 | ij>
|
||||
! !
|
||||
! END_DOC
|
||||
!
|
||||
|
@ -142,8 +142,8 @@ END_PROVIDER
|
|||
! do l = 1, ao_num
|
||||
! do i = 1, ao_num
|
||||
! do k = 1, ao_num
|
||||
! tc_grad_square_ao(k,i,l,j) = ac_mat(k,i,l,j) + ac_mat(l,j,k,i)
|
||||
! !write(11,*) tc_grad_square_ao(k,i,l,j)
|
||||
! 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
|
||||
|
@ -155,19 +155,23 @@ END_PROVIDER
|
|||
|
||||
! ---
|
||||
|
||||
BEGIN_PROVIDER [double precision, tc_grad_square_ao, (ao_num, ao_num, ao_num, ao_num)]
|
||||
BEGIN_PROVIDER [double precision, tc_grad_square_ao_loop, (ao_num, ao_num, ao_num, ao_num)]
|
||||
|
||||
BEGIN_DOC
|
||||
!
|
||||
! tc_grad_square_ao(k,i,l,j) = -1/2 <kl | |\grad_1 u(r1,r2)|^2 + |\grad_1 u(r1,r2)|^2 | ij>
|
||||
! tc_grad_square_ao_loop(k,i,l,j) = 1/2 <kl | |\grad_1 u(r1,r2)|^2 + |\grad_2 u(r1,r2)|^2 | ij>
|
||||
!
|
||||
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))
|
||||
|
@ -177,10 +181,12 @@ BEGIN_PROVIDER [double precision, tc_grad_square_ao, (ao_num, ao_num, ao_num, ao
|
|||
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_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_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
|
||||
|
@ -196,7 +202,7 @@ BEGIN_PROVIDER [double precision, tc_grad_square_ao, (ao_num, ao_num, ao_num, ao
|
|||
do l = 1, ao_num
|
||||
do i = 1, ao_num
|
||||
do k = 1, ao_num
|
||||
tc_grad_square_ao(k,i,l,j) = ac_mat(k,i,l,j) + ac_mat(l,j,k,i) + bc_mat(k,i,l,j)
|
||||
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
|
||||
|
@ -205,6 +211,9 @@ BEGIN_PROVIDER [double precision, tc_grad_square_ao, (ao_num, ao_num, ao_num, ao
|
|||
deallocate(ac_mat)
|
||||
deallocate(bc_mat)
|
||||
|
||||
call wall_time(time1)
|
||||
print*, ' Wall time for tc_grad_square_ao_loop = ', time1 - time0
|
||||
|
||||
END_PROVIDER
|
||||
|
||||
! ---
|
||||
|
@ -290,6 +299,7 @@ BEGIN_PROVIDER [ double precision, u12sq_j1bsq, (ao_num, ao_num, n_points_final_
|
|||
|
||||
END_PROVIDER
|
||||
|
||||
! ---
|
||||
! ---
|
||||
|
||||
BEGIN_PROVIDER [ double precision, u12_grad1_u12_j1b_grad1_j1b, (ao_num, ao_num, n_points_final_grid) ]
|
||||
|
@ -328,9 +338,9 @@ BEGIN_PROVIDER [ double precision, u12_grad1_u12_j1b_grad1_j1b, (ao_num, 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(1,i,j,ipoint) &
|
||||
+ tmp7 * tmp9 + tmp4 * int2_u_grad1u_x_j1b2(2,i,j,ipoint) &
|
||||
+ tmp8 * tmp9 + tmp5 * int2_u_grad1u_x_j1b2(3,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
|
||||
|
@ -342,3 +352,86 @@ 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 <kl | |\grad_1 u(r1,r2)|^2 + |\grad_2 u(r1,r2)|^2 | ij>
|
||||
!
|
||||
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(:,:,:,:), b_mat(:,:,:), tmp(:,:,:)
|
||||
|
||||
print*, ' providing tc_grad_square_ao ...'
|
||||
call wall_time(time0)
|
||||
|
||||
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))
|
||||
|
||||
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
|
||||
|
||||
tmp = 0.d0
|
||||
!$OMP PARALLEL &
|
||||
!$OMP DEFAULT (NONE) &
|
||||
!$OMP PRIVATE (j, l, ipoint) &
|
||||
!$OMP SHARED (tmp, ao_num, n_points_final_grid, u12sq_j1bsq, u12_grad1_u12_j1b_grad1_j1b, grad12_j12)
|
||||
!$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(l,j,ipoint) + u12_grad1_u12_j1b_grad1_j1b(l,j,ipoint) + 0.5d0 * grad12_j12(l,j,ipoint)
|
||||
enddo
|
||||
enddo
|
||||
enddo
|
||||
!$OMP END DO
|
||||
!$OMP END PARALLEL
|
||||
|
||||
|
||||
ac_mat = 0.d0
|
||||
call dgemm( "N", "N", ao_num*ao_num, ao_num*ao_num, n_points_final_grid, 1.d0 &
|
||||
, tmp(1,1,1), ao_num*ao_num, b_mat(1,1,1), n_points_final_grid &
|
||||
, 1.d0, ac_mat, ao_num*ao_num)
|
||||
deallocate(tmp, b_mat)
|
||||
|
||||
!$OMP PARALLEL &
|
||||
!$OMP DEFAULT (NONE) &
|
||||
!$OMP PRIVATE (i, j, k, l) &
|
||||
!$OMP SHARED (ac_mat, tc_grad_square_ao, ao_num)
|
||||
!$OMP DO SCHEDULE (static)
|
||||
do j = 1, ao_num
|
||||
do l = 1, ao_num
|
||||
do i = 1, ao_num
|
||||
do k = 1, ao_num
|
||||
tc_grad_square_ao(k,i,l,j) = ac_mat(k,i,l,j) + ac_mat(l,j,k,i)
|
||||
enddo
|
||||
enddo
|
||||
enddo
|
||||
enddo
|
||||
!$OMP END DO
|
||||
!$OMP END PARALLEL
|
||||
|
||||
deallocate(ac_mat)
|
||||
|
||||
call wall_time(time1)
|
||||
print*, ' Wall time for tc_grad_square_ao = ', time1 - time0
|
||||
|
||||
END_PROVIDER
|
||||
|
||||
! ---
|
||||
|
|
221
src/non_h_ints_mu/grad_squared_manu.irp.f
Normal file
221
src/non_h_ints_mu/grad_squared_manu.irp.f
Normal file
|
@ -0,0 +1,221 @@
|
|||
|
||||
BEGIN_PROVIDER [double precision, tc_grad_square_ao_test, (ao_num, ao_num, ao_num, ao_num)]
|
||||
|
||||
BEGIN_DOC
|
||||
!
|
||||
! tc_grad_square_ao_test(k,i,l,j) = -1/2 <kl | |\grad_1 u(r1,r2)|^2 + |\grad_1 u(r1,r2)|^2 | ij>
|
||||
!
|
||||
END_DOC
|
||||
|
||||
implicit none
|
||||
integer :: ipoint, i, j, k, l
|
||||
double precision :: weight1, ao_ik_r, ao_i_r,contrib,contrib2
|
||||
double precision :: time0, time1
|
||||
double precision, allocatable :: ac_mat(:,:,:,:), b_mat(:,:,:), tmp(:,:,:)
|
||||
|
||||
print*, ' providing tc_grad_square_ao_test ...'
|
||||
call wall_time(time0)
|
||||
|
||||
provide u12sq_j1bsq_test u12_grad1_u12_j1b_grad1_j1b_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))
|
||||
|
||||
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
|
||||
|
||||
tmp = 0.d0
|
||||
!$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 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)
|
||||
enddo
|
||||
enddo
|
||||
enddo
|
||||
!$OMP END DO
|
||||
!$OMP END PARALLEL
|
||||
|
||||
ac_mat = 0.d0
|
||||
call dgemm( "N", "N", ao_num*ao_num, ao_num*ao_num, n_points_final_grid, 1.d0 &
|
||||
, tmp(1,1,1), ao_num*ao_num, b_mat(1,1,1), n_points_final_grid &
|
||||
, 1.d0, ac_mat, ao_num*ao_num)
|
||||
deallocate(tmp, b_mat)
|
||||
|
||||
!$OMP PARALLEL &
|
||||
!$OMP DEFAULT (NONE) &
|
||||
!$OMP PRIVATE (i, j, k, l) &
|
||||
!$OMP SHARED (ac_mat, tc_grad_square_ao_test, ao_num)
|
||||
!$OMP DO SCHEDULE (static)
|
||||
do j = 1, ao_num
|
||||
do l = 1, ao_num
|
||||
do i = 1, ao_num
|
||||
do k = 1, ao_num
|
||||
tc_grad_square_ao_test(k,i,l,j) = ac_mat(k,i,l,j) + ac_mat(l,j,k,i)
|
||||
enddo
|
||||
enddo
|
||||
enddo
|
||||
enddo
|
||||
!$OMP END DO
|
||||
!$OMP END PARALLEL
|
||||
|
||||
deallocate(ac_mat)
|
||||
|
||||
call wall_time(time1)
|
||||
print*, ' Wall time for tc_grad_square_ao_test = ', time1 - time0
|
||||
|
||||
END_PROVIDER
|
||||
|
||||
! ---
|
||||
|
||||
BEGIN_PROVIDER [ double precision, u12sq_j1bsq_test, (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_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)
|
||||
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)
|
||||
enddo
|
||||
enddo
|
||||
enddo
|
||||
|
||||
call wall_time(time1)
|
||||
print*, ' Wall time for u12sq_j1bsq_test = ', time1 - time0
|
||||
|
||||
END_PROVIDER
|
||||
|
||||
! ---
|
||||
|
||||
BEGIN_PROVIDER [ double precision, u12_grad1_u12_j1b_grad1_j1b_test, (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_test ...'
|
||||
|
||||
provide int2_u_grad1u_x_j1b2_test
|
||||
call wall_time(time0)
|
||||
|
||||
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_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)
|
||||
enddo
|
||||
enddo
|
||||
enddo
|
||||
|
||||
call wall_time(time1)
|
||||
print*, ' Wall time for u12_grad1_u12_j1b_grad1_j1b_test = ', time1 - time0
|
||||
|
||||
END_PROVIDER
|
||||
|
||||
! ---
|
||||
|
||||
BEGIN_PROVIDER [ double precision, grad12_j12_test, (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
|
||||
provide int2_grad1u2_grad2u2_j1b2_test
|
||||
print*, ' providing grad12_j12_test ...'
|
||||
call wall_time(time0)
|
||||
|
||||
PROVIDE j1b_type
|
||||
|
||||
if(j1b_type .eq. 3) then
|
||||
|
||||
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_test(i,j,ipoint) = tmp1 * int2_grad1u2_grad2u2_j1b2_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
|
||||
|
||||
endif
|
||||
|
||||
call wall_time(time1)
|
||||
print*, ' Wall time for grad12_j12_test = ', time1 - time0
|
||||
|
||||
END_PROVIDER
|
||||
|
||||
! ---
|
||||
|
|
@ -237,6 +237,23 @@ end function j12_mu
|
|||
|
||||
! ---
|
||||
|
||||
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 j12_mu_gauss(r1, r2)
|
||||
|
||||
implicit none
|
||||
|
|
|
@ -1,22 +1,21 @@
|
|||
|
||||
! ---
|
||||
|
||||
BEGIN_PROVIDER [ double precision, int2_grad1_u12_ao, (3, ao_num, ao_num, n_points_final_grid)]
|
||||
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 [-1 * \grad_r1 J(r1,r2)] \phi_i(r2) \phi_j(r2)
|
||||
! 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:
|
||||
!
|
||||
! 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)
|
||||
! 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
|
||||
!
|
||||
! 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) ]
|
||||
! 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,:)
|
||||
|
@ -25,6 +24,95 @@ BEGIN_PROVIDER [ double precision, int2_grad1_u12_ao, (3, ao_num, ao_num, n_poin
|
|||
!
|
||||
END_DOC
|
||||
|
||||
implicit none
|
||||
integer :: ipoint, i, j
|
||||
double precision :: time0, time1
|
||||
double precision :: x, y, z, tmp_x, tmp_y, tmp_z, tmp0, tmp1, tmp2
|
||||
|
||||
print*, ' providing int2_grad1_u12_ao ...'
|
||||
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)
|
||||
|
||||
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(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
|
||||
|
||||
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(i,j,ipoint,1) = tmp1 * x - x_v_ij_erf_rk_cst_mu_transp_bis(ipoint,i,j,1)
|
||||
int2_grad1_u12_ao(i,j,ipoint,2) = tmp1 * y - x_v_ij_erf_rk_cst_mu_transp_bis(ipoint,i,j,2)
|
||||
int2_grad1_u12_ao(i,j,ipoint,3) = tmp1 * z - x_v_ij_erf_rk_cst_mu_transp_bis(ipoint,i,j,3)
|
||||
enddo
|
||||
enddo
|
||||
enddo
|
||||
|
||||
int2_grad1_u12_ao *= 0.5d0
|
||||
|
||||
endif
|
||||
|
||||
call wall_time(time1)
|
||||
print*, ' Wall time for int2_grad1_u12_ao = ', time1 - time0
|
||||
|
||||
END_PROVIDER
|
||||
|
||||
! ---
|
||||
|
||||
BEGIN_PROVIDER [ double precision, int1_grad2_u12_ao, (3, ao_num, ao_num, n_points_final_grid)]
|
||||
|
||||
BEGIN_DOC
|
||||
!
|
||||
! int1_grad2_u12_ao(:,i,j,ipoint) = \int dr1 [-1 * \grad_r2 J(r1,r2)] \phi_i(r1) \phi_j(r1)
|
||||
!
|
||||
! where r1 = r(ipoint)
|
||||
!
|
||||
! if J(r1,r2) = u12:
|
||||
!
|
||||
! int1_grad2_u12_ao(:,i,j,ipoint) = +0.5 x \int dr1 [-(r1 - r2) (erf(mu * r12)-1)r_12] \phi_i(r1) \phi_j(r1)
|
||||
! = -0.5 * [ v_ij_erf_rk_cst_mu(i,j,ipoint) * r(:) - x_v_ij_erf_rk_cst_mu(i,j,ipoint,:) ]
|
||||
! = -int2_grad1_u12_ao(i,j,ipoint,:)
|
||||
!
|
||||
! if J(r1,r2) = u12 x v1 x v2
|
||||
!
|
||||
! int1_grad2_u12_ao(:,i,j,ipoint) = v2 x [ 0.5 x \int dr1 [-(r1 - r2) (erf(mu * r12)-1)r_12] v1 \phi_i(r1) \phi_j(r1) ]
|
||||
! - \grad_2 v2 x [ \int dr1 u12 v1 \phi_i(r1) \phi_j(r1) ]
|
||||
! = -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
|
||||
double precision :: x, y, z, tmp_x, tmp_y, tmp_z, tmp0, tmp1, tmp2
|
||||
|
@ -49,32 +137,16 @@ BEGIN_PROVIDER [ double precision, int2_grad1_u12_ao, (3, ao_num, ao_num, n_poin
|
|||
tmp1 = tmp0 * v_ij_erf_rk_cst_mu_j1b(i,j,ipoint)
|
||||
tmp2 = v_ij_u_cst_mu_j1b(i,j,ipoint)
|
||||
|
||||
int2_grad1_u12_ao(1,i,j,ipoint) = tmp1 * x - tmp0 * x_v_ij_erf_rk_cst_mu_tmp_j1b(1,i,j,ipoint) - tmp2 * tmp_x
|
||||
int2_grad1_u12_ao(2,i,j,ipoint) = tmp1 * y - tmp0 * x_v_ij_erf_rk_cst_mu_tmp_j1b(2,i,j,ipoint) - tmp2 * tmp_y
|
||||
int2_grad1_u12_ao(3,i,j,ipoint) = tmp1 * z - tmp0 * x_v_ij_erf_rk_cst_mu_tmp_j1b(3,i,j,ipoint) - tmp2 * tmp_z
|
||||
int1_grad2_u12_ao(1,i,j,ipoint) = -tmp1 * x + tmp0 * x_v_ij_erf_rk_cst_mu_j1b(i,j,ipoint,1) - tmp2 * tmp_x
|
||||
int1_grad2_u12_ao(2,i,j,ipoint) = -tmp1 * y + tmp0 * x_v_ij_erf_rk_cst_mu_j1b(i,j,ipoint,2) - tmp2 * tmp_y
|
||||
int1_grad2_u12_ao(3,i,j,ipoint) = -tmp1 * z + tmp0 * x_v_ij_erf_rk_cst_mu_j1b(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(1,i,j,ipoint) = tmp1 * x - x_v_ij_erf_rk_cst_mu_tmp(1,i,j,ipoint)
|
||||
int2_grad1_u12_ao(2,i,j,ipoint) = tmp1 * y - x_v_ij_erf_rk_cst_mu_tmp(2,i,j,ipoint)
|
||||
int2_grad1_u12_ao(3,i,j,ipoint) = tmp1 * z - x_v_ij_erf_rk_cst_mu_tmp(3,i,j,ipoint)
|
||||
enddo
|
||||
enddo
|
||||
enddo
|
||||
|
||||
int2_grad1_u12_ao *= 0.5d0
|
||||
int1_grad2_u12_ao = -1.d0 * int2_grad1_u12_ao
|
||||
|
||||
endif
|
||||
|
||||
|
@ -82,11 +154,11 @@ END_PROVIDER
|
|||
|
||||
! ---
|
||||
|
||||
BEGIN_PROVIDER [double precision, tc_grad_and_lapl_ao, (ao_num, ao_num, ao_num, ao_num)]
|
||||
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(k,i,l,j) = < k l | -1/2 \Delta_1 u(r1,r2) - \grad_1 u(r1,r2) | ij >
|
||||
! 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)
|
||||
!
|
||||
|
@ -98,33 +170,48 @@ BEGIN_PROVIDER [double precision, tc_grad_and_lapl_ao, (ao_num, ao_num, ao_num,
|
|||
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_transp (ipoint,i)
|
||||
ao_i_dx = weight1 * aos_grad_in_r_array_transp_bis(ipoint,i,1)
|
||||
ao_i_dy = weight1 * aos_grad_in_r_array_transp_bis(ipoint,i,2)
|
||||
ao_i_dz = weight1 * aos_grad_in_r_array_transp_bis(ipoint,i,3)
|
||||
!ao_i_r = weight1 * aos_in_r_array_transp (ipoint,i)
|
||||
!ao_i_dx = weight1 * aos_grad_in_r_array_transp_bis(ipoint,i,1)
|
||||
!ao_i_dy = weight1 * aos_grad_in_r_array_transp_bis(ipoint,i,2)
|
||||
!ao_i_dz = weight1 * aos_grad_in_r_array_transp_bis(ipoint,i,3)
|
||||
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_transp(ipoint,k)
|
||||
!ao_k_r = aos_in_r_array_transp(ipoint,k)
|
||||
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_transp_bis(ipoint,k,1)
|
||||
tmp_y = ao_k_r * ao_i_dy - ao_i_r * aos_grad_in_r_array_transp_bis(ipoint,k,2)
|
||||
tmp_z = ao_k_r * ao_i_dz - ao_i_r * aos_grad_in_r_array_transp_bis(ipoint,k,3)
|
||||
!tmp_x = ao_k_r * ao_i_dx - ao_i_r * aos_grad_in_r_array_transp_bis(ipoint,k,1)
|
||||
!tmp_y = ao_k_r * ao_i_dy - ao_i_r * aos_grad_in_r_array_transp_bis(ipoint,k,2)
|
||||
!tmp_z = ao_k_r * ao_i_dz - ao_i_r * aos_grad_in_r_array_transp_bis(ipoint,k,3)
|
||||
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(1,l,j,ipoint) * tmp_x
|
||||
contrib_y = int2_grad1_u12_ao(2,l,j,ipoint) * tmp_y
|
||||
contrib_z = int2_grad1_u12_ao(3,l,j,ipoint) * tmp_z
|
||||
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
|
||||
|
@ -132,12 +219,47 @@ BEGIN_PROVIDER [double precision, tc_grad_and_lapl_ao, (ao_num, ao_num, ao_num,
|
|||
enddo
|
||||
enddo
|
||||
enddo
|
||||
|
||||
! ---
|
||||
|
||||
!do ipoint = 1, n_points_final_grid
|
||||
! weight1 = 0.5d0 * final_weight_at_r_vector(ipoint)
|
||||
|
||||
! do l = 1, ao_num
|
||||
! ao_l_r = weight1 * aos_in_r_array_transp (ipoint,l)
|
||||
! ao_l_dx = weight1 * aos_grad_in_r_array_transp_bis(ipoint,l,1)
|
||||
! ao_l_dy = weight1 * aos_grad_in_r_array_transp_bis(ipoint,l,2)
|
||||
! ao_l_dz = weight1 * aos_grad_in_r_array_transp_bis(ipoint,l,3)
|
||||
|
||||
! do j = 1, ao_num
|
||||
! ao_j_r = aos_in_r_array_transp(ipoint,j)
|
||||
|
||||
! tmp_x = ao_j_r * ao_l_dx - ao_l_r * aos_grad_in_r_array_transp_bis(ipoint,j,1)
|
||||
! tmp_y = ao_j_r * ao_l_dy - ao_l_r * aos_grad_in_r_array_transp_bis(ipoint,j,2)
|
||||
! tmp_z = ao_j_r * ao_l_dz - ao_l_r * aos_grad_in_r_array_transp_bis(ipoint,j,3)
|
||||
|
||||
! do i = 1, ao_num
|
||||
! do k = 1, ao_num
|
||||
|
||||
! contrib_x = int2_grad1_u12_ao(k,i,ipoint,1) * tmp_x
|
||||
! contrib_y = int2_grad1_u12_ao(k,i,ipoint,2) * tmp_y
|
||||
! contrib_z = int2_grad1_u12_ao(k,i,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(k,i,l,j) = ac_mat(k,i,l,j) + ac_mat(l,j,k,i)
|
||||
tc_grad_and_lapl_ao_loop(k,i,l,j) = ac_mat(k,i,l,j) + ac_mat(l,j,k,i)
|
||||
!tc_grad_and_lapl_ao_loop(k,i,l,j) = ac_mat(k,i,l,j)
|
||||
enddo
|
||||
enddo
|
||||
enddo
|
||||
|
@ -145,7 +267,94 @@ BEGIN_PROVIDER [double precision, tc_grad_and_lapl_ao, (ao_num, ao_num, ao_num,
|
|||
|
||||
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)
|
||||
!
|
||||
! 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 :: ac_mat(:,:,:,:), b_mat(:,:,:,:)
|
||||
|
||||
print*, ' providing tc_grad_and_lapl_ao ...'
|
||||
call wall_time(time0)
|
||||
|
||||
allocate(b_mat(n_points_final_grid,ao_num,ao_num,3), ac_mat(ao_num,ao_num,ao_num,ao_num))
|
||||
|
||||
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
|
||||
|
||||
ac_mat = 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, ac_mat, ao_num*ao_num)
|
||||
|
||||
enddo
|
||||
deallocate(b_mat)
|
||||
|
||||
!$OMP PARALLEL &
|
||||
!$OMP DEFAULT (NONE) &
|
||||
!$OMP PRIVATE (i, j, k, l) &
|
||||
!$OMP SHARED (ac_mat, tc_grad_and_lapl_ao, ao_num)
|
||||
!$OMP DO SCHEDULE (static)
|
||||
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(k,i,l,j) = ac_mat(k,i,l,j) + ac_mat(l,j,k,i)
|
||||
!tc_grad_and_lapl_ao(k,i,l,j) = ac_mat(k,i,l,j)
|
||||
enddo
|
||||
enddo
|
||||
enddo
|
||||
enddo
|
||||
!$OMP END DO
|
||||
!$OMP END PARALLEL
|
||||
|
||||
deallocate(ac_mat)
|
||||
|
||||
call wall_time(time1)
|
||||
print*, ' Wall time for tc_grad_and_lapl_ao = ', time1 - time0
|
||||
|
||||
END_PROVIDER
|
||||
|
||||
! ---
|
||||
|
||||
|
||||
|
|
174
src/non_h_ints_mu/new_grad_tc_manu.irp.f
Normal file
174
src/non_h_ints_mu/new_grad_tc_manu.irp.f
Normal file
|
@ -0,0 +1,174 @@
|
|||
|
||||
BEGIN_PROVIDER [ double precision, int2_grad1_u12_ao_test, (ao_num, ao_num, n_points_final_grid, 3)]
|
||||
|
||||
BEGIN_DOC
|
||||
!
|
||||
! 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)
|
||||
!
|
||||
! if J(r1,r2) = u12:
|
||||
!
|
||||
! int2_grad1_u12_ao_test(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
|
||||
!
|
||||
! 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)
|
||||
!
|
||||
!
|
||||
END_DOC
|
||||
|
||||
implicit none
|
||||
integer :: ipoint, i, j
|
||||
double precision :: time0, time1
|
||||
double precision :: x, y, z, tmp_x, tmp_y, tmp_z, tmp0, tmp1, tmp2
|
||||
|
||||
print*, ' providing int2_grad1_u12_ao_test ...'
|
||||
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)
|
||||
|
||||
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_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
|
||||
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
|
||||
|
||||
call wall_time(time1)
|
||||
print*, ' Wall time for int2_grad1_u12_ao_test = ', time1 - time0
|
||||
|
||||
END_PROVIDER
|
||||
|
||||
! ---
|
||||
|
||||
BEGIN_PROVIDER [double precision, tc_grad_and_lapl_ao_test, (ao_num, ao_num, ao_num, ao_num)]
|
||||
|
||||
BEGIN_DOC
|
||||
!
|
||||
! tc_grad_and_lapl_ao_test(k,i,l,j) = < k l | -1/2 \Delta_1 u(r1,r2) - \grad_1 u(r1,r2) | 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, m
|
||||
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 :: time0, time1
|
||||
double precision, allocatable :: ac_mat(:,:,:,:), b_mat(:,:,:,:)
|
||||
|
||||
print*, ' providing tc_grad_and_lapl_ao_test ...'
|
||||
call wall_time(time0)
|
||||
|
||||
provide int2_grad1_u12_ao_test
|
||||
|
||||
allocate(b_mat(n_points_final_grid,ao_num,ao_num,3), ac_mat(ao_num,ao_num,ao_num,ao_num))
|
||||
|
||||
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
|
||||
|
||||
ac_mat = 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_test(1,1,1,m), ao_num*ao_num, b_mat(1,1,1,m), n_points_final_grid &
|
||||
, 1.d0, ac_mat, ao_num*ao_num)
|
||||
|
||||
enddo
|
||||
deallocate(b_mat)
|
||||
|
||||
!$OMP PARALLEL &
|
||||
!$OMP DEFAULT (NONE) &
|
||||
!$OMP PRIVATE (i, j, k, l) &
|
||||
!$OMP SHARED (ac_mat, tc_grad_and_lapl_ao_test, ao_num)
|
||||
!$OMP DO SCHEDULE (static)
|
||||
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_test(k,i,l,j) = ac_mat(k,i,l,j) + ac_mat(l,j,k,i)
|
||||
enddo
|
||||
enddo
|
||||
enddo
|
||||
enddo
|
||||
!$OMP END DO
|
||||
!$OMP END PARALLEL
|
||||
|
||||
deallocate(ac_mat)
|
||||
|
||||
call wall_time(time1)
|
||||
print*, ' Wall time for tc_grad_and_lapl_ao_test = ', time1 - time0
|
||||
|
||||
END_PROVIDER
|
||||
|
||||
! ---
|
||||
|
|
@ -7,17 +7,22 @@ BEGIN_PROVIDER [double precision, ao_tc_int_chemist, (ao_num, ao_num, ao_num, ao
|
|||
integer :: i, j, k, l
|
||||
double precision :: wall1, wall0
|
||||
|
||||
print *, ' providing ao_tc_int_chemist ...'
|
||||
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(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)
|
||||
enddo
|
||||
enddo
|
||||
enddo
|
||||
enddo
|
||||
|
||||
if(test_cycle_tc)then
|
||||
ao_tc_int_chemist = ao_tc_int_chemist_test
|
||||
else
|
||||
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)
|
||||
enddo
|
||||
enddo
|
||||
enddo
|
||||
enddo
|
||||
endif
|
||||
|
||||
call wall_time(wall1)
|
||||
print *, ' wall time for ao_tc_int_chemist ', wall1 - wall0
|
||||
|
@ -26,6 +31,32 @@ 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)
|
||||
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
|
||||
|
|
|
@ -283,16 +283,16 @@ subroutine non_hrmt_bieig(n, A, thr_d, thr_nd, leigvec, reigvec, n_real_eigv, ei
|
|||
! -------------------------------------------------------------------------------------
|
||||
!
|
||||
|
||||
print *, ' '
|
||||
print *, ' Computing the left/right eigenvectors ...'
|
||||
print *, ' '
|
||||
!print *, ' '
|
||||
!print *, ' Computing the left/right eigenvectors ...'
|
||||
!print *, ' '
|
||||
|
||||
allocate( WR(n), WI(n), VL(n,n), VR(n,n) )
|
||||
allocate(WR(n), WI(n), VL(n,n), VR(n,n))
|
||||
|
||||
print *, ' fock matrix'
|
||||
do i = 1, n
|
||||
write(*, '(1000(F16.10,X))') A(i,:)
|
||||
enddo
|
||||
!print *, ' fock matrix'
|
||||
!do i = 1, n
|
||||
! write(*, '(1000(F16.10,X))') A(i,:)
|
||||
!enddo
|
||||
|
||||
!thr_cut = 1.d-15
|
||||
!call cancel_small_elmts(A, n, thr_cut)
|
||||
|
@ -301,11 +301,11 @@ 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
|
||||
!print *, ' '
|
||||
!print *, ' eigenvalues'
|
||||
!do i = 1, n
|
||||
! write(*, '(1000(F16.10,X))') WR(i), WI(i)
|
||||
!enddo
|
||||
!print *, ' right eigenvect bef'
|
||||
!do i = 1, n
|
||||
! write(*, '(1000(F16.10,X))') VR(:,i)
|
||||
|
@ -328,9 +328,10 @@ subroutine non_hrmt_bieig(n, A, thr_d, thr_nd, leigvec, reigvec, n_real_eigv, ei
|
|||
! track & sort the real eigenvalues
|
||||
|
||||
n_good = 0
|
||||
thr = 1.d-3
|
||||
!thr = 100d0
|
||||
thr = Im_thresh_tcscf
|
||||
do i = 1, n
|
||||
print*, 'Re(i) + Im(i)', WR(i), WI(i)
|
||||
!print*, 'Re(i) + Im(i)', WR(i), WI(i)
|
||||
if(dabs(WI(i)) .lt. thr) then
|
||||
n_good += 1
|
||||
else
|
||||
|
@ -404,23 +405,24 @@ 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
|
||||
|
||||
elseif( (accu_nd .lt. thr_nd) .and. (dabs(accu_d-dble(n_real_eigv))/dble(n_real_eigv) .gt. thr_d) ) then
|
||||
! 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
|
||||
|
||||
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_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'
|
||||
|
||||
! ---
|
||||
|
||||
|
@ -442,8 +444,8 @@ 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, leigvec, reigvec)
|
||||
!call impose_biorthog_lu(n, n_real_eigv, leigvec, reigvec)
|
||||
!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)
|
||||
|
||||
! ---
|
||||
|
||||
|
@ -609,7 +611,7 @@ subroutine non_hrmt_bieig_random_diag(n, A, leigvec, reigvec, n_real_eigv, eigva
|
|||
enddo
|
||||
accu_nd = dsqrt(accu_nd)
|
||||
|
||||
if(accu_nd .lt. 1d-8) then
|
||||
if(accu_nd .lt. thresh_biorthog_nondiag) then
|
||||
! L x R is already bi-orthogonal
|
||||
|
||||
print *, ' L & T bi-orthogonality: ok'
|
||||
|
@ -621,7 +623,7 @@ subroutine non_hrmt_bieig_random_diag(n, A, leigvec, reigvec, n_real_eigv, eigva
|
|||
|
||||
print *, ' L & T bi-orthogonality: not imposed yet'
|
||||
print *, ' accu_nd = ', accu_nd
|
||||
call impose_biorthog_qr(n, n_real_eigv, leigvec, reigvec)
|
||||
call impose_biorthog_qr(n, n_real_eigv, thresh_biorthog_diag, thresh_biorthog_nondiag, leigvec, reigvec)
|
||||
deallocate( S )
|
||||
|
||||
endif
|
||||
|
@ -631,7 +633,7 @@ subroutine non_hrmt_bieig_random_diag(n, A, leigvec, reigvec, n_real_eigv, eigva
|
|||
|
||||
return
|
||||
|
||||
end
|
||||
end subroutine non_hrmt_bieig_random_diag
|
||||
|
||||
! ---
|
||||
|
||||
|
@ -959,7 +961,7 @@ subroutine non_hrmt_bieig_fullvect(n, A, leigvec, reigvec, n_real_eigv, eigval)
|
|||
enddo
|
||||
accu_nd = dsqrt(accu_nd)
|
||||
|
||||
if( accu_nd .lt. 1d-8 ) then
|
||||
if(accu_nd .lt. thresh_biorthog_nondiag) then
|
||||
! L x R is already bi-orthogonal
|
||||
|
||||
!print *, ' L & T bi-orthogonality: ok'
|
||||
|
@ -971,7 +973,7 @@ subroutine non_hrmt_bieig_fullvect(n, A, leigvec, reigvec, n_real_eigv, eigval)
|
|||
|
||||
!print *, ' L & T bi-orthogonality: not imposed yet'
|
||||
!print *, ' accu_nd = ', accu_nd
|
||||
call impose_biorthog_qr(n, n, leigvec, reigvec)
|
||||
call impose_biorthog_qr(n, n, thresh_biorthog_diag, thresh_biorthog_nondiag, leigvec, reigvec)
|
||||
deallocate( S )
|
||||
|
||||
endif
|
||||
|
|
|
@ -930,7 +930,7 @@ subroutine check_EIGVEC(n, m, A, eigval, leigvec, reigvec, thr_diag, thr_norm, s
|
|||
|
||||
tmp_abs = tmp_abs + tmp
|
||||
V_nrm = V_nrm + U_nrm
|
||||
write(*,'(I4,X,(100(F25.16,X)))')j,eigval(j), tmp, U_nrm
|
||||
!write(*,'(I4,X,(100(F25.16,X)))') j,eigval(j), tmp, U_nrm
|
||||
|
||||
enddo
|
||||
|
||||
|
@ -973,7 +973,7 @@ subroutine check_EIGVEC(n, m, A, eigval, leigvec, reigvec, thr_diag, thr_norm, s
|
|||
|
||||
tmp_abs = tmp_abs + tmp
|
||||
V_nrm = V_nrm + U_nrm
|
||||
write(*,'(I4,X,(100(F25.16,X)))')j,eigval(j), tmp, U_nrm
|
||||
!write(*,'(I4,X,(100(F25.16,X)))') j,eigval(j), tmp, U_nrm
|
||||
|
||||
enddo
|
||||
|
||||
|
@ -1082,7 +1082,7 @@ subroutine impose_weighted_orthog_svd(n, m, W, C)
|
|||
double precision, allocatable :: S(:,:), tmp(:,:)
|
||||
double precision, allocatable :: U(:,:), Vt(:,:), D(:)
|
||||
|
||||
print *, ' apply SVD to orthogonalize & normalize weighted vectors'
|
||||
!print *, ' apply SVD to orthogonalize & normalize weighted vectors'
|
||||
|
||||
! ---
|
||||
|
||||
|
@ -1097,10 +1097,10 @@ subroutine impose_weighted_orthog_svd(n, m, W, C)
|
|||
, 0.d0, S, size(S, 1) )
|
||||
deallocate(tmp)
|
||||
|
||||
print *, ' overlap bef SVD: '
|
||||
do i = 1, m
|
||||
write(*, '(1000(F16.10,X))') S(i,:)
|
||||
enddo
|
||||
!print *, ' overlap bef SVD: '
|
||||
!do i = 1, m
|
||||
! write(*, '(1000(F16.10,X))') S(i,:)
|
||||
!enddo
|
||||
|
||||
! ---
|
||||
|
||||
|
@ -1160,10 +1160,10 @@ subroutine impose_weighted_orthog_svd(n, m, W, C)
|
|||
, 0.d0, S, size(S, 1) )
|
||||
deallocate(tmp)
|
||||
|
||||
print *, ' overlap aft SVD: '
|
||||
do i = 1, m
|
||||
write(*, '(1000(F16.10,X))') S(i,:)
|
||||
enddo
|
||||
!print *, ' overlap aft SVD: '
|
||||
!do i = 1, m
|
||||
! write(*, '(1000(F16.10,X))') S(i,:)
|
||||
!enddo
|
||||
|
||||
deallocate(S)
|
||||
|
||||
|
@ -1185,7 +1185,7 @@ subroutine impose_orthog_svd(n, m, C)
|
|||
double precision, allocatable :: S(:,:), tmp(:,:)
|
||||
double precision, allocatable :: U(:,:), Vt(:,:), D(:)
|
||||
|
||||
print *, ' apply SVD to orthogonalize & normalize vectors'
|
||||
!print *, ' apply SVD to orthogonalize & normalize vectors'
|
||||
|
||||
! ---
|
||||
|
||||
|
@ -1196,10 +1196,10 @@ subroutine impose_orthog_svd(n, m, C)
|
|||
, C, size(C, 1), C, size(C, 1) &
|
||||
, 0.d0, S, size(S, 1) )
|
||||
|
||||
print *, ' eigenvec overlap bef SVD: '
|
||||
do i = 1, m
|
||||
write(*, '(1000(F16.10,X))') S(i,:)
|
||||
enddo
|
||||
!print *, ' eigenvec overlap bef SVD: '
|
||||
!do i = 1, m
|
||||
! write(*, '(1000(F16.10,X))') S(i,:)
|
||||
!enddo
|
||||
|
||||
! ---
|
||||
|
||||
|
@ -1224,6 +1224,7 @@ subroutine impose_orthog_svd(n, m, C)
|
|||
if(num_linear_dependencies > 0) then
|
||||
write(*,*) ' linear dependencies = ', num_linear_dependencies
|
||||
write(*,*) ' m = ', m
|
||||
write(*,*) ' try with Graham-Schmidt'
|
||||
stop
|
||||
endif
|
||||
|
||||
|
@ -1256,10 +1257,10 @@ subroutine impose_orthog_svd(n, m, C)
|
|||
, C, size(C, 1), C, size(C, 1) &
|
||||
, 0.d0, S, size(S, 1) )
|
||||
|
||||
print *, ' eigenvec overlap aft SVD: '
|
||||
do i = 1, m
|
||||
write(*, '(1000(F16.10,X))') S(i,:)
|
||||
enddo
|
||||
!print *, ' eigenvec overlap aft SVD: '
|
||||
!do i = 1, m
|
||||
! write(*, '(1000(F16.10,X))') S(i,:)
|
||||
!enddo
|
||||
|
||||
deallocate(S)
|
||||
|
||||
|
@ -1296,10 +1297,10 @@ subroutine impose_orthog_svd_overlap(n, m, C, overlap)
|
|||
, 0.d0, S, size(S, 1) )
|
||||
deallocate(Stmp)
|
||||
|
||||
print *, ' eigenvec overlap bef SVD: '
|
||||
do i = 1, m
|
||||
write(*, '(1000(F16.10,X))') S(i,:)
|
||||
enddo
|
||||
!print *, ' eigenvec overlap bef SVD: '
|
||||
!do i = 1, m
|
||||
! write(*, '(1000(F16.10,X))') S(i,:)
|
||||
!enddo
|
||||
|
||||
! ---
|
||||
|
||||
|
@ -1358,10 +1359,10 @@ subroutine impose_orthog_svd_overlap(n, m, C, overlap)
|
|||
, 0.d0, S, size(S, 1) )
|
||||
deallocate(Stmp)
|
||||
|
||||
print *, ' eigenvec overlap aft SVD: '
|
||||
do i = 1, m
|
||||
write(*, '(1000(F16.10,X))') S(i,:)
|
||||
enddo
|
||||
!print *, ' eigenvec overlap aft SVD: '
|
||||
!do i = 1, m
|
||||
! write(*, '(1000(F16.10,X))') S(i,:)
|
||||
!enddo
|
||||
deallocate(S)
|
||||
|
||||
end subroutine impose_orthog_svd_overlap
|
||||
|
@ -1528,11 +1529,11 @@ subroutine impose_orthog_degen_eigvec(n, e0, C0)
|
|||
enddo
|
||||
|
||||
|
||||
do i = 1, n
|
||||
if(deg_num(i).gt.1) then
|
||||
print *, ' degen on', i, deg_num(i)
|
||||
endif
|
||||
enddo
|
||||
!do i = 1, n
|
||||
! if(deg_num(i) .gt. 1) then
|
||||
! print *, ' degen on', i, deg_num(i)
|
||||
! endif
|
||||
!enddo
|
||||
|
||||
! ---
|
||||
|
||||
|
@ -1677,7 +1678,7 @@ subroutine check_biorthog_binormalize(n, m, Vl, Vr, thr_d, thr_nd, stop_ifnot)
|
|||
double precision :: accu_d, accu_nd, s_tmp
|
||||
double precision, allocatable :: S(:,:)
|
||||
|
||||
print *, ' check bi-orthonormality'
|
||||
!print *, ' check bi-orthonormality'
|
||||
|
||||
! ---
|
||||
|
||||
|
@ -1714,15 +1715,19 @@ subroutine check_biorthog_binormalize(n, m, Vl, Vr, thr_d, thr_nd, stop_ifnot)
|
|||
enddo
|
||||
enddo
|
||||
accu_nd = dsqrt(accu_nd) / dble(m)
|
||||
print*, ' diag acc: ', accu_d
|
||||
print*, ' nondiag acc: ', accu_nd
|
||||
!print*, ' diag acc bef = ', accu_d
|
||||
!print*, ' nondiag acc bef = ', accu_nd
|
||||
|
||||
! ---
|
||||
|
||||
if( (accu_nd .lt. thr_nd) .and. (dabs(accu_d-dble(m))/dble(m) .gt. thr_d) ) then
|
||||
|
||||
do i = 1, m
|
||||
print *, i, S(i,i)
|
||||
if(S(i,i) <= 0.d0) then
|
||||
print *, ' overap negative'
|
||||
print *, i, S(i,i)
|
||||
exit
|
||||
endif
|
||||
if(dabs(S(i,i) - 1.d0) .gt. thr_d) then
|
||||
s_tmp = 1.d0 / dsqrt(S(i,i))
|
||||
do j = 1, n
|
||||
|
@ -1757,8 +1762,8 @@ subroutine check_biorthog_binormalize(n, m, Vl, Vr, thr_d, thr_nd, stop_ifnot)
|
|||
enddo
|
||||
enddo
|
||||
accu_nd = dsqrt(accu_nd) / dble(m)
|
||||
print *, ' diag acc: ', accu_d
|
||||
print *, ' nondiag acc: ', accu_nd
|
||||
!print *, ' diag acc aft = ', accu_d
|
||||
!print *, ' nondiag acc aft = ', accu_nd
|
||||
|
||||
deallocate(S)
|
||||
|
||||
|
@ -1801,10 +1806,10 @@ subroutine check_weighted_biorthog(n, m, W, Vl, Vr, thr_d, thr_nd, accu_d, accu_
|
|||
, 0.d0, S, size(S, 1) )
|
||||
deallocate(tmp)
|
||||
|
||||
print *, ' overlap matrix:'
|
||||
do i = 1, m
|
||||
write(*,'(1000(F16.10,X))') S(i,:)
|
||||
enddo
|
||||
!print *, ' overlap matrix:'
|
||||
!do i = 1, m
|
||||
! write(*,'(1000(F16.10,X))') S(i,:)
|
||||
!enddo
|
||||
|
||||
accu_d = 0.d0
|
||||
accu_nd = 0.d0
|
||||
|
@ -1852,17 +1857,18 @@ 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'
|
||||
|
||||
! ---
|
||||
|
||||
call dgemm( 'T', 'N', m, m, n, 1.d0 &
|
||||
, Vl, size(Vl, 1), Vr, size(Vr, 1) &
|
||||
, 0.d0, S, size(S, 1) )
|
||||
print *, ' overlap matrix:'
|
||||
do i = 1, m
|
||||
write(*,'(1000(F16.10,X))') S(i,:)
|
||||
enddo
|
||||
|
||||
!print *, ' overlap matrix:'
|
||||
!do i = 1, m
|
||||
! write(*,'(1000(F16.10,X))') S(i,:)
|
||||
!enddo
|
||||
|
||||
accu_d = 0.d0
|
||||
accu_nd = 0.d0
|
||||
|
@ -1877,12 +1883,12 @@ subroutine check_biorthog(n, m, Vl, Vr, accu_d, accu_nd, S, thr_d, thr_nd, stop_
|
|||
enddo
|
||||
accu_nd = dsqrt(accu_nd) / dble(m)
|
||||
|
||||
print *, ' accu_nd = ', accu_nd
|
||||
print *, ' accu_d = ', dabs(accu_d-dble(m))/dble(m)
|
||||
!print *, ' accu_nd = ', accu_nd
|
||||
!print *, ' accu_d = ', dabs(accu_d-dble(m))/dble(m)
|
||||
|
||||
! ---
|
||||
|
||||
if( stop_ifnot .and. ((accu_nd .gt. thr_nd) .or. dabs(accu_d-dble(m))/dble(m) .gt. thr_d) ) then
|
||||
if(stop_ifnot .and. ((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)
|
||||
|
@ -1912,12 +1918,12 @@ subroutine check_orthog(n, m, V, accu_d, accu_nd, S)
|
|||
, V, size(V, 1), V, size(V, 1) &
|
||||
, 0.d0, S, size(S, 1) )
|
||||
|
||||
print *, ''
|
||||
print *, ' overlap matrix:'
|
||||
do i = 1, m
|
||||
write(*,'(1000(F16.10,X))') S(i,:)
|
||||
enddo
|
||||
print *, ''
|
||||
!print *, ''
|
||||
!print *, ' overlap matrix:'
|
||||
!do i = 1, m
|
||||
! write(*,'(1000(F16.10,X))') S(i,:)
|
||||
!enddo
|
||||
!print *, ''
|
||||
|
||||
accu_d = 0.d0
|
||||
accu_nd = 0.d0
|
||||
|
@ -1981,11 +1987,11 @@ subroutine impose_biorthog_degen_eigvec(n, e0, L0, R0)
|
|||
enddo
|
||||
enddo
|
||||
|
||||
do i = 1, n
|
||||
if(deg_num(i).gt.1) then
|
||||
print *, ' degen on', i, deg_num(i), e0(i)
|
||||
endif
|
||||
enddo
|
||||
!do i = 1, n
|
||||
! if(deg_num(i) .gt. 1) then
|
||||
! print *, ' degen on', i, deg_num(i), e0(i)
|
||||
! endif
|
||||
!enddo
|
||||
|
||||
! ---
|
||||
|
||||
|
@ -2181,11 +2187,11 @@ subroutine impose_unique_biorthog_degen_eigvec(n, thr_d, thr_nd, e0, C0, W0, L0,
|
|||
enddo
|
||||
enddo
|
||||
|
||||
do i = 1, n
|
||||
if(deg_num(i).gt.1) then
|
||||
print *, ' degen on', i, deg_num(i)
|
||||
endif
|
||||
enddo
|
||||
!do i = 1, n
|
||||
! if(deg_num(i) .gt. 1) then
|
||||
! print *, ' degen on', i, deg_num(i)
|
||||
! endif
|
||||
!enddo
|
||||
|
||||
! ---
|
||||
|
||||
|
@ -2414,10 +2420,10 @@ subroutine impose_biorthog_svd(n, m, L, R)
|
|||
, L, size(L, 1), R, size(R, 1) &
|
||||
, 0.d0, S, size(S, 1) )
|
||||
|
||||
print *, ' overlap bef SVD: '
|
||||
do i = 1, m
|
||||
write(*, '(1000(F16.10,X))') S(i,:)
|
||||
enddo
|
||||
!print *, ' overlap bef SVD: '
|
||||
!do i = 1, m
|
||||
! write(*, '(1000(F16.10,X))') S(i,:)
|
||||
!enddo
|
||||
|
||||
! ---
|
||||
|
||||
|
@ -2489,10 +2495,11 @@ subroutine impose_biorthog_svd(n, m, L, R)
|
|||
, 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
|
||||
!print *, ' overlap aft SVD: '
|
||||
!do i = 1, m
|
||||
! write(*, '(1000(F16.10,X))') S(i,:)
|
||||
!enddo
|
||||
|
||||
deallocate(S)
|
||||
|
||||
! ---
|
||||
|
@ -2806,10 +2813,10 @@ subroutine impose_weighted_biorthog_svd(n, m, overlap, L, R)
|
|||
, 0.d0, S, size(S, 1) )
|
||||
deallocate(Stmp)
|
||||
|
||||
print *, ' overlap bef SVD: '
|
||||
do i = 1, m
|
||||
write(*, '(1000(F25.16,X))') S(i,:)
|
||||
enddo
|
||||
!print *, ' overlap bef SVD: '
|
||||
!do i = 1, m
|
||||
! write(*, '(1000(F25.16,X))') S(i,:)
|
||||
!enddo
|
||||
|
||||
! ---
|
||||
|
||||
|
@ -2886,10 +2893,11 @@ subroutine impose_weighted_biorthog_svd(n, m, overlap, L, R)
|
|||
, 0.d0, S, size(S, 1) )
|
||||
deallocate(Stmp)
|
||||
|
||||
print *, ' overlap aft SVD with overlap: '
|
||||
do i = 1, m
|
||||
write(*, '(1000(F16.10,X))') S(i,:)
|
||||
enddo
|
||||
!print *, ' overlap aft SVD with overlap: '
|
||||
!do i = 1, m
|
||||
! write(*, '(1000(F16.10,X))') S(i,:)
|
||||
!enddo
|
||||
|
||||
deallocate(S)
|
||||
|
||||
return
|
||||
|
|
|
@ -132,9 +132,9 @@ subroutine non_hrmt_diag_split_degen_bi_orthog(n, A, leigvec, reigvec, n_real_ei
|
|||
|
||||
!!! ONCE ALL EIGENVALUES ARE REAL ::: CHECK BI-ORTHONORMALITY
|
||||
! check bi-orthogonality
|
||||
call check_biorthog(n, n, leigvec_tmp, reigvec_tmp, accu_d, accu_nd, S, .false.)
|
||||
call check_biorthog(n, n, leigvec_tmp, reigvec_tmp, accu_d, accu_nd, S, thresh_biorthog_diag, thresh_biorthog_nondiag, .false.)
|
||||
print *, ' accu_nd bi-orthog = ', accu_nd
|
||||
if( accu_nd .lt. 1d-10 ) then
|
||||
if(accu_nd .lt. thresh_biorthog_nondiag) then
|
||||
print *, ' bi-orthogonality: ok'
|
||||
else
|
||||
print *, ' '
|
||||
|
@ -149,14 +149,14 @@ subroutine non_hrmt_diag_split_degen_bi_orthog(n, A, leigvec, reigvec, n_real_ei
|
|||
deallocate(S_nh_inv_half)
|
||||
call impose_orthog_degen_eigvec(n, eigval, reigvec_tmp)
|
||||
call impose_orthog_degen_eigvec(n, eigval, leigvec_tmp)
|
||||
call check_biorthog(n, n, leigvec_tmp, reigvec_tmp, accu_d, accu_nd, S, .false.)
|
||||
if( accu_nd .lt. 1d-10 ) then
|
||||
call check_biorthog(n, n, leigvec_tmp, reigvec_tmp, accu_d, accu_nd, S, thresh_biorthog_diag, thresh_biorthog_nondiag, .false.)
|
||||
if(accu_nd .lt. thresh_biorthog_nondiag) then
|
||||
print *, ' bi-orthogonality: ok'
|
||||
else
|
||||
print*,'New vectors not bi-orthonormals at ',accu_nd
|
||||
call impose_biorthog_qr(n, n, leigvec_tmp, reigvec_tmp, S)
|
||||
call check_biorthog(n, n, leigvec_tmp, reigvec_tmp, accu_d, accu_nd, S, .false.)
|
||||
if( accu_nd .lt. 1d-10 ) then
|
||||
call check_biorthog(n, n, leigvec_tmp, reigvec_tmp, accu_d, accu_nd, S, thresh_biorthog_diag, thresh_biorthog_nondiag, .false.)
|
||||
if(accu_nd .lt. thresh_biorthog_nondiag) then
|
||||
print *, ' bi-orthogonality: ok'
|
||||
else
|
||||
print*,'New vectors not bi-orthonormals at ',accu_nd
|
||||
|
@ -200,10 +200,10 @@ subroutine non_hrmt_diag_split_degen_bi_orthog(n, A, leigvec, reigvec, n_real_ei
|
|||
shift_current = max(1.d-10,shift_current)
|
||||
print*,'Thr for eigenvectors = ',shift_current
|
||||
call check_EIGVEC(n, n, A, eigval, leigvec, reigvec, shift_current, thr_norm, .false.)
|
||||
call check_biorthog(n, n, leigvec, reigvec, accu_d, accu_nd, S, .false.)
|
||||
call check_biorthog(n, n, leigvec, reigvec, accu_d, accu_nd, S, thresh_biorthog_diag, thresh_biorthog_nondiag, .false.)
|
||||
print *, ' accu_nd bi-orthog = ', accu_nd
|
||||
|
||||
if( accu_nd .lt. 1d-10 ) then
|
||||
if(accu_nd .lt. thresh_biorthog_nondiag) then
|
||||
print *, ' bi-orthogonality: ok'
|
||||
else
|
||||
print*,'Something went wrong in non_hrmt_diag_split_degen_bi_orthog'
|
||||
|
@ -354,14 +354,14 @@ subroutine non_hrmt_diag_split_degen_s_inv_half(n, A, leigvec, reigvec, n_real_e
|
|||
|
||||
!!! ONCE ALL EIGENVALUES ARE REAL ::: CHECK BI-ORTHONORMALITY
|
||||
! check bi-orthogonality
|
||||
call check_biorthog(n, n, leigvec_tmp, reigvec_tmp, accu_d, accu_nd, S, .false.)
|
||||
call check_biorthog(n, n, leigvec_tmp, reigvec_tmp, accu_d, accu_nd, S, thresh_biorthog_diag, thresh_biorthog_nondiag, .false.)
|
||||
print *, ' accu_nd bi-orthog = ', accu_nd
|
||||
if( accu_nd .lt. 1d-10 ) then
|
||||
if(accu_nd .lt. thresh_biorthog_nondiag) then
|
||||
print *, ' bi-orthogonality: ok'
|
||||
else
|
||||
print *, ' '
|
||||
print *, ' bi-orthogonality: not imposed yet'
|
||||
if(complex_root)then
|
||||
if(complex_root) then
|
||||
print *, ' '
|
||||
print *, ' '
|
||||
print *, ' orthog between degen eigenvect'
|
||||
|
@ -369,15 +369,15 @@ subroutine non_hrmt_diag_split_degen_s_inv_half(n, A, leigvec, reigvec, n_real_e
|
|||
! bi-orthonormalization using orthogonalization of left, right and then QR between left and right
|
||||
call impose_orthog_degen_eigvec(n, eigval, reigvec_tmp) ! orthogonalization of reigvec
|
||||
call impose_orthog_degen_eigvec(n, eigval, leigvec_tmp) ! orthogonalization of leigvec
|
||||
call check_biorthog(n, n, leigvec_tmp, reigvec_tmp, accu_d, accu_nd, S)
|
||||
call check_biorthog(n, n, leigvec_tmp, reigvec_tmp, accu_d, accu_nd, S, thresh_biorthog_diag, thresh_biorthog_nondiag, .false.)
|
||||
|
||||
if( accu_nd .lt. 1d-10 ) then
|
||||
if(accu_nd .lt. thresh_biorthog_nondiag) then
|
||||
print *, ' bi-orthogonality: ok'
|
||||
else
|
||||
print*,'New vectors not bi-orthonormals at ', accu_nd
|
||||
call get_inv_half_nonsymmat_diago(S, n, S_nh_inv_half, complex_root)
|
||||
if(complex_root)then
|
||||
call impose_biorthog_qr(n, n, leigvec_tmp, reigvec_tmp) ! bi-orthonormalization using QR
|
||||
call impose_biorthog_qr(n, n, leigvec_tmp, reigvec_tmp, S) ! bi-orthonormalization using QR
|
||||
else
|
||||
print*,'S^{-1/2} exists !!'
|
||||
call bi_ortho_s_inv_half(n,leigvec_tmp,reigvec_tmp,S_nh_inv_half) ! use of S^{-1/2} bi-orthonormalization
|
||||
|
@ -387,8 +387,8 @@ subroutine non_hrmt_diag_split_degen_s_inv_half(n, A, leigvec, reigvec, n_real_e
|
|||
print*,'S^{-1/2} exists !!'
|
||||
call bi_ortho_s_inv_half(n,leigvec_tmp,reigvec_tmp,S_nh_inv_half) ! use of S^{-1/2} bi-orthonormalization
|
||||
endif
|
||||
call check_biorthog(n, n, leigvec_tmp, reigvec_tmp, accu_d, accu_nd, S, .false.)
|
||||
if( accu_nd .lt. 1d-10 ) then
|
||||
call check_biorthog(n, n, leigvec_tmp, reigvec_tmp, accu_d, accu_nd, S, thresh_biorthog_diag, thresh_biorthog_nondiag, .false.)
|
||||
if(accu_nd .lt. thresh_biorthog_nondiag) then
|
||||
print *, ' bi-orthogonality: ok'
|
||||
else
|
||||
print*,'New vectors not bi-orthonormals at ',accu_nd
|
||||
|
@ -431,10 +431,10 @@ subroutine non_hrmt_diag_split_degen_s_inv_half(n, A, leigvec, reigvec, n_real_e
|
|||
shift_current = max(1.d-10,shift_current)
|
||||
print*,'Thr for eigenvectors = ',shift_current
|
||||
call check_EIGVEC(n, n, A, eigval, leigvec, reigvec, shift_current, thr_norm, .false.)
|
||||
call check_biorthog(n, n, leigvec, reigvec, accu_d, accu_nd, S, .false.)
|
||||
call check_biorthog(n, n, leigvec, reigvec, accu_d, accu_nd, S, thresh_biorthog_diag, thresh_biorthog_nondiag, .false.)
|
||||
print *, ' accu_nd bi-orthog = ', accu_nd
|
||||
|
||||
if( accu_nd .lt. 1d-10 ) then
|
||||
if(accu_nd .lt. thresh_biorthog_nondiag) then
|
||||
print *, ' bi-orthogonality: ok'
|
||||
else
|
||||
print*,'Something went wrong in non_hrmt_diag_split_degen_bi_orthog'
|
||||
|
@ -472,6 +472,7 @@ subroutine non_hrmt_fock_mat(n, A, leigvec, reigvec, n_real_eigv, eigval)
|
|||
double precision :: accu,thr_cut
|
||||
double precision, allocatable :: S_nh_inv_half(:,:)
|
||||
logical :: complex_root
|
||||
double precision :: thr_norm=1d0
|
||||
|
||||
|
||||
thr_cut = 1.d-15
|
||||
|
@ -580,9 +581,9 @@ subroutine non_hrmt_fock_mat(n, A, leigvec, reigvec, n_real_eigv, eigval)
|
|||
|
||||
!!! ONCE ALL EIGENVALUES ARE REAL ::: CHECK BI-ORTHONORMALITY
|
||||
! check bi-orthogonality
|
||||
call check_biorthog(n, n, leigvec_tmp, reigvec_tmp, accu_d, accu_nd, S)
|
||||
call check_biorthog(n, n, leigvec_tmp, reigvec_tmp, accu_d, accu_nd, S, thresh_biorthog_diag, thresh_biorthog_nondiag, .false.)
|
||||
print *, ' accu_nd bi-orthog = ', accu_nd
|
||||
if( accu_nd .lt. 1d-10 ) then
|
||||
if(accu_nd .lt. thresh_biorthog_nondiag) then
|
||||
print *, ' bi-orthogonality: ok'
|
||||
else
|
||||
print *, ' '
|
||||
|
@ -593,9 +594,9 @@ subroutine non_hrmt_fock_mat(n, A, leigvec, reigvec, n_real_eigv, eigval)
|
|||
print *, ' '
|
||||
! bi-orthonormalization using orthogonalization of left, right and then QR between left and right
|
||||
call impose_unique_biorthog_degen_eigvec(n, eigval, mo_coef, leigvec_tmp, reigvec_tmp)
|
||||
call check_biorthog(n, n, leigvec_tmp, reigvec_tmp, accu_d, accu_nd, S)
|
||||
call check_biorthog(n, n, leigvec_tmp, reigvec_tmp, accu_d, accu_nd, S, thresh_biorthog_diag, thresh_biorthog_nondiag, .false.)
|
||||
print*,'accu_nd = ',accu_nd
|
||||
if( accu_nd .lt. 1d-10 ) then
|
||||
if(accu_nd .lt. thresh_biorthog_nondiag) then
|
||||
print *, ' bi-orthogonality: ok'
|
||||
else
|
||||
print*,'New vectors not bi-orthonormals at ',accu_nd
|
||||
|
@ -608,8 +609,8 @@ subroutine non_hrmt_fock_mat(n, A, leigvec, reigvec, n_real_eigv, eigval)
|
|||
call bi_ortho_s_inv_half(n,leigvec_tmp,reigvec_tmp,S_nh_inv_half) ! use of S^{-1/2} bi-orthonormalization
|
||||
endif
|
||||
endif
|
||||
call check_biorthog(n, n, leigvec_tmp, reigvec_tmp, accu_d, accu_nd, S)
|
||||
if( accu_nd .lt. 1d-10 ) then
|
||||
call check_biorthog(n, n, leigvec_tmp, reigvec_tmp, accu_d, accu_nd, S, thresh_biorthog_diag, thresh_biorthog_nondiag, .false.)
|
||||
if(accu_nd .lt. thresh_biorthog_nondiag) then
|
||||
print *, ' bi-orthogonality: ok'
|
||||
else
|
||||
print*,'New vectors not bi-orthonormals at ',accu_nd
|
||||
|
@ -651,11 +652,11 @@ subroutine non_hrmt_fock_mat(n, A, leigvec, reigvec, n_real_eigv, eigval)
|
|||
print*,'Checking for final reigvec/leigvec'
|
||||
shift_current = max(1.d-10,shift_current)
|
||||
print*,'Thr for eigenvectors = ',shift_current
|
||||
call check_EIGVEC(n, n, A, eigval, leigvec, reigvec,shift_current)
|
||||
call check_biorthog(n, n, leigvec, reigvec, accu_d, accu_nd, S)
|
||||
call check_EIGVEC(n, n, A, eigval, leigvec, reigvec, shift_current, thr_norm, .false.)
|
||||
call check_biorthog(n, n, leigvec, reigvec, accu_d, accu_nd, S, thresh_biorthog_diag, thresh_biorthog_nondiag, .false.)
|
||||
print *, ' accu_nd bi-orthog = ', accu_nd
|
||||
|
||||
if( accu_nd .lt. 1d-10 ) then
|
||||
if(accu_nd .lt. thresh_biorthog_nondiag) then
|
||||
print *, ' bi-orthogonality: ok'
|
||||
else
|
||||
print*,'Something went wrong in non_hrmt_diag_split_degen_bi_orthog'
|
||||
|
|
|
@ -37,3 +37,27 @@ type: logical
|
|||
doc: If true, the calculation uses periodic boundary conditions
|
||||
interface: ezfio, provider, ocaml
|
||||
default: false
|
||||
|
||||
[n_pts_charge]
|
||||
type: integer
|
||||
doc: Number of point charges to be added to the potential
|
||||
interface: ezfio
|
||||
default: 0
|
||||
|
||||
[pts_charge_z]
|
||||
type: double precision
|
||||
doc: Charge associated to each point charge
|
||||
interface: ezfio
|
||||
size: (nuclei.n_pts_charge)
|
||||
|
||||
[pts_charge_coord]
|
||||
type: double precision
|
||||
doc: Coordinate of each point charge.
|
||||
interface: ezfio
|
||||
size: (nuclei.n_pts_charge,3)
|
||||
|
||||
[point_charges]
|
||||
type: logical
|
||||
doc: If |true|, point charges (see nuclei/write_pt_charges.py) are added to the one-electron potential
|
||||
interface: ezfio,provider,ocaml
|
||||
default: False
|
||||
|
|
|
@ -205,6 +205,9 @@ BEGIN_PROVIDER [ double precision, nuclear_repulsion ]
|
|||
enddo
|
||||
enddo
|
||||
nuclear_repulsion *= 0.5d0
|
||||
if(point_charges)then
|
||||
nuclear_repulsion += pt_chrg_nuclei_repulsion + pt_chrg_repulsion
|
||||
endif
|
||||
end if
|
||||
|
||||
call write_time(6)
|
||||
|
|
209
src/nuclei/point_charges.irp.f
Normal file
209
src/nuclei/point_charges.irp.f
Normal file
|
@ -0,0 +1,209 @@
|
|||
! ---
|
||||
|
||||
|
||||
BEGIN_PROVIDER [ integer, n_pts_charge ]
|
||||
implicit none
|
||||
BEGIN_DOC
|
||||
! Number of point charges to be added to the potential
|
||||
END_DOC
|
||||
|
||||
logical :: has
|
||||
PROVIDE ezfio_filename
|
||||
if (mpi_master) then
|
||||
|
||||
call ezfio_has_nuclei_n_pts_charge(has)
|
||||
if (has) then
|
||||
write(6,'(A)') '.. >>>>> [ IO READ: n_pts_charge ] <<<<< ..'
|
||||
call ezfio_get_nuclei_n_pts_charge(n_pts_charge)
|
||||
else
|
||||
print *, 'nuclei/n_pts_charge not found in EZFIO file'
|
||||
stop 1
|
||||
endif
|
||||
endif
|
||||
IRP_IF MPI_DEBUG
|
||||
print *, irp_here, mpi_rank
|
||||
call MPI_BARRIER(MPI_COMM_WORLD, ierr)
|
||||
IRP_ENDIF
|
||||
IRP_IF MPI
|
||||
include 'mpif.h'
|
||||
integer :: ierr
|
||||
call MPI_BCAST( n_pts_charge, 1, MPI_INTEGER, 0, MPI_COMM_WORLD, ierr)
|
||||
if (ierr /= MPI_SUCCESS) then
|
||||
stop 'Unable to read n_pts_charge with MPI'
|
||||
endif
|
||||
IRP_ENDIF
|
||||
|
||||
call write_time(6)
|
||||
|
||||
END_PROVIDER
|
||||
|
||||
BEGIN_PROVIDER [ double precision, pts_charge_z, (n_pts_charge) ]
|
||||
|
||||
BEGIN_DOC
|
||||
! Charge associated to each point charge.
|
||||
END_DOC
|
||||
|
||||
implicit none
|
||||
logical :: exists
|
||||
|
||||
PROVIDE ezfio_filename
|
||||
|
||||
if (mpi_master) then
|
||||
call ezfio_has_nuclei_pts_charge_z(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(pts_charge_z, (n_pts_charge), MPI_DOUBLE_PRECISION, 0, MPI_COMM_WORLD, ierr)
|
||||
if (ierr /= MPI_SUCCESS) then
|
||||
stop 'Unable to read pts_charge_z with MPI'
|
||||
endif
|
||||
IRP_ENDIF
|
||||
|
||||
if (exists) then
|
||||
|
||||
if (mpi_master) then
|
||||
write(6,'(A)') '.. >>>>> [ IO READ: pts_charge_z ] <<<<< ..'
|
||||
call ezfio_get_nuclei_pts_charge_z(pts_charge_z)
|
||||
IRP_IF MPI
|
||||
call MPI_BCAST(pts_charge_z, (n_pts_charge), MPI_DOUBLE_PRECISION, 0, MPI_COMM_WORLD, ierr)
|
||||
if (ierr /= MPI_SUCCESS) then
|
||||
stop 'Unable to read pts_charge_z with MPI'
|
||||
endif
|
||||
IRP_ENDIF
|
||||
endif
|
||||
|
||||
else
|
||||
|
||||
integer :: i
|
||||
do i = 1, n_pts_charge
|
||||
pts_charge_z(i) = 0.d0
|
||||
enddo
|
||||
|
||||
endif
|
||||
print*,'Point charges '
|
||||
do i = 1, n_pts_charge
|
||||
print*,'i,pts_charge_z(i)',i,pts_charge_z(i)
|
||||
enddo
|
||||
|
||||
END_PROVIDER
|
||||
|
||||
|
||||
BEGIN_PROVIDER [ double precision, pts_charge_coord, (n_pts_charge,3) ]
|
||||
|
||||
BEGIN_DOC
|
||||
! Coordinates of each point charge.
|
||||
END_DOC
|
||||
|
||||
implicit none
|
||||
logical :: exists
|
||||
|
||||
PROVIDE ezfio_filename
|
||||
|
||||
if (mpi_master) then
|
||||
call ezfio_has_nuclei_pts_charge_coord(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(pts_charge_coord, (n_pts_charge), MPI_DOUBLE_PRECISION, 0, MPI_COMM_WORLD, ierr)
|
||||
if (ierr /= MPI_SUCCESS) then
|
||||
stop 'Unable to read pts_charge_coord with MPI'
|
||||
endif
|
||||
IRP_ENDIF
|
||||
|
||||
if (exists) then
|
||||
|
||||
if (mpi_master) then
|
||||
double precision, allocatable :: buffer(:,:)
|
||||
allocate (buffer(n_pts_charge,3))
|
||||
write(6,'(A)') '.. >>>>> [ IO READ: pts_charge_coord ] <<<<< ..'
|
||||
call ezfio_get_nuclei_pts_charge_coord(buffer)
|
||||
integer :: i,j
|
||||
do i=1,3
|
||||
do j=1,n_pts_charge
|
||||
pts_charge_coord(j,i) = buffer(j,i)
|
||||
enddo
|
||||
enddo
|
||||
deallocate(buffer)
|
||||
IRP_IF MPI
|
||||
call MPI_BCAST(pts_charge_coord, (n_pts_charge), MPI_DOUBLE_PRECISION, 0, MPI_COMM_WORLD, ierr)
|
||||
if (ierr /= MPI_SUCCESS) then
|
||||
stop 'Unable to read pts_charge_coord with MPI'
|
||||
endif
|
||||
IRP_ENDIF
|
||||
endif
|
||||
|
||||
else
|
||||
|
||||
do i = 1, n_pts_charge
|
||||
pts_charge_coord(i,:) = 0.d0
|
||||
enddo
|
||||
|
||||
endif
|
||||
print*,'Coordinates for the point charges '
|
||||
do i = 1, n_pts_charge
|
||||
write(*,'(I3,X,3(F16.8,X))') i,pts_charge_coord(i,1:3)
|
||||
enddo
|
||||
|
||||
END_PROVIDER
|
||||
|
||||
! ---
|
||||
BEGIN_PROVIDER [ double precision, pt_chrg_repulsion]
|
||||
implicit none
|
||||
BEGIN_DOC
|
||||
! repulsion between the point charges
|
||||
END_DOC
|
||||
integer :: i,j
|
||||
double precision :: Z_A, z_B,A_center(3), B_center(3), dist
|
||||
pt_chrg_repulsion = 0.d0
|
||||
do i = 1, n_pts_charge
|
||||
Z_A = pts_charge_z(i)
|
||||
A_center(1:3) = pts_charge_coord(i,1:3)
|
||||
do j = i+1, n_pts_charge
|
||||
Z_B = pts_charge_z(j)
|
||||
B_center(1:3) = pts_charge_coord(j,1:3)
|
||||
dist = (A_center(1)-B_center(1))**2 + (A_center(2)-B_center(2))**2 + (A_center(3)-B_center(3))**2
|
||||
dist = dsqrt(dist)
|
||||
pt_chrg_repulsion += Z_A*Z_B/dist
|
||||
enddo
|
||||
enddo
|
||||
print*,'Repulsion of point charges '
|
||||
print*,'pt_chrg_repulsion = ',pt_chrg_repulsion
|
||||
END_PROVIDER
|
||||
|
||||
BEGIN_PROVIDER [ double precision, pt_chrg_nuclei_repulsion]
|
||||
implicit none
|
||||
BEGIN_DOC
|
||||
! repulsion between the point charges and the nuclei
|
||||
END_DOC
|
||||
integer :: i,j
|
||||
double precision :: Z_A, z_B,A_center(3), B_center(3), dist
|
||||
pt_chrg_nuclei_repulsion = 0.d0
|
||||
do i = 1, n_pts_charge
|
||||
Z_A = pts_charge_z(i)
|
||||
A_center(1:3) = pts_charge_coord(i,1:3)
|
||||
do j = 1, nucl_num
|
||||
Z_B = nucl_charge(j)
|
||||
B_center(1:3) = nucl_coord(j,1:3)
|
||||
dist = (A_center(1)-B_center(1))**2 + (A_center(2)-B_center(2))**2 + (A_center(3)-B_center(3))**2
|
||||
dist = dsqrt(dist)
|
||||
pt_chrg_nuclei_repulsion += Z_A*Z_B/dist
|
||||
enddo
|
||||
enddo
|
||||
print*,'Repulsion between point charges and nuclei'
|
||||
print*,'pt_chrg_nuclei_repulsion = ',pt_chrg_nuclei_repulsion
|
||||
END_PROVIDER
|
||||
|
79
src/nuclei/write_pt_charges.py
Executable file
79
src/nuclei/write_pt_charges.py
Executable file
|
@ -0,0 +1,79 @@
|
|||
#!/usr/bin/env python
|
||||
import os
|
||||
import sys
|
||||
|
||||
# First argument is the EZFIO file
|
||||
# It reads a file EZFIO_point_charges.xyz written in this way:
|
||||
# charge x y z (Angstrom)
|
||||
# for all charges
|
||||
|
||||
|
||||
def zip_in_ezfio(ezfio,tmp):
|
||||
tmpzip=tmp+".gz"
|
||||
cmdzip="gzip -c "+tmp+" > "+tmpzip
|
||||
os.system(cmdzip)
|
||||
os.system("rm "+tmp)
|
||||
cmdmv="mv "+tmpzip+" "+EZFIO+"/nuclei/"+tmpzip
|
||||
os.system(cmdmv)
|
||||
|
||||
def mv_in_ezfio(ezfio,tmp):
|
||||
cmdmv="mv "+tmp+" "+EZFIO+"/nuclei/"+tmp
|
||||
os.system(cmdmv)
|
||||
|
||||
|
||||
# Getting the EZFIO
|
||||
EZFIO=sys.argv[1]
|
||||
EZFIO=EZFIO.replace("/", "")
|
||||
print(EZFIO)
|
||||
|
||||
# Reading the point charges and convert the Angstrom geometry in Bohr for QP
|
||||
f = open(EZFIO+'_point_charges.xyz','r')
|
||||
lines = f.readlines()
|
||||
convert_angs_to_bohr=1.8897259885789233
|
||||
|
||||
n_charges=0
|
||||
coord_x=[]
|
||||
coord_y=[]
|
||||
coord_z=[]
|
||||
charges=[]
|
||||
for line in lines:
|
||||
data = line.split()
|
||||
if(len(data)>0):
|
||||
n_charges += 1
|
||||
charges.append(str(data[0]))
|
||||
coord_x.append(str(convert_angs_to_bohr*float(data[1])))
|
||||
coord_y.append(str(convert_angs_to_bohr*float(data[2])))
|
||||
coord_z.append(str(convert_angs_to_bohr*float(data[3])))
|
||||
|
||||
# Write the file containing the number of charges and set in EZFIO folder
|
||||
tmp="n_pts_charge"
|
||||
fncharges = open(tmp,'w')
|
||||
fncharges.write(" "+str(n_charges)+'\n')
|
||||
fncharges.close()
|
||||
mv_in_ezfio(EZFIO,tmp)
|
||||
|
||||
# Write the file containing the charges and set in EZFIO folder
|
||||
tmp="pts_charge_z"
|
||||
fcharges = open(tmp,'w')
|
||||
fcharges.write(" 1\n")
|
||||
fcharges.write(" "+str(n_charges)+'\n')
|
||||
for i in range(n_charges):
|
||||
fcharges.write(charges[i]+'\n')
|
||||
fcharges.close()
|
||||
zip_in_ezfio(EZFIO,tmp)
|
||||
|
||||
# Write the file containing the charge coordinates and set in EZFIO folder
|
||||
tmp="pts_charge_coord"
|
||||
fcoord = open(tmp,'w')
|
||||
fcoord.write(" 2\n")
|
||||
fcoord.write(" "+str(n_charges)+' 3\n')
|
||||
#fcoord.write(" "+' 3 '+str(n_charges)+' \n')
|
||||
for i in range(n_charges):
|
||||
fcoord.write(' '+coord_x[i]+'\n')
|
||||
for i in range(n_charges):
|
||||
fcoord.write(' '+coord_y[i]+'\n')
|
||||
for i in range(n_charges):
|
||||
fcoord.write(' '+coord_z[i]+'\n')
|
||||
fcoord.close()
|
||||
zip_in_ezfio(EZFIO,tmp)
|
||||
|
|
@ -20,6 +20,12 @@ BEGIN_PROVIDER [ double precision, eigenvectors_Fock_matrix_mo, (ao_num,mo_num)
|
|||
enddo
|
||||
enddo
|
||||
|
||||
!print *, ' Fock_matrix_MO :'
|
||||
!do i = 1, mo_num
|
||||
! write(*, '(100(f15.7, 2x))') (Fock_matrix_MO(j,i), j = 1, mo_num)
|
||||
!enddo
|
||||
|
||||
|
||||
if(frozen_orb_scf)then
|
||||
integer :: iorb,jorb
|
||||
do i = 1, n_core_orb
|
||||
|
@ -57,7 +63,6 @@ BEGIN_PROVIDER [ double precision, eigenvectors_Fock_matrix_mo, (ao_num,mo_num)
|
|||
do i = elec_beta_num+1, elec_alpha_num
|
||||
F(i,i) += 0.5d0*level_shift
|
||||
enddo
|
||||
|
||||
do i = elec_alpha_num+1, mo_num
|
||||
F(i,i) += level_shift
|
||||
enddo
|
||||
|
@ -90,6 +95,10 @@ BEGIN_PROVIDER [ double precision, eigenvectors_Fock_matrix_mo, (ao_num,mo_num)
|
|||
call dsyevd( 'V', 'U', mo_num, F, &
|
||||
size(F,1), diag, work, lwork, iwork, liwork, info)
|
||||
deallocate(iwork)
|
||||
!print*, ' Fock eigval:'
|
||||
!do i = 1, mo_num
|
||||
! print *, diag(i)
|
||||
!enddo
|
||||
|
||||
|
||||
if (info /= 0) then
|
||||
|
|
|
@ -1,3 +1,5 @@
|
|||
! ---
|
||||
|
||||
BEGIN_PROVIDER [ double precision, threshold_DIIS_nonzero ]
|
||||
implicit none
|
||||
BEGIN_DOC
|
||||
|
@ -12,6 +14,8 @@ BEGIN_PROVIDER [ double precision, threshold_DIIS_nonzero ]
|
|||
|
||||
END_PROVIDER
|
||||
|
||||
! ---
|
||||
|
||||
BEGIN_PROVIDER [double precision, FPS_SPF_Matrix_AO, (AO_num, AO_num)]
|
||||
implicit none
|
||||
BEGIN_DOC
|
||||
|
@ -60,6 +64,8 @@ BEGIN_PROVIDER [double precision, FPS_SPF_Matrix_AO, (AO_num, AO_num)]
|
|||
|
||||
END_PROVIDER
|
||||
|
||||
! ---
|
||||
|
||||
BEGIN_PROVIDER [double precision, FPS_SPF_Matrix_MO, (mo_num, mo_num)]
|
||||
implicit none
|
||||
begin_doc
|
||||
|
@ -69,6 +75,7 @@ BEGIN_PROVIDER [double precision, FPS_SPF_Matrix_MO, (mo_num, mo_num)]
|
|||
FPS_SPF_Matrix_MO, size(FPS_SPF_Matrix_MO,1))
|
||||
END_PROVIDER
|
||||
|
||||
! ---
|
||||
|
||||
BEGIN_PROVIDER [ double precision, eigenvalues_Fock_matrix_AO, (AO_num) ]
|
||||
&BEGIN_PROVIDER [ double precision, eigenvectors_Fock_matrix_AO, (AO_num,AO_num) ]
|
||||
|
@ -137,3 +144,175 @@ END_PROVIDER
|
|||
|
||||
END_PROVIDER
|
||||
|
||||
! ---
|
||||
|
||||
!BEGIN_PROVIDER [double precision, error_diis_Fmo, (ao_num, ao_num)]
|
||||
!
|
||||
! BEGIN_DOC
|
||||
! !
|
||||
! ! error_diis_Fmo = (S x C) x [F_mo x \eta_occ - \eta_occ x F_mo] x (S x C).T
|
||||
! !
|
||||
! ! \eta_occ is the matrix of occupation : \eta_occ = \eta_occ(alpha) + \eta_occ(beta)
|
||||
! !
|
||||
! END_DOC
|
||||
!
|
||||
! implicit none
|
||||
! integer :: i, j
|
||||
! double precision, allocatable :: tmp(:,:)
|
||||
!
|
||||
! provide Fock_matrix_mo
|
||||
!
|
||||
! allocate(tmp(mo_num,mo_num))
|
||||
! tmp = 0.d0
|
||||
!
|
||||
! ! F_mo x \eta_occ(alpha) - \eta_occ x F_mo(alpha)
|
||||
! do j = 1, elec_alpha_num
|
||||
! do i = elec_alpha_num + 1, mo_num
|
||||
! tmp(i,j) = Fock_matrix_mo(i,j)
|
||||
! enddo
|
||||
! enddo
|
||||
! do j = elec_alpha_num + 1, mo_num
|
||||
! do i = 1, elec_alpha_num
|
||||
! tmp(i,j) = -Fock_matrix_mo(i,j)
|
||||
! enddo
|
||||
! enddo
|
||||
!
|
||||
! ! F_mo x \eta_occ(beta) - \eta_occ x F_mo(beta)
|
||||
! do j = 1, elec_beta_num
|
||||
! do i = elec_beta_num + 1, mo_num
|
||||
! tmp(i,j) += Fock_matrix_mo(i,j)
|
||||
! enddo
|
||||
! enddo
|
||||
! do j = elec_beta_num + 1, mo_num
|
||||
! do i = 1, elec_beta_num
|
||||
! tmp(i,j) -= Fock_matrix_mo(i,j)
|
||||
! enddo
|
||||
! enddo
|
||||
!
|
||||
! call mo_to_ao(tmp, size(tmp, 1), error_diis_Fmo, size(error_diis_Fmo, 1))
|
||||
!
|
||||
! deallocate(tmp)
|
||||
!
|
||||
!END_PROVIDER
|
||||
|
||||
! ---
|
||||
|
||||
BEGIN_PROVIDER [double precision, error_diis_Fmo, (mo_num, mo_num)]
|
||||
|
||||
BEGIN_DOC
|
||||
!
|
||||
! error_diis_Fmo = [F_mo x \eta_occ - \eta_occ x F_mo]
|
||||
!
|
||||
! \eta_occ is the matrix of occupation : \eta_occ = \eta_occ(alpha) + \eta_occ(beta)
|
||||
!
|
||||
END_DOC
|
||||
|
||||
implicit none
|
||||
integer :: i, j
|
||||
double precision, allocatable :: tmp(:,:)
|
||||
|
||||
provide Fock_matrix_mo
|
||||
|
||||
error_diis_Fmo = 0.d0
|
||||
|
||||
! F_mo x \eta_occ(alpha) - \eta_occ x F_mo(alpha)
|
||||
do j = 1, elec_alpha_num
|
||||
do i = elec_alpha_num + 1, mo_num
|
||||
error_diis_Fmo(i,j) += Fock_matrix_mo(i,j)
|
||||
enddo
|
||||
enddo
|
||||
do j = elec_alpha_num + 1, mo_num
|
||||
do i = 1, elec_alpha_num
|
||||
error_diis_Fmo(i,j) -= Fock_matrix_mo(i,j)
|
||||
enddo
|
||||
enddo
|
||||
|
||||
! F_mo x \eta_occ(beta) - \eta_occ x F_mo(beta)
|
||||
do j = 1, elec_beta_num
|
||||
do i = elec_beta_num + 1, mo_num
|
||||
error_diis_Fmo(i,j) += Fock_matrix_mo(i,j)
|
||||
enddo
|
||||
enddo
|
||||
do j = elec_beta_num + 1, mo_num
|
||||
do i = 1, elec_beta_num
|
||||
error_diis_Fmo(i,j) -= Fock_matrix_mo(i,j)
|
||||
enddo
|
||||
enddo
|
||||
|
||||
!allocate(tmp(ao_num,ao_num))
|
||||
!call mo_to_ao(error_diis_Fmo, size(error_diis_Fmo, 1), tmp, size(tmp, 1))
|
||||
!call ao_to_mo(tmp, size(tmp, 1), error_diis_Fmo, size(error_diis_Fmo, 1))
|
||||
!deallocate(tmp)
|
||||
|
||||
END_PROVIDER
|
||||
|
||||
! ---
|
||||
|
||||
BEGIN_PROVIDER [double precision, FPS_SPF_Matrix_AO_a, (AO_num, AO_num)]
|
||||
|
||||
implicit none
|
||||
double precision, allocatable :: scratch(:,:)
|
||||
|
||||
allocate(scratch(AO_num, AO_num))
|
||||
|
||||
call dgemm( 'N', 'N', AO_num, AO_num, AO_num, 1.d0 &
|
||||
, Fock_Matrix_AO_alpha, size(Fock_Matrix_AO_alpha, 1), SCF_density_matrix_ao_alpha, size(SCF_Density_Matrix_AO_alpha, 1) &
|
||||
, 0.d0, scratch, size(scratch, 1) )
|
||||
|
||||
call dgemm( 'N', 'N', AO_num, AO_num, AO_num, 1.d0 &
|
||||
, scratch, size(scratch, 1), AO_Overlap, size(AO_Overlap, 1) &
|
||||
, 0.d0, FPS_SPF_Matrix_AO_a, size(FPS_SPF_Matrix_AO_a, 1) )
|
||||
|
||||
call dgemm( 'N', 'N', AO_num, AO_num, AO_num, 1.d0 &
|
||||
, AO_Overlap, size(AO_Overlap, 1), SCF_density_matrix_ao_alpha, size(SCF_density_matrix_ao_alpha, 1) &
|
||||
, 0.d0, scratch, size(scratch, 1) )
|
||||
|
||||
call dgemm( 'N', 'N', AO_num, AO_num, AO_num, -1.d0 &
|
||||
, scratch, size(scratch, 1), Fock_Matrix_AO_alpha, size(Fock_Matrix_AO_alpha, 1) &
|
||||
, 1.d0, FPS_SPF_Matrix_AO_a, size(FPS_SPF_Matrix_AO_a, 1) )
|
||||
|
||||
END_PROVIDER
|
||||
|
||||
! ---
|
||||
|
||||
BEGIN_PROVIDER [double precision, FPS_SPF_Matrix_AO_b, (AO_num, AO_num)]
|
||||
|
||||
implicit none
|
||||
double precision, allocatable :: scratch(:,:)
|
||||
|
||||
allocate(scratch(AO_num, AO_num))
|
||||
|
||||
call dgemm( 'N', 'N', AO_num, AO_num, AO_num, 1.d0 &
|
||||
, Fock_Matrix_AO_beta, size(Fock_Matrix_AO_beta, 1), SCF_density_matrix_ao_beta, size(SCF_Density_Matrix_AO_beta, 1) &
|
||||
, 0.d0, scratch, size(scratch, 1) )
|
||||
|
||||
call dgemm( 'N', 'N', AO_num, AO_num, AO_num, 1.d0 &
|
||||
, scratch, size(scratch, 1), AO_Overlap, size(AO_Overlap, 1) &
|
||||
, 0.d0, FPS_SPF_Matrix_AO_b, size(FPS_SPF_Matrix_AO_b, 1) )
|
||||
|
||||
call dgemm( 'N', 'N', AO_num, AO_num, AO_num, 1.d0 &
|
||||
, AO_Overlap, size(AO_Overlap, 1), SCF_density_matrix_ao_beta, size(SCF_density_matrix_ao_beta, 1) &
|
||||
, 0.d0, scratch, size(scratch, 1) )
|
||||
|
||||
call dgemm( 'N', 'N', AO_num, AO_num, AO_num, -1.d0 &
|
||||
, scratch, size(scratch, 1), Fock_Matrix_AO_beta, size(Fock_Matrix_AO_beta, 1) &
|
||||
, 1.d0, FPS_SPF_Matrix_AO_b, size(FPS_SPF_Matrix_AO_b, 1) )
|
||||
|
||||
END_PROVIDER
|
||||
|
||||
! ---
|
||||
|
||||
BEGIN_PROVIDER [double precision, FPS_SPF_Matrix_MO_a, (mo_num, mo_num)]
|
||||
implicit none
|
||||
call ao_to_mo(FPS_SPF_Matrix_AO_a, size(FPS_SPF_Matrix_AO_a, 1), FPS_SPF_Matrix_MO_a, size(FPS_SPF_Matrix_MO_a, 1))
|
||||
END_PROVIDER
|
||||
|
||||
! ---
|
||||
|
||||
BEGIN_PROVIDER [double precision, FPS_SPF_Matrix_MO_b, (mo_num, mo_num)]
|
||||
implicit none
|
||||
call ao_to_mo(FPS_SPF_Matrix_AO_b, size(FPS_SPF_Matrix_AO_b, 1), FPS_SPF_Matrix_MO_b, size(FPS_SPF_Matrix_MO_b, 1))
|
||||
END_PROVIDER
|
||||
|
||||
! ---
|
||||
|
||||
|
|
|
@ -267,3 +267,5 @@ BEGIN_PROVIDER [ double precision, SCF_energy ]
|
|||
|
||||
END_PROVIDER
|
||||
|
||||
! ---
|
||||
|
||||
|
|
308
src/scf_utils/rh_scf_mo.irp.f
Normal file
308
src/scf_utils/rh_scf_mo.irp.f
Normal file
|
@ -0,0 +1,308 @@
|
|||
! ---
|
||||
|
||||
subroutine Roothaan_Hall_SCF_MO()
|
||||
|
||||
BEGIN_DOC
|
||||
!
|
||||
! Roothaan-Hall algorithm for SCF Hartree-Fock calculation
|
||||
!
|
||||
END_DOC
|
||||
|
||||
implicit none
|
||||
|
||||
double precision :: energy_SCF, energy_SCF_previous, Delta_energy_SCF
|
||||
double precision :: max_error_DIIS
|
||||
double precision, allocatable :: Fock_matrix_DIIS(:,:,:), error_matrix_DIIS(:,:,:)
|
||||
|
||||
integer :: iteration_SCF, dim_DIIS, index_dim_DIIS
|
||||
|
||||
integer :: i, j
|
||||
double precision :: level_shift_save
|
||||
double precision, allocatable :: mo_coef_save(:,:)
|
||||
|
||||
logical, external :: qp_stop
|
||||
|
||||
PROVIDE ao_md5 mo_occ level_shift
|
||||
|
||||
allocate( mo_coef_save(ao_num,mo_num) &
|
||||
, Fock_matrix_DIIS (mo_num,mo_num,max_dim_DIIS) &
|
||||
, error_matrix_DIIS(mo_num,mo_num,max_dim_DIIS) )
|
||||
|
||||
Fock_matrix_DIIS = 0.d0
|
||||
error_matrix_DIIS = 0.d0
|
||||
mo_coef_save = 0.d0
|
||||
|
||||
call write_time(6)
|
||||
|
||||
print*,'energy of the guess = ',SCF_energy
|
||||
write(6,'(A4, 1X, A16, 1X, A16, 1X, A16, 1X, A16)') &
|
||||
'====','================','================','================','================'
|
||||
write(6,'(A4, 1X, A16, 1X, A16, 1X, A16, 1X, A16)') &
|
||||
' N ', 'energy ', 'energy diff ', 'DIIS error ', 'Level shift '
|
||||
write(6,'(A4, 1X, A16, 1X, A16, 1X, A16, 1X, A16)') &
|
||||
'====','================','================','================','================'
|
||||
|
||||
! Initialize energies and density matrices
|
||||
energy_SCF_previous = SCF_energy
|
||||
Delta_energy_SCF = 1.d0
|
||||
iteration_SCF = 0
|
||||
dim_DIIS = 0
|
||||
max_error_DIIS = 1.d0
|
||||
|
||||
|
||||
!
|
||||
! Start of main SCF loop
|
||||
!
|
||||
PROVIDE Fock_matrix_mo error_diis_Fmo
|
||||
|
||||
do while ( &
|
||||
( (max_error_DIIS > threshold_DIIS_nonzero) .or. &
|
||||
(dabs(Delta_energy_SCF) > thresh_SCF) &
|
||||
) .and. (iteration_SCF < n_it_SCF_max) )
|
||||
|
||||
iteration_SCF += 1
|
||||
if(frozen_orb_scf) then
|
||||
call initialize_mo_coef_begin_iteration
|
||||
endif
|
||||
|
||||
dim_DIIS = min(dim_DIIS+1, max_dim_DIIS)
|
||||
|
||||
if( (scf_algorithm == 'DIIS_MO').and.(dabs(Delta_energy_SCF) > 1.d-6)) then
|
||||
!if(scf_algorithm == 'DIIS_MO') then
|
||||
|
||||
index_dim_DIIS = mod(dim_DIIS-1, max_dim_DIIS) + 1
|
||||
do j = 1, mo_num
|
||||
do i = 1, mo_num
|
||||
Fock_matrix_DIIS (i,j,index_dim_DIIS) = Fock_matrix_mo(i,j)
|
||||
error_matrix_DIIS(i,j,index_dim_DIIS) = error_diis_Fmo(i,j)
|
||||
enddo
|
||||
enddo
|
||||
|
||||
call extrapolate_Fock_matrix_mo(error_matrix_DIIS, Fock_matrix_DIIS, Fock_matrix_mo, size(Fock_matrix_mo, 1), iteration_SCF, dim_DIIS)
|
||||
do i = 1, mo_num
|
||||
Fock_matrix_diag_mo(i) = Fock_matrix_mo(i,i)
|
||||
enddo
|
||||
TOUCH Fock_matrix_mo fock_matrix_diag_mo
|
||||
endif
|
||||
|
||||
mo_coef = eigenvectors_Fock_matrix_mo
|
||||
if(frozen_orb_scf) then
|
||||
call reorder_core_orb
|
||||
call initialize_mo_coef_begin_iteration
|
||||
endif
|
||||
|
||||
TOUCH mo_coef
|
||||
|
||||
max_error_DIIS = maxval(Abs(error_diis_Fmo))
|
||||
|
||||
energy_SCF = SCF_energy
|
||||
Delta_energy_SCF = energy_SCF - energy_SCF_previous
|
||||
|
||||
if( (SCF_algorithm == 'DIIS_MO') .and. (Delta_energy_SCF > 0.d0) ) then
|
||||
Fock_matrix_MO(1:mo_num,1:mo_num) = Fock_matrix_DIIS(1:mo_num,1:mo_num,index_dim_DIIS)
|
||||
do i = 1, mo_num
|
||||
Fock_matrix_diag_mo(i) = Fock_matrix_mo(i,i)
|
||||
enddo
|
||||
TOUCH Fock_matrix_mo fock_matrix_diag_mo
|
||||
mo_coef = eigenvectors_Fock_matrix_mo
|
||||
max_error_DIIS = maxval(Abs(error_diis_Fmo))
|
||||
energy_SCF = SCF_energy
|
||||
Delta_energy_SCF = energy_SCF - energy_SCF_previous
|
||||
endif
|
||||
|
||||
level_shift_save = level_shift
|
||||
mo_coef_save(1:ao_num,1:mo_num) = mo_coef(1:ao_num,1:mo_num)
|
||||
do while(Delta_energy_SCF > 0.d0)
|
||||
mo_coef(1:ao_num,1:mo_num) = mo_coef_save(1:ao_num,1:mo_num)
|
||||
if(level_shift <= .1d0) then
|
||||
level_shift = 1.d0
|
||||
else
|
||||
level_shift = level_shift * 3.0d0
|
||||
endif
|
||||
TOUCH mo_coef level_shift
|
||||
mo_coef(1:ao_num,1:mo_num) = eigenvectors_Fock_matrix_mo(1:ao_num,1:mo_num)
|
||||
if(frozen_orb_scf) then
|
||||
call reorder_core_orb
|
||||
call initialize_mo_coef_begin_iteration
|
||||
endif
|
||||
TOUCH mo_coef
|
||||
Delta_energy_SCF = SCF_energy - energy_SCF_previous
|
||||
energy_SCF = SCF_energy
|
||||
if(level_shift-level_shift_save > 40.d0) then
|
||||
level_shift = level_shift_save * 4.d0
|
||||
SOFT_TOUCH level_shift
|
||||
exit
|
||||
endif
|
||||
|
||||
dim_DIIS=0
|
||||
enddo
|
||||
|
||||
level_shift = level_shift * 0.5d0
|
||||
SOFT_TOUCH level_shift
|
||||
energy_SCF_previous = energy_SCF
|
||||
|
||||
! Print results at the end of each iteration
|
||||
|
||||
write(6,'(I4, 1X, F16.10, 1X, F16.10, 1X, F16.10, 1X, F16.10, 1X, I3)') &
|
||||
iteration_SCF, energy_SCF, Delta_energy_SCF, max_error_DIIS, level_shift, dim_DIIS
|
||||
|
||||
if(Delta_energy_SCF < 0.d0) then
|
||||
call save_mos
|
||||
endif
|
||||
|
||||
if(qp_stop()) exit
|
||||
enddo
|
||||
|
||||
!
|
||||
! End of Main SCF loop
|
||||
!
|
||||
|
||||
if(iteration_SCF < n_it_SCF_max) then
|
||||
mo_label = 'Canonical'
|
||||
endif
|
||||
|
||||
write(6,'(A4, 1X, A16, 1X, A16, 1X, A16, 1X, A16)') &
|
||||
'====','================','================','================','================'
|
||||
write(6,*)
|
||||
|
||||
if(.not.frozen_orb_scf)then
|
||||
call mo_as_eigvectors_of_mo_matrix(Fock_matrix_mo, size(Fock_matrix_mo, 1), size(Fock_matrix_mo, 2), mo_label, 1, .true.)
|
||||
call restore_symmetry(ao_num, mo_num, mo_coef, size(mo_coef, 1), 1.d-10)
|
||||
call orthonormalize_mos
|
||||
call save_mos
|
||||
endif
|
||||
|
||||
call write_double(6, energy_SCF, 'SCF energy')
|
||||
|
||||
call write_time(6)
|
||||
|
||||
end
|
||||
|
||||
! ---
|
||||
|
||||
subroutine extrapolate_Fock_matrix_mo(error_matrix_DIIS, Fock_matrix_DIIS, Fock_matrix_MO_, size_Fock_matrix_MO, iteration_SCF, dim_DIIS)
|
||||
|
||||
BEGIN_DOC
|
||||
! Compute the extrapolated Fock matrix using the DIIS procedure
|
||||
END_DOC
|
||||
|
||||
implicit none
|
||||
|
||||
integer,intent(inout) :: dim_DIIS
|
||||
double precision,intent(in) :: Fock_matrix_DIIS(mo_num,mo_num,dim_DIIS), error_matrix_DIIS(mo_num,mo_num,dim_DIIS)
|
||||
integer,intent(in) :: iteration_SCF, size_Fock_matrix_MO
|
||||
double precision,intent(inout):: Fock_matrix_MO_(size_Fock_matrix_MO,mo_num)
|
||||
|
||||
double precision,allocatable :: B_matrix_DIIS(:,:),X_vector_DIIS(:)
|
||||
double precision,allocatable :: C_vector_DIIS(:)
|
||||
|
||||
double precision,allocatable :: scratch(:,:)
|
||||
integer :: i,j,k,l,i_DIIS,j_DIIS
|
||||
double precision :: rcond, ferr, berr
|
||||
integer, allocatable :: iwork(:)
|
||||
integer :: lwork
|
||||
|
||||
if(dim_DIIS < 1) then
|
||||
return
|
||||
endif
|
||||
|
||||
allocate( &
|
||||
B_matrix_DIIS(dim_DIIS+1,dim_DIIS+1), &
|
||||
X_vector_DIIS(dim_DIIS+1), &
|
||||
C_vector_DIIS(dim_DIIS+1), &
|
||||
scratch(mo_num,mo_num) &
|
||||
)
|
||||
|
||||
! Compute the matrices B and X
|
||||
B_matrix_DIIS(:,:) = 0.d0
|
||||
do j = 1, dim_DIIS
|
||||
j_DIIS = min(dim_DIIS, mod(iteration_SCF-j, max_dim_DIIS) + 1)
|
||||
|
||||
do i = 1, dim_DIIS
|
||||
i_DIIS = min(dim_DIIS, mod(iteration_SCF-i, max_dim_DIIS) + 1)
|
||||
|
||||
! Compute product of two errors vectors
|
||||
do l = 1, mo_num
|
||||
do k = 1, mo_num
|
||||
B_matrix_DIIS(i,j) = B_matrix_DIIS(i,j) + error_matrix_DIIS(k,l,i_DIIS) * error_matrix_DIIS(k,l,j_DIIS)
|
||||
enddo
|
||||
enddo
|
||||
|
||||
enddo
|
||||
enddo
|
||||
|
||||
! Pad B matrix and build the X matrix
|
||||
|
||||
C_vector_DIIS(:) = 0.d0
|
||||
do i = 1, dim_DIIS
|
||||
B_matrix_DIIS(i,dim_DIIS+1) = -1.d0
|
||||
B_matrix_DIIS(dim_DIIS+1,i) = -1.d0
|
||||
enddo
|
||||
C_vector_DIIS(dim_DIIS+1) = -1.d0
|
||||
|
||||
deallocate(scratch)
|
||||
|
||||
! Estimate condition number of B
|
||||
double precision :: anorm
|
||||
integer :: info
|
||||
integer,allocatable :: ipiv(:)
|
||||
double precision, allocatable :: AF(:,:)
|
||||
double precision, external :: dlange
|
||||
|
||||
lwork = max((dim_DIIS+1)**2, (dim_DIIS+1)*5)
|
||||
allocate(AF(dim_DIIS+1,dim_DIIS+1))
|
||||
allocate(ipiv(2*(dim_DIIS+1)), iwork(2*(dim_DIIS+1)) )
|
||||
allocate(scratch(lwork,1))
|
||||
scratch(:,1) = 0.d0
|
||||
|
||||
anorm = dlange('1', dim_DIIS+1, dim_DIIS+1, B_matrix_DIIS, size(B_matrix_DIIS, 1), scratch(1,1))
|
||||
|
||||
AF(:,:) = B_matrix_DIIS(:,:)
|
||||
call dgetrf(dim_DIIS+1, dim_DIIS+1, AF, size(AF, 1), ipiv, info)
|
||||
if(info /= 0) then
|
||||
dim_DIIS = 0
|
||||
return
|
||||
endif
|
||||
|
||||
call dgecon( '1', dim_DIIS+1, AF, size(AF, 1), anorm, rcond, scratch, iwork, info)
|
||||
if(info /= 0) then
|
||||
dim_DIIS = 0
|
||||
return
|
||||
endif
|
||||
|
||||
if(rcond < 1.d-14) then
|
||||
dim_DIIS = 0
|
||||
return
|
||||
endif
|
||||
|
||||
! solve the linear system C = B.X
|
||||
|
||||
X_vector_DIIS = C_vector_DIIS
|
||||
call dgesv(dim_DIIS+1 , 1, B_matrix_DIIS, size(B_matrix_DIIS, 1), ipiv, X_vector_DIIS, size(X_vector_DIIS, 1), info)
|
||||
|
||||
deallocate(scratch, AF, iwork)
|
||||
|
||||
if(info < 0) then
|
||||
stop 'bug in DIIS_MO'
|
||||
endif
|
||||
|
||||
! Compute extrapolated Fock matrix
|
||||
|
||||
|
||||
!$OMP PARALLEL DO PRIVATE(i,j,k) DEFAULT(SHARED) if (mo_num > 200)
|
||||
do j = 1, mo_num
|
||||
do i = 1, mo_num
|
||||
Fock_matrix_MO_(i,j) = 0.d0
|
||||
enddo
|
||||
do k = 1, dim_DIIS
|
||||
if(dabs(X_vector_DIIS(k)) < 1.d-10) cycle
|
||||
do i = 1, mo_num
|
||||
! FPE here
|
||||
Fock_matrix_MO_(i,j) = Fock_matrix_MO_(i,j) + X_vector_DIIS(k) * Fock_matrix_DIIS(i,j,dim_DIIS-k+1)
|
||||
enddo
|
||||
enddo
|
||||
enddo
|
||||
!$OMP END PARALLEL DO
|
||||
|
||||
end
|
||||
|
196
src/scf_utils/rh_scf_modif.irp.f
Normal file
196
src/scf_utils/rh_scf_modif.irp.f
Normal file
|
@ -0,0 +1,196 @@
|
|||
subroutine Roothaan_Hall_SCF_MODIF
|
||||
|
||||
BEGIN_DOC
|
||||
! Roothaan-Hall algorithm for SCF Hartree-Fock calculation
|
||||
END_DOC
|
||||
|
||||
implicit none
|
||||
|
||||
double precision :: energy_SCF,energy_SCF_previous,Delta_energy_SCF
|
||||
double precision :: max_error_DIIS,max_error_DIIS_alpha,max_error_DIIS_beta
|
||||
double precision, allocatable :: Fock_matrix_DIIS(:,:,:),error_matrix_DIIS(:,:,:)
|
||||
|
||||
integer :: iteration_SCF,dim_DIIS,index_dim_DIIS
|
||||
|
||||
integer :: i,j
|
||||
logical, external :: qp_stop
|
||||
double precision, allocatable :: mo_coef_save(:,:)
|
||||
|
||||
PROVIDE ao_md5 mo_occ level_shift
|
||||
|
||||
allocate(mo_coef_save(ao_num,mo_num), &
|
||||
Fock_matrix_DIIS (ao_num,ao_num,max_dim_DIIS), &
|
||||
error_matrix_DIIS(ao_num,ao_num,max_dim_DIIS) &
|
||||
)
|
||||
|
||||
Fock_matrix_DIIS = 0.d0
|
||||
error_matrix_DIIS = 0.d0
|
||||
mo_coef_save = 0.d0
|
||||
|
||||
call write_time(6)
|
||||
|
||||
print*,'energy of the guess = ',SCF_energy
|
||||
write(6,'(A4, 1X, A16, 1X, A16, 1X, A16, 1X, A16)') &
|
||||
'====','================','================','================','================'
|
||||
write(6,'(A4, 1X, A16, 1X, A16, 1X, A16, 1X, A16)') &
|
||||
' N ', 'energy ', 'energy diff ', 'DIIS error ', 'Level shift '
|
||||
write(6,'(A4, 1X, A16, 1X, A16, 1X, A16, 1X, A16)') &
|
||||
'====','================','================','================','================'
|
||||
|
||||
! Initialize energies and density matrices
|
||||
energy_SCF_previous = SCF_energy
|
||||
Delta_energy_SCF = 1.d0
|
||||
iteration_SCF = 0
|
||||
dim_DIIS = 0
|
||||
max_error_DIIS = 1.d0
|
||||
|
||||
|
||||
!
|
||||
! Start of main SCF loop
|
||||
!
|
||||
PROVIDE FPS_SPF_matrix_AO Fock_matrix_AO
|
||||
|
||||
do while ( &
|
||||
( (max_error_DIIS > threshold_DIIS_nonzero) .or. &
|
||||
(dabs(Delta_energy_SCF) > thresh_SCF) &
|
||||
) .and. (iteration_SCF < n_it_SCF_max) )
|
||||
|
||||
! Increment cycle number
|
||||
|
||||
iteration_SCF += 1
|
||||
if(frozen_orb_scf)then
|
||||
call initialize_mo_coef_begin_iteration
|
||||
endif
|
||||
|
||||
! Current size of the DIIS space
|
||||
|
||||
dim_DIIS = min(dim_DIIS+1,max_dim_DIIS)
|
||||
|
||||
if( (scf_algorithm == 'DIIS_MODIF') .and. (dabs(Delta_energy_SCF) > 1.d-6) ) then
|
||||
!if(scf_algorithm == 'DIIS_MODIF') then
|
||||
|
||||
! Store Fock and error matrices at each iteration
|
||||
index_dim_DIIS = mod(dim_DIIS-1,max_dim_DIIS)+1
|
||||
do j=1,ao_num
|
||||
do i=1,ao_num
|
||||
Fock_matrix_DIIS (i,j,index_dim_DIIS) = Fock_matrix_AO(i,j)
|
||||
error_matrix_DIIS(i,j,index_dim_DIIS) = FPS_SPF_matrix_AO(i,j)
|
||||
enddo
|
||||
enddo
|
||||
|
||||
! Compute the extrapolated Fock matrix
|
||||
|
||||
call extrapolate_Fock_matrix( &
|
||||
error_matrix_DIIS,Fock_matrix_DIIS, &
|
||||
Fock_matrix_AO,size(Fock_matrix_AO,1), &
|
||||
iteration_SCF,dim_DIIS &
|
||||
)
|
||||
call ao_to_mo(Fock_matrix_AO, size(Fock_matrix_AO, 1), Fock_matrix_MO, size(Fock_matrix_MO, 1))
|
||||
do i = 1, mo_num
|
||||
Fock_matrix_diag_MO(i) = Fock_matrix_MO(i,i)
|
||||
enddo
|
||||
TOUCH Fock_matrix_MO Fock_matrix_diag_MO
|
||||
|
||||
!Fock_matrix_AO_alpha = Fock_matrix_AO*0.5d0
|
||||
!Fock_matrix_AO_beta = Fock_matrix_AO*0.5d0
|
||||
!TOUCH Fock_matrix_AO_alpha Fock_matrix_AO_beta
|
||||
endif
|
||||
|
||||
MO_coef = eigenvectors_Fock_matrix_MO
|
||||
if(frozen_orb_scf)then
|
||||
call reorder_core_orb
|
||||
call initialize_mo_coef_begin_iteration
|
||||
endif
|
||||
|
||||
TOUCH MO_coef
|
||||
|
||||
! Calculate error vectors
|
||||
|
||||
max_error_DIIS = maxval(Abs(FPS_SPF_Matrix_MO))
|
||||
|
||||
! SCF energy
|
||||
|
||||
energy_SCF = SCF_energy
|
||||
Delta_energy_SCF = energy_SCF - energy_SCF_previous
|
||||
if( (SCF_algorithm == 'DIIS_MODIF') .and. (Delta_energy_SCF > 0.d0) ) then
|
||||
Fock_matrix_AO(1:ao_num,1:ao_num) = Fock_matrix_DIIS(1:ao_num,1:ao_num,index_dim_DIIS)
|
||||
call ao_to_mo(Fock_matrix_AO, size(Fock_matrix_AO, 1), Fock_matrix_MO, size(Fock_matrix_MO, 1))
|
||||
do i = 1, mo_num
|
||||
Fock_matrix_diag_MO(i) = Fock_matrix_MO(i,i)
|
||||
enddo
|
||||
TOUCH Fock_matrix_MO Fock_matrix_diag_MO
|
||||
|
||||
!Fock_matrix_AO_alpha = Fock_matrix_AO*0.5d0
|
||||
!Fock_matrix_AO_beta = Fock_matrix_AO*0.5d0
|
||||
!TOUCH Fock_matrix_AO_alpha Fock_matrix_AO_beta
|
||||
endif
|
||||
|
||||
double precision :: level_shift_save
|
||||
level_shift_save = level_shift
|
||||
mo_coef_save(1:ao_num,1:mo_num) = mo_coef(1:ao_num,1:mo_num)
|
||||
do while (Delta_energy_SCF > 0.d0)
|
||||
mo_coef(1:ao_num,1:mo_num) = mo_coef_save
|
||||
if (level_shift <= .1d0) then
|
||||
level_shift = 1.d0
|
||||
else
|
||||
level_shift = level_shift * 3.0d0
|
||||
endif
|
||||
TOUCH mo_coef level_shift
|
||||
mo_coef(1:ao_num,1:mo_num) = eigenvectors_Fock_matrix_MO(1:ao_num,1:mo_num)
|
||||
if(frozen_orb_scf)then
|
||||
call reorder_core_orb
|
||||
call initialize_mo_coef_begin_iteration
|
||||
endif
|
||||
TOUCH mo_coef
|
||||
Delta_energy_SCF = SCF_energy - energy_SCF_previous
|
||||
energy_SCF = SCF_energy
|
||||
if (level_shift-level_shift_save > 40.d0) then
|
||||
level_shift = level_shift_save * 4.d0
|
||||
SOFT_TOUCH level_shift
|
||||
exit
|
||||
endif
|
||||
|
||||
dim_DIIS=0
|
||||
enddo
|
||||
|
||||
level_shift = level_shift * 0.5d0
|
||||
SOFT_TOUCH level_shift
|
||||
energy_SCF_previous = energy_SCF
|
||||
|
||||
! Print results at the end of each iteration
|
||||
|
||||
write(6,'(I4, 1X, F16.10, 1X, F16.10, 1X, F16.10, 1X, F16.10, 1X, I3)') &
|
||||
iteration_SCF, energy_SCF, Delta_energy_SCF, max_error_DIIS, level_shift, dim_DIIS
|
||||
|
||||
if (Delta_energy_SCF < 0.d0) then
|
||||
call save_mos
|
||||
endif
|
||||
if (qp_stop()) exit
|
||||
|
||||
enddo
|
||||
|
||||
if (iteration_SCF < n_it_SCF_max) then
|
||||
mo_label = 'Canonical'
|
||||
endif
|
||||
!
|
||||
! End of Main SCF loop
|
||||
!
|
||||
|
||||
write(6,'(A4, 1X, A16, 1X, A16, 1X, A16, 1X, A16)') &
|
||||
'====','================','================','================','================'
|
||||
write(6,*)
|
||||
|
||||
if(.not.frozen_orb_scf)then
|
||||
call mo_as_eigvectors_of_mo_matrix(Fock_matrix_mo,size(Fock_matrix_mo,1), &
|
||||
size(Fock_matrix_mo,2),mo_label,1,.true.)
|
||||
call restore_symmetry(ao_num, mo_num, mo_coef, size(mo_coef,1), 1.d-10)
|
||||
call orthonormalize_mos
|
||||
call save_mos
|
||||
endif
|
||||
|
||||
call write_double(6, energy_SCF, 'SCF energy')
|
||||
|
||||
call write_time(6)
|
||||
|
||||
end
|
||||
|
129
src/scf_utils/rh_scf_simple.irp.f
Normal file
129
src/scf_utils/rh_scf_simple.irp.f
Normal file
|
@ -0,0 +1,129 @@
|
|||
subroutine Roothaan_Hall_SCF_Simple
|
||||
|
||||
BEGIN_DOC
|
||||
! Roothaan-Hall algorithm for SCF Hartree-Fock calculation
|
||||
END_DOC
|
||||
|
||||
implicit none
|
||||
|
||||
integer :: iteration_SCF, dim_DIIS
|
||||
double precision :: energy_SCF,energy_SCF_previous,Delta_energy_SCF
|
||||
double precision :: max_error_DIIS
|
||||
|
||||
integer :: i,j
|
||||
logical, external :: qp_stop
|
||||
double precision, allocatable :: mo_coef_save(:,:)
|
||||
|
||||
PROVIDE ao_md5 mo_occ level_shift
|
||||
|
||||
allocate(mo_coef_save(ao_num,mo_num))
|
||||
|
||||
|
||||
dim_DIIS = 0
|
||||
mo_coef_save = 0.d0
|
||||
|
||||
call write_time(6)
|
||||
|
||||
print*,'energy of the guess = ',SCF_energy
|
||||
write(6,'(A4, 1X, A16, 1X, A16, 1X, A16, 1X, A16)') &
|
||||
'====','================','================','================','================'
|
||||
write(6,'(A4, 1X, A16, 1X, A16, 1X, A16, 1X, A16)') &
|
||||
' N ', 'energy ', 'energy diff ', 'DIIS error ', 'Level shift '
|
||||
write(6,'(A4, 1X, A16, 1X, A16, 1X, A16, 1X, A16)') &
|
||||
'====','================','================','================','================'
|
||||
|
||||
! Initialize energies and density matrices
|
||||
energy_SCF_previous = SCF_energy
|
||||
Delta_energy_SCF = 1.d0
|
||||
iteration_SCF = 0
|
||||
max_error_DIIS = 1.d0
|
||||
|
||||
do while ( &
|
||||
( (max_error_DIIS > threshold_DIIS_nonzero) .or. &
|
||||
(dabs(Delta_energy_SCF) > thresh_SCF) &
|
||||
) .and. (iteration_SCF < n_it_SCF_max) )
|
||||
|
||||
iteration_SCF += 1
|
||||
if(frozen_orb_scf)then
|
||||
call initialize_mo_coef_begin_iteration
|
||||
endif
|
||||
|
||||
MO_coef = eigenvectors_Fock_matrix_MO
|
||||
if(frozen_orb_scf)then
|
||||
call reorder_core_orb
|
||||
call initialize_mo_coef_begin_iteration
|
||||
endif
|
||||
TOUCH MO_coef
|
||||
|
||||
! Calculate error vectors
|
||||
max_error_DIIS = maxval(Abs(FPS_SPF_Matrix_MO))
|
||||
|
||||
! SCF energy
|
||||
|
||||
energy_SCF = SCF_energy
|
||||
Delta_energy_SCF = energy_SCF - energy_SCF_previous
|
||||
|
||||
!double precision :: level_shift_save
|
||||
!level_shift_save = level_shift
|
||||
!mo_coef_save(1:ao_num,1:mo_num) = mo_coef(1:ao_num,1:mo_num)
|
||||
!do while (Delta_energy_SCF > 0.d0)
|
||||
! mo_coef(1:ao_num,1:mo_num) = mo_coef_save
|
||||
! if (level_shift <= .1d0) then
|
||||
! level_shift = 1.d0
|
||||
! else
|
||||
! level_shift = level_shift * 3.0d0
|
||||
! endif
|
||||
! TOUCH mo_coef level_shift
|
||||
! mo_coef(1:ao_num,1:mo_num) = eigenvectors_Fock_matrix_MO(1:ao_num,1:mo_num)
|
||||
! if(frozen_orb_scf)then
|
||||
! call reorder_core_orb
|
||||
! call initialize_mo_coef_begin_iteration
|
||||
! endif
|
||||
! TOUCH mo_coef
|
||||
! Delta_energy_SCF = SCF_energy - energy_SCF_previous
|
||||
! energy_SCF = SCF_energy
|
||||
! if (level_shift-level_shift_save > 40.d0) then
|
||||
! level_shift = level_shift_save * 4.d0
|
||||
! SOFT_TOUCH level_shift
|
||||
! exit
|
||||
! endif
|
||||
!enddo
|
||||
!level_shift = level_shift * 0.5d0
|
||||
!SOFT_TOUCH level_shift
|
||||
|
||||
energy_SCF_previous = energy_SCF
|
||||
|
||||
! Print results at the end of each iteration
|
||||
|
||||
write(6,'(I4, 1X, F16.10, 1X, F16.10, 1X, F16.10, 1X, F16.10, 1X, I3)') &
|
||||
iteration_SCF, energy_SCF, Delta_energy_SCF, max_error_DIIS, level_shift, dim_DIIS
|
||||
|
||||
if(Delta_energy_SCF < 0.d0) then
|
||||
call save_mos()
|
||||
endif
|
||||
if(qp_stop()) exit
|
||||
|
||||
enddo
|
||||
|
||||
if (iteration_SCF < n_it_SCF_max) then
|
||||
mo_label = 'Canonical'
|
||||
endif
|
||||
|
||||
write(6,'(A4, 1X, A16, 1X, A16, 1X, A16, 1X, A16)') &
|
||||
'====','================','================','================','================'
|
||||
write(6,*)
|
||||
|
||||
if(.not.frozen_orb_scf)then
|
||||
call mo_as_eigvectors_of_mo_matrix(Fock_matrix_mo,size(Fock_matrix_mo,1), &
|
||||
size(Fock_matrix_mo,2),mo_label,1,.true.)
|
||||
call restore_symmetry(ao_num, mo_num, mo_coef, size(mo_coef,1), 1.d-10)
|
||||
call orthonormalize_mos
|
||||
call save_mos
|
||||
endif
|
||||
|
||||
call write_double(6, energy_SCF, 'SCF energy')
|
||||
|
||||
call write_time(6)
|
||||
|
||||
end
|
||||
|
|
@ -29,11 +29,11 @@ END_DOC
|
|||
|
||||
call write_time(6)
|
||||
|
||||
print*,'Energy of the guess = ',SCF_energy
|
||||
print*,'energy of the guess = ',SCF_energy
|
||||
write(6,'(A4, 1X, A16, 1X, A16, 1X, A16, 1X, A16)') &
|
||||
'====','================','================','================','================'
|
||||
write(6,'(A4, 1X, A16, 1X, A16, 1X, A16, 1X, A16)') &
|
||||
' N ', 'Energy ', 'Energy diff ', 'DIIS error ', 'Level shift '
|
||||
' N ', 'energy ', 'energy diff ', 'DIIS error ', 'Level shift '
|
||||
write(6,'(A4, 1X, A16, 1X, A16, 1X, A16, 1X, A16)') &
|
||||
'====','================','================','================','================'
|
||||
|
||||
|
@ -66,7 +66,8 @@ END_DOC
|
|||
|
||||
dim_DIIS = min(dim_DIIS+1,max_dim_DIIS)
|
||||
|
||||
if ( (scf_algorithm == 'DIIS').and.(dabs(Delta_energy_SCF) > 1.d-6) ) then
|
||||
if( (scf_algorithm == 'DIIS') .and. (dabs(Delta_energy_SCF) > 1.d-6)) then
|
||||
!if(scf_algorithm == 'DIIS') then
|
||||
|
||||
! Store Fock and error matrices at each iteration
|
||||
index_dim_DIIS = mod(dim_DIIS-1,max_dim_DIIS)+1
|
||||
|
@ -85,10 +86,9 @@ END_DOC
|
|||
iteration_SCF,dim_DIIS &
|
||||
)
|
||||
|
||||
Fock_matrix_AO_alpha = Fock_matrix_AO*0.5d0
|
||||
Fock_matrix_AO_beta = Fock_matrix_AO*0.5d0
|
||||
Fock_matrix_AO_alpha = Fock_matrix_AO!*0.5d0
|
||||
Fock_matrix_AO_beta = Fock_matrix_AO!*0.5d0
|
||||
TOUCH Fock_matrix_AO_alpha Fock_matrix_AO_beta
|
||||
|
||||
endif
|
||||
|
||||
MO_coef = eigenvectors_Fock_matrix_MO
|
||||
|
@ -99,18 +99,14 @@ END_DOC
|
|||
|
||||
TOUCH MO_coef
|
||||
|
||||
! Calculate error vectors
|
||||
|
||||
max_error_DIIS = maxval(Abs(FPS_SPF_Matrix_MO))
|
||||
|
||||
! SCF energy
|
||||
|
||||
energy_SCF = SCF_energy
|
||||
Delta_Energy_SCF = energy_SCF - energy_SCF_previous
|
||||
if ( (SCF_algorithm == 'DIIS').and.(Delta_Energy_SCF > 0.d0) ) then
|
||||
Delta_energy_SCF = energy_SCF - energy_SCF_previous
|
||||
if ( (SCF_algorithm == 'DIIS').and.(Delta_energy_SCF > 0.d0) ) then
|
||||
Fock_matrix_AO(1:ao_num,1:ao_num) = Fock_matrix_DIIS (1:ao_num,1:ao_num,index_dim_DIIS)
|
||||
Fock_matrix_AO_alpha = Fock_matrix_AO*0.5d0
|
||||
Fock_matrix_AO_beta = Fock_matrix_AO*0.5d0
|
||||
Fock_matrix_AO_alpha = Fock_matrix_AO!*0.5d0
|
||||
Fock_matrix_AO_beta = Fock_matrix_AO!*0.5d0
|
||||
TOUCH Fock_matrix_AO_alpha Fock_matrix_AO_beta
|
||||
endif
|
||||
|
||||
|
@ -131,19 +127,24 @@ END_DOC
|
|||
call initialize_mo_coef_begin_iteration
|
||||
endif
|
||||
TOUCH mo_coef
|
||||
Delta_Energy_SCF = SCF_energy - energy_SCF_previous
|
||||
Delta_energy_SCF = SCF_energy - energy_SCF_previous
|
||||
energy_SCF = SCF_energy
|
||||
if (level_shift-level_shift_save > 40.d0) then
|
||||
level_shift = level_shift_save * 4.d0
|
||||
SOFT_TOUCH level_shift
|
||||
exit
|
||||
endif
|
||||
|
||||
dim_DIIS=0
|
||||
enddo
|
||||
|
||||
level_shift = level_shift * 0.5d0
|
||||
SOFT_TOUCH level_shift
|
||||
energy_SCF_previous = energy_SCF
|
||||
|
||||
! Calculate error vectors
|
||||
max_error_DIIS = maxval(Abs(FPS_SPF_Matrix_MO))
|
||||
|
||||
! Print results at the end of each iteration
|
||||
|
||||
write(6,'(I4, 1X, F16.10, 1X, F16.10, 1X, F16.10, 1X, F16.10, 1X, I3)') &
|
||||
|
@ -175,7 +176,7 @@ END_DOC
|
|||
call save_mos
|
||||
endif
|
||||
|
||||
call write_double(6, Energy_SCF, 'SCF energy')
|
||||
call write_double(6, energy_SCF, 'SCF energy')
|
||||
|
||||
call write_time(6)
|
||||
|
||||
|
|
|
@ -14,21 +14,36 @@ program save_bitcpsileft_for_qmcchem
|
|||
|
||||
e_ref = 0.d0
|
||||
iunit = 13
|
||||
open(unit=iunit,file=trim(ezfio_filename)//'/simulation/e_ref',action='write')
|
||||
call ezfio_has_fci_energy_pt2(exists)
|
||||
|
||||
if(.not.exists) then
|
||||
call ezfio_has_fci_energy(exists)
|
||||
open(unit=iunit, file=trim(ezfio_filename)//'/simulation/e_ref', action='write')
|
||||
|
||||
call ezfio_has_fci_energy_pt2(exists)
|
||||
if(.not.exists) then
|
||||
call ezfio_has_tc_scf_bitc_energy(exists)
|
||||
if(exists) then
|
||||
call ezfio_get_tc_scf_bitc_energy(e_ref)
|
||||
|
||||
call ezfio_has_fci_energy(exists)
|
||||
if(.not.exists) then
|
||||
|
||||
call ezfio_has_cisd_energy(exists)
|
||||
if(.not.exists) then
|
||||
|
||||
call ezfio_has_tc_scf_bitc_energy(exists)
|
||||
if(exists) then
|
||||
call ezfio_get_tc_scf_bitc_energy(e_ref)
|
||||
endif
|
||||
|
||||
else
|
||||
call ezfio_get_cisd_energy(e_ref)
|
||||
endif
|
||||
|
||||
else
|
||||
call ezfio_get_fci_energy(e_ref)
|
||||
endif
|
||||
|
||||
else
|
||||
call ezfio_get_fci_energy_pt2(e_ref)
|
||||
endif
|
||||
|
||||
endif
|
||||
write(iunit,*) e_ref
|
||||
write(iunit,*) e_ref
|
||||
|
||||
close(iunit)
|
||||
|
||||
end
|
||||
|
|
|
@ -324,6 +324,9 @@ subroutine single_htilde_mu_mat_bi_ortho(Nint, key_j, key_i, hmono, htwoe, htot)
|
|||
|
||||
call get_single_excitation(key_i, key_j, exc, phase, Nint)
|
||||
call decode_exc(exc,1,h1,p1,h2,p2,s1,s2)
|
||||
! if(h1==14.and.p1==2)then
|
||||
! print*,'h1,p1 old = ',h1,p1
|
||||
! endif
|
||||
|
||||
hmono = mo_bi_ortho_tc_one_e(p1,h1) * phase
|
||||
|
||||
|
|
|
@ -49,8 +49,6 @@ subroutine diag_htilde_three_body_ints_bi_ort(Nint, key_i, hthree)
|
|||
|
||||
if(Ne(1)+Ne(2).ge.3)then
|
||||
!! ! alpha/alpha/beta three-body
|
||||
double precision :: accu
|
||||
accu = 0.d0
|
||||
do i = 1, Ne(1)
|
||||
ii = occ(i,1)
|
||||
do j = i+1, Ne(1)
|
||||
|
@ -62,14 +60,11 @@ subroutine diag_htilde_three_body_ints_bi_ort(Nint, key_i, hthree)
|
|||
direct_int = three_e_3_idx_direct_bi_ort(mm,jj,ii) ! USES 3-IDX TENSOR
|
||||
exchange_int = three_e_3_idx_exch12_bi_ort(mm,jj,ii) ! USES 3-IDX TENSOR
|
||||
hthree += direct_int - exchange_int
|
||||
accu += direct_int - exchange_int
|
||||
enddo
|
||||
enddo
|
||||
enddo
|
||||
!print*,'aab = ',accu
|
||||
|
||||
! beta/beta/alpha three-body
|
||||
accu = 0.d0
|
||||
do i = 1, Ne(2)
|
||||
ii = occ(i,2)
|
||||
do j = i+1, Ne(2)
|
||||
|
@ -79,14 +74,11 @@ subroutine diag_htilde_three_body_ints_bi_ort(Nint, key_i, hthree)
|
|||
direct_int = three_e_3_idx_direct_bi_ort(mm,jj,ii)
|
||||
exchange_int = three_e_3_idx_exch12_bi_ort(mm,jj,ii)
|
||||
hthree += direct_int - exchange_int
|
||||
accu += direct_int - exchange_int
|
||||
enddo
|
||||
enddo
|
||||
enddo
|
||||
!print*,'abb = ',accu
|
||||
|
||||
! alpha/alpha/alpha three-body
|
||||
accu = 0.d0
|
||||
do i = 1, Ne(1)
|
||||
ii = occ(i,1) ! 1
|
||||
do j = i+1, Ne(1)
|
||||
|
@ -95,14 +87,11 @@ subroutine diag_htilde_three_body_ints_bi_ort(Nint, key_i, hthree)
|
|||
mm = occ(m,1) ! 3
|
||||
! ref = sym_3_e_int_from_6_idx_tensor(mm,jj,ii,mm,jj,ii) USES THE 6 IDX TENSOR
|
||||
hthree += three_e_diag_parrallel_spin(mm,jj,ii) ! USES ONLY 3-IDX TENSORS
|
||||
accu += three_e_diag_parrallel_spin(mm,jj,ii)
|
||||
enddo
|
||||
enddo
|
||||
enddo
|
||||
!print*,'aaa = ',accu
|
||||
|
||||
! beta/beta/beta three-body
|
||||
accu = 0.d0
|
||||
do i = 1, Ne(2)
|
||||
ii = occ(i,2) ! 1
|
||||
do j = i+1, Ne(2)
|
||||
|
@ -111,11 +100,9 @@ subroutine diag_htilde_three_body_ints_bi_ort(Nint, key_i, hthree)
|
|||
mm = occ(m,2) ! 3
|
||||
! ref = sym_3_e_int_from_6_idx_tensor(mm,jj,ii,mm,jj,ii) USES THE 6 IDX TENSOR
|
||||
hthree += three_e_diag_parrallel_spin(mm,jj,ii) ! USES ONLY 3-IDX TENSORS
|
||||
accu += three_e_diag_parrallel_spin(mm,jj,ii)
|
||||
enddo
|
||||
enddo
|
||||
enddo
|
||||
!print*,'bbb = ',accu
|
||||
endif
|
||||
|
||||
end
|
||||
|
@ -269,20 +256,16 @@ subroutine double_htilde_three_body_ints_bi_ort(Nint, key_j, key_i, hthree)
|
|||
if(Ne(1)+Ne(2).ge.3)then
|
||||
if(s1==s2)then ! same spin excitation
|
||||
ispin = other_spin(s1)
|
||||
! print*,'htilde ij'
|
||||
do m = 1, Ne(ispin) ! direct(other_spin) - exchange(s1)
|
||||
mm = occ(m,ispin)
|
||||
!! direct_int = three_body_ints_bi_ort(mm,p2,p1,mm,h2,h1)
|
||||
!! exchange_int = three_body_ints_bi_ort(mm,p2,p1,mm,h1,h2)
|
||||
direct_int = three_e_5_idx_direct_bi_ort(mm,p2,h2,p1,h1)
|
||||
exchange_int = three_e_5_idx_exch12_bi_ort(mm,p2,h2,p1,h1)
|
||||
! print*,direct_int,exchange_int
|
||||
hthree += direct_int - exchange_int
|
||||
enddo
|
||||
do m = 1, Ne(s1) ! pure contribution from s1
|
||||
mm = occ(m,s1)
|
||||
hthree += three_e_double_parrallel_spin(mm,p2,h2,p1,h1)
|
||||
enddo
|
||||
do m = 1, Ne(ispin) ! direct(other_spin) - exchange(s1)
|
||||
mm = occ(m,ispin)
|
||||
direct_int = three_e_5_idx_direct_bi_ort(mm,p2,h2,p1,h1)
|
||||
exchange_int = three_e_5_idx_exch12_bi_ort(mm,p2,h2,p1,h1)
|
||||
hthree += direct_int - exchange_int
|
||||
enddo
|
||||
do m = 1, Ne(s1) ! pure contribution from s1
|
||||
mm = occ(m,s1)
|
||||
hthree += three_e_double_parrallel_spin(mm,p2,h2,p1,h1)
|
||||
enddo
|
||||
else ! different spin excitation
|
||||
do m = 1, Ne(s1)
|
||||
mm = occ(m,s1) !
|
||||
|
|
86
src/tc_bi_ortho/slater_tc_opt.irp.f
Normal file
86
src/tc_bi_ortho/slater_tc_opt.irp.f
Normal file
|
@ -0,0 +1,86 @@
|
|||
subroutine htilde_mu_mat_opt_bi_ortho(key_j, key_i, Nint, hmono, htwoe, hthree, htot)
|
||||
|
||||
BEGIN_DOC
|
||||
!
|
||||
! <key_j | H_tilde | key_i> where |key_j> is developed on the LEFT basis and |key_i> is developed on the RIGHT basis
|
||||
!!
|
||||
! Returns the detail of the matrix element in terms of single, two and three electron contribution.
|
||||
!! WARNING !!
|
||||
!
|
||||
! Non hermitian !!
|
||||
!
|
||||
END_DOC
|
||||
|
||||
use bitmasks
|
||||
|
||||
implicit none
|
||||
integer, intent(in) :: Nint
|
||||
integer(bit_kind), intent(in) :: key_i(Nint,2), key_j(Nint,2)
|
||||
double precision, intent(out) :: hmono, htwoe, hthree, htot
|
||||
integer :: degree
|
||||
|
||||
hmono = 0.d0
|
||||
htwoe = 0.d0
|
||||
htot = 0.d0
|
||||
hthree = 0.D0
|
||||
|
||||
call get_excitation_degree(key_i, key_j, degree, Nint)
|
||||
if(degree.gt.2) return
|
||||
|
||||
if(degree == 0)then
|
||||
call diag_htilde_mu_mat_fock_bi_ortho (Nint, key_i, hmono, htwoe, hthree, htot)
|
||||
else if (degree == 1)then
|
||||
call single_htilde_mu_mat_fock_bi_ortho(Nint,key_j, key_i , hmono, htwoe, hthree, htot)
|
||||
else if(degree == 2)then
|
||||
call double_htilde_mu_mat_fock_bi_ortho(Nint, key_j, key_i, hmono, htwoe, hthree, htot)
|
||||
endif
|
||||
|
||||
if(degree==0) then
|
||||
htot += nuclear_repulsion
|
||||
endif
|
||||
|
||||
end
|
||||
|
||||
! ---
|
||||
|
||||
subroutine htilde_mu_mat_opt_bi_ortho_no_3e(key_j, key_i, Nint, htot)
|
||||
|
||||
BEGIN_DOC
|
||||
!
|
||||
! <key_j | H_tilde | key_i> where |key_j> is developed on the LEFT basis and |key_i> is developed on the RIGHT basis
|
||||
!!
|
||||
! Returns the detail of the matrix element WITHOUT ANY CONTRIBUTION FROM THE THREE ELECTRON TERMS
|
||||
!! WARNING !!
|
||||
!
|
||||
! Non hermitian !!
|
||||
!
|
||||
END_DOC
|
||||
|
||||
use bitmasks
|
||||
|
||||
implicit none
|
||||
integer, intent(in) :: Nint
|
||||
integer(bit_kind), intent(in) :: key_i(Nint,2), key_j(Nint,2)
|
||||
double precision, intent(out) :: htot
|
||||
integer :: degree
|
||||
|
||||
htot = 0.d0
|
||||
|
||||
call get_excitation_degree(key_i, key_j, degree, Nint)
|
||||
if(degree.gt.2) return
|
||||
|
||||
if(degree == 0)then
|
||||
call diag_htilde_mu_mat_fock_bi_ortho_no_3e(Nint, key_i,htot)
|
||||
else if (degree == 1)then
|
||||
call single_htilde_mu_mat_fock_bi_ortho_no_3e(Nint,key_j, key_i , htot)
|
||||
else if(degree == 2)then
|
||||
call double_htilde_mu_mat_fock_bi_ortho_no_3e(Nint, key_j, key_i, htot)
|
||||
endif
|
||||
|
||||
if(degree==0) then
|
||||
htot += nuclear_repulsion
|
||||
endif
|
||||
|
||||
end
|
||||
|
||||
! ---
|
473
src/tc_bi_ortho/slater_tc_opt_diag.irp.f
Normal file
473
src/tc_bi_ortho/slater_tc_opt_diag.irp.f
Normal file
|
@ -0,0 +1,473 @@
|
|||
BEGIN_PROVIDER [ double precision, ref_tc_energy_tot]
|
||||
&BEGIN_PROVIDER [ double precision, ref_tc_energy_1e]
|
||||
&BEGIN_PROVIDER [ double precision, ref_tc_energy_2e]
|
||||
&BEGIN_PROVIDER [ double precision, ref_tc_energy_3e]
|
||||
implicit none
|
||||
BEGIN_DOC
|
||||
! Various component of the TC energy for the reference "HF" Slater determinant
|
||||
END_DOC
|
||||
double precision :: hmono, htwoe, htot, hthree
|
||||
call diag_htilde_mu_mat_bi_ortho(N_int,HF_bitmask , hmono, htwoe, htot)
|
||||
ref_tc_energy_1e = hmono
|
||||
ref_tc_energy_2e = htwoe
|
||||
if(three_body_h_tc)then
|
||||
call diag_htilde_three_body_ints_bi_ort(N_int, HF_bitmask, hthree)
|
||||
ref_tc_energy_3e = hthree
|
||||
else
|
||||
ref_tc_energy_3e = 0.d0
|
||||
endif
|
||||
ref_tc_energy_tot = ref_tc_energy_1e + ref_tc_energy_2e + ref_tc_energy_3e
|
||||
END_PROVIDER
|
||||
|
||||
subroutine diag_htilde_mu_mat_fock_bi_ortho(Nint, det_in, hmono, htwoe, hthree, htot)
|
||||
implicit none
|
||||
BEGIN_DOC
|
||||
! Computes $\langle i|H|i \rangle$.
|
||||
END_DOC
|
||||
integer,intent(in) :: Nint
|
||||
integer(bit_kind),intent(in) :: det_in(Nint,2)
|
||||
double precision, intent(out) :: hmono,htwoe,htot,hthree
|
||||
|
||||
integer(bit_kind) :: hole(Nint,2)
|
||||
integer(bit_kind) :: particle(Nint,2)
|
||||
integer :: i, nexc(2), ispin
|
||||
integer :: occ_particle(Nint*bit_kind_size,2)
|
||||
integer :: occ_hole(Nint*bit_kind_size,2)
|
||||
integer(bit_kind) :: det_tmp(Nint,2)
|
||||
integer :: na, nb
|
||||
|
||||
ASSERT (Nint > 0)
|
||||
ASSERT (sum(popcnt(det_in(:,1))) == elec_alpha_num)
|
||||
ASSERT (sum(popcnt(det_in(:,2))) == elec_beta_num)
|
||||
|
||||
|
||||
nexc(1) = 0
|
||||
nexc(2) = 0
|
||||
do i=1,Nint
|
||||
hole(i,1) = xor(det_in(i,1),ref_bitmask(i,1))
|
||||
hole(i,2) = xor(det_in(i,2),ref_bitmask(i,2))
|
||||
particle(i,1) = iand(hole(i,1),det_in(i,1))
|
||||
particle(i,2) = iand(hole(i,2),det_in(i,2))
|
||||
hole(i,1) = iand(hole(i,1),ref_bitmask(i,1))
|
||||
hole(i,2) = iand(hole(i,2),ref_bitmask(i,2))
|
||||
nexc(1) = nexc(1) + popcnt(hole(i,1))
|
||||
nexc(2) = nexc(2) + popcnt(hole(i,2))
|
||||
enddo
|
||||
|
||||
if (nexc(1)+nexc(2) == 0) then
|
||||
hmono = ref_tc_energy_1e
|
||||
htwoe = ref_tc_energy_2e
|
||||
hthree= ref_tc_energy_3e
|
||||
htot = ref_tc_energy_tot
|
||||
return
|
||||
endif
|
||||
|
||||
!call debug_det(det_in,Nint)
|
||||
integer :: tmp(2)
|
||||
!DIR$ FORCEINLINE
|
||||
call bitstring_to_list_ab(particle, occ_particle, tmp, Nint)
|
||||
ASSERT (tmp(1) == nexc(1)) ! Number of particles alpha
|
||||
ASSERT (tmp(2) == nexc(2)) ! Number of particle beta
|
||||
!DIR$ FORCEINLINE
|
||||
call bitstring_to_list_ab(hole, occ_hole, tmp, Nint)
|
||||
ASSERT (tmp(1) == nexc(1)) ! Number of holes alpha
|
||||
ASSERT (tmp(2) == nexc(2)) ! Number of holes beta
|
||||
|
||||
|
||||
det_tmp = ref_bitmask
|
||||
hmono = ref_tc_energy_1e
|
||||
htwoe = ref_tc_energy_2e
|
||||
hthree= ref_tc_energy_3e
|
||||
do ispin=1,2
|
||||
na = elec_num_tab(ispin)
|
||||
nb = elec_num_tab(iand(ispin,1)+1)
|
||||
do i=1,nexc(ispin)
|
||||
!DIR$ FORCEINLINE
|
||||
call ac_tc_operator( occ_particle(i,ispin), ispin, det_tmp, hmono,htwoe,hthree, Nint,na,nb)
|
||||
!DIR$ FORCEINLINE
|
||||
call a_tc_operator ( occ_hole (i,ispin), ispin, det_tmp, hmono,htwoe,hthree, Nint,na,nb)
|
||||
enddo
|
||||
enddo
|
||||
htot = hmono+htwoe+hthree
|
||||
end
|
||||
|
||||
subroutine ac_tc_operator(iorb,ispin,key,hmono,htwoe,hthree,Nint,na,nb)
|
||||
use bitmasks
|
||||
implicit none
|
||||
BEGIN_DOC
|
||||
! Routine that computes one- and two-body energy corresponding
|
||||
!
|
||||
! to the ADDITION of an electron in an orbital 'iorb' of spin 'ispin'
|
||||
!
|
||||
! onto a determinant 'key'.
|
||||
!
|
||||
! in output, the determinant key is changed by the ADDITION of that electron
|
||||
!
|
||||
! and the quantities hmono,htwoe,hthree are INCREMENTED
|
||||
END_DOC
|
||||
integer, intent(in) :: iorb, ispin, Nint
|
||||
integer, intent(inout) :: na, nb
|
||||
integer(bit_kind), intent(inout) :: key(Nint,2)
|
||||
double precision, intent(inout) :: hmono,htwoe,hthree
|
||||
|
||||
integer :: occ(Nint*bit_kind_size,2)
|
||||
integer :: other_spin
|
||||
integer :: k,l,i,jj,mm,j,m
|
||||
double precision :: direct_int, exchange_int
|
||||
|
||||
|
||||
if (iorb < 1) then
|
||||
print *, irp_here, ': iorb < 1'
|
||||
print *, iorb, mo_num
|
||||
stop -1
|
||||
endif
|
||||
if (iorb > mo_num) then
|
||||
print *, irp_here, ': iorb > mo_num'
|
||||
print *, iorb, mo_num
|
||||
stop -1
|
||||
endif
|
||||
|
||||
ASSERT (ispin > 0)
|
||||
ASSERT (ispin < 3)
|
||||
ASSERT (Nint > 0)
|
||||
|
||||
integer :: tmp(2)
|
||||
!DIR$ FORCEINLINE
|
||||
call bitstring_to_list_ab(key, occ, tmp, Nint)
|
||||
ASSERT (tmp(1) == elec_alpha_num)
|
||||
ASSERT (tmp(2) == elec_beta_num)
|
||||
|
||||
k = shiftr(iorb-1,bit_kind_shift)+1
|
||||
ASSERT (k >0)
|
||||
l = iorb - shiftl(k-1,bit_kind_shift)-1
|
||||
ASSERT (l >= 0)
|
||||
key(k,ispin) = ibset(key(k,ispin),l)
|
||||
other_spin = iand(ispin,1)+1
|
||||
|
||||
hmono = hmono + mo_bi_ortho_tc_one_e(iorb,iorb)
|
||||
|
||||
! Same spin
|
||||
do i=1,na
|
||||
htwoe = htwoe + mo_bi_ortho_tc_two_e_jj_anti(occ(i,ispin),iorb)
|
||||
enddo
|
||||
|
||||
! Opposite spin
|
||||
do i=1,nb
|
||||
htwoe = htwoe + mo_bi_ortho_tc_two_e_jj(occ(i,other_spin),iorb)
|
||||
enddo
|
||||
|
||||
if(three_body_h_tc)then
|
||||
!!!!! 3-e part
|
||||
!! same-spin/same-spin
|
||||
do j = 1, na
|
||||
jj = occ(j,ispin)
|
||||
do m = j+1, na
|
||||
mm = occ(m,ispin)
|
||||
hthree += three_e_diag_parrallel_spin_prov(mm,jj,iorb)
|
||||
enddo
|
||||
enddo
|
||||
!! same-spin/oposite-spin
|
||||
do j = 1, na
|
||||
jj = occ(j,ispin)
|
||||
do m = 1, nb
|
||||
mm = occ(m,other_spin)
|
||||
direct_int = three_e_3_idx_direct_bi_ort(mm,jj,iorb) ! USES 3-IDX TENSOR
|
||||
exchange_int = three_e_3_idx_exch12_bi_ort(mm,jj,iorb) ! USES 3-IDX TENSOR
|
||||
hthree += direct_int - exchange_int
|
||||
enddo
|
||||
enddo
|
||||
!! oposite-spin/opposite-spin
|
||||
do j = 1, nb
|
||||
jj = occ(j,other_spin)
|
||||
do m = j+1, nb
|
||||
mm = occ(m,other_spin)
|
||||
direct_int = three_e_3_idx_direct_bi_ort(mm,jj,iorb) ! USES 3-IDX TENSOR
|
||||
exchange_int = three_e_3_idx_exch23_bi_ort(mm,jj,iorb) ! USES 3-IDX TENSOR
|
||||
hthree += direct_int - exchange_int
|
||||
enddo
|
||||
enddo
|
||||
endif
|
||||
|
||||
na = na+1
|
||||
end
|
||||
|
||||
subroutine a_tc_operator(iorb,ispin,key,hmono,htwoe,hthree,Nint,na,nb)
|
||||
use bitmasks
|
||||
implicit none
|
||||
BEGIN_DOC
|
||||
! Routine that computes one- and two-body energy corresponding
|
||||
!
|
||||
! to the REMOVAL of an electron in an orbital 'iorb' of spin 'ispin'
|
||||
!
|
||||
! onto a determinant 'key'.
|
||||
!
|
||||
! in output, the determinant key is changed by the REMOVAL of that electron
|
||||
!
|
||||
! and the quantities hmono,htwoe,hthree are INCREMENTED
|
||||
END_DOC
|
||||
integer, intent(in) :: iorb, ispin, Nint
|
||||
integer, intent(inout) :: na, nb
|
||||
integer(bit_kind), intent(inout) :: key(Nint,2)
|
||||
double precision, intent(inout) :: hmono,htwoe,hthree
|
||||
|
||||
double precision :: direct_int, exchange_int
|
||||
integer :: occ(Nint*bit_kind_size,2)
|
||||
integer :: other_spin
|
||||
integer :: k,l,i,jj,mm,j,m
|
||||
integer :: tmp(2)
|
||||
|
||||
ASSERT (iorb > 0)
|
||||
ASSERT (ispin > 0)
|
||||
ASSERT (ispin < 3)
|
||||
ASSERT (Nint > 0)
|
||||
|
||||
k = shiftr(iorb-1,bit_kind_shift)+1
|
||||
ASSERT (k>0)
|
||||
l = iorb - shiftl(k-1,bit_kind_shift)-1
|
||||
key(k,ispin) = ibclr(key(k,ispin),l)
|
||||
other_spin = iand(ispin,1)+1
|
||||
|
||||
!DIR$ FORCEINLINE
|
||||
call bitstring_to_list_ab(key, occ, tmp, Nint)
|
||||
na = na-1
|
||||
|
||||
hmono = hmono - mo_bi_ortho_tc_one_e(iorb,iorb)
|
||||
|
||||
! Same spin
|
||||
do i=1,na
|
||||
htwoe= htwoe- mo_bi_ortho_tc_two_e_jj_anti(occ(i,ispin),iorb)
|
||||
enddo
|
||||
|
||||
! Opposite spin
|
||||
do i=1,nb
|
||||
htwoe= htwoe- mo_bi_ortho_tc_two_e_jj(occ(i,other_spin),iorb)
|
||||
enddo
|
||||
|
||||
if(three_body_h_tc)then
|
||||
!!!!! 3-e part
|
||||
!! same-spin/same-spin
|
||||
do j = 1, na
|
||||
jj = occ(j,ispin)
|
||||
do m = j+1, na
|
||||
mm = occ(m,ispin)
|
||||
hthree -= three_e_diag_parrallel_spin_prov(mm,jj,iorb)
|
||||
enddo
|
||||
enddo
|
||||
!! same-spin/oposite-spin
|
||||
do j = 1, na
|
||||
jj = occ(j,ispin)
|
||||
do m = 1, nb
|
||||
mm = occ(m,other_spin)
|
||||
direct_int = three_e_3_idx_direct_bi_ort(mm,jj,iorb) ! USES 3-IDX TENSOR
|
||||
exchange_int = three_e_3_idx_exch12_bi_ort(mm,jj,iorb) ! USES 3-IDX TENSOR
|
||||
hthree -= (direct_int - exchange_int)
|
||||
enddo
|
||||
enddo
|
||||
!! oposite-spin/opposite-spin
|
||||
do j = 1, nb
|
||||
jj = occ(j,other_spin)
|
||||
do m = j+1, nb
|
||||
mm = occ(m,other_spin)
|
||||
direct_int = three_e_3_idx_direct_bi_ort(mm,jj,iorb) ! USES 3-IDX TENSOR
|
||||
exchange_int = three_e_3_idx_exch23_bi_ort(mm,jj,iorb) ! USES 3-IDX TENSOR
|
||||
hthree -= (direct_int - exchange_int)
|
||||
enddo
|
||||
enddo
|
||||
endif
|
||||
|
||||
end
|
||||
|
||||
|
||||
subroutine diag_htilde_mu_mat_fock_bi_ortho_no_3e(Nint, det_in,htot)
|
||||
implicit none
|
||||
BEGIN_DOC
|
||||
! Computes $\langle i|H|i \rangle$. WITHOUT ANY CONTRIBUTIONS FROM 3E TERMS
|
||||
END_DOC
|
||||
integer,intent(in) :: Nint
|
||||
integer(bit_kind),intent(in) :: det_in(Nint,2)
|
||||
double precision, intent(out) :: htot
|
||||
double precision :: hmono,htwoe
|
||||
|
||||
integer(bit_kind) :: hole(Nint,2)
|
||||
integer(bit_kind) :: particle(Nint,2)
|
||||
integer :: i, nexc(2), ispin
|
||||
integer :: occ_particle(Nint*bit_kind_size,2)
|
||||
integer :: occ_hole(Nint*bit_kind_size,2)
|
||||
integer(bit_kind) :: det_tmp(Nint,2)
|
||||
integer :: na, nb
|
||||
|
||||
ASSERT (Nint > 0)
|
||||
ASSERT (sum(popcnt(det_in(:,1))) == elec_alpha_num)
|
||||
ASSERT (sum(popcnt(det_in(:,2))) == elec_beta_num)
|
||||
|
||||
|
||||
nexc(1) = 0
|
||||
nexc(2) = 0
|
||||
do i=1,Nint
|
||||
hole(i,1) = xor(det_in(i,1),ref_bitmask(i,1))
|
||||
hole(i,2) = xor(det_in(i,2),ref_bitmask(i,2))
|
||||
particle(i,1) = iand(hole(i,1),det_in(i,1))
|
||||
particle(i,2) = iand(hole(i,2),det_in(i,2))
|
||||
hole(i,1) = iand(hole(i,1),ref_bitmask(i,1))
|
||||
hole(i,2) = iand(hole(i,2),ref_bitmask(i,2))
|
||||
nexc(1) = nexc(1) + popcnt(hole(i,1))
|
||||
nexc(2) = nexc(2) + popcnt(hole(i,2))
|
||||
enddo
|
||||
|
||||
if (nexc(1)+nexc(2) == 0) then
|
||||
hmono = ref_tc_energy_1e
|
||||
htwoe = ref_tc_energy_2e
|
||||
htot = ref_tc_energy_tot
|
||||
return
|
||||
endif
|
||||
|
||||
!call debug_det(det_in,Nint)
|
||||
integer :: tmp(2)
|
||||
!DIR$ FORCEINLINE
|
||||
call bitstring_to_list_ab(particle, occ_particle, tmp, Nint)
|
||||
ASSERT (tmp(1) == nexc(1)) ! Number of particles alpha
|
||||
ASSERT (tmp(2) == nexc(2)) ! Number of particle beta
|
||||
!DIR$ FORCEINLINE
|
||||
call bitstring_to_list_ab(hole, occ_hole, tmp, Nint)
|
||||
ASSERT (tmp(1) == nexc(1)) ! Number of holes alpha
|
||||
ASSERT (tmp(2) == nexc(2)) ! Number of holes beta
|
||||
|
||||
|
||||
det_tmp = ref_bitmask
|
||||
hmono = ref_tc_energy_1e
|
||||
htwoe = ref_tc_energy_2e
|
||||
do ispin=1,2
|
||||
na = elec_num_tab(ispin)
|
||||
nb = elec_num_tab(iand(ispin,1)+1)
|
||||
do i=1,nexc(ispin)
|
||||
!DIR$ FORCEINLINE
|
||||
call ac_tc_operator_no_3e( occ_particle(i,ispin), ispin, det_tmp, hmono,htwoe, Nint,na,nb)
|
||||
!DIR$ FORCEINLINE
|
||||
call a_tc_operator_no_3e ( occ_hole (i,ispin), ispin, det_tmp, hmono,htwoe, Nint,na,nb)
|
||||
enddo
|
||||
enddo
|
||||
htot = hmono+htwoe
|
||||
end
|
||||
|
||||
subroutine ac_tc_operator_no_3e(iorb,ispin,key,hmono,htwoe,Nint,na,nb)
|
||||
use bitmasks
|
||||
implicit none
|
||||
BEGIN_DOC
|
||||
! Routine that computes one- and two-body energy corresponding
|
||||
!
|
||||
! to the ADDITION of an electron in an orbital 'iorb' of spin 'ispin'
|
||||
!
|
||||
! onto a determinant 'key'.
|
||||
!
|
||||
! in output, the determinant key is changed by the ADDITION of that electron
|
||||
!
|
||||
! and the quantities hmono,htwoe are INCREMENTED
|
||||
END_DOC
|
||||
integer, intent(in) :: iorb, ispin, Nint
|
||||
integer, intent(inout) :: na, nb
|
||||
integer(bit_kind), intent(inout) :: key(Nint,2)
|
||||
double precision, intent(inout) :: hmono,htwoe
|
||||
|
||||
integer :: occ(Nint*bit_kind_size,2)
|
||||
integer :: other_spin
|
||||
integer :: k,l,i,jj,mm,j,m
|
||||
double precision :: direct_int, exchange_int
|
||||
|
||||
|
||||
if (iorb < 1) then
|
||||
print *, irp_here, ': iorb < 1'
|
||||
print *, iorb, mo_num
|
||||
stop -1
|
||||
endif
|
||||
if (iorb > mo_num) then
|
||||
print *, irp_here, ': iorb > mo_num'
|
||||
print *, iorb, mo_num
|
||||
stop -1
|
||||
endif
|
||||
|
||||
ASSERT (ispin > 0)
|
||||
ASSERT (ispin < 3)
|
||||
ASSERT (Nint > 0)
|
||||
|
||||
integer :: tmp(2)
|
||||
!DIR$ FORCEINLINE
|
||||
call bitstring_to_list_ab(key, occ, tmp, Nint)
|
||||
ASSERT (tmp(1) == elec_alpha_num)
|
||||
ASSERT (tmp(2) == elec_beta_num)
|
||||
|
||||
k = shiftr(iorb-1,bit_kind_shift)+1
|
||||
ASSERT (k >0)
|
||||
l = iorb - shiftl(k-1,bit_kind_shift)-1
|
||||
ASSERT (l >= 0)
|
||||
key(k,ispin) = ibset(key(k,ispin),l)
|
||||
other_spin = iand(ispin,1)+1
|
||||
|
||||
hmono = hmono + mo_bi_ortho_tc_one_e(iorb,iorb)
|
||||
|
||||
! Same spin
|
||||
do i=1,na
|
||||
htwoe = htwoe + mo_bi_ortho_tc_two_e_jj_anti(occ(i,ispin),iorb)
|
||||
enddo
|
||||
|
||||
! Opposite spin
|
||||
do i=1,nb
|
||||
htwoe = htwoe + mo_bi_ortho_tc_two_e_jj(occ(i,other_spin),iorb)
|
||||
enddo
|
||||
|
||||
na = na+1
|
||||
end
|
||||
|
||||
subroutine a_tc_operator_no_3e(iorb,ispin,key,hmono,htwoe,Nint,na,nb)
|
||||
use bitmasks
|
||||
implicit none
|
||||
BEGIN_DOC
|
||||
! Routine that computes one- and two-body energy corresponding
|
||||
!
|
||||
! to the REMOVAL of an electron in an orbital 'iorb' of spin 'ispin'
|
||||
!
|
||||
! onto a determinant 'key'.
|
||||
!
|
||||
! in output, the determinant key is changed by the REMOVAL of that electron
|
||||
!
|
||||
! and the quantities hmono,htwoe are INCREMENTED
|
||||
END_DOC
|
||||
integer, intent(in) :: iorb, ispin, Nint
|
||||
integer, intent(inout) :: na, nb
|
||||
integer(bit_kind), intent(inout) :: key(Nint,2)
|
||||
double precision, intent(inout) :: hmono,htwoe
|
||||
|
||||
double precision :: direct_int, exchange_int
|
||||
integer :: occ(Nint*bit_kind_size,2)
|
||||
integer :: other_spin
|
||||
integer :: k,l,i,jj,mm,j,m
|
||||
integer :: tmp(2)
|
||||
|
||||
ASSERT (iorb > 0)
|
||||
ASSERT (ispin > 0)
|
||||
ASSERT (ispin < 3)
|
||||
ASSERT (Nint > 0)
|
||||
|
||||
k = shiftr(iorb-1,bit_kind_shift)+1
|
||||
ASSERT (k>0)
|
||||
l = iorb - shiftl(k-1,bit_kind_shift)-1
|
||||
key(k,ispin) = ibclr(key(k,ispin),l)
|
||||
other_spin = iand(ispin,1)+1
|
||||
|
||||
!DIR$ FORCEINLINE
|
||||
call bitstring_to_list_ab(key, occ, tmp, Nint)
|
||||
na = na-1
|
||||
|
||||
hmono = hmono - mo_bi_ortho_tc_one_e(iorb,iorb)
|
||||
|
||||
! Same spin
|
||||
do i=1,na
|
||||
htwoe= htwoe- mo_bi_ortho_tc_two_e_jj_anti(occ(i,ispin),iorb)
|
||||
enddo
|
||||
|
||||
! Opposite spin
|
||||
do i=1,nb
|
||||
htwoe= htwoe- mo_bi_ortho_tc_two_e_jj(occ(i,other_spin),iorb)
|
||||
enddo
|
||||
|
||||
end
|
||||
|
476
src/tc_bi_ortho/slater_tc_opt_double.irp.f
Normal file
476
src/tc_bi_ortho/slater_tc_opt_double.irp.f
Normal file
|
@ -0,0 +1,476 @@
|
|||
|
||||
subroutine double_htilde_mu_mat_fock_bi_ortho(Nint, key_j, key_i, hmono, htwoe, hthree, htot)
|
||||
|
||||
BEGIN_DOC
|
||||
! <key_j | H_tilde | key_i> for double excitation ONLY FOR ONE- AND TWO-BODY TERMS
|
||||
!!
|
||||
!! WARNING !!
|
||||
!
|
||||
! Non hermitian !!
|
||||
END_DOC
|
||||
|
||||
use bitmasks
|
||||
|
||||
implicit none
|
||||
integer, intent(in) :: Nint
|
||||
integer(bit_kind), intent(in) :: key_j(Nint,2), key_i(Nint,2)
|
||||
double precision, intent(out) :: hmono, htwoe, hthree, htot
|
||||
integer :: occ(Nint*bit_kind_size,2)
|
||||
integer :: Ne(2), i, j, ii, jj, ispin, jspin, k, kk
|
||||
integer :: degree,exc(0:2,2,2)
|
||||
integer :: h1, p1, h2, p2, s1, s2
|
||||
double precision :: get_mo_two_e_integral_tc_int,phase
|
||||
|
||||
|
||||
call get_excitation_degree(key_i, key_j, degree, Nint)
|
||||
|
||||
hmono = 0.d0
|
||||
htwoe = 0.d0
|
||||
hthree = 0.d0
|
||||
htot = 0.d0
|
||||
|
||||
if(degree.ne.2)then
|
||||
return
|
||||
endif
|
||||
integer :: degree_i,degree_j
|
||||
call get_excitation_degree(ref_bitmask,key_i,degree_i,N_int)
|
||||
call get_excitation_degree(ref_bitmask,key_j,degree_j,N_int)
|
||||
call get_double_excitation(key_i, key_j, exc, phase, Nint)
|
||||
call decode_exc(exc, 2, h1, p1, h2, p2, s1, s2)
|
||||
|
||||
if(s1.ne.s2)then
|
||||
! opposite spin two-body
|
||||
htwoe = mo_bi_ortho_tc_two_e(p2,p1,h2,h1)
|
||||
if(three_body_h_tc)then
|
||||
if(.not.double_normal_ord)then
|
||||
if(degree_i>degree_j)then
|
||||
call three_comp_two_e_elem(key_j,h1,h2,p1,p2,s1,s2,hthree)
|
||||
else
|
||||
call three_comp_two_e_elem(key_i,h1,h2,p1,p2,s1,s2,hthree)
|
||||
endif
|
||||
elseif(double_normal_ord.and.elec_num+elec_num.gt.2)then
|
||||
htwoe += normal_two_body_bi_orth(p2,h2,p1,h1)!!! WTF ???
|
||||
endif
|
||||
endif
|
||||
else
|
||||
! same spin two-body
|
||||
! direct terms
|
||||
htwoe = mo_bi_ortho_tc_two_e(p2,p1,h2,h1)
|
||||
! exchange terms
|
||||
htwoe -= mo_bi_ortho_tc_two_e(p1,p2,h2,h1)
|
||||
if(three_body_h_tc)then
|
||||
if(.not.double_normal_ord)then
|
||||
if(degree_i>degree_j)then
|
||||
call three_comp_two_e_elem(key_j,h1,h2,p1,p2,s1,s2,hthree)
|
||||
else
|
||||
call three_comp_two_e_elem(key_i,h1,h2,p1,p2,s1,s2,hthree)
|
||||
endif
|
||||
elseif(double_normal_ord.and.elec_num+elec_num.gt.2)then
|
||||
htwoe -= normal_two_body_bi_orth(h2,p1,h1,p2)!!! WTF ???
|
||||
htwoe += normal_two_body_bi_orth(h1,p1,h2,p2)!!! WTF ???
|
||||
endif
|
||||
endif
|
||||
endif
|
||||
hthree *= phase
|
||||
htwoe *= phase
|
||||
htot = htwoe + hthree
|
||||
|
||||
end
|
||||
|
||||
|
||||
|
||||
subroutine three_comp_two_e_elem(key_i,h1,h2,p1,p2,s1,s2,hthree)
|
||||
implicit none
|
||||
integer(bit_kind), intent(in) :: key_i(N_int,2)
|
||||
integer, intent(in) :: h1,h2,p1,p2,s1,s2
|
||||
double precision, intent(out) :: hthree
|
||||
integer :: nexc(2),i,ispin,na,nb
|
||||
integer(bit_kind) :: hole(N_int,2)
|
||||
integer(bit_kind) :: particle(N_int,2)
|
||||
integer :: occ_hole(N_int*bit_kind_size,2)
|
||||
integer :: occ_particle(N_int*bit_kind_size,2)
|
||||
integer :: n_occ_ab_hole(2),n_occ_ab_particle(2)
|
||||
integer(bit_kind) :: det_tmp(N_int,2)
|
||||
integer :: ipart, ihole
|
||||
double precision :: direct_int, exchange_int
|
||||
|
||||
nexc(1) = 0
|
||||
nexc(2) = 0
|
||||
!! Get all the holes and particles of key_i with respect to the ROHF determinant
|
||||
do i=1,N_int
|
||||
hole(i,1) = xor(key_i(i,1),ref_bitmask(i,1))
|
||||
hole(i,2) = xor(key_i(i,2),ref_bitmask(i,2))
|
||||
particle(i,1) = iand(hole(i,1),key_i(i,1))
|
||||
particle(i,2) = iand(hole(i,2),key_i(i,2))
|
||||
hole(i,1) = iand(hole(i,1),ref_bitmask(i,1))
|
||||
hole(i,2) = iand(hole(i,2),ref_bitmask(i,2))
|
||||
nexc(1) = nexc(1) + popcnt(hole(i,1))
|
||||
nexc(2) = nexc(2) + popcnt(hole(i,2))
|
||||
enddo
|
||||
integer :: tmp(2)
|
||||
!DIR$ FORCEINLINE
|
||||
call bitstring_to_list_ab(particle, occ_particle, tmp, N_int)
|
||||
ASSERT (tmp(1) == nexc(1)) ! Number of particles alpha
|
||||
ASSERT (tmp(2) == nexc(2)) ! Number of particle beta
|
||||
!DIR$ FORCEINLINE
|
||||
call bitstring_to_list_ab(hole, occ_hole, tmp, N_int)
|
||||
ASSERT (tmp(1) == nexc(1)) ! Number of holes alpha
|
||||
ASSERT (tmp(2) == nexc(2)) ! Number of holes beta
|
||||
if(s1==s2.and.s1==1)then
|
||||
!!!!!!!!!!!!!!!!!!!!!!!!!! alpha/alpha double exc
|
||||
hthree = eff_2_e_from_3_e_aa(p2,p1,h2,h1)
|
||||
if(nexc(1)+nexc(2) ==0)return !! if you're on the reference determinant
|
||||
!!!!!!!! the matrix element is already exact
|
||||
!!!!!!!! else you need to take care of holes and particles
|
||||
!!!!!!!!!!!!! Holes and particles !!!!!!!!!!!!!!!!!!!!!!!
|
||||
ispin = 1 ! i==alpha ==> pure same spin terms
|
||||
do i = 1, nexc(ispin) ! number of couple of holes/particles
|
||||
ipart=occ_particle(i,ispin)
|
||||
hthree += three_e_double_parrallel_spin_prov(ipart,p2,h2,p1,h1)
|
||||
ihole=occ_hole(i,ispin)
|
||||
hthree -= three_e_double_parrallel_spin_prov(ihole,p2,h2,p1,h1)
|
||||
enddo
|
||||
ispin = 2 ! i==beta ==> alpha/alpha/beta terms
|
||||
do i = 1, nexc(ispin) ! number of couple of holes/particles
|
||||
! exchange between (h1,p1) and (h2,p2)
|
||||
ipart=occ_particle(i,ispin)
|
||||
direct_int = three_e_5_idx_direct_bi_ort(ipart,p2,h2,p1,h1)
|
||||
exchange_int = three_e_5_idx_exch12_bi_ort(ipart,p2,h2,p1,h1)
|
||||
hthree += direct_int - exchange_int
|
||||
ihole=occ_hole(i,ispin)
|
||||
direct_int = three_e_5_idx_direct_bi_ort(ihole,p2,h2,p1,h1)
|
||||
exchange_int = three_e_5_idx_exch12_bi_ort(ihole,p2,h2,p1,h1)
|
||||
hthree -= direct_int - exchange_int
|
||||
enddo
|
||||
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
|
||||
elseif(s1==s2.and.s1==2)then
|
||||
!!!!!!!!!!!!!!!!!!!!!!!!!! beta/beta double exc
|
||||
hthree = eff_2_e_from_3_e_bb(p2,p1,h2,h1)
|
||||
if(nexc(1)+nexc(2) ==0)return !! if you're on the reference determinant
|
||||
!!!!!!!! the matrix element is already exact
|
||||
!!!!!!!! else you need to take care of holes and particles
|
||||
!!!!!!!!!!!!! Holes and particles !!!!!!!!!!!!!!!!!!!!!!!
|
||||
ispin = 2 ! i==beta ==> pure same spin terms
|
||||
do i = 1, nexc(ispin) ! number of couple of holes/particles
|
||||
ipart=occ_particle(i,ispin)
|
||||
hthree += three_e_double_parrallel_spin_prov(ipart,p2,h2,p1,h1)
|
||||
ihole=occ_hole(i,ispin)
|
||||
hthree -= three_e_double_parrallel_spin_prov(ihole,p2,h2,p1,h1)
|
||||
enddo
|
||||
ispin = 1 ! i==alpha==> beta/beta/alpha terms
|
||||
do i = 1, nexc(ispin) ! number of couple of holes/particles
|
||||
! exchange between (h1,p1) and (h2,p2)
|
||||
ipart=occ_particle(i,ispin)
|
||||
direct_int = three_e_5_idx_direct_bi_ort(ipart,p2,h2,p1,h1)
|
||||
exchange_int = three_e_5_idx_exch12_bi_ort(ipart,p2,h2,p1,h1)
|
||||
hthree += direct_int - exchange_int
|
||||
ihole=occ_hole(i,ispin)
|
||||
direct_int = three_e_5_idx_direct_bi_ort(ihole,p2,h2,p1,h1)
|
||||
exchange_int = three_e_5_idx_exch12_bi_ort(ihole,p2,h2,p1,h1)
|
||||
hthree -= direct_int - exchange_int
|
||||
enddo
|
||||
else ! (h1,p1) == alpha/(h2,p2) == beta
|
||||
hthree = eff_2_e_from_3_e_ab(p2,p1,h2,h1)
|
||||
if(nexc(1)+nexc(2) ==0)return !! if you're on the reference determinant
|
||||
!!!!!!!! the matrix element is already exact
|
||||
!!!!!!!! else you need to take care of holes and particles
|
||||
!!!!!!!!!!!!! Holes and particles !!!!!!!!!!!!!!!!!!!!!!!
|
||||
ispin = 1 ! i==alpha ==> alpha/beta/alpha terms
|
||||
do i = 1, nexc(ispin) ! number of couple of holes/particles
|
||||
! exchange between (h1,p1) and i
|
||||
ipart=occ_particle(i,ispin)
|
||||
direct_int = three_e_5_idx_direct_bi_ort(ipart,p2,h2,p1,h1)
|
||||
exchange_int = three_e_5_idx_exch13_bi_ort(ipart,p2,h2,p1,h1)
|
||||
hthree += direct_int - exchange_int
|
||||
ihole=occ_hole(i,ispin)
|
||||
direct_int = three_e_5_idx_direct_bi_ort(ihole,p2,h2,p1,h1)
|
||||
exchange_int = three_e_5_idx_exch13_bi_ort(ihole,p2,h2,p1,h1)
|
||||
hthree -= direct_int - exchange_int
|
||||
enddo
|
||||
ispin = 2 ! i==beta ==> alpha/beta/beta terms
|
||||
do i = 1, nexc(ispin) ! number of couple of holes/particles
|
||||
! exchange between (h2,p2) and i
|
||||
ipart=occ_particle(i,ispin)
|
||||
direct_int = three_e_5_idx_direct_bi_ort(ipart,p2,h2,p1,h1)
|
||||
exchange_int = three_e_5_idx_exch23_bi_ort(ipart,p2,h2,p1,h1)
|
||||
hthree += direct_int - exchange_int
|
||||
ihole=occ_hole(i,ispin)
|
||||
direct_int = three_e_5_idx_direct_bi_ort(ihole,p2,h2,p1,h1)
|
||||
exchange_int = three_e_5_idx_exch23_bi_ort(ihole,p2,h2,p1,h1)
|
||||
hthree -= direct_int - exchange_int
|
||||
enddo
|
||||
endif
|
||||
end
|
||||
|
||||
|
||||
BEGIN_PROVIDER [ double precision, eff_2_e_from_3_e_ab, (mo_num, mo_num, mo_num, mo_num)]
|
||||
implicit none
|
||||
BEGIN_DOC
|
||||
! eff_2_e_from_3_e_ab(p2,p1,h2,h1) = Effective Two-electron operator for alpha/beta double excitations
|
||||
!
|
||||
! from contraction with HF density = a^{dagger}_p1_alpha a^{dagger}_p2_beta a_h2_beta a_h1_alpha
|
||||
END_DOC
|
||||
integer :: i,h1,p1,h2,p2
|
||||
integer :: hh1,hh2,pp1,pp2,m,mm
|
||||
integer :: Ne(2)
|
||||
integer, allocatable :: occ(:,:)
|
||||
double precision :: contrib
|
||||
allocate( occ(N_int*bit_kind_size,2) )
|
||||
call bitstring_to_list_ab(ref_bitmask,occ,Ne,N_int)
|
||||
call give_contrib_for_abab(1,1,1,1,occ,Ne,contrib)
|
||||
eff_2_e_from_3_e_ab = 0.d0
|
||||
!$OMP PARALLEL &
|
||||
!$OMP DEFAULT (NONE) &
|
||||
!$OMP PRIVATE (hh1, h1, hh2, h2, pp1, p1, pp2, p2, contrib) &
|
||||
!$OMP SHARED (n_act_orb, list_act, Ne,occ, eff_2_e_from_3_e_ab)
|
||||
!$OMP DO SCHEDULE (static)
|
||||
do hh1 = 1, n_act_orb !! alpha
|
||||
h1 = list_act(hh1)
|
||||
do hh2 = 1, n_act_orb !! beta
|
||||
h2 = list_act(hh2)
|
||||
do pp1 = 1, n_act_orb !! alpha
|
||||
p1 = list_act(pp1)
|
||||
do pp2 = 1, n_act_orb !! beta
|
||||
p2 = list_act(pp2)
|
||||
call give_contrib_for_abab(h1,h2,p1,p2,occ,Ne,contrib)
|
||||
eff_2_e_from_3_e_ab(p2,p1,h2,h1) = contrib
|
||||
enddo
|
||||
enddo
|
||||
enddo
|
||||
enddo
|
||||
!$OMP END DO
|
||||
!$OMP END PARALLEL
|
||||
|
||||
END_PROVIDER
|
||||
|
||||
subroutine give_contrib_for_abab(h1,h2,p1,p2,occ,Ne,contrib)
|
||||
implicit none
|
||||
BEGIN_DOC
|
||||
! gives the contribution for a double excitation (h1,p1)_alpha (h2,p2)_beta
|
||||
!
|
||||
! on top of a determinant whose occupied orbitals is in (occ, Ne)
|
||||
END_DOC
|
||||
integer, intent(in) :: h1,h2,p1,p2,occ(N_int*bit_kind_size,2),Ne(2)
|
||||
double precision, intent(out) :: contrib
|
||||
integer :: mm,m
|
||||
double precision :: direct_int, exchange_int
|
||||
!! h1,p1 == alpha
|
||||
!! h2,p2 == beta
|
||||
contrib = 0.d0
|
||||
do mm = 1, Ne(1) !! alpha
|
||||
m = occ(mm,1)
|
||||
direct_int = three_e_5_idx_direct_bi_ort(mm,p2,h2,p1,h1)
|
||||
! exchange between (h1,p1) and m
|
||||
exchange_int = three_e_5_idx_exch13_bi_ort(mm,p2,h2,p1,h1)
|
||||
contrib += direct_int - exchange_int
|
||||
enddo
|
||||
|
||||
do mm = 1, Ne(2) !! beta
|
||||
m = occ(mm,2)
|
||||
direct_int = three_e_5_idx_direct_bi_ort(mm,p2,h2,p1,h1)
|
||||
! exchange between (h2,p2) and m
|
||||
exchange_int = three_e_5_idx_exch23_bi_ort(mm,p2,h2,p1,h1)
|
||||
contrib += direct_int - exchange_int
|
||||
enddo
|
||||
end
|
||||
|
||||
BEGIN_PROVIDER [ double precision, eff_2_e_from_3_e_aa, (mo_num, mo_num, mo_num, mo_num)]
|
||||
implicit none
|
||||
BEGIN_DOC
|
||||
! eff_2_e_from_3_e_ab(p2,p1,h2,h1) = Effective Two-electron operator for alpha/alpha double excitations
|
||||
!
|
||||
! from contractionelec_alpha_num with HF density = a^{dagger}_p1_alpha a^{dagger}_p2_alpha a_h2_alpha a_h1_alpha
|
||||
!
|
||||
! WARNING :: to be coherent with the phase convention used in the Hamiltonian matrix elements, you must fulfill
|
||||
!
|
||||
! |||| h2>h1, p2>p1 ||||
|
||||
END_DOC
|
||||
integer :: i,h1,p1,h2,p2
|
||||
integer :: hh1,hh2,pp1,pp2,m,mm
|
||||
integer :: Ne(2)
|
||||
integer, allocatable :: occ(:,:)
|
||||
double precision :: contrib
|
||||
allocate( occ(N_int*bit_kind_size,2) )
|
||||
call bitstring_to_list_ab(ref_bitmask,occ,Ne,N_int)
|
||||
call give_contrib_for_aaaa(1 ,1 ,1 ,1 ,occ,Ne,contrib)
|
||||
eff_2_e_from_3_e_aa = 100000000.d0
|
||||
!$OMP PARALLEL &
|
||||
!$OMP DEFAULT (NONE) &
|
||||
!$OMP PRIVATE (hh1, h1, hh2, h2, pp1, p1, pp2, p2, contrib) &
|
||||
!$OMP SHARED (n_act_orb, list_act, Ne,occ, eff_2_e_from_3_e_aa)
|
||||
!$OMP DO SCHEDULE (static)
|
||||
do hh1 = 1, n_act_orb !! alpha
|
||||
h1 = list_act(hh1)
|
||||
do hh2 = hh1+1, n_act_orb !! alpha
|
||||
h2 = list_act(hh2)
|
||||
do pp1 = 1, n_act_orb !! alpha
|
||||
p1 = list_act(pp1)
|
||||
do pp2 = pp1+1, n_act_orb !! alpha
|
||||
p2 = list_act(pp2)
|
||||
call give_contrib_for_aaaa(h1,h2,p1,p2,occ,Ne,contrib)
|
||||
eff_2_e_from_3_e_aa(p2,p1,h2,h1) = contrib
|
||||
enddo
|
||||
enddo
|
||||
enddo
|
||||
enddo
|
||||
!$OMP END DO
|
||||
!$OMP END PARALLEL
|
||||
|
||||
END_PROVIDER
|
||||
|
||||
subroutine give_contrib_for_aaaa(h1,h2,p1,p2,occ,Ne,contrib)
|
||||
implicit none
|
||||
BEGIN_DOC
|
||||
! gives the contribution for a double excitation (h1,p1)_alpha (h2,p2)_alpha
|
||||
!
|
||||
! on top of a determinant whose occupied orbitals is in (occ, Ne)
|
||||
END_DOC
|
||||
integer, intent(in) :: h1,h2,p1,p2,occ(N_int*bit_kind_size,2),Ne(2)
|
||||
double precision, intent(out) :: contrib
|
||||
integer :: mm,m
|
||||
double precision :: direct_int, exchange_int
|
||||
!! h1,p1 == alpha
|
||||
!! h2,p2 == alpha
|
||||
contrib = 0.d0
|
||||
do mm = 1, Ne(1) !! alpha ==> pure parallele spin contribution
|
||||
m = occ(mm,1)
|
||||
contrib += three_e_double_parrallel_spin_prov(m,p2,h2,p1,h1)
|
||||
enddo
|
||||
|
||||
do mm = 1, Ne(2) !! beta
|
||||
m = occ(mm,2)
|
||||
direct_int = three_e_5_idx_direct_bi_ort(mm,p2,h2,p1,h1)
|
||||
! exchange between (h1,p1) and (h2,p2)
|
||||
exchange_int = three_e_5_idx_exch12_bi_ort(mm,p2,h2,p1,h1)
|
||||
contrib += direct_int - exchange_int
|
||||
enddo
|
||||
end
|
||||
|
||||
|
||||
BEGIN_PROVIDER [ double precision, eff_2_e_from_3_e_bb, (mo_num, mo_num, mo_num, mo_num)]
|
||||
implicit none
|
||||
BEGIN_DOC
|
||||
! eff_2_e_from_3_e_ab(p2,p1,h2,h1) = Effective Two-electron operator for beta/beta double excitations
|
||||
!
|
||||
! from contractionelec_beta_num with HF density = a^{dagger}_p1_beta a^{dagger}_p2_beta a_h2_beta a_h1_beta
|
||||
!
|
||||
! WARNING :: to be coherent with the phase convention used in the Hamiltonian matrix elements, you must fulfill
|
||||
!
|
||||
! |||| h2>h1, p2>p1 ||||
|
||||
END_DOC
|
||||
integer :: i,h1,p1,h2,p2
|
||||
integer :: hh1,hh2,pp1,pp2,m,mm
|
||||
integer :: Ne(2)
|
||||
integer, allocatable :: occ(:,:)
|
||||
double precision :: contrib
|
||||
allocate( occ(N_int*bit_kind_size,2) )
|
||||
call bitstring_to_list_ab(ref_bitmask,occ,Ne,N_int)
|
||||
call give_contrib_for_bbbb(1,1 ,1 ,1 ,occ,Ne,contrib)
|
||||
eff_2_e_from_3_e_bb = 100000000.d0
|
||||
!$OMP PARALLEL &
|
||||
!$OMP DEFAULT (NONE) &
|
||||
!$OMP PRIVATE (hh1, h1, hh2, h2, pp1, p1, pp2, p2, contrib) &
|
||||
!$OMP SHARED (n_act_orb, list_act, Ne,occ, eff_2_e_from_3_e_bb)
|
||||
!$OMP DO SCHEDULE (static)
|
||||
do hh1 = 1, n_act_orb !! beta
|
||||
h1 = list_act(hh1)
|
||||
do hh2 = hh1+1, n_act_orb !! beta
|
||||
h2 = list_act(hh2)
|
||||
do pp1 = 1, n_act_orb !! beta
|
||||
p1 = list_act(pp1)
|
||||
do pp2 = pp1+1, n_act_orb !! beta
|
||||
p2 = list_act(pp2)
|
||||
call give_contrib_for_bbbb(h1,h2,p1,p2,occ,Ne,contrib)
|
||||
eff_2_e_from_3_e_bb(p2,p1,h2,h1) = contrib
|
||||
enddo
|
||||
enddo
|
||||
enddo
|
||||
enddo
|
||||
!$OMP END DO
|
||||
!$OMP END PARALLEL
|
||||
|
||||
END_PROVIDER
|
||||
|
||||
subroutine give_contrib_for_bbbb(h1,h2,p1,p2,occ,Ne,contrib)
|
||||
implicit none
|
||||
BEGIN_DOC
|
||||
! gives the contribution for a double excitation (h1,p1)_beta (h2,p2)_beta
|
||||
!
|
||||
! on top of a determinant whose occupied orbitals is in (occ, Ne)
|
||||
END_DOC
|
||||
integer, intent(in) :: h1,h2,p1,p2,occ(N_int*bit_kind_size,2),Ne(2)
|
||||
double precision, intent(out) :: contrib
|
||||
integer :: mm,m
|
||||
double precision :: direct_int, exchange_int
|
||||
!! h1,p1 == beta
|
||||
!! h2,p2 == beta
|
||||
contrib = 0.d0
|
||||
do mm = 1, Ne(2) !! beta ==> pure parallele spin contribution
|
||||
m = occ(mm,1)
|
||||
contrib += three_e_double_parrallel_spin_prov(m,p2,h2,p1,h1)
|
||||
enddo
|
||||
|
||||
do mm = 1, Ne(1) !! alpha
|
||||
m = occ(mm,1)
|
||||
direct_int = three_e_5_idx_direct_bi_ort(mm,p2,h2,p1,h1)
|
||||
! exchange between (h1,p1) and (h2,p2)
|
||||
exchange_int = three_e_5_idx_exch12_bi_ort(mm,p2,h2,p1,h1)
|
||||
contrib += direct_int - exchange_int
|
||||
enddo
|
||||
end
|
||||
|
||||
|
||||
subroutine double_htilde_mu_mat_fock_bi_ortho_no_3e(Nint, key_j, key_i, htot)
|
||||
|
||||
BEGIN_DOC
|
||||
! <key_j | H_tilde | key_i> for double excitation ONLY FOR ONE- AND TWO-BODY TERMS
|
||||
!!
|
||||
!! WARNING !!
|
||||
!
|
||||
! Non hermitian !!
|
||||
END_DOC
|
||||
|
||||
use bitmasks
|
||||
|
||||
implicit none
|
||||
integer, intent(in) :: Nint
|
||||
integer(bit_kind), intent(in) :: key_j(Nint,2), key_i(Nint,2)
|
||||
double precision, intent(out) :: htot
|
||||
double precision :: hmono, htwoe
|
||||
integer :: occ(Nint*bit_kind_size,2)
|
||||
integer :: Ne(2), i, j, ii, jj, ispin, jspin, k, kk
|
||||
integer :: degree,exc(0:2,2,2)
|
||||
integer :: h1, p1, h2, p2, s1, s2
|
||||
double precision :: get_mo_two_e_integral_tc_int,phase
|
||||
|
||||
|
||||
call get_excitation_degree(key_i, key_j, degree, Nint)
|
||||
|
||||
hmono = 0.d0
|
||||
htwoe = 0.d0
|
||||
htot = 0.d0
|
||||
|
||||
if(degree.ne.2)then
|
||||
return
|
||||
endif
|
||||
integer :: degree_i,degree_j
|
||||
call get_excitation_degree(ref_bitmask,key_i,degree_i,N_int)
|
||||
call get_excitation_degree(ref_bitmask,key_j,degree_j,N_int)
|
||||
call get_double_excitation(key_i, key_j, exc, phase, Nint)
|
||||
call decode_exc(exc, 2, h1, p1, h2, p2, s1, s2)
|
||||
|
||||
if(s1.ne.s2)then
|
||||
! opposite spin two-body
|
||||
htwoe = mo_bi_ortho_tc_two_e(p2,p1,h2,h1)
|
||||
else
|
||||
! same spin two-body
|
||||
! direct terms
|
||||
htwoe = mo_bi_ortho_tc_two_e(p2,p1,h2,h1)
|
||||
! exchange terms
|
||||
htwoe -= mo_bi_ortho_tc_two_e(p1,p2,h2,h1)
|
||||
endif
|
||||
htwoe *= phase
|
||||
htot = htwoe
|
||||
|
||||
end
|
||||
|
572
src/tc_bi_ortho/slater_tc_opt_single.irp.f
Normal file
572
src/tc_bi_ortho/slater_tc_opt_single.irp.f
Normal file
|
@ -0,0 +1,572 @@
|
|||
|
||||
|
||||
subroutine single_htilde_mu_mat_fock_bi_ortho (Nint, key_j, key_i, hmono, htwoe, hthree, htot)
|
||||
BEGIN_DOC
|
||||
! <key_j | H_tilde | key_i> for single excitation ONLY FOR ONE- AND TWO-BODY TERMS
|
||||
!!
|
||||
!! WARNING !!
|
||||
!
|
||||
! Non hermitian !!
|
||||
END_DOC
|
||||
|
||||
use bitmasks
|
||||
|
||||
implicit none
|
||||
integer, intent(in) :: Nint
|
||||
integer(bit_kind), intent(in) :: key_j(Nint,2), key_i(Nint,2)
|
||||
double precision, intent(out) :: hmono, htwoe, hthree, htot
|
||||
integer :: occ(Nint*bit_kind_size,2)
|
||||
integer :: Ne(2), i, j, ii, jj, ispin, jspin, k, kk
|
||||
integer :: degree,exc(0:2,2,2)
|
||||
integer :: h1, p1, h2, p2, s1, s2
|
||||
double precision :: get_mo_two_e_integral_tc_int, phase
|
||||
double precision :: direct_int, exchange_int_12, exchange_int_23, exchange_int_13
|
||||
integer :: other_spin(2)
|
||||
integer(bit_kind) :: key_j_core(Nint,2), key_i_core(Nint,2)
|
||||
|
||||
other_spin(1) = 2
|
||||
other_spin(2) = 1
|
||||
|
||||
hmono = 0.d0
|
||||
htwoe = 0.d0
|
||||
hthree = 0.d0
|
||||
htot = 0.d0
|
||||
call get_excitation_degree(key_i, key_j, degree, Nint)
|
||||
if(degree.ne.1)then
|
||||
return
|
||||
endif
|
||||
call bitstring_to_list_ab(key_i, occ, Ne, Nint)
|
||||
|
||||
call get_single_excitation(key_i, key_j, exc, phase, Nint)
|
||||
call decode_exc(exc,1,h1,p1,h2,p2,s1,s2)
|
||||
call get_single_excitation_from_fock_tc(key_i,key_j,h1,p1,s1,phase,hmono,htwoe,hthree,htot)
|
||||
end
|
||||
|
||||
|
||||
subroutine get_single_excitation_from_fock_tc(key_i,key_j,h,p,spin,phase,hmono,htwoe,hthree,htot)
|
||||
use bitmasks
|
||||
implicit none
|
||||
integer,intent(in) :: h,p,spin
|
||||
double precision, intent(in) :: phase
|
||||
integer(bit_kind), intent(in) :: key_i(N_int,2), key_j(N_int,2)
|
||||
double precision, intent(out) :: hmono,htwoe,hthree,htot
|
||||
integer(bit_kind) :: differences(N_int,2)
|
||||
integer(bit_kind) :: hole(N_int,2)
|
||||
integer(bit_kind) :: partcl(N_int,2)
|
||||
integer :: occ_hole(N_int*bit_kind_size,2)
|
||||
integer :: occ_partcl(N_int*bit_kind_size,2)
|
||||
integer :: n_occ_ab_hole(2),n_occ_ab_partcl(2)
|
||||
integer :: i0,i
|
||||
double precision :: buffer_c(mo_num),buffer_x(mo_num)
|
||||
do i=1, mo_num
|
||||
buffer_c(i) = tc_2e_3idx_coulomb_integrals(i,p,h)
|
||||
buffer_x(i) = tc_2e_3idx_exchange_integrals(i,p,h)
|
||||
enddo
|
||||
do i = 1, N_int
|
||||
differences(i,1) = xor(key_i(i,1),ref_closed_shell_bitmask(i,1))
|
||||
differences(i,2) = xor(key_i(i,2),ref_closed_shell_bitmask(i,2))
|
||||
hole(i,1) = iand(differences(i,1),ref_closed_shell_bitmask(i,1))
|
||||
hole(i,2) = iand(differences(i,2),ref_closed_shell_bitmask(i,2))
|
||||
partcl(i,1) = iand(differences(i,1),key_i(i,1))
|
||||
partcl(i,2) = iand(differences(i,2),key_i(i,2))
|
||||
enddo
|
||||
call bitstring_to_list_ab(hole, occ_hole, n_occ_ab_hole, N_int)
|
||||
call bitstring_to_list_ab(partcl, occ_partcl, n_occ_ab_partcl, N_int)
|
||||
hmono = mo_bi_ortho_tc_one_e(p,h)
|
||||
htwoe = fock_op_2_e_tc_closed_shell(p,h)
|
||||
! holes :: direct terms
|
||||
do i0 = 1, n_occ_ab_hole(1)
|
||||
i = occ_hole(i0,1)
|
||||
htwoe -= buffer_c(i)
|
||||
enddo
|
||||
do i0 = 1, n_occ_ab_hole(2)
|
||||
i = occ_hole(i0,2)
|
||||
htwoe -= buffer_c(i)
|
||||
enddo
|
||||
|
||||
! holes :: exchange terms
|
||||
do i0 = 1, n_occ_ab_hole(spin)
|
||||
i = occ_hole(i0,spin)
|
||||
htwoe += buffer_x(i)
|
||||
enddo
|
||||
|
||||
! particles :: direct terms
|
||||
do i0 = 1, n_occ_ab_partcl(1)
|
||||
i = occ_partcl(i0,1)
|
||||
htwoe += buffer_c(i)
|
||||
enddo
|
||||
do i0 = 1, n_occ_ab_partcl(2)
|
||||
i = occ_partcl(i0,2)
|
||||
htwoe += buffer_c(i)
|
||||
enddo
|
||||
|
||||
! particles :: exchange terms
|
||||
do i0 = 1, n_occ_ab_partcl(spin)
|
||||
i = occ_partcl(i0,spin)
|
||||
htwoe -= buffer_x(i)
|
||||
enddo
|
||||
hthree = 0.d0
|
||||
if (three_body_h_tc)then
|
||||
call three_comp_fock_elem(key_i,h,p,spin,hthree)
|
||||
endif
|
||||
|
||||
|
||||
htwoe = htwoe * phase
|
||||
hmono = hmono * phase
|
||||
hthree = hthree * phase
|
||||
htot = htwoe + hmono + hthree
|
||||
|
||||
end
|
||||
|
||||
subroutine three_comp_fock_elem(key_i,h_fock,p_fock,ispin_fock,hthree)
|
||||
implicit none
|
||||
integer,intent(in) :: h_fock,p_fock,ispin_fock
|
||||
integer(bit_kind), intent(in) :: key_i(N_int,2)
|
||||
double precision, intent(out) :: hthree
|
||||
integer :: nexc(2),i,ispin,na,nb
|
||||
integer(bit_kind) :: hole(N_int,2)
|
||||
integer(bit_kind) :: particle(N_int,2)
|
||||
integer :: occ_hole(N_int*bit_kind_size,2)
|
||||
integer :: occ_particle(N_int*bit_kind_size,2)
|
||||
integer :: n_occ_ab_hole(2),n_occ_ab_particle(2)
|
||||
integer(bit_kind) :: det_tmp(N_int,2)
|
||||
|
||||
|
||||
nexc(1) = 0
|
||||
nexc(2) = 0
|
||||
!! Get all the holes and particles of key_i with respect to the ROHF determinant
|
||||
do i=1,N_int
|
||||
hole(i,1) = xor(key_i(i,1),ref_bitmask(i,1))
|
||||
hole(i,2) = xor(key_i(i,2),ref_bitmask(i,2))
|
||||
particle(i,1) = iand(hole(i,1),key_i(i,1))
|
||||
particle(i,2) = iand(hole(i,2),key_i(i,2))
|
||||
hole(i,1) = iand(hole(i,1),ref_bitmask(i,1))
|
||||
hole(i,2) = iand(hole(i,2),ref_bitmask(i,2))
|
||||
nexc(1) = nexc(1) + popcnt(hole(i,1))
|
||||
nexc(2) = nexc(2) + popcnt(hole(i,2))
|
||||
enddo
|
||||
integer :: tmp(2)
|
||||
!DIR$ FORCEINLINE
|
||||
call bitstring_to_list_ab(particle, occ_particle, tmp, N_int)
|
||||
ASSERT (tmp(1) == nexc(1)) ! Number of particles alpha
|
||||
ASSERT (tmp(2) == nexc(2)) ! Number of particle beta
|
||||
!DIR$ FORCEINLINE
|
||||
call bitstring_to_list_ab(hole, occ_hole, tmp, N_int)
|
||||
ASSERT (tmp(1) == nexc(1)) ! Number of holes alpha
|
||||
ASSERT (tmp(2) == nexc(2)) ! Number of holes beta
|
||||
|
||||
!! Initialize the matrix element with the reference ROHF Slater determinant Fock element
|
||||
if(ispin_fock==1)then
|
||||
hthree = fock_a_tot_3e_bi_orth(p_fock,h_fock)
|
||||
else
|
||||
hthree = fock_b_tot_3e_bi_orth(p_fock,h_fock)
|
||||
endif
|
||||
det_tmp = ref_bitmask
|
||||
do ispin=1,2
|
||||
na = elec_num_tab(ispin)
|
||||
nb = elec_num_tab(iand(ispin,1)+1)
|
||||
do i=1,nexc(ispin)
|
||||
!DIR$ FORCEINLINE
|
||||
call fock_ac_tc_operator( occ_particle(i,ispin), ispin, det_tmp, h_fock,p_fock, ispin_fock, hthree, N_int,na,nb)
|
||||
!DIR$ FORCEINLINE
|
||||
call fock_a_tc_operator ( occ_hole (i,ispin), ispin, det_tmp, h_fock,p_fock, ispin_fock, hthree, N_int,na,nb)
|
||||
enddo
|
||||
enddo
|
||||
end
|
||||
|
||||
subroutine fock_ac_tc_operator(iorb,ispin,key, h_fock,p_fock, ispin_fock,hthree,Nint,na,nb)
|
||||
use bitmasks
|
||||
implicit none
|
||||
BEGIN_DOC
|
||||
! Routine that computes the contribution to the three-electron part of the Fock operator
|
||||
!
|
||||
! a^dagger_{p_fock} a_{h_fock} of spin ispin_fock
|
||||
!
|
||||
! on top of a determinant 'key' on which you ADD an electron of spin ispin in orbital iorb
|
||||
!
|
||||
! in output, the determinant key is changed by the ADDITION of that electron
|
||||
!
|
||||
! the output hthree is INCREMENTED
|
||||
END_DOC
|
||||
integer, intent(in) :: iorb, ispin, Nint, h_fock,p_fock, ispin_fock
|
||||
integer, intent(inout) :: na, nb
|
||||
integer(bit_kind), intent(inout) :: key(Nint,2)
|
||||
double precision, intent(inout) :: hthree
|
||||
|
||||
integer :: occ(Nint*bit_kind_size,2)
|
||||
integer :: other_spin
|
||||
integer :: k,l,i,jj,j
|
||||
double precision :: direct_int, exchange_int
|
||||
|
||||
|
||||
if (iorb < 1) then
|
||||
print *, irp_here, ': iorb < 1'
|
||||
print *, iorb, mo_num
|
||||
stop -1
|
||||
endif
|
||||
if (iorb > mo_num) then
|
||||
print *, irp_here, ': iorb > mo_num'
|
||||
print *, iorb, mo_num
|
||||
stop -1
|
||||
endif
|
||||
|
||||
ASSERT (ispin > 0)
|
||||
ASSERT (ispin < 3)
|
||||
ASSERT (Nint > 0)
|
||||
|
||||
integer :: tmp(2)
|
||||
!DIR$ FORCEINLINE
|
||||
call bitstring_to_list_ab(key, occ, tmp, Nint)
|
||||
ASSERT (tmp(1) == elec_alpha_num)
|
||||
ASSERT (tmp(2) == elec_beta_num)
|
||||
|
||||
k = shiftr(iorb-1,bit_kind_shift)+1
|
||||
ASSERT (k >0)
|
||||
l = iorb - shiftl(k-1,bit_kind_shift)-1
|
||||
ASSERT (l >= 0)
|
||||
key(k,ispin) = ibset(key(k,ispin),l)
|
||||
other_spin = iand(ispin,1)+1
|
||||
|
||||
|
||||
!! spin of other electrons == ispin
|
||||
if(ispin == ispin_fock)then
|
||||
!! in what follows :: jj == other electrons in the determinant
|
||||
!! :: iorb == electron that has been added of spin ispin
|
||||
!! :: p_fock, h_fock == hole particle of spin ispin_fock
|
||||
!! jj = ispin = ispin_fock >> pure parallel spin
|
||||
do j = 1, na
|
||||
jj = occ(j,ispin)
|
||||
hthree += three_e_single_parrallel_spin_prov(jj,iorb,p_fock,h_fock)
|
||||
enddo
|
||||
!! spin of jj == other spin than ispin AND ispin_fock
|
||||
!! exchange between the iorb and (h_fock, p_fock)
|
||||
do j = 1, nb
|
||||
jj = occ(j,other_spin)
|
||||
direct_int = three_e_4_idx_direct_bi_ort(jj,iorb,p_fock,h_fock) ! USES 4-IDX TENSOR
|
||||
exchange_int = three_e_4_idx_exch12_bi_ort(jj,iorb,p_fock,h_fock) ! USES 4-IDX TENSOR
|
||||
hthree += direct_int - exchange_int
|
||||
enddo
|
||||
else !! ispin NE to ispin_fock
|
||||
!! jj = ispin BUT NON EQUAL TO ispin_fock
|
||||
!! exchange between the jj and iorb
|
||||
do j = 1, na
|
||||
jj = occ(j,ispin)
|
||||
direct_int = three_e_4_idx_direct_bi_ort(jj,iorb,p_fock,h_fock) ! USES 4-IDX TENSOR
|
||||
exchange_int = three_e_4_idx_exch23_bi_ort(jj,iorb,p_fock,h_fock) ! USES 4-IDX TENSOR
|
||||
hthree += direct_int - exchange_int
|
||||
enddo
|
||||
!! jj = other_spin than ispin BUT jj == ispin_fock
|
||||
!! exchange between jj and (h_fock,p_fock)
|
||||
do j = 1, nb
|
||||
jj = occ(j,other_spin)
|
||||
direct_int = three_e_4_idx_direct_bi_ort(jj,iorb,p_fock,h_fock) ! USES 4-IDX TENSOR
|
||||
exchange_int = three_e_4_idx_exch13_bi_ort(jj,iorb,p_fock,h_fock) ! USES 4-IDX TENSOR
|
||||
hthree += direct_int - exchange_int
|
||||
enddo
|
||||
endif
|
||||
|
||||
na = na+1
|
||||
end
|
||||
|
||||
subroutine fock_a_tc_operator(iorb,ispin,key, h_fock,p_fock, ispin_fock,hthree,Nint,na,nb)
|
||||
use bitmasks
|
||||
implicit none
|
||||
BEGIN_DOC
|
||||
! Routine that computes the contribution to the three-electron part of the Fock operator
|
||||
!
|
||||
! a^dagger_{p_fock} a_{h_fock} of spin ispin_fock
|
||||
!
|
||||
! on top of a determinant 'key' on which you REMOVE an electron of spin ispin in orbital iorb
|
||||
!
|
||||
! in output, the determinant key is changed by the REMOVAL of that electron
|
||||
!
|
||||
! the output hthree is INCREMENTED
|
||||
END_DOC
|
||||
integer, intent(in) :: iorb, ispin, Nint, h_fock,p_fock, ispin_fock
|
||||
integer, intent(inout) :: na, nb
|
||||
integer(bit_kind), intent(inout) :: key(Nint,2)
|
||||
double precision, intent(inout) :: hthree
|
||||
|
||||
double precision :: direct_int, exchange_int
|
||||
integer :: occ(Nint*bit_kind_size,2)
|
||||
integer :: other_spin
|
||||
integer :: k,l,i,jj,mm,j,m
|
||||
integer :: tmp(2)
|
||||
|
||||
ASSERT (iorb > 0)
|
||||
ASSERT (ispin > 0)
|
||||
ASSERT (ispin < 3)
|
||||
ASSERT (Nint > 0)
|
||||
|
||||
k = shiftr(iorb-1,bit_kind_shift)+1
|
||||
ASSERT (k>0)
|
||||
l = iorb - shiftl(k-1,bit_kind_shift)-1
|
||||
key(k,ispin) = ibclr(key(k,ispin),l)
|
||||
other_spin = iand(ispin,1)+1
|
||||
|
||||
!DIR$ FORCEINLINE
|
||||
call bitstring_to_list_ab(key, occ, tmp, Nint)
|
||||
na = na-1
|
||||
!! spin of other electrons == ispin
|
||||
if(ispin == ispin_fock)then
|
||||
!! in what follows :: jj == other electrons in the determinant
|
||||
!! :: iorb == electron that has been added of spin ispin
|
||||
!! :: p_fock, h_fock == hole particle of spin ispin_fock
|
||||
!! jj = ispin = ispin_fock >> pure parallel spin
|
||||
do j = 1, na
|
||||
jj = occ(j,ispin)
|
||||
hthree -= three_e_single_parrallel_spin_prov(jj,iorb,p_fock,h_fock)
|
||||
enddo
|
||||
!! spin of jj == other spin than ispin AND ispin_fock
|
||||
!! exchange between the iorb and (h_fock, p_fock)
|
||||
do j = 1, nb
|
||||
jj = occ(j,other_spin)
|
||||
direct_int = three_e_4_idx_direct_bi_ort(jj,iorb,p_fock,h_fock) ! USES 4-IDX TENSOR
|
||||
exchange_int = three_e_4_idx_exch12_bi_ort(jj,iorb,p_fock,h_fock) ! USES 4-IDX TENSOR
|
||||
hthree -= direct_int - exchange_int
|
||||
enddo
|
||||
else !! ispin NE to ispin_fock
|
||||
!! jj = ispin BUT NON EQUAL TO ispin_fock
|
||||
!! exchange between the jj and iorb
|
||||
do j = 1, na
|
||||
jj = occ(j,ispin)
|
||||
direct_int = three_e_4_idx_direct_bi_ort(jj,iorb,p_fock,h_fock) ! USES 4-IDX TENSOR
|
||||
exchange_int = three_e_4_idx_exch23_bi_ort(jj,iorb,p_fock,h_fock) ! USES 4-IDX TENSOR
|
||||
hthree -= direct_int - exchange_int
|
||||
enddo
|
||||
!! jj = other_spin than ispin BUT jj == ispin_fock
|
||||
!! exchange between jj and (h_fock,p_fock)
|
||||
do j = 1, nb
|
||||
jj = occ(j,other_spin)
|
||||
direct_int = three_e_4_idx_direct_bi_ort(jj,iorb,p_fock,h_fock) ! USES 4-IDX TENSOR
|
||||
exchange_int = three_e_4_idx_exch13_bi_ort(jj,iorb,p_fock,h_fock) ! USES 4-IDX TENSOR
|
||||
hthree -= direct_int - exchange_int
|
||||
enddo
|
||||
endif
|
||||
|
||||
end
|
||||
|
||||
|
||||
BEGIN_PROVIDER [double precision, fock_op_2_e_tc_closed_shell, (mo_num, mo_num) ]
|
||||
implicit none
|
||||
BEGIN_DOC
|
||||
! Closed-shell part of the Fock operator for the TC operator
|
||||
END_DOC
|
||||
integer :: h0,p0,h,p,k0,k,i
|
||||
integer :: n_occ_ab(2)
|
||||
integer :: occ(N_int*bit_kind_size,2)
|
||||
integer :: n_occ_ab_virt(2)
|
||||
integer :: occ_virt(N_int*bit_kind_size,2)
|
||||
integer(bit_kind) :: key_test(N_int)
|
||||
integer(bit_kind) :: key_virt(N_int,2)
|
||||
double precision :: accu
|
||||
|
||||
fock_op_2_e_tc_closed_shell = -1000.d0
|
||||
call bitstring_to_list_ab(ref_closed_shell_bitmask, occ, n_occ_ab, N_int)
|
||||
do i = 1, N_int
|
||||
key_virt(i,1) = full_ijkl_bitmask(i)
|
||||
key_virt(i,2) = full_ijkl_bitmask(i)
|
||||
key_virt(i,1) = xor(key_virt(i,1),ref_closed_shell_bitmask(i,1))
|
||||
key_virt(i,2) = xor(key_virt(i,2),ref_closed_shell_bitmask(i,2))
|
||||
enddo
|
||||
call bitstring_to_list_ab(key_virt, occ_virt, n_occ_ab_virt, N_int)
|
||||
! docc ---> virt single excitations
|
||||
do h0 = 1, n_occ_ab(1)
|
||||
h=occ(h0,1)
|
||||
do p0 = 1, n_occ_ab_virt(1)
|
||||
p = occ_virt(p0,1)
|
||||
accu = 0.d0
|
||||
do k0 = 1, n_occ_ab(1)
|
||||
k = occ(k0,1)
|
||||
accu += 2.d0 * tc_2e_3idx_coulomb_integrals(k,p,h) - tc_2e_3idx_exchange_integrals(k,p,h)
|
||||
enddo
|
||||
fock_op_2_e_tc_closed_shell(p,h) = accu
|
||||
enddo
|
||||
enddo
|
||||
|
||||
do h0 = 1, n_occ_ab_virt(1)
|
||||
h = occ_virt(h0,1)
|
||||
do p0 = 1, n_occ_ab(1)
|
||||
p=occ(p0,1)
|
||||
accu = 0.d0
|
||||
do k0 = 1, n_occ_ab(1)
|
||||
k = occ(k0,1)
|
||||
accu += 2.d0 * tc_2e_3idx_coulomb_integrals(k,p,h) - tc_2e_3idx_exchange_integrals(k,p,h)
|
||||
enddo
|
||||
fock_op_2_e_tc_closed_shell(p,h) = accu
|
||||
enddo
|
||||
enddo
|
||||
|
||||
! virt ---> virt single excitations
|
||||
do h0 = 1, n_occ_ab_virt(1)
|
||||
h=occ_virt(h0,1)
|
||||
do p0 = 1, n_occ_ab_virt(1)
|
||||
p = occ_virt(p0,1)
|
||||
accu = 0.d0
|
||||
do k0 = 1, n_occ_ab(1)
|
||||
k = occ(k0,1)
|
||||
accu += 2.d0 * tc_2e_3idx_coulomb_integrals(k,p,h) - tc_2e_3idx_exchange_integrals(k,p,h)
|
||||
enddo
|
||||
fock_op_2_e_tc_closed_shell(p,h) = accu
|
||||
enddo
|
||||
enddo
|
||||
|
||||
do h0 = 1, n_occ_ab_virt(1)
|
||||
h = occ_virt(h0,1)
|
||||
do p0 = 1, n_occ_ab_virt(1)
|
||||
p=occ_virt(p0,1)
|
||||
accu = 0.d0
|
||||
do k0 = 1, n_occ_ab(1)
|
||||
k = occ(k0,1)
|
||||
accu += 2.d0 * tc_2e_3idx_coulomb_integrals(k,p,h) - tc_2e_3idx_exchange_integrals(k,p,h)
|
||||
enddo
|
||||
fock_op_2_e_tc_closed_shell(p,h) = accu
|
||||
enddo
|
||||
enddo
|
||||
|
||||
|
||||
! docc ---> docc single excitations
|
||||
do h0 = 1, n_occ_ab(1)
|
||||
h=occ(h0,1)
|
||||
do p0 = 1, n_occ_ab(1)
|
||||
p = occ(p0,1)
|
||||
accu = 0.d0
|
||||
do k0 = 1, n_occ_ab(1)
|
||||
k = occ(k0,1)
|
||||
accu += 2.d0 * tc_2e_3idx_coulomb_integrals(k,p,h) - tc_2e_3idx_exchange_integrals(k,p,h)
|
||||
enddo
|
||||
fock_op_2_e_tc_closed_shell(p,h) = accu
|
||||
enddo
|
||||
enddo
|
||||
|
||||
do h0 = 1, n_occ_ab(1)
|
||||
h = occ(h0,1)
|
||||
do p0 = 1, n_occ_ab(1)
|
||||
p=occ(p0,1)
|
||||
accu = 0.d0
|
||||
do k0 = 1, n_occ_ab(1)
|
||||
k = occ(k0,1)
|
||||
accu += 2.d0 * tc_2e_3idx_coulomb_integrals(k,p,h) - tc_2e_3idx_exchange_integrals(k,p,h)
|
||||
enddo
|
||||
fock_op_2_e_tc_closed_shell(p,h) = accu
|
||||
enddo
|
||||
enddo
|
||||
|
||||
! do i = 1, mo_num
|
||||
! write(*,'(100(F10.5,X))')fock_op_2_e_tc_closed_shell(:,i)
|
||||
! enddo
|
||||
|
||||
END_PROVIDER
|
||||
|
||||
|
||||
subroutine single_htilde_mu_mat_fock_bi_ortho_no_3e(Nint, key_j, key_i, htot)
|
||||
BEGIN_DOC
|
||||
! <key_j | H_tilde | key_i> for single excitation ONLY FOR ONE- AND TWO-BODY TERMS
|
||||
!!
|
||||
!! WARNING !!
|
||||
!
|
||||
! Non hermitian !!
|
||||
END_DOC
|
||||
|
||||
use bitmasks
|
||||
|
||||
implicit none
|
||||
integer, intent(in) :: Nint
|
||||
integer(bit_kind), intent(in) :: key_j(Nint,2), key_i(Nint,2)
|
||||
double precision, intent(out) :: htot
|
||||
double precision :: hmono, htwoe
|
||||
integer :: occ(Nint*bit_kind_size,2)
|
||||
integer :: Ne(2), i, j, ii, jj, ispin, jspin, k, kk
|
||||
integer :: degree,exc(0:2,2,2)
|
||||
integer :: h1, p1, h2, p2, s1, s2
|
||||
double precision :: get_mo_two_e_integral_tc_int, phase
|
||||
double precision :: direct_int, exchange_int_12, exchange_int_23, exchange_int_13
|
||||
integer :: other_spin(2)
|
||||
integer(bit_kind) :: key_j_core(Nint,2), key_i_core(Nint,2)
|
||||
|
||||
other_spin(1) = 2
|
||||
other_spin(2) = 1
|
||||
|
||||
hmono = 0.d0
|
||||
htwoe = 0.d0
|
||||
htot = 0.d0
|
||||
call get_excitation_degree(key_i, key_j, degree, Nint)
|
||||
if(degree.ne.1)then
|
||||
return
|
||||
endif
|
||||
call bitstring_to_list_ab(key_i, occ, Ne, Nint)
|
||||
|
||||
call get_single_excitation(key_i, key_j, exc, phase, Nint)
|
||||
call decode_exc(exc,1,h1,p1,h2,p2,s1,s2)
|
||||
call get_single_excitation_from_fock_tc_no_3e(key_i,key_j,h1,p1,s1,phase,hmono,htwoe,htot)
|
||||
end
|
||||
|
||||
|
||||
subroutine get_single_excitation_from_fock_tc_no_3e(key_i,key_j,h,p,spin,phase,hmono,htwoe,htot)
|
||||
use bitmasks
|
||||
implicit none
|
||||
integer,intent(in) :: h,p,spin
|
||||
double precision, intent(in) :: phase
|
||||
integer(bit_kind), intent(in) :: key_i(N_int,2), key_j(N_int,2)
|
||||
double precision, intent(out) :: hmono,htwoe,htot
|
||||
integer(bit_kind) :: differences(N_int,2)
|
||||
integer(bit_kind) :: hole(N_int,2)
|
||||
integer(bit_kind) :: partcl(N_int,2)
|
||||
integer :: occ_hole(N_int*bit_kind_size,2)
|
||||
integer :: occ_partcl(N_int*bit_kind_size,2)
|
||||
integer :: n_occ_ab_hole(2),n_occ_ab_partcl(2)
|
||||
integer :: i0,i
|
||||
double precision :: buffer_c(mo_num),buffer_x(mo_num)
|
||||
do i=1, mo_num
|
||||
buffer_c(i) = tc_2e_3idx_coulomb_integrals(i,p,h)
|
||||
buffer_x(i) = tc_2e_3idx_exchange_integrals(i,p,h)
|
||||
enddo
|
||||
do i = 1, N_int
|
||||
differences(i,1) = xor(key_i(i,1),ref_closed_shell_bitmask(i,1))
|
||||
differences(i,2) = xor(key_i(i,2),ref_closed_shell_bitmask(i,2))
|
||||
hole(i,1) = iand(differences(i,1),ref_closed_shell_bitmask(i,1))
|
||||
hole(i,2) = iand(differences(i,2),ref_closed_shell_bitmask(i,2))
|
||||
partcl(i,1) = iand(differences(i,1),key_i(i,1))
|
||||
partcl(i,2) = iand(differences(i,2),key_i(i,2))
|
||||
enddo
|
||||
call bitstring_to_list_ab(hole, occ_hole, n_occ_ab_hole, N_int)
|
||||
call bitstring_to_list_ab(partcl, occ_partcl, n_occ_ab_partcl, N_int)
|
||||
hmono = mo_bi_ortho_tc_one_e(p,h)
|
||||
htwoe = fock_op_2_e_tc_closed_shell(p,h)
|
||||
! holes :: direct terms
|
||||
do i0 = 1, n_occ_ab_hole(1)
|
||||
i = occ_hole(i0,1)
|
||||
htwoe -= buffer_c(i)
|
||||
enddo
|
||||
do i0 = 1, n_occ_ab_hole(2)
|
||||
i = occ_hole(i0,2)
|
||||
htwoe -= buffer_c(i)
|
||||
enddo
|
||||
|
||||
! holes :: exchange terms
|
||||
do i0 = 1, n_occ_ab_hole(spin)
|
||||
i = occ_hole(i0,spin)
|
||||
htwoe += buffer_x(i)
|
||||
enddo
|
||||
|
||||
! particles :: direct terms
|
||||
do i0 = 1, n_occ_ab_partcl(1)
|
||||
i = occ_partcl(i0,1)
|
||||
htwoe += buffer_c(i)
|
||||
enddo
|
||||
do i0 = 1, n_occ_ab_partcl(2)
|
||||
i = occ_partcl(i0,2)
|
||||
htwoe += buffer_c(i)
|
||||
enddo
|
||||
|
||||
! particles :: exchange terms
|
||||
do i0 = 1, n_occ_ab_partcl(spin)
|
||||
i = occ_partcl(i0,spin)
|
||||
htwoe -= buffer_x(i)
|
||||
enddo
|
||||
htwoe = htwoe * phase
|
||||
hmono = hmono * phase
|
||||
htot = htwoe + hmono
|
||||
|
||||
end
|
||||
|
140
src/tc_bi_ortho/symmetrized_3_e_int_prov.irp.f
Normal file
140
src/tc_bi_ortho/symmetrized_3_e_int_prov.irp.f
Normal file
|
@ -0,0 +1,140 @@
|
|||
|
||||
BEGIN_PROVIDER [ double precision, three_e_diag_parrallel_spin_prov, (mo_num, mo_num, mo_num)]
|
||||
|
||||
BEGIN_DOC
|
||||
!
|
||||
! matrix element of the -L three-body operator ON A BI ORTHONORMAL BASIS
|
||||
!
|
||||
! three_e_diag_parrallel_spin_prov(m,j,i) = All combinations of the form <mji|-L|mji> for same spin matrix elements
|
||||
!
|
||||
! notice the -1 sign: in this way three_e_diag_parrallel_spin_prov can be directly used to compute Slater rules with a + sign
|
||||
!
|
||||
END_DOC
|
||||
|
||||
implicit none
|
||||
integer :: i, j, m
|
||||
double precision :: integral, wall1, wall0, three_e_diag_parrallel_spin
|
||||
|
||||
three_e_diag_parrallel_spin_prov = 0.d0
|
||||
print *, ' Providing the three_e_diag_parrallel_spin_prov ...'
|
||||
|
||||
integral = three_e_diag_parrallel_spin(1,1,1) ! to provide all stuffs
|
||||
call wall_time(wall0)
|
||||
!$OMP PARALLEL &
|
||||
!$OMP DEFAULT (NONE) &
|
||||
!$OMP PRIVATE (i,j,m,integral) &
|
||||
!$OMP SHARED (mo_num,three_e_diag_parrallel_spin_prov)
|
||||
!$OMP DO SCHEDULE (dynamic)
|
||||
do i = 1, mo_num
|
||||
do j = 1, mo_num
|
||||
do m = j, mo_num
|
||||
three_e_diag_parrallel_spin_prov(m,j,i) = three_e_diag_parrallel_spin(m,j,i)
|
||||
enddo
|
||||
enddo
|
||||
enddo
|
||||
!$OMP END DO
|
||||
!$OMP END PARALLEL
|
||||
|
||||
do i = 1, mo_num
|
||||
do j = 1, mo_num
|
||||
do m = 1, j
|
||||
three_e_diag_parrallel_spin_prov(m,j,i) = three_e_diag_parrallel_spin_prov(j,m,i)
|
||||
enddo
|
||||
enddo
|
||||
enddo
|
||||
|
||||
call wall_time(wall1)
|
||||
print *, ' wall time for three_e_diag_parrallel_spin_prov', wall1 - wall0
|
||||
|
||||
END_PROVIDER
|
||||
|
||||
BEGIN_PROVIDER [ double precision, three_e_single_parrallel_spin_prov, (mo_num, mo_num, mo_num, mo_num)]
|
||||
|
||||
BEGIN_DOC
|
||||
!
|
||||
! matrix element of the -L three-body operator FOR THE DIRECT TERMS OF SINGLE EXCITATIONS AND BI ORTHO MOs
|
||||
!
|
||||
! three_e_single_parrallel_spin_prov(m,j,k,i) = All combination of <mjk|-L|mji> for same spin matrix elements
|
||||
!
|
||||
! notice the -1 sign: in this way three_e_3_idx_direct_bi_ort can be directly used to compute Slater rules with a + sign
|
||||
!
|
||||
END_DOC
|
||||
|
||||
implicit none
|
||||
integer :: i, j, k, m
|
||||
double precision :: integral, wall1, wall0, three_e_single_parrallel_spin
|
||||
|
||||
three_e_single_parrallel_spin_prov = 0.d0
|
||||
print *, ' Providing the three_e_single_parrallel_spin_prov ...'
|
||||
|
||||
integral = three_e_single_parrallel_spin(1,1,1,1)
|
||||
call wall_time(wall0)
|
||||
!$OMP PARALLEL &
|
||||
!$OMP DEFAULT (NONE) &
|
||||
!$OMP PRIVATE (i,j,k,m,integral) &
|
||||
!$OMP SHARED (mo_num,three_e_single_parrallel_spin_prov)
|
||||
!$OMP DO SCHEDULE (dynamic)
|
||||
do i = 1, mo_num
|
||||
do k = 1, mo_num
|
||||
do j = 1, mo_num
|
||||
do m = 1, mo_num
|
||||
three_e_single_parrallel_spin_prov(m,j,k,i) = three_e_single_parrallel_spin(m,j,k,i)
|
||||
enddo
|
||||
enddo
|
||||
enddo
|
||||
enddo
|
||||
!$OMP END DO
|
||||
!$OMP END PARALLEL
|
||||
|
||||
call wall_time(wall1)
|
||||
print *, ' wall time for three_e_single_parrallel_spin_prov', wall1 - wall0
|
||||
|
||||
END_PROVIDER
|
||||
|
||||
|
||||
! ---
|
||||
|
||||
BEGIN_PROVIDER [ double precision, three_e_double_parrallel_spin_prov, (mo_num, mo_num, mo_num, mo_num, mo_num)]
|
||||
|
||||
BEGIN_DOC
|
||||
!
|
||||
! matrix element of the -L three-body operator FOR THE DIRECT TERMS OF DOUBLE EXCITATIONS AND BI ORTHO MOs
|
||||
!
|
||||
! three_e_double_parrallel_spin_prov(m,l,j,k,i) = <mlk|-L|mji> ::: notice that i is the RIGHT MO and k is the LEFT MO
|
||||
!
|
||||
! notice the -1 sign: in this way three_e_3_idx_direct_bi_ort can be directly used to compute Slater rules with a + sign
|
||||
END_DOC
|
||||
|
||||
implicit none
|
||||
integer :: i, j, k, m, l
|
||||
double precision :: integral, wall1, wall0, three_e_double_parrallel_spin
|
||||
|
||||
three_e_double_parrallel_spin_prov = 0.d0
|
||||
print *, ' Providing the three_e_double_parrallel_spin_prov ...'
|
||||
call wall_time(wall0)
|
||||
|
||||
integral = three_e_double_parrallel_spin(1,1,1,1,1)
|
||||
!$OMP PARALLEL &
|
||||
!$OMP DEFAULT (NONE) &
|
||||
!$OMP PRIVATE (i,j,k,m,l,integral) &
|
||||
!$OMP SHARED (mo_num,three_e_double_parrallel_spin_prov)
|
||||
!$OMP DO SCHEDULE (dynamic)
|
||||
do i = 1, mo_num
|
||||
do k = 1, mo_num
|
||||
do j = 1, mo_num
|
||||
do l = 1, mo_num
|
||||
do m = 1, mo_num
|
||||
three_e_double_parrallel_spin_prov(m,l,j,k,i) = three_e_double_parrallel_spin(m,l,j,k,i)
|
||||
enddo
|
||||
enddo
|
||||
enddo
|
||||
enddo
|
||||
enddo
|
||||
!$OMP END DO
|
||||
!$OMP END PARALLEL
|
||||
|
||||
call wall_time(wall1)
|
||||
print *, ' wall time for three_e_double_parrallel_spin_prov', wall1 - wall0
|
||||
|
||||
END_PROVIDER
|
||||
|
70
src/tc_bi_ortho/tc_som.irp.f
Normal file
70
src/tc_bi_ortho/tc_som.irp.f
Normal file
|
@ -0,0 +1,70 @@
|
|||
! ---
|
||||
|
||||
program tc_som
|
||||
|
||||
BEGIN_DOC
|
||||
! TODO : Put the documentation of the program here
|
||||
END_DOC
|
||||
|
||||
implicit none
|
||||
|
||||
print *, ' starting ...'
|
||||
print *, ' do not forget to do tc-scf first'
|
||||
|
||||
my_grid_becke = .True.
|
||||
my_n_pt_r_grid = 30
|
||||
my_n_pt_a_grid = 50
|
||||
! my_n_pt_r_grid = 10 ! small grid for quick debug
|
||||
! my_n_pt_a_grid = 26 ! small grid for quick debug
|
||||
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
|
||||
|
||||
call main()
|
||||
|
||||
end
|
||||
|
||||
! ---
|
||||
|
||||
subroutine main()
|
||||
|
||||
implicit none
|
||||
integer :: i, i_HF, degree
|
||||
double precision :: hmono_1, htwoe_1, hthree_1, htot_1
|
||||
double precision :: hmono_2, htwoe_2, hthree_2, htot_2
|
||||
double precision :: U_SOM
|
||||
|
||||
PROVIDE N_int N_det
|
||||
|
||||
do i = 1, N_det
|
||||
call get_excitation_degree(HF_bitmask, psi_det(1,1,i), degree, N_int)
|
||||
if(degree == 0) then
|
||||
i_HF = i
|
||||
exit
|
||||
endif
|
||||
enddo
|
||||
print *, ' HF determinants:', i_HF
|
||||
print *, ' N_det :', N_det
|
||||
|
||||
U_SOM = 0.d0
|
||||
do i = 1, N_det
|
||||
if(i == i_HF) cycle
|
||||
call htilde_mu_mat_bi_ortho(psi_det(1,1,i_HF), psi_det(1,1,i), N_int, hmono_1, htwoe_1, hthree_1, htot_1)
|
||||
call htilde_mu_mat_bi_ortho(psi_det(1,1,i), psi_det(1,1,i_HF), N_int, hmono_2, htwoe_2, hthree_2, htot_2)
|
||||
U_SOM += htot_1 * htot_2
|
||||
enddo
|
||||
U_SOM = 0.5d0 * U_SOM
|
||||
print *, ' U_SOM = ', U_SOM
|
||||
|
||||
return
|
||||
end subroutine main
|
||||
|
||||
! ---
|
||||
|
|
@ -10,6 +10,7 @@ program test_normal_order
|
|||
read_wf = .True.
|
||||
touch read_wf
|
||||
touch my_grid_becke my_n_pt_r_grid my_n_pt_a_grid
|
||||
call provide_all_three_ints_bi_ortho
|
||||
call test
|
||||
end
|
||||
|
||||
|
@ -28,7 +29,7 @@ subroutine test
|
|||
s2 = 2
|
||||
accu = 0.d0
|
||||
do h1 = 1, elec_beta_num
|
||||
do p1 = elec_beta_num+1, mo_num
|
||||
do p1 = elec_alpha_num+1, mo_num
|
||||
do h2 = 1, elec_beta_num
|
||||
do p2 = elec_beta_num+1, mo_num
|
||||
det_i = ref_bitmask
|
||||
|
@ -38,36 +39,93 @@ subroutine test
|
|||
call get_excitation_degree(ref_bitmask,det_i,degree,N_int)
|
||||
call get_excitation(ref_bitmask,det_i,exc,degree,phase,N_int)
|
||||
hthree *= phase
|
||||
normal = normal_two_body_bi_orth_ab(p2,h2,p1,h1)
|
||||
! !normal = normal_two_body_bi_orth_ab(p2,h2,p1,h1)
|
||||
call three_comp_two_e_elem(det_i,h1,h2,p1,p2,s1,s2,normal)
|
||||
! normal = eff_2_e_from_3_e_ab(p2,p1,h2,h1)
|
||||
accu += dabs(hthree-normal)
|
||||
enddo
|
||||
enddo
|
||||
enddo
|
||||
enddo
|
||||
print*,'accu opposite spin = ',accu
|
||||
print*,'accu opposite spin = ',accu
|
||||
stop
|
||||
|
||||
s1 = 2
|
||||
s2 = 2
|
||||
accu = 0.d0
|
||||
do h1 = 1, elec_beta_num
|
||||
do p1 = elec_beta_num+1, mo_num
|
||||
do h2 = h1+1, elec_beta_num
|
||||
do p2 = elec_beta_num+1, mo_num
|
||||
det_i = ref_bitmask
|
||||
call do_single_excitation(det_i,h1,p1,s1,i_ok)
|
||||
call do_single_excitation(det_i,h2,p2,s2,i_ok)
|
||||
if(i_ok.ne.1)cycle
|
||||
call htilde_mu_mat_bi_ortho(det_i,ref_bitmask,N_int,hmono,htwoe,hthree,htilde_ij)
|
||||
call get_excitation_degree(ref_bitmask,det_i,degree,N_int)
|
||||
call get_excitation(ref_bitmask,det_i,exc,degree,phase,N_int)
|
||||
hthree *= phase
|
||||
normal = normal_two_body_bi_orth_aa_bb(p2,h2,p1,h1)
|
||||
accu += dabs(hthree-normal)
|
||||
enddo
|
||||
! p2=6
|
||||
! p1=5
|
||||
! h2=2
|
||||
! h1=1
|
||||
|
||||
s1 = 1
|
||||
s2 = 1
|
||||
accu = 0.d0
|
||||
do h1 = 1, elec_alpha_num
|
||||
do p1 = elec_alpha_num+1, mo_num
|
||||
do p2 = p1+1, mo_num
|
||||
do h2 = h1+1, elec_alpha_num
|
||||
det_i = ref_bitmask
|
||||
call do_single_excitation(det_i,h1,p1,s1,i_ok)
|
||||
if(i_ok.ne.1)cycle
|
||||
call do_single_excitation(det_i,h2,p2,s2,i_ok)
|
||||
if(i_ok.ne.1)cycle
|
||||
call htilde_mu_mat_bi_ortho(det_i,ref_bitmask,N_int,hmono,htwoe,hthree,htilde_ij)
|
||||
call get_excitation_degree(ref_bitmask,det_i,degree,N_int)
|
||||
call get_excitation(ref_bitmask,det_i,exc,degree,phase,N_int)
|
||||
integer :: hh1, pp1, hh2, pp2, ss1, ss2
|
||||
call decode_exc(exc, 2, hh1, pp1, hh2, pp2, ss1, ss2)
|
||||
hthree *= phase
|
||||
! normal = normal_two_body_bi_orth_aa_bb(p2,h2,p1,h1)
|
||||
normal = eff_2_e_from_3_e_aa(p2,p1,h2,h1)
|
||||
if(dabs(hthree).lt.1.d-10)cycle
|
||||
if(dabs(hthree-normal).gt.1.d-10)then
|
||||
print*,pp2,pp1,hh2,hh1
|
||||
print*,p2,p1,h2,h1
|
||||
print*,hthree,normal,dabs(hthree-normal)
|
||||
stop
|
||||
endif
|
||||
! print*,hthree,normal,dabs(hthree-normal)
|
||||
accu += dabs(hthree-normal)
|
||||
enddo
|
||||
enddo
|
||||
enddo
|
||||
print*,'accu same spin = ',accu
|
||||
enddo
|
||||
print*,'accu same spin alpha = ',accu
|
||||
|
||||
|
||||
s1 = 2
|
||||
s2 = 2
|
||||
accu = 0.d0
|
||||
do h1 = 1, elec_beta_num
|
||||
do p1 = elec_beta_num+1, mo_num
|
||||
do p2 = p1+1, mo_num
|
||||
do h2 = h1+1, elec_beta_num
|
||||
det_i = ref_bitmask
|
||||
call do_single_excitation(det_i,h1,p1,s1,i_ok)
|
||||
if(i_ok.ne.1)cycle
|
||||
call do_single_excitation(det_i,h2,p2,s2,i_ok)
|
||||
if(i_ok.ne.1)cycle
|
||||
call htilde_mu_mat_bi_ortho(det_i,ref_bitmask,N_int,hmono,htwoe,hthree,htilde_ij)
|
||||
call get_excitation_degree(ref_bitmask,det_i,degree,N_int)
|
||||
call get_excitation(ref_bitmask,det_i,exc,degree,phase,N_int)
|
||||
call decode_exc(exc, 2, hh1, pp1, hh2, pp2, ss1, ss2)
|
||||
hthree *= phase
|
||||
! normal = normal_two_body_bi_orth_aa_bb(p2,h2,p1,h1)
|
||||
normal = eff_2_e_from_3_e_bb(p2,p1,h2,h1)
|
||||
if(dabs(hthree).lt.1.d-10)cycle
|
||||
if(dabs(hthree-normal).gt.1.d-10)then
|
||||
print*,pp2,pp1,hh2,hh1
|
||||
print*,p2,p1,h2,h1
|
||||
print*,hthree,normal,dabs(hthree-normal)
|
||||
stop
|
||||
endif
|
||||
! print*,hthree,normal,dabs(hthree-normal)
|
||||
accu += dabs(hthree-normal)
|
||||
enddo
|
||||
enddo
|
||||
enddo
|
||||
enddo
|
||||
print*,'accu same spin beta = ',accu
|
||||
|
||||
|
||||
end
|
||||
|
||||
|
||||
|
|
|
@ -11,121 +11,210 @@ program tc_bi_ortho
|
|||
touch read_wf
|
||||
touch my_grid_becke my_n_pt_r_grid my_n_pt_a_grid
|
||||
|
||||
! call routine_2
|
||||
call test_rout
|
||||
! call test_slater_tc_opt
|
||||
call timing_tot
|
||||
! call timing_diag
|
||||
! call timing_single
|
||||
! call timing_double
|
||||
end
|
||||
|
||||
subroutine test_rout
|
||||
subroutine test_slater_tc_opt
|
||||
implicit none
|
||||
integer :: i,j,ii,jj
|
||||
use bitmasks ! you need to include the bitmasks_module.f90 features
|
||||
integer(bit_kind), allocatable :: det_i(:,:)
|
||||
allocate(det_i(N_int,2))
|
||||
det_i(:,:)= psi_det(:,:,1)
|
||||
call debug_det(det_i,N_int)
|
||||
integer, allocatable :: occ(:,:)
|
||||
integer :: n_occ_ab(2)
|
||||
allocate(occ(N_int*bit_kind_size,2))
|
||||
call bitstring_to_list_ab(det_i, occ, n_occ_ab, N_int)
|
||||
double precision :: hmono, htwoe, htot
|
||||
call diag_htilde_mu_mat_bi_ortho(N_int, det_i, hmono, htwoe, htot)
|
||||
print*,'hmono, htwoe, htot'
|
||||
print*, hmono, htwoe, htot
|
||||
print*,'alpha electrons orbital occupancy'
|
||||
do i = 1, n_occ_ab(1) ! browsing the alpha electrons
|
||||
j = occ(i,1)
|
||||
print*,j,mo_bi_ortho_tc_one_e(j,j)
|
||||
enddo
|
||||
print*,'beta electrons orbital occupancy'
|
||||
do i = 1, n_occ_ab(2) ! browsing the beta electrons
|
||||
j = occ(i,2)
|
||||
print*,j,mo_bi_ortho_tc_one_e(j,j)
|
||||
enddo
|
||||
print*,'alpha beta'
|
||||
do i = 1, n_occ_ab(1)
|
||||
ii = occ(i,1)
|
||||
do j = 1, n_occ_ab(2)
|
||||
jj = occ(j,2)
|
||||
print*,ii,jj,mo_bi_ortho_tc_two_e(jj,ii,jj,ii)
|
||||
enddo
|
||||
enddo
|
||||
print*,'alpha alpha'
|
||||
do i = 1, n_occ_ab(1)
|
||||
ii = occ(i,1)
|
||||
do j = 1, n_occ_ab(1)
|
||||
jj = occ(j,1)
|
||||
print*,ii,jj,mo_bi_ortho_tc_two_e(jj,ii,jj,ii), mo_bi_ortho_tc_two_e(ii,jj,jj,ii)
|
||||
enddo
|
||||
enddo
|
||||
|
||||
print*,'beta beta'
|
||||
do i = 1, n_occ_ab(2)
|
||||
ii = occ(i,2)
|
||||
do j = 1, n_occ_ab(2)
|
||||
jj = occ(j,2)
|
||||
print*,ii,jj,mo_bi_ortho_tc_two_e(jj,ii,jj,ii), mo_bi_ortho_tc_two_e(ii,jj,jj,ii)
|
||||
enddo
|
||||
enddo
|
||||
|
||||
|
||||
end
|
||||
|
||||
subroutine routine_2
|
||||
implicit none
|
||||
integer :: i
|
||||
double precision :: bi_ortho_mo_ints
|
||||
print*,'H matrix'
|
||||
integer :: i,j,degree
|
||||
double precision :: hmono, htwoe, htot, hthree
|
||||
double precision :: hnewmono, hnewtwoe, hnewthree, hnewtot
|
||||
double precision :: accu_d ,i_count, accu
|
||||
accu = 0.d0
|
||||
accu_d = 0.d0
|
||||
i_count = 0.d0
|
||||
do i = 1, N_det
|
||||
write(*,'(1000(F16.5,X))')htilde_matrix_elmt_bi_ortho(:,i)
|
||||
enddo
|
||||
i = 1
|
||||
double precision :: phase
|
||||
integer :: degree,h1, p1, h2, p2, s1, s2, exc(0:2,2,2)
|
||||
call get_excitation_degree(ref_bitmask, psi_det(1,1,i), degree, N_int)
|
||||
if(degree==2)then
|
||||
call get_double_excitation(ref_bitmask, psi_det(1,1,i), exc, phase, N_int)
|
||||
call decode_exc(exc, 2, h1, p1, h2, p2, s1, s2)
|
||||
print*,'h1,h2,p1,p2'
|
||||
print*, h1,h2,p1,p2
|
||||
print*,mo_bi_ortho_tc_two_e(p1,p2,h1,h2),mo_bi_ortho_tc_two_e(h1,h2,p1,p2)
|
||||
endif
|
||||
|
||||
|
||||
print*,'coef'
|
||||
do i = 1, ao_num
|
||||
print*,i,mo_l_coef(i,8),mo_r_coef(i,8)
|
||||
enddo
|
||||
! print*,'mdlqfmlqgmqglj'
|
||||
! print*,'mo_bi_ortho_tc_two_e()',mo_bi_ortho_tc_two_e(2,2,3,3)
|
||||
! print*,'bi_ortho_mo_ints ',bi_ortho_mo_ints(2,2,3,3)
|
||||
print*,'Overlap'
|
||||
do i = 1, mo_num
|
||||
write(*,'(100(F16.10,X))')overlap_bi_ortho(:,i)
|
||||
do j = 1,N_det
|
||||
call htilde_mu_mat_bi_ortho(psi_det(1,1,j), psi_det(1,1,i), N_int, hmono, htwoe, hthree, htot)
|
||||
call htilde_mu_mat_opt_bi_ortho(psi_det(1,1,j), psi_det(1,1,i), N_int, hnewmono, hnewtwoe, hnewthree, hnewtot)
|
||||
if(dabs(htot).gt.1.d-15)then
|
||||
i_count += 1.D0
|
||||
accu += dabs(htot-hnewtot)
|
||||
if(dabs(htot-hnewtot).gt.1.d-8.or.dabs(htot-hnewtot).gt.dabs(htot))then
|
||||
call get_excitation_degree(psi_det(1,1,j), psi_det(1,1,i),degree,N_int)
|
||||
print*,j,i,degree
|
||||
call debug_det(psi_det(1,1,i),N_int)
|
||||
call debug_det(psi_det(1,1,j),N_int)
|
||||
print*,htot,hnewtot,dabs(htot-hnewtot)
|
||||
print*,hthree,hnewthree,dabs(hthree-hnewthree)
|
||||
stop
|
||||
endif
|
||||
endif
|
||||
enddo
|
||||
enddo
|
||||
print*,'accu = ',accu/i_count
|
||||
|
||||
end
|
||||
|
||||
subroutine routine
|
||||
subroutine timing_tot
|
||||
implicit none
|
||||
double precision :: hmono,htwoe,hthree,htot
|
||||
integer(bit_kind), allocatable :: key1(:,:)
|
||||
integer(bit_kind), allocatable :: key2(:,:)
|
||||
allocate(key1(N_int,2),key2(N_int,2))
|
||||
use bitmasks
|
||||
key1 = ref_bitmask
|
||||
call htilde_mu_mat_bi_ortho(key1,key1, N_int, hmono,htwoe,hthree,htot)
|
||||
key2 = key1
|
||||
integer :: h,p,i_ok
|
||||
h = 1
|
||||
p = 8
|
||||
call do_single_excitation(key2,h,p,1,i_ok)
|
||||
call debug_det(key2,N_int)
|
||||
call htilde_mu_mat_bi_ortho(key2,key1, N_int, hmono,htwoe,hthree,htot)
|
||||
! print*,'fock_matrix_tc_mo_alpha(p,h) = ',fock_matrix_tc_mo_alpha(p,h)
|
||||
print*,'htot = ',htot
|
||||
print*,'hmono = ',hmono
|
||||
print*,'htwoe = ',htwoe
|
||||
double precision :: bi_ortho_mo_ints
|
||||
print*,'bi_ortho_mo_ints(1,p,1,h)',bi_ortho_mo_ints(1,p,1,h)
|
||||
integer :: i,j
|
||||
double precision :: wall0, wall1
|
||||
double precision, allocatable :: mat_old(:,:),mat_new(:,:)
|
||||
double precision :: hmono, htwoe, hthree, htot, i_count
|
||||
integer :: degree
|
||||
call htilde_mu_mat_opt_bi_ortho(psi_det(1,1,1), psi_det(1,1,2), N_int, hmono, htwoe, hthree, htot)
|
||||
call htilde_mu_mat_opt_bi_ortho(psi_det(1,1,1), psi_det(1,1,2), N_int, hmono, htwoe, hthree, htot)
|
||||
call wall_time(wall0)
|
||||
i_count = 0.d0
|
||||
do i = 1, N_det
|
||||
do j = 1, N_det
|
||||
! call get_excitation_degree(psi_det(1,1,j), psi_det(1,1,i),degree,N_int)
|
||||
i_count += 1.d0
|
||||
call htilde_mu_mat_bi_ortho(psi_det(1,1,j), psi_det(1,1,i), N_int, hmono, htwoe, hthree, htot)
|
||||
enddo
|
||||
enddo
|
||||
call wall_time(wall1)
|
||||
print*,'i_count = ',i_count
|
||||
print*,'time for old hij for total = ',wall1 - wall0
|
||||
|
||||
call wall_time(wall0)
|
||||
i_count = 0.d0
|
||||
do i = 1, N_det
|
||||
do j = 1, N_det
|
||||
! call get_excitation_degree(psi_det(1,1,j), psi_det(1,1,i),degree,N_int)
|
||||
i_count += 1.d0
|
||||
call htilde_mu_mat_opt_bi_ortho(psi_det(1,1,j), psi_det(1,1,i), N_int, hmono, htwoe, hthree, htot)
|
||||
enddo
|
||||
enddo
|
||||
call wall_time(wall1)
|
||||
print*,'i_count = ',i_count
|
||||
print*,'time for new hij for total = ',wall1 - wall0
|
||||
call i_H_j(psi_det(1,1,1), psi_det(1,1,2),N_int,htot)
|
||||
call wall_time(wall0)
|
||||
i_count = 0.d0
|
||||
do i = 1, N_det
|
||||
do j = 1, N_det
|
||||
call i_H_j(psi_det(1,1,j), psi_det(1,1,i),N_int,htot)
|
||||
i_count += 1.d0
|
||||
enddo
|
||||
enddo
|
||||
call wall_time(wall1)
|
||||
print*,'i_count = ',i_count
|
||||
print*,'time for new hij STANDARD = ',wall1 - wall0
|
||||
|
||||
end
|
||||
|
||||
subroutine timing_diag
|
||||
implicit none
|
||||
integer :: i,j
|
||||
double precision :: wall0, wall1
|
||||
double precision, allocatable :: mat_old(:,:),mat_new(:,:)
|
||||
double precision :: hmono, htwoe, hthree, htot, i_count
|
||||
integer :: degree
|
||||
call htilde_mu_mat_opt_bi_ortho(psi_det(1,1,1), psi_det(1,1,1), N_int, hmono, htwoe, hthree, htot)
|
||||
call wall_time(wall0)
|
||||
i_count = 0.d0
|
||||
do i = 1, N_det
|
||||
do j = i,i
|
||||
i_count += 1.d0
|
||||
call htilde_mu_mat_bi_ortho(psi_det(1,1,j), psi_det(1,1,i), N_int, hmono, htwoe, hthree, htot)
|
||||
enddo
|
||||
enddo
|
||||
call wall_time(wall1)
|
||||
print*,'i_count = ',i_count
|
||||
print*,'time for old hij for diagonal= ',wall1 - wall0
|
||||
|
||||
call wall_time(wall0)
|
||||
i_count = 0.d0
|
||||
do i = 1, N_det
|
||||
do j = i,i
|
||||
i_count += 1.d0
|
||||
call htilde_mu_mat_opt_bi_ortho(psi_det(1,1,j), psi_det(1,1,i), N_int, hmono, htwoe, hthree, htot)
|
||||
enddo
|
||||
enddo
|
||||
call wall_time(wall1)
|
||||
print*,'i_count = ',i_count
|
||||
print*,'time for new hij for diagonal= ',wall1 - wall0
|
||||
|
||||
end
|
||||
|
||||
subroutine timing_single
|
||||
implicit none
|
||||
integer :: i,j
|
||||
double precision :: wall0, wall1,accu
|
||||
double precision, allocatable :: mat_old(:,:),mat_new(:,:)
|
||||
double precision :: hmono, htwoe, hthree, htot, i_count
|
||||
integer :: degree
|
||||
call htilde_mu_mat_opt_bi_ortho(psi_det(1,1,1), psi_det(1,1,1), N_int, hmono, htwoe, hthree, htot)
|
||||
i_count = 0.d0
|
||||
accu = 0.d0
|
||||
do i = 1, N_det
|
||||
do j = 1, N_det
|
||||
call get_excitation_degree(psi_det(1,1,j), psi_det(1,1,i),degree,N_int)
|
||||
if(degree.ne.1)cycle
|
||||
i_count += 1.d0
|
||||
call wall_time(wall0)
|
||||
call htilde_mu_mat_bi_ortho(psi_det(1,1,j), psi_det(1,1,i), N_int, hmono, htwoe, hthree, htot)
|
||||
call wall_time(wall1)
|
||||
accu += wall1 - wall0
|
||||
enddo
|
||||
enddo
|
||||
print*,'i_count = ',i_count
|
||||
print*,'time for old hij for singles = ',accu
|
||||
|
||||
i_count = 0.d0
|
||||
accu = 0.d0
|
||||
do i = 1, N_det
|
||||
do j = 1, N_det
|
||||
call get_excitation_degree(psi_det(1,1,j), psi_det(1,1,i),degree,N_int)
|
||||
if(degree.ne.1)cycle
|
||||
i_count += 1.d0
|
||||
call wall_time(wall0)
|
||||
call htilde_mu_mat_opt_bi_ortho(psi_det(1,1,j), psi_det(1,1,i), N_int, hmono, htwoe, hthree, htot)
|
||||
call wall_time(wall1)
|
||||
accu += wall1 - wall0
|
||||
enddo
|
||||
enddo
|
||||
print*,'i_count = ',i_count
|
||||
print*,'time for new hij for singles = ',accu
|
||||
|
||||
end
|
||||
|
||||
subroutine timing_double
|
||||
implicit none
|
||||
integer :: i,j
|
||||
double precision :: wall0, wall1,accu
|
||||
double precision, allocatable :: mat_old(:,:),mat_new(:,:)
|
||||
double precision :: hmono, htwoe, hthree, htot, i_count
|
||||
integer :: degree
|
||||
call htilde_mu_mat_opt_bi_ortho(psi_det(1,1,1), psi_det(1,1,1), N_int, hmono, htwoe, hthree, htot)
|
||||
i_count = 0.d0
|
||||
accu = 0.d0
|
||||
do i = 1, N_det
|
||||
do j = 1, N_det
|
||||
call get_excitation_degree(psi_det(1,1,j), psi_det(1,1,i),degree,N_int)
|
||||
if(degree.ne.2)cycle
|
||||
i_count += 1.d0
|
||||
call wall_time(wall0)
|
||||
call htilde_mu_mat_bi_ortho(psi_det(1,1,j), psi_det(1,1,i), N_int, hmono, htwoe, hthree, htot)
|
||||
call wall_time(wall1)
|
||||
accu += wall1 - wall0
|
||||
enddo
|
||||
enddo
|
||||
print*,'i_count = ',i_count
|
||||
print*,'time for old hij for doubles = ',accu
|
||||
|
||||
i_count = 0.d0
|
||||
accu = 0.d0
|
||||
do i = 1, N_det
|
||||
do j = 1, N_det
|
||||
call get_excitation_degree(psi_det(1,1,j), psi_det(1,1,i),degree,N_int)
|
||||
if(degree.ne.2)cycle
|
||||
i_count += 1.d0
|
||||
call wall_time(wall0)
|
||||
call htilde_mu_mat_opt_bi_ortho(psi_det(1,1,j), psi_det(1,1,i), N_int, hmono, htwoe, hthree, htot)
|
||||
call wall_time(wall1)
|
||||
accu += wall1 - wall0
|
||||
enddo
|
||||
enddo
|
||||
call wall_time(wall1)
|
||||
print*,'i_count = ',i_count
|
||||
print*,'time for new hij for doubles = ',accu
|
||||
|
||||
end
|
||||
|
||||
|
|
|
@ -15,7 +15,8 @@ program test_tc_fock
|
|||
!call routine_2
|
||||
! call routine_3()
|
||||
|
||||
call test_3e
|
||||
! call test_3e
|
||||
call routine_tot
|
||||
end
|
||||
|
||||
! ---
|
||||
|
@ -32,7 +33,7 @@ subroutine test_3e
|
|||
print*,'htot = ',htot
|
||||
print*,''
|
||||
print*,''
|
||||
print*,'TC_one= ',TC_HF_one_electron_energy
|
||||
print*,'TC_one= ',tc_hf_one_e_energy
|
||||
print*,'TC_two= ',TC_HF_two_e_energy
|
||||
print*,'TC_3e = ',diag_three_elem_hf
|
||||
print*,'TC_tot= ',TC_HF_energy
|
||||
|
@ -84,8 +85,8 @@ subroutine routine_3()
|
|||
print*, i, a
|
||||
stop
|
||||
endif
|
||||
!print*, ' excited det'
|
||||
!call debug_det(det_i, N_int)
|
||||
print*, ' excited det'
|
||||
call debug_det(det_i, N_int)
|
||||
|
||||
call htilde_mu_mat_bi_ortho(det_i, ref_bitmask, N_int, hmono, htwoe, hthree, htilde_ij)
|
||||
if(dabs(hthree).lt.1.d-10)cycle
|
||||
|
@ -116,3 +117,78 @@ subroutine routine_3()
|
|||
end subroutine routine_3
|
||||
|
||||
! ---
|
||||
subroutine routine_tot()
|
||||
|
||||
use bitmasks ! you need to include the bitmasks_module.f90 features
|
||||
|
||||
implicit none
|
||||
integer :: i, a, i_ok, s1,other_spin(2)
|
||||
double precision :: hmono, htwoe, hthree, htilde_ij
|
||||
double precision :: err_ai, err_tot, ref, new
|
||||
integer(bit_kind), allocatable :: det_i(:,:)
|
||||
|
||||
allocate(det_i(N_int,2))
|
||||
other_spin(1) = 2
|
||||
other_spin(2) = 1
|
||||
|
||||
err_tot = 0.d0
|
||||
|
||||
! do s1 = 1, 2
|
||||
s1 = 2
|
||||
det_i = ref_bitmask
|
||||
call debug_det(det_i, N_int)
|
||||
print*, ' HF det'
|
||||
call debug_det(det_i, N_int)
|
||||
|
||||
! do i = 1, elec_num_tab(s1)
|
||||
! do a = elec_num_tab(s1)+1, mo_num ! virtual
|
||||
do i = 1, elec_beta_num
|
||||
do a = elec_beta_num+1, elec_alpha_num! virtual
|
||||
! do i = elec_beta_num+1, elec_alpha_num
|
||||
! do a = elec_alpha_num+1, mo_num! virtual
|
||||
print*,i,a
|
||||
|
||||
det_i = ref_bitmask
|
||||
call do_single_excitation(det_i, i, a, s1, i_ok)
|
||||
if(i_ok == -1) then
|
||||
print*, 'PB !!'
|
||||
print*, i, a
|
||||
stop
|
||||
endif
|
||||
|
||||
call htilde_mu_mat_bi_ortho(det_i, ref_bitmask, N_int, hmono, htwoe, hthree, htilde_ij)
|
||||
print*,htilde_ij
|
||||
if(dabs(htilde_ij).lt.1.d-10)cycle
|
||||
print*, ' excited det'
|
||||
call debug_det(det_i, N_int)
|
||||
|
||||
if(s1 == 1)then
|
||||
new = Fock_matrix_tc_mo_alpha(a,i)
|
||||
else
|
||||
new = Fock_matrix_tc_mo_beta(a,i)
|
||||
endif
|
||||
ref = htilde_ij
|
||||
! if(s1 == 1)then
|
||||
! new = fock_a_tot_3e_bi_orth(a,i)
|
||||
! else if(s1 == 2)then
|
||||
! new = fock_b_tot_3e_bi_orth(a,i)
|
||||
! endif
|
||||
err_ai = dabs(dabs(ref) - dabs(new))
|
||||
if(err_ai .gt. 1d-7) then
|
||||
print*,'s1 = ',s1
|
||||
print*, ' warning on', i, a
|
||||
print*, ref,new,err_ai
|
||||
endif
|
||||
print*, ref,new,err_ai
|
||||
err_tot += err_ai
|
||||
|
||||
write(22, *) htilde_ij
|
||||
enddo
|
||||
enddo
|
||||
! enddo
|
||||
|
||||
print *, ' err_tot = ', err_tot
|
||||
|
||||
deallocate(det_i)
|
||||
|
||||
end subroutine routine_3
|
||||
|
|
|
@ -86,7 +86,7 @@ default: False
|
|||
type: Threshold
|
||||
doc: Threshold on the convergence of the Hartree Fock energy.
|
||||
interface: ezfio,provider,ocaml
|
||||
default: 1.e-10
|
||||
default: 1.e-12
|
||||
|
||||
[n_it_tcscf_max]
|
||||
type: Strictly_positive_int
|
||||
|
@ -134,5 +134,53 @@ default: False
|
|||
type: integer
|
||||
doc: nb of Gaussians used to fit Jastrow fcts
|
||||
interface: ezfio,provider,ocaml
|
||||
default: 6
|
||||
default: 20
|
||||
|
||||
[tcscf_algorithm]
|
||||
type: character*(32)
|
||||
doc: Type of TCSCF algorithm used. Possible choices are [Simple | DIIS]
|
||||
interface: ezfio,provider,ocaml
|
||||
default: Simple
|
||||
|
||||
[test_cycle_tc]
|
||||
type: logical
|
||||
doc: If |true|, the integrals of the three-body jastrow are computed with cycles
|
||||
interface: ezfio,provider,ocaml
|
||||
default: False
|
||||
|
||||
[thresh_biorthog_diag]
|
||||
type: Threshold
|
||||
doc: Threshold to determine if diagonal elements of the bi-orthogonal condition L.T x R are close enouph to 1
|
||||
interface: ezfio,provider,ocaml
|
||||
default: 1.e-6
|
||||
|
||||
[thresh_biorthog_nondiag]
|
||||
type: Threshold
|
||||
doc: Threshold to determine if non-diagonal elements of L.T x R are close enouph to 0
|
||||
interface: ezfio,provider,ocaml
|
||||
default: 1.e-6
|
||||
|
||||
[max_dim_diis_tcscf]
|
||||
type: integer
|
||||
doc: Maximum size of the DIIS extrapolation procedure
|
||||
interface: ezfio,provider,ocaml
|
||||
default: 15
|
||||
|
||||
[threshold_diis_tcscf]
|
||||
type: Threshold
|
||||
doc: Threshold on the convergence of the DIIS error vector during a TCSCF calculation. If 0. is chosen, the square root of thresh_tcscf will be used.
|
||||
interface: ezfio,provider,ocaml
|
||||
default: 0.
|
||||
|
||||
[level_shift_tcscf]
|
||||
type: Positive_float
|
||||
doc: Energy shift on the virtual MOs to improve TCSCF convergence
|
||||
interface: ezfio,provider,ocaml
|
||||
default: 0.
|
||||
|
||||
[im_thresh_tcscf]
|
||||
type: Threshold
|
||||
doc: Thresholds on the Imag part of energy
|
||||
interface: ezfio,provider,ocaml
|
||||
default: 1.e-7
|
||||
|
||||
|
|
|
@ -1,3 +1,5 @@
|
|||
! ---
|
||||
|
||||
BEGIN_PROVIDER [ double precision, fock_tc_reigvec_mo, (mo_num, mo_num)]
|
||||
&BEGIN_PROVIDER [ double precision, fock_tc_leigvec_mo, (mo_num, mo_num)]
|
||||
&BEGIN_PROVIDER [ double precision, eigval_fock_tc_mo, (mo_num)]
|
||||
|
@ -9,32 +11,46 @@
|
|||
|
||||
implicit none
|
||||
integer :: n_real_tc
|
||||
integer :: i, k, l
|
||||
integer :: i, j, k, l
|
||||
double precision :: accu_d, accu_nd, accu_tmp
|
||||
double precision :: thr_d, thr_nd
|
||||
double precision :: norm
|
||||
double precision, allocatable :: eigval_right_tmp(:)
|
||||
double precision, allocatable :: F_tmp(:,:)
|
||||
|
||||
thr_d = 1d-6
|
||||
thr_nd = 1d-6
|
||||
|
||||
allocate( eigval_right_tmp(mo_num) )
|
||||
allocate( eigval_right_tmp(mo_num), F_tmp(mo_num,mo_num) )
|
||||
|
||||
PROVIDE Fock_matrix_tc_mo_tot
|
||||
|
||||
call non_hrmt_bieig( mo_num, Fock_matrix_tc_mo_tot, thr_d, thr_nd &
|
||||
, fock_tc_leigvec_mo, fock_tc_reigvec_mo &
|
||||
do i = 1, mo_num
|
||||
do j = 1, mo_num
|
||||
F_tmp(j,i) = Fock_matrix_tc_mo_tot(j,i)
|
||||
enddo
|
||||
enddo
|
||||
! insert level shift here
|
||||
do i = elec_beta_num+1, elec_alpha_num
|
||||
F_tmp(i,i) += 0.5d0 * level_shift_tcscf
|
||||
enddo
|
||||
do i = elec_alpha_num+1, mo_num
|
||||
F_tmp(i,i) += level_shift_tcscf
|
||||
enddo
|
||||
|
||||
call non_hrmt_bieig( mo_num, F_tmp, thresh_biorthog_diag, thresh_biorthog_nondiag &
|
||||
, fock_tc_leigvec_mo, fock_tc_reigvec_mo &
|
||||
, n_real_tc, eigval_right_tmp )
|
||||
|
||||
!if(max_ov_tc_scf)then
|
||||
! call non_hrmt_fock_mat( mo_num, Fock_matrix_tc_mo_tot, thr_d, thr_nd &
|
||||
! , fock_tc_leigvec_mo, fock_tc_reigvec_mo &
|
||||
! call non_hrmt_fock_mat( mo_num, F_tmp, thresh_biorthog_diag, thresh_biorthog_nondiag &
|
||||
! , fock_tc_leigvec_mo, fock_tc_reigvec_mo &
|
||||
! , n_real_tc, eigval_right_tmp )
|
||||
!else
|
||||
! call non_hrmt_diag_split_degen_bi_orthog( mo_num, Fock_matrix_tc_mo_tot &
|
||||
! call non_hrmt_diag_split_degen_bi_orthog( mo_num, F_tmp &
|
||||
! , fock_tc_leigvec_mo, fock_tc_reigvec_mo &
|
||||
! , n_real_tc, eigval_right_tmp )
|
||||
!endif
|
||||
|
||||
deallocate(F_tmp)
|
||||
|
||||
|
||||
! if(n_real_tc .ne. mo_num)then
|
||||
! print*,'n_real_tc ne mo_num ! ',n_real_tc
|
||||
! stop
|
||||
|
@ -42,9 +58,12 @@
|
|||
|
||||
eigval_fock_tc_mo = eigval_right_tmp
|
||||
! print*,'Eigenvalues of Fock_matrix_tc_mo_tot'
|
||||
! do i = 1, mo_num
|
||||
! do i = 1, elec_alpha_num
|
||||
! print*, i, eigval_fock_tc_mo(i)
|
||||
! enddo
|
||||
! do i = elec_alpha_num+1, mo_num
|
||||
! print*, i, eigval_fock_tc_mo(i) - level_shift_tcscf
|
||||
! enddo
|
||||
! deallocate( eigval_right_tmp )
|
||||
|
||||
! L.T x R
|
||||
|
@ -53,6 +72,8 @@
|
|||
, fock_tc_reigvec_mo, size(fock_tc_reigvec_mo, 1) &
|
||||
, 0.d0, overlap_fock_tc_eigvec_mo, size(overlap_fock_tc_eigvec_mo, 1) )
|
||||
|
||||
! ---
|
||||
|
||||
accu_d = 0.d0
|
||||
accu_nd = 0.d0
|
||||
do i = 1, mo_num
|
||||
|
@ -63,45 +84,80 @@
|
|||
else
|
||||
accu_tmp = overlap_fock_tc_eigvec_mo(k,i)
|
||||
accu_nd += accu_tmp * accu_tmp
|
||||
if(dabs(overlap_fock_tc_eigvec_mo(k,i)) .gt. thr_nd)then
|
||||
if(dabs(overlap_fock_tc_eigvec_mo(k,i)) .gt. thresh_biorthog_nondiag)then
|
||||
print *, 'k,i', k, i, overlap_fock_tc_eigvec_mo(k,i)
|
||||
endif
|
||||
endif
|
||||
enddo
|
||||
enddo
|
||||
accu_nd = dsqrt(accu_nd)/accu_d
|
||||
|
||||
if(accu_nd .gt. thr_nd) then
|
||||
accu_nd = dsqrt(accu_nd) / accu_d
|
||||
if(accu_nd .gt. thresh_biorthog_nondiag) then
|
||||
print *, ' bi-orthog failed'
|
||||
print*,'accu_nd MO = ', accu_nd, thr_nd
|
||||
print*,'overlap_fock_tc_eigvec_mo = '
|
||||
print *, ' accu_nd MO = ', accu_nd, thresh_biorthog_nondiag
|
||||
print *, ' overlap_fock_tc_eigvec_mo = '
|
||||
do i = 1, mo_num
|
||||
write(*,'(100(F16.10,X))') overlap_fock_tc_eigvec_mo(i,:)
|
||||
enddo
|
||||
stop
|
||||
stop
|
||||
endif
|
||||
|
||||
if( dabs(accu_d - dble(mo_num))/dble(mo_num) .gt. thr_d ) then
|
||||
print *, 'mo_num = ', mo_num
|
||||
print *, 'accu_d MO = ', accu_d, thr_d
|
||||
print *, 'normalizing vectors ...'
|
||||
! ---
|
||||
|
||||
if(dabs(accu_d - dble(mo_num))/dble(mo_num) .gt. thresh_biorthog_diag) then
|
||||
|
||||
print *, ' mo_num = ', mo_num
|
||||
print *, ' accu_d MO = ', accu_d, thresh_biorthog_diag
|
||||
print *, ' normalizing vectors ...'
|
||||
do i = 1, mo_num
|
||||
norm = dsqrt(dabs(overlap_fock_tc_eigvec_mo(i,i)))
|
||||
if(norm .gt. thr_d) then
|
||||
if(norm .gt. thresh_biorthog_diag) then
|
||||
do k = 1, mo_num
|
||||
fock_tc_reigvec_mo(k,i) *= 1.d0/norm
|
||||
fock_tc_leigvec_mo(k,i) *= 1.d0/norm
|
||||
enddo
|
||||
endif
|
||||
enddo
|
||||
|
||||
call dgemm( "T", "N", mo_num, mo_num, mo_num, 1.d0 &
|
||||
, fock_tc_leigvec_mo, size(fock_tc_leigvec_mo, 1) &
|
||||
, fock_tc_reigvec_mo, size(fock_tc_reigvec_mo, 1) &
|
||||
, 0.d0, overlap_fock_tc_eigvec_mo, size(overlap_fock_tc_eigvec_mo, 1) )
|
||||
|
||||
accu_d = 0.d0
|
||||
accu_nd = 0.d0
|
||||
do i = 1, mo_num
|
||||
do k = 1, mo_num
|
||||
if(i==k) then
|
||||
accu_tmp = overlap_fock_tc_eigvec_mo(k,i)
|
||||
accu_d += dabs(accu_tmp)
|
||||
else
|
||||
accu_tmp = overlap_fock_tc_eigvec_mo(k,i)
|
||||
accu_nd += accu_tmp * accu_tmp
|
||||
if(dabs(overlap_fock_tc_eigvec_mo(k,i)) .gt. thresh_biorthog_nondiag)then
|
||||
print *, 'k,i', k, i, overlap_fock_tc_eigvec_mo(k,i)
|
||||
endif
|
||||
endif
|
||||
enddo
|
||||
enddo
|
||||
accu_nd = dsqrt(accu_nd) / accu_d
|
||||
if(accu_nd .gt. thresh_biorthog_diag) then
|
||||
print *, ' bi-orthog failed'
|
||||
print *, ' accu_nd MO = ', accu_nd, thresh_biorthog_nondiag
|
||||
print *, ' overlap_fock_tc_eigvec_mo = '
|
||||
do i = 1, mo_num
|
||||
write(*,'(100(F16.10,X))') overlap_fock_tc_eigvec_mo(i,:)
|
||||
enddo
|
||||
stop
|
||||
endif
|
||||
|
||||
endif
|
||||
|
||||
! ---
|
||||
|
||||
END_PROVIDER
|
||||
|
||||
! ---
|
||||
|
||||
BEGIN_PROVIDER [ double precision, fock_tc_reigvec_ao, (ao_num, mo_num)]
|
||||
&BEGIN_PROVIDER [ double precision, fock_tc_leigvec_ao, (ao_num, mo_num)]
|
||||
&BEGIN_PROVIDER [ double precision, overlap_fock_tc_eigvec_ao, (mo_num, mo_num) ]
|
||||
|
@ -117,6 +173,7 @@ END_PROVIDER
|
|||
double precision :: accu, accu_d
|
||||
double precision, allocatable :: tmp(:,:)
|
||||
|
||||
PROVIDE mo_l_coef mo_r_coef
|
||||
|
||||
! ! MO_R x R
|
||||
call dgemm( 'N', 'N', ao_num, mo_num, mo_num, 1.d0 &
|
||||
|
|
186
src/tc_scf/diis_tcscf.irp.f
Normal file
186
src/tc_scf/diis_tcscf.irp.f
Normal file
|
@ -0,0 +1,186 @@
|
|||
! ---
|
||||
|
||||
BEGIN_PROVIDER [ double precision, threshold_DIIS_nonzero_TCSCF ]
|
||||
|
||||
implicit none
|
||||
|
||||
if(threshold_DIIS_TCSCF == 0.d0) then
|
||||
threshold_DIIS_nonzero_TCSCF = dsqrt(thresh_tcscf)
|
||||
else
|
||||
threshold_DIIS_nonzero_TCSCF = threshold_DIIS_TCSCF
|
||||
endif
|
||||
ASSERT(threshold_DIIS_nonzero_TCSCF >= 0.d0)
|
||||
|
||||
END_PROVIDER
|
||||
|
||||
! ---
|
||||
|
||||
BEGIN_PROVIDER [double precision, Q_alpha, (ao_num, ao_num) ]
|
||||
|
||||
BEGIN_DOC
|
||||
!
|
||||
! Q_alpha = mo_r_coef x eta_occ_alpha x mo_l_coef.T
|
||||
!
|
||||
! [Q_alpha]_ij = \sum_{k=1}^{elec_alpha_num} [mo_r_coef]_ik [mo_l_coef]_jk
|
||||
!
|
||||
END_DOC
|
||||
|
||||
implicit none
|
||||
|
||||
Q_alpha = 0.d0
|
||||
call dgemm( 'N', 'T', ao_num, ao_num, elec_alpha_num, 1.d0 &
|
||||
, mo_r_coef, size(mo_r_coef, 1), mo_l_coef, size(mo_l_coef, 1) &
|
||||
, 0.d0, Q_alpha, size(Q_alpha, 1) )
|
||||
|
||||
END_PROVIDER
|
||||
|
||||
! ---
|
||||
|
||||
BEGIN_PROVIDER [ double precision, Q_beta, (ao_num, ao_num) ]
|
||||
|
||||
BEGIN_DOC
|
||||
!
|
||||
! Q_beta = mo_r_coef x eta_occ_beta x mo_l_coef.T
|
||||
!
|
||||
! [Q_beta]_ij = \sum_{k=1}^{elec_beta_num} [mo_r_coef]_ik [mo_l_coef]_jk
|
||||
!
|
||||
END_DOC
|
||||
|
||||
implicit none
|
||||
|
||||
Q_beta = 0.d0
|
||||
call dgemm( 'N', 'T', ao_num, ao_num, elec_beta_num, 1.d0 &
|
||||
, mo_r_coef, size(mo_r_coef, 1), mo_l_coef, size(mo_l_coef, 1) &
|
||||
, 0.d0, Q_beta, size(Q_beta, 1) )
|
||||
|
||||
END_PROVIDER
|
||||
|
||||
! ---
|
||||
|
||||
BEGIN_PROVIDER [ double precision, Q_matrix, (ao_num, ao_num) ]
|
||||
|
||||
BEGIN_DOC
|
||||
!
|
||||
! Q_matrix = 2 mo_r_coef x eta_occ x mo_l_coef.T
|
||||
!
|
||||
! with:
|
||||
! | 1 if i = j = 1, ..., nb of occ orbitals
|
||||
! [eta_occ]_ij = |
|
||||
! | 0 otherwise
|
||||
!
|
||||
! the diis error is defines as:
|
||||
! e = F_ao x Q x ao_overlap - ao_overlap x Q x F_ao
|
||||
! with:
|
||||
! mo_l_coef.T x ao_overlap x mo_r_coef = I
|
||||
! F_mo = mo_l_coef.T x F_ao x mo_r_coef
|
||||
! F_ao = (ao_overlap x mo_r_coef) x F_mo x (ao_overlap x mo_l_coef).T
|
||||
!
|
||||
! ==> e = 2 ao_overlap x mo_r_coef x [ F_mo x eta_occ - eta_occ x F_mo ] x (ao_overlap x mo_l_coef).T
|
||||
!
|
||||
! at convergence:
|
||||
! F_mo x eta_occ - eta_occ x F_mo = 0
|
||||
! ==> [F_mo]_ij ([eta_occ]_ii - [eta_occ]_jj) = 0
|
||||
! ==> [F_mo]_ia = [F_mo]_ai = 0 where: i = occ and a = vir
|
||||
! ==> Brillouin conditions
|
||||
!
|
||||
END_DOC
|
||||
|
||||
implicit none
|
||||
|
||||
if(elec_alpha_num == elec_beta_num) then
|
||||
Q_matrix = Q_alpha + Q_alpha
|
||||
else
|
||||
Q_matrix = Q_alpha + Q_beta
|
||||
endif
|
||||
|
||||
END_PROVIDER
|
||||
|
||||
! ---
|
||||
|
||||
BEGIN_PROVIDER [double precision, FQS_SQF_ao, (ao_num, ao_num)]
|
||||
|
||||
implicit none
|
||||
double precision, allocatable :: tmp(:,:)
|
||||
|
||||
allocate(tmp(ao_num,ao_num))
|
||||
|
||||
! F x Q
|
||||
call dgemm( 'N', 'N', ao_num, ao_num, ao_num, 1.d0 &
|
||||
, Fock_matrix_tc_ao_tot, size(Fock_matrix_tc_ao_tot, 1), Q_matrix, size(Q_matrix, 1) &
|
||||
, 0.d0, tmp, size(tmp, 1) )
|
||||
|
||||
! F x Q x S
|
||||
call dgemm( 'N', 'N', ao_num, ao_num, ao_num, 1.d0 &
|
||||
, tmp, size(tmp, 1), ao_overlap, size(ao_overlap, 1) &
|
||||
, 0.d0, FQS_SQF_ao, size(FQS_SQF_ao, 1) )
|
||||
|
||||
! S x Q
|
||||
tmp = 0.d0
|
||||
call dgemm( 'N', 'N', ao_num, ao_num, ao_num, 1.d0 &
|
||||
, ao_overlap, size(ao_overlap, 1), Q_matrix, size(Q_matrix, 1) &
|
||||
, 0.d0, tmp, size(tmp, 1) )
|
||||
|
||||
! F x Q x S - S x Q x F
|
||||
call dgemm( 'N', 'N', ao_num, ao_num, ao_num, -1.d0 &
|
||||
, tmp, size(tmp, 1), Fock_matrix_tc_ao_tot, size(Fock_matrix_tc_ao_tot, 1) &
|
||||
, 1.d0, FQS_SQF_ao, size(FQS_SQF_ao, 1) )
|
||||
|
||||
deallocate(tmp)
|
||||
|
||||
END_PROVIDER
|
||||
|
||||
! ---
|
||||
|
||||
BEGIN_PROVIDER [double precision, FQS_SQF_mo, (mo_num, mo_num)]
|
||||
|
||||
implicit none
|
||||
|
||||
call ao_to_mo_bi_ortho( FQS_SQF_ao, size(FQS_SQF_ao, 1) &
|
||||
, FQS_SQF_mo, size(FQS_SQF_mo, 1) )
|
||||
|
||||
END_PROVIDER
|
||||
|
||||
! ---
|
||||
|
||||
! BEGIN_PROVIDER [ double precision, eigenval_Fock_tc_ao, (ao_num) ]
|
||||
!&BEGIN_PROVIDER [ double precision, eigenvec_Fock_tc_ao, (ao_num,ao_num) ]
|
||||
!
|
||||
! BEGIN_DOC
|
||||
! !
|
||||
! ! Eigenvalues and eigenvectors of the Fock matrix over the ao basis
|
||||
! !
|
||||
! ! F' = X.T x F x X where X = ao_overlap^(-1/2)
|
||||
! !
|
||||
! ! F' x Cr' = Cr' x E ==> F Cr = Cr x E with Cr = X x Cr'
|
||||
! ! F'.T x Cl' = Cl' x E ==> F.T Cl = Cl x E with Cl = X x Cl'
|
||||
! !
|
||||
! END_DOC
|
||||
!
|
||||
! implicit none
|
||||
! double precision, allocatable :: tmp1(:,:), tmp2(:,:)
|
||||
!
|
||||
! ! ---
|
||||
! ! Fock matrix in orthogonal basis: F' = X.T x F x X
|
||||
!
|
||||
! allocate(tmp1(ao_num,ao_num))
|
||||
! call dgemm( 'N', 'N', ao_num, ao_num, ao_num, 1.d0 &
|
||||
! , Fock_matrix_tc_ao_tot, size(Fock_matrix_tc_ao_tot, 1), S_half_inv, size(S_half_inv, 1) &
|
||||
! , 0.d0, tmp1, size(tmp1, 1) )
|
||||
!
|
||||
! allocate(tmp2(ao_num,ao_num))
|
||||
! call dgemm( 'T', 'N', ao_num, ao_num, ao_num, 1.d0 &
|
||||
! , S_half_inv, size(S_half_inv, 1), tmp1, size(tmp1, 1) &
|
||||
! , 0.d0, tmp2, size(tmp2, 1) )
|
||||
!
|
||||
! ! ---
|
||||
!
|
||||
! ! Diagonalize F' to obtain eigenvectors in orthogonal basis C' and eigenvalues
|
||||
! ! TODO
|
||||
!
|
||||
! ! Back-transform eigenvectors: C =X.C'
|
||||
!
|
||||
!END_PROVIDER
|
||||
|
||||
! ---
|
||||
|
||||
~
|
405
src/tc_scf/fock_3e_bi_ortho_uhf.irp.f
Normal file
405
src/tc_scf/fock_3e_bi_ortho_uhf.irp.f
Normal file
|
@ -0,0 +1,405 @@
|
|||
|
||||
! ---
|
||||
|
||||
BEGIN_PROVIDER [double precision, fock_3e_uhf_mo_cs, (mo_num, mo_num)]
|
||||
|
||||
implicit none
|
||||
integer :: a, b, i, j
|
||||
double precision :: I_bij_aij, I_bij_ija, I_bij_jai, I_bij_aji, I_bij_iaj, I_bij_jia
|
||||
double precision :: ti, tf
|
||||
|
||||
PROVIDE mo_l_coef mo_r_coef
|
||||
|
||||
!print *, ' PROVIDING fock_3e_uhf_mo_cs ...'
|
||||
call wall_time(ti)
|
||||
|
||||
fock_3e_uhf_mo_cs = 0.d0
|
||||
|
||||
do a = 1, mo_num
|
||||
do b = 1, mo_num
|
||||
|
||||
do j = 1, elec_beta_num
|
||||
do i = 1, elec_beta_num
|
||||
|
||||
call give_integrals_3_body_bi_ort(b, i, j, a, i, j, I_bij_aij)
|
||||
call give_integrals_3_body_bi_ort(b, i, j, i, j, a, I_bij_ija)
|
||||
call give_integrals_3_body_bi_ort(b, i, j, j, a, i, I_bij_jai)
|
||||
call give_integrals_3_body_bi_ort(b, i, j, a, j, i, I_bij_aji)
|
||||
call give_integrals_3_body_bi_ort(b, i, j, i, a, j, I_bij_iaj)
|
||||
call give_integrals_3_body_bi_ort(b, i, j, j, i, a, I_bij_jia)
|
||||
|
||||
fock_3e_uhf_mo_cs(b,a) -= 0.5d0 * ( 4.d0 * I_bij_aij &
|
||||
+ I_bij_ija &
|
||||
+ I_bij_jai &
|
||||
- 2.d0 * I_bij_aji &
|
||||
- 2.d0 * I_bij_iaj &
|
||||
- 2.d0 * I_bij_jia )
|
||||
|
||||
enddo
|
||||
enddo
|
||||
enddo
|
||||
enddo
|
||||
|
||||
call wall_time(tf)
|
||||
!print *, ' total Wall time for fock_3e_uhf_mo_cs =', tf - ti
|
||||
|
||||
END_PROVIDER
|
||||
|
||||
! ---
|
||||
|
||||
BEGIN_PROVIDER [double precision, fock_3e_uhf_mo_a, (mo_num, mo_num)]
|
||||
|
||||
implicit none
|
||||
integer :: a, b, i, j, o
|
||||
double precision :: I_bij_aij, I_bij_ija, I_bij_jai, I_bij_aji, I_bij_iaj, I_bij_jia
|
||||
double precision :: ti, tf
|
||||
|
||||
PROVIDE mo_l_coef mo_r_coef
|
||||
|
||||
!print *, ' PROVIDING fock_3e_uhf_mo_a ...'
|
||||
call wall_time(ti)
|
||||
|
||||
o = elec_beta_num + 1
|
||||
|
||||
fock_3e_uhf_mo_a = fock_3e_uhf_mo_cs
|
||||
|
||||
do a = 1, mo_num
|
||||
do b = 1, mo_num
|
||||
|
||||
! ---
|
||||
|
||||
do j = o, elec_alpha_num
|
||||
do i = 1, elec_beta_num
|
||||
|
||||
call give_integrals_3_body_bi_ort(b, i, j, a, i, j, I_bij_aij)
|
||||
call give_integrals_3_body_bi_ort(b, i, j, i, j, a, I_bij_ija)
|
||||
call give_integrals_3_body_bi_ort(b, i, j, j, a, i, I_bij_jai)
|
||||
call give_integrals_3_body_bi_ort(b, i, j, a, j, i, I_bij_aji)
|
||||
call give_integrals_3_body_bi_ort(b, i, j, i, a, j, I_bij_iaj)
|
||||
call give_integrals_3_body_bi_ort(b, i, j, j, i, a, I_bij_jia)
|
||||
|
||||
fock_3e_uhf_mo_a(b,a) -= 0.5d0 * ( 2.d0 * I_bij_aij &
|
||||
+ I_bij_ija &
|
||||
+ I_bij_jai &
|
||||
- I_bij_aji &
|
||||
- I_bij_iaj &
|
||||
- 2.d0 * I_bij_jia )
|
||||
|
||||
enddo
|
||||
enddo
|
||||
|
||||
! ---
|
||||
|
||||
do j = 1, elec_beta_num
|
||||
do i = o, elec_alpha_num
|
||||
|
||||
call give_integrals_3_body_bi_ort(b, i, j, a, i, j, I_bij_aij)
|
||||
call give_integrals_3_body_bi_ort(b, i, j, i, j, a, I_bij_ija)
|
||||
call give_integrals_3_body_bi_ort(b, i, j, j, a, i, I_bij_jai)
|
||||
call give_integrals_3_body_bi_ort(b, i, j, a, j, i, I_bij_aji)
|
||||
call give_integrals_3_body_bi_ort(b, i, j, i, a, j, I_bij_iaj)
|
||||
call give_integrals_3_body_bi_ort(b, i, j, j, i, a, I_bij_jia)
|
||||
|
||||
fock_3e_uhf_mo_a(b,a) -= 0.5d0 * ( 2.d0 * I_bij_aij &
|
||||
+ I_bij_ija &
|
||||
+ I_bij_jai &
|
||||
- I_bij_aji &
|
||||
- 2.d0 * I_bij_iaj &
|
||||
- I_bij_jia )
|
||||
|
||||
enddo
|
||||
enddo
|
||||
|
||||
! ---
|
||||
|
||||
do j = o, elec_alpha_num
|
||||
do i = o, elec_alpha_num
|
||||
|
||||
call give_integrals_3_body_bi_ort(b, i, j, a, i, j, I_bij_aij)
|
||||
call give_integrals_3_body_bi_ort(b, i, j, i, j, a, I_bij_ija)
|
||||
call give_integrals_3_body_bi_ort(b, i, j, j, a, i, I_bij_jai)
|
||||
call give_integrals_3_body_bi_ort(b, i, j, a, j, i, I_bij_aji)
|
||||
call give_integrals_3_body_bi_ort(b, i, j, i, a, j, I_bij_iaj)
|
||||
call give_integrals_3_body_bi_ort(b, i, j, j, i, a, I_bij_jia)
|
||||
|
||||
fock_3e_uhf_mo_a(b,a) -= 0.5d0 * ( I_bij_aij &
|
||||
+ I_bij_ija &
|
||||
+ I_bij_jai &
|
||||
- I_bij_aji &
|
||||
- I_bij_iaj &
|
||||
- I_bij_jia )
|
||||
|
||||
enddo
|
||||
enddo
|
||||
|
||||
! ---
|
||||
|
||||
enddo
|
||||
enddo
|
||||
|
||||
call wall_time(tf)
|
||||
!print *, ' total Wall time for fock_3e_uhf_mo_a =', tf - ti
|
||||
|
||||
END_PROVIDER
|
||||
|
||||
! ---
|
||||
|
||||
BEGIN_PROVIDER [double precision, fock_3e_uhf_mo_b, (mo_num, mo_num)]
|
||||
|
||||
implicit none
|
||||
integer :: a, b, i, j, o
|
||||
double precision :: I_bij_aij, I_bij_ija, I_bij_jai, I_bij_aji, I_bij_iaj, I_bij_jia
|
||||
double precision :: ti, tf
|
||||
|
||||
PROVIDE mo_l_coef mo_r_coef
|
||||
|
||||
!print *, ' PROVIDING fock_3e_uhf_mo_b ...'
|
||||
call wall_time(ti)
|
||||
|
||||
o = elec_beta_num + 1
|
||||
|
||||
fock_3e_uhf_mo_b = fock_3e_uhf_mo_cs
|
||||
|
||||
do a = 1, mo_num
|
||||
do b = 1, mo_num
|
||||
|
||||
! ---
|
||||
|
||||
do j = o, elec_alpha_num
|
||||
do i = 1, elec_beta_num
|
||||
|
||||
call give_integrals_3_body_bi_ort(b, i, j, a, i, j, I_bij_aij)
|
||||
call give_integrals_3_body_bi_ort(b, i, j, i, j, a, I_bij_ija)
|
||||
call give_integrals_3_body_bi_ort(b, i, j, j, a, i, I_bij_jai)
|
||||
call give_integrals_3_body_bi_ort(b, i, j, a, j, i, I_bij_aji)
|
||||
call give_integrals_3_body_bi_ort(b, i, j, i, a, j, I_bij_iaj)
|
||||
call give_integrals_3_body_bi_ort(b, i, j, j, i, a, I_bij_jia)
|
||||
|
||||
fock_3e_uhf_mo_b(b,a) -= 0.5d0 * ( 2.d0 * I_bij_aij &
|
||||
- I_bij_aji &
|
||||
- I_bij_iaj )
|
||||
|
||||
enddo
|
||||
enddo
|
||||
|
||||
! ---
|
||||
|
||||
do j = 1, elec_beta_num
|
||||
do i = o, elec_alpha_num
|
||||
|
||||
call give_integrals_3_body_bi_ort(b, i, j, a, i, j, I_bij_aij)
|
||||
call give_integrals_3_body_bi_ort(b, i, j, i, j, a, I_bij_ija)
|
||||
call give_integrals_3_body_bi_ort(b, i, j, j, a, i, I_bij_jai)
|
||||
call give_integrals_3_body_bi_ort(b, i, j, a, j, i, I_bij_aji)
|
||||
call give_integrals_3_body_bi_ort(b, i, j, i, a, j, I_bij_iaj)
|
||||
call give_integrals_3_body_bi_ort(b, i, j, j, i, a, I_bij_jia)
|
||||
|
||||
fock_3e_uhf_mo_b(b,a) -= 0.5d0 * ( 2.d0 * I_bij_aij &
|
||||
- I_bij_aji &
|
||||
- I_bij_jia )
|
||||
|
||||
enddo
|
||||
enddo
|
||||
|
||||
! ---
|
||||
|
||||
do j = o, elec_alpha_num
|
||||
do i = o, elec_alpha_num
|
||||
|
||||
call give_integrals_3_body_bi_ort(b, i, j, a, i, j, I_bij_aij)
|
||||
call give_integrals_3_body_bi_ort(b, i, j, i, j, a, I_bij_ija)
|
||||
call give_integrals_3_body_bi_ort(b, i, j, j, a, i, I_bij_jai)
|
||||
call give_integrals_3_body_bi_ort(b, i, j, a, j, i, I_bij_aji)
|
||||
call give_integrals_3_body_bi_ort(b, i, j, i, a, j, I_bij_iaj)
|
||||
call give_integrals_3_body_bi_ort(b, i, j, j, i, a, I_bij_jia)
|
||||
|
||||
fock_3e_uhf_mo_b(b,a) -= 0.5d0 * ( I_bij_aij &
|
||||
- I_bij_aji )
|
||||
|
||||
enddo
|
||||
enddo
|
||||
|
||||
! ---
|
||||
|
||||
enddo
|
||||
enddo
|
||||
|
||||
call wall_time(tf)
|
||||
!print *, ' total Wall time for fock_3e_uhf_mo_b =', tf - ti
|
||||
|
||||
END_PROVIDER
|
||||
|
||||
! ---
|
||||
|
||||
BEGIN_PROVIDER [double precision, fock_3e_uhf_ao_a, (ao_num, ao_num)]
|
||||
|
||||
BEGIN_DOC
|
||||
!
|
||||
! Equations (B6) and (B7)
|
||||
!
|
||||
! g <--> gamma
|
||||
! d <--> delta
|
||||
! e <--> eta
|
||||
! k <--> kappa
|
||||
!
|
||||
END_DOC
|
||||
|
||||
implicit none
|
||||
integer :: g, d, e, k, mu, nu
|
||||
double precision :: dm_ge_a, dm_ge_b, dm_ge
|
||||
double precision :: dm_dk_a, dm_dk_b, dm_dk
|
||||
double precision :: i_mugd_nuek, i_mugd_eknu, i_mugd_knue, i_mugd_nuke, i_mugd_enuk, i_mugd_kenu
|
||||
double precision :: ti, tf
|
||||
double precision, allocatable :: f_tmp(:,:)
|
||||
|
||||
print *, ' PROVIDING fock_3e_uhf_ao_a ...'
|
||||
call wall_time(ti)
|
||||
|
||||
fock_3e_uhf_ao_a = 0.d0
|
||||
|
||||
!$OMP PARALLEL DEFAULT (NONE) &
|
||||
!$OMP PRIVATE (g, e, d, k, mu, nu, dm_ge_a, dm_ge_b, dm_ge, dm_dk_a, dm_dk_b, dm_dk, f_tmp, &
|
||||
!$OMP i_mugd_nuek, i_mugd_eknu, i_mugd_knue, i_mugd_nuke, i_mugd_enuk, i_mugd_kenu) &
|
||||
!$OMP SHARED (ao_num, TCSCF_bi_ort_dm_ao_alpha, TCSCF_bi_ort_dm_ao_beta, fock_3e_uhf_ao_a)
|
||||
|
||||
allocate(f_tmp(ao_num,ao_num))
|
||||
f_tmp = 0.d0
|
||||
|
||||
!$OMP DO
|
||||
do g = 1, ao_num
|
||||
do e = 1, ao_num
|
||||
dm_ge_a = TCSCF_bi_ort_dm_ao_alpha(g,e)
|
||||
dm_ge_b = TCSCF_bi_ort_dm_ao_beta (g,e)
|
||||
dm_ge = dm_ge_a + dm_ge_b
|
||||
do d = 1, ao_num
|
||||
do k = 1, ao_num
|
||||
dm_dk_a = TCSCF_bi_ort_dm_ao_alpha(d,k)
|
||||
dm_dk_b = TCSCF_bi_ort_dm_ao_beta (d,k)
|
||||
dm_dk = dm_dk_a + dm_dk_b
|
||||
do mu = 1, ao_num
|
||||
do nu = 1, ao_num
|
||||
call give_integrals_3_body_bi_ort_ao(mu, g, d, nu, e, k, i_mugd_nuek)
|
||||
call give_integrals_3_body_bi_ort_ao(mu, g, d, e, k, nu, i_mugd_eknu)
|
||||
call give_integrals_3_body_bi_ort_ao(mu, g, d, k, nu, e, i_mugd_knue)
|
||||
call give_integrals_3_body_bi_ort_ao(mu, g, d, nu, k, e, i_mugd_nuke)
|
||||
call give_integrals_3_body_bi_ort_ao(mu, g, d, e, nu, k, i_mugd_enuk)
|
||||
call give_integrals_3_body_bi_ort_ao(mu, g, d, k, e, nu, i_mugd_kenu)
|
||||
f_tmp(mu,nu) -= 0.5d0 * ( dm_ge * dm_dk * i_mugd_nuek &
|
||||
+ dm_ge_a * dm_dk_a * i_mugd_eknu &
|
||||
+ dm_ge_a * dm_dk_a * i_mugd_knue &
|
||||
- dm_ge_a * dm_dk * i_mugd_enuk &
|
||||
- dm_ge * dm_dk_a * i_mugd_kenu &
|
||||
- dm_ge_a * dm_dk_a * i_mugd_nuke &
|
||||
- dm_ge_b * dm_dk_b * i_mugd_nuke )
|
||||
enddo
|
||||
enddo
|
||||
enddo
|
||||
enddo
|
||||
enddo
|
||||
enddo
|
||||
!$OMP END DO NOWAIT
|
||||
|
||||
!$OMP CRITICAL
|
||||
do mu = 1, ao_num
|
||||
do nu = 1, ao_num
|
||||
fock_3e_uhf_ao_a(mu,nu) += f_tmp(mu,nu)
|
||||
enddo
|
||||
enddo
|
||||
!$OMP END CRITICAL
|
||||
|
||||
deallocate(f_tmp)
|
||||
!$OMP END PARALLEL
|
||||
|
||||
call wall_time(tf)
|
||||
print *, ' total Wall time for fock_3e_uhf_ao_a =', tf - ti
|
||||
|
||||
END_PROVIDER
|
||||
|
||||
! ---
|
||||
|
||||
BEGIN_PROVIDER [double precision, fock_3e_uhf_ao_b, (ao_num, ao_num)]
|
||||
|
||||
BEGIN_DOC
|
||||
!
|
||||
! Equations (B6) and (B7)
|
||||
!
|
||||
! g <--> gamma
|
||||
! d <--> delta
|
||||
! e <--> eta
|
||||
! k <--> kappa
|
||||
!
|
||||
END_DOC
|
||||
|
||||
implicit none
|
||||
integer :: g, d, e, k, mu, nu
|
||||
double precision :: dm_ge_a, dm_ge_b, dm_ge
|
||||
double precision :: dm_dk_a, dm_dk_b, dm_dk
|
||||
double precision :: i_mugd_nuek, i_mugd_eknu, i_mugd_knue, i_mugd_nuke, i_mugd_enuk, i_mugd_kenu
|
||||
double precision :: ti, tf
|
||||
double precision, allocatable :: f_tmp(:,:)
|
||||
|
||||
print *, ' PROVIDING fock_3e_uhf_ao_b ...'
|
||||
call wall_time(ti)
|
||||
|
||||
fock_3e_uhf_ao_b = 0.d0
|
||||
|
||||
!$OMP PARALLEL DEFAULT (NONE) &
|
||||
!$OMP PRIVATE (g, e, d, k, mu, nu, dm_ge_a, dm_ge_b, dm_ge, dm_dk_a, dm_dk_b, dm_dk, f_tmp, &
|
||||
!$OMP i_mugd_nuek, i_mugd_eknu, i_mugd_knue, i_mugd_nuke, i_mugd_enuk, i_mugd_kenu) &
|
||||
!$OMP SHARED (ao_num, TCSCF_bi_ort_dm_ao_alpha, TCSCF_bi_ort_dm_ao_beta, fock_3e_uhf_ao_b)
|
||||
|
||||
allocate(f_tmp(ao_num,ao_num))
|
||||
f_tmp = 0.d0
|
||||
|
||||
!$OMP DO
|
||||
do g = 1, ao_num
|
||||
do e = 1, ao_num
|
||||
dm_ge_a = TCSCF_bi_ort_dm_ao_alpha(g,e)
|
||||
dm_ge_b = TCSCF_bi_ort_dm_ao_beta (g,e)
|
||||
dm_ge = dm_ge_a + dm_ge_b
|
||||
do d = 1, ao_num
|
||||
do k = 1, ao_num
|
||||
dm_dk_a = TCSCF_bi_ort_dm_ao_alpha(d,k)
|
||||
dm_dk_b = TCSCF_bi_ort_dm_ao_beta (d,k)
|
||||
dm_dk = dm_dk_a + dm_dk_b
|
||||
do mu = 1, ao_num
|
||||
do nu = 1, ao_num
|
||||
call give_integrals_3_body_bi_ort_ao(mu, g, d, nu, e, k, i_mugd_nuek)
|
||||
call give_integrals_3_body_bi_ort_ao(mu, g, d, e, k, nu, i_mugd_eknu)
|
||||
call give_integrals_3_body_bi_ort_ao(mu, g, d, k, nu, e, i_mugd_knue)
|
||||
call give_integrals_3_body_bi_ort_ao(mu, g, d, nu, k, e, i_mugd_nuke)
|
||||
call give_integrals_3_body_bi_ort_ao(mu, g, d, e, nu, k, i_mugd_enuk)
|
||||
call give_integrals_3_body_bi_ort_ao(mu, g, d, k, e, nu, i_mugd_kenu)
|
||||
f_tmp(mu,nu) -= 0.5d0 * ( dm_ge * dm_dk * i_mugd_nuek &
|
||||
+ dm_ge_b * dm_dk_b * i_mugd_eknu &
|
||||
+ dm_ge_b * dm_dk_b * i_mugd_knue &
|
||||
- dm_ge_b * dm_dk * i_mugd_enuk &
|
||||
- dm_ge * dm_dk_b * i_mugd_kenu &
|
||||
- dm_ge_b * dm_dk_b * i_mugd_nuke &
|
||||
- dm_ge_a * dm_dk_a * i_mugd_nuke )
|
||||
enddo
|
||||
enddo
|
||||
enddo
|
||||
enddo
|
||||
enddo
|
||||
enddo
|
||||
!$OMP END DO NOWAIT
|
||||
|
||||
!$OMP CRITICAL
|
||||
do mu = 1, ao_num
|
||||
do nu = 1, ao_num
|
||||
fock_3e_uhf_ao_b(mu,nu) += f_tmp(mu,nu)
|
||||
enddo
|
||||
enddo
|
||||
!$OMP END CRITICAL
|
||||
|
||||
deallocate(f_tmp)
|
||||
!$OMP END PARALLEL
|
||||
|
||||
call wall_time(tf)
|
||||
print *, ' total Wall time for fock_3e_uhf_ao_b =', tf - ti
|
||||
|
||||
END_PROVIDER
|
||||
|
||||
! ---
|
||||
|
|
@ -1,63 +1,156 @@
|
|||
|
||||
! ---
|
||||
|
||||
BEGIN_PROVIDER [ double precision, two_e_tc_non_hermit_integral_alpha, (ao_num, ao_num)]
|
||||
&BEGIN_PROVIDER [ double precision, two_e_tc_non_hermit_integral_beta , (ao_num, ao_num)]
|
||||
BEGIN_DOC
|
||||
! two_e_tc_non_hermit_integral_alpha(k,i) = <k| F^tc_alpha |i>
|
||||
!
|
||||
! where F^tc is the two-body part of the TC Fock matrix and k,i are AO basis functions
|
||||
END_DOC
|
||||
BEGIN_PROVIDER [ double precision, two_e_tc_non_hermit_integral_seq_alpha, (ao_num, ao_num)]
|
||||
&BEGIN_PROVIDER [ double precision, two_e_tc_non_hermit_integral_seq_beta , (ao_num, ao_num)]
|
||||
|
||||
BEGIN_DOC
|
||||
!
|
||||
! two_e_tc_non_hermit_integral_seq_alpha(k,i) = <k| F^tc_alpha |i>
|
||||
!
|
||||
! where F^tc is the two-body part of the TC Fock matrix and k,i are AO basis functions
|
||||
!
|
||||
END_DOC
|
||||
|
||||
implicit none
|
||||
integer :: i, j, k, l
|
||||
double precision :: density, density_a, density_b
|
||||
double precision :: t0, t1
|
||||
|
||||
two_e_tc_non_hermit_integral_alpha = 0.d0
|
||||
two_e_tc_non_hermit_integral_beta = 0.d0
|
||||
!print*, ' providing two_e_tc_non_hermit_integral_seq ...'
|
||||
!call wall_time(t0)
|
||||
|
||||
two_e_tc_non_hermit_integral_seq_alpha = 0.d0
|
||||
two_e_tc_non_hermit_integral_seq_beta = 0.d0
|
||||
|
||||
!! TODO :: parallelization properly done
|
||||
do i = 1, ao_num
|
||||
do k = 1, ao_num
|
||||
!!$OMP PARALLEL &
|
||||
!!$OMP DEFAULT (NONE) &
|
||||
!!$OMP PRIVATE (j,l,density_a,density_b,density) &
|
||||
!!$OMP SHARED (i,k,ao_num,SCF_density_matrix_ao_alpha,SCF_density_matrix_ao_beta,ao_non_hermit_term_chemist) &
|
||||
!!$OMP SHARED (two_e_tc_non_hermit_integral_alpha,two_e_tc_non_hermit_integral_beta)
|
||||
!!$OMP DO SCHEDULE (dynamic)
|
||||
do j = 1, ao_num
|
||||
do l = 1, ao_num
|
||||
|
||||
density_a = TCSCF_density_matrix_ao_alpha(l,j)
|
||||
density_b = TCSCF_density_matrix_ao_beta (l,j)
|
||||
density = density_a + density_b
|
||||
density = density_a + density_b
|
||||
|
||||
!! rho(l,j) * < k l| T | i j>
|
||||
!two_e_tc_non_hermit_integral_seq_alpha(k,i) += density * ao_two_e_tc_tot(l,j,k,i)
|
||||
!! rho(l,j) * < k l| T | i j>
|
||||
!two_e_tc_non_hermit_integral_seq_beta (k,i) += density * ao_two_e_tc_tot(l,j,k,i)
|
||||
!! rho_a(l,j) * < l k| T | i j>
|
||||
!two_e_tc_non_hermit_integral_seq_alpha(k,i) -= density_a * ao_two_e_tc_tot(k,j,l,i)
|
||||
!! rho_b(l,j) * < l k| T | i j>
|
||||
!two_e_tc_non_hermit_integral_seq_beta (k,i) -= density_b * ao_two_e_tc_tot(k,j,l,i)
|
||||
|
||||
!! rho(l,j) * < k l| T | i j>
|
||||
!two_e_tc_non_hermit_integral_alpha(k,i) += density * ao_two_e_tc_tot(l,j,k,i)
|
||||
!! rho(l,j) * < k l| T | i j>
|
||||
!two_e_tc_non_hermit_integral_beta (k,i) += density * ao_two_e_tc_tot(l,j,k,i)
|
||||
!! rho_a(l,j) * < l k| T | i j>
|
||||
!two_e_tc_non_hermit_integral_alpha(k,i) -= density_a * ao_two_e_tc_tot(k,j,l,i)
|
||||
!! rho_b(l,j) * < l k| T | i j>
|
||||
!two_e_tc_non_hermit_integral_beta (k,i) -= density_b * ao_two_e_tc_tot(k,j,l,i)
|
||||
|
||||
! rho(l,j) * < k l| T | i j>
|
||||
two_e_tc_non_hermit_integral_alpha(k,i) += density * ao_two_e_tc_tot(l,j,k,i)
|
||||
two_e_tc_non_hermit_integral_seq_alpha(k,i) += density * ao_two_e_tc_tot(k,i,l,j)
|
||||
! rho(l,j) * < k l| T | i j>
|
||||
two_e_tc_non_hermit_integral_beta (k,i) += density * ao_two_e_tc_tot(l,j,k,i)
|
||||
! rho_a(l,j) * < l k| T | i j>
|
||||
two_e_tc_non_hermit_integral_alpha(k,i) -= density_a * ao_two_e_tc_tot(k,j,l,i)
|
||||
! rho_b(l,j) * < l k| T | i j>
|
||||
two_e_tc_non_hermit_integral_beta (k,i) -= density_b * ao_two_e_tc_tot(k,j,l,i)
|
||||
two_e_tc_non_hermit_integral_seq_beta (k,i) += density * ao_two_e_tc_tot(k,i,l,j)
|
||||
! rho_a(l,j) * < k l| T | j i>
|
||||
two_e_tc_non_hermit_integral_seq_alpha(k,i) -= density_a * ao_two_e_tc_tot(k,j,l,i)
|
||||
! rho_b(l,j) * < k l| T | j i>
|
||||
two_e_tc_non_hermit_integral_seq_beta (k,i) -= density_b * ao_two_e_tc_tot(k,j,l,i)
|
||||
|
||||
enddo
|
||||
enddo
|
||||
!!$OMP END DO
|
||||
!!$OMP END PARALLEL
|
||||
enddo
|
||||
enddo
|
||||
|
||||
!call wall_time(t1)
|
||||
!print*, ' wall time for two_e_tc_non_hermit_integral_seq after = ', t1 - t0
|
||||
|
||||
END_PROVIDER
|
||||
|
||||
! ---
|
||||
|
||||
BEGIN_PROVIDER [ double precision, two_e_tc_non_hermit_integral_alpha, (ao_num, ao_num)]
|
||||
&BEGIN_PROVIDER [ double precision, two_e_tc_non_hermit_integral_beta , (ao_num, ao_num)]
|
||||
|
||||
BEGIN_DOC
|
||||
!
|
||||
! two_e_tc_non_hermit_integral_alpha(k,i) = <k| F^tc_alpha |i>
|
||||
!
|
||||
! where F^tc is the two-body part of the TC Fock matrix and k,i are AO basis functions
|
||||
!
|
||||
END_DOC
|
||||
|
||||
implicit none
|
||||
integer :: i, j, k, l
|
||||
double precision :: density, density_a, density_b, I_coul, I_kjli
|
||||
double precision :: t0, t1
|
||||
double precision, allocatable :: tmp_a(:,:), tmp_b(:,:)
|
||||
|
||||
!print*, ' providing two_e_tc_non_hermit_integral ...'
|
||||
!call wall_time(t0)
|
||||
|
||||
two_e_tc_non_hermit_integral_alpha = 0.d0
|
||||
two_e_tc_non_hermit_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_tc_tot, &
|
||||
!$OMP two_e_tc_non_hermit_integral_alpha, two_e_tc_non_hermit_integral_beta)
|
||||
|
||||
allocate(tmp_a(ao_num,ao_num), tmp_b(ao_num,ao_num))
|
||||
tmp_a = 0.d0
|
||||
tmp_b = 0.d0
|
||||
|
||||
!$OMP DO
|
||||
do j = 1, ao_num
|
||||
do l = 1, ao_num
|
||||
density_a = TCSCF_density_matrix_ao_alpha(l,j)
|
||||
density_b = TCSCF_density_matrix_ao_beta (l,j)
|
||||
density = density_a + density_b
|
||||
do i = 1, ao_num
|
||||
do k = 1, ao_num
|
||||
|
||||
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
|
||||
enddo
|
||||
enddo
|
||||
enddo
|
||||
enddo
|
||||
!$OMP END DO NOWAIT
|
||||
|
||||
!$OMP CRITICAL
|
||||
do i = 1, ao_num
|
||||
do j = 1, ao_num
|
||||
two_e_tc_non_hermit_integral_alpha(j,i) += tmp_a(j,i)
|
||||
two_e_tc_non_hermit_integral_beta (j,i) += tmp_b(j,i)
|
||||
enddo
|
||||
enddo
|
||||
!$OMP END CRITICAL
|
||||
|
||||
deallocate(tmp_a, tmp_b)
|
||||
!$OMP END PARALLEL
|
||||
|
||||
!call wall_time(t1)
|
||||
!print*, ' wall time for two_e_tc_non_hermit_integral after = ', t1 - t0
|
||||
|
||||
END_PROVIDER
|
||||
|
||||
! ---
|
||||
|
||||
BEGIN_PROVIDER [ double precision, Fock_matrix_tc_ao_alpha, (ao_num, ao_num)]
|
||||
implicit none
|
||||
|
||||
BEGIN_DOC
|
||||
! Total alpha TC Fock matrix : h_c + Two-e^TC terms on the AO basis
|
||||
! Total alpha TC Fock matrix : h_c + Two-e^TC terms on the AO basis
|
||||
END_DOC
|
||||
Fock_matrix_tc_ao_alpha = ao_one_e_integrals_tc_tot &
|
||||
+ two_e_tc_non_hermit_integral_alpha
|
||||
|
||||
implicit none
|
||||
|
||||
Fock_matrix_tc_ao_alpha = ao_one_e_integrals_tc_tot + two_e_tc_non_hermit_integral_alpha
|
||||
|
||||
END_PROVIDER
|
||||
|
||||
|
@ -66,102 +159,149 @@ END_PROVIDER
|
|||
BEGIN_PROVIDER [ double precision, Fock_matrix_tc_ao_beta, (ao_num, ao_num)]
|
||||
|
||||
BEGIN_DOC
|
||||
! Total beta TC Fock matrix : h_c + Two-e^TC terms on the AO basis
|
||||
! Total beta TC Fock matrix : h_c + Two-e^TC terms on the AO basis
|
||||
END_DOC
|
||||
|
||||
implicit none
|
||||
|
||||
Fock_matrix_tc_ao_beta = ao_one_e_integrals_tc_tot &
|
||||
+ two_e_tc_non_hermit_integral_beta
|
||||
Fock_matrix_tc_ao_beta = ao_one_e_integrals_tc_tot + two_e_tc_non_hermit_integral_beta
|
||||
|
||||
END_PROVIDER
|
||||
! ---
|
||||
|
||||
!BEGIN_PROVIDER [ double precision, Fock_matrix_tc_ao_tot, (ao_num, ao_num) ]
|
||||
! implicit none
|
||||
! BEGIN_DOC
|
||||
! ! Total alpha+beta TC Fock matrix : h_c + Two-e^TC terms on the AO basis
|
||||
! END_DOC
|
||||
! Fock_matrix_tc_ao_tot = 0.5d0 * (Fock_matrix_tc_ao_alpha + Fock_matrix_tc_ao_beta)
|
||||
!END_PROVIDER
|
||||
|
||||
! ---
|
||||
|
||||
BEGIN_PROVIDER [ double precision, Fock_matrix_tc_mo_alpha, (mo_num, mo_num) ]
|
||||
implicit none
|
||||
|
||||
BEGIN_DOC
|
||||
! Total alpha TC Fock matrix : h_c + Two-e^TC terms on the MO basis
|
||||
! Total alpha TC Fock matrix : h_c + Two-e^TC terms on the MO basis
|
||||
END_DOC
|
||||
if(bi_ortho)then
|
||||
call ao_to_mo_bi_ortho( Fock_matrix_tc_ao_alpha, size(Fock_matrix_tc_ao_alpha, 1) &
|
||||
, Fock_matrix_tc_mo_alpha, size(Fock_matrix_tc_mo_alpha, 1) )
|
||||
if(three_body_h_tc)then
|
||||
Fock_matrix_tc_mo_alpha += fock_a_tot_3e_bi_orth
|
||||
endif
|
||||
|
||||
implicit none
|
||||
double precision, allocatable :: tmp(:,:)
|
||||
|
||||
if(bi_ortho) then
|
||||
|
||||
!allocate(tmp(ao_num,ao_num))
|
||||
!tmp = Fock_matrix_tc_ao_alpha
|
||||
!if(three_body_h_tc) then
|
||||
! tmp += fock_3e_uhf_ao_a
|
||||
!endif
|
||||
!call ao_to_mo_bi_ortho(tmp, size(tmp, 1), Fock_matrix_tc_mo_alpha, size(Fock_matrix_tc_mo_alpha, 1))
|
||||
!deallocate(tmp)
|
||||
|
||||
call ao_to_mo_bi_ortho( Fock_matrix_tc_ao_alpha, size(Fock_matrix_tc_ao_alpha, 1) &
|
||||
, Fock_matrix_tc_mo_alpha, size(Fock_matrix_tc_mo_alpha, 1) )
|
||||
if(three_body_h_tc) then
|
||||
!Fock_matrix_tc_mo_alpha += fock_a_tot_3e_bi_orth
|
||||
Fock_matrix_tc_mo_alpha += fock_3e_uhf_mo_a
|
||||
endif
|
||||
|
||||
else
|
||||
call ao_to_mo( Fock_matrix_tc_ao_alpha, size(Fock_matrix_tc_ao_alpha, 1) &
|
||||
call ao_to_mo( Fock_matrix_tc_ao_alpha, size(Fock_matrix_tc_ao_alpha, 1) &
|
||||
, Fock_matrix_tc_mo_alpha, size(Fock_matrix_tc_mo_alpha, 1) )
|
||||
|
||||
endif
|
||||
|
||||
END_PROVIDER
|
||||
|
||||
! ---
|
||||
|
||||
BEGIN_PROVIDER [ double precision, Fock_matrix_tc_mo_beta, (mo_num,mo_num) ]
|
||||
implicit none
|
||||
|
||||
BEGIN_DOC
|
||||
! Total beta TC Fock matrix : h_c + Two-e^TC terms on the MO basis
|
||||
! Total beta TC Fock matrix : h_c + Two-e^TC terms on the MO basis
|
||||
END_DOC
|
||||
if(bi_ortho)then
|
||||
call ao_to_mo_bi_ortho( Fock_matrix_tc_ao_beta, size(Fock_matrix_tc_ao_beta, 1) &
|
||||
, Fock_matrix_tc_mo_beta, size(Fock_matrix_tc_mo_beta, 1) )
|
||||
if(three_body_h_tc)then
|
||||
Fock_matrix_tc_mo_beta += fock_b_tot_3e_bi_orth
|
||||
endif
|
||||
|
||||
implicit none
|
||||
double precision, allocatable :: tmp(:,:)
|
||||
|
||||
if(bi_ortho) then
|
||||
|
||||
!allocate(tmp(ao_num,ao_num))
|
||||
!tmp = Fock_matrix_tc_ao_beta
|
||||
!if(three_body_h_tc) then
|
||||
! tmp += fock_3e_uhf_ao_b
|
||||
!endif
|
||||
!call ao_to_mo_bi_ortho(tmp, size(tmp, 1), Fock_matrix_tc_mo_beta, size(Fock_matrix_tc_mo_beta, 1))
|
||||
!deallocate(tmp)
|
||||
|
||||
call ao_to_mo_bi_ortho( Fock_matrix_tc_ao_beta, size(Fock_matrix_tc_ao_beta, 1) &
|
||||
, Fock_matrix_tc_mo_beta, size(Fock_matrix_tc_mo_beta, 1) )
|
||||
if(three_body_h_tc) then
|
||||
!Fock_matrix_tc_mo_beta += fock_b_tot_3e_bi_orth
|
||||
Fock_matrix_tc_mo_beta += fock_3e_uhf_mo_b
|
||||
endif
|
||||
|
||||
else
|
||||
call ao_to_mo( Fock_matrix_tc_ao_beta, size(Fock_matrix_tc_ao_beta, 1) &
|
||||
|
||||
call ao_to_mo( Fock_matrix_tc_ao_beta, size(Fock_matrix_tc_ao_beta, 1) &
|
||||
, Fock_matrix_tc_mo_beta, size(Fock_matrix_tc_mo_beta, 1) )
|
||||
|
||||
endif
|
||||
|
||||
END_PROVIDER
|
||||
|
||||
! ---
|
||||
|
||||
!BEGIN_PROVIDER [ double precision, Fock_matrix_tc_mo_tot, (mo_num, mo_num)]
|
||||
! implicit none
|
||||
! BEGIN_DOC
|
||||
! ! Total alpha+beta TC Fock matrix : h_c + Two-e^TC terms on the MO basis
|
||||
! END_DOC
|
||||
! Fock_matrix_tc_mo_tot = 0.5d0 * (Fock_matrix_tc_mo_alpha + Fock_matrix_tc_mo_beta)
|
||||
! if(three_body_h_tc) then
|
||||
! Fock_matrix_tc_mo_tot += fock_3_mat
|
||||
! endif
|
||||
! !call restore_symmetry(mo_num, mo_num, Fock_matrix_tc_mo_tot, mo_num, 1.d-10)
|
||||
!END_PROVIDER
|
||||
|
||||
! ---
|
||||
|
||||
BEGIN_PROVIDER [ double precision, grad_non_hermit_left]
|
||||
&BEGIN_PROVIDER [ double precision, grad_non_hermit_right]
|
||||
&BEGIN_PROVIDER [ double precision, grad_non_hermit]
|
||||
implicit none
|
||||
|
||||
implicit none
|
||||
integer :: i, k
|
||||
grad_non_hermit_left = 0.d0
|
||||
|
||||
grad_non_hermit_left = 0.d0
|
||||
grad_non_hermit_right = 0.d0
|
||||
|
||||
do i = 1, elec_beta_num ! doc --> SOMO
|
||||
do k = elec_beta_num+1, elec_alpha_num
|
||||
grad_non_hermit_left+= dabs(Fock_matrix_tc_mo_tot(k,i))
|
||||
grad_non_hermit_right+= dabs(Fock_matrix_tc_mo_tot(i,k))
|
||||
grad_non_hermit_left = max(grad_non_hermit_left , dabs(Fock_matrix_tc_mo_tot(k,i)))
|
||||
grad_non_hermit_right = max(grad_non_hermit_right, dabs(Fock_matrix_tc_mo_tot(i,k)))
|
||||
!grad_non_hermit_left += dabs(Fock_matrix_tc_mo_tot(k,i))
|
||||
!grad_non_hermit_right += dabs(Fock_matrix_tc_mo_tot(i,k))
|
||||
!grad_non_hermit_left += Fock_matrix_tc_mo_tot(k,i) * Fock_matrix_tc_mo_tot(k,i)
|
||||
!grad_non_hermit_right += Fock_matrix_tc_mo_tot(i,k) * Fock_matrix_tc_mo_tot(i,k)
|
||||
enddo
|
||||
enddo
|
||||
|
||||
do i = 1, elec_beta_num ! doc --> virt
|
||||
do k = elec_alpha_num+1, mo_num
|
||||
grad_non_hermit_left+= dabs(Fock_matrix_tc_mo_tot(k,i))
|
||||
grad_non_hermit_right+= dabs(Fock_matrix_tc_mo_tot(i,k))
|
||||
grad_non_hermit_left = max(grad_non_hermit_left , dabs(Fock_matrix_tc_mo_tot(k,i)))
|
||||
grad_non_hermit_right = max(grad_non_hermit_right, dabs(Fock_matrix_tc_mo_tot(i,k)))
|
||||
!grad_non_hermit_left += dabs(Fock_matrix_tc_mo_tot(k,i))
|
||||
!grad_non_hermit_right += dabs(Fock_matrix_tc_mo_tot(i,k))
|
||||
grad_non_hermit_left += Fock_matrix_tc_mo_tot(k,i) * Fock_matrix_tc_mo_tot(k,i)
|
||||
grad_non_hermit_right += Fock_matrix_tc_mo_tot(i,k) * Fock_matrix_tc_mo_tot(i,k)
|
||||
enddo
|
||||
enddo
|
||||
|
||||
do i = elec_beta_num+1, elec_alpha_num ! SOMO --> virt
|
||||
do k = elec_alpha_num+1, mo_num
|
||||
grad_non_hermit_left+= dabs(Fock_matrix_tc_mo_tot(k,i))
|
||||
grad_non_hermit_right+= dabs(Fock_matrix_tc_mo_tot(i,k))
|
||||
grad_non_hermit_left = max(grad_non_hermit_left , dabs(Fock_matrix_tc_mo_tot(k,i)))
|
||||
grad_non_hermit_right = max(grad_non_hermit_right, dabs(Fock_matrix_tc_mo_tot(i,k)))
|
||||
!grad_non_hermit_left += dabs(Fock_matrix_tc_mo_tot(k,i))
|
||||
!grad_non_hermit_right += dabs(Fock_matrix_tc_mo_tot(i,k))
|
||||
grad_non_hermit_left += Fock_matrix_tc_mo_tot(k,i) * Fock_matrix_tc_mo_tot(k,i)
|
||||
grad_non_hermit_right += Fock_matrix_tc_mo_tot(i,k) * Fock_matrix_tc_mo_tot(i,k)
|
||||
enddo
|
||||
enddo
|
||||
grad_non_hermit = grad_non_hermit_left + grad_non_hermit_right
|
||||
|
||||
!grad_non_hermit = dsqrt(grad_non_hermit_left) + dsqrt(grad_non_hermit_right)
|
||||
grad_non_hermit = grad_non_hermit_left + grad_non_hermit_right
|
||||
|
||||
END_PROVIDER
|
||||
|
||||
! ---
|
||||
|
||||
BEGIN_PROVIDER [ double precision, Fock_matrix_tc_ao_tot, (ao_num, ao_num) ]
|
||||
|
||||
implicit none
|
||||
|
||||
call mo_to_ao_bi_ortho( Fock_matrix_tc_mo_tot, size(Fock_matrix_tc_mo_tot, 1) &
|
||||
, Fock_matrix_tc_ao_tot, size(Fock_matrix_tc_ao_tot, 1) )
|
||||
|
||||
END_PROVIDER
|
||||
|
||||
! ---
|
||||
|
||||
|
||||
|
|
|
@ -73,6 +73,29 @@
|
|||
+ (Fock_matrix_tc_mo_beta(i,j) - Fock_matrix_tc_mo_alpha(i,j))
|
||||
enddo
|
||||
enddo
|
||||
if(three_body_h_tc)then
|
||||
! C-O
|
||||
do j = 1, elec_beta_num
|
||||
do i = elec_beta_num+1, elec_alpha_num
|
||||
Fock_matrix_tc_mo_tot(i,j) += 0.5d0*(fock_a_tot_3e_bi_orth(i,j) + fock_b_tot_3e_bi_orth(i,j))
|
||||
Fock_matrix_tc_mo_tot(j,i) += 0.5d0*(fock_a_tot_3e_bi_orth(j,i) + fock_b_tot_3e_bi_orth(j,i))
|
||||
enddo
|
||||
enddo
|
||||
! C-V
|
||||
do j = 1, elec_beta_num
|
||||
do i = elec_alpha_num+1, mo_num
|
||||
Fock_matrix_tc_mo_tot(i,j) += 0.5d0*(fock_a_tot_3e_bi_orth(i,j) + fock_b_tot_3e_bi_orth(i,j))
|
||||
Fock_matrix_tc_mo_tot(j,i) += 0.5d0*(fock_a_tot_3e_bi_orth(j,i) + fock_b_tot_3e_bi_orth(j,i))
|
||||
enddo
|
||||
enddo
|
||||
! O-V
|
||||
do j = elec_beta_num+1, elec_alpha_num
|
||||
do i = elec_alpha_num+1, mo_num
|
||||
Fock_matrix_tc_mo_tot(i,j) += 0.5d0*(fock_a_tot_3e_bi_orth(i,j) + fock_b_tot_3e_bi_orth(i,j))
|
||||
Fock_matrix_tc_mo_tot(j,i) += 0.5d0*(fock_a_tot_3e_bi_orth(j,i) + fock_b_tot_3e_bi_orth(j,i))
|
||||
enddo
|
||||
enddo
|
||||
endif
|
||||
|
||||
endif
|
||||
|
||||
|
|
|
@ -70,52 +70,76 @@ subroutine give_fock_ia_three_e_total(i,a,contrib)
|
|||
|
||||
end
|
||||
|
||||
! ---
|
||||
|
||||
BEGIN_PROVIDER [double precision, diag_three_elem_hf]
|
||||
implicit none
|
||||
integer :: i,j,k,ipoint,mm
|
||||
double precision :: contrib,weight,four_third,one_third,two_third,exchange_int_231
|
||||
print*,'providing diag_three_elem_hf'
|
||||
if(.not.three_body_h_tc)then
|
||||
diag_three_elem_hf = 0.d0
|
||||
else
|
||||
if(.not.bi_ortho)then
|
||||
one_third = 1.d0/3.d0
|
||||
two_third = 2.d0/3.d0
|
||||
four_third = 4.d0/3.d0
|
||||
diag_three_elem_hf = 0.d0
|
||||
do i = 1, elec_beta_num
|
||||
do j = 1, elec_beta_num
|
||||
do k = 1, elec_beta_num
|
||||
call give_integrals_3_body(k,j,i,j,i,k,exchange_int_231)
|
||||
diag_three_elem_hf += two_third * exchange_int_231
|
||||
enddo
|
||||
enddo
|
||||
enddo
|
||||
do mm = 1, 3
|
||||
do ipoint = 1, n_points_final_grid
|
||||
weight = final_weight_at_r_vector(ipoint)
|
||||
contrib = 3.d0 * fock_3_w_kk_sum(ipoint,mm) * fock_3_rho_beta(ipoint) * fock_3_w_kk_sum(ipoint,mm) &
|
||||
-2.d0 * fock_3_w_kl_mo_k_mo_l(ipoint,mm) * fock_3_w_kk_sum(ipoint,mm) &
|
||||
-1.d0 * fock_3_rho_beta(ipoint) * fock_3_w_kl_w_kl(ipoint,mm)
|
||||
contrib *= four_third
|
||||
contrib += -two_third * fock_3_rho_beta(ipoint) * fock_3_w_kl_w_kl(ipoint,mm) &
|
||||
- four_third * fock_3_w_kk_sum(ipoint,mm) * fock_3_w_kl_mo_k_mo_l(ipoint,mm)
|
||||
diag_three_elem_hf += weight * contrib
|
||||
enddo
|
||||
enddo
|
||||
diag_three_elem_hf = - diag_three_elem_hf
|
||||
|
||||
implicit none
|
||||
integer :: i, j, k, ipoint, mm
|
||||
double precision :: contrib, weight, four_third, one_third, two_third, exchange_int_231
|
||||
double precision :: integral_aaa, hthree, integral_aab, integral_abb, integral_bbb
|
||||
|
||||
PROVIDE mo_l_coef mo_r_coef
|
||||
|
||||
!print *, ' providing diag_three_elem_hf'
|
||||
|
||||
if(.not. three_body_h_tc) then
|
||||
|
||||
diag_three_elem_hf = 0.d0
|
||||
|
||||
else
|
||||
double precision :: integral_aaa,hthree, integral_aab,integral_abb,integral_bbb
|
||||
provide mo_l_coef mo_r_coef
|
||||
call give_aaa_contrib(integral_aaa)
|
||||
call give_aab_contrib(integral_aab)
|
||||
call give_abb_contrib(integral_abb)
|
||||
call give_bbb_contrib(integral_bbb)
|
||||
diag_three_elem_hf = integral_aaa + integral_aab + integral_abb + integral_bbb
|
||||
|
||||
if(.not. bi_ortho) then
|
||||
|
||||
! ---
|
||||
|
||||
one_third = 1.d0/3.d0
|
||||
two_third = 2.d0/3.d0
|
||||
four_third = 4.d0/3.d0
|
||||
diag_three_elem_hf = 0.d0
|
||||
do i = 1, elec_beta_num
|
||||
do j = 1, elec_beta_num
|
||||
do k = 1, elec_beta_num
|
||||
call give_integrals_3_body(k, j, i, j, i, k,exchange_int_231)
|
||||
diag_three_elem_hf += two_third * exchange_int_231
|
||||
enddo
|
||||
enddo
|
||||
enddo
|
||||
do mm = 1, 3
|
||||
do ipoint = 1, n_points_final_grid
|
||||
weight = final_weight_at_r_vector(ipoint)
|
||||
contrib = 3.d0 * fock_3_w_kk_sum(ipoint,mm) * fock_3_rho_beta(ipoint) * fock_3_w_kk_sum(ipoint,mm) &
|
||||
- 2.d0 * fock_3_w_kl_mo_k_mo_l(ipoint,mm) * fock_3_w_kk_sum(ipoint,mm) &
|
||||
- 1.d0 * fock_3_rho_beta(ipoint) * fock_3_w_kl_w_kl(ipoint,mm)
|
||||
contrib *= four_third
|
||||
contrib += -two_third * fock_3_rho_beta(ipoint) * fock_3_w_kl_w_kl(ipoint,mm) &
|
||||
-four_third * fock_3_w_kk_sum(ipoint,mm) * fock_3_w_kl_mo_k_mo_l(ipoint,mm)
|
||||
diag_three_elem_hf += weight * contrib
|
||||
enddo
|
||||
enddo
|
||||
|
||||
diag_three_elem_hf = - diag_three_elem_hf
|
||||
|
||||
! ---
|
||||
|
||||
else
|
||||
|
||||
provide mo_l_coef mo_r_coef
|
||||
call give_aaa_contrib(integral_aaa)
|
||||
call give_aab_contrib(integral_aab)
|
||||
call give_abb_contrib(integral_abb)
|
||||
call give_bbb_contrib(integral_bbb)
|
||||
diag_three_elem_hf = integral_aaa + integral_aab + integral_abb + integral_bbb
|
||||
! print*,'integral_aaa + integral_aab + integral_abb + integral_bbb'
|
||||
! print*,integral_aaa , integral_aab , integral_abb , integral_bbb
|
||||
|
||||
endif
|
||||
|
||||
endif
|
||||
endif
|
||||
|
||||
END_PROVIDER
|
||||
|
||||
! ---
|
||||
|
||||
BEGIN_PROVIDER [ double precision, fock_3_mat_a_op_sh, (mo_num, mo_num)]
|
||||
implicit none
|
||||
|
|
|
@ -1,202 +1,286 @@
|
|||
|
||||
! ---
|
||||
|
||||
BEGIN_PROVIDER [double precision, fock_a_tot_3e_bi_orth, (mo_num, mo_num)]
|
||||
implicit none
|
||||
integer :: i,a,j,k
|
||||
double precision :: contrib_sss, contrib_sos, contrib_soo,contrib
|
||||
fock_a_tot_3e_bi_orth = 0.d0
|
||||
do i = 1, mo_num
|
||||
do a = 1, mo_num
|
||||
fock_a_tot_3e_bi_orth(a,i) += fock_cs_3e_bi_orth(a,i)
|
||||
fock_a_tot_3e_bi_orth(a,i) += fock_a_tmp1_bi_ortho(a,i)
|
||||
fock_a_tot_3e_bi_orth(a,i) += fock_a_tmp2_bi_ortho(a,i)
|
||||
|
||||
implicit none
|
||||
integer :: i, a
|
||||
|
||||
PROVIDE mo_l_coef mo_r_coef
|
||||
|
||||
fock_a_tot_3e_bi_orth = 0.d0
|
||||
|
||||
do i = 1, mo_num
|
||||
do a = 1, mo_num
|
||||
fock_a_tot_3e_bi_orth(a,i) += fock_cs_3e_bi_orth (a,i)
|
||||
fock_a_tot_3e_bi_orth(a,i) += fock_a_tmp1_bi_ortho(a,i)
|
||||
fock_a_tot_3e_bi_orth(a,i) += fock_a_tmp2_bi_ortho(a,i)
|
||||
enddo
|
||||
enddo
|
||||
enddo
|
||||
|
||||
END_PROVIDER
|
||||
|
||||
! ---
|
||||
|
||||
BEGIN_PROVIDER [double precision, fock_b_tot_3e_bi_orth, (mo_num, mo_num)]
|
||||
implicit none
|
||||
integer :: i,a,j,k
|
||||
double precision :: contrib_sss, contrib_sos, contrib_soo,contrib
|
||||
fock_b_tot_3e_bi_orth = 0.d0
|
||||
do i = 1, mo_num
|
||||
do a = 1, mo_num
|
||||
fock_b_tot_3e_bi_orth(a,i) += fock_cs_3e_bi_orth(a,i)
|
||||
fock_b_tot_3e_bi_orth(a,i) += fock_b_tmp2_bi_ortho(a,i)
|
||||
fock_b_tot_3e_bi_orth(a,i) += fock_b_tmp1_bi_ortho(a,i)
|
||||
|
||||
implicit none
|
||||
integer :: i, a
|
||||
|
||||
PROVIDE mo_l_coef mo_r_coef
|
||||
|
||||
fock_b_tot_3e_bi_orth = 0.d0
|
||||
|
||||
do i = 1, mo_num
|
||||
do a = 1, mo_num
|
||||
fock_b_tot_3e_bi_orth(a,i) += fock_cs_3e_bi_orth (a,i)
|
||||
fock_b_tot_3e_bi_orth(a,i) += fock_b_tmp2_bi_ortho(a,i)
|
||||
fock_b_tot_3e_bi_orth(a,i) += fock_b_tmp1_bi_ortho(a,i)
|
||||
enddo
|
||||
enddo
|
||||
enddo
|
||||
|
||||
END_PROVIDER
|
||||
|
||||
! ---
|
||||
|
||||
BEGIN_PROVIDER [double precision, fock_cs_3e_bi_orth, (mo_num, mo_num)]
|
||||
implicit none
|
||||
integer :: i,a,j,k
|
||||
double precision :: contrib_sss, contrib_sos, contrib_soo, contrib
|
||||
double precision :: direct_int, exch_13_int, exch_23_int, exch_12_int, c_3_int, c_minus_3_int
|
||||
double precision :: new
|
||||
fock_cs_3e_bi_orth = 0.d0
|
||||
do i = 1, mo_num
|
||||
do a = 1, mo_num
|
||||
|
||||
do j = 1, elec_beta_num
|
||||
do k = 1, elec_beta_num
|
||||
! call contrib_3e_sss(a,i,j,k,contrib_sss)
|
||||
! call contrib_3e_soo(a,i,j,k,contrib_soo)
|
||||
! call contrib_3e_sos(a,i,j,k,contrib_sos)
|
||||
! contrib = 0.5d0 * (contrib_sss + contrib_soo) + contrib_sos
|
||||
|
||||
call give_integrals_3_body_bi_ort(a, k, j, i, k, j, direct_int )!!! < a k j | i k j >
|
||||
call give_integrals_3_body_bi_ort(a, k, j, j, i, k, c_3_int) ! < a k j | j i k >
|
||||
call give_integrals_3_body_bi_ort(a, k, j, k, j, i, c_minus_3_int)! < a k j | k j i >
|
||||
! negative terms :: exchange contrib
|
||||
call give_integrals_3_body_bi_ort(a, k, j, j, k, i, exch_13_int)!!! < a k j | j k i > : E_13
|
||||
call give_integrals_3_body_bi_ort(a, k, j, i, j, k, exch_23_int)!!! < a k j | i j k > : E_23
|
||||
call give_integrals_3_body_bi_ort(a, k, j, k, i, j, exch_12_int)!!! < a k j | k i j > : E_12
|
||||
new = 2.d0 * direct_int + 0.5d0 * (c_3_int + c_minus_3_int - exch_12_int) &
|
||||
-1.5d0 * exch_13_int - exch_23_int
|
||||
fock_cs_3e_bi_orth(a,i) += new
|
||||
implicit none
|
||||
integer :: i, a, j, k
|
||||
double precision :: contrib_sss, contrib_sos, contrib_soo, contrib
|
||||
double precision :: direct_int, exch_13_int, exch_23_int, exch_12_int, c_3_int, c_minus_3_int
|
||||
double precision :: new
|
||||
|
||||
PROVIDE mo_l_coef mo_r_coef
|
||||
|
||||
fock_cs_3e_bi_orth = 0.d0
|
||||
|
||||
do i = 1, mo_num
|
||||
do a = 1, mo_num
|
||||
|
||||
do j = 1, elec_beta_num
|
||||
do k = 1, elec_beta_num
|
||||
|
||||
!!call contrib_3e_sss(a,i,j,k,contrib_sss)
|
||||
!!call contrib_3e_soo(a,i,j,k,contrib_soo)
|
||||
!!call contrib_3e_sos(a,i,j,k,contrib_sos)
|
||||
!!contrib = 0.5d0 * (contrib_sss + contrib_soo) + contrib_sos
|
||||
|
||||
call give_integrals_3_body_bi_ort(a, k, j, i, k, j, direct_int )!!! < a k j | i k j >
|
||||
call give_integrals_3_body_bi_ort(a, k, j, j, i, k, c_3_int) ! < a k j | j i k >
|
||||
call give_integrals_3_body_bi_ort(a, k, j, k, j, i, c_minus_3_int)! < a k j | k j i >
|
||||
|
||||
! negative terms :: exchange contrib
|
||||
call give_integrals_3_body_bi_ort(a, k, j, j, k, i, exch_13_int)!!! < a k j | j k i > : E_13
|
||||
call give_integrals_3_body_bi_ort(a, k, j, i, j, k, exch_23_int)!!! < a k j | i j k > : E_23
|
||||
call give_integrals_3_body_bi_ort(a, k, j, k, i, j, exch_12_int)!!! < a k j | k i j > : E_12
|
||||
|
||||
new = 2.d0 * direct_int + 0.5d0 * (c_3_int + c_minus_3_int - exch_12_int) -1.5d0 * exch_13_int - exch_23_int
|
||||
|
||||
fock_cs_3e_bi_orth(a,i) += new
|
||||
enddo
|
||||
enddo
|
||||
enddo
|
||||
enddo
|
||||
|
||||
enddo
|
||||
enddo
|
||||
fock_cs_3e_bi_orth = - fock_cs_3e_bi_orth
|
||||
|
||||
fock_cs_3e_bi_orth = - fock_cs_3e_bi_orth
|
||||
|
||||
END_PROVIDER
|
||||
|
||||
! ---
|
||||
|
||||
BEGIN_PROVIDER [double precision, fock_a_tmp1_bi_ortho, (mo_num, mo_num)]
|
||||
implicit none
|
||||
integer :: i,a,j,k
|
||||
double precision :: contrib_sss, contrib_sos, contrib_soo, contrib
|
||||
double precision :: direct_int, exch_13_int, exch_23_int, exch_12_int, c_3_int, c_minus_3_int
|
||||
double precision :: new
|
||||
fock_a_tmp1_bi_ortho = 0.d0
|
||||
do i = 1, mo_num
|
||||
do a = 1, mo_num
|
||||
|
||||
do j = elec_beta_num + 1, elec_alpha_num
|
||||
do k = 1, elec_beta_num
|
||||
call give_integrals_3_body_bi_ort(a, k, j, i, k, j, direct_int )!!! < a k j | i k j >
|
||||
call give_integrals_3_body_bi_ort(a, k, j, j, i, k, c_3_int) ! < a k j | j i k >
|
||||
call give_integrals_3_body_bi_ort(a, k, j, k, j, i, c_minus_3_int)! < a k j | k j i >
|
||||
call give_integrals_3_body_bi_ort(a, k, j, j, k, i, exch_13_int)!!! < a k j | j k i > : E_13
|
||||
call give_integrals_3_body_bi_ort(a, k, j, i, j, k, exch_23_int)!!! < a k j | i j k > : E_23
|
||||
call give_integrals_3_body_bi_ort(a, k, j, k, i, j, exch_12_int)!!! < a k j | k i j > : E_12
|
||||
fock_a_tmp1_bi_ortho(a,i) += 1.5d0 * (direct_int - exch_13_int) &
|
||||
+ 0.5d0 * (c_3_int + c_minus_3_int - exch_23_int - exch_12_int)
|
||||
enddo
|
||||
enddo
|
||||
|
||||
implicit none
|
||||
integer :: i, a, j, k
|
||||
double precision :: contrib_sss, contrib_sos, contrib_soo, contrib
|
||||
double precision :: direct_int, exch_13_int, exch_23_int, exch_12_int, c_3_int, c_minus_3_int
|
||||
double precision :: new
|
||||
|
||||
PROVIDE mo_l_coef mo_r_coef
|
||||
|
||||
fock_a_tmp1_bi_ortho = 0.d0
|
||||
|
||||
do i = 1, mo_num
|
||||
do a = 1, mo_num
|
||||
|
||||
do j = elec_beta_num + 1, elec_alpha_num
|
||||
do k = 1, elec_beta_num
|
||||
call give_integrals_3_body_bi_ort(a, k, j, i, k, j, direct_int )!!! < a k j | i k j >
|
||||
call give_integrals_3_body_bi_ort(a, k, j, j, i, k, c_3_int) ! < a k j | j i k >
|
||||
call give_integrals_3_body_bi_ort(a, k, j, k, j, i, c_minus_3_int)! < a k j | k j i >
|
||||
call give_integrals_3_body_bi_ort(a, k, j, j, k, i, exch_13_int)!!! < a k j | j k i > : E_13
|
||||
call give_integrals_3_body_bi_ort(a, k, j, i, j, k, exch_23_int)!!! < a k j | i j k > : E_23
|
||||
call give_integrals_3_body_bi_ort(a, k, j, k, i, j, exch_12_int)!!! < a k j | k i j > : E_12
|
||||
|
||||
fock_a_tmp1_bi_ortho(a,i) += 1.5d0 * (direct_int - exch_13_int) + 0.5d0 * (c_3_int + c_minus_3_int - exch_23_int - exch_12_int)
|
||||
enddo
|
||||
enddo
|
||||
enddo
|
||||
enddo
|
||||
enddo
|
||||
fock_a_tmp1_bi_ortho = - fock_a_tmp1_bi_ortho
|
||||
|
||||
fock_a_tmp1_bi_ortho = - fock_a_tmp1_bi_ortho
|
||||
|
||||
END_PROVIDER
|
||||
|
||||
! ---
|
||||
|
||||
BEGIN_PROVIDER [double precision, fock_a_tmp2_bi_ortho, (mo_num, mo_num)]
|
||||
implicit none
|
||||
integer :: i,a,j,k
|
||||
double precision :: contrib_sss
|
||||
fock_a_tmp2_bi_ortho = 0.d0
|
||||
do i = 1, mo_num
|
||||
do a = 1, mo_num
|
||||
do j = 1, elec_alpha_num
|
||||
do k = elec_beta_num+1, elec_alpha_num
|
||||
call contrib_3e_sss(a,i,j,k,contrib_sss)
|
||||
fock_a_tmp2_bi_ortho(a,i) += 0.5d0 * contrib_sss
|
||||
|
||||
implicit none
|
||||
integer :: i, a, j, k
|
||||
double precision :: contrib_sss
|
||||
|
||||
PROVIDE mo_l_coef mo_r_coef
|
||||
|
||||
fock_a_tmp2_bi_ortho = 0.d0
|
||||
|
||||
do i = 1, mo_num
|
||||
do a = 1, mo_num
|
||||
do j = 1, elec_alpha_num
|
||||
do k = elec_beta_num+1, elec_alpha_num
|
||||
call contrib_3e_sss(a, i, j, k, contrib_sss)
|
||||
|
||||
fock_a_tmp2_bi_ortho(a,i) += 0.5d0 * contrib_sss
|
||||
enddo
|
||||
enddo
|
||||
enddo
|
||||
enddo
|
||||
enddo
|
||||
enddo
|
||||
|
||||
END_PROVIDER
|
||||
|
||||
|
||||
|
||||
|
||||
! ---
|
||||
|
||||
BEGIN_PROVIDER [double precision, fock_b_tmp1_bi_ortho, (mo_num, mo_num)]
|
||||
implicit none
|
||||
integer :: i,a,j,k
|
||||
double precision :: direct_int, exch_13_int, exch_23_int, exch_12_int
|
||||
double precision :: new
|
||||
fock_b_tmp1_bi_ortho = 0.d0
|
||||
do i = 1, mo_num
|
||||
do a = 1, mo_num
|
||||
|
||||
do j = 1, elec_beta_num
|
||||
do k = elec_beta_num+1, elec_alpha_num
|
||||
call give_integrals_3_body_bi_ort(a, k, j, i, k, j, direct_int )!!! < a k j | i k j >
|
||||
call give_integrals_3_body_bi_ort(a, k, j, j, k, i, exch_13_int)!!! < a k j | j k i > : E_13
|
||||
call give_integrals_3_body_bi_ort(a, k, j, i, j, k, exch_23_int)!!! < a k j | i j k > : E_23
|
||||
fock_b_tmp1_bi_ortho(a,i) += 1.5d0 * direct_int - 0.5d0 * exch_23_int - exch_13_int
|
||||
enddo
|
||||
enddo
|
||||
|
||||
implicit none
|
||||
integer :: i, a, j, k
|
||||
double precision :: direct_int, exch_13_int, exch_23_int, exch_12_int
|
||||
double precision :: new
|
||||
|
||||
PROVIDE mo_l_coef mo_r_coef
|
||||
|
||||
fock_b_tmp1_bi_ortho = 0.d0
|
||||
|
||||
do i = 1, mo_num
|
||||
do a = 1, mo_num
|
||||
do j = 1, elec_beta_num
|
||||
do k = elec_beta_num+1, elec_alpha_num
|
||||
call give_integrals_3_body_bi_ort(a, k, j, i, k, j, direct_int )!!! < a k j | i k j >
|
||||
call give_integrals_3_body_bi_ort(a, k, j, j, k, i, exch_13_int)!!! < a k j | j k i > : E_13
|
||||
call give_integrals_3_body_bi_ort(a, k, j, i, j, k, exch_23_int)!!! < a k j | i j k > : E_23
|
||||
|
||||
fock_b_tmp1_bi_ortho(a,i) += 1.5d0 * direct_int - 0.5d0 * exch_23_int - exch_13_int
|
||||
enddo
|
||||
enddo
|
||||
enddo
|
||||
enddo
|
||||
enddo
|
||||
fock_b_tmp1_bi_ortho = - fock_b_tmp1_bi_ortho
|
||||
|
||||
fock_b_tmp1_bi_ortho = - fock_b_tmp1_bi_ortho
|
||||
|
||||
END_PROVIDER
|
||||
|
||||
! ---
|
||||
|
||||
BEGIN_PROVIDER [double precision, fock_b_tmp2_bi_ortho, (mo_num, mo_num)]
|
||||
implicit none
|
||||
integer :: i,a,j,k
|
||||
double precision :: contrib_soo
|
||||
fock_b_tmp2_bi_ortho = 0.d0
|
||||
do i = 1, mo_num
|
||||
do a = 1, mo_num
|
||||
do j = elec_beta_num + 1, elec_alpha_num
|
||||
do k = 1, elec_alpha_num
|
||||
call contrib_3e_soo(a,i,j,k,contrib_soo)
|
||||
fock_b_tmp2_bi_ortho(a,i) += 0.5d0 * contrib_soo
|
||||
|
||||
implicit none
|
||||
integer :: i, a, j, k
|
||||
double precision :: contrib_soo
|
||||
|
||||
PROVIDE mo_l_coef mo_r_coef
|
||||
|
||||
fock_b_tmp2_bi_ortho = 0.d0
|
||||
|
||||
do i = 1, mo_num
|
||||
do a = 1, mo_num
|
||||
do j = elec_beta_num + 1, elec_alpha_num
|
||||
do k = 1, elec_alpha_num
|
||||
call contrib_3e_soo(a, i, j, k, contrib_soo)
|
||||
|
||||
fock_b_tmp2_bi_ortho(a,i) += 0.5d0 * contrib_soo
|
||||
enddo
|
||||
enddo
|
||||
enddo
|
||||
enddo
|
||||
enddo
|
||||
enddo
|
||||
|
||||
END_PROVIDER
|
||||
|
||||
subroutine contrib_3e_sss(a,i,j,k,integral)
|
||||
implicit none
|
||||
integer, intent(in) :: a,i,j,k
|
||||
BEGIN_DOC
|
||||
! returns the pure same spin contribution to F(a,i) from two orbitals j,k
|
||||
END_DOC
|
||||
double precision, intent(out) :: integral
|
||||
double precision :: direct_int, exch_13_int, exch_23_int, exch_12_int, c_3_int, c_minus_3_int
|
||||
call give_integrals_3_body_bi_ort(a, k, j, i, k, j, direct_int )!!! < a k j | i k j >
|
||||
call give_integrals_3_body_bi_ort(a, k, j, j, i, k, c_3_int) ! < a k j | j i k >
|
||||
call give_integrals_3_body_bi_ort(a, k, j, k, j, i, c_minus_3_int)! < a k j | k j i >
|
||||
integral = direct_int + c_3_int + c_minus_3_int
|
||||
! negative terms :: exchange contrib
|
||||
call give_integrals_3_body_bi_ort(a, k, j, j, k, i, exch_13_int)!!! < a k j | j k i > : E_13
|
||||
call give_integrals_3_body_bi_ort(a, k, j, i, j, k, exch_23_int)!!! < a k j | i j k > : E_23
|
||||
call give_integrals_3_body_bi_ort(a, k, j, k, i, j, exch_12_int)!!! < a k j | k i j > : E_12
|
||||
integral += - exch_13_int - exch_23_int - exch_12_int
|
||||
integral = -integral
|
||||
! ---
|
||||
|
||||
subroutine contrib_3e_sss(a, i, j, k, integral)
|
||||
|
||||
BEGIN_DOC
|
||||
! returns the pure same spin contribution to F(a,i) from two orbitals j,k
|
||||
END_DOC
|
||||
|
||||
implicit none
|
||||
integer, intent(in) :: a, i, j, k
|
||||
double precision, intent(out) :: integral
|
||||
double precision :: direct_int, exch_13_int, exch_23_int, exch_12_int, c_3_int, c_minus_3_int
|
||||
|
||||
PROVIDE mo_l_coef mo_r_coef
|
||||
|
||||
call give_integrals_3_body_bi_ort(a, k, j, i, k, j, direct_int )!!! < a k j | i k j >
|
||||
call give_integrals_3_body_bi_ort(a, k, j, j, i, k, c_3_int) ! < a k j | j i k >
|
||||
call give_integrals_3_body_bi_ort(a, k, j, k, j, i, c_minus_3_int)! < a k j | k j i >
|
||||
integral = direct_int + c_3_int + c_minus_3_int
|
||||
|
||||
! negative terms :: exchange contrib
|
||||
call give_integrals_3_body_bi_ort(a, k, j, j, k, i, exch_13_int)!!! < a k j | j k i > : E_13
|
||||
call give_integrals_3_body_bi_ort(a, k, j, i, j, k, exch_23_int)!!! < a k j | i j k > : E_23
|
||||
call give_integrals_3_body_bi_ort(a, k, j, k, i, j, exch_12_int)!!! < a k j | k i j > : E_12
|
||||
integral += - exch_13_int - exch_23_int - exch_12_int
|
||||
|
||||
integral = -integral
|
||||
|
||||
end
|
||||
|
||||
! ---
|
||||
|
||||
subroutine contrib_3e_soo(a,i,j,k,integral)
|
||||
implicit none
|
||||
integer, intent(in) :: a,i,j,k
|
||||
BEGIN_DOC
|
||||
! returns the same spin / opposite spin / opposite spin contribution to F(a,i) from two orbitals j,k
|
||||
END_DOC
|
||||
double precision, intent(out) :: integral
|
||||
double precision :: direct_int, exch_23_int
|
||||
call give_integrals_3_body_bi_ort(a, k, j, i, k, j, direct_int) ! < a k j | i k j >
|
||||
call give_integrals_3_body_bi_ort(a, k, j, i, j, k, exch_23_int)! < a k j | i j k > : E_23
|
||||
integral = direct_int - exch_23_int
|
||||
integral = -integral
|
||||
|
||||
BEGIN_DOC
|
||||
! returns the same spin / opposite spin / opposite spin contribution to F(a,i) from two orbitals j,k
|
||||
END_DOC
|
||||
|
||||
implicit none
|
||||
integer, intent(in) :: a, i, j, k
|
||||
double precision, intent(out) :: integral
|
||||
double precision :: direct_int, exch_23_int
|
||||
|
||||
PROVIDE mo_l_coef mo_r_coef
|
||||
|
||||
call give_integrals_3_body_bi_ort(a, k, j, i, k, j, direct_int) ! < a k j | i k j >
|
||||
call give_integrals_3_body_bi_ort(a, k, j, i, j, k, exch_23_int)! < a k j | i j k > : E_23
|
||||
integral = direct_int - exch_23_int
|
||||
|
||||
integral = -integral
|
||||
|
||||
end
|
||||
|
||||
subroutine contrib_3e_sos(a,i,j,k,integral)
|
||||
implicit none
|
||||
integer, intent(in) :: a,i,j,k
|
||||
BEGIN_DOC
|
||||
! returns the same spin / opposite spin / same spin contribution to F(a,i) from two orbitals j,k
|
||||
END_DOC
|
||||
double precision, intent(out) :: integral
|
||||
double precision :: direct_int, exch_13_int
|
||||
call give_integrals_3_body_bi_ort(a, k, j, i, k, j, direct_int )! < a k j | i k j >
|
||||
call give_integrals_3_body_bi_ort(a, k, j, j, k, i, exch_13_int)! < a k j | j k i > : E_13
|
||||
integral = direct_int - exch_13_int
|
||||
integral = -integral
|
||||
! ---
|
||||
|
||||
subroutine contrib_3e_sos(a, i, j, k, integral)
|
||||
|
||||
BEGIN_DOC
|
||||
! returns the same spin / opposite spin / same spin contribution to F(a,i) from two orbitals j,k
|
||||
END_DOC
|
||||
|
||||
PROVIDE mo_l_coef mo_r_coef
|
||||
|
||||
implicit none
|
||||
integer, intent(in) :: a, i, j, k
|
||||
double precision, intent(out) :: integral
|
||||
double precision :: direct_int, exch_13_int
|
||||
|
||||
call give_integrals_3_body_bi_ort(a, k, j, i, k, j, direct_int )! < a k j | i k j >
|
||||
call give_integrals_3_body_bi_ort(a, k, j, j, k, i, exch_13_int)! < a k j | j k i > : E_13
|
||||
integral = direct_int - exch_13_int
|
||||
|
||||
integral = -integral
|
||||
|
||||
end
|
||||
|
||||
! ---
|
||||
|
||||
|
|
336
src/tc_scf/rh_tcscf.irp.f
Normal file
336
src/tc_scf/rh_tcscf.irp.f
Normal file
|
@ -0,0 +1,336 @@
|
|||
! ---
|
||||
|
||||
subroutine rh_tcscf()
|
||||
|
||||
BEGIN_DOC
|
||||
!
|
||||
! Roothaan-Hall algorithm for TC-SCF calculation
|
||||
!
|
||||
END_DOC
|
||||
|
||||
implicit none
|
||||
|
||||
integer :: i, j
|
||||
integer :: iteration_TCSCF, dim_DIIS, index_dim_DIIS
|
||||
double precision :: energy_TCSCF, energy_TCSCF_1e, energy_TCSCF_2e, energy_TCSCF_3e, gradie_TCSCF
|
||||
double precision :: energy_TCSCF_previous, delta_energy_TCSCF
|
||||
double precision :: gradie_TCSCF_previous, delta_gradie_TCSCF
|
||||
double precision :: max_error_DIIS_TCSCF
|
||||
double precision :: level_shift_save
|
||||
double precision :: delta_energy_tmp, delta_gradie_tmp
|
||||
double precision, allocatable :: F_DIIS(:,:,:), e_DIIS(:,:,:)
|
||||
double precision, allocatable :: mo_r_coef_save(:,:), mo_l_coef_save(:,:)
|
||||
|
||||
logical, external :: qp_stop
|
||||
|
||||
|
||||
!PROVIDE ao_md5 mo_occ
|
||||
PROVIDE level_shift_TCSCF
|
||||
|
||||
allocate( mo_r_coef_save(ao_num,mo_num), mo_l_coef_save(ao_num,mo_num) &
|
||||
, F_DIIS(ao_num,ao_num,max_dim_DIIS_TCSCF), e_DIIS(ao_num,ao_num,max_dim_DIIS_TCSCF) )
|
||||
|
||||
F_DIIS = 0.d0
|
||||
e_DIIS = 0.d0
|
||||
mo_l_coef_save = 0.d0
|
||||
mo_r_coef_save = 0.d0
|
||||
|
||||
call write_time(6)
|
||||
|
||||
! ---
|
||||
! Initialize energies and density matrices
|
||||
|
||||
energy_TCSCF_previous = TC_HF_energy
|
||||
energy_TCSCF_1e = TC_HF_one_e_energy
|
||||
energy_TCSCF_2e = TC_HF_two_e_energy
|
||||
energy_TCSCF_3e = 0.d0
|
||||
if(three_body_h_tc) then
|
||||
energy_TCSCF_3e = diag_three_elem_hf
|
||||
endif
|
||||
gradie_TCSCF_previous = grad_non_hermit
|
||||
delta_energy_TCSCF = 1.d0
|
||||
delta_gradie_TCSCF = 1.d0
|
||||
iteration_TCSCF = 0
|
||||
dim_DIIS = 0
|
||||
max_error_DIIS_TCSCF = 1.d0
|
||||
|
||||
! ---
|
||||
|
||||
! Start of main SCF loop
|
||||
|
||||
PROVIDE FQS_SQF_ao Fock_matrix_tc_ao_tot
|
||||
|
||||
do while( (max_error_DIIS_TCSCF > threshold_DIIS_nonzero_TCSCF) .or. &
|
||||
!(dabs(delta_energy_TCSCF) > thresh_TCSCF) .or. &
|
||||
(dabs(gradie_TCSCF_previous) > dsqrt(thresh_TCSCF)) )
|
||||
|
||||
iteration_TCSCF += 1
|
||||
if(iteration_TCSCF > n_it_TCSCF_max) then
|
||||
print *, ' max of TCSCF iterations is reached ', n_it_TCSCF_max
|
||||
stop
|
||||
endif
|
||||
|
||||
dim_DIIS = min(dim_DIIS+1, max_dim_DIIS_TCSCF)
|
||||
|
||||
! ---
|
||||
|
||||
if((tcscf_algorithm == 'DIIS') .and. (dabs(delta_energy_TCSCF) > 1.d-6)) then
|
||||
|
||||
! store Fock and error matrices at each iteration
|
||||
index_dim_DIIS = mod(dim_DIIS-1, max_dim_DIIS_TCSCF) + 1
|
||||
do j = 1, ao_num
|
||||
do i = 1, ao_num
|
||||
F_DIIS(i,j,index_dim_DIIS) = Fock_matrix_tc_ao_tot(i,j)
|
||||
e_DIIS(i,j,index_dim_DIIS) = FQS_SQF_ao(i,j)
|
||||
enddo
|
||||
enddo
|
||||
|
||||
call extrapolate_TC_Fock_matrix(e_DIIS, F_DIIS, Fock_matrix_tc_ao_tot, size(Fock_matrix_tc_ao_tot, 1), iteration_TCSCF, dim_DIIS)
|
||||
|
||||
Fock_matrix_tc_ao_alpha = 0.5d0 * Fock_matrix_tc_ao_tot
|
||||
Fock_matrix_tc_ao_beta = 0.5d0 * Fock_matrix_tc_ao_tot
|
||||
!TOUCH Fock_matrix_tc_ao_alpha Fock_matrix_tc_ao_beta
|
||||
|
||||
call ao_to_mo_bi_ortho( Fock_matrix_tc_ao_alpha, size(Fock_matrix_tc_ao_alpha, 1) &
|
||||
, Fock_matrix_tc_mo_alpha, size(Fock_matrix_tc_mo_alpha, 1) )
|
||||
call ao_to_mo_bi_ortho( Fock_matrix_tc_ao_beta , size(Fock_matrix_tc_ao_beta , 1) &
|
||||
, Fock_matrix_tc_mo_beta , size(Fock_matrix_tc_mo_beta , 1) )
|
||||
TOUCH Fock_matrix_tc_mo_alpha Fock_matrix_tc_mo_beta
|
||||
endif
|
||||
|
||||
! ---
|
||||
|
||||
mo_l_coef(1:ao_num,1:mo_num) = fock_tc_leigvec_ao(1:ao_num,1:mo_num)
|
||||
mo_r_coef(1:ao_num,1:mo_num) = fock_tc_reigvec_ao(1:ao_num,1:mo_num)
|
||||
TOUCH mo_l_coef mo_r_coef
|
||||
|
||||
! ---
|
||||
|
||||
! calculate error vectors
|
||||
max_error_DIIS_TCSCF = maxval(abs(FQS_SQF_mo))
|
||||
|
||||
! ---
|
||||
|
||||
delta_energy_tmp = TC_HF_energy - energy_TCSCF_previous
|
||||
delta_gradie_tmp = grad_non_hermit - gradie_TCSCF_previous
|
||||
|
||||
! ---
|
||||
|
||||
do while((delta_gradie_tmp > 1.d-7) .and. (iteration_TCSCF > 1))
|
||||
!do while((dabs(delta_energy_tmp) > 0.5d0) .and. (iteration_TCSCF > 1))
|
||||
print *, ' very big or bad step : ', delta_energy_tmp, delta_gradie_tmp
|
||||
print *, ' TC level shift = ', level_shift_TCSCF
|
||||
|
||||
mo_l_coef(1:ao_num,1:mo_num) = mo_l_coef_save(1:ao_num,1:mo_num)
|
||||
mo_r_coef(1:ao_num,1:mo_num) = mo_r_coef_save(1:ao_num,1:mo_num)
|
||||
|
||||
if(level_shift_TCSCF <= .1d0) then
|
||||
level_shift_TCSCF = 1.d0
|
||||
else
|
||||
level_shift_TCSCF = level_shift_TCSCF * 3.0d0
|
||||
endif
|
||||
TOUCH mo_l_coef mo_r_coef level_shift_TCSCF
|
||||
|
||||
mo_l_coef(1:ao_num,1:mo_num) = fock_tc_leigvec_ao(1:ao_num,1:mo_num)
|
||||
mo_r_coef(1:ao_num,1:mo_num) = fock_tc_reigvec_ao(1:ao_num,1:mo_num)
|
||||
TOUCH mo_l_coef mo_r_coef
|
||||
|
||||
delta_energy_tmp = TC_HF_energy - energy_TCSCF_previous
|
||||
delta_gradie_tmp = grad_non_hermit - gradie_TCSCF_previous
|
||||
|
||||
if(level_shift_TCSCF - level_shift_save > 40.d0) then
|
||||
level_shift_TCSCF = level_shift_save * 4.d0
|
||||
SOFT_TOUCH level_shift_TCSCF
|
||||
exit
|
||||
endif
|
||||
|
||||
dim_DIIS = 0
|
||||
enddo
|
||||
! print *, ' very big step : ', delta_energy_tmp
|
||||
! print *, ' TC level shift = ', level_shift_TCSCF
|
||||
|
||||
! ---
|
||||
|
||||
level_shift_TCSCF = 0.d0
|
||||
!level_shift_TCSCF = level_shift_TCSCF * 0.5d0
|
||||
SOFT_TOUCH level_shift_TCSCF
|
||||
|
||||
gradie_TCSCF = grad_non_hermit
|
||||
energy_TCSCF = TC_HF_energy
|
||||
energy_TCSCF_1e = TC_HF_one_e_energy
|
||||
energy_TCSCF_2e = TC_HF_two_e_energy
|
||||
energy_TCSCF_3e = 0.d0
|
||||
if(three_body_h_tc) then
|
||||
energy_TCSCF_3e = diag_three_elem_hf
|
||||
endif
|
||||
delta_energy_TCSCF = energy_TCSCF - energy_TCSCF_previous
|
||||
delta_gradie_TCSCF = gradie_TCSCF - gradie_TCSCF_previous
|
||||
|
||||
energy_TCSCF_previous = energy_TCSCF
|
||||
gradie_TCSCF_previous = gradie_TCSCF
|
||||
|
||||
|
||||
level_shift_save = level_shift_TCSCF
|
||||
mo_l_coef_save(1:ao_num,1:mo_num) = mo_l_coef(1:ao_num,1:mo_num)
|
||||
mo_r_coef_save(1:ao_num,1:mo_num) = mo_r_coef(1:ao_num,1:mo_num)
|
||||
|
||||
|
||||
print *, ' iteration = ', iteration_TCSCF
|
||||
print *, ' total TC energy = ', energy_TCSCF
|
||||
print *, ' 1-e TC energy = ', energy_TCSCF_1e
|
||||
print *, ' 2-e TC energy = ', energy_TCSCF_2e
|
||||
print *, ' 3-e TC energy = ', energy_TCSCF_3e
|
||||
print *, ' |delta TC energy| = ', dabs(delta_energy_TCSCF)
|
||||
print *, ' TC gradient = ', gradie_TCSCF
|
||||
print *, ' delta TC gradient = ', delta_gradie_TCSCF
|
||||
print *, ' max TC DIIS error = ', max_error_DIIS_TCSCF
|
||||
print *, ' TC DIIS dim = ', dim_DIIS
|
||||
print *, ' TC level shift = ', level_shift_TCSCF
|
||||
print *, ' '
|
||||
|
||||
call ezfio_set_bi_ortho_mos_mo_l_coef(mo_l_coef)
|
||||
call ezfio_set_bi_ortho_mos_mo_r_coef(mo_r_coef)
|
||||
|
||||
if(qp_stop()) exit
|
||||
enddo
|
||||
|
||||
! ---
|
||||
|
||||
print *, ' TCSCF DIIS converged !'
|
||||
call print_energy_and_mos()
|
||||
|
||||
call write_time(6)
|
||||
|
||||
deallocate(mo_r_coef_save, mo_l_coef_save, F_DIIS, e_DIIS)
|
||||
|
||||
end
|
||||
|
||||
! ---
|
||||
|
||||
subroutine extrapolate_TC_Fock_matrix(e_DIIS, F_DIIS, F_ao, size_F_ao, iteration_TCSCF, dim_DIIS)
|
||||
|
||||
BEGIN_DOC
|
||||
!
|
||||
! Compute the extrapolated Fock matrix using the DIIS procedure
|
||||
!
|
||||
! e = \sum_i c_i e_i and \sum_i c_i = 1
|
||||
! ==> lagrange multiplier with L = |e|^2 - \lambda (\sum_i c_i = 1)
|
||||
!
|
||||
END_DOC
|
||||
|
||||
implicit none
|
||||
|
||||
integer, intent(in) :: iteration_TCSCF, size_F_ao
|
||||
integer, intent(inout) :: dim_DIIS
|
||||
double precision, intent(in) :: F_DIIS(ao_num,ao_num,dim_DIIS)
|
||||
double precision, intent(in) :: e_DIIS(ao_num,ao_num,dim_DIIS)
|
||||
double precision, intent(inout) :: F_ao(size_F_ao,ao_num)
|
||||
|
||||
double precision, allocatable :: B_matrix_DIIS(:,:), X_vector_DIIS(:), C_vector_DIIS(:)
|
||||
|
||||
integer :: i, j, k, l, i_DIIS, j_DIIS
|
||||
integer :: lwork
|
||||
double precision :: rcond, ferr, berr
|
||||
integer, allocatable :: iwork(:)
|
||||
double precision, allocatable :: scratch(:,:)
|
||||
|
||||
if(dim_DIIS < 1) then
|
||||
return
|
||||
endif
|
||||
|
||||
allocate( B_matrix_DIIS(dim_DIIS+1,dim_DIIS+1), X_vector_DIIS(dim_DIIS+1) &
|
||||
, C_vector_DIIS(dim_DIIS+1), scratch(ao_num,ao_num) )
|
||||
|
||||
! Compute the matrices B and X
|
||||
B_matrix_DIIS(:,:) = 0.d0
|
||||
do j = 1, dim_DIIS
|
||||
j_DIIS = min(dim_DIIS, mod(iteration_TCSCF-j, max_dim_DIIS_TCSCF)+1)
|
||||
|
||||
do i = 1, dim_DIIS
|
||||
i_DIIS = min(dim_DIIS, mod(iteration_TCSCF-i, max_dim_DIIS_TCSCF)+1)
|
||||
|
||||
! Compute product of two errors vectors
|
||||
do l = 1, ao_num
|
||||
do k = 1, ao_num
|
||||
B_matrix_DIIS(i,j) = B_matrix_DIIS(i,j) + e_DIIS(k,l,i_DIIS) * e_DIIS(k,l,j_DIIS)
|
||||
enddo
|
||||
enddo
|
||||
|
||||
enddo
|
||||
enddo
|
||||
|
||||
! Pad B matrix and build the X matrix
|
||||
|
||||
C_vector_DIIS(:) = 0.d0
|
||||
do i = 1, dim_DIIS
|
||||
B_matrix_DIIS(i,dim_DIIS+1) = -1.d0
|
||||
B_matrix_DIIS(dim_DIIS+1,i) = -1.d0
|
||||
enddo
|
||||
C_vector_DIIS(dim_DIIS+1) = -1.d0
|
||||
|
||||
deallocate(scratch)
|
||||
|
||||
! Estimate condition number of B
|
||||
integer :: info
|
||||
double precision :: anorm
|
||||
integer, allocatable :: ipiv(:)
|
||||
double precision, allocatable :: AF(:,:)
|
||||
double precision, external :: dlange
|
||||
|
||||
lwork = max((dim_DIIS+1)**2, (dim_DIIS+1)*5)
|
||||
allocate(AF(dim_DIIS+1,dim_DIIS+1))
|
||||
allocate(ipiv(2*(dim_DIIS+1)), iwork(2*(dim_DIIS+1)) )
|
||||
allocate(scratch(lwork,1))
|
||||
scratch(:,1) = 0.d0
|
||||
|
||||
anorm = dlange('1', dim_DIIS+1, dim_DIIS+1, B_matrix_DIIS, size(B_matrix_DIIS, 1), scratch(1,1))
|
||||
|
||||
AF(:,:) = B_matrix_DIIS(:,:)
|
||||
call dgetrf(dim_DIIS+1, dim_DIIS+1, AF, size(AF, 1), ipiv, info)
|
||||
if(info /= 0) then
|
||||
dim_DIIS = 0
|
||||
return
|
||||
endif
|
||||
|
||||
call dgecon('1', dim_DIIS+1, AF, size(AF, 1), anorm, rcond, scratch, iwork, info)
|
||||
if(info /= 0) then
|
||||
dim_DIIS = 0
|
||||
return
|
||||
endif
|
||||
|
||||
if(rcond < 1.d-14) then
|
||||
dim_DIIS = 0
|
||||
return
|
||||
endif
|
||||
|
||||
! solve the linear system C = B x X
|
||||
|
||||
X_vector_DIIS = C_vector_DIIS
|
||||
call dgesv(dim_DIIS+1, 1, B_matrix_DIIS, size(B_matrix_DIIS, 1), ipiv , X_vector_DIIS, size(X_vector_DIIS, 1), info)
|
||||
|
||||
deallocate(scratch, AF, iwork)
|
||||
if(info < 0) then
|
||||
stop ' bug in TC-DIIS'
|
||||
endif
|
||||
|
||||
! Compute extrapolated Fock matrix
|
||||
|
||||
!$OMP PARALLEL DO PRIVATE(i,j,k) DEFAULT(SHARED) if (ao_num > 200)
|
||||
do j = 1, ao_num
|
||||
do i = 1, ao_num
|
||||
F_ao(i,j) = 0.d0
|
||||
enddo
|
||||
do k = 1, dim_DIIS
|
||||
if(dabs(X_vector_DIIS(k)) < 1.d-10) cycle
|
||||
do i = 1,ao_num
|
||||
! FPE here
|
||||
F_ao(i,j) = F_ao(i,j) + X_vector_DIIS(k) * F_DIIS(i,j,dim_DIIS-k+1)
|
||||
enddo
|
||||
enddo
|
||||
enddo
|
||||
!$OMP END PARALLEL DO
|
||||
|
||||
end
|
||||
|
||||
! ---
|
||||
|
362
src/tc_scf/rh_tcscf_diis.irp.f
Normal file
362
src/tc_scf/rh_tcscf_diis.irp.f
Normal file
|
@ -0,0 +1,362 @@
|
|||
! ---
|
||||
|
||||
subroutine rh_tcscf_diis()
|
||||
|
||||
implicit none
|
||||
|
||||
integer :: i, j, it
|
||||
integer :: dim_DIIS, index_dim_DIIS
|
||||
double precision :: etc_tot, etc_1e, etc_2e, etc_3e, e_save, e_delta
|
||||
double precision :: tc_grad, g_save, g_delta, g_delta_th
|
||||
double precision :: level_shift_save, rate_th
|
||||
double precision :: t0, t1
|
||||
double precision :: er_DIIS, er_delta, er_save, er_delta_th
|
||||
double precision, allocatable :: F_DIIS(:,:,:), E_DIIS(:,:,:)
|
||||
double precision, allocatable :: mo_r_coef_save(:,:), mo_l_coef_save(:,:)
|
||||
|
||||
logical, external :: qp_stop
|
||||
|
||||
it = 0
|
||||
e_save = 0.d0
|
||||
dim_DIIS = 0
|
||||
g_delta_th = 1d0
|
||||
er_delta_th = 1d0
|
||||
rate_th = 100.d0 !0.01d0 !0.2d0
|
||||
|
||||
allocate(mo_r_coef_save(ao_num,mo_num), mo_l_coef_save(ao_num,mo_num))
|
||||
mo_l_coef_save = 0.d0
|
||||
mo_r_coef_save = 0.d0
|
||||
|
||||
allocate(F_DIIS(ao_num,ao_num,max_dim_DIIS_TCSCF), E_DIIS(ao_num,ao_num,max_dim_DIIS_TCSCF))
|
||||
F_DIIS = 0.d0
|
||||
E_DIIS = 0.d0
|
||||
|
||||
call write_time(6)
|
||||
|
||||
! ---
|
||||
|
||||
PROVIDE level_shift_TCSCF
|
||||
PROVIDE mo_l_coef mo_r_coef
|
||||
|
||||
write(6, '(A4,1X, A16,1X, A16,1X, A16,1X, A16,1X, A16,1X, A16,1X, A16,1X, A16,1X, A4, 1X, A8)') &
|
||||
'====', '================', '================', '================', '================', '================' &
|
||||
, '================', '================', '================', '====', '========'
|
||||
|
||||
write(6, '(A4,1X, A16,1X, A16,1X, A16,1X, A16,1X, A16,1X, A16,1X, A16,1X, A16,1X, A4, 1X, A8)') &
|
||||
' it ', ' SCF TC Energy ', ' E(1e) ', ' E(2e) ', ' E(3e) ', ' energy diff ' &
|
||||
, ' gradient ', ' DIIS error ', ' level shift ', 'DIIS', ' WT (m)'
|
||||
|
||||
write(6, '(A4,1X, A16,1X, A16,1X, A16,1X, A16,1X, A16,1X, A16,1X, A16,1X, A16,1X, A4, 1X, A8)') &
|
||||
'====', '================', '================', '================', '================', '================' &
|
||||
, '================', '================', '================', '====', '========'
|
||||
|
||||
|
||||
! first iteration (HF orbitals)
|
||||
call wall_time(t0)
|
||||
|
||||
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
|
||||
tc_grad = grad_non_hermit
|
||||
er_DIIS = maxval(abs(FQS_SQF_mo))
|
||||
e_delta = dabs(etc_tot - e_save)
|
||||
|
||||
e_save = etc_tot
|
||||
g_save = tc_grad
|
||||
er_save = er_DIIS
|
||||
|
||||
call wall_time(t1)
|
||||
write(6, '(I4,1X, F16.10,1X, F16.10,1X, F16.10,1X, F16.10,1X, F16.10,1X, F16.10,1X, F16.10,1X, F16.10,1X, I4,1X, F8.2)') &
|
||||
it, etc_tot, etc_1e, etc_2e, etc_3e, e_delta, tc_grad, er_DIIS, level_shift_tcscf, dim_DIIS, (t1-t0)/60.d0
|
||||
|
||||
! ---
|
||||
|
||||
PROVIDE FQS_SQF_ao Fock_matrix_tc_ao_tot
|
||||
|
||||
do while((tc_grad .gt. dsqrt(thresh_tcscf)) .and. (er_DIIS .gt. threshold_DIIS_nonzero_TCSCF))
|
||||
|
||||
call wall_time(t0)
|
||||
|
||||
it += 1
|
||||
if(it > n_it_TCSCF_max) then
|
||||
print *, ' max of TCSCF iterations is reached ', n_it_TCSCF_max
|
||||
stop
|
||||
endif
|
||||
|
||||
dim_DIIS = min(dim_DIIS+1, max_dim_DIIS_TCSCF)
|
||||
|
||||
! ---
|
||||
|
||||
if(dabs(e_delta) > 1.d-12) then
|
||||
|
||||
index_dim_DIIS = mod(dim_DIIS-1, max_dim_DIIS_TCSCF) + 1
|
||||
do j = 1, ao_num
|
||||
do i = 1, ao_num
|
||||
F_DIIS(i,j,index_dim_DIIS) = Fock_matrix_tc_ao_tot(i,j)
|
||||
E_DIIS(i,j,index_dim_DIIS) = FQS_SQF_ao (i,j)
|
||||
enddo
|
||||
enddo
|
||||
|
||||
call extrapolate_TC_Fock_matrix(E_DIIS, F_DIIS, Fock_matrix_tc_ao_tot, size(Fock_matrix_tc_ao_tot, 1), it, dim_DIIS)
|
||||
|
||||
call ao_to_mo_bi_ortho( Fock_matrix_tc_ao_tot, size(Fock_matrix_tc_ao_tot, 1) &
|
||||
, Fock_matrix_tc_mo_tot, size(Fock_matrix_tc_mo_tot, 1) )
|
||||
TOUCH Fock_matrix_tc_mo_tot fock_matrix_tc_diag_mo_tot
|
||||
endif
|
||||
|
||||
! ---
|
||||
|
||||
mo_l_coef(1:ao_num,1:mo_num) = fock_tc_leigvec_ao(1:ao_num,1:mo_num)
|
||||
mo_r_coef(1:ao_num,1:mo_num) = fock_tc_reigvec_ao(1:ao_num,1:mo_num)
|
||||
!call ezfio_set_bi_ortho_mos_mo_l_coef(mo_l_coef)
|
||||
!call ezfio_set_bi_ortho_mos_mo_r_coef(mo_r_coef)
|
||||
TOUCH mo_l_coef mo_r_coef
|
||||
|
||||
! ---
|
||||
|
||||
g_delta = grad_non_hermit - g_save
|
||||
er_delta = maxval(abs(FQS_SQF_mo)) - er_save
|
||||
|
||||
!if((g_delta > rate_th * g_delta_th) .and. (er_delta > rate_th * er_delta_th) .and. (it > 1)) then
|
||||
if((g_delta > rate_th * g_delta_th) .and. (it > 1)) then
|
||||
!if((g_delta > 0.d0) .and. (it > 1)) then
|
||||
|
||||
Fock_matrix_tc_ao_tot(1:ao_num,1:ao_num) = F_DIIS(1:ao_num,1:ao_num,index_dim_DIIS)
|
||||
call ao_to_mo_bi_ortho( Fock_matrix_tc_ao_tot, size(Fock_matrix_tc_ao_tot, 1) &
|
||||
, Fock_matrix_tc_mo_tot, size(Fock_matrix_tc_mo_tot, 1) )
|
||||
TOUCH Fock_matrix_tc_mo_tot fock_matrix_tc_diag_mo_tot
|
||||
|
||||
mo_l_coef(1:ao_num,1:mo_num) = fock_tc_leigvec_ao(1:ao_num,1:mo_num)
|
||||
mo_r_coef(1:ao_num,1:mo_num) = fock_tc_reigvec_ao(1:ao_num,1:mo_num)
|
||||
!call ezfio_set_bi_ortho_mos_mo_l_coef(mo_l_coef)
|
||||
!call ezfio_set_bi_ortho_mos_mo_r_coef(mo_r_coef)
|
||||
TOUCH mo_l_coef mo_r_coef
|
||||
|
||||
endif
|
||||
|
||||
! ---
|
||||
|
||||
g_delta = grad_non_hermit - g_save
|
||||
er_delta = maxval(abs(FQS_SQF_mo)) - er_save
|
||||
|
||||
mo_l_coef_save(1:ao_num,1:mo_num) = mo_l_coef(1:ao_num,1:mo_num)
|
||||
mo_r_coef_save(1:ao_num,1:mo_num) = mo_r_coef(1:ao_num,1:mo_num)
|
||||
|
||||
!do while((g_delta > rate_th * g_delta_th) .and. (er_delta > rate_th * er_delta_th) .and. (it > 1))
|
||||
do while((g_delta > rate_th * g_delta_th) .and. (it > 1))
|
||||
print *, ' big or bad step : ', g_delta, rate_th * g_delta_th
|
||||
|
||||
mo_l_coef(1:ao_num,1:mo_num) = mo_l_coef_save(1:ao_num,1:mo_num)
|
||||
mo_r_coef(1:ao_num,1:mo_num) = mo_r_coef_save(1:ao_num,1:mo_num)
|
||||
if(level_shift_TCSCF <= .1d0) then
|
||||
level_shift_TCSCF = 1.d0
|
||||
else
|
||||
level_shift_TCSCF = level_shift_TCSCF * 3.0d0
|
||||
endif
|
||||
TOUCH mo_l_coef mo_r_coef level_shift_TCSCF
|
||||
|
||||
mo_l_coef(1:ao_num,1:mo_num) = fock_tc_leigvec_ao(1:ao_num,1:mo_num)
|
||||
mo_r_coef(1:ao_num,1:mo_num) = fock_tc_reigvec_ao(1:ao_num,1:mo_num)
|
||||
!call ezfio_set_bi_ortho_mos_mo_l_coef(mo_l_coef)
|
||||
!call ezfio_set_bi_ortho_mos_mo_r_coef(mo_r_coef)
|
||||
TOUCH mo_l_coef mo_r_coef
|
||||
|
||||
g_delta = grad_non_hermit - g_save
|
||||
er_delta = maxval(abs(FQS_SQF_mo)) - er_save
|
||||
|
||||
if(level_shift_TCSCF - level_shift_save > 40.d0) then
|
||||
level_shift_TCSCF = level_shift_save * 4.d0
|
||||
SOFT_TOUCH level_shift_TCSCF
|
||||
exit
|
||||
endif
|
||||
|
||||
dim_DIIS = 0
|
||||
enddo
|
||||
|
||||
! ---
|
||||
|
||||
level_shift_TCSCF = level_shift_TCSCF * 0.5d0
|
||||
SOFT_TOUCH level_shift_TCSCF
|
||||
|
||||
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
|
||||
tc_grad = grad_non_hermit
|
||||
er_DIIS = maxval(abs(FQS_SQF_mo))
|
||||
e_delta = dabs(etc_tot - e_save)
|
||||
g_delta = tc_grad - g_save
|
||||
er_delta = er_DIIS - er_save
|
||||
|
||||
e_save = etc_tot
|
||||
g_save = tc_grad
|
||||
level_shift_save = level_shift_TCSCF
|
||||
er_save = er_DIIS
|
||||
|
||||
g_delta_th = dabs(tc_grad) ! g_delta)
|
||||
er_delta_th = dabs(er_DIIS) !er_delta)
|
||||
|
||||
call wall_time(t1)
|
||||
write(6, '(I4,1X, F16.10,1X, F16.10,1X, F16.10,1X, F16.10,1X, F16.10,1X, F16.10,1X, F16.10,1X, F16.10,1X, I4,1X, F8.2)') &
|
||||
it, etc_tot, etc_1e, etc_2e, etc_3e, e_delta, tc_grad, er_DIIS, level_shift_tcscf, dim_DIIS, (t1-t0)/60.d0
|
||||
|
||||
if(g_delta .lt. 0.d0) then
|
||||
call ezfio_set_tc_scf_bitc_energy(etc_tot)
|
||||
call ezfio_set_bi_ortho_mos_mo_l_coef(mo_l_coef)
|
||||
call ezfio_set_bi_ortho_mos_mo_r_coef(mo_r_coef)
|
||||
endif
|
||||
|
||||
if(qp_stop()) exit
|
||||
enddo
|
||||
|
||||
! ---
|
||||
|
||||
print *, ' TCSCF DIIS converged !'
|
||||
call print_energy_and_mos()
|
||||
|
||||
call write_time(6)
|
||||
|
||||
deallocate(mo_r_coef_save, mo_l_coef_save, F_DIIS, E_DIIS)
|
||||
|
||||
call ezfio_set_tc_scf_bitc_energy(TC_HF_energy)
|
||||
call ezfio_set_bi_ortho_mos_mo_l_coef(mo_l_coef)
|
||||
call ezfio_set_bi_ortho_mos_mo_r_coef(mo_r_coef)
|
||||
|
||||
end
|
||||
|
||||
! ---
|
||||
|
||||
subroutine extrapolate_TC_Fock_matrix(E_DIIS, F_DIIS, F_ao, size_F_ao, it, dim_DIIS)
|
||||
|
||||
BEGIN_DOC
|
||||
!
|
||||
! Compute the extrapolated Fock matrix using the DIIS procedure
|
||||
!
|
||||
! e = \sum_i c_i e_i and \sum_i c_i = 1
|
||||
! ==> lagrange multiplier with L = |e|^2 - \lambda (\sum_i c_i = 1)
|
||||
!
|
||||
END_DOC
|
||||
|
||||
implicit none
|
||||
|
||||
integer, intent(in) :: it, size_F_ao
|
||||
integer, intent(inout) :: dim_DIIS
|
||||
double precision, intent(in) :: F_DIIS(ao_num,ao_num,dim_DIIS)
|
||||
double precision, intent(in) :: E_DIIS(ao_num,ao_num,dim_DIIS)
|
||||
double precision, intent(inout) :: F_ao(size_F_ao,ao_num)
|
||||
|
||||
double precision, allocatable :: B_matrix_DIIS(:,:), X_vector_DIIS(:), C_vector_DIIS(:)
|
||||
|
||||
integer :: i, j, k, l, i_DIIS, j_DIIS
|
||||
integer :: lwork
|
||||
double precision :: rcond, ferr, berr
|
||||
integer, allocatable :: iwork(:)
|
||||
double precision, allocatable :: scratch(:,:)
|
||||
|
||||
if(dim_DIIS < 1) then
|
||||
return
|
||||
endif
|
||||
|
||||
allocate( B_matrix_DIIS(dim_DIIS+1,dim_DIIS+1), X_vector_DIIS(dim_DIIS+1) &
|
||||
, C_vector_DIIS(dim_DIIS+1), scratch(ao_num,ao_num) )
|
||||
|
||||
! Compute the matrices B and X
|
||||
B_matrix_DIIS(:,:) = 0.d0
|
||||
do j = 1, dim_DIIS
|
||||
j_DIIS = min(dim_DIIS, mod(it-j, max_dim_DIIS_TCSCF)+1)
|
||||
|
||||
do i = 1, dim_DIIS
|
||||
i_DIIS = min(dim_DIIS, mod(it-i, max_dim_DIIS_TCSCF)+1)
|
||||
|
||||
! Compute product of two errors vectors
|
||||
do l = 1, ao_num
|
||||
do k = 1, ao_num
|
||||
B_matrix_DIIS(i,j) = B_matrix_DIIS(i,j) + E_DIIS(k,l,i_DIIS) * E_DIIS(k,l,j_DIIS)
|
||||
enddo
|
||||
enddo
|
||||
|
||||
enddo
|
||||
enddo
|
||||
|
||||
! Pad B matrix and build the X matrix
|
||||
|
||||
C_vector_DIIS(:) = 0.d0
|
||||
do i = 1, dim_DIIS
|
||||
B_matrix_DIIS(i,dim_DIIS+1) = -1.d0
|
||||
B_matrix_DIIS(dim_DIIS+1,i) = -1.d0
|
||||
enddo
|
||||
C_vector_DIIS(dim_DIIS+1) = -1.d0
|
||||
|
||||
deallocate(scratch)
|
||||
|
||||
! Estimate condition number of B
|
||||
integer :: info
|
||||
double precision :: anorm
|
||||
integer, allocatable :: ipiv(:)
|
||||
double precision, allocatable :: AF(:,:)
|
||||
double precision, external :: dlange
|
||||
|
||||
lwork = max((dim_DIIS+1)**2, (dim_DIIS+1)*5)
|
||||
allocate(AF(dim_DIIS+1,dim_DIIS+1))
|
||||
allocate(ipiv(2*(dim_DIIS+1)), iwork(2*(dim_DIIS+1)) )
|
||||
allocate(scratch(lwork,1))
|
||||
scratch(:,1) = 0.d0
|
||||
|
||||
anorm = dlange('1', dim_DIIS+1, dim_DIIS+1, B_matrix_DIIS, size(B_matrix_DIIS, 1), scratch(1,1))
|
||||
|
||||
AF(:,:) = B_matrix_DIIS(:,:)
|
||||
call dgetrf(dim_DIIS+1, dim_DIIS+1, AF, size(AF, 1), ipiv, info)
|
||||
if(info /= 0) then
|
||||
dim_DIIS = 0
|
||||
return
|
||||
endif
|
||||
|
||||
call dgecon('1', dim_DIIS+1, AF, size(AF, 1), anorm, rcond, scratch, iwork, info)
|
||||
if(info /= 0) then
|
||||
dim_DIIS = 0
|
||||
return
|
||||
endif
|
||||
|
||||
if(rcond < 1.d-14) then
|
||||
dim_DIIS = 0
|
||||
return
|
||||
endif
|
||||
|
||||
! solve the linear system C = B x X
|
||||
|
||||
X_vector_DIIS = C_vector_DIIS
|
||||
call dgesv(dim_DIIS+1, 1, B_matrix_DIIS, size(B_matrix_DIIS, 1), ipiv , X_vector_DIIS, size(X_vector_DIIS, 1), info)
|
||||
|
||||
deallocate(scratch, AF, iwork)
|
||||
if(info < 0) then
|
||||
stop ' bug in TC-DIIS'
|
||||
endif
|
||||
|
||||
! Compute extrapolated Fock matrix
|
||||
|
||||
!$OMP PARALLEL DO PRIVATE(i,j,k) DEFAULT(SHARED) if (ao_num > 200)
|
||||
do j = 1, ao_num
|
||||
do i = 1, ao_num
|
||||
F_ao(i,j) = 0.d0
|
||||
enddo
|
||||
do k = 1, dim_DIIS
|
||||
if(dabs(X_vector_DIIS(k)) < 1.d-10) cycle
|
||||
do i = 1,ao_num
|
||||
! FPE here
|
||||
F_ao(i,j) = F_ao(i,j) + X_vector_DIIS(k) * F_DIIS(i,j,dim_DIIS-k+1)
|
||||
enddo
|
||||
enddo
|
||||
enddo
|
||||
!$OMP END PARALLEL DO
|
||||
|
||||
end
|
||||
|
||||
! ---
|
||||
|
Some files were not shown because too many files have changed in this diff Show More
Loading…
Reference in New Issue
Block a user