PTEROSOR/QuantumPackage
10
0
Fork 0
mirror of https://github.com/QuantumPackage/qp2.git synced 2024-08-07 21:10:03 +02:00
Code Releases Activity

Merge pull request #25 from QuantumPackage/dev-stable

Browse Source 
Dev stable
This commit is contained in:
AbdAmmar 2023-10-15 09:42:50 +02:00 committed by GitHub
commit fb98da5fb4
No known key found for this signature in database
GPG Key ID: 4AEE18F83AFDEB23
348 changed files with 35693 additions and 6685 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

1
.github/workflows/compilation.yml vendored
View File

@ -49,6 +49,7 @@ jobs:
./configure -i resultsFile || : ./configure -i resultsFile || :
./configure -i bats || : ./configure -i bats || :
./configure -i trexio-nohdf5 || : ./configure -i trexio-nohdf5 || :
./configure -i qmckl || :
./configure -c ./config/gfortran_debug.cfg ./configure -c ./config/gfortran_debug.cfg
- name: Compilation - name: Compilation
run: | run: |

5
.github/workflows/configuration.yml vendored
View File

@ -22,7 +22,7 @@ jobs:
- uses: actions/checkout@v3 - uses: actions/checkout@v3
- name: Install dependencies - name: Install dependencies
run: | run: |
sudo apt install gfortran gcc liblapack-dev libblas-dev wget python3 make m4 pkg-config hdf5 sudo apt install gfortran gcc liblapack-dev libblas-dev wget python3 make m4 pkg-config libhdf5-dev
- name: zlib - name: zlib
run: | run: |
./configure -i zlib || echo OK ./configure -i zlib || echo OK
@ -56,6 +56,9 @@ jobs:
- name: trexio - name: trexio
run: | run: |
./configure -i trexio || echo OK ./configure -i trexio || echo OK
- name: qmckl
run: |
./configure -i qmckl || echo OK
- name: Final check - name: Final check
run: | run: |
./configure -c config/gfortran_debug.cfg ./configure -c config/gfortran_debug.cfg

5
RELEASE_NOTES.org
View File

@ -10,7 +10,8 @@
- Added many types of integrals - Added many types of integrals
- Accelerated four-index transformation - Accelerated four-index transformation
- Added transcorrelated SCF - Added transcorrelated SCF
- Added transcorrelated CIPSI - Added bi-orthonormal transcorrelated CIPSI
- Added Cholesky decomposition of AO integrals
- Added CCSD and CCSD(T) - Added CCSD and CCSD(T)
- Added MO localization - Added MO localization
- Changed coupling parameters for ROHF - Changed coupling parameters for ROHF
@ -20,7 +21,7 @@
- Removed cryptokit dependency in OCaml - Removed cryptokit dependency in OCaml
- Using now standard convention in RDM - Using now standard convention in RDM
- Added molecular properties - Added molecular properties
- [ ] Added GTOs with complex exponent - Added GTOs with complex exponent
*** TODO: take from dev *** TODO: take from dev
- Updated version of f77-zmq - Updated version of f77-zmq

2
bin/qp_reset
View File

@ -97,6 +97,8 @@ if [[ $dets -eq 1 ]] ; then
rm --force -- ${ezfio}/determinants/psi_{det,coef}.gz rm --force -- ${ezfio}/determinants/psi_{det,coef}.gz
rm --force -- ${ezfio}/determinants/n_det_qp_edit rm --force -- ${ezfio}/determinants/n_det_qp_edit
rm --force -- ${ezfio}/determinants/psi_{det,coef}_qp_edit.gz rm --force -- ${ezfio}/determinants/psi_{det,coef}_qp_edit.gz
rm --force -- ${ezfio}/tc_bi_ortho/psi_{l,r}_coef_bi_ortho.gz
fi fi
if [[ $mos -eq 1 ]] ; then if [[ $mos -eq 1 ]] ; then

62
config/flang_avx.cfg Normal file
View 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 : flang -ffree-line-length-none -I . -mavx -g -fPIC
LAPACK_LIB : -llapack -lblas
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 -mavx
# 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

62
config/gfortran10.cfg Normal file
View 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-10 -g -ffree-line-length-none -I . -fPIC
LAPACK_LIB : -lblas -llapack
IRPF90 : irpf90
IRPF90_FLAGS : --ninja --align=32 --assert -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
####################
#
# -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 -msse4.2 -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

2
config/gfortran_armpl.cfg
View File

@ -14,7 +14,7 @@
# #
[COMMON] [COMMON]
FC : gfortran -g -ffree-line-length-none -I . -fPIC -march=native FC : gfortran -g -ffree-line-length-none -I . -fPIC -march=native
LAPACK_LIB : -larmpl_lp64 LAPACK_LIB : -larmpl_lp64_mp
IRPF90 : irpf90 IRPF90 : irpf90
IRPF90_FLAGS : --ninja --align=32 --assert -DSET_NESTED IRPF90_FLAGS : --ninja --align=32 --assert -DSET_NESTED

62
config/gfortran_mpi_mkl.cfg Normal file
View 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 : mpif90 -ffree-line-length-none -I . -g -fPIC -std=legacy
LAPACK_LIB : -lblas -llapack
IRPF90 : irpf90
IRPF90_FLAGS : --ninja --align=32 -DMPI -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 -msse4.2
# Profiling flags
#################
#
[PROFILE]
FC : -p -g
FCFLAGS : -Ofast -msse4.2
# 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

63
config/ifort_2019_avx_notz.cfg Normal file
View File

@ -0,0 +1,63 @@
# 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
IRPF90 : irpf90
IRPF90_FLAGS : --ninja --align=32 --define=WITHOUT_TRAILZ --define=WITHOUT_SHIFTRL -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
####################
#
# -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 : -xAVX -O2 -ip -ftz -g
# Profiling flags
#################
#
[PROFILE]
FC : -p -g
FCFLAGS : -xSSE4.2 -O2 -ip -ftz
# Debugging flags
#################
#
# -traceback : Activate backtrace on runtime
# -fpe0 : All floating point exaceptions
# -C : Checks uninitialized variables, array subscripts, etc...
# -g : Extra debugging information
# -xSSE2 : Valgrind needs a very simple x86 executable
#
[DEBUG]
FC : -g -traceback
FCFLAGS : -xSSE2 -C -fpe0 -implicitnone
# OpenMP flags
#################
#
[OPENMP]
FC : -qopenmp
IRPF90_FLAGS : --openmp

2
config/ifort_2019_debug.cfg
View File

@ -7,7 +7,7 @@
# #
[COMMON] [COMMON]
FC : ifort -fpic FC : ifort -fpic
LAPACK_LIB : -mkl=parallel -lirc -lsvml -limf -lipps LAPACK_LIB : -mkl=parallel
IRPF90 : irpf90 IRPF90 : irpf90
IRPF90_FLAGS : --ninja --align=32 --assert -DINTEL -DSET_NESTED IRPF90_FLAGS : --ninja --align=32 --assert -DINTEL -DSET_NESTED

63
config/ifort_2021_avx_notz.cfg Normal file
View File

@ -0,0 +1,63 @@
# 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
IRPF90 : irpf90
IRPF90_FLAGS : --ninja --align=32 --define=WITHOUT_TRAILZ --define=WITHOUT_SHIFTRL
# 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
####################
#
# -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 : -xAVX -O2 -ip -ftz -g
# Profiling flags
#################
#
[PROFILE]
FC : -p -g
FCFLAGS : -xSSE4.2 -O2 -ip -ftz
# Debugging flags
#################
#
# -traceback : Activate backtrace on runtime
# -fpe0 : All floating point exaceptions
# -C : Checks uninitialized variables, array subscripts, etc...
# -g : Extra debugging information
# -xSSE2 : Valgrind needs a very simple x86 executable
#
[DEBUG]
FC : -g -traceback
FCFLAGS : -xSSE2 -C -fpe0 -implicitnone
# OpenMP flags
#################
#
[OPENMP]
FC : -qopenmp
IRPF90_FLAGS : --openmp

66
config/ifort_2021_debug.cfg Normal file
View 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
IRPF90 : irpf90
IRPF90_FLAGS : --ninja --align=32 --assert -DINTEL
# 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

46
configure vendored
View File

@ -191,7 +191,7 @@ if [[ "${PACKAGES}.x" != ".x" ]] ; then
fi fi
if [[ ${PACKAGES} = all ]] ; then if [[ ${PACKAGES} = all ]] ; then
PACKAGES="zlib ninja zeromq f77zmq gmp ocaml docopt resultsFile bats trexio" PACKAGES="zlib ninja zeromq f77zmq gmp ocaml docopt resultsFile bats trexio qmckl"
fi fi
@ -211,11 +211,11 @@ EOF
execute << EOF execute << EOF
cd "\${QP_ROOT}"/external cd "\${QP_ROOT}"/external
wget https://github.com/TREX-CoE/trexio/releases/download/v${VERSION}/trexio-${VERSION}.tar.gz wget https://github.com/TREX-CoE/trexio/releases/download/v${VERSION}/trexio-${VERSION}.tar.gz
tar -zxf trexio-${VERSION}.tar.gz rm -rf trexio-${VERSION}
tar -zxf trexio-${VERSION}.tar.gz && rm trexio-${VERSION}.tar.gz
cd trexio-${VERSION} cd trexio-${VERSION}
./configure --prefix=\${QP_ROOT} --without-hdf5 ./configure --prefix=\${QP_ROOT} --without-hdf5 CFLAGS='-g'
make -j 8 && make -j 8 check && make -j 8 install make -j 8 && make -j 8 check && make -j 8 install
cp ${QP_ROOT}/include/trexio_f.f90 ${QP_ROOT}/src/ezfio_files
tar -zxvf "\${QP_ROOT}"/external/qp2-dependencies/${ARCHITECTURE}/ninja.tar.gz tar -zxvf "\${QP_ROOT}"/external/qp2-dependencies/${ARCHITECTURE}/ninja.tar.gz
mv ninja "\${QP_ROOT}"/bin/ mv ninja "\${QP_ROOT}"/bin/
EOF EOF
@ -225,11 +225,35 @@ EOF
execute << EOF execute << EOF
cd "\${QP_ROOT}"/external cd "\${QP_ROOT}"/external
wget https://github.com/TREX-CoE/trexio/releases/download/v${VERSION}/trexio-${VERSION}.tar.gz wget https://github.com/TREX-CoE/trexio/releases/download/v${VERSION}/trexio-${VERSION}.tar.gz
tar -zxf trexio-${VERSION}.tar.gz rm -rf trexio-${VERSION}
tar -zxf trexio-${VERSION}.tar.gz && rm trexio-${VERSION}.tar.gz
cd trexio-${VERSION} cd trexio-${VERSION}
./configure --prefix=\${QP_ROOT} ./configure --prefix=\${QP_ROOT} CFLAGS="-g"
make -j 8 && make -j 8 check && make -j 8 install make -j 8 && make -j 8 check && make -j 8 install
cp ${QP_ROOT}/include/trexio_f.f90 ${QP_ROOT}/src/ezfio_files EOF
elif [[ ${PACKAGE} = qmckl ]] ; then
VERSION=0.5.4
execute << EOF
cd "\${QP_ROOT}"/external
wget https://github.com/TREX-CoE/qmckl/releases/download/v${VERSION}/qmckl-${VERSION}.tar.gz
rm -rf qmckl-${VERSION}
tar -zxf qmckl-${VERSION}.tar.gz && rm qmckl-${VERSION}.tar.gz
cd qmckl-${VERSION}
./configure --prefix=\${QP_ROOT} --enable-hpc --disable-doc CFLAGS='-g'
make && make -j 4 check && make install
EOF
elif [[ ${PACKAGE} = qmckl-intel ]] ; then
VERSION=0.5.4
execute << EOF
cd "\${QP_ROOT}"/external
wget https://github.com/TREX-CoE/qmckl/releases/download/v${VERSION}/qmckl-${VERSION}.tar.gz
rm -rf qmckl-${VERSION}
tar -zxf qmckl-${VERSION}.tar.gz && rm qmckl-${VERSION}.tar.gz
cd qmckl-${VERSION}
./configure --prefix=\${QP_ROOT} --enable-hpc --disable-doc --with-icc --with-ifort CFLAGS='-g'
make && make -j 4 check && make install
EOF EOF
@ -369,7 +393,13 @@ fi
TREXIO=$(find_lib -ltrexio) TREXIO=$(find_lib -ltrexio)
if [[ ${TREXIO} = $(not_found) ]] ; then if [[ ${TREXIO} = $(not_found) ]] ; then
error "TREXIO (trexio,trexio-nohdf5) is not installed. If you don't have HDF5, use trexio-nohdf5" error "TREXIO (trexio | trexio-nohdf5) is not installed. If you don't have HDF5, use trexio-nohdf5"
fail
fi
QMCKL=$(find_lib -lqmckl)
if [[ ${QMCKL} = $(not_found) ]] ; then
error "QMCkl (qmckl | qmckl-intel) is not installed."
fail fail
fi fi

696
data/basis/cc-pv5z_ecp_bfd
View File

File diff suppressed because it is too large Load Diff

920
data/pseudo/def2 Normal file
View File

@ -0,0 +1,920 @@
$ECP
RB-ECP GEN 28 3
1 ----- f-ul potential -----
-12.3169000 2 3.8431140
3 ----- s-f potential -----
89.5001980 2 5.0365510
0.4937610 2 1.9708490
12.3169000 2 3.8431140
3 ----- p-f potential -----
58.5689740 2 4.2583410
0.4317910 2 1.4707090
12.3169000 2 3.8431140
3 ----- d-f potential -----
26.2248980 2 3.0231270
0.9628390 2 0.6503830
12.3169000 2 3.8431140
SR-ECP GEN 28 3
1 ----- f-ul potential -----
-15.8059920 2 4.6339750
3 ----- s-f potential -----
135.4794300 2 7.4000740
17.5344630 2 3.6063790
15.8059920 2 4.6339750
3 ----- p-f potential -----
88.3597090 2 6.4848680
15.3943720 2 3.2880530
15.8059920 2 4.6339750
3 ----- d-f potential -----
29.8889870 2 4.6228410
6.6594140 2 2.2469040
15.8059920 2 4.6339750
Y-ECP GEN 28 3
2 ----- f-ul potential -----
-19.12219811 2 6.5842120
-2.43637543 2 3.2921060
4 ----- s-f potential -----
135.15384412 2 7.4880494
15.55244130 2 3.7440247
19.12219811 2 6.5842120
2.43637543 2 3.2921060
4 ----- p-f potential -----
87.78499167 2 6.4453772
11.56406599 2 3.2226886
19.12219811 2 6.5842120
2.43637543 2 3.2921060
4 ----- d-f potential -----
29.70100072 2 4.6584472
5.53996847 2 2.3292236
19.12219811 2 6.5842120
2.43637543 2 3.2921060
ZR-ECP GEN 28 3
2 ----- f-ul potential -----
-21.09377605 2 7.5400000
-3.08069427 2 3.7700000
4 ----- s-f potential -----
150.26759106 2 8.2000000
18.97621650 2 4.0897278
21.09377605 2 7.5400000
3.08069427 2 3.7700000
4 ----- p-f potential -----
99.62212372 2 7.1100000
14.16873329 2 3.5967980
21.09377605 2 7.5400000
3.08069427 2 3.7700000
4 ----- d-f potential -----
35.04512355 2 5.3500000
6.11125948 2 2.4918215
21.09377605 2 7.5400000
3.08069427 2 3.7700000
NB-ECP GEN 28 3
2 ----- f-ul potential -----
-22.92954996 2 8.4900000
-3.66630986 2 4.2500000
4 ----- s-f potential -----
165.17914349 2 8.9000000
21.99297437 2 4.4300000
22.92954996 2 8.4900000
3.66630986 2 4.2500000
4 ----- p-f potential -----
111.79441445 2 7.7700000
16.63348326 2 3.9600000
22.92954996 2 8.4900000
3.66630986 2 4.2500000
4 ----- d-f potential -----
38.11224880 2 6.0500000
8.03916727 2 2.8400000
22.92954996 2 8.4900000
3.66630986 2 4.2500000
MO-ECP GEN 28 3
2 ----- f-ul potential -----
-24.80517707 2 9.4500000
-4.15378155 2 4.7200000
4 ----- s-f potential -----
180.10310850 2 9.7145938
24.99722791 2 4.6805004
24.80517707 2 9.4500000
4.15378155 2 4.7200000
4 ----- p-f potential -----
123.77275231 2 8.1421366
19.53022800 2 4.6259863
24.80517707 2 9.4500000
4.15378155 2 4.7200000
4 ----- d-f potential -----
48.37502229 2 6.6184148
8.89205274 2 3.2487516
24.80517707 2 9.4500000
4.15378155 2 4.7200000
TC-ECP GEN 28 3
2 ----- f-ul potential -----
-26.56244747 2 10.4000000
-4.58568054 2 5.2000000
4 ----- s-f potential -----
195.15916591 2 10.4223462
28.09260333 2 5.0365160
26.56244747 2 10.4000000
4.58568054 2 5.2000000
4 ----- p-f potential -----
135.28456622 2 8.9504494
21.80650430 2 4.8544394
26.56244747 2 10.4000000
4.58568054 2 5.2000000
4 ----- d-f potential -----
54.32972942 2 6.9456968
11.15506795 2 3.9705849
26.56244747 2 10.4000000
4.58568054 2 5.2000000
RU-ECP GEN 28 3
2 ----- f-ul potential -----
-28.34061627 2 11.3600000
-4.94462923 2 5.6800000
4 ----- s-f potential -----
209.82297122 2 11.1052693
30.65472642 2 5.4147454
28.34061627 2 11.3600000
4.94462923 2 5.6800000
4 ----- p-f potential -----
146.33618228 2 9.7712707
24.12787723 2 5.0739908
28.34061627 2 11.3600000
4.94462923 2 5.6800000
4 ----- d-f potential -----
67.51589667 2 7.6714231
9.87010415 2 4.1365647
28.34061627 2 11.3600000
4.94462923 2 5.6800000
RH-ECP GEN 28 3
2 ----- f-ul potential -----
-30.09345572 2 12.3100000
-5.21848192 2 6.1600000
4 ----- s-f potential -----
225.34775353 2 11.7200000
32.82318898 2 5.8200000
30.09345572 2 12.3100000
5.21848192 2 6.1600000
4 ----- p-f potential -----
158.70941159 2 10.4200000
26.44410049 2 5.4500000
30.09345572 2 12.3100000
5.21848192 2 6.1600000
4 ----- d-f potential -----
62.75862572 2 8.8200000
10.97871947 2 3.8700000
30.09345572 2 12.3100000
5.21848192 2 6.1600000
PD-ECP GEN 28 3
2 ----- f-ul potential -----
-31.92955431 2 13.2700000
-5.39821694 2 6.6300000
4 ----- s-f potential -----
240.22904033 2 12.4300000
35.17194347 2 6.1707594
31.92955431 2 13.2700000
5.39821694 2 6.6300000
4 ----- p-f potential -----
170.41727605 2 11.0800000
28.47213287 2 5.8295541
31.92955431 2 13.2700000
5.39821694 2 6.6300000
4 ----- d-f potential -----
69.01384488 2 9.5100000
11.75086158 2 4.1397811
31.92955431 2 13.2700000
5.39821694 2 6.6300000
AG-ECP GEN 28 3
2 ----- f-ul potential -----
-33.68992012 2 14.2200000
-5.53112021 2 7.1100000
4 ----- s-f potential -----
255.13936452 2 13.1300000
36.86612154 2 6.5100000
33.68992012 2 14.2200000
5.53112021 2 7.1100000
4 ----- p-f potential -----
182.18186871 2 11.7400000
30.35775148 2 6.2000000
33.68992012 2 14.2200000
5.53112021 2 7.1100000
4 ----- d-f potential -----
73.71926087 2 10.2100000
12.50211712 2 4.3800000
33.68992012 2 14.2200000
5.53112021 2 7.1100000
CD-ECP GEN 28 3
2 ----- f-ul potential -----
-35.47662555 2 15.1847957
-5.61767685 2 7.5923978
4 ----- s-f potential -----
270.00948324 2 13.8358689
38.76730798 2 6.8572704
35.47662555 2 15.1847957
5.61767685 2 7.5923978
4 ----- p-f potential -----
193.82962939 2 12.4049710
31.89652523 2 6.5677995
35.47662555 2 15.1847957
5.61767685 2 7.5923978
4 ----- d-f potential -----
79.19364700 2 10.8969253
13.23082674 2 4.6411649
35.47662555 2 15.1847957
5.61767685 2 7.5923978
IN-ECP GEN 28 3
2 ----- f-ul potential -----
-13.72807800 2 12.53905600
-18.20686600 2 12.55256100
4 ----- s-f potential -----
281.12235000 2 15.39282200
61.90147000 2 8.05586400
13.72807800 2 12.53905600
18.20686600 2 12.55256100
6 ----- p-f potential -----
67.46215400 2 13.92867200
134.94925000 2 13.34723400
14.74614000 2 7.61413200
29.63926200 2 7.31836500
13.72807800 2 12.53905600
18.20686600 2 12.55256100
6 ----- d-f potential -----
35.49325400 2 14.03471500
53.17877300 2 14.51161600
9.17728100 2 5.55055000
12.39241000 2 5.05941500
13.72807800 2 12.53905600
18.20686600 2 12.55256100
SN-ECP GEN 28 3
2 ----- f-ul potential -----
-12.57633300 2 12.28234800
-16.59594400 2 12.27215000
4 ----- s-f potential -----
279.98868200 2 17.42041400
62.37781000 2 7.63115500
12.57633300 2 12.28234800
16.59594400 2 12.27215000
6 ----- p-f potential -----
66.16252300 2 16.13102400
132.17439600 2 15.62807700
16.33941700 2 7.32560800
32.48895900 2 6.94251900
12.57633300 2 12.28234800
16.59594400 2 12.27215000
6 ----- d-f potential -----
36.38744100 2 15.51497600
54.50784100 2 15.18816000
8.69682300 2 5.45602400
12.84020800 2 5.36310500
12.57633300 2 12.28234800
16.59594400 2 12.27215000
SB-ECP GEN 28 3
2 ----- f-ul potential -----
-15.36680100 2 14.44497800
-20.29613800 2 14.44929500
4 ----- s-f potential -----
281.07158100 2 16.33086500
61.71660400 2 8.55654200
15.36680100 2 14.44497800
20.29613800 2 14.44929500
6 ----- p-f potential -----
67.45738000 2 14.47033700
134.93350300 2 13.81619400
14.71634400 2 8.42492400
29.51851200 2 8.09272800
15.36680100 2 14.44497800
20.29613800 2 14.44929500
6 ----- d-f potential -----
35.44781500 2 14.88633100
53.14346600 2 15.14631900
9.17922300 2 5.90826700
13.24025300 2 5.59432200
15.36680100 2 14.44497800
20.29613800 2 14.44929500
TE-ECP GEN 28 3
2 ----- f-ul potential -----
-15.74545000 2 15.20616800
-20.74244800 2 15.20170200
4 ----- s-f potential -----
281.04584300 2 16.81447300
61.62065600 2 8.79352600
15.74545000 2 15.20616800
20.74244800 2 15.20170200
6 ----- p-f potential -----
67.44946400 2 14.87780100
134.90430400 2 14.26973100
14.68954700 2 8.72443500
29.41506300 2 8.29151500
15.74545000 2 15.20616800
20.74244800 2 15.20170200
6 ----- d-f potential -----
35.43205700 2 15.20500800
53.13568700 2 15.22584800
9.06980200 2 6.07176900
13.12230400 2 5.80476000
15.74545000 2 15.20616800
20.74244800 2 15.20170200
I-ECP GEN 28 3
4 ----- f-ul potential -----
-21.84204000 2 19.45860900
-28.46819100 2 19.34926000
-0.24371300 2 4.82376700
-0.32080400 2 4.88431500
7 ----- s-f potential -----
49.99429300 2 40.01583500
281.02531700 2 17.42974700
61.57332600 2 9.00548400
21.84204000 2 19.45860900
28.46819100 2 19.34926000
0.24371300 2 4.82376700
0.32080400 2 4.88431500
8 ----- p-f potential -----
67.44284100 2 15.35546600
134.88113700 2 14.97183300
14.67505100 2 8.96016400
29.37566600 2 8.25909600
21.84204000 2 19.45860900
28.46819100 2 19.34926000
0.24371300 2 4.82376700
0.32080400 2 4.88431500
10 ----- d-f potential -----
35.43952900 2 15.06890800
53.17605700 2 14.55532200
9.06719500 2 6.71864700
13.20693700 2 6.45639300
0.08933500 2 1.19177900
0.05238000 2 1.29115700
21.84204000 2 19.45860900
28.46819100 2 19.34926000
0.24371300 2 4.82376700
0.32080400 2 4.88431500
XE-ECP GEN 28 3
4 ----- f-ul potential -----
-23.08929500 2 20.88155700
-30.07447500 2 20.78344300
-0.28822700 2 5.25338900
-0.38692400 2 5.36118800
7 ----- s-f potential -----
49.99796200 2 40.00518400
281.01330300 2 17.81221400
61.53825500 2 9.30415000
23.08929500 2 20.88155700
30.07447500 2 20.78344300
0.28822700 2 5.25338900
0.38692400 2 5.36118800
8 ----- p-f potential -----
67.43914200 2 15.70177200
134.87471100 2 15.25860800
14.66330000 2 9.29218400
29.35473000 2 8.55900300
23.08929500 2 20.88155700
30.07447500 2 20.78344300
0.28822700 2 5.25338900
0.38692400 2 5.36118800
10 ----- d-f potential -----
35.43690800 2 15.18560000
53.19577200 2 14.28450000
9.04623200 2 7.12188900
13.22368100 2 6.99196300
0.08485300 2 0.62394600
0.04415500 2 0.64728400
23.08929500 2 20.88155700
30.07447500 2 20.78344300
0.28822700 2 5.25338900
0.38692400 2 5.36118800
CS-ECP GEN 46 3
1 ----- f-ul potential -----
-28.8843090 2 3.1232690
3 ----- s-f potential -----
84.5477300 2 4.0797500
16.6541730 2 2.4174060
28.8843090 2 3.1232690
3 ----- p-f potential -----
157.0490590 2 5.5140800
26.4233070 2 2.1603160
28.8843090 2 3.1232690
3 ----- d-f potential -----
13.1727530 2 1.8074100
3.3428330 2 0.8581820
28.8843090 2 3.1232690
BA-ECP GEN 46 3
1 ----- f-ul potential -----
-33.4731740 2 3.5894650
3 ----- s-f potential -----
427.8458160 2 9.5269860
204.4175300 2 4.4875100
33.4731740 2 3.5894650
3 ----- p-f potential -----
293.6058640 2 8.3159300
294.1933160 2 4.2922170
33.4731740 2 3.5894650
3 ----- d-f potential -----
112.5504020 2 5.9161080
181.7826210 2 2.8748420
33.4731740 2 3.5894650
LA-ECP GEN 46 3
1 ----- f-ul potential -----
-36.0100160 2 4.0286000
3 ----- s-f potential -----
91.9321770 2 3.3099000
-3.7887640 2 1.6550000
36.0100160 2 4.0286000
3 ----- p-f potential -----
63.7594860 2 2.8368000
-0.6479580 2 1.4184000
36.0100160 2 4.0286000
3 ----- d-f potential -----
36.1161730 2 2.0213000
0.2191140 2 1.0107000
36.0100160 2 4.0286000
CE-ECP GEN 28 5
1 ----- h-ul potential -----
0.00000000 2 1.00000000
1 ----- s-h potential -----
580.08345700 2 20.13782900
1 ----- p-h potential -----
310.30283300 2 15.99848200
1 ----- d-h potential -----
167.81394400 2 14.97418700
1 ----- f-h potential -----
-49.39022900 2 23.40245500
1 ----- g-h potential -----
-21.33187900 2 16.57055300
PR-ECP GEN 28 5
1 ----- h-ul potential -----
0.00000000 2 1.00000000
1 ----- s-h potential -----
577.57312200 2 20.76627800
1 ----- p-h potential -----
295.78584600 2 16.07844800
1 ----- d-h potential -----
150.86705500 2 14.70508900
1 ----- f-h potential -----
-48.73676600 2 23.37896900
1 ----- g-h potential -----
-22.32948800 2 17.44713800
ND-ECP GEN 28 5
1 ----- h-ul potential -----
0.00000000 2 1.00000000
1 ----- s-h potential -----
574.37098000 2 21.35226700
1 ----- p-h potential -----
280.94644000 2 16.11926500
1 ----- d-h potential -----
138.67062700 2 14.49410300
1 ----- f-h potential -----
-47.52266800 2 23.18386000
1 ----- g-h potential -----
-23.34458700 2 18.34417400
PM-ECP GEN 28 5
1 ----- h-ul potential -----
0.00000000 2 1.00000000
1 ----- s-h potential -----
575.39574900 2 21.94286500
1 ----- p-h potential -----
281.70451400 2 16.55516100
1 ----- d-h potential -----
123.52473700 2 13.96030800
1 ----- f-h potential -----
-50.74151100 2 24.03354600
1 ----- g-h potential -----
-24.37251000 2 19.26024500
SM-ECP GEN 28 5
1 ----- h-ul potential -----
0.00000000 2 1.00000000
1 ----- s-h potential -----
572.98533200 2 22.34447100
1 ----- p-h potential -----
272.35914500 2 16.69459000
1 ----- d-h potential -----
115.29390000 2 13.72770500
1 ----- f-h potential -----
-51.10839200 2 24.05909200
1 ----- g-h potential -----
-25.42188500 2 20.19724900
EU-ECP GEN 28 5
1 ----- h-ul potential -----
0.00000000 2 1.00000000
1 ----- s-h potential -----
607.65933100 2 23.47138400
1 ----- p-h potential -----
264.38547600 2 16.77247900
1 ----- d-h potential -----
115.38137500 2 13.98134300
1 ----- f-h potential -----
-49.40079400 2 23.96288800
1 ----- g-h potential -----
-26.74827300 2 21.23245800
GD-ECP GEN 28 5
1 ----- h-ul potential -----
0.00000000 2 1.00000000
1 ----- s-h potential -----
637.20086900 2 24.60215100
1 ----- p-h potential -----
261.68960100 2 16.88925000
1 ----- d-h potential -----
106.85653300 2 13.64335800
1 ----- f-h potential -----
-50.68359000 2 24.12691700
1 ----- g-h potential -----
-27.57963000 2 22.13188700
TB-ECP GEN 28 5
1 ----- h-ul potential -----
0.00000000 2 1.00000000
1 ----- s-h potential -----
668.59715500 2 24.95295600
1 ----- p-h potential -----
266.98047500 2 17.61089900
1 ----- d-h potential -----
97.50659600 2 12.97600900
1 ----- f-h potential -----
-52.17575700 2 24.24886900
1 ----- g-h potential -----
-28.69426800 2 23.13067200
DY-ECP GEN 28 5
1 ----- h-ul potential -----
0.00000000 2 1.00000000
1 ----- s-h potential -----
705.67122100 2 26.42958600
1 ----- p-h potential -----
254.86698900 2 17.31703400
1 ----- d-h potential -----
95.04518700 2 12.91359900
1 ----- f-h potential -----
-54.57409300 2 24.90787800
1 ----- g-h potential -----
-29.82827700 2 24.14875300
HO-ECP GEN 28 5
1 ----- h-ul potential -----
0.00000000 2 1.00000000
1 ----- s-h potential -----
755.70313600 2 28.39725700
1 ----- p-h potential -----
253.55199800 2 17.43863300
1 ----- d-h potential -----
89.63567700 2 12.43421200
1 ----- f-h potential -----
-55.48203600 2 25.38701000
1 ----- g-h potential -----
-30.99112500 2 25.18850100
ER-ECP GEN 28 5
1 ----- h-ul potential -----
0.00000000 2 1.00000000
1 ----- s-h potential -----
800.95287600 2 29.79859200
1 ----- p-h potential -----
262.01986900 2 18.11423700
1 ----- d-h potential -----
80.17055200 2 11.36958700
1 ----- f-h potential -----
-42.33628500 2 21.82123300
1 ----- g-h potential -----
-32.18527800 2 26.25073500
TM-ECP GEN 28 5
1 ----- h-ul potential -----
0.00000000 2 1.00000000
1 ----- s-h potential -----
845.51074300 2 31.14412200
1 ----- p-h potential -----
258.58523900 2 18.09235300
1 ----- d-h potential -----
80.72905900 2 11.46915900
1 ----- f-h potential -----
-48.70126600 2 23.60554400
1 ----- g-h potential -----
-33.39549600 2 27.32978100
YB-ECP GEN 28 5
1 ----- h-ul potential -----
0.00000000 2 1.00000000
1 ----- s-h potential -----
891.01377700 2 32.42448400
1 ----- p-h potential -----
264.03695300 2 18.65623200
1 ----- d-h potential -----
73.92391900 2 10.49022200
1 ----- f-h potential -----
-39.59217300 2 20.77418300
1 ----- g-h potential -----
-34.63863800 2 28.43102800
LU-ECP GEN 28 5
1 ----- h-ul potential -----
0.00000000 2 1.00000000
1 ----- s-h potential -----
989.99558400 2 35.16209700
1 ----- p-h potential -----
278.86565200 2 19.46440200
1 ----- d-h potential -----
71.00917800 2 10.00686500
1 ----- f-h potential -----
-47.40589000 2 23.51793200
1 ----- g-h potential -----
-35.55714600 2 29.41223800
HF-ECP GEN 60 3
1 ----- f-ul potential -----
10.04672251 2 1.78576984
3 ----- s-f potential -----
1499.28471073 2 14.76995900
40.28210136 2 7.38497940
-10.04672251 2 1.78576984
3 ----- p-f potential -----
397.73300533 2 9.84948950
19.31640586 2 4.92474450
-10.04672251 2 1.78576984
3 ----- d-f potential -----
101.32980526 2 6.09675640
5.87343821 2 3.04837820
-10.04672251 2 1.78576984
TA-ECP GEN 60 3
1 ----- f-ul potential -----
12.01796094 2 2.01788111
3 ----- s-f potential -----
1345.88064703 2 14.54640770
36.76680620 2 7.27320380
-12.01796094 2 2.01788111
3 ----- p-f potential -----
378.42530145 2 9.93556529
22.29309086 2 4.96778243
-12.01796094 2 2.01788111
3 ----- d-f potential -----
104.88395571 2 6.34737691
8.75584805 2 3.17368846
-12.01796094 2 2.01788111
W-ECP GEN 60 3
1 ----- f-ul potential -----
14.15257947 2 2.25888846
3 ----- s-f potential -----
1192.39588226 2 14.32285640
32.52293315 2 7.16142810
-14.15257947 2 2.25888846
3 ----- p-f potential -----
359.03196711 2 10.02164110
24.03038019 2 5.01082040
-14.15257947 2 2.25888846
3 ----- d-f potential -----
108.30134897 2 6.59799743
10.98252827 2 3.29899871
-14.15257947 2 2.25888846
RE-ECP GEN 60 3
1 ----- f-ul potential -----
16.44985227 2 2.50865059
3 ----- s-f potential -----
1038.95157226 2 14.09930510
29.56173830 2 7.04965250
-16.44985227 2 2.50865059
3 ----- p-f potential -----
339.54350965 2 10.10771690
24.91369646 2 5.05385830
-16.44985227 2 2.50865059
3 ----- d-f potential -----
111.69965275 2 6.84861794
12.62432927 2 3.42430897
-16.44985227 2 2.50865059
OS-ECP GEN 60 3
1 ----- f-ul potential -----
18.90945701 2 2.76707510
3 ----- s-f potential -----
885.40571914 2 13.87575390
25.96704014 2 6.93787690
-18.90945701 2 2.76707510
3 ----- p-f potential -----
320.08390185 2 10.19379260
26.14876493 2 5.09689620
-18.90945701 2 2.76707510
3 ----- d-f potential -----
115.04484313 2 7.09923846
13.62257457 2 3.54961923
-18.90945701 2 2.76707510
IR-ECP GEN 60 3
1 ----- f-ul potential -----
21.53103107 2 3.03407192
3 ----- s-f potential -----
732.26919978 2 13.65220260
26.48472087 2 6.82610130
-21.53103107 2 3.03407192
3 ----- p-f potential -----
299.48947357 2 10.27986840
26.46623354 2 5.13993410
-21.53103107 2 3.03407192
3 ----- d-f potential -----
124.45759451 2 7.34985897
14.03599518 2 3.67492949
-21.53103107 2 3.03407192
PT-ECP GEN 60 3
1 ----- f-ul potential -----
24.31437573 2 3.30956857
3 ----- s-f potential -----
579.22386092 2 13.42865130
29.66949062 2 6.71432560
-24.31437573 2 3.30956857
3 ----- p-f potential -----
280.86077422 2 10.36594420
26.74538204 2 5.18297210
-24.31437573 2 3.30956857
3 ----- d-f potential -----
120.39644429 2 7.60047949
15.81092058 2 3.80023974
-24.31437573 2 3.30956857
AU-ECP GEN 60 3
2 ----- f-ul potential -----
30.49008890 2 4.78982000
5.17107381 2 2.39491000
4 ----- s-f potential -----
426.84667920 2 13.20510000
37.00708285 2 6.60255000
-30.49008890 2 4.78982000
-5.17107381 2 2.39491000
4 ----- p-f potential -----
261.19958038 2 10.45202000
26.96249604 2 5.22601000
-30.49008890 2 4.78982000
-5.17107381 2 2.39491000
4 ----- d-f potential -----
124.79066561 2 7.85110000
16.30072573 2 3.92555000
-30.49008890 2 4.78982000
-5.17107381 2 2.39491000
HG-ECP GEN 60 3
1 ----- f-ul potential -----
30.36499643 2 3.88579112
3 ----- s-f potential -----
275.73721174 2 12.98154870
49.08921249 2 6.49077440
-30.36499643 2 3.88579112
3 ----- p-f potential -----
241.54007398 2 10.53809580
27.39659081 2 5.26904790
-30.36499643 2 3.88579112
3 ----- d-f potential -----
127.86700761 2 8.10172051
16.60831151 2 4.05086026
-30.36499643 2 3.88579112
TL-ECP GEN 60 3
4 ----- f-ul potential -----
15.82548800 2 5.62639900
21.10402100 2 5.54895200
2.91512700 2 2.87494600
3.89690300 2 2.82145100
6 ----- s-f potential -----
281.28466300 2 12.16780500
62.43425100 2 8.29490900
-15.82548800 2 5.62639900
-21.10402100 2 5.54895200
-2.91512700 2 2.87494600
-3.89690300 2 2.82145100
8 ----- p-f potential -----
4.63340800 2 7.15149200
9.34175600 2 5.17286500
72.29925300 2 9.89107200
144.55803700 2 9.00339100
-15.82548800 2 5.62639900
-21.10402100 2 5.54895200
-2.91512700 2 2.87494600
-3.89690300 2 2.82145100
8 ----- d-f potential -----
35.94303900 2 7.13021800
53.90959300 2 6.92690600
10.38193900 2 5.41757000
15.58382200 2 5.13868100
-15.82548800 2 5.62639900
-21.10402100 2 5.54895200
-2.91512700 2 2.87494600
-3.89690300 2 2.82145100
PB-ECP GEN 60 3
2 ----- f-ul potential -----
12.20989200 2 3.88751200
16.19029100 2 3.81196300
4 ----- s-f potential -----
281.28549900 2 12.29630300
62.52021700 2 8.63263400
-12.20989200 2 3.88751200
-16.19029100 2 3.81196300
6 ----- p-f potential -----
72.27689700 2 10.24179000
144.59108300 2 8.92417600
4.75869300 2 6.58134200
9.94062100 2 6.25540300
-12.20989200 2 3.88751200
-16.19029100 2 3.81196300
6 ----- d-f potential -----
35.84850700 2 7.75433600
53.72434200 2 7.72028100
10.11525600 2 4.97026400
14.83373100 2 4.56378900
-12.20989200 2 3.88751200
-16.19029100 2 3.81196300
BI-ECP GEN 60 3
2 ----- f-ul potential -----
13.71338300 2 4.21454600
18.19430800 2 4.13340000
4 ----- s-f potential -----
283.26422700 2 13.04309000
62.47195900 2 8.22168200
-13.71338300 2 4.21454600
-18.19430800 2 4.13340000
6 ----- p-f potential -----
72.00149900 2 10.46777700
144.00227700 2 9.11890100
5.00794500 2 6.75479100
9.99155000 2 6.25259200
-13.71338300 2 4.21454600
-18.19430800 2 4.13340000
6 ----- d-f potential -----
36.39625900 2 8.08147400
54.59766400 2 7.89059500
9.98429400 2 4.95555600
14.98148500 2 4.70455900
-13.71338300 2 4.21454600
-18.19430800 2 4.13340000
PO-ECP GEN 60 3
4 ----- f-ul potential -----
17.42829500 2 5.01327000
23.38035300 2 4.98464000
0.16339200 2 1.32676000
0.32456600 2 1.52875800
6 ----- s-f potential -----
283.24470600 2 13.27722700
62.39646100 2 8.39951800
-17.42829500 2 5.01327000
-23.38035300 2 4.98464000
-0.16339200 2 1.32676000
-0.32456600 2 1.52875800
8 ----- p-f potential -----
71.99171600 2 10.66568200
143.97187100 2 9.28375300
4.94961500 2 6.87274900
9.74049900 2 6.32615000
-17.42829500 2 5.01327000
-23.38035300 2 4.98464000
-0.16339200 2 1.32676000
-0.32456600 2 1.52875800
8 ----- d-f potential -----
36.37838300 2 8.21486600
54.56271500 2 8.00869600
9.88949900 2 5.05522700
14.69387700 2 4.78255300
-17.42829500 2 5.01327000
-23.38035300 2 4.98464000
-0.16339200 2 1.32676000
-0.32456600 2 1.52875800
AT-ECP GEN 60 3
4 ----- f-ul potential -----
19.87019800 2 5.81216300
26.41645200 2 5.75371500
0.99497000 2 2.51347200
1.49070100 2 2.53626100
7 ----- s-f potential -----
49.95715800 2 30.20083200
283.21037100 2 13.61230600
62.28105200 2 8.52934000
-19.87019800 2 5.81216300
-26.41645200 2 5.75371500
-0.99497000 2 2.51347200
-1.49070100 2 2.53626100
8 ----- p-f potential -----
71.98237100 2 10.85406500
143.90353200 2 9.46822900
4.87175900 2 7.03111400
8.98305900 2 6.14385800
-19.87019800 2 5.81216300
-26.41645200 2 5.75371500
-0.99497000 2 2.51347200
-1.49070100 2 2.53626100
8 ----- d-f potential -----
36.36323700 2 8.31351500
54.54897000 2 7.99896500
9.77628500 2 5.17996600
14.26475500 2 4.94222600
-19.87019800 2 5.81216300
-26.41645200 2 5.75371500
-0.99497000 2 2.51347200
-1.49070100 2 2.53626100
RN-ECP GEN 60 3
4 ----- f-ul potential -----
21.79729000 2 6.34857100
28.94680500 2 6.29594900
1.44736500 2 2.88211800
2.17796400 2 2.90804800
7 ----- s-f potential -----
49.96555100 2 30.15124200
283.07000000 2 14.52124100
62.00287000 2 8.05203800
-21.79729000 2 6.34857100
-28.94680500 2 6.29594900
-1.44736500 2 2.88211800
-2.17796400 2 2.90804800
8 ----- p-f potential -----
71.96911900 2 11.00994200
143.86055900 2 9.61762500
4.71476100 2 7.33600800
9.01306500 2 6.40625300
-21.79729000 2 6.34857100
-28.94680500 2 6.29594900
-1.44736500 2 2.88211800
-2.17796400 2 2.90804800
8 ----- d-f potential -----
36.36836500 2 8.36922000
54.55176100 2 8.11697500
9.63448700 2 5.35365600
14.38790200 2 5.09721200
-21.79729000 2 6.34857100
-28.94680500 2 6.29594900
-1.44736500 2 2.88211800
-2.17796400 2 2.90804800
$END

13
etc/qp.rc
View File

@ -188,7 +188,18 @@ _qp_Complete()
;; ;;
esac;; esac;;
set_file) set_file)
COMPREPLY=( $(compgen -W "$(for i in */ $(find . -name ezfio | sed 's/ezfio$/.version/') ; do [[ -f $i ]] && echo ${i%/.version} ; done)" -- ${cur} ) ) # Array to store directory names
dirs=""
# Find directories containing "ezfio/.version" file recursively
for i in $(find . -name ezfio | sed 's/ezfio$/.version/')
do
dir_name=${i%/.version} # Remove the ".version" suffix
dir_name=${dir_name#./} # Remove the leading "./"
dirs+="./$dir_name "
done
COMPREPLY=( $(compgen -W "$dirs" -- ${cur} ) )
return 0 return 0
;; ;;
plugins) plugins)

2
external/ezfio vendored

@ -1 +1 @@
Subproject commit d5805497fa0ef30e70e055cde1ecec2963303e93 Subproject commit dba01c4fe0ff7b84c5ecfb1c7c77ec68781311b3

47
ocaml/Input_ao_basis.ml
View File

@ -44,8 +44,12 @@ end = struct
let get_default = Qpackage.get_ezfio_default "ao_basis";; let get_default = Qpackage.get_ezfio_default "ao_basis";;
let read_ao_basis () = let read_ao_basis () =
Ezfio.get_ao_basis_ao_basis () let result =
|> AO_basis_name.of_string Ezfio.get_ao_basis_ao_basis ()
in
if result <> "None" then
AO_basis_name.of_string result
else failwith "No basis"
;; ;;
let read_ao_num () = let read_ao_num () =
@ -192,7 +196,7 @@ end = struct
ao_expo ; ao_expo ;
ao_cartesian ; ao_cartesian ;
ao_normalized ; ao_normalized ;
primitives_normalized ; primitives_normalized ;
} = b } = b
in in
write_md5 b ; write_md5 b ;
@ -207,7 +211,7 @@ end = struct
Ezfio.set_ao_basis_ao_prim_num (Ezfio.ezfio_array_of_list Ezfio.set_ao_basis_ao_prim_num (Ezfio.ezfio_array_of_list
~rank:1 ~dim:[| ao_num |] ~data:ao_prim_num) ; ~rank:1 ~dim:[| ao_num |] ~data:ao_prim_num) ;
let ao_nucl = let ao_nucl =
Array.to_list ao_nucl Array.to_list ao_nucl
|> list_map Nucl_number.to_int |> list_map Nucl_number.to_int
in in
@ -215,7 +219,7 @@ end = struct
~rank:1 ~dim:[| ao_num |] ~data:ao_nucl) ; ~rank:1 ~dim:[| ao_num |] ~data:ao_nucl) ;
let ao_power = let ao_power =
let l = Array.to_list ao_power in let l = Array.to_list ao_power in
List.concat [ List.concat [
(list_map (fun a -> Positive_int.to_int a.Angmom.Xyz.x) l) ; (list_map (fun a -> Positive_int.to_int a.Angmom.Xyz.x) l) ;
(list_map (fun a -> Positive_int.to_int a.Angmom.Xyz.y) l) ; (list_map (fun a -> Positive_int.to_int a.Angmom.Xyz.y) l) ;
@ -227,7 +231,7 @@ end = struct
Ezfio.set_ao_basis_ao_cartesian(ao_cartesian); Ezfio.set_ao_basis_ao_cartesian(ao_cartesian);
Ezfio.set_ao_basis_ao_normalized(ao_normalized); Ezfio.set_ao_basis_ao_normalized(ao_normalized);
Ezfio.set_ao_basis_primitives_normalized(primitives_normalized); Ezfio.set_ao_basis_primitives_normalized(primitives_normalized);
let ao_coef = let ao_coef =
Array.to_list ao_coef Array.to_list ao_coef
|> list_map AO_coef.to_float |> list_map AO_coef.to_float
@ -267,7 +271,10 @@ end = struct
|> Ezfio.set_ao_basis_ao_md5 ; |> Ezfio.set_ao_basis_ao_md5 ;
Some result Some result
with with
| _ -> (Ezfio.set_ao_basis_ao_md5 "None" ; None) | _ -> ( "None"
|> Digest.string
|> Digest.to_hex
|> Ezfio.set_ao_basis_ao_md5 ; None)
;; ;;
@ -276,7 +283,7 @@ end = struct
to_basis b to_basis b
|> Long_basis.of_basis |> Long_basis.of_basis
|> Array.of_list |> Array.of_list
and unordered_basis = and unordered_basis =
to_long_basis b to_long_basis b
|> Array.of_list |> Array.of_list
in in
@ -289,15 +296,15 @@ end = struct
(a.(i) <- None ; i) (a.(i) <- None ; i)
else else
find x a (i+1) find x a (i+1)
and find2 (s,g,n) a i = and find2 (s,g,n) a i =
if i = Array.length a then -1 if i = Array.length a then -1
else else
match a.(i) with match a.(i) with
| None -> find2 (s,g,n) a (i+1) | None -> find2 (s,g,n) a (i+1)
| Some (s', g', n') -> | Some (s', g', n') ->
if s <> s' || n <> n' then find2 (s,g,n) a (i+1) if s <> s' || n <> n' then find2 (s,g,n) a (i+1)
else else
let lc = list_map (fun (prim, _) -> prim) g.Gto.lc let lc = list_map (fun (prim, _) -> prim) g.Gto.lc
and lc' = list_map (fun (prim, _) -> prim) g'.Gto.lc and lc' = list_map (fun (prim, _) -> prim) g'.Gto.lc
in in
if lc <> lc' then find2 (s,g,n) a (i+1) else (a.(i) <- None ; i) if lc <> lc' then find2 (s,g,n) a (i+1) else (a.(i) <- None ; i)
@ -313,13 +320,13 @@ end = struct
let ao_num = List.length long_basis |> AO_number.of_int in let ao_num = List.length long_basis |> AO_number.of_int in
let ao_prim_num = let ao_prim_num =
list_map (fun (_,g,_) -> List.length g.Gto.lc list_map (fun (_,g,_) -> List.length g.Gto.lc
|> AO_prim_number.of_int ) long_basis |> AO_prim_number.of_int ) long_basis
|> Array.of_list |> Array.of_list
and ao_nucl = and ao_nucl =
list_map (fun (_,_,n) -> n) long_basis list_map (fun (_,_,n) -> n) long_basis
|> Array.of_list |> Array.of_list
and ao_power = and ao_power =
list_map (fun (x,_,_) -> x) long_basis list_map (fun (x,_,_) -> x) long_basis
|> Array.of_list |> Array.of_list
in in
let ao_prim_num_max = Array.fold_left (fun s x -> let ao_prim_num_max = Array.fold_left (fun s x ->
@ -329,16 +336,16 @@ end = struct
in in
let gtos = let gtos =
list_map (fun (_,x,_) -> x) long_basis list_map (fun (_,x,_) -> x) long_basis
in in
let create_expo_coef ec = let create_expo_coef ec =
let coefs = let coefs =
begin match ec with begin match ec with
| `Coefs -> list_map (fun x-> | `Coefs -> list_map (fun x->
list_map (fun (_,coef) -> AO_coef.to_float coef) x.Gto.lc ) gtos list_map (fun (_,coef) -> AO_coef.to_float coef) x.Gto.lc ) gtos
| `Expos -> list_map (fun x-> | `Expos -> list_map (fun x->
list_map (fun (prim,_) -> AO_expo.to_float list_map (fun (prim,_) -> AO_expo.to_float
prim.GaussianPrimitive.expo) x.Gto.lc ) gtos prim.GaussianPrimitive.expo) x.Gto.lc ) gtos
end end
in in
let rec get_n n accu = function let rec get_n n accu = function
@ -360,7 +367,7 @@ end = struct
let ao_coef = create_expo_coef `Coefs let ao_coef = create_expo_coef `Coefs
|> Array.of_list |> Array.of_list
|> Array.map AO_coef.of_float |> Array.map AO_coef.of_float
and ao_expo = create_expo_coef `Expos and ao_expo = create_expo_coef `Expos
|> Array.of_list |> Array.of_list
|> Array.map AO_expo.of_float |> Array.map AO_expo.of_float
in in
@ -372,7 +379,7 @@ end = struct
} }
;; ;;
let reorder b = let reorder b =
let order = ordering b in let order = ordering b in
let f a = Array.init (Array.length a) (fun i -> a.(order.(i))) in let f a = Array.init (Array.length a) (fun i -> a.(order.(i))) in
let ao_prim_num_max = AO_prim_number.to_int b.ao_prim_num_max let ao_prim_num_max = AO_prim_number.to_int b.ao_prim_num_max
@ -464,7 +471,7 @@ Basis set (read-only) ::
| line :: tail -> | line :: tail ->
let line = String.trim line in let line = String.trim line in
if line = "Basis set (read-only) ::" then if line = "Basis set (read-only) ::" then
String.concat "\n" tail String.concat "\n" tail
else else
extract_basis tail extract_basis tail
in in

5
ocaml/Input_mo_basis.ml
View File

@ -56,7 +56,10 @@ end = struct
let read_ao_md5 () = let read_ao_md5 () =
let ao_md5 = let ao_md5 =
match (Input_ao_basis.Ao_basis.read ()) with match (Input_ao_basis.Ao_basis.read ()) with
| None -> failwith "Unable to read AO basis" | None -> ("None"
|> Digest.string
|> Digest.to_hex
|> MD5.of_string)
| Some result -> Input_ao_basis.Ao_basis.to_md5 result | Some result -> Input_ao_basis.Ao_basis.to_md5 result
in in
let result = let result =

3
ocaml/qp_run.ml
View File

@ -38,7 +38,8 @@ let run slave ?prefix exe ezfio_file =
| Unix.Unix_error _ -> try_new_port (port_number+100) | Unix.Unix_error _ -> try_new_port (port_number+100)
in in
let result = let result =
try_new_port 41279 let port = 10*(Unix.getpid () mod 2823) + 32_769 in
try_new_port port
in in
Zmq.Socket.close dummy_socket; Zmq.Socket.close dummy_socket;
Zmq.Context.terminate zmq_context; Zmq.Context.terminate zmq_context;

2
ocaml/tests/test_pub.py
View File

@ -1,4 +1,4 @@
#!/usr/bin/python #!/usr/bin/env python3
import zmq import zmq
import sys, os import sys, os

2
ocaml/tests/test_task_server.py
View File

@ -1,4 +1,4 @@
#!/usr/bin/python #!/usr/bin/env python3
import zmq import zmq
import sys, os import sys, os

3
scripts/Hn.py
View File

@ -1,4 +1,5 @@
#!/usr/bin/env python #!/usr/bin/env python3
import sys import sys
from math import * from math import *
arg = sys.argv arg = sys.argv

2
scripts/compilation/cache_compile.py
View File

@ -1,7 +1,7 @@
#!/usr/bin/env python3 #!/usr/bin/env python3
""" """
Save the .o from a .f90 Save the .o from a .f90
and is the .o is asked a second time, retur it and is the .o is asked a second time, return it
Take in argv command like: Take in argv command like:
ifort -g -openmp -I IRPF90_temp/Ezfio_files/ -c IRPF90_temp/Integrals_Monoelec/kin_ao_ints.irp.module.F90 -o IRPF90_temp/Integrals_Monoelec/kin_ao_ints.irp.module.o ifort -g -openmp -I IRPF90_temp/Ezfio_files/ -c IRPF90_temp/Integrals_Monoelec/kin_ao_ints.irp.module.F90 -o IRPF90_temp/Integrals_Monoelec/kin_ao_ints.irp.module.o
""" """

5
scripts/compilation/qp_create_ninja
View File

@ -38,9 +38,8 @@ def comp_path(path):
from qp_path import QP_ROOT, QP_SRC, QP_EZFIO from qp_path import QP_ROOT, QP_SRC, QP_EZFIO
LIB = " -lz -ltrexio" LIB = " -lz"
EZFIO_LIB = join("$QP_ROOT", "lib", "libezfio_irp.a") EZFIO_LIB = join("$QP_ROOT", "lib", "libezfio_irp.a")
ZMQ_LIB = join("$QP_ROOT", "lib", "libf77zmq.a") + " " + join("$QP_ROOT", "lib", "libzmq.a") + " -lstdc++ -lrt -ldl"
ROOT_BUILD_NINJA = join("$QP_ROOT", "config", "build.ninja") ROOT_BUILD_NINJA = join("$QP_ROOT", "config", "build.ninja")
ROOT_BUILD_NINJA_EXP = join(QP_ROOT, "config", "build.ninja") ROOT_BUILD_NINJA_EXP = join(QP_ROOT, "config", "build.ninja")
ROOT_BUILD_NINJA_EXP_tmp = join(QP_ROOT, "config", "build.ninja.tmp") ROOT_BUILD_NINJA_EXP_tmp = join(QP_ROOT, "config", "build.ninja.tmp")
@ -118,7 +117,7 @@ def ninja_create_env_variable(pwd_config_file):
lib_lapack = get_compilation_option(pwd_config_file, "LAPACK_LIB") lib_lapack = get_compilation_option(pwd_config_file, "LAPACK_LIB")
lib_usr = get_compilation_option(pwd_config_file, "LIB") lib_usr = get_compilation_option(pwd_config_file, "LIB")
str_lib = " ".join([lib_lapack, EZFIO_LIB, ZMQ_LIB, LIB, lib_usr]) str_lib = " ".join([lib_lapack, EZFIO_LIB, LIB, lib_usr])
# Read all LIB files in modules # Read all LIB files in modules
for directory in [real_join(QP_SRC, m) for m in sorted(os.listdir(QP_SRC))]: for directory in [real_join(QP_SRC, m) for m in sorted(os.listdir(QP_SRC))]:

4
scripts/ezfio_interface/ei_handler.py
View File

@ -829,4 +829,8 @@ if __name__ == "__main__":
# _| # _|
for (m, dict_ezfio_cfg) in l_dict_ezfio_cfg: for (m, dict_ezfio_cfg) in l_dict_ezfio_cfg:
if dict_ezfio_cfg == {}:
print("Error: Empty EZFIO.cfg in ", arguments["--path_module"])
sys.exit(-1)
code_generation(arguments, dict_ezfio_cfg, m) code_generation(arguments, dict_ezfio_cfg, m)

69
scripts/import_champ_jastrow.py Executable file
View File

@ -0,0 +1,69 @@
#!/usr/bin/env python3
conv = [ 0, 0, 2 , 6 , 13 , 23 , 37 , 55 , 78 , 106 , 140 ]
def import_jastrow(jastrow_filename):
with open(jastrow_filename,'r') as jastrow_file:
lines = [ line.strip() for line in jastrow_file.readlines() ]
lines = [ line for line in lines if line != "" ]
start = 0
end = len(lines)
for i,line in enumerate(lines):
if line.startswith("jastrow_parameter"):
start = i
elif line.startswith("end"):
end = i
lines = lines[start:end]
type_num = (len(lines)-4)//2
nord_a,nord_b,nord_c = [ int(i) for i in lines[1].split()[:3] ]
scale_k = float(lines[2].split()[0])
vec_a = []
for j in range(type_num):
vec_a += [ float(i) for i in lines[3+j].split()[:nord_a+1] ]
vec_b = [ float(i) for i in lines[3+type_num].split()[:nord_b+1] ]
vec_c = []
for j in range(type_num):
vec_c += [ float(i) for i in lines[4+type_num+j].split()[:conv[nord_c]] ]
return {
'type_num' : type_num,
'scale_k' : scale_k,
'nord_a' : nord_a,
'nord_b' : nord_b,
'nord_c' : nord_c,
'vec_a' : vec_a,
'vec_b' : vec_b,
'vec_c' : vec_c,
}
if __name__ == '__main__':
import sys
from ezfio import ezfio
ezfio.set_file(sys.argv[1])
jastrow_file = sys.argv[2]
jastrow = import_jastrow(jastrow_file)
print (jastrow)
ezfio.set_jastrow_jast_type("Qmckl")
ezfio.set_jastrow_jast_qmckl_type_nucl_num(jastrow['type_num'])
charges = ezfio.get_nuclei_nucl_charge()
types = {}
k = 1
for c in charges:
if c not in types:
types[c] = k
k += 1
type_nucl_vector = [types[c] for c in charges]
print(type_nucl_vector)
ezfio.set_jastrow_jast_qmckl_type_nucl_vector(type_nucl_vector)
ezfio.set_jastrow_jast_qmckl_rescale_ee(jastrow['scale_k'])
ezfio.set_jastrow_jast_qmckl_rescale_en([jastrow['scale_k'] for i in type_nucl_vector])
ezfio.set_jastrow_jast_qmckl_aord_num(jastrow['nord_a'])
ezfio.set_jastrow_jast_qmckl_bord_num(jastrow['nord_b'])
ezfio.set_jastrow_jast_qmckl_cord_num(jastrow['nord_c'])
ezfio.set_jastrow_jast_qmckl_c_vector_size(len(jastrow['vec_c']))
ezfio.set_jastrow_jast_qmckl_a_vector(jastrow['vec_a'])
ezfio.set_jastrow_jast_qmckl_b_vector(jastrow['vec_b'])
ezfio.set_jastrow_jast_qmckl_c_vector(jastrow['vec_c'])

3
scripts/qp_exc_energy.py
View File

@ -1,4 +1,5 @@
#!/usr/bin/env python #!/usr/bin/env python3
# Computes the error on the excitation energy of a CIPSI run. # Computes the error on the excitation energy of a CIPSI run.
def student(p,df): def student(p,df):

219
src/trexio/qp_import_trexio.py → scripts/qp_import_trexio.py
View File

@ -13,11 +13,17 @@ Options:
import sys import sys
import os import os
import trexio
import numpy as np import numpy as np
from functools import reduce from functools import reduce
from ezfio import ezfio from ezfio import ezfio
from docopt import docopt from docopt import docopt
import qp_bitmasks
try:
import trexio
except ImportError:
print("Error: trexio python module is not found. Try python3 -m pip install trexio")
sys.exit(1)
try: try:
@ -32,6 +38,15 @@ else:
QP_ROOT + "/install", QP_ROOT + "/install",
QP_ROOT + "/scripts"] + sys.path QP_ROOT + "/scripts"] + sys.path
def uint64_to_int64(u):
# Check if the most significant bit is set
if u & (1 << 63):
# Calculate the two's complement
result = -int(np.bitwise_not(np.uint64(u))+1)
else:
# The number is already positive
result = u
return result
def generate_xyz(l): def generate_xyz(l):
@ -90,14 +105,15 @@ def write_ezfio(trexio_filename, filename):
p = re.compile(r'(\d*)$') p = re.compile(r'(\d*)$')
label = [p.sub("", x).capitalize() for x in label] label = [p.sub("", x).capitalize() for x in label]
ezfio.set_nuclei_nucl_label(label) ezfio.set_nuclei_nucl_label(label)
print("OK")
else: else:
ezfio.set_nuclei_nucl_num(1) ezfio.set_nuclei_nucl_num(1)
ezfio.set_nuclei_nucl_charge([0.]) ezfio.set_nuclei_nucl_charge([0.])
ezfio.set_nuclei_nucl_coord([0.,0.,0.]) ezfio.set_nuclei_nucl_coord([0.,0.,0.])
ezfio.set_nuclei_nucl_label(["X"]) ezfio.set_nuclei_nucl_label(["X"])
print("None")
print("OK")
print("Electrons\t...\t", end=' ') print("Electrons\t...\t", end=' ')
@ -105,12 +121,12 @@ def write_ezfio(trexio_filename, filename):
try: try:
num_beta = trexio.read_electron_dn_num(trexio_file) num_beta = trexio.read_electron_dn_num(trexio_file)
except: except:
num_beta = sum(charge)//2 num_beta = int(sum(charge))//2
try: try:
num_alpha = trexio.read_electron_up_num(trexio_file) num_alpha = trexio.read_electron_up_num(trexio_file)
except: except:
num_alpha = sum(charge) - num_beta num_alpha = int(sum(charge)) - num_beta
if num_alpha == 0: if num_alpha == 0:
print("\n\nError: There are zero electrons in the TREXIO file.\n\n") print("\n\nError: There are zero electrons in the TREXIO file.\n\n")
@ -118,7 +134,7 @@ def write_ezfio(trexio_filename, filename):
ezfio.set_electrons_elec_alpha_num(num_alpha) ezfio.set_electrons_elec_alpha_num(num_alpha)
ezfio.set_electrons_elec_beta_num(num_beta) ezfio.set_electrons_elec_beta_num(num_beta)
print("OK") print(f"{num_alpha} {num_beta}")
print("Basis\t\t...\t", end=' ') print("Basis\t\t...\t", end=' ')
@ -126,60 +142,113 @@ def write_ezfio(trexio_filename, filename):
try: try:
basis_type = trexio.read_basis_type(trexio_file) basis_type = trexio.read_basis_type(trexio_file)
if basis_type.lower() not in ["gaussian", "slater"]: if basis_type.lower() in ["gaussian", "slater"]:
raise TypeError shell_num = trexio.read_basis_shell_num(trexio_file)
prim_num = trexio.read_basis_prim_num(trexio_file)
ang_mom = trexio.read_basis_shell_ang_mom(trexio_file)
nucl_index = trexio.read_basis_nucleus_index(trexio_file)
exponent = trexio.read_basis_exponent(trexio_file)
coefficient = trexio.read_basis_coefficient(trexio_file)
shell_index = trexio.read_basis_shell_index(trexio_file)
ao_shell = trexio.read_ao_shell(trexio_file)
shell_num = trexio.read_basis_shell_num(trexio_file) ezfio.set_basis_basis("Read from TREXIO")
prim_num = trexio.read_basis_prim_num(trexio_file) ezfio.set_ao_basis_ao_basis("Read from TREXIO")
ang_mom = trexio.read_basis_shell_ang_mom(trexio_file) ezfio.set_basis_shell_num(shell_num)
nucl_index = trexio.read_basis_nucleus_index(trexio_file) ezfio.set_basis_prim_num(prim_num)
exponent = trexio.read_basis_exponent(trexio_file) ezfio.set_basis_shell_ang_mom(ang_mom)
coefficient = trexio.read_basis_coefficient(trexio_file) ezfio.set_basis_basis_nucleus_index([ x+1 for x in nucl_index ])
shell_index = trexio.read_basis_shell_index(trexio_file) ezfio.set_basis_prim_expo(exponent)
ao_shell = trexio.read_ao_shell(trexio_file) ezfio.set_basis_prim_coef(coefficient)
ezfio.set_basis_basis("Read from TREXIO") nucl_shell_num = []
ezfio.set_basis_shell_num(shell_num) prev = None
ezfio.set_basis_prim_num(prim_num) m = 0
ezfio.set_basis_shell_ang_mom(ang_mom) for i in ao_shell:
ezfio.set_basis_basis_nucleus_index([ x+1 for x in nucl_index ]) if i != prev:
ezfio.set_basis_prim_expo(exponent) m += 1
ezfio.set_basis_prim_coef(coefficient) if prev is None or nucl_index[i] != nucl_index[prev]:
nucl_shell_num.append(m)
m = 0
prev = i
assert (len(nucl_shell_num) == nucl_num)
nucl_shell_num = [] shell_prim_num = []
prev = None prev = shell_index[0]
m = 0 count = 0
for i in ao_shell: for i in shell_index:
if i != prev: if i != prev:
m += 1 shell_prim_num.append(count)
if prev is None or nucl_index[i] != nucl_index[prev]: count = 0
nucl_shell_num.append(m) count += 1
m = 0 prev = i
prev = i shell_prim_num.append(count)
assert (len(nucl_shell_num) == nucl_num)
shell_prim_num = [] assert (len(shell_prim_num) == shell_num)
prev = shell_index[0]
count = 0
for i in shell_index:
if i != prev:
shell_prim_num.append(count)
count = 0
count += 1
prev = i
shell_prim_num.append(count)
assert (len(shell_prim_num) == shell_num) ezfio.set_basis_shell_prim_num(shell_prim_num)
ezfio.set_basis_shell_index([x+1 for x in shell_index])
ezfio.set_basis_shell_prim_num(shell_prim_num) ezfio.set_basis_nucleus_shell_num(nucl_shell_num)
ezfio.set_basis_shell_index([x+1 for x in shell_index])
ezfio.set_basis_nucleus_shell_num(nucl_shell_num)
shell_factor = trexio.read_basis_shell_factor(trexio_file) shell_factor = trexio.read_basis_shell_factor(trexio_file)
prim_factor = trexio.read_basis_prim_factor(trexio_file) prim_factor = trexio.read_basis_prim_factor(trexio_file)
print("OK") elif basis_type.lower() == "numerical":
shell_num = trexio.read_basis_shell_num(trexio_file)
prim_num = shell_num
ang_mom = trexio.read_basis_shell_ang_mom(trexio_file)
nucl_index = trexio.read_basis_nucleus_index(trexio_file)
exponent = [1.]*prim_num
coefficient = [1.]*prim_num
shell_index = [i for i in range(shell_num)]
ao_shell = trexio.read_ao_shell(trexio_file)
ezfio.set_basis_basis("None")
ezfio.set_ao_basis_ao_basis("None")
ezfio.set_basis_shell_num(shell_num)
ezfio.set_basis_prim_num(prim_num)
ezfio.set_basis_shell_ang_mom(ang_mom)
ezfio.set_basis_basis_nucleus_index([ x+1 for x in nucl_index ])
ezfio.set_basis_prim_expo(exponent)
ezfio.set_basis_prim_coef(coefficient)
nucl_shell_num = []
prev = None
m = 0
for i in ao_shell:
if i != prev:
m += 1
if prev is None or nucl_index[i] != nucl_index[prev]:
nucl_shell_num.append(m)
m = 0
prev = i
assert (len(nucl_shell_num) == nucl_num)
shell_prim_num = []
prev = shell_index[0]
count = 0
for i in shell_index:
if i != prev:
shell_prim_num.append(count)
count = 0
count += 1
prev = i
shell_prim_num.append(count)
assert (len(shell_prim_num) == shell_num)
ezfio.set_basis_shell_prim_num(shell_prim_num)
ezfio.set_basis_shell_index([x+1 for x in shell_index])
ezfio.set_basis_nucleus_shell_num(nucl_shell_num)
shell_factor = trexio.read_basis_shell_factor(trexio_file)
prim_factor = [1.]*prim_num
else:
raise TypeError
print(basis_type)
except: except:
print("None") print("None")
ezfio.set_ao_basis_ao_cartesian(True) ezfio.set_ao_basis_ao_cartesian(True)
@ -256,9 +325,11 @@ def write_ezfio(trexio_filename, filename):
# ezfio.set_ao_basis_ao_prim_num_max(prim_num_max) # ezfio.set_ao_basis_ao_prim_num_max(prim_num_max)
ezfio.set_ao_basis_ao_coef(coef) ezfio.set_ao_basis_ao_coef(coef)
ezfio.set_ao_basis_ao_expo(expo) ezfio.set_ao_basis_ao_expo(expo)
ezfio.set_ao_basis_ao_basis("Read from TREXIO")
print("OK") print("OK")
else:
print("None")
# _ # _
@ -279,6 +350,7 @@ def write_ezfio(trexio_filename, filename):
except: except:
label = "None" label = "None"
ezfio.set_mo_basis_mo_label(label) ezfio.set_mo_basis_mo_label(label)
ezfio.set_determinants_mo_label(label)
try: try:
clss = trexio.read_mo_class(trexio_file) clss = trexio.read_mo_class(trexio_file)
@ -303,10 +375,10 @@ def write_ezfio(trexio_filename, filename):
for i in range(num_beta): for i in range(num_beta):
mo_occ[i] += 1. mo_occ[i] += 1.
ezfio.set_mo_basis_mo_occ(mo_occ) ezfio.set_mo_basis_mo_occ(mo_occ)
print("OK")
except: except:
pass print("None")
print("OK")
print("Pseudos\t\t...\t", end=' ') print("Pseudos\t\t...\t", end=' ')
@ -386,8 +458,45 @@ def write_ezfio(trexio_filename, filename):
ezfio.set_pseudo_pseudo_n_kl(pseudo_n_kl) ezfio.set_pseudo_pseudo_n_kl(pseudo_n_kl)
ezfio.set_pseudo_pseudo_v_kl(pseudo_v_kl) ezfio.set_pseudo_pseudo_v_kl(pseudo_v_kl)
ezfio.set_pseudo_pseudo_dz_kl(pseudo_dz_kl) ezfio.set_pseudo_pseudo_dz_kl(pseudo_dz_kl)
print("OK")
else:
print("None")
print("Determinant\t...\t", end=' ')
alpha = [ i for i in range(num_alpha) ]
beta = [ i for i in range(num_beta) ]
if trexio.has_mo_spin(trexio_file):
spin = trexio.read_mo_spin(trexio_file)
if max(spin) == 1:
alpha = [ i for i in range(len(spin)) if spin[i] == 0 ]
alpha = [ alpha[i] for i in range(num_alpha) ]
beta = [ i for i in range(len(spin)) if spin[i] == 1 ]
beta = [ beta[i] for i in range(num_beta) ]
print("Warning -- UHF orbitals --", end=' ')
alpha_s = ['0']*mo_num
beta_s = ['0']*mo_num
for i in alpha:
alpha_s[i] = '1'
for i in beta:
beta_s[i] = '1'
alpha_s = ''.join(alpha_s)[::-1]
beta_s = ''.join(beta_s)[::-1]
def conv(i):
try:
result = np.int64(i)
except:
result = np.int64(i-2**63-1)
return result
alpha = [ uint64_to_int64(int(i,2)) for i in qp_bitmasks.string_to_bitmask(alpha_s) ][::-1]
beta = [ uint64_to_int64(int(i,2)) for i in qp_bitmasks.string_to_bitmask(beta_s ) ][::-1]
ezfio.set_determinants_bit_kind(8)
ezfio.set_determinants_n_int(1+mo_num//64)
ezfio.set_determinants_n_det(1)
ezfio.set_determinants_n_states(1)
ezfio.set_determinants_psi_det(alpha+beta)
ezfio.set_determinants_psi_coef([[1.0]])
print("OK") print("OK")

6
scripts/utility/qp_bitmasks.py
View File

@ -22,7 +22,7 @@ def int_to_string(s):
assert s>=0 assert s>=0
AssertionError AssertionError
""" """
assert type(s) in (int, long) assert type(s) == int
assert s>=0 assert s>=0
return '{s:0b}'.format(s=s) return '{s:0b}'.format(s=s)
@ -62,7 +62,7 @@ def int_to_bitmask(s,bit_kind_size=BIT_KIND_SIZE):
['1111111111111111111111111111111111111111111111111111111111110110'] ['1111111111111111111111111111111111111111111111111111111111110110']
>>> >>>
""" """
assert type(s) in (int, long) assert type(s) == int
if s < 0: if s < 0:
s = s + (1 << bit_kind_size) s = s + (1 << bit_kind_size)
return ['{s:0{width}b}'.format(s=s,width=bit_kind_size)] return ['{s:0{width}b}'.format(s=s,width=bit_kind_size)]
@ -104,7 +104,7 @@ class BitMask(object):
return self._data_int[i] return self._data_int[i]
def __setitem__(self,i,value): def __setitem__(self,i,value):
if type(value) in (int,long): if type(value) == int :
self._data_int[i] = value self._data_int[i] = value
elif type(value) == str: elif type(value) == str:
s = string_to_bitmask(value,bit_kind_size=self.bit_kind_size)[0] s = string_to_bitmask(value,bit_kind_size=self.bit_kind_size)[0]

3
scripts/utility/qp_json.py
View File

@ -1,4 +1,5 @@
#!/usr/bin/env python #!/usr/bin/env python3
import os import os
import json import json

12
src/ao_basis/EZFIO.cfg
View File

@ -67,3 +67,15 @@ doc: Use normalized primitive functions
interface: ezfio, provider interface: ezfio, provider
default: true default: true
[ao_expoim_cosgtos]
type: double precision
doc: imag part for Exponents for each primitive of each cosGTOs |AO|
size: (ao_basis.ao_num,ao_basis.ao_prim_num_max)
interface: ezfio, provider
[use_cosgtos]
type: logical
doc: If true, use cosgtos for AO integrals
interface: ezfio
default: False

84
src/ao_basis/aos_in_r.irp.f
View File

@ -65,46 +65,60 @@ double precision function primitive_value(i,j,r)
end end
! ---
subroutine give_all_aos_at_r(r,aos_array) subroutine give_all_aos_at_r(r, tmp_array)
implicit none
BEGIN_dOC
! input : r == r(1) = x and so on
!
! output : aos_array(i) = aos(i) evaluated in $\textbf{r}$
END_DOC
double precision, intent(in) :: r(3)
double precision, intent(out):: aos_array(ao_num)
integer :: power_ao(3) BEGIN_dOC
integer :: i,j,k,l,m !
double precision :: dx,dy,dz,r2 ! input : r == r(1) = x and so on
double precision :: dx2,dy2,dz2 !
double precision :: center_ao(3) ! output : tmp_array(i) = aos(i) evaluated in $\textbf{r}$
double precision :: beta !
do i = 1, nucl_num END_DOC
center_ao(1:3) = nucl_coord(i,1:3)
dx = (r(1) - center_ao(1)) implicit none
dy = (r(2) - center_ao(2)) double precision, intent(in) :: r(3)
dz = (r(3) - center_ao(3)) double precision, intent(out) :: tmp_array(ao_num)
r2 = dx*dx + dy*dy + dz*dz integer :: p_ao(3)
do j = 1,Nucl_N_Aos(i) integer :: i, j, k, l, m
k = Nucl_Aos_transposed(j,i) ! index of the ao in the ordered format double precision :: dx, dy, dz, r2
aos_array(k) = 0.d0 double precision :: dx2, dy2, dz2
power_ao(1:3)= ao_power_ordered_transp_per_nucl(1:3,j,i) double precision :: c_ao(3)
dx2 = dx**power_ao(1) double precision :: beta
dy2 = dy**power_ao(2)
dz2 = dz**power_ao(3) do i = 1, nucl_num
do l = 1,ao_prim_num(k)
beta = ao_expo_ordered_transp_per_nucl(l,j,i) c_ao(1:3) = nucl_coord(i,1:3)
if(dabs(beta*r2).gt.40.d0)cycle dx = r(1) - c_ao(1)
aos_array(k)+= ao_coef_normalized_ordered_transp_per_nucl(l,j,i) * dexp(-beta*r2) dy = r(2) - c_ao(2)
enddo dz = r(3) - c_ao(3)
aos_array(k) = aos_array(k) * dx2 * dy2 * dz2 r2 = dx*dx + dy*dy + dz*dz
do j = 1, Nucl_N_Aos(i)
k = Nucl_Aos_transposed(j,i) ! index of the ao in the ordered format
p_ao(1:3) = ao_power_ordered_transp_per_nucl(1:3,j,i)
dx2 = dx**p_ao(1)
dy2 = dy**p_ao(2)
dz2 = dz**p_ao(3)
tmp_array(k) = 0.d0
do l = 1,ao_prim_num(k)
beta = ao_expo_ordered_transp_per_nucl(l,j,i)
if(dabs(beta*r2).gt.40.d0) cycle
tmp_array(k) += ao_coef_normalized_ordered_transp_per_nucl(l,j,i) * dexp(-beta*r2)
enddo
tmp_array(k) = tmp_array(k) * dx2 * dy2 * dz2
enddo
enddo enddo
enddo
return
end end
! ---
subroutine give_all_aos_and_grad_at_r(r,aos_array,aos_grad_array) subroutine give_all_aos_and_grad_at_r(r,aos_array,aos_grad_array)
implicit none implicit none

38
src/ao_basis/aos_transp.irp.f
View File

@ -1,20 +1,28 @@
BEGIN_PROVIDER [ integer, Nucl_Aos_transposed, (N_AOs_max,nucl_num)]
implicit none ! ---
BEGIN_DOC
! List of AOs attached on each atom BEGIN_PROVIDER [ integer, Nucl_Aos_transposed, (N_AOs_max,nucl_num)]
END_DOC
integer :: i BEGIN_DOC
integer, allocatable :: nucl_tmp(:) ! List of AOs attached on each atom
allocate(nucl_tmp(nucl_num)) END_DOC
nucl_tmp = 0
Nucl_Aos = 0 implicit none
do i = 1, ao_num integer :: i
nucl_tmp(ao_nucl(i))+=1 integer, allocatable :: nucl_tmp(:)
Nucl_Aos_transposed(nucl_tmp(ao_nucl(i)),ao_nucl(i)) = i
enddo allocate(nucl_tmp(nucl_num))
deallocate(nucl_tmp) nucl_tmp = 0
do i = 1, ao_num
nucl_tmp(ao_nucl(i)) += 1
Nucl_Aos_transposed(nucl_tmp(ao_nucl(i)),ao_nucl(i)) = i
enddo
deallocate(nucl_tmp)
END_PROVIDER END_PROVIDER
! ---
BEGIN_PROVIDER [double precision, ao_expo_ordered_transp_per_nucl, (ao_prim_num_max,N_AOs_max,nucl_num) ] BEGIN_PROVIDER [double precision, ao_expo_ordered_transp_per_nucl, (ao_prim_num_max,N_AOs_max,nucl_num) ]
implicit none implicit none
integer :: i,j,k,l integer :: i,j,k,l

34
src/ao_basis/cosgtos.irp.f Normal file
View File

@ -0,0 +1,34 @@
BEGIN_PROVIDER [ logical, use_cosgtos ]
implicit none
BEGIN_DOC
! If true, use cosgtos for AO integrals
END_DOC
logical :: has
PROVIDE ezfio_filename
use_cosgtos = .False.
if (mpi_master) then
call ezfio_has_ao_basis_use_cosgtos(has)
if (has) then
! write(6,'(A)') '.. >>>>> [ IO READ: use_cosgtos ] <<<<< ..'
call ezfio_get_ao_basis_use_cosgtos(use_cosgtos)
else
call ezfio_set_ao_basis_use_cosgtos(use_cosgtos)
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( use_cosgtos, 1, MPI_LOGICAL, 0, MPI_COMM_WORLD, ierr)
if (ierr /= MPI_SUCCESS) then
stop 'Unable to read use_cosgtos with MPI'
endif
IRP_ENDIF
! call write_time(6)
END_PROVIDER

1
src/ao_many_one_e_ints/NEED
View File

@ -3,3 +3,4 @@ ao_two_e_ints
becke_numerical_grid becke_numerical_grid
mo_one_e_ints mo_one_e_ints
dft_utils_in_r dft_utils_in_r
tc_keywords

296
src/ao_many_one_e_ints/ao_erf_gauss.irp.f
View File

@ -212,9 +212,7 @@ subroutine NAI_pol_x_mult_erf_ao(i_ao, j_ao, mu_in, C_center, ints)
! Computes the following integral : ! Computes the following integral :
! !
! $\int_{-\infty}^{infty} dr x * \chi_i(r) \chi_j(r) \frac{\erf(\mu | r - R_C | )}{ | r - R_C | }$. ! $\int_{-\infty}^{infty} dr x * \chi_i(r) \chi_j(r) \frac{\erf(\mu | r - R_C | )}{ | r - R_C | }$.
!
! $\int_{-\infty}^{infty} dr y * \chi_i(r) \chi_j(r) \frac{\erf(\mu | r - R_C | )}{ | r - R_C | }$. ! $\int_{-\infty}^{infty} dr y * \chi_i(r) \chi_j(r) \frac{\erf(\mu | r - R_C | )}{ | r - R_C | }$.
!
! $\int_{-\infty}^{infty} dr z * \chi_i(r) \chi_j(r) \frac{\erf(\mu | r - R_C | )}{ | r - R_C | }$. ! $\int_{-\infty}^{infty} dr z * \chi_i(r) \chi_j(r) \frac{\erf(\mu | r - R_C | )}{ | r - R_C | }$.
! !
END_DOC END_DOC
@ -279,9 +277,7 @@ subroutine NAI_pol_x_mult_erf_ao_v0(i_ao, j_ao, mu_in, C_center, LD_C, ints, LD_
! Computes the following integral : ! Computes the following integral :
! !
! $\int_{-\infty}^{infty} dr x * \chi_i(r) \chi_j(r) \frac{\erf(\mu | r - R_C | )}{ | r - R_C | }$. ! $\int_{-\infty}^{infty} dr x * \chi_i(r) \chi_j(r) \frac{\erf(\mu | r - R_C | )}{ | r - R_C | }$.
!
! $\int_{-\infty}^{infty} dr y * \chi_i(r) \chi_j(r) \frac{\erf(\mu | r - R_C | )}{ | r - R_C | }$. ! $\int_{-\infty}^{infty} dr y * \chi_i(r) \chi_j(r) \frac{\erf(\mu | r - R_C | )}{ | r - R_C | }$.
!
! $\int_{-\infty}^{infty} dr z * \chi_i(r) \chi_j(r) \frac{\erf(\mu | r - R_C | )}{ | r - R_C | }$. ! $\int_{-\infty}^{infty} dr z * \chi_i(r) \chi_j(r) \frac{\erf(\mu | r - R_C | )}{ | r - R_C | }$.
! !
END_DOC END_DOC
@ -1111,3 +1107,295 @@ end
! --- ! ---
subroutine NAI_pol_x2_mult_erf_ao_with1s(i_ao, j_ao, beta, B_center, mu_in, C_center, ints)
BEGIN_DOC
!
! Computes the following integral :
!
! $\int_{-\infty}^{infty} dr x^2 * \chi_i(r) \chi_j(r) e^{-\beta (r - B_center)^2} \frac{\erf(\mu | r - R_C | )}{ | r - R_C | }$.
! $\int_{-\infty}^{infty} dr y^2 * \chi_i(r) \chi_j(r) e^{-\beta (r - B_center)^2} \frac{\erf(\mu | r - R_C | )}{ | r - R_C | }$.
! $\int_{-\infty}^{infty} dr z^2 * \chi_i(r) \chi_j(r) e^{-\beta (r - B_center)^2} \frac{\erf(\mu | r - R_C | )}{ | r - R_C | }$.
!
END_DOC
include 'utils/constants.include.F'
implicit none
integer, intent(in) :: i_ao, j_ao
double precision, intent(in) :: beta, B_center(3), mu_in, C_center(3)
double precision, intent(out) :: ints(3)
integer :: i, j, power_Ai(3), power_Aj(3), n_pt_in, m
integer :: power_A1(3), power_A2(3)
double precision :: Ai_center(3), Aj_center(3), alphai, alphaj, coef, coefi
double precision :: integral0, integral1, integral2
double precision, external :: NAI_pol_mult_erf_with1s
ASSERT(beta .ge. 0.d0)
if(beta .lt. 1d-10) then
call NAI_pol_x2_mult_erf_ao(i_ao, j_ao, mu_in, C_center, ints)
return
endif
ints = 0.d0
power_Ai(1:3) = ao_power(i_ao,1:3)
power_Aj(1:3) = ao_power(j_ao,1:3)
Ai_center(1:3) = nucl_coord(ao_nucl(i_ao),1:3)
Aj_center(1:3) = nucl_coord(ao_nucl(j_ao),1:3)
n_pt_in = n_pt_max_integrals
do i = 1, ao_prim_num(i_ao)
alphai = ao_expo_ordered_transp (i,i_ao)
coefi = ao_coef_normalized_ordered_transp(i,i_ao)
do m = 1, 3
power_A1 = power_Ai
power_A1(m) += 1
power_A2 = power_Ai
power_A2(m) += 2
do j = 1, ao_prim_num(j_ao)
alphaj = ao_expo_ordered_transp (j,j_ao)
coef = coefi * ao_coef_normalized_ordered_transp(j,j_ao)
integral0 = NAI_pol_mult_erf_with1s(Ai_center, Aj_center, power_Ai, power_Aj, alphai, alphaj, beta, B_center, C_center, n_pt_in, mu_in)
integral1 = NAI_pol_mult_erf_with1s(Ai_center, Aj_center, power_A1, power_Aj, alphai, alphaj, beta, B_center, C_center, n_pt_in, mu_in)
integral2 = NAI_pol_mult_erf_with1s(Ai_center, Aj_center, power_A2, power_Aj, alphai, alphaj, beta, B_center, C_center, n_pt_in, mu_in)
ints(m) += coef * (integral2 + Ai_center(m) * (2.d0*integral1 + Ai_center(m)*integral0))
enddo
enddo
enddo
end subroutine NAI_pol_x2_mult_erf_ao_with1s
! ---
subroutine NAI_pol_x2_mult_erf_ao(i_ao, j_ao, mu_in, C_center, ints)
BEGIN_DOC
!
! Computes the following integral :
!
! $\int_{-\infty}^{infty} dr x^2 * \chi_i(r) \chi_j(r) \frac{\erf(\mu | r - R_C | )}{ | r - R_C | }$.
! $\int_{-\infty}^{infty} dr y^2 * \chi_i(r) \chi_j(r) \frac{\erf(\mu | r - R_C | )}{ | r - R_C | }$.
! $\int_{-\infty}^{infty} dr z^2 * \chi_i(r) \chi_j(r) \frac{\erf(\mu | r - R_C | )}{ | r - R_C | }$.
!
END_DOC
include 'utils/constants.include.F'
implicit none
integer, intent(in) :: i_ao, j_ao
double precision, intent(in) :: mu_in, C_center(3)
double precision, intent(out) :: ints(3)
integer :: i, j, num_A, num_B, power_A(3), power_B(3), n_pt_in, m
integer :: power_A1(3), power_A2(3)
double precision :: A_center(3), B_center(3), alpha, beta, coef
double precision :: integral0, integral1, integral2
double precision :: NAI_pol_mult_erf
ints = 0.d0
num_A = ao_nucl(i_ao)
power_A(1:3) = ao_power(i_ao,1:3)
A_center(1:3) = nucl_coord(num_A,1:3)
num_B = ao_nucl(j_ao)
power_B(1:3) = ao_power(j_ao,1:3)
B_center(1:3) = nucl_coord(num_B,1:3)
n_pt_in = n_pt_max_integrals
do i = 1, ao_prim_num(i_ao)
alpha = ao_expo_ordered_transp(i,i_ao)
do m = 1, 3
power_A1 = power_A
power_A1(m) += 1
power_A2 = power_A
power_A2(m) += 2
do j = 1, ao_prim_num(j_ao)
beta = ao_expo_ordered_transp(j,j_ao)
coef = ao_coef_normalized_ordered_transp(j,j_ao) * ao_coef_normalized_ordered_transp(i,i_ao)
integral0 = NAI_pol_mult_erf(A_center, B_center, power_A , power_B, alpha, beta, C_center, n_pt_in, mu_in)
integral1 = NAI_pol_mult_erf(A_center, B_center, power_A1, power_B, alpha, beta, C_center, n_pt_in, mu_in)
integral2 = NAI_pol_mult_erf(A_center, B_center, power_A2, power_B, alpha, beta, C_center, n_pt_in, mu_in)
ints(m) += coef * (integral2 + A_center(m) * (2.d0*integral1 + A_center(m)*integral0))
enddo
enddo
enddo
end subroutine NAI_pol_x2_mult_erf_ao
! ---
subroutine NAI_pol_012_mult_erf_ao_with1s(i_ao, j_ao, beta, B_center, mu_in, C_center, ints)
BEGIN_DOC
!
! Computes the following integral :
!
! ints(1) = $\int_{-\infty}^{infty} dr x^0 * \chi_i(r) \chi_j(r) e^{-\beta (r - B_center)^2} \frac{\erf(\mu | r - R_C | )}{ | r - R_C | }$.
!
! ints(2) = $\int_{-\infty}^{infty} dr x^1 * \chi_i(r) \chi_j(r) e^{-\beta (r - B_center)^2} \frac{\erf(\mu | r - R_C | )}{ | r - R_C | }$.
! ints(3) = $\int_{-\infty}^{infty} dr y^1 * \chi_i(r) \chi_j(r) e^{-\beta (r - B_center)^2} \frac{\erf(\mu | r - R_C | )}{ | r - R_C | }$.
! ints(4) = $\int_{-\infty}^{infty} dr z^1 * \chi_i(r) \chi_j(r) e^{-\beta (r - B_center)^2} \frac{\erf(\mu | r - R_C | )}{ | r - R_C | }$.
!
! ints(5) = $\int_{-\infty}^{infty} dr x^2 * \chi_i(r) \chi_j(r) e^{-\beta (r - B_center)^2} \frac{\erf(\mu | r - R_C | )}{ | r - R_C | }$.
! ints(6) = $\int_{-\infty}^{infty} dr y^2 * \chi_i(r) \chi_j(r) e^{-\beta (r - B_center)^2} \frac{\erf(\mu | r - R_C | )}{ | r - R_C | }$.
! ints(7) = $\int_{-\infty}^{infty} dr z^2 * \chi_i(r) \chi_j(r) e^{-\beta (r - B_center)^2} \frac{\erf(\mu | r - R_C | )}{ | r - R_C | }$.
!
END_DOC
include 'utils/constants.include.F'
implicit none
integer, intent(in) :: i_ao, j_ao
double precision, intent(in) :: beta, B_center(3), mu_in, C_center(3)
double precision, intent(out) :: ints(7)
integer :: i, j, power_Ai(3), power_Aj(3), n_pt_in, m
integer :: power_A1(3), power_A2(3)
double precision :: Ai_center(3), Aj_center(3), alphai, alphaj, coef, coefi
double precision :: integral0, integral1, integral2
double precision, external :: NAI_pol_mult_erf_with1s
ASSERT(beta .ge. 0.d0)
if(beta .lt. 1d-10) then
call NAI_pol_012_mult_erf_ao(i_ao, j_ao, mu_in, C_center, ints)
return
endif
ints = 0.d0
power_Ai(1:3) = ao_power(i_ao,1:3)
power_Aj(1:3) = ao_power(j_ao,1:3)
Ai_center(1:3) = nucl_coord(ao_nucl(i_ao),1:3)
Aj_center(1:3) = nucl_coord(ao_nucl(j_ao),1:3)
n_pt_in = n_pt_max_integrals
do i = 1, ao_prim_num(i_ao)
alphai = ao_expo_ordered_transp (i,i_ao)
coefi = ao_coef_normalized_ordered_transp(i,i_ao)
do j = 1, ao_prim_num(j_ao)
alphaj = ao_expo_ordered_transp (j,j_ao)
coef = coefi * ao_coef_normalized_ordered_transp(j,j_ao)
integral0 = NAI_pol_mult_erf_with1s(Ai_center, Aj_center, power_Ai, power_Aj, alphai, alphaj, beta, B_center, C_center, n_pt_in, mu_in)
ints(1) += coef * integral0
do m = 1, 3
power_A1 = power_Ai
power_A1(m) += 1
integral1 = NAI_pol_mult_erf_with1s(Ai_center, Aj_center, power_A1, power_Aj, alphai, alphaj, beta, B_center, C_center, n_pt_in, mu_in)
ints(1+m) += coef * (integral1 + Ai_center(m)*integral0)
power_A2 = power_Ai
power_A2(m) += 2
integral2 = NAI_pol_mult_erf_with1s(Ai_center, Aj_center, power_A2, power_Aj, alphai, alphaj, beta, B_center, C_center, n_pt_in, mu_in)
ints(4+m) += coef * (integral2 + Ai_center(m) * (2.d0*integral1 + Ai_center(m)*integral0))
enddo
enddo
enddo
end subroutine NAI_pol_012_mult_erf_ao_with1s
! ---
subroutine NAI_pol_012_mult_erf_ao(i_ao, j_ao, mu_in, C_center, ints)
BEGIN_DOC
!
! Computes the following integral :
!
! int(1) = $\int_{-\infty}^{infty} dr x^0 * \chi_i(r) \chi_j(r) \frac{\erf(\mu | r - R_C | )}{ | r - R_C | }$.
!
! int(2) = $\int_{-\infty}^{infty} dr x^1 * \chi_i(r) \chi_j(r) \frac{\erf(\mu | r - R_C | )}{ | r - R_C | }$.
! int(3) = $\int_{-\infty}^{infty} dr y^1 * \chi_i(r) \chi_j(r) \frac{\erf(\mu | r - R_C | )}{ | r - R_C | }$.
! int(4) = $\int_{-\infty}^{infty} dr z^1 * \chi_i(r) \chi_j(r) \frac{\erf(\mu | r - R_C | )}{ | r - R_C | }$.
!
! int(5) = $\int_{-\infty}^{infty} dr x^2 * \chi_i(r) \chi_j(r) \frac{\erf(\mu | r - R_C | )}{ | r - R_C | }$.
! int(6) = $\int_{-\infty}^{infty} dr y^2 * \chi_i(r) \chi_j(r) \frac{\erf(\mu | r - R_C | )}{ | r - R_C | }$.
! int(7) = $\int_{-\infty}^{infty} dr z^2 * \chi_i(r) \chi_j(r) \frac{\erf(\mu | r - R_C | )}{ | r - R_C | }$.
!
END_DOC
include 'utils/constants.include.F'
implicit none
integer, intent(in) :: i_ao, j_ao
double precision, intent(in) :: mu_in, C_center(3)
double precision, intent(out) :: ints(7)
integer :: i, j, num_A, num_B, power_A(3), power_B(3), n_pt_in, m
integer :: power_A1(3), power_A2(3)
double precision :: A_center(3), B_center(3), alpha, beta, coef
double precision :: integral0, integral1, integral2
double precision :: NAI_pol_mult_erf
ints = 0.d0
num_A = ao_nucl(i_ao)
power_A(1:3) = ao_power(i_ao,1:3)
A_center(1:3) = nucl_coord(num_A,1:3)
num_B = ao_nucl(j_ao)
power_B(1:3) = ao_power(j_ao,1:3)
B_center(1:3) = nucl_coord(num_B,1:3)
n_pt_in = n_pt_max_integrals
do i = 1, ao_prim_num(i_ao)
alpha = ao_expo_ordered_transp(i,i_ao)
do j = 1, ao_prim_num(j_ao)
beta = ao_expo_ordered_transp(j,j_ao)
coef = ao_coef_normalized_ordered_transp(j,j_ao) * ao_coef_normalized_ordered_transp(i,i_ao)
integral0 = NAI_pol_mult_erf(A_center, B_center, power_A, power_B, alpha, beta, C_center, n_pt_in, mu_in)
ints(1) += coef * integral0
do m = 1, 3
power_A1 = power_A
power_A1(m) += 1
integral1 = NAI_pol_mult_erf(A_center, B_center, power_A1, power_B, alpha, beta, C_center, n_pt_in, mu_in)
ints(1+m) += coef * (integral1 + A_center(m)*integral0)
power_A2 = power_A
power_A2(m) += 2
integral2 = NAI_pol_mult_erf(A_center, B_center, power_A2, power_B, alpha, beta, C_center, n_pt_in, mu_in)
ints(4+m) += coef * (integral2 + A_center(m) * (2.d0*integral1 + A_center(m)*integral0))
enddo
enddo
enddo
end subroutine NAI_pol_012_mult_erf_ao
! ---

122
src/ao_many_one_e_ints/grad2_jmu_modif.irp.f
View File

@ -1,4 +1,72 @@
! ---
BEGIN_PROVIDER [ double precision, int2_grad1u2_grad2u2, (ao_num, ao_num, n_points_final_grid)]
BEGIN_DOC
!
! -\frac{1}{4} x int dr2 phi_i(r2) phi_j(r2) [1 - erf(mu r12)]^2
!
END_DOC
implicit none
integer :: i, j, ipoint, i_fit
double precision :: r(3), expo_fit, coef_fit
double precision :: tmp
double precision :: wall0, wall1
double precision, external :: overlap_gauss_r12_ao
print*, ' providing int2_grad1u2_grad2u2 ...'
call wall_time(wall0)
provide mu_erf final_grid_points j1b_pen
int2_grad1u2_grad2u2 = 0.d0
!$OMP PARALLEL DEFAULT (NONE) &
!$OMP PRIVATE (ipoint, i, j, i_fit, r, coef_fit, expo_fit, tmp) &
!$OMP SHARED (n_points_final_grid, ao_num, final_grid_points, ng_fit_jast, &
!$OMP expo_gauss_1_erf_x_2, coef_gauss_1_erf_x_2,int2_grad1u2_grad2u2)
!$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_fit = 1, ng_fit_jast
expo_fit = expo_gauss_1_erf_x_2(i_fit)
coef_fit = coef_gauss_1_erf_x_2(i_fit)
tmp += -0.25d0 * coef_fit * overlap_gauss_r12_ao(r, expo_fit, i, j)
enddo
int2_grad1u2_grad2u2(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_grad1u2_grad2u2(j,i,ipoint) = int2_grad1u2_grad2u2(i,j,ipoint)
enddo
enddo
enddo
call wall_time(wall1)
print*, ' wall time for int2_grad1u2_grad2u2 =', wall1 - wall0
END_PROVIDER
! --- ! ---
BEGIN_PROVIDER [ double precision, int2_grad1u2_grad2u2_j1b2, (ao_num, ao_num, n_points_final_grid)] BEGIN_PROVIDER [ double precision, int2_grad1u2_grad2u2_j1b2, (ao_num, ao_num, n_points_final_grid)]
@ -26,15 +94,15 @@ BEGIN_PROVIDER [ double precision, int2_grad1u2_grad2u2_j1b2, (ao_num, ao_num, n
int2_grad1u2_grad2u2_j1b2 = 0.d0 int2_grad1u2_grad2u2_j1b2 = 0.d0
!$OMP PARALLEL DEFAULT (NONE) & !$OMP PARALLEL DEFAULT (NONE) &
!$OMP PRIVATE (ipoint, i, j, i_1s, i_fit, r, coef, beta, B_center, & !$OMP PRIVATE (ipoint, i, j, i_1s, i_fit, r, coef, beta, B_center, &
!$OMP coef_fit, expo_fit, int_fit, tmp) & !$OMP coef_fit, expo_fit, int_fit, tmp) &
!$OMP SHARED (n_points_final_grid, ao_num, List_all_comb_b3_size, & !$OMP SHARED (n_points_final_grid, ao_num, List_all_comb_b3_size, &
!$OMP final_grid_points, ng_fit_jast, & !$OMP final_grid_points, ng_fit_jast, &
!$OMP expo_gauss_1_erf_x_2, coef_gauss_1_erf_x_2, & !$OMP expo_gauss_1_erf_x_2, coef_gauss_1_erf_x_2, &
!$OMP List_all_comb_b3_coef, List_all_comb_b3_expo, & !$OMP List_all_comb_b3_coef, List_all_comb_b3_expo, &
!$OMP List_all_comb_b3_cent, int2_grad1u2_grad2u2_j1b2) !$OMP List_all_comb_b3_cent, int2_grad1u2_grad2u2_j1b2)
!$OMP DO !$OMP DO
do ipoint = 1, n_points_final_grid do ipoint = 1, n_points_final_grid
r(1) = final_grid_points(1,ipoint) r(1) = final_grid_points(1,ipoint)
r(2) = final_grid_points(2,ipoint) r(2) = final_grid_points(2,ipoint)
@ -53,13 +121,14 @@ BEGIN_PROVIDER [ double precision, int2_grad1u2_grad2u2_j1b2, (ao_num, ao_num, n
int_fit = overlap_gauss_r12_ao(r, expo_fit, i, j) int_fit = overlap_gauss_r12_ao(r, expo_fit, i, j)
tmp += -0.25d0 * coef_fit * int_fit tmp += -0.25d0 * coef_fit * int_fit
! if(dabs(coef_fit*int_fit) .lt. 1d-12) cycle ! if(dabs(coef_fit*int_fit) .lt. 1d-12) cycle
! --- ! ---
do i_1s = 2, List_all_comb_b3_size do i_1s = 2, List_all_comb_b3_size
coef = List_all_comb_b3_coef (i_1s) coef = List_all_comb_b3_coef (i_1s)
if(dabs(coef) .lt. 1d-15) cycle ! beta = 0.0
beta = List_all_comb_b3_expo (i_1s) beta = List_all_comb_b3_expo (i_1s)
B_center(1) = List_all_comb_b3_cent(1,i_1s) B_center(1) = List_all_comb_b3_cent(1,i_1s)
B_center(2) = List_all_comb_b3_cent(2,i_1s) B_center(2) = List_all_comb_b3_cent(2,i_1s)
@ -78,8 +147,8 @@ BEGIN_PROVIDER [ double precision, int2_grad1u2_grad2u2_j1b2, (ao_num, ao_num, n
enddo enddo
enddo enddo
enddo enddo
!$OMP END DO !$OMP END DO
!$OMP END PARALLEL !$OMP END PARALLEL
do ipoint = 1, n_points_final_grid do ipoint = 1, n_points_final_grid
do i = 2, ao_num do i = 2, ao_num
@ -96,7 +165,7 @@ END_PROVIDER
! --- ! ---
BEGIN_PROVIDER [ double precision, int2_u2_j1b2, (ao_num, ao_num, n_points_final_grid)] BEGIN_PROVIDER [double precision, int2_u2_j1b2, (ao_num, ao_num, n_points_final_grid)]
BEGIN_DOC BEGIN_DOC
! !
@ -120,15 +189,15 @@ BEGIN_PROVIDER [ double precision, int2_u2_j1b2, (ao_num, ao_num, n_points_final
int2_u2_j1b2 = 0.d0 int2_u2_j1b2 = 0.d0
!$OMP PARALLEL DEFAULT (NONE) & !$OMP PARALLEL DEFAULT (NONE) &
!$OMP PRIVATE (ipoint, i, j, i_1s, i_fit, r, coef, beta, B_center, & !$OMP PRIVATE (ipoint, i, j, i_1s, i_fit, r, coef, beta, B_center, &
!$OMP coef_fit, expo_fit, int_fit, tmp) & !$OMP coef_fit, expo_fit, int_fit, tmp) &
!$OMP SHARED (n_points_final_grid, ao_num, List_all_comb_b3_size, & !$OMP SHARED (n_points_final_grid, ao_num, List_all_comb_b3_size, &
!$OMP final_grid_points, ng_fit_jast, & !$OMP final_grid_points, ng_fit_jast, &
!$OMP expo_gauss_j_mu_x_2, coef_gauss_j_mu_x_2, & !$OMP expo_gauss_j_mu_x_2, coef_gauss_j_mu_x_2, &
!$OMP List_all_comb_b3_coef, List_all_comb_b3_expo, & !$OMP List_all_comb_b3_coef, List_all_comb_b3_expo, &
!$OMP List_all_comb_b3_cent, int2_u2_j1b2) !$OMP List_all_comb_b3_cent, int2_u2_j1b2)
!$OMP DO !$OMP DO
do ipoint = 1, n_points_final_grid do ipoint = 1, n_points_final_grid
r(1) = final_grid_points(1,ipoint) r(1) = final_grid_points(1,ipoint)
r(2) = final_grid_points(2,ipoint) r(2) = final_grid_points(2,ipoint)
@ -147,13 +216,14 @@ 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) int_fit = overlap_gauss_r12_ao(r, expo_fit, i, j)
tmp += coef_fit * int_fit tmp += coef_fit * int_fit
! if(dabs(coef_fit*int_fit) .lt. 1d-12) cycle ! if(dabs(coef_fit*int_fit) .lt. 1d-12) cycle
! --- ! ---
do i_1s = 2, List_all_comb_b3_size do i_1s = 2, List_all_comb_b3_size
coef = List_all_comb_b3_coef (i_1s) coef = List_all_comb_b3_coef (i_1s)
if(dabs(coef) .lt. 1d-15) cycle ! beta = 0.0
beta = List_all_comb_b3_expo (i_1s) beta = List_all_comb_b3_expo (i_1s)
B_center(1) = List_all_comb_b3_cent(1,i_1s) B_center(1) = List_all_comb_b3_cent(1,i_1s)
B_center(2) = List_all_comb_b3_cent(2,i_1s) B_center(2) = List_all_comb_b3_cent(2,i_1s)
@ -172,8 +242,8 @@ BEGIN_PROVIDER [ double precision, int2_u2_j1b2, (ao_num, ao_num, n_points_final
enddo enddo
enddo enddo
enddo enddo
!$OMP END DO !$OMP END DO
!$OMP END PARALLEL !$OMP END PARALLEL
do ipoint = 1, n_points_final_grid do ipoint = 1, n_points_final_grid
do i = 2, ao_num do i = 2, ao_num
@ -254,6 +324,7 @@ BEGIN_PROVIDER [ double precision, int2_u_grad1u_x_j1b2, (ao_num, ao_num, n_poin
do i_1s = 2, List_all_comb_b3_size do i_1s = 2, List_all_comb_b3_size
coef = List_all_comb_b3_coef (i_1s) coef = List_all_comb_b3_coef (i_1s)
if(dabs(coef) .lt. 1d-15) cycle ! beta = 0.0
beta = List_all_comb_b3_expo (i_1s) beta = List_all_comb_b3_expo (i_1s)
B_center(1) = List_all_comb_b3_cent(1,i_1s) B_center(1) = List_all_comb_b3_cent(1,i_1s)
B_center(2) = List_all_comb_b3_cent(2,i_1s) B_center(2) = List_all_comb_b3_cent(2,i_1s)
@ -368,6 +439,7 @@ BEGIN_PROVIDER [ double precision, int2_u_grad1u_j1b2, (ao_num, ao_num, n_points
do i_1s = 2, List_all_comb_b3_size do i_1s = 2, List_all_comb_b3_size
coef = List_all_comb_b3_coef (i_1s) coef = List_all_comb_b3_coef (i_1s)
if(dabs(coef) .lt. 1d-15) cycle ! beta = 0.0
beta = List_all_comb_b3_expo (i_1s) beta = List_all_comb_b3_expo (i_1s)
B_center(1) = List_all_comb_b3_cent(1,i_1s) B_center(1) = List_all_comb_b3_cent(1,i_1s)
B_center(2) = List_all_comb_b3_cent(2,i_1s) B_center(2) = List_all_comb_b3_cent(2,i_1s)

332
src/ao_many_one_e_ints/grad_lapl_jmu_modif.irp.f
View File

@ -24,12 +24,12 @@ BEGIN_PROVIDER [ double precision, v_ij_erf_rk_cst_mu_j1b, (ao_num, ao_num, n_po
v_ij_erf_rk_cst_mu_j1b = 0.d0 v_ij_erf_rk_cst_mu_j1b = 0.d0
!$OMP PARALLEL DEFAULT (NONE) & !$OMP PARALLEL DEFAULT (NONE) &
!$OMP PRIVATE (ipoint, i, j, i_1s, r, coef, beta, B_center, int_mu, int_coulomb, tmp) & !$OMP PRIVATE (ipoint, i, j, i_1s, r, coef, beta, B_center, int_mu, int_coulomb, tmp) &
!$OMP SHARED (n_points_final_grid, ao_num, List_all_comb_b2_size, final_grid_points, & !$OMP 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 List_all_comb_b2_coef, List_all_comb_b2_expo, List_all_comb_b2_cent, &
!$OMP v_ij_erf_rk_cst_mu_j1b, mu_erf) !$OMP v_ij_erf_rk_cst_mu_j1b, mu_erf)
!$OMP DO !$OMP DO
!do ipoint = 1, 10 !do ipoint = 1, 10
do ipoint = 1, n_points_final_grid do ipoint = 1, n_points_final_grid
r(1) = final_grid_points(1,ipoint) r(1) = final_grid_points(1,ipoint)
@ -51,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_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) int_coulomb = NAI_pol_mult_erf_ao_with1s(i, j, beta, B_center, 1.d+9, r)
! if(dabs(coef)*dabs(int_mu - int_coulomb) .lt. 1d-12) cycle ! if(dabs(coef)*dabs(int_mu - int_coulomb) .lt. 1d-12) cycle
tmp += coef * (int_mu - int_coulomb) tmp += coef * (int_mu - int_coulomb)
@ -60,6 +60,7 @@ BEGIN_PROVIDER [ double precision, v_ij_erf_rk_cst_mu_j1b, (ao_num, ao_num, n_po
do i_1s = 2, List_all_comb_b2_size do i_1s = 2, List_all_comb_b2_size
coef = List_all_comb_b2_coef (i_1s) coef = List_all_comb_b2_coef (i_1s)
if(dabs(coef) .lt. 1d-15) cycle ! beta = 0.0
beta = List_all_comb_b2_expo (i_1s) beta = List_all_comb_b2_expo (i_1s)
B_center(1) = List_all_comb_b2_cent(1,i_1s) B_center(1) = List_all_comb_b2_cent(1,i_1s)
B_center(2) = List_all_comb_b2_cent(2,i_1s) B_center(2) = List_all_comb_b2_cent(2,i_1s)
@ -77,8 +78,8 @@ BEGIN_PROVIDER [ double precision, v_ij_erf_rk_cst_mu_j1b, (ao_num, ao_num, n_po
enddo enddo
enddo enddo
enddo enddo
!$OMP END DO !$OMP END DO
!$OMP END PARALLEL !$OMP END PARALLEL
do ipoint = 1, n_points_final_grid do ipoint = 1, n_points_final_grid
do i = 2, ao_num do i = 2, ao_num
@ -112,13 +113,13 @@ BEGIN_PROVIDER [ double precision, x_v_ij_erf_rk_cst_mu_j1b, (ao_num, ao_num, n_
x_v_ij_erf_rk_cst_mu_j1b = 0.d0 x_v_ij_erf_rk_cst_mu_j1b = 0.d0
!$OMP PARALLEL DEFAULT (NONE) & !$OMP PARALLEL DEFAULT (NONE) &
!$OMP PRIVATE (ipoint, i, j, i_1s, r, coef, beta, B_center, ints, ints_coulomb, & !$OMP PRIVATE (ipoint, i, j, i_1s, r, coef, beta, B_center, ints, ints_coulomb, &
!$OMP tmp_x, tmp_y, tmp_z) & !$OMP tmp_x, tmp_y, tmp_z) &
!$OMP SHARED (n_points_final_grid, ao_num, List_all_comb_b2_size, final_grid_points,& !$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 List_all_comb_b2_coef, List_all_comb_b2_expo, List_all_comb_b2_cent, &
!$OMP x_v_ij_erf_rk_cst_mu_j1b, mu_erf) !$OMP x_v_ij_erf_rk_cst_mu_j1b, mu_erf)
!$OMP DO !$OMP DO
!do ipoint = 1, 10 !do ipoint = 1, 10
do ipoint = 1, n_points_final_grid do ipoint = 1, n_points_final_grid
r(1) = final_grid_points(1,ipoint) r(1) = final_grid_points(1,ipoint)
@ -143,7 +144,7 @@ BEGIN_PROVIDER [ double precision, x_v_ij_erf_rk_cst_mu_j1b, (ao_num, ao_num, n_
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, mu_erf, r, ints )
call NAI_pol_x_mult_erf_ao_with1s(i, j, beta, B_center, 1.d+9, r, ints_coulomb) call NAI_pol_x_mult_erf_ao_with1s(i, j, beta, B_center, 1.d+9, r, ints_coulomb)
! 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 ! 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_x += coef * (ints(1) - ints_coulomb(1))
tmp_y += coef * (ints(2) - ints_coulomb(2)) tmp_y += coef * (ints(2) - ints_coulomb(2))
@ -154,6 +155,7 @@ BEGIN_PROVIDER [ double precision, x_v_ij_erf_rk_cst_mu_j1b, (ao_num, ao_num, n_
do i_1s = 2, List_all_comb_b2_size do i_1s = 2, List_all_comb_b2_size
coef = List_all_comb_b2_coef (i_1s) coef = List_all_comb_b2_coef (i_1s)
if(dabs(coef) .lt. 1d-15) cycle ! beta = 0.0
beta = List_all_comb_b2_expo (i_1s) beta = List_all_comb_b2_expo (i_1s)
B_center(1) = List_all_comb_b2_cent(1,i_1s) B_center(1) = List_all_comb_b2_cent(1,i_1s)
B_center(2) = List_all_comb_b2_cent(2,i_1s) B_center(2) = List_all_comb_b2_cent(2,i_1s)
@ -175,8 +177,8 @@ BEGIN_PROVIDER [ double precision, x_v_ij_erf_rk_cst_mu_j1b, (ao_num, ao_num, n_
enddo enddo
enddo enddo
enddo enddo
!$OMP END DO !$OMP END DO
!$OMP END PARALLEL !$OMP END PARALLEL
do ipoint = 1, n_points_final_grid do ipoint = 1, n_points_final_grid
do i = 2, ao_num do i = 2, ao_num
@ -195,8 +197,7 @@ END_PROVIDER
! --- ! ---
! TODO analytically BEGIN_PROVIDER [ double precision, v_ij_u_cst_mu_j1b_fit, (ao_num, ao_num, n_points_final_grid)]
BEGIN_PROVIDER [ double precision, v_ij_u_cst_mu_j1b, (ao_num, ao_num, n_points_final_grid)]
BEGIN_DOC BEGIN_DOC
! !
@ -213,23 +214,24 @@ BEGIN_PROVIDER [ double precision, v_ij_u_cst_mu_j1b, (ao_num, ao_num, n_points_
double precision, external :: overlap_gauss_r12_ao_with1s double precision, external :: overlap_gauss_r12_ao_with1s
print*, ' providing v_ij_u_cst_mu_j1b ...' print*, ' providing v_ij_u_cst_mu_j1b_fit ...'
call wall_time(wall0) call wall_time(wall0)
provide mu_erf final_grid_points j1b_pen provide mu_erf final_grid_points j1b_pen
PROVIDE ng_fit_jast expo_gauss_j_mu_x coef_gauss_j_mu_x
PROVIDE List_all_comb_b2_size List_all_comb_b2_coef List_all_comb_b2_expo List_all_comb_b2_cent
v_ij_u_cst_mu_j1b = 0.d0 v_ij_u_cst_mu_j1b_fit = 0.d0
!$OMP PARALLEL DEFAULT (NONE) & !$OMP PARALLEL DEFAULT (NONE) &
!$OMP PRIVATE (ipoint, i, j, i_1s, i_fit, r, coef, beta, B_center, & !$OMP PRIVATE (ipoint, i, j, i_1s, i_fit, r, coef, beta, B_center, &
!$OMP coef_fit, expo_fit, int_fit, tmp) & !$OMP coef_fit, expo_fit, int_fit, tmp) &
!$OMP SHARED (n_points_final_grid, ao_num, List_all_comb_b2_size, & !$OMP SHARED (n_points_final_grid, ao_num, List_all_comb_b2_size, &
!$OMP final_grid_points, ng_fit_jast, & !$OMP final_grid_points, ng_fit_jast, &
!$OMP expo_gauss_j_mu_x, coef_gauss_j_mu_x, & !$OMP expo_gauss_j_mu_x, coef_gauss_j_mu_x, &
!$OMP List_all_comb_b2_coef, List_all_comb_b2_expo, & !$OMP List_all_comb_b2_coef, List_all_comb_b2_expo, &
!$OMP List_all_comb_b2_cent, v_ij_u_cst_mu_j1b) !$OMP List_all_comb_b2_cent, v_ij_u_cst_mu_j1b_fit)
!$OMP DO !$OMP DO
!do ipoint = 1, 10
do ipoint = 1, n_points_final_grid do ipoint = 1, n_points_final_grid
r(1) = final_grid_points(1,ipoint) r(1) = final_grid_points(1,ipoint)
r(2) = final_grid_points(2,ipoint) r(2) = final_grid_points(2,ipoint)
@ -240,7 +242,6 @@ BEGIN_PROVIDER [ double precision, v_ij_u_cst_mu_j1b, (ao_num, ao_num, n_points_
tmp = 0.d0 tmp = 0.d0
do i_fit = 1, ng_fit_jast do i_fit = 1, ng_fit_jast
expo_fit = expo_gauss_j_mu_x(i_fit) expo_fit = expo_gauss_j_mu_x(i_fit)
coef_fit = coef_gauss_j_mu_x(i_fit) coef_fit = coef_gauss_j_mu_x(i_fit)
@ -253,7 +254,6 @@ 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) 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) int_fit = overlap_gauss_r12_ao_with1s(B_center, beta, r, expo_fit, i, j)
! if(dabs(int_fit*coef) .lt. 1d-12) cycle
tmp += coef * coef_fit * int_fit tmp += coef * coef_fit * int_fit
@ -262,6 +262,7 @@ BEGIN_PROVIDER [ double precision, v_ij_u_cst_mu_j1b, (ao_num, ao_num, n_points_
do i_1s = 2, List_all_comb_b2_size do i_1s = 2, List_all_comb_b2_size
coef = List_all_comb_b2_coef (i_1s) coef = List_all_comb_b2_coef (i_1s)
if(dabs(coef) .lt. 1d-15) cycle ! beta = 0.0
beta = List_all_comb_b2_expo (i_1s) beta = List_all_comb_b2_expo (i_1s)
B_center(1) = List_all_comb_b2_cent(1,i_1s) B_center(1) = List_all_comb_b2_cent(1,i_1s)
B_center(2) = List_all_comb_b2_cent(2,i_1s) B_center(2) = List_all_comb_b2_cent(2,i_1s)
@ -276,25 +277,276 @@ BEGIN_PROVIDER [ double precision, v_ij_u_cst_mu_j1b, (ao_num, ao_num, n_points_
enddo enddo
v_ij_u_cst_mu_j1b(j,i,ipoint) = tmp v_ij_u_cst_mu_j1b_fit(j,i,ipoint) = tmp
enddo enddo
enddo enddo
enddo enddo
!$OMP END DO !$OMP END DO
!$OMP END PARALLEL !$OMP END PARALLEL
do ipoint = 1, n_points_final_grid do ipoint = 1, n_points_final_grid
do i = 2, ao_num do i = 2, ao_num
do j = 1, i-1 do j = 1, i-1
v_ij_u_cst_mu_j1b(j,i,ipoint) = v_ij_u_cst_mu_j1b(i,j,ipoint) v_ij_u_cst_mu_j1b_fit(j,i,ipoint) = v_ij_u_cst_mu_j1b_fit(i,j,ipoint)
enddo enddo
enddo enddo
enddo enddo
call wall_time(wall1) call wall_time(wall1)
print*, ' wall time for v_ij_u_cst_mu_j1b', wall1 - wall0 print*, ' wall time for v_ij_u_cst_mu_j1b_fit', wall1 - wall0
END_PROVIDER END_PROVIDER
! --- ! ---
BEGIN_PROVIDER [double precision, v_ij_u_cst_mu_j1b_an_old, (ao_num, ao_num, n_points_final_grid)]
BEGIN_DOC
!
! int dr2 phi_i(r2) phi_j(r2) 1s_j1b(r2) u(mu, r12)
!
END_DOC
include 'constants.include.F'
implicit none
integer :: i, j, ipoint, i_1s
double precision :: r(3), r1_2
double precision :: int_c1, int_e1, int_o
double precision :: int_c2(3), int_e2(3)
double precision :: int_c3(3), int_e3(3)
double precision :: coef, beta, B_center(3)
double precision :: tmp, ct
double precision :: wall0, wall1
double precision, external :: overlap_gauss_r12_ao_with1s
double precision, external :: NAI_pol_mult_erf_ao_with1s
print*, ' providing v_ij_u_cst_mu_j1b_an_old ...'
call wall_time(wall0)
provide mu_erf final_grid_points j1b_pen
PROVIDE List_all_comb_b2_size List_all_comb_b2_coef List_all_comb_b2_expo List_all_comb_b2_cent
ct = inv_sq_pi_2 / mu_erf
v_ij_u_cst_mu_j1b_an_old = 0.d0
!$OMP PARALLEL DEFAULT (NONE) &
!$OMP PRIVATE (ipoint, i, j, i_1s, r, coef, beta, B_center, &
!$OMP r1_2, tmp, int_c1, int_e1, int_o, int_c2, &
!$OMP int_e2, int_c3, int_e3) &
!$OMP SHARED (n_points_final_grid, ao_num, List_all_comb_b2_size, &
!$OMP final_grid_points, mu_erf, ct, &
!$OMP List_all_comb_b2_coef, List_all_comb_b2_expo, &
!$OMP List_all_comb_b2_cent, v_ij_u_cst_mu_j1b_an_old)
!$OMP 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)
r1_2 = 0.5d0 * (r(1)*r(1) + r(2)*r(2) + r(3)*r(3))
do i = 1, ao_num
do j = i, ao_num
! ---
coef = List_all_comb_b2_coef (1)
beta = List_all_comb_b2_expo (1)
B_center(1) = List_all_comb_b2_cent(1,1)
B_center(2) = List_all_comb_b2_cent(2,1)
B_center(3) = List_all_comb_b2_cent(3,1)
int_c1 = NAI_pol_mult_erf_ao_with1s(i, j, beta, B_center, 1.d+9, r)
int_e1 = NAI_pol_mult_erf_ao_with1s(i, j, beta, B_center, mu_erf, r)
call NAI_pol_x_mult_erf_ao_with1s(i, j, beta, B_center, 1.d+9, r, int_c2)
call NAI_pol_x_mult_erf_ao_with1s(i, j, beta, B_center, mu_erf, r, int_e2)
call NAI_pol_x2_mult_erf_ao_with1s(i, j, beta, B_center, 1.d+9, r, int_c3)
call NAI_pol_x2_mult_erf_ao_with1s(i, j, beta, B_center, mu_erf, r, int_e3)
int_o = overlap_gauss_r12_ao_with1s(B_center, beta, r, mu_erf*mu_erf, i, j)
tmp = coef &
* ( r1_2 * (int_c1 - int_e1) &
- r(1) * (int_c2(1) - int_e2(1)) - r(2) * (int_c2(2) - int_e2(2)) - r(3) * (int_c2(3) - int_e2(3)) &
+ 0.5d0 * (int_c3(1) + int_c3(2) + int_c3(3) - int_e3(1) - int_e3(2) - int_e3(3)) &
- ct * int_o &
)
! ---
do i_1s = 2, List_all_comb_b2_size
coef = List_all_comb_b2_coef (i_1s)
if(dabs(coef) .lt. 1d-15) cycle ! beta = 0.0
beta = List_all_comb_b2_expo (i_1s)
B_center(1) = List_all_comb_b2_cent(1,i_1s)
B_center(2) = List_all_comb_b2_cent(2,i_1s)
B_center(3) = List_all_comb_b2_cent(3,i_1s)
int_c1 = NAI_pol_mult_erf_ao_with1s(i, j, beta, B_center, 1.d+9, r)
int_e1 = NAI_pol_mult_erf_ao_with1s(i, j, beta, B_center, mu_erf, r)
call NAI_pol_x_mult_erf_ao_with1s(i, j, beta, B_center, 1.d+9, r, int_c2)
call NAI_pol_x_mult_erf_ao_with1s(i, j, beta, B_center, mu_erf, r, int_e2)
call NAI_pol_x2_mult_erf_ao_with1s(i, j, beta, B_center, 1.d+9, r, int_c3)
call NAI_pol_x2_mult_erf_ao_with1s(i, j, beta, B_center, mu_erf, r, int_e3)
int_o = overlap_gauss_r12_ao_with1s(B_center, beta, r, mu_erf*mu_erf, i, j)
tmp = tmp + coef &
* ( r1_2 * (int_c1 - int_e1) &
- r(1) * (int_c2(1) - int_e2(1)) - r(2) * (int_c2(2) - int_e2(2)) - r(3) * (int_c2(3) - int_e2(3)) &
+ 0.5d0 * (int_c3(1) + int_c3(2) + int_c3(3) - int_e3(1) - int_e3(2) - int_e3(3)) &
- ct * int_o &
)
enddo
! ---
v_ij_u_cst_mu_j1b_an_old(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_an_old(j,i,ipoint) = v_ij_u_cst_mu_j1b_an_old(i,j,ipoint)
enddo
enddo
enddo
call wall_time(wall1)
print*, ' wall time for v_ij_u_cst_mu_j1b_an_old', wall1 - wall0
END_PROVIDER
! ---
BEGIN_PROVIDER [double precision, v_ij_u_cst_mu_j1b_an, (ao_num, ao_num, n_points_final_grid)]
BEGIN_DOC
!
! int dr2 phi_i(r2) phi_j(r2) 1s_j1b(r2) u(mu, r12)
!
END_DOC
include 'constants.include.F'
implicit none
integer :: i, j, ipoint, i_1s
double precision :: r(3), r1_2
double precision :: int_o
double precision :: int_c(7), int_e(7)
double precision :: coef, beta, B_center(3)
double precision :: tmp, ct
double precision :: wall0, wall1
double precision, external :: overlap_gauss_r12_ao_with1s
double precision, external :: NAI_pol_mult_erf_ao_with1s
print*, ' providing v_ij_u_cst_mu_j1b_an ...'
call wall_time(wall0)
provide mu_erf final_grid_points j1b_pen
PROVIDE List_all_comb_b2_size List_all_comb_b2_coef List_all_comb_b2_expo List_all_comb_b2_cent
ct = inv_sq_pi_2 / mu_erf
v_ij_u_cst_mu_j1b_an = 0.d0
!$OMP PARALLEL DEFAULT (NONE) &
!$OMP PRIVATE (ipoint, i, j, i_1s, r, coef, beta, B_center, &
!$OMP r1_2, tmp, int_c, int_e, int_o) &
!$OMP SHARED (n_points_final_grid, ao_num, List_all_comb_b2_size, &
!$OMP final_grid_points, mu_erf, ct, &
!$OMP List_all_comb_b2_coef, List_all_comb_b2_expo, &
!$OMP List_all_comb_b2_cent, v_ij_u_cst_mu_j1b_an)
!$OMP 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)
r1_2 = 0.5d0 * (r(1)*r(1) + r(2)*r(2) + r(3)*r(3))
do i = 1, ao_num
do j = i, ao_num
! ---
coef = List_all_comb_b2_coef (1)
beta = List_all_comb_b2_expo (1)
B_center(1) = List_all_comb_b2_cent(1,1)
B_center(2) = List_all_comb_b2_cent(2,1)
B_center(3) = List_all_comb_b2_cent(3,1)
call NAI_pol_012_mult_erf_ao_with1s(i, j, beta, B_center, 1.d+9, r, int_c)
call NAI_pol_012_mult_erf_ao_with1s(i, j, beta, B_center, mu_erf, r, int_e)
int_o = overlap_gauss_r12_ao_with1s(B_center, beta, r, mu_erf*mu_erf, i, j)
tmp = coef &
* ( r1_2 * (int_c(1) - int_e(1)) &
- r(1) * (int_c(2) - int_e(2)) - r(2) * (int_c(3) - int_e(3)) - r(3) * (int_c(4) - int_e(4)) &
+ 0.5d0 * (int_c(5) + int_c(6) + int_c(7) - int_e(5) - int_e(6) - int_e(7)) &
- ct * int_o &
)
! ---
do i_1s = 2, List_all_comb_b2_size
coef = List_all_comb_b2_coef (i_1s)
if(dabs(coef) .lt. 1d-15) cycle ! beta = 0.0
beta = List_all_comb_b2_expo (i_1s)
B_center(1) = List_all_comb_b2_cent(1,i_1s)
B_center(2) = List_all_comb_b2_cent(2,i_1s)
B_center(3) = List_all_comb_b2_cent(3,i_1s)
call NAI_pol_012_mult_erf_ao_with1s(i, j, beta, B_center, 1.d+9, r, int_c)
call NAI_pol_012_mult_erf_ao_with1s(i, j, beta, B_center, mu_erf, r, int_e)
int_o = overlap_gauss_r12_ao_with1s(B_center, beta, r, mu_erf*mu_erf, i, j)
tmp = tmp + coef &
* ( r1_2 * (int_c(1) - int_e(1)) &
- r(1) * (int_c(2) - int_e(2)) - r(2) * (int_c(3) - int_e(3)) - r(3) * (int_c(4) - int_e(4)) &
+ 0.5d0 * (int_c(5) + int_c(6) + int_c(7) - int_e(5) - int_e(6) - int_e(7)) &
- ct * int_o &
)
enddo
! ---
v_ij_u_cst_mu_j1b_an(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_an(j,i,ipoint) = v_ij_u_cst_mu_j1b_an(i,j,ipoint)
enddo
enddo
enddo
call wall_time(wall1)
print*, ' wall time for v_ij_u_cst_mu_j1b_an', wall1 - wall0
END_PROVIDER
! ---

299
src/ao_many_one_e_ints/listj1b.irp.f
View File

@ -1,17 +1,34 @@
! --- ! ---
BEGIN_PROVIDER [ integer, List_all_comb_b2_size] BEGIN_PROVIDER [integer, List_all_comb_b2_size]
implicit none implicit none
List_all_comb_b2_size = 2**nucl_num PROVIDE j1b_type
if((j1b_type .eq. 3) .or. (j1b_type .eq. 103)) then
List_all_comb_b2_size = 2**nucl_num
elseif((j1b_type .eq. 4) .or. (j1b_type .eq. 104)) then
List_all_comb_b2_size = nucl_num + 1
else
print *, 'j1b_type = ', j1b_type, 'is not implemented'
stop
endif
print *, ' nb of linear terms in the envelope is ', List_all_comb_b2_size
END_PROVIDER END_PROVIDER
! --- ! ---
BEGIN_PROVIDER [ integer, List_all_comb_b2, (nucl_num, List_all_comb_b2_size)] BEGIN_PROVIDER [integer, List_all_comb_b2, (nucl_num, List_all_comb_b2_size)]
implicit none implicit none
integer :: i, j integer :: i, j
@ -45,62 +62,85 @@ END_PROVIDER
double precision :: tmp_cent_x, tmp_cent_y, tmp_cent_z double precision :: tmp_cent_x, tmp_cent_y, tmp_cent_z
provide j1b_pen provide j1b_pen
provide j1b_pen_coef
List_all_comb_b2_coef = 0.d0 List_all_comb_b2_coef = 0.d0
List_all_comb_b2_expo = 0.d0 List_all_comb_b2_expo = 0.d0
List_all_comb_b2_cent = 0.d0 List_all_comb_b2_cent = 0.d0
do i = 1, List_all_comb_b2_size if((j1b_type .eq. 3) .or. (j1b_type .eq. 103)) then
tmp_cent_x = 0.d0 do i = 1, List_all_comb_b2_size
tmp_cent_y = 0.d0
tmp_cent_z = 0.d0
do j = 1, nucl_num
tmp_alphaj = dble(List_all_comb_b2(j,i)) * j1b_pen(j)
List_all_comb_b2_expo(i) += tmp_alphaj
tmp_cent_x += tmp_alphaj * nucl_coord(j,1)
tmp_cent_y += tmp_alphaj * nucl_coord(j,2)
tmp_cent_z += tmp_alphaj * nucl_coord(j,3)
enddo
if(List_all_comb_b2_expo(i) .lt. 1d-10) cycle tmp_cent_x = 0.d0
tmp_cent_y = 0.d0
List_all_comb_b2_cent(1,i) = tmp_cent_x / List_all_comb_b2_expo(i) tmp_cent_z = 0.d0
List_all_comb_b2_cent(2,i) = tmp_cent_y / List_all_comb_b2_expo(i) do j = 1, nucl_num
List_all_comb_b2_cent(3,i) = tmp_cent_z / List_all_comb_b2_expo(i) tmp_alphaj = dble(List_all_comb_b2(j,i)) * j1b_pen(j)
enddo List_all_comb_b2_expo(i) += tmp_alphaj
tmp_cent_x += tmp_alphaj * nucl_coord(j,1)
! --- tmp_cent_y += tmp_alphaj * nucl_coord(j,2)
tmp_cent_z += tmp_alphaj * nucl_coord(j,3)
do i = 1, List_all_comb_b2_size
do j = 2, nucl_num, 1
tmp_alphaj = dble(List_all_comb_b2(j,i)) * j1b_pen(j)
do k = 1, j-1, 1
tmp_alphak = dble(List_all_comb_b2(k,i)) * j1b_pen(k)
List_all_comb_b2_coef(i) += tmp_alphaj * tmp_alphak * ( (nucl_coord(j,1) - nucl_coord(k,1)) * (nucl_coord(j,1) - nucl_coord(k,1)) &
+ (nucl_coord(j,2) - nucl_coord(k,2)) * (nucl_coord(j,2) - nucl_coord(k,2)) &
+ (nucl_coord(j,3) - nucl_coord(k,3)) * (nucl_coord(j,3) - nucl_coord(k,3)) )
enddo enddo
if(List_all_comb_b2_expo(i) .lt. 1d-10) cycle
List_all_comb_b2_cent(1,i) = tmp_cent_x / List_all_comb_b2_expo(i)
List_all_comb_b2_cent(2,i) = tmp_cent_y / List_all_comb_b2_expo(i)
List_all_comb_b2_cent(3,i) = tmp_cent_z / List_all_comb_b2_expo(i)
enddo enddo
if(List_all_comb_b2_expo(i) .lt. 1d-10) cycle ! ---
List_all_comb_b2_coef(i) = List_all_comb_b2_coef(i) / List_all_comb_b2_expo(i) do i = 1, List_all_comb_b2_size
enddo
! --- do j = 2, nucl_num, 1
tmp_alphaj = dble(List_all_comb_b2(j,i)) * j1b_pen(j)
do k = 1, j-1, 1
tmp_alphak = dble(List_all_comb_b2(k,i)) * j1b_pen(k)
do i = 1, List_all_comb_b2_size List_all_comb_b2_coef(i) += tmp_alphaj * tmp_alphak * ( (nucl_coord(j,1) - nucl_coord(k,1)) * (nucl_coord(j,1) - nucl_coord(k,1)) &
+ (nucl_coord(j,2) - nucl_coord(k,2)) * (nucl_coord(j,2) - nucl_coord(k,2)) &
+ (nucl_coord(j,3) - nucl_coord(k,3)) * (nucl_coord(j,3) - nucl_coord(k,3)) )
enddo
enddo
phase = 0 if(List_all_comb_b2_expo(i) .lt. 1d-10) cycle
do j = 1, nucl_num
phase += List_all_comb_b2(j,i) List_all_comb_b2_coef(i) = List_all_comb_b2_coef(i) / List_all_comb_b2_expo(i)
enddo enddo
List_all_comb_b2_coef(i) = (-1.d0)**dble(phase) * dexp(-List_all_comb_b2_coef(i)) ! ---
enddo
do i = 1, List_all_comb_b2_size
phase = 0
do j = 1, nucl_num
phase += List_all_comb_b2(j,i)
enddo
List_all_comb_b2_coef(i) = (-1.d0)**dble(phase) * dexp(-List_all_comb_b2_coef(i))
enddo
elseif((j1b_type .eq. 4) .or. (j1b_type .eq. 104)) then
List_all_comb_b2_coef( 1) = 1.d0
List_all_comb_b2_expo( 1) = 0.d0
List_all_comb_b2_cent(1:3,1) = 0.d0
do i = 1, nucl_num
List_all_comb_b2_coef( i+1) = -1.d0 * j1b_pen_coef(i)
List_all_comb_b2_expo( i+1) = j1b_pen(i)
List_all_comb_b2_cent(1,i+1) = nucl_coord(i,1)
List_all_comb_b2_cent(2,i+1) = nucl_coord(i,2)
List_all_comb_b2_cent(3,i+1) = nucl_coord(i,3)
enddo
else
print *, 'j1b_type = ', j1b_type, 'is not implemented'
stop
endif
!print *, ' coeff, expo & cent of list b2' !print *, ' coeff, expo & cent of list b2'
!do i = 1, List_all_comb_b2_size !do i = 1, List_all_comb_b2_size
@ -115,14 +155,31 @@ END_PROVIDER
BEGIN_PROVIDER [ integer, List_all_comb_b3_size] BEGIN_PROVIDER [ integer, List_all_comb_b3_size]
implicit none implicit none
double precision :: tmp
List_all_comb_b3_size = 3**nucl_num if((j1b_type .eq. 3) .or. (j1b_type .eq. 103)) then
List_all_comb_b3_size = 3**nucl_num
elseif((j1b_type .eq. 4) .or. (j1b_type .eq. 104)) then
tmp = 0.5d0 * dble(nucl_num) * (dble(nucl_num) + 3.d0)
List_all_comb_b3_size = int(tmp) + 1
else
print *, 'j1b_type = ', j1b_type, 'is not implemented'
stop
endif
print *, ' nb of linear terms in the square of the envelope is ', List_all_comb_b3_size
END_PROVIDER END_PROVIDER
! --- ! ---
BEGIN_PROVIDER [ integer, List_all_comb_b3, (nucl_num, List_all_comb_b3_size)] BEGIN_PROVIDER [integer, List_all_comb_b3, (nucl_num, List_all_comb_b3_size)]
implicit none implicit none
integer :: i, j, ii, jj integer :: i, j, ii, jj
@ -162,68 +219,140 @@ END_PROVIDER
implicit none implicit none
integer :: i, j, k, phase integer :: i, j, k, phase
integer :: ii
double precision :: tmp_alphaj, tmp_alphak, facto double precision :: tmp_alphaj, tmp_alphak, facto
double precision :: tmp1, tmp2, tmp3, tmp4
double precision :: xi, yi, zi, xj, yj, zj
double precision :: dx, dy, dz, r2
provide j1b_pen provide j1b_pen
provide j1b_pen_coef
List_all_comb_b3_coef = 0.d0 List_all_comb_b3_coef = 0.d0
List_all_comb_b3_expo = 0.d0 List_all_comb_b3_expo = 0.d0
List_all_comb_b3_cent = 0.d0 List_all_comb_b3_cent = 0.d0
do i = 1, List_all_comb_b3_size if((j1b_type .eq. 3) .or. (j1b_type .eq. 103)) then
do j = 1, nucl_num do i = 1, List_all_comb_b3_size
tmp_alphaj = dble(List_all_comb_b3(j,i)) * j1b_pen(j)
List_all_comb_b3_expo(i) += tmp_alphaj
List_all_comb_b3_cent(1,i) += tmp_alphaj * nucl_coord(j,1)
List_all_comb_b3_cent(2,i) += tmp_alphaj * nucl_coord(j,2)
List_all_comb_b3_cent(3,i) += tmp_alphaj * nucl_coord(j,3)
do j = 1, nucl_num
tmp_alphaj = dble(List_all_comb_b3(j,i)) * j1b_pen(j)
List_all_comb_b3_expo(i) += tmp_alphaj
List_all_comb_b3_cent(1,i) += tmp_alphaj * nucl_coord(j,1)
List_all_comb_b3_cent(2,i) += tmp_alphaj * nucl_coord(j,2)
List_all_comb_b3_cent(3,i) += tmp_alphaj * nucl_coord(j,3)
enddo
if(List_all_comb_b3_expo(i) .lt. 1d-10) cycle
ASSERT(List_all_comb_b3_expo(i) .gt. 0d0)
List_all_comb_b3_cent(1,i) = List_all_comb_b3_cent(1,i) / List_all_comb_b3_expo(i)
List_all_comb_b3_cent(2,i) = List_all_comb_b3_cent(2,i) / List_all_comb_b3_expo(i)
List_all_comb_b3_cent(3,i) = List_all_comb_b3_cent(3,i) / List_all_comb_b3_expo(i)
enddo enddo
if(List_all_comb_b3_expo(i) .lt. 1d-10) cycle ! ---
ASSERT(List_all_comb_b3_expo(i) .gt. 0d0)
List_all_comb_b3_cent(1,i) = List_all_comb_b3_cent(1,i) / List_all_comb_b3_expo(i) do i = 1, List_all_comb_b3_size
List_all_comb_b3_cent(2,i) = List_all_comb_b3_cent(2,i) / List_all_comb_b3_expo(i)
List_all_comb_b3_cent(3,i) = List_all_comb_b3_cent(3,i) / List_all_comb_b3_expo(i)
enddo
! --- do j = 2, nucl_num, 1
tmp_alphaj = dble(List_all_comb_b3(j,i)) * j1b_pen(j)
do k = 1, j-1, 1
tmp_alphak = dble(List_all_comb_b3(k,i)) * j1b_pen(k)
do i = 1, List_all_comb_b3_size List_all_comb_b3_coef(i) += tmp_alphaj * tmp_alphak * ( (nucl_coord(j,1) - nucl_coord(k,1)) * (nucl_coord(j,1) - nucl_coord(k,1)) &
+ (nucl_coord(j,2) - nucl_coord(k,2)) * (nucl_coord(j,2) - nucl_coord(k,2)) &
+ (nucl_coord(j,3) - nucl_coord(k,3)) * (nucl_coord(j,3) - nucl_coord(k,3)) )
enddo
enddo
do j = 2, nucl_num, 1 if(List_all_comb_b3_expo(i) .lt. 1d-10) cycle
tmp_alphaj = dble(List_all_comb_b3(j,i)) * j1b_pen(j)
do k = 1, j-1, 1
tmp_alphak = dble(List_all_comb_b3(k,i)) * j1b_pen(k)
List_all_comb_b3_coef(i) += tmp_alphaj * tmp_alphak * ( (nucl_coord(j,1) - nucl_coord(k,1)) * (nucl_coord(j,1) - nucl_coord(k,1)) & List_all_comb_b3_coef(i) = List_all_comb_b3_coef(i) / List_all_comb_b3_expo(i)
+ (nucl_coord(j,2) - nucl_coord(k,2)) * (nucl_coord(j,2) - nucl_coord(k,2)) & enddo
+ (nucl_coord(j,3) - nucl_coord(k,3)) * (nucl_coord(j,3) - nucl_coord(k,3)) )
! ---
do i = 1, List_all_comb_b3_size
facto = 1.d0
phase = 0
do j = 1, nucl_num
tmp_alphaj = dble(List_all_comb_b3(j,i))
facto *= 2.d0 / (gamma(tmp_alphaj+1.d0) * gamma(3.d0-tmp_alphaj))
phase += List_all_comb_b3(j,i)
enddo
List_all_comb_b3_coef(i) = (-1.d0)**dble(phase) * facto * dexp(-List_all_comb_b3_coef(i))
enddo
elseif((j1b_type .eq. 4) .or. (j1b_type .eq. 104)) then
ii = 1
List_all_comb_b3_coef( ii) = 1.d0
List_all_comb_b3_expo( ii) = 0.d0
List_all_comb_b3_cent(1:3,ii) = 0.d0
do i = 1, nucl_num
ii = ii + 1
List_all_comb_b3_coef( ii) = -2.d0 * j1b_pen_coef(i)
List_all_comb_b3_expo( ii) = j1b_pen(i)
List_all_comb_b3_cent(1,ii) = nucl_coord(i,1)
List_all_comb_b3_cent(2,ii) = nucl_coord(i,2)
List_all_comb_b3_cent(3,ii) = nucl_coord(i,3)
enddo
do i = 1, nucl_num
ii = ii + 1
List_all_comb_b3_coef( ii) = 1.d0 * j1b_pen_coef(i) * j1b_pen_coef(i)
List_all_comb_b3_expo( ii) = 2.d0 * j1b_pen(i)
List_all_comb_b3_cent(1,ii) = nucl_coord(i,1)
List_all_comb_b3_cent(2,ii) = nucl_coord(i,2)
List_all_comb_b3_cent(3,ii) = nucl_coord(i,3)
enddo
do i = 1, nucl_num-1
tmp1 = j1b_pen(i)
xi = nucl_coord(i,1)
yi = nucl_coord(i,2)
zi = nucl_coord(i,3)
do j = i+1, nucl_num
tmp2 = j1b_pen(j)
tmp3 = tmp1 + tmp2
tmp4 = 1.d0 / tmp3
xj = nucl_coord(j,1)
yj = nucl_coord(j,2)
zj = nucl_coord(j,3)
dx = xi - xj
dy = yi - yj
dz = zi - zj
r2 = dx*dx + dy*dy + dz*dz
ii = ii + 1
! x 2 to avoid doing integrals twice
List_all_comb_b3_coef( ii) = 2.d0 * dexp(-tmp1*tmp2*tmp4*r2) * j1b_pen_coef(i) * j1b_pen_coef(j)
List_all_comb_b3_expo( ii) = tmp3
List_all_comb_b3_cent(1,ii) = tmp4 * (tmp1 * xi + tmp2 * xj)
List_all_comb_b3_cent(2,ii) = tmp4 * (tmp1 * yi + tmp2 * yj)
List_all_comb_b3_cent(3,ii) = tmp4 * (tmp1 * zi + tmp2 * zj)
enddo enddo
enddo enddo
if(List_all_comb_b3_expo(i) .lt. 1d-10) cycle else
List_all_comb_b3_coef(i) = List_all_comb_b3_coef(i) / List_all_comb_b3_expo(i) print *, 'j1b_type = ', j1b_type, 'is not implemented'
enddo stop
! --- endif
do i = 1, List_all_comb_b3_size
facto = 1.d0
phase = 0
do j = 1, nucl_num
tmp_alphaj = dble(List_all_comb_b3(j,i))
facto *= 2.d0 / (gamma(tmp_alphaj+1.d0) * gamma(3.d0-tmp_alphaj))
phase += List_all_comb_b3(j,i)
enddo
List_all_comb_b3_coef(i) = (-1.d0)**dble(phase) * facto * dexp(-List_all_comb_b3_coef(i))
enddo
!print *, ' coeff, expo & cent of list b3' !print *, ' coeff, expo & cent of list b3'
!do i = 1, List_all_comb_b3_size !do i = 1, List_all_comb_b3_size

1
src/ao_one_e_ints/NEED
View File

@ -1,3 +1,2 @@
ao_basis ao_basis
pseudo pseudo
cosgtos_ao_int

0
src/cosgtos_ao_int/aos_cosgtos.irp.f → src/ao_one_e_ints/aos_cosgtos.irp.f
View File

0
src/cosgtos_ao_int/one_e_Coul_integrals.irp.f → src/ao_one_e_ints/one_e_Coul_integrals_cosgtos.irp.f
View File

0
src/cosgtos_ao_int/one_e_kin_integrals.irp.f → src/ao_one_e_ints/one_e_kin_integrals_cosgtos.irp.f
View File

24
src/ao_one_e_ints/pot_ao_ints.irp.f
View File

@ -104,6 +104,9 @@ BEGIN_PROVIDER [ double precision, ao_integrals_n_e, (ao_num,ao_num)]
IF(do_pseudo) THEN IF(do_pseudo) THEN
ao_integrals_n_e += ao_pseudo_integrals ao_integrals_n_e += ao_pseudo_integrals
ENDIF ENDIF
IF(point_charges) THEN
ao_integrals_n_e += ao_integrals_pt_chrg
ENDIF
endif endif
@ -455,10 +458,12 @@ recursive subroutine I_x1_pol_mult_one_e(a,c,R1x,R1xp,R2x,d,nd,n_pt_in)
do ix=0,nx do ix=0,nx
X(ix) *= dble(c) X(ix) *= dble(c)
enddo enddo
call multiply_poly(X,nx,R2x,2,d,nd) ! call multiply_poly(X,nx,R2x,2,d,nd)
call multiply_poly_c2(X,nx,R2x,d,nd)
ny=0 ny=0
call I_x2_pol_mult_one_e(c,R1x,R1xp,R2x,Y,ny,n_pt_in) call I_x2_pol_mult_one_e(c,R1x,R1xp,R2x,Y,ny,n_pt_in)
call multiply_poly(Y,ny,R1x,2,d,nd) ! call multiply_poly(Y,ny,R1x,2,d,nd)
call multiply_poly_c2(Y,ny,R1x,d,nd)
else else
do ix=0,n_pt_in do ix=0,n_pt_in
X(ix) = 0.d0 X(ix) = 0.d0
@ -469,7 +474,8 @@ recursive subroutine I_x1_pol_mult_one_e(a,c,R1x,R1xp,R2x,d,nd,n_pt_in)
do ix=0,nx do ix=0,nx
X(ix) *= dble(a-1) X(ix) *= dble(a-1)
enddo enddo
call multiply_poly(X,nx,R2x,2,d,nd) ! call multiply_poly(X,nx,R2x,2,d,nd)
call multiply_poly_c2(X,nx,R2x,d,nd)
nx = nd nx = nd
do ix=0,n_pt_in do ix=0,n_pt_in
@ -479,10 +485,12 @@ recursive subroutine I_x1_pol_mult_one_e(a,c,R1x,R1xp,R2x,d,nd,n_pt_in)
do ix=0,nx do ix=0,nx
X(ix) *= dble(c) X(ix) *= dble(c)
enddo enddo
call multiply_poly(X,nx,R2x,2,d,nd) ! call multiply_poly(X,nx,R2x,2,d,nd)
call multiply_poly_c2(X,nx,R2x,d,nd)
ny=0 ny=0
call I_x1_pol_mult_one_e(a-1,c,R1x,R1xp,R2x,Y,ny,n_pt_in) call I_x1_pol_mult_one_e(a-1,c,R1x,R1xp,R2x,Y,ny,n_pt_in)
call multiply_poly(Y,ny,R1x,2,d,nd) ! call multiply_poly(Y,ny,R1x,2,d,nd)
call multiply_poly_c2(Y,ny,R1x,d,nd)
endif endif
end end
@ -519,7 +527,8 @@ recursive subroutine I_x2_pol_mult_one_e(c,R1x,R1xp,R2x,d,nd,dim)
do ix=0,nx do ix=0,nx
X(ix) *= dble(c-1) X(ix) *= dble(c-1)
enddo enddo
call multiply_poly(X,nx,R2x,2,d,nd) ! call multiply_poly(X,nx,R2x,2,d,nd)
call multiply_poly_c2(X,nx,R2x,d,nd)
ny = 0 ny = 0
do ix=0,dim do ix=0,dim
Y(ix) = 0.d0 Y(ix) = 0.d0
@ -527,7 +536,8 @@ recursive subroutine I_x2_pol_mult_one_e(c,R1x,R1xp,R2x,d,nd,dim)
call I_x1_pol_mult_one_e(0,c-1,R1x,R1xp,R2x,Y,ny,dim) call I_x1_pol_mult_one_e(0,c-1,R1x,R1xp,R2x,Y,ny,dim)
if(ny.ge.0)then if(ny.ge.0)then
call multiply_poly(Y,ny,R1xp,2,d,nd) ! call multiply_poly(Y,ny,R1xp,2,d,nd)
call multiply_poly_c2(Y,ny,R1xp,d,nd)
endif endif
endif endif
end end

14
src/ao_tc_eff_map/compute_ints_eff_pot.irp.f
View File

@ -53,13 +53,13 @@ subroutine compute_ao_tc_sym_two_e_pot_jl(j, l, n_integrals, buffer_i, buffer_va
integral_erf = ao_two_e_integral_erf(i, k, j, l) integral_erf = ao_two_e_integral_erf(i, k, j, l)
integral = integral_erf + integral_pot integral = integral_erf + integral_pot
if( j1b_type .eq. 1 ) then !if( j1b_type .eq. 1 ) then
!print *, ' j1b type 1 is added' ! !print *, ' j1b type 1 is added'
integral = integral + j1b_gauss_2e_j1(i, k, j, l) ! integral = integral + j1b_gauss_2e_j1(i, k, j, l)
elseif( j1b_type .eq. 2 ) then !elseif( j1b_type .eq. 2 ) then
!print *, ' j1b type 2 is added' ! !print *, ' j1b type 2 is added'
integral = integral + j1b_gauss_2e_j2(i, k, j, l) ! integral = integral + j1b_gauss_2e_j2(i, k, j, l)
endif !endif
if(abs(integral) < thr) then if(abs(integral) < thr) then
cycle cycle

29
src/ao_tc_eff_map/fit_j.irp.f
View File

@ -36,16 +36,25 @@ END_PROVIDER
END_PROVIDER END_PROVIDER
BEGIN_PROVIDER [ double precision, expo_j_xmu, (n_fit_1_erf_x) ] BEGIN_PROVIDER [ double precision, expo_j_xmu, (n_fit_1_erf_x) ]
implicit none
BEGIN_DOC BEGIN_DOC
! F(x) = x * (1 - erf(x)) - 1/sqrt(pi) * exp(-x**2) is fitted with a gaussian and a Slater ! F(x) = x * (1 - erf(x)) - 1/sqrt(pi) * exp(-x**2) is fitted with a gaussian and a Slater
! !
! \approx - 1/sqrt(pi) * exp(-alpha * x ) exp(-beta * x**2) ! \approx - 1/sqrt(pi) * exp(-alpha * x ) exp(-beta * x**2)
! !
! where alpha = expo_j_xmu(1) and beta = expo_j_xmu(2) ! where alpha = expo_j_xmu(1) and beta = expo_j_xmu(2)
END_DOC END_DOC
expo_j_xmu(1) = 1.7477d0
expo_j_xmu(2) = 0.668662d0 implicit none
!expo_j_xmu(1) = 1.7477d0
!expo_j_xmu(2) = 0.668662d0
!expo_j_xmu(1) = 1.74766377595541d0
!expo_j_xmu(2) = 0.668719925486403d0
expo_j_xmu(1) = 1.74770446934522d0
expo_j_xmu(2) = 0.668659706559979d0
END_PROVIDER END_PROVIDER

19
src/ao_two_e_ints/EZFIO.cfg
View File

@ -4,6 +4,25 @@ doc: Read/Write |AO| integrals from/to disk [ Write | Read | None ]
interface: ezfio,provider,ocaml interface: ezfio,provider,ocaml
default: None default: None
[io_ao_cholesky]
type: Disk_access
doc: Read/Write |AO| integrals from/to disk [ Write | Read | None ]
interface: ezfio,provider,ocaml
default: None
[ao_integrals_threshold]
type: Threshold
doc: If | (pq|rs) | < `ao_integrals_threshold` then (pq|rs) is zero
interface: ezfio,provider,ocaml
default: 1.e-15
ezfio_name: threshold_ao
[ao_cholesky_threshold]
type: Threshold
doc: If | (ii|jj) | < `ao_cholesky_threshold` then (ii|jj) is zero
interface: ezfio,provider,ocaml
default: 1.e-12
[do_direct_integrals] [do_direct_integrals]
type: logical type: logical
doc: Compute integrals on the fly (very slow, only for debugging) doc: Compute integrals on the fly (very slow, only for debugging)

483
src/ao_two_e_ints/cholesky.irp.f
View File

@ -1,88 +1,3 @@
BEGIN_PROVIDER [ integer, cholesky_ao_num_guess ]
implicit none
BEGIN_DOC
! Number of Cholesky vectors in AO basis
END_DOC
integer :: i,j,k,l
double precision :: xnorm0, x, integral
double precision, external :: ao_two_e_integral
cholesky_ao_num_guess = 0
xnorm0 = 0.d0
x = 0.d0
do j=1,ao_num
do i=1,ao_num
integral = ao_two_e_integral(i,i,j,j)
if (integral > ao_integrals_threshold) then
cholesky_ao_num_guess += 1
else
x += integral
endif
enddo
enddo
print *, 'Cholesky decomposition of AO integrals'
print *, '--------------------------------------'
print *, ''
print *, 'Estimated Error: ', x
print *, 'Guess size: ', cholesky_ao_num_guess, '(', 100.d0*dble(cholesky_ao_num_guess)/dble(ao_num*ao_num), ' %)'
END_PROVIDER
BEGIN_PROVIDER [ integer, cholesky_ao_num ]
&BEGIN_PROVIDER [ double precision, cholesky_ao, (ao_num, ao_num, cholesky_ao_num_guess) ]
use mmap_module
implicit none
BEGIN_DOC
! Cholesky vectors in AO basis: (ik|a):
! <ij|kl> = (ik|jl) = sum_a (ik|a).(a|jl)
END_DOC
type(c_ptr) :: ptr
integer :: fd, i,j,k,l, rank
double precision, pointer :: ao_integrals(:,:,:,:)
double precision, external :: ao_two_e_integral
! Store AO integrals in a memory mapped file
call mmap(trim(ezfio_work_dir)//'ao_integrals', &
(/ int(ao_num,8), int(ao_num,8), int(ao_num,8), int(ao_num,8) /), &
8, fd, .False., ptr)
call c_f_pointer(ptr, ao_integrals, (/ao_num, ao_num, ao_num, ao_num/))
double precision :: integral
logical, external :: ao_two_e_integral_zero
!$OMP PARALLEL DO DEFAULT(SHARED) PRIVATE(i,j,k,l, integral) SCHEDULE(dynamic)
do l=1,ao_num
do j=1,l
do k=1,ao_num
do i=1,k
if (ao_two_e_integral_zero(i,j,k,l)) cycle
integral = ao_two_e_integral(i,k,j,l)
ao_integrals(i,k,j,l) = integral
ao_integrals(k,i,j,l) = integral
ao_integrals(i,k,l,j) = integral
ao_integrals(k,i,l,j) = integral
enddo
enddo
enddo
enddo
!$OMP END PARALLEL DO
! Call Lapack
cholesky_ao_num = cholesky_ao_num_guess
call pivoted_cholesky(ao_integrals, cholesky_ao_num, ao_integrals_threshold, ao_num*ao_num, cholesky_ao)
print *, 'Rank: ', cholesky_ao_num, '(', 100.d0*dble(cholesky_ao_num)/dble(ao_num*ao_num), ' %)'
! Remove mmap
double precision, external :: getUnitAndOpen
call munmap( &
(/ int(ao_num,8), int(ao_num,8), int(ao_num,8), int(ao_num,8) /), &
8, fd, ptr)
open(unit=99,file=trim(ezfio_work_dir)//'ao_integrals')
close(99, status='delete')
END_PROVIDER
BEGIN_PROVIDER [ double precision, cholesky_ao_transp, (cholesky_ao_num, ao_num, ao_num) ] BEGIN_PROVIDER [ double precision, cholesky_ao_transp, (cholesky_ao_num, ao_num, ao_num) ]
implicit none implicit none
BEGIN_DOC BEGIN_DOC
@ -98,3 +13,401 @@ BEGIN_PROVIDER [ double precision, cholesky_ao_transp, (cholesky_ao_num, ao_num,
enddo enddo
END_PROVIDER END_PROVIDER
BEGIN_PROVIDER [ integer, cholesky_ao_num ]
&BEGIN_PROVIDER [ double precision, cholesky_ao, (ao_num, ao_num, 1) ]
implicit none
BEGIN_DOC
! Cholesky vectors in AO basis: (ik|a):
! <ij|kl> = (ik|jl) = sum_a (ik|a).(a|jl)
!
! Last dimension of cholesky_ao is cholesky_ao_num
END_DOC
integer :: rank, ndim
double precision :: tau
double precision, pointer :: L(:,:), L_old(:,:)
double precision :: s
double precision, parameter :: dscale = 1.d0
double precision, allocatable :: D(:), Delta(:,:), Ltmp_p(:,:), Ltmp_q(:,:)
integer, allocatable :: Lset(:), Dset(:), addr(:,:)
logical, allocatable :: computed(:)
integer :: i,j,k,m,p,q, qj, dj, p2, q2
integer :: N, np, nq
double precision :: Dmax, Dmin, Qmax, f
double precision, external :: get_ao_two_e_integral
logical, external :: ao_two_e_integral_zero
double precision, external :: ao_two_e_integral
integer :: block_size, iblock, ierr
double precision :: mem
double precision, external :: memory_of_double, memory_of_int
integer, external :: getUnitAndOpen
integer :: iunit
ndim = ao_num*ao_num
deallocate(cholesky_ao)
if (read_ao_cholesky) then
print *, 'Reading Cholesky vectors from disk...'
iunit = getUnitAndOpen(trim(ezfio_work_dir)//'cholesky_ao', 'R')
read(iunit) rank
allocate(cholesky_ao(ao_num,ao_num,rank), stat=ierr)
read(iunit) cholesky_ao
close(iunit)
cholesky_ao_num = rank
else
PROVIDE nucl_coord
if (do_direct_integrals) then
if (ao_two_e_integral(1,1,1,1) < huge(1.d0)) then
! Trigger providers inside ao_two_e_integral
continue
endif
else
PROVIDE ao_two_e_integrals_in_map
endif
tau = ao_cholesky_threshold
mem = 6.d0 * memory_of_double(ndim) + 6.d0 * memory_of_int(ndim)
call check_mem(mem, irp_here)
call print_memory_usage()
allocate(L(ndim,1))
print *, ''
print *, 'Cholesky decomposition of AO integrals'
print *, '======================================'
print *, ''
print *, '============ ============='
print *, ' Rank Threshold'
print *, '============ ============='
rank = 0
allocate( D(ndim), Lset(ndim), Dset(ndim) )
allocate( addr(3,ndim) )
! 1.
k=0
do j=1,ao_num
do i=1,ao_num
k = k+1
addr(1,k) = i
addr(2,k) = j
addr(3,k) = (i-1)*ao_num + j
enddo
enddo
if (do_direct_integrals) then
!$OMP PARALLEL DO DEFAULT(SHARED) PRIVATE(i) SCHEDULE(guided)
do i=1,ndim
D(i) = ao_two_e_integral(addr(1,i), addr(2,i), &
addr(1,i), addr(2,i))
enddo
!$OMP END PARALLEL DO
else
!$OMP PARALLEL DO DEFAULT(SHARED) PRIVATE(i) SCHEDULE(guided)
do i=1,ndim
D(i) = get_ao_two_e_integral(addr(1,i), addr(1,i), &
addr(2,i), addr(2,i), &
ao_integrals_map)
enddo
!$OMP END PARALLEL DO
endif
Dmax = maxval(D)
! 2.
np=0
do p=1,ndim
if ( dscale*dscale*Dmax*D(p) > tau*tau ) then
np = np+1
Lset(np) = p
endif
enddo
! 3.
N = 0
! 4.
i = 0
! 5.
do while ( (Dmax > tau).and.(rank < ndim) )
! a.
i = i+1
s = 0.01d0
! Inrease s until the arrays fit in memory
do while (.True.)
! b.
Dmin = max(s*Dmax,tau)
! c.
nq=0
do p=1,np
if ( D(Lset(p)) > Dmin ) then
nq = nq+1
Dset(nq) = Lset(p)
endif
enddo
call total_memory(mem)
mem = mem &
+ np*memory_of_double(nq) &! Delta(np,nq)
+ (rank+nq)* memory_of_double(ndim) &! L(ndim,rank+nq)
+ (np+nq)*memory_of_double(block_size) ! Ltmp_p(np,block_size) + Ltmp_q(nq,block_size)
if (mem > qp_max_mem) then
s = s*2.d0
else
exit
endif
if ((s > 1.d0).or.(nq == 0)) then
call print_memory_usage()
print *, 'Not enough memory. Reduce cholesky threshold'
stop -1
endif
enddo
! d., e.
block_size = max(N,24)
L_old => L
allocate(L(ndim,rank+nq), stat=ierr)
if (ierr /= 0) then
call print_memory_usage()
print *, irp_here, ': allocation failed : (L(ndim,rank+nq))'
stop -1
endif
!$OMP PARALLEL DO PRIVATE(k,j)
do k=1,rank
do j=1,ndim
L(j,k) = L_old(j,k)
enddo
enddo
!$OMP END PARALLEL DO
deallocate(L_old)
allocate(Delta(np,nq), stat=ierr)
if (ierr /= 0) then
call print_memory_usage()
print *, irp_here, ': allocation failed : (Delta(np,nq))'
stop -1
endif
allocate(Ltmp_p(np,block_size), stat=ierr)
if (ierr /= 0) then
call print_memory_usage()
print *, irp_here, ': allocation failed : (Ltmp_p(np,block_size))'
stop -1
endif
allocate(Ltmp_q(nq,block_size), stat=ierr)
if (ierr /= 0) then
call print_memory_usage()
print *, irp_here, ': allocation failed : (Ltmp_q(nq,block_size))'
stop -1
endif
allocate(computed(nq))
!$OMP PARALLEL DEFAULT(SHARED) PRIVATE(m,k,p,q,j)
!$OMP DO
do q=1,nq
do j=1,np
Delta(j,q) = 0.d0
enddo
computed(q) = .False.
enddo
!$OMP ENDDO NOWAIT
!$OMP DO
do k=1,N
do p=1,np
Ltmp_p(p,k) = L(Lset(p),k)
enddo
do q=1,nq
Ltmp_q(q,k) = L(Dset(q),k)
enddo
enddo
!$OMP END DO NOWAIT
!$OMP BARRIER
!$OMP END PARALLEL
if (N>0) then
call dgemm('N','T', np, nq, N, -1.d0, &
Ltmp_p, np, Ltmp_q, nq, 1.d0, Delta, np)
endif
! f.
Qmax = D(Dset(1))
do q=1,nq
Qmax = max(Qmax, D(Dset(q)))
enddo
! g.
iblock = 0
do j=1,nq
if ( (Qmax <= Dmin).or.(N+j > ndim) ) exit
! i.
rank = N+j
if (iblock == block_size) then
call dgemm('N','T',np,nq,block_size,-1.d0, &
Ltmp_p, np, Ltmp_q, nq, 1.d0, Delta, np)
iblock = 0
endif
! ii.
do dj=1,nq
qj = Dset(dj)
if (D(qj) == Qmax) then
exit
endif
enddo
L(1:ndim, rank) = 0.d0
if (.not.computed(dj)) then
m = dj
!$OMP PARALLEL DO PRIVATE(k) SCHEDULE(guided)
do k=np,1,-1
if (.not.ao_two_e_integral_zero( addr(1,Lset(k)), addr(1,Dset(m)),&
addr(2,Lset(k)), addr(2,Dset(m)) ) ) then
if (do_direct_integrals) then
Delta(k,m) = Delta(k,m) + &
ao_two_e_integral(addr(1,Lset(k)), addr(2,Lset(k)),&
addr(1,Dset(m)), addr(2,Dset(m)))
else
Delta(k,m) = Delta(k,m) + &
get_ao_two_e_integral( addr(1,Lset(k)), addr(1,Dset(m)),&
addr(2,Lset(k)), addr(2,Dset(m)), ao_integrals_map)
endif
endif
enddo
!$OMP END PARALLEL DO
computed(dj) = .True.
endif
iblock = iblock+1
do p=1,np
Ltmp_p(p,iblock) = Delta(p,dj)
enddo
! iv.
if (iblock > 1) then
call dgemv('N', np, iblock-1, -1.d0, Ltmp_p, np, Ltmp_q(dj,1), nq, 1.d0,&
Ltmp_p(1,iblock), 1)
endif
! iii.
f = 1.d0/dsqrt(Qmax)
!$OMP PARALLEL PRIVATE(m,p,q,k) DEFAULT(shared)
!$OMP DO
do p=1,np
Ltmp_p(p,iblock) = Ltmp_p(p,iblock) * f
L(Lset(p), rank) = Ltmp_p(p,iblock)
D(Lset(p)) = D(Lset(p)) - Ltmp_p(p,iblock) * Ltmp_p(p,iblock)
enddo
!$OMP END DO
!$OMP DO
do q=1,nq
Ltmp_q(q,iblock) = L(Dset(q), rank)
enddo
!$OMP END DO
!$OMP END PARALLEL
Qmax = D(Dset(1))
do q=1,nq
Qmax = max(Qmax, D(Dset(q)))
enddo
enddo
print '(I10, 4X, ES12.3)', rank, Qmax
deallocate(computed)
deallocate(Delta)
deallocate(Ltmp_p)
deallocate(Ltmp_q)
! i.
N = rank
! j.
Dmax = D(Lset(1))
do p=1,np
Dmax = max(Dmax, D(Lset(p)))
enddo
np=0
do p=1,ndim
if ( dscale*dscale*Dmax*D(p) > tau*tau ) then
np = np+1
Lset(np) = p
endif
enddo
enddo
allocate(cholesky_ao(ao_num,ao_num,rank), stat=ierr)
if (ierr /= 0) then
call print_memory_usage()
print *, irp_here, ': Allocation failed'
stop -1
endif
!$OMP PARALLEL DO PRIVATE(k)
do k=1,rank
call dcopy(ndim, L(1,k), 1, cholesky_ao(1,1,k), 1)
enddo
!$OMP END PARALLEL DO
deallocate(L)
cholesky_ao_num = rank
print *, '============ ============='
print *, ''
if (write_ao_cholesky) then
print *, 'Writing Cholesky vectors to disk...'
iunit = getUnitAndOpen(trim(ezfio_work_dir)//'cholesky_ao', 'W')
write(iunit) rank
write(iunit) cholesky_ao
close(iunit)
call ezfio_set_ao_two_e_ints_io_ao_cholesky('Read')
endif
endif
print *, 'Rank : ', cholesky_ao_num, '(', 100.d0*dble(cholesky_ao_num)/dble(ao_num*ao_num), ' %)'
print *, ''
END_PROVIDER

0
src/cosgtos_ao_int/gauss_legendre.irp.f → src/ao_two_e_ints/gauss_legendre.irp.f
View File

30
src/cosgtos_ao_int/two_e_Coul_integrals.irp.f → src/ao_two_e_ints/two_e_Coul_integrals_cosgtos.irp.f
View File

@ -29,14 +29,14 @@ double precision function ao_two_e_integral_cosgtos(i, j, k, l)
complex*16 :: integral5, integral6, integral7, integral8 complex*16 :: integral5, integral6, integral7, integral8
complex*16 :: integral_tot complex*16 :: integral_tot
double precision :: ao_two_e_integral_cosgtos_schwartz_accel double precision :: ao_2e_cosgtos_schwartz_accel
complex*16 :: ERI_cosgtos complex*16 :: ERI_cosgtos
complex*16 :: general_primitive_integral_cosgtos complex*16 :: general_primitive_integral_cosgtos
if(ao_prim_num(i) * ao_prim_num(j) * ao_prim_num(k) * ao_prim_num(l) > 1024) then if(ao_prim_num(i) * ao_prim_num(j) * ao_prim_num(k) * ao_prim_num(l) > 1024) then
!print *, ' with shwartz acc ' !print *, ' with shwartz acc '
ao_two_e_integral_cosgtos = ao_two_e_integral_cosgtos_schwartz_accel(i, j, k, l) ao_two_e_integral_cosgtos = ao_2e_cosgtos_schwartz_accel(i, j, k, l)
else else
!print *, ' without shwartz acc ' !print *, ' without shwartz acc '
@ -294,7 +294,7 @@ end function ao_two_e_integral_cosgtos
! --- ! ---
double precision function ao_two_e_integral_cosgtos_schwartz_accel(i, j, k, l) double precision function ao_2e_cosgtos_schwartz_accel(i, j, k, l)
BEGIN_DOC BEGIN_DOC
! integral of the AO basis <ik|jl> or (ij|kl) ! integral of the AO basis <ik|jl> or (ij|kl)
@ -329,7 +329,7 @@ double precision function ao_two_e_integral_cosgtos_schwartz_accel(i, j, k, l)
complex*16 :: ERI_cosgtos complex*16 :: ERI_cosgtos
complex*16 :: general_primitive_integral_cosgtos complex*16 :: general_primitive_integral_cosgtos
ao_two_e_integral_cosgtos_schwartz_accel = 0.d0 ao_2e_cosgtos_schwartz_accel = 0.d0
dim1 = n_pt_max_integrals dim1 = n_pt_max_integrals
@ -519,8 +519,7 @@ double precision function ao_two_e_integral_cosgtos_schwartz_accel(i, j, k, l)
integral_tot = integral1 + integral2 + integral3 + integral4 + integral5 + integral6 + integral7 + integral8 integral_tot = integral1 + integral2 + integral3 + integral4 + integral5 + integral6 + integral7 + integral8
ao_two_e_integral_cosgtos_schwartz_accel = ao_two_e_integral_cosgtos_schwartz_accel & ao_2e_cosgtos_schwartz_accel = ao_2e_cosgtos_schwartz_accel + coef4 * 2.d0 * real(integral_tot)
+ coef4 * 2.d0 * real(integral_tot)
enddo ! s enddo ! s
enddo ! r enddo ! r
enddo ! q enddo ! q
@ -698,8 +697,7 @@ double precision function ao_two_e_integral_cosgtos_schwartz_accel(i, j, k, l)
integral_tot = integral1 + integral2 + integral3 + integral4 + integral5 + integral6 + integral7 + integral8 integral_tot = integral1 + integral2 + integral3 + integral4 + integral5 + integral6 + integral7 + integral8
ao_two_e_integral_cosgtos_schwartz_accel = ao_two_e_integral_cosgtos_schwartz_accel & ao_2e_cosgtos_schwartz_accel = ao_2e_cosgtos_schwartz_accel + coef4 * 2.d0 * real(integral_tot)
+ coef4 * 2.d0 * real(integral_tot)
enddo ! s enddo ! s
enddo ! r enddo ! r
enddo ! q enddo ! q
@ -709,11 +707,11 @@ double precision function ao_two_e_integral_cosgtos_schwartz_accel(i, j, k, l)
deallocate(schwartz_kl) deallocate(schwartz_kl)
end function ao_two_e_integral_cosgtos_schwartz_accel end function ao_2e_cosgtos_schwartz_accel
! --- ! ---
BEGIN_PROVIDER [ double precision, ao_two_e_integral_cosgtos_schwartz, (ao_num,ao_num) ] BEGIN_PROVIDER [ double precision, ao_2e_cosgtos_schwartz, (ao_num,ao_num)]
BEGIN_DOC BEGIN_DOC
! Needed to compute Schwartz inequalities ! Needed to compute Schwartz inequalities
@ -723,16 +721,16 @@ BEGIN_PROVIDER [ double precision, ao_two_e_integral_cosgtos_schwartz, (ao_num,a
integer :: i, k integer :: i, k
double precision :: ao_two_e_integral_cosgtos double precision :: ao_two_e_integral_cosgtos
ao_two_e_integral_cosgtos_schwartz(1,1) = ao_two_e_integral_cosgtos(1, 1, 1, 1) ao_2e_cosgtos_schwartz(1,1) = ao_two_e_integral_cosgtos(1, 1, 1, 1)
!$OMP PARALLEL DO PRIVATE(i,k) & !$OMP PARALLEL DO PRIVATE(i,k) &
!$OMP DEFAULT(NONE) & !$OMP DEFAULT(NONE) &
!$OMP SHARED(ao_num, ao_two_e_integral_cosgtos_schwartz) & !$OMP SHARED(ao_num, ao_2e_cosgtos_schwartz) &
!$OMP SCHEDULE(dynamic) !$OMP SCHEDULE(dynamic)
do i = 1, ao_num do i = 1, ao_num
do k = 1, i do k = 1, i
ao_two_e_integral_cosgtos_schwartz(i,k) = dsqrt(ao_two_e_integral_cosgtos(i, i, k, k)) ao_2e_cosgtos_schwartz(i,k) = dsqrt(ao_two_e_integral_cosgtos(i, i, k, k))
ao_two_e_integral_cosgtos_schwartz(k,i) = ao_two_e_integral_cosgtos_schwartz(i,k) ao_2e_cosgtos_schwartz(k,i) = ao_2e_cosgtos_schwartz(i,k)
enddo enddo
enddo enddo
!$OMP END PARALLEL DO !$OMP END PARALLEL DO

585
src/ao_two_e_ints/two_e_integrals.irp.f
View File

@ -460,7 +460,7 @@ BEGIN_PROVIDER [ double precision, ao_two_e_integral_schwartz, (ao_num, ao_num)
!$OMP PARALLEL DO PRIVATE(i,k) & !$OMP PARALLEL DO PRIVATE(i,k) &
!$OMP DEFAULT(NONE) & !$OMP DEFAULT(NONE) &
!$OMP SHARED (ao_num,ao_two_e_integral_schwartz) & !$OMP SHARED (ao_num,ao_two_e_integral_schwartz) &
!$OMP SCHEDULE(dynamic) !$OMP SCHEDULE(guided)
do i=1,ao_num do i=1,ao_num
do k=1,i do k=1,i
ao_two_e_integral_schwartz(i,k) = dsqrt(ao_two_e_integral(i,i,k,k)) ao_two_e_integral_schwartz(i,k) = dsqrt(ao_two_e_integral(i,i,k,k))
@ -590,8 +590,20 @@ double precision function general_primitive_integral(dim, &
d_poly(i)=0.d0 d_poly(i)=0.d0
enddo enddo
!DIR$ FORCEINLINE ! call multiply_poly(Ix_pol,n_Ix,Iy_pol,n_Iy,d_poly,n_pt_tmp)
call multiply_poly(Ix_pol,n_Ix,Iy_pol,n_Iy,d_poly,n_pt_tmp) integer :: ib, ic
if (ior(n_Ix,n_Iy) >= 0) then
do ib=0,n_Ix
do ic = 0,n_Iy
d_poly(ib+ic) = d_poly(ib+ic) + Iy_pol(ic) * Ix_pol(ib)
enddo
enddo
do n_pt_tmp = n_Ix+n_Iy, 0, -1
if (d_poly(n_pt_tmp) /= 0.d0) exit
enddo
endif
if (n_pt_tmp == -1) then if (n_pt_tmp == -1) then
return return
endif endif
@ -600,8 +612,21 @@ double precision function general_primitive_integral(dim, &
d1(i)=0.d0 d1(i)=0.d0
enddo enddo
!DIR$ FORCEINLINE ! call multiply_poly(d_poly ,n_pt_tmp ,Iz_pol,n_Iz,d1,n_pt_out)
call multiply_poly(d_poly ,n_pt_tmp ,Iz_pol,n_Iz,d1,n_pt_out) if (ior(n_pt_tmp,n_Iz) >= 0) then
! Bottleneck here
do ib=0,n_pt_tmp
do ic = 0,n_Iz
d1(ib+ic) = d1(ib+ic) + Iz_pol(ic) * d_poly(ib)
enddo
enddo
do n_pt_out = n_pt_tmp+n_Iz, 0, -1
if (d1(n_pt_out) /= 0.d0) exit
enddo
endif
double precision :: rint_sum double precision :: rint_sum
accu = accu + rint_sum(n_pt_out,const,d1) accu = accu + rint_sum(n_pt_out,const,d1)
@ -926,7 +951,7 @@ recursive subroutine I_x1_pol_mult_recurs(a,c,B_10,B_01,B_00,C_00,D_00,d,nd,n_pt
double precision :: X(0:max_dim) double precision :: X(0:max_dim)
double precision :: Y(0:max_dim) double precision :: Y(0:max_dim)
!DIR$ ATTRIBUTES ALIGN : $IRP_ALIGN :: X,Y !DIR$ ATTRIBUTES ALIGN : $IRP_ALIGN :: X,Y
integer :: nx, ix,iy,ny integer :: nx, ix,iy,ny,ib
ASSERT (a>2) ASSERT (a>2)
!DIR$ LOOP COUNT(8) !DIR$ LOOP COUNT(8)
@ -948,8 +973,44 @@ recursive subroutine I_x1_pol_mult_recurs(a,c,B_10,B_01,B_00,C_00,D_00,d,nd,n_pt
X(ix) *= dble(a-1) X(ix) *= dble(a-1)
enddo enddo
!DIR$ FORCEINLINE ! !DIR$ FORCEINLINE
call multiply_poly(X,nx,B_10,2,d,nd) ! call multiply_poly_c2_inline_2e(X,nx,B_10,d,nd)
if (nx >= 0) then
select case (nx)
case (0)
d(0) = d(0) + B_10(0) * X(0)
d(1) = d(1) + B_10(1) * X(0)
d(2) = d(2) + B_10(2) * X(0)
case (1)
d(0) = d(0) + B_10(0) * X(0)
d(1) = d(1) + B_10(0) * X(1) + B_10(1) * X(0)
d(2) = d(2) + B_10(1) * X(1) + B_10(2) * X(0)
d(3) = d(3) + B_10(2) * X(1)
case (2)
d(0) = d(0) + B_10(0) * X(0)
d(1) = d(1) + B_10(0) * X(1) + B_10(1) * X(0)
d(2) = d(2) + B_10(0) * X(2) + B_10(1) * X(1) + B_10(2) * X(0)
d(3) = d(3) + B_10(1) * X(2) + B_10(2) * X(1)
d(4) = d(4) + B_10(2) * X(2)
case default
d(0) = d(0) + B_10(0) * X(0)
d(1) = d(1) + B_10(0) * X(1) + B_10(1) * X(0)
do ib=2,nx
d(ib) = d(ib) + B_10(0) * X(ib) + B_10(1) * X(ib-1) + B_10(2) * X(ib-2)
enddo
d(nx+1) = d(nx+1) + B_10(1) * X(nx) + B_10(2) * X(nx-1)
d(nx+2) = d(nx+2) + B_10(2) * X(nx)
end select
do nd = nx+2,0,-1
if (d(nd) /= 0.d0) exit
enddo
endif
nx = nd nx = nd
!DIR$ LOOP COUNT(8) !DIR$ LOOP COUNT(8)
@ -970,8 +1031,47 @@ recursive subroutine I_x1_pol_mult_recurs(a,c,B_10,B_01,B_00,C_00,D_00,d,nd,n_pt
X(ix) *= c X(ix) *= c
enddo enddo
endif endif
!DIR$ FORCEINLINE
call multiply_poly(X,nx,B_00,2,d,nd) ! !DIR$ FORCEINLINE
! call multiply_poly_c2_inline_2e(X,nx,B_00,d,nd)
if(nx >= 0) then
select case (nx)
case (0)
d(0) = d(0) + B_00(0) * X(0)
d(1) = d(1) + B_00(1) * X(0)
d(2) = d(2) + B_00(2) * X(0)
case (1)
d(0) = d(0) + B_00(0) * X(0)
d(1) = d(1) + B_00(0) * X(1) + B_00(1) * X(0)
d(2) = d(2) + B_00(1) * X(1) + B_00(2) * X(0)
d(3) = d(3) + B_00(2) * X(1)
case (2)
d(0) = d(0) + B_00(0) * X(0)
d(1) = d(1) + B_00(0) * X(1) + B_00(1) * X(0)
d(2) = d(2) + B_00(0) * X(2) + B_00(1) * X(1) + B_00(2) * X(0)
d(3) = d(3) + B_00(1) * X(2) + B_00(2) * X(1)
d(4) = d(4) + B_00(2) * X(2)
case default
d(0) = d(0) + B_00(0) * X(0)
d(1) = d(1) + B_00(0) * X(1) + B_00(1) * X(0)
do ib=2,nx
d(ib) = d(ib) + B_00(0) * X(ib) + B_00(1) * X(ib-1) + B_00(2) * X(ib-2)
enddo
d(nx+1) = d(nx+1) + B_00(1) * X(nx) + B_00(2) * X(nx-1)
d(nx+2) = d(nx+2) + B_00(2) * X(nx)
end select
do nd = nx+2,0,-1
if (d(nd) /= 0.d0) exit
enddo
endif
endif endif
ny=0 ny=0
@ -988,8 +1088,45 @@ recursive subroutine I_x1_pol_mult_recurs(a,c,B_10,B_01,B_00,C_00,D_00,d,nd,n_pt
call I_x1_pol_mult_recurs(a-1,c,B_10,B_01,B_00,C_00,D_00,Y,ny,n_pt_in) call I_x1_pol_mult_recurs(a-1,c,B_10,B_01,B_00,C_00,D_00,Y,ny,n_pt_in)
endif endif
!DIR$ FORCEINLINE ! !DIR$ FORCEINLINE
call multiply_poly(Y,ny,C_00,2,d,nd) ! call multiply_poly_c2_inline_2e(Y,ny,C_00,d,nd)
if(ny >= 0) then
select case (ny)
case (0)
d(0) = d(0) + C_00(0) * Y(0)
d(1) = d(1) + C_00(1) * Y(0)
d(2) = d(2) + C_00(2) * Y(0)
case (1)
d(0) = d(0) + C_00(0) * Y(0)
d(1) = d(1) + C_00(0) * Y(1) + C_00(1) * Y(0)
d(2) = d(2) + C_00(1) * Y(1) + C_00(2) * Y(0)
d(3) = d(3) + C_00(2) * Y(1)
case (2)
d(0) = d(0) + C_00(0) * Y(0)
d(1) = d(1) + C_00(0) * Y(1) + C_00(1) * Y(0)
d(2) = d(2) + C_00(0) * Y(2) + C_00(1) * Y(1) + C_00(2) * Y(0)
d(3) = d(3) + C_00(1) * Y(2) + C_00(2) * Y(1)
d(4) = d(4) + C_00(2) * Y(2)
case default
d(0) = d(0) + C_00(0) * Y(0)
d(1) = d(1) + C_00(0) * Y(1) + C_00(1) * Y(0)
do ib=2,ny
d(ib) = d(ib) + C_00(0) * Y(ib) + C_00(1) * Y(ib-1) + C_00(2) * Y(ib-2)
enddo
d(ny+1) = d(ny+1) + C_00(1) * Y(ny) + C_00(2) * Y(ny-1)
d(ny+2) = d(ny+2) + C_00(2) * Y(ny)
end select
do nd = ny+2,0,-1
if (d(nd) /= 0.d0) exit
enddo
endif
end end
@ -1007,7 +1144,7 @@ recursive subroutine I_x1_pol_mult_a1(c,B_10,B_01,B_00,C_00,D_00,d,nd,n_pt_in)
double precision :: X(0:max_dim) double precision :: X(0:max_dim)
double precision :: Y(0:max_dim) double precision :: Y(0:max_dim)
!DIR$ ATTRIBUTES ALIGN : $IRP_ALIGN :: X,Y !DIR$ ATTRIBUTES ALIGN : $IRP_ALIGN :: X,Y
integer :: nx, ix,iy,ny integer :: nx, ix,iy,ny,ib
if( (c<0).or.(nd<0) )then if( (c<0).or.(nd<0) )then
nd = -1 nd = -1
@ -1028,8 +1165,45 @@ recursive subroutine I_x1_pol_mult_a1(c,B_10,B_01,B_00,C_00,D_00,d,nd,n_pt_in)
enddo enddo
endif endif
!DIR$ FORCEINLINE ! !DIR$ FORCEINLINE
call multiply_poly(X,nx,B_00,2,d,nd) ! call multiply_poly_c2_inline_2e(X,nx,B_00,d,nd)
if(nx >= 0) then
select case (nx)
case (0)
d(0) = d(0) + B_00(0) * X(0)
d(1) = d(1) + B_00(1) * X(0)
d(2) = d(2) + B_00(2) * X(0)
case (1)
d(0) = d(0) + B_00(0) * X(0)
d(1) = d(1) + B_00(0) * X(1) + B_00(1) * X(0)
d(2) = d(2) + B_00(1) * X(1) + B_00(2) * X(0)
d(3) = d(3) + B_00(2) * X(1)
case (2)
d(0) = d(0) + B_00(0) * X(0)
d(1) = d(1) + B_00(0) * X(1) + B_00(1) * X(0)
d(2) = d(2) + B_00(0) * X(2) + B_00(1) * X(1) + B_00(2) * X(0)
d(3) = d(3) + B_00(1) * X(2) + B_00(2) * X(1)
d(4) = d(4) + B_00(2) * X(2)
case default
d(0) = d(0) + B_00(0) * X(0)
d(1) = d(1) + B_00(0) * X(1) + B_00(1) * X(0)
do ib=2,nx
d(ib) = d(ib) + B_00(0) * X(ib) + B_00(1) * X(ib-1) + B_00(2) * X(ib-2)
enddo
d(nx+1) = d(nx+1) + B_00(1) * X(nx) + B_00(2) * X(nx-1)
d(nx+2) = d(nx+2) + B_00(2) * X(nx)
end select
do nd = nx+2,0,-1
if (d(nd) /= 0.d0) exit
enddo
endif
ny=0 ny=0
@ -1039,8 +1213,45 @@ recursive subroutine I_x1_pol_mult_a1(c,B_10,B_01,B_00,C_00,D_00,d,nd,n_pt_in)
enddo enddo
call I_x2_pol_mult(c,B_10,B_01,B_00,C_00,D_00,Y,ny,n_pt_in) call I_x2_pol_mult(c,B_10,B_01,B_00,C_00,D_00,Y,ny,n_pt_in)
!DIR$ FORCEINLINE ! !DIR$ FORCEINLINE
call multiply_poly(Y,ny,C_00,2,d,nd) ! call multiply_poly_c2_inline_2e(Y,ny,C_00,d,nd)
if(ny >= 0) then
select case (ny)
case (0)
d(0) = d(0) + C_00(0) * Y(0)
d(1) = d(1) + C_00(1) * Y(0)
d(2) = d(2) + C_00(2) * Y(0)
case (1)
d(0) = d(0) + C_00(0) * Y(0)
d(1) = d(1) + C_00(0) * Y(1) + C_00(1) * Y(0)
d(2) = d(2) + C_00(1) * Y(1) + C_00(2) * Y(0)
d(3) = d(3) + C_00(2) * Y(1)
case (2)
d(0) = d(0) + C_00(0) * Y(0)
d(1) = d(1) + C_00(0) * Y(1) + C_00(1) * Y(0)
d(2) = d(2) + C_00(0) * Y(2) + C_00(1) * Y(1) + C_00(2) * Y(0)
d(3) = d(3) + C_00(1) * Y(2) + C_00(2) * Y(1)
d(4) = d(4) + C_00(2) * Y(2)
case default
d(0) = d(0) + C_00(0) * Y(0)
d(1) = d(1) + C_00(0) * Y(1) + C_00(1) * Y(0)
do ib=2,ny
d(ib) = d(ib) + C_00(0) * Y(ib) + C_00(1) * Y(ib-1) + C_00(2) * Y(ib-2)
enddo
d(ny+1) = d(ny+1) + C_00(1) * Y(ny) + C_00(2) * Y(ny-1)
d(ny+2) = d(ny+2) + C_00(2) * Y(ny)
end select
do nd = ny+2,0,-1
if (d(nd) /= 0.d0) exit
enddo
endif
end end
@ -1058,7 +1269,7 @@ recursive subroutine I_x1_pol_mult_a2(c,B_10,B_01,B_00,C_00,D_00,d,nd,n_pt_in)
double precision :: X(0:max_dim) double precision :: X(0:max_dim)
double precision :: Y(0:max_dim) double precision :: Y(0:max_dim)
!DIR$ ATTRIBUTES ALIGN : $IRP_ALIGN :: X,Y !DIR$ ATTRIBUTES ALIGN : $IRP_ALIGN :: X,Y
integer :: nx, ix,iy,ny integer :: nx, ix,iy,ny,ib
!DIR$ LOOP COUNT(8) !DIR$ LOOP COUNT(8)
do ix=0,n_pt_in do ix=0,n_pt_in
@ -1067,8 +1278,45 @@ recursive subroutine I_x1_pol_mult_a2(c,B_10,B_01,B_00,C_00,D_00,d,nd,n_pt_in)
nx = 0 nx = 0
call I_x2_pol_mult(c,B_10,B_01,B_00,C_00,D_00,X,nx,n_pt_in) call I_x2_pol_mult(c,B_10,B_01,B_00,C_00,D_00,X,nx,n_pt_in)
!DIR$ FORCEINLINE ! !DIR$ FORCEINLINE
call multiply_poly(X,nx,B_10,2,d,nd) ! call multiply_poly_c2_inline_2e(X,nx,B_10,d,nd)
if(nx >= 0) then
select case (nx)
case (0)
d(0) = d(0) + B_10(0) * X(0)
d(1) = d(1) + B_10(1) * X(0)
d(2) = d(2) + B_10(2) * X(0)
case (1)
d(0) = d(0) + B_10(0) * X(0)
d(1) = d(1) + B_10(0) * X(1) + B_10(1) * X(0)
d(2) = d(2) + B_10(1) * X(1) + B_10(2) * X(0)
d(3) = d(3) + B_10(2) * X(1)
case (2)
d(0) = d(0) + B_10(0) * X(0)
d(1) = d(1) + B_10(0) * X(1) + B_10(1) * X(0)
d(2) = d(2) + B_10(0) * X(2) + B_10(1) * X(1) + B_10(2) * X(0)
d(3) = d(3) + B_10(1) * X(2) + B_10(2) * X(1)
d(4) = d(4) + B_10(2) * X(2)
case default
d(0) = d(0) + B_10(0) * X(0)
d(1) = d(1) + B_10(0) * X(1) + B_10(1) * X(0)
do ib=2,nx
d(ib) = d(ib) + B_10(0) * X(ib) + B_10(1) * X(ib-1) + B_10(2) * X(ib-2)
enddo
d(nx+1) = d(nx+1) + B_10(1) * X(nx) + B_10(2) * X(nx-1)
d(nx+2) = d(nx+2) + B_10(2) * X(nx)
end select
do nd = nx+2,0,-1
if (d(nd) /= 0.d0) exit
enddo
endif
nx = nd nx = nd
!DIR$ LOOP COUNT(8) !DIR$ LOOP COUNT(8)
@ -1086,8 +1334,45 @@ recursive subroutine I_x1_pol_mult_a2(c,B_10,B_01,B_00,C_00,D_00,d,nd,n_pt_in)
enddo enddo
endif endif
!DIR$ FORCEINLINE ! !DIR$ FORCEINLINE
call multiply_poly(X,nx,B_00,2,d,nd) ! call multiply_poly_c2_inline_2e(X,nx,B_00,d,nd)
if(nx >= 0) then
select case (nx)
case (0)
d(0) = d(0) + B_00(0) * X(0)
d(1) = d(1) + B_00(1) * X(0)
d(2) = d(2) + B_00(2) * X(0)
case (1)
d(0) = d(0) + B_00(0) * X(0)
d(1) = d(1) + B_00(0) * X(1) + B_00(1) * X(0)
d(2) = d(2) + B_00(1) * X(1) + B_00(2) * X(0)
d(3) = d(3) + B_00(2) * X(1)
case (2)
d(0) = d(0) + B_00(0) * X(0)
d(1) = d(1) + B_00(0) * X(1) + B_00(1) * X(0)
d(2) = d(2) + B_00(0) * X(2) + B_00(1) * X(1) + B_00(2) * X(0)
d(3) = d(3) + B_00(1) * X(2) + B_00(2) * X(1)
d(4) = d(4) + B_00(2) * X(2)
case default
d(0) = d(0) + B_00(0) * X(0)
d(1) = d(1) + B_00(0) * X(1) + B_00(1) * X(0)
do ib=2,nx
d(ib) = d(ib) + B_00(0) * X(ib) + B_00(1) * X(ib-1) + B_00(2) * X(ib-2)
enddo
d(nx+1) = d(nx+1) + B_00(1) * X(nx) + B_00(2) * X(nx-1)
d(nx+2) = d(nx+2) + B_00(2) * X(nx)
end select
do nd = nx+2,0,-1
if (d(nd) /= 0.d0) exit
enddo
endif
ny=0 ny=0
!DIR$ LOOP COUNT(8) !DIR$ LOOP COUNT(8)
@ -1097,8 +1382,45 @@ recursive subroutine I_x1_pol_mult_a2(c,B_10,B_01,B_00,C_00,D_00,d,nd,n_pt_in)
!DIR$ FORCEINLINE !DIR$ FORCEINLINE
call I_x1_pol_mult_a1(c,B_10,B_01,B_00,C_00,D_00,Y,ny,n_pt_in) call I_x1_pol_mult_a1(c,B_10,B_01,B_00,C_00,D_00,Y,ny,n_pt_in)
!DIR$ FORCEINLINE ! !DIR$ FORCEINLINE
call multiply_poly(Y,ny,C_00,2,d,nd) ! call multiply_poly_c2_inline_2e(Y,ny,C_00,d,nd)
if(ny >= 0) then
select case (ny)
case (0)
d(0) = d(0) + C_00(0) * Y(0)
d(1) = d(1) + C_00(1) * Y(0)
d(2) = d(2) + C_00(2) * Y(0)
case (1)
d(0) = d(0) + C_00(0) * Y(0)
d(1) = d(1) + C_00(0) * Y(1) + C_00(1) * Y(0)
d(2) = d(2) + C_00(1) * Y(1) + C_00(2) * Y(0)
d(3) = d(3) + C_00(2) * Y(1)
case (2)
d(0) = d(0) + C_00(0) * Y(0)
d(1) = d(1) + C_00(0) * Y(1) + C_00(1) * Y(0)
d(2) = d(2) + C_00(0) * Y(2) + C_00(1) * Y(1) + C_00(2) * Y(0)
d(3) = d(3) + C_00(1) * Y(2) + C_00(2) * Y(1)
d(4) = d(4) + C_00(2) * Y(2)
case default
d(0) = d(0) + C_00(0) * Y(0)
d(1) = d(1) + C_00(0) * Y(1) + C_00(1) * Y(0)
do ib=2,ny
d(ib) = d(ib) + C_00(0) * Y(ib) + C_00(1) * Y(ib-1) + C_00(2) * Y(ib-2)
enddo
d(ny+1) = d(ny+1) + C_00(1) * Y(ny) + C_00(2) * Y(ny-1)
d(ny+2) = d(ny+2) + C_00(2) * Y(ny)
end select
do nd = ny+2,0,-1
if (d(nd) /= 0.d0) exit
enddo
endif
end end
@ -1116,7 +1438,7 @@ recursive subroutine I_x2_pol_mult(c,B_10,B_01,B_00,C_00,D_00,d,nd,dim)
integer :: nx, ix,ny integer :: nx, ix,ny
double precision :: X(0:max_dim),Y(0:max_dim) double precision :: X(0:max_dim),Y(0:max_dim)
!DIR$ ATTRIBUTES ALIGN : $IRP_ALIGN :: X, Y !DIR$ ATTRIBUTES ALIGN : $IRP_ALIGN :: X, Y
integer :: i integer :: i, ib
select case (c) select case (c)
case (0) case (0)
@ -1146,8 +1468,47 @@ recursive subroutine I_x2_pol_mult(c,B_10,B_01,B_00,C_00,D_00,d,nd,dim)
Y(1) = D_00(1) Y(1) = D_00(1)
Y(2) = D_00(2) Y(2) = D_00(2)
!DIR$ FORCEINLINE ! !DIR$ FORCEINLINE
call multiply_poly(Y,ny,D_00,2,d,nd) ! call multiply_poly_c2_inline_2e(Y,ny,D_00,d,nd)
if(ny >= 0) then
select case (ny)
case (0)
d(0) = d(0) + D_00(0) * Y(0)
d(1) = d(1) + D_00(1) * Y(0)
d(2) = d(2) + D_00(2) * Y(0)
case (1)
d(0) = d(0) + D_00(0) * Y(0)
d(1) = d(1) + D_00(0) * Y(1) + D_00(1) * Y(0)
d(2) = d(2) + D_00(1) * Y(1) + D_00(2) * Y(0)
d(3) = d(3) + D_00(2) * Y(1)
case (2)
d(0) = d(0) + D_00(0) * Y(0)
d(1) = d(1) + D_00(0) * Y(1) + D_00(1) * Y(0)
d(2) = d(2) + D_00(0) * Y(2) + D_00(1) * Y(1) + D_00(2) * Y(0)
d(3) = d(3) + D_00(1) * Y(2) + D_00(2) * Y(1)
d(4) = d(4) + D_00(2) * Y(2)
case default
d(0) = d(0) + D_00(0) * Y(0)
d(1) = d(1) + D_00(0) * Y(1) + D_00(1) * Y(0)
do ib=2,ny
d(ib) = d(ib) + D_00(0) * Y(ib) + D_00(1) * Y(ib-1) + D_00(2) * Y(ib-2)
enddo
d(ny+1) = d(ny+1) + D_00(1) * Y(ny) + D_00(2) * Y(ny-1)
d(ny+2) = d(ny+2) + D_00(2) * Y(ny)
end select
do nd = ny+2,0,-1
if (d(nd) /= 0.d0) exit
enddo
endif
return return
case default case default
@ -1164,8 +1525,45 @@ recursive subroutine I_x2_pol_mult(c,B_10,B_01,B_00,C_00,D_00,d,nd,dim)
X(ix) *= dble(c-1) X(ix) *= dble(c-1)
enddo enddo
!DIR$ FORCEINLINE ! !DIR$ FORCEINLINE
call multiply_poly(X,nx,B_01,2,d,nd) ! call multiply_poly_c2_inline_2e(X,nx,B_01,d,nd)
if(nx >= 0) then
select case (nx)
case (0)
d(0) = d(0) + B_01(0) * X(0)
d(1) = d(1) + B_01(1) * X(0)
d(2) = d(2) + B_01(2) * X(0)
case (1)
d(0) = d(0) + B_01(0) * X(0)
d(1) = d(1) + B_01(0) * X(1) + B_01(1) * X(0)
d(2) = d(2) + B_01(1) * X(1) + B_01(2) * X(0)
d(3) = d(3) + B_01(2) * X(1)
case (2)
d(0) = d(0) + B_01(0) * X(0)
d(1) = d(1) + B_01(0) * X(1) + B_01(1) * X(0)
d(2) = d(2) + B_01(0) * X(2) + B_01(1) * X(1) + B_01(2) * X(0)
d(3) = d(3) + B_01(1) * X(2) + B_01(2) * X(1)
d(4) = d(4) + B_01(2) * X(2)
case default
d(0) = d(0) + B_01(0) * X(0)
d(1) = d(1) + B_01(0) * X(1) + B_01(1) * X(0)
do ib=2,nx
d(ib) = d(ib) + B_01(0) * X(ib) + B_01(1) * X(ib-1) + B_01(2) * X(ib-2)
enddo
d(nx+1) = d(nx+1) + B_01(1) * X(nx) + B_01(2) * X(nx-1)
d(nx+2) = d(nx+2) + B_01(2) * X(nx)
end select
do nd = nx+2,0,-1
if (d(nd) /= 0.d0) exit
enddo
endif
ny = 0 ny = 0
!DIR$ LOOP COUNT(6) !DIR$ LOOP COUNT(6)
@ -1174,8 +1572,46 @@ recursive subroutine I_x2_pol_mult(c,B_10,B_01,B_00,C_00,D_00,d,nd,dim)
enddo enddo
call I_x2_pol_mult(c-1,B_10,B_01,B_00,C_00,D_00,Y,ny,dim) call I_x2_pol_mult(c-1,B_10,B_01,B_00,C_00,D_00,Y,ny,dim)
!DIR$ FORCEINLINE ! !DIR$ FORCEINLINE
call multiply_poly(Y,ny,D_00,2,d,nd) ! call multiply_poly_c2_inline_2e(Y,ny,D_00,d,nd)
if(ny >= 0) then
select case (ny)
case (0)
d(0) = d(0) + D_00(0) * Y(0)
d(1) = d(1) + D_00(1) * Y(0)
d(2) = d(2) + D_00(2) * Y(0)
case (1)
d(0) = d(0) + D_00(0) * Y(0)
d(1) = d(1) + D_00(0) * Y(1) + D_00(1) * Y(0)
d(2) = d(2) + D_00(1) * Y(1) + D_00(2) * Y(0)
d(3) = d(3) + D_00(2) * Y(1)
case (2)
d(0) = d(0) + D_00(0) * Y(0)
d(1) = d(1) + D_00(0) * Y(1) + D_00(1) * Y(0)
d(2) = d(2) + D_00(0) * Y(2) + D_00(1) * Y(1) + D_00(2) * Y(0)
d(3) = d(3) + D_00(1) * Y(2) + D_00(2) * Y(1)
d(4) = d(4) + D_00(2) * Y(2)
case default
d(0) = d(0) + D_00(0) * Y(0)
d(1) = d(1) + D_00(0) * Y(1) + D_00(1) * Y(0)
do ib=2,ny
d(ib) = d(ib) + D_00(0) * Y(ib) + D_00(1) * Y(ib-1) + D_00(2) * Y(ib-2)
enddo
d(ny+1) = d(ny+1) + D_00(1) * Y(ny) + D_00(2) * Y(ny-1)
d(ny+2) = d(ny+2) + D_00(2) * Y(ny)
end select
do nd = ny+2,0,-1
if (d(nd) /= 0.d0) exit
enddo
endif
end select end select
end end
@ -1197,7 +1633,8 @@ subroutine compute_ao_integrals_jl(j,l,n_integrals,buffer_i,buffer_value)
logical, external :: ao_two_e_integral_zero logical, external :: ao_two_e_integral_zero
integer :: i,k integer :: i,k
double precision :: ao_two_e_integral,cpu_1,cpu_2, wall_1, wall_2 double precision, external :: ao_two_e_integral
double precision :: cpu_1,cpu_2, wall_1, wall_2
double precision :: integral, wall_0 double precision :: integral, wall_0
double precision :: thr double precision :: thr
integer :: kk, m, j1, i1 integer :: kk, m, j1, i1
@ -1233,3 +1670,87 @@ subroutine compute_ao_integrals_jl(j,l,n_integrals,buffer_i,buffer_value)
enddo enddo
end end
subroutine multiply_poly_local(b,nb,c,nc,d,nd)
implicit none
BEGIN_DOC
! Multiply two polynomials
! D(t) += B(t)*C(t)
END_DOC
integer, intent(in) :: nb, nc
integer, intent(out) :: nd
double precision, intent(in) :: b(0:nb), c(0:nc)
double precision, intent(inout) :: d(0:nb+nc)
integer :: ndtmp
integer :: ib, ic, id, k
if(ior(nc,nb) < 0) return !False if nc>=0 and nb>=0
do ib=0,nb
do ic = 0,nc
d(ib+ic) = d(ib+ic) + c(ic) * b(ib)
enddo
enddo
do nd = nb+nc,0,-1
if (d(nd) /= 0.d0) exit
enddo
end
!DIR$ FORCEINLINE
subroutine multiply_poly_c2_inline_2e(b,nb,c,d,nd)
implicit none
BEGIN_DOC
! Multiply two polynomials
! D(t) += B(t)*C(t)
END_DOC
integer, intent(in) :: nb
integer, intent(out) :: nd
double precision, intent(in) :: b(0:nb), c(0:2)
double precision, intent(inout) :: d(0:nb+2)
integer :: ndtmp
integer :: ib, ic, id, k
if(nb < 0) return !False if nb>=0
select case (nb)
case (0)
d(0) = d(0) + c(0) * b(0)
d(1) = d(1) + c(1) * b(0)
d(2) = d(2) + c(2) * b(0)
case (1)
d(0) = d(0) + c(0) * b(0)
d(1) = d(1) + c(0) * b(1) + c(1) * b(0)
d(2) = d(2) + c(1) * b(1) + c(2) * b(0)
d(3) = d(3) + c(2) * b(1)
case (2)
d(0) = d(0) + c(0) * b(0)
d(1) = d(1) + c(0) * b(1) + c(1) * b(0)
d(2) = d(2) + c(0) * b(2) + c(1) * b(1) + c(2) * b(0)
d(3) = d(3) + c(1) * b(2) + c(2) * b(1)
d(4) = d(4) + c(2) * b(2)
case default
d(0) = d(0) + c(0) * b(0)
d(1) = d(1) + c(0) * b(1) + c(1) * b(0)
do ib=2,nb
d(ib) = d(ib) + c(0) * b(ib) + c(1) * b(ib-1) + c(2) * b(ib-2)
enddo
d(nb+1) = d(nb+1) + c(1) * b(nb) + c(2) * b(nb-1)
d(nb+2) = d(nb+2) + c(2) * b(nb)
end select
do nd = nb+2,0,-1
if (d(nd) /= 0.d0) exit
enddo
end

16
src/becke_numerical_grid/EZFIO.cfg
View File

@ -33,6 +33,10 @@ doc: Number of angular grid points given from input. Warning, this number cannot
interface: ezfio,provider,ocaml interface: ezfio,provider,ocaml
default: 1202 default: 1202
[n_points_extra_final_grid]
type: integer
doc: Total number of extra_grid points
interface: ezfio
[extra_grid_type_sgn] [extra_grid_type_sgn]
type: integer type: integer
@ -64,3 +68,15 @@ doc: Number of angular extra_grid points given from input. Warning, this number
interface: ezfio,provider,ocaml interface: ezfio,provider,ocaml
default: 1202 default: 1202
[rad_grid_type]
type: character*(32)
doc: method used to sample the radial space. Possible choices are [KNOWLES | GILL]
interface: ezfio,provider,ocaml
default: KNOWLES
[extra_rad_grid_type]
type: character*(32)
doc: method used to sample the radial space. Possible choices are [KNOWLES | GILL]
interface: ezfio,provider,ocaml
default: KNOWLES

278
src/becke_numerical_grid/extra_grid.irp.f
View File

@ -1,96 +1,149 @@
! ---
BEGIN_PROVIDER [integer, n_points_extra_radial_grid] BEGIN_PROVIDER [integer, n_points_extra_radial_grid]
&BEGIN_PROVIDER [integer, n_points_extra_integration_angular] &BEGIN_PROVIDER [integer, n_points_extra_integration_angular]
implicit none
BEGIN_DOC BEGIN_DOC
! n_points_extra_radial_grid = number of radial grid points_extra per atom ! n_points_extra_radial_grid = number of radial grid points_extra per atom
! !
! n_points_extra_integration_angular = number of angular grid points_extra per atom ! n_points_extra_integration_angular = number of angular grid points_extra per atom
! !
! These numbers are automatically set by setting the grid_type_sgn parameter ! These numbers are automatically set by setting the grid_type_sgn parameter
END_DOC END_DOC
if(.not.my_extra_grid_becke)then
select case (extra_grid_type_sgn) implicit none
case(0)
n_points_extra_radial_grid = 23 if(.not. my_extra_grid_becke) then
n_points_extra_integration_angular = 170 select case (extra_grid_type_sgn)
case(1) case(0)
n_points_extra_radial_grid = 50 n_points_extra_radial_grid = 23
n_points_extra_integration_angular = 194 n_points_extra_integration_angular = 170
case(2) case(1)
n_points_extra_radial_grid = 75 n_points_extra_radial_grid = 50
n_points_extra_integration_angular = 302 n_points_extra_integration_angular = 194
case(3) case(2)
n_points_extra_radial_grid = 99 n_points_extra_radial_grid = 75
n_points_extra_integration_angular = 590 n_points_extra_integration_angular = 302
case default case(3)
write(*,*) '!!! Quadrature grid not available !!!' n_points_extra_radial_grid = 99
stop n_points_extra_integration_angular = 590
end select case default
else write(*,*) '!!! Quadrature grid not available !!!'
n_points_extra_radial_grid = my_n_pt_r_extra_grid stop
n_points_extra_integration_angular = my_n_pt_a_extra_grid end select
endif else
n_points_extra_radial_grid = my_n_pt_r_extra_grid
n_points_extra_integration_angular = my_n_pt_a_extra_grid
endif
END_PROVIDER END_PROVIDER
! ---
BEGIN_PROVIDER [integer, n_points_extra_grid_per_atom] BEGIN_PROVIDER [integer, n_points_extra_grid_per_atom]
implicit none
BEGIN_DOC BEGIN_DOC
! Number of grid points_extra per atom ! Number of grid points_extra per atom
END_DOC END_DOC
implicit none
n_points_extra_grid_per_atom = n_points_extra_integration_angular * n_points_extra_radial_grid n_points_extra_grid_per_atom = n_points_extra_integration_angular * n_points_extra_radial_grid
END_PROVIDER END_PROVIDER
! ---
BEGIN_PROVIDER [double precision, grid_points_extra_radial, (n_points_extra_radial_grid)] BEGIN_PROVIDER [double precision, grid_points_extra_radial, (n_points_extra_radial_grid)]
&BEGIN_PROVIDER [double precision, dr_radial_extra_integral] &BEGIN_PROVIDER [double precision, dr_radial_extra_integral]
implicit none
BEGIN_DOC BEGIN_DOC
! points_extra in [0,1] to map the radial integral [0,\infty] ! points_extra in [0,1] to map the radial integral [0,\infty]
END_DOC END_DOC
implicit none
integer :: i
dr_radial_extra_integral = 1.d0/dble(n_points_extra_radial_grid-1) dr_radial_extra_integral = 1.d0/dble(n_points_extra_radial_grid-1)
integer :: i
do i = 1, n_points_extra_radial_grid do i = 1, n_points_extra_radial_grid
grid_points_extra_radial(i) = dble(i-1) * dr_radial_extra_integral grid_points_extra_radial(i) = dble(i-1) * dr_radial_extra_integral
enddo enddo
END_PROVIDER END_PROVIDER
! ---
BEGIN_PROVIDER [double precision, grid_points_extra_per_atom, (3,n_points_extra_integration_angular,n_points_extra_radial_grid,nucl_num)] BEGIN_PROVIDER [double precision, grid_points_extra_per_atom, (3,n_points_extra_integration_angular,n_points_extra_radial_grid,nucl_num)]
BEGIN_DOC BEGIN_DOC
! x,y,z coordinates of grid points_extra used for integration in 3d space ! x,y,z coordinates of grid points_extra used for integration in 3d space
END_DOC END_DOC
implicit none implicit none
integer :: i,j,k integer :: i, j, k
double precision :: dr,x_ref,y_ref,z_ref double precision :: dr, x_ref, y_ref, z_ref
double precision :: knowles_function double precision :: x, r, tmp
do i = 1, nucl_num double precision, external :: knowles_function
x_ref = nucl_coord(i,1)
y_ref = nucl_coord(i,2)
z_ref = nucl_coord(i,3)
do j = 1, n_points_extra_radial_grid-1
double precision :: x,r
! x value for the mapping of the [0, +\infty] to [0,1]
x = grid_points_extra_radial(j)
! value of the radial coordinate for the integration grid_points_extra_per_atom = 0.d0
r = knowles_function(alpha_knowles(grid_atomic_number(i)),m_knowles,x)
! explicit values of the grid points_extra centered around each atom PROVIDE extra_rad_grid_type
do k = 1, n_points_extra_integration_angular if(extra_rad_grid_type .eq. "KNOWLES") then
grid_points_extra_per_atom(1,k,j,i) = &
x_ref + angular_quadrature_points_extra(k,1) * r do i = 1, nucl_num
grid_points_extra_per_atom(2,k,j,i) = & x_ref = nucl_coord(i,1)
y_ref + angular_quadrature_points_extra(k,2) * r y_ref = nucl_coord(i,2)
grid_points_extra_per_atom(3,k,j,i) = & z_ref = nucl_coord(i,3)
z_ref + angular_quadrature_points_extra(k,3) * r do j = 1, n_points_extra_radial_grid-1
! x value for the mapping of the [0, +\infty] to [0,1]
x = grid_points_extra_radial(j)
! value of the radial coordinate for the integration
r = knowles_function(alpha_knowles(grid_atomic_number(i)), m_knowles, x)
! explicit values of the grid points_extra centered around each atom
do k = 1, n_points_extra_integration_angular
grid_points_extra_per_atom(1,k,j,i) = x_ref + angular_quadrature_points_extra(k,1) * r
grid_points_extra_per_atom(2,k,j,i) = y_ref + angular_quadrature_points_extra(k,2) * r
grid_points_extra_per_atom(3,k,j,i) = z_ref + angular_quadrature_points_extra(k,3) * r
enddo
enddo enddo
enddo enddo
enddo
elseif(extra_rad_grid_type .eq. "GILL") then
! GILL & CHIEN, 2002
do i = 1, nucl_num
x_ref = nucl_coord(i,1)
y_ref = nucl_coord(i,2)
z_ref = nucl_coord(i,3)
do j = 1, n_points_extra_radial_grid-1
r = R_gill * dble(j-1)**2 / dble(n_points_extra_radial_grid-j+1)**2
! explicit values of the grid points_extra centered around each atom
do k = 1, n_points_extra_integration_angular
grid_points_extra_per_atom(1,k,j,i) = x_ref + angular_quadrature_points_extra(k,1) * r
grid_points_extra_per_atom(2,k,j,i) = y_ref + angular_quadrature_points_extra(k,2) * r
grid_points_extra_per_atom(3,k,j,i) = z_ref + angular_quadrature_points_extra(k,3) * r
enddo
enddo
enddo
else
print*, " extra_rad_grid_type = ", extra_rad_grid_type, ' is not implemented'
stop
endif
END_PROVIDER END_PROVIDER
! ---
BEGIN_PROVIDER [double precision, weight_at_r_extra, (n_points_extra_integration_angular,n_points_extra_radial_grid,nucl_num) ] BEGIN_PROVIDER [double precision, weight_at_r_extra, (n_points_extra_integration_angular,n_points_extra_radial_grid,nucl_num) ]
BEGIN_DOC BEGIN_DOC
! Weight function at grid points_extra : w_n(r) according to the equation (22) ! Weight function at grid points_extra : w_n(r) according to the equation (22)
! of Becke original paper (JCP, 88, 1988) ! of Becke original paper (JCP, 88, 1988)
@ -99,11 +152,14 @@ BEGIN_PROVIDER [double precision, weight_at_r_extra, (n_points_extra_integration
! represented by the last dimension and the points_extra are labelled by the ! represented by the last dimension and the points_extra are labelled by the
! other dimensions. ! other dimensions.
END_DOC END_DOC
implicit none implicit none
integer :: i,j,k,l,m integer :: i, j, k, l, m
double precision :: r(3) double precision :: r(3)
double precision :: accu,cell_function_becke double precision :: accu
double precision :: tmp_array(nucl_num) double precision :: tmp_array(nucl_num)
double precision, external :: cell_function_becke
! run over all points_extra in space ! run over all points_extra in space
! that are referred to each atom ! that are referred to each atom
do j = 1, nucl_num do j = 1, nucl_num
@ -114,6 +170,7 @@ BEGIN_PROVIDER [double precision, weight_at_r_extra, (n_points_extra_integration
r(1) = grid_points_extra_per_atom(1,l,k,j) r(1) = grid_points_extra_per_atom(1,l,k,j)
r(2) = grid_points_extra_per_atom(2,l,k,j) r(2) = grid_points_extra_per_atom(2,l,k,j)
r(3) = grid_points_extra_per_atom(3,l,k,j) r(3) = grid_points_extra_per_atom(3,l,k,j)
accu = 0.d0 accu = 0.d0
! For each of these points_extra in space, ou need to evaluate the P_n(r) ! For each of these points_extra in space, ou need to evaluate the P_n(r)
do i = 1, nucl_num do i = 1, nucl_num
@ -124,18 +181,19 @@ BEGIN_PROVIDER [double precision, weight_at_r_extra, (n_points_extra_integration
enddo enddo
accu = 1.d0/accu accu = 1.d0/accu
weight_at_r_extra(l,k,j) = tmp_array(j) * accu weight_at_r_extra(l,k,j) = tmp_array(j) * accu
if(isnan(weight_at_r_extra(l,k,j)))then if(isnan(weight_at_r_extra(l,k,j)))then
print*,'isnan(weight_at_r_extra(l,k,j))' print*,'isnan(weight_at_r_extra(l,k,j))'
print*,l,k,j print*,l,k,j
accu = 0.d0 accu = 0.d0
do i = 1, nucl_num do i = 1, nucl_num
! function defined for each atom "i" by equation (13) and (21) with k == 3 ! function defined for each atom "i" by equation (13) and (21) with k == 3
tmp_array(i) = cell_function_becke(r,i) ! P_n(r) tmp_array(i) = cell_function_becke(r,i) ! P_n(r)
print*,i,tmp_array(i) print*,i,tmp_array(i)
! Then you compute the summ the P_n(r) function for each of the "r" points_extra ! Then you compute the summ the P_n(r) function for each of the "r" points_extra
accu += tmp_array(i) accu += tmp_array(i)
enddo enddo
write(*,'(100(F16.10,X))')tmp_array(j) , accu write(*,'(100(F16.10,X))')tmp_array(j) , accu
stop stop
endif endif
enddo enddo
@ -144,35 +202,73 @@ BEGIN_PROVIDER [double precision, weight_at_r_extra, (n_points_extra_integration
END_PROVIDER END_PROVIDER
! ---
BEGIN_PROVIDER [double precision, final_weight_at_r_extra, (n_points_extra_integration_angular,n_points_extra_radial_grid,nucl_num) ] BEGIN_PROVIDER [double precision, final_weight_at_r_extra, (n_points_extra_integration_angular,n_points_extra_radial_grid,nucl_num) ]
BEGIN_DOC BEGIN_DOC
! Total weight on each grid point which takes into account all Lebedev, Voronoi and radial weights. ! Total weight on each grid point which takes into account all Lebedev, Voronoi and radial weights.
END_DOC END_DOC
implicit none implicit none
integer :: i,j,k,l,m integer :: i, j, k, l, m
double precision :: r(3) double precision :: r(3)
double precision :: accu,cell_function_becke double precision :: tmp_array(nucl_num)
double precision :: tmp_array(nucl_num) double precision :: contrib_integration, x, tmp
double precision :: contrib_integration,x double precision, external :: derivative_knowles_function, knowles_function
double precision :: derivative_knowles_function,knowles_function
! run over all points_extra in space PROVIDE extra_rad_grid_type
do j = 1, nucl_num ! that are referred to each atom if(extra_rad_grid_type .eq. "KNOWLES") then
do i = 1, n_points_extra_radial_grid -1 !for each radial grid attached to the "jth" atom
x = grid_points_extra_radial(i) ! x value for the mapping of the [0, +\infty] to [0,1] ! run over all points_extra in space
do k = 1, n_points_extra_integration_angular ! for each angular point attached to the "jth" atom do j = 1, nucl_num ! that are referred to each atom
contrib_integration = derivative_knowles_function(alpha_knowles(grid_atomic_number(j)),m_knowles,x)& do i = 1, n_points_extra_radial_grid -1 !for each radial grid attached to the "jth" atom
*knowles_function(alpha_knowles(grid_atomic_number(j)),m_knowles,x)**2 x = grid_points_extra_radial(i) ! x value for the mapping of the [0, +\infty] to [0,1]
final_weight_at_r_extra(k,i,j) = weights_angular_points_extra(k) * weight_at_r_extra(k,i,j) * contrib_integration * dr_radial_extra_integral do k = 1, n_points_extra_integration_angular ! for each angular point attached to the "jth" atom
if(isnan(final_weight_at_r_extra(k,i,j)))then contrib_integration = derivative_knowles_function(alpha_knowles(grid_atomic_number(j)),m_knowles,x)&
print*,'isnan(final_weight_at_r_extra(k,i,j))' * knowles_function(alpha_knowles(grid_atomic_number(j)),m_knowles,x)**2
print*,k,i,j final_weight_at_r_extra(k,i,j) = weights_angular_points_extra(k) * weight_at_r_extra(k,i,j) * contrib_integration * dr_radial_extra_integral
write(*,'(100(F16.10,X))')weights_angular_points_extra(k) , weight_at_r_extra(k,i,j) , contrib_integration , dr_radial_extra_integral if(isnan(final_weight_at_r_extra(k,i,j)))then
stop print*,'isnan(final_weight_at_r_extra(k,i,j))'
endif print*,k,i,j
write(*,'(100(F16.10,X))')weights_angular_points_extra(k) , weight_at_r_extra(k,i,j) , contrib_integration , dr_radial_extra_integral
stop
endif
enddo
enddo enddo
enddo enddo
enddo
elseif(extra_rad_grid_type .eq. "GILL") then
! GILL & CHIEN, 2002
PROVIDE R_gill
tmp = 2.d0 * R_gill * R_gill * R_gill * dble(n_points_extra_radial_grid)
! run over all points_extra in space
do j = 1, nucl_num ! that are referred to each atom
do i = 1, n_points_extra_radial_grid -1 !for each radial grid attached to the "jth" atom
contrib_integration = tmp * dble(i-1)**5 / dble(n_points_extra_radial_grid-i+1)**7
do k = 1, n_points_extra_integration_angular ! for each angular point attached to the "jth" atom
final_weight_at_r_extra(k,i,j) = weights_angular_points_extra(k) * weight_at_r_extra(k,i,j) * contrib_integration
if(isnan(final_weight_at_r_extra(k,i,j)))then
print*,'isnan(final_weight_at_r_extra(k,i,j))'
print*,k,i,j
write(*,'(100(F16.10,X))') weights_angular_points_extra(k), weight_at_r_extra(k,i,j), contrib_integration
stop
endif
enddo
enddo
enddo
else
print*, " extra_rad_grid_type = ", extra_rad_grid_type, ' is not implemented'
stop
endif
END_PROVIDER END_PROVIDER

49
src/becke_numerical_grid/extra_grid_vector.irp.f
View File

@ -1,42 +1,55 @@
! ---
BEGIN_PROVIDER [integer, n_points_extra_final_grid] BEGIN_PROVIDER [integer, n_points_extra_final_grid]
implicit none
BEGIN_DOC BEGIN_DOC
! Number of points_extra which are non zero ! Number of points_extra which are non zero
END_DOC END_DOC
integer :: i,j,k,l
implicit none
integer :: i, j, k, l
n_points_extra_final_grid = 0 n_points_extra_final_grid = 0
do j = 1, nucl_num do j = 1, nucl_num
do i = 1, n_points_extra_radial_grid -1 do i = 1, n_points_extra_radial_grid -1
do k = 1, n_points_extra_integration_angular do k = 1, n_points_extra_integration_angular
if(dabs(final_weight_at_r_extra(k,i,j)) < thresh_extra_grid)then if(dabs(final_weight_at_r_extra(k,i,j)) < thresh_extra_grid) then
cycle cycle
endif endif
n_points_extra_final_grid += 1 n_points_extra_final_grid += 1
enddo enddo
enddo enddo
enddo enddo
print*,'n_points_extra_final_grid = ',n_points_extra_final_grid
print*,'n max point = ',n_points_extra_integration_angular*(n_points_extra_radial_grid*nucl_num - 1) print*, ' n_points_extra_final_grid = ', n_points_extra_final_grid
! call ezfio_set_becke_numerical_grid_n_points_extra_final_grid(n_points_extra_final_grid) print*, ' n max point = ', n_points_extra_integration_angular*(n_points_extra_radial_grid*nucl_num - 1)
call ezfio_set_becke_numerical_grid_n_points_extra_final_grid(n_points_extra_final_grid)
END_PROVIDER END_PROVIDER
! ---
BEGIN_PROVIDER [double precision, final_grid_points_extra, (3,n_points_extra_final_grid)] BEGIN_PROVIDER [double precision, final_grid_points_extra, (3,n_points_extra_final_grid)]
&BEGIN_PROVIDER [double precision, final_weight_at_r_vector_extra, (n_points_extra_final_grid) ] &BEGIN_PROVIDER [double precision, final_weight_at_r_vector_extra, (n_points_extra_final_grid)]
&BEGIN_PROVIDER [integer, index_final_points_extra, (3,n_points_extra_final_grid) ] &BEGIN_PROVIDER [integer, index_final_points_extra, (3,n_points_extra_final_grid)]
&BEGIN_PROVIDER [integer, index_final_points_extra_reverse, (n_points_extra_integration_angular,n_points_extra_radial_grid,nucl_num) ] &BEGIN_PROVIDER [integer, index_final_points_extra_reverse, (n_points_extra_integration_angular,n_points_extra_radial_grid,nucl_num)]
implicit none
BEGIN_DOC BEGIN_DOC
! final_grid_points_extra(1:3,j) = (/ x, y, z /) of the jth grid point ! final_grid_points_extra(1:3,j) = (/ x, y, z /) of the jth grid point
! !
! final_weight_at_r_vector_extra(i) = Total weight function of the ith grid point which contains the Lebedev, Voronoi and radial weights contributions ! final_weight_at_r_vector_extra(i) = Total weight function of the ith grid point which contains the Lebedev, Voronoi and radial weights contributions
! !
! index_final_points_extra(1:3,i) = gives the angular, radial and atomic indices associated to the ith grid point ! index_final_points_extra(1:3,i) = gives the angular, radial and atomic indices associated to the ith grid point
! !
! index_final_points_extra_reverse(i,j,k) = index of the grid point having i as angular, j as radial and l as atomic indices ! index_final_points_extra_reverse(i,j,k) = index of the grid point having i as angular, j as radial and l as atomic indices
END_DOC END_DOC
implicit none
integer :: i,j,k,l,i_count integer :: i,j,k,l,i_count
double precision :: r(3) double precision :: r(3)
i_count = 0 i_count = 0
do j = 1, nucl_num do j = 1, nucl_num
do i = 1, n_points_extra_radial_grid -1 do i = 1, n_points_extra_radial_grid -1
@ -58,3 +71,5 @@ END_PROVIDER
enddo enddo
END_PROVIDER END_PROVIDER

317
src/becke_numerical_grid/grid_becke.irp.f
View File

@ -1,103 +1,177 @@
! ---
BEGIN_PROVIDER [integer, n_points_radial_grid] BEGIN_PROVIDER [integer, n_points_radial_grid]
&BEGIN_PROVIDER [integer, n_points_integration_angular] &BEGIN_PROVIDER [integer, n_points_integration_angular]
implicit none
BEGIN_DOC BEGIN_DOC
! n_points_radial_grid = number of radial grid points per atom ! n_points_radial_grid = number of radial grid points per atom
! !
! n_points_integration_angular = number of angular grid points per atom ! n_points_integration_angular = number of angular grid points per atom
! !
! These numbers are automatically set by setting the grid_type_sgn parameter ! These numbers are automatically set by setting the grid_type_sgn parameter
END_DOC END_DOC
if(.not.my_grid_becke)then
select case (grid_type_sgn) implicit none
case(0)
n_points_radial_grid = 23 if(.not. my_grid_becke) then
n_points_integration_angular = 170 select case (grid_type_sgn)
case(1) case(0)
n_points_radial_grid = 50 n_points_radial_grid = 23
n_points_integration_angular = 194 n_points_integration_angular = 170
case(2) case(1)
n_points_radial_grid = 75 n_points_radial_grid = 50
n_points_integration_angular = 302 n_points_integration_angular = 194
case(3) case(2)
n_points_radial_grid = 99 n_points_radial_grid = 75
n_points_integration_angular = 590 n_points_integration_angular = 302
case default case(3)
write(*,*) '!!! Quadrature grid not available !!!' n_points_radial_grid = 99
stop n_points_integration_angular = 590
end select case default
else write(*,*) '!!! Quadrature grid not available !!!'
n_points_radial_grid = my_n_pt_r_grid stop
n_points_integration_angular = my_n_pt_a_grid end select
endif else
n_points_radial_grid = my_n_pt_r_grid
n_points_integration_angular = my_n_pt_a_grid
endif
print*, " n_points_radial_grid = ", n_points_radial_grid
print*, " n_points_integration_angular = ", n_points_integration_angular
END_PROVIDER END_PROVIDER
! ---
BEGIN_PROVIDER [integer, n_points_grid_per_atom] BEGIN_PROVIDER [integer, n_points_grid_per_atom]
implicit none
BEGIN_DOC BEGIN_DOC
! Number of grid points per atom ! Number of grid points per atom
END_DOC END_DOC
implicit none
n_points_grid_per_atom = n_points_integration_angular * n_points_radial_grid n_points_grid_per_atom = n_points_integration_angular * n_points_radial_grid
END_PROVIDER END_PROVIDER
BEGIN_PROVIDER [integer , m_knowles] ! ---
implicit none
BEGIN_PROVIDER [integer, m_knowles]
BEGIN_DOC BEGIN_DOC
! value of the "m" parameter in the equation (7) of the paper of Knowles (JCP, 104, 1996) ! value of the "m" parameter in the equation (7) of the paper of Knowles (JCP, 104, 1996)
END_DOC END_DOC
implicit none
m_knowles = 3 m_knowles = 3
END_PROVIDER END_PROVIDER
! ---
BEGIN_PROVIDER [double precision, R_gill]
implicit none
R_gill = 3.d0
END_PROVIDER
! ---
BEGIN_PROVIDER [double precision, grid_points_radial, (n_points_radial_grid)] BEGIN_PROVIDER [double precision, grid_points_radial, (n_points_radial_grid)]
&BEGIN_PROVIDER [double precision, dr_radial_integral] &BEGIN_PROVIDER [double precision, dr_radial_integral]
implicit none
BEGIN_DOC BEGIN_DOC
! points in [0,1] to map the radial integral [0,\infty] ! points in [0,1] to map the radial integral [0,\infty]
END_DOC END_DOC
dr_radial_integral = 1.d0/dble(n_points_radial_grid-1)
integer :: i implicit none
integer :: i
dr_radial_integral = 1.d0 / dble(n_points_radial_grid-1)
do i = 1, n_points_radial_grid do i = 1, n_points_radial_grid
grid_points_radial(i) = dble(i-1) * dr_radial_integral grid_points_radial(i) = dble(i-1) * dr_radial_integral
enddo enddo
END_PROVIDER END_PROVIDER
! ---
BEGIN_PROVIDER [double precision, grid_points_per_atom, (3,n_points_integration_angular,n_points_radial_grid,nucl_num)] BEGIN_PROVIDER [double precision, grid_points_per_atom, (3,n_points_integration_angular,n_points_radial_grid,nucl_num)]
BEGIN_DOC BEGIN_DOC
! x,y,z coordinates of grid points used for integration in 3d space ! x,y,z coordinates of grid points used for integration in 3d space
END_DOC END_DOC
implicit none implicit none
integer :: i,j,k integer :: i, j, k
double precision :: dr,x_ref,y_ref,z_ref double precision :: dr, x_ref, y_ref, z_ref
double precision :: knowles_function double precision :: x, r, tmp
do i = 1, nucl_num double precision, external :: knowles_function
x_ref = nucl_coord(i,1)
y_ref = nucl_coord(i,2)
z_ref = nucl_coord(i,3)
do j = 1, n_points_radial_grid-1
double precision :: x,r
! x value for the mapping of the [0, +\infty] to [0,1]
x = grid_points_radial(j)
! value of the radial coordinate for the integration grid_points_per_atom = 0.d0
r = knowles_function(alpha_knowles(grid_atomic_number(i)),m_knowles,x)
! explicit values of the grid points centered around each atom PROVIDE rad_grid_type
do k = 1, n_points_integration_angular if(rad_grid_type .eq. "KNOWLES") then
grid_points_per_atom(1,k,j,i) = &
x_ref + angular_quadrature_points(k,1) * r do i = 1, nucl_num
grid_points_per_atom(2,k,j,i) = & x_ref = nucl_coord(i,1)
y_ref + angular_quadrature_points(k,2) * r y_ref = nucl_coord(i,2)
grid_points_per_atom(3,k,j,i) = & z_ref = nucl_coord(i,3)
z_ref + angular_quadrature_points(k,3) * r do j = 1, n_points_radial_grid-1
! x value for the mapping of the [0, +\infty] to [0,1]
x = grid_points_radial(j)
! value of the radial coordinate for the integration
r = knowles_function(alpha_knowles(grid_atomic_number(i)), m_knowles, x)
! explicit values of the grid points centered around each atom
do k = 1, n_points_integration_angular
grid_points_per_atom(1,k,j,i) = x_ref + angular_quadrature_points(k,1) * r
grid_points_per_atom(2,k,j,i) = y_ref + angular_quadrature_points(k,2) * r
grid_points_per_atom(3,k,j,i) = z_ref + angular_quadrature_points(k,3) * r
enddo
enddo enddo
enddo enddo
enddo
elseif(rad_grid_type .eq. "GILL") then
! GILL & CHIEN, 2002
do i = 1, nucl_num
x_ref = nucl_coord(i,1)
y_ref = nucl_coord(i,2)
z_ref = nucl_coord(i,3)
do j = 1, n_points_radial_grid-1
r = R_gill * dble(j-1)**2 / dble(n_points_radial_grid-j+1)**2
! explicit values of the grid points centered around each atom
do k = 1, n_points_integration_angular
grid_points_per_atom(1,k,j,i) = x_ref + angular_quadrature_points(k,1) * r
grid_points_per_atom(2,k,j,i) = y_ref + angular_quadrature_points(k,2) * r
grid_points_per_atom(3,k,j,i) = z_ref + angular_quadrature_points(k,3) * r
enddo
enddo
enddo
else
print*, " rad_grid_type = ", rad_grid_type, ' is not implemented'
stop
endif
END_PROVIDER END_PROVIDER
BEGIN_PROVIDER [double precision, weight_at_r, (n_points_integration_angular,n_points_radial_grid,nucl_num) ] ! ---
BEGIN_PROVIDER [double precision, weight_at_r, (n_points_integration_angular,n_points_radial_grid,nucl_num)]
BEGIN_DOC BEGIN_DOC
! Weight function at grid points : w_n(r) according to the equation (22) ! Weight function at grid points : w_n(r) according to the equation (22)
! of Becke original paper (JCP, 88, 1988) ! of Becke original paper (JCP, 88, 1988)
@ -106,11 +180,13 @@ BEGIN_PROVIDER [double precision, weight_at_r, (n_points_integration_angular,n_p
! represented by the last dimension and the points are labelled by the ! represented by the last dimension and the points are labelled by the
! other dimensions. ! other dimensions.
END_DOC END_DOC
implicit none implicit none
integer :: i,j,k,l,m integer :: i, j, k, l, m
double precision :: r(3) double precision :: r(3), accu
double precision :: accu,cell_function_becke double precision :: tmp_array(nucl_num)
double precision :: tmp_array(nucl_num) double precision, external :: cell_function_becke
! run over all points in space ! run over all points in space
! that are referred to each atom ! that are referred to each atom
do j = 1, nucl_num do j = 1, nucl_num
@ -121,28 +197,30 @@ BEGIN_PROVIDER [double precision, weight_at_r, (n_points_integration_angular,n_p
r(1) = grid_points_per_atom(1,l,k,j) r(1) = grid_points_per_atom(1,l,k,j)
r(2) = grid_points_per_atom(2,l,k,j) r(2) = grid_points_per_atom(2,l,k,j)
r(3) = grid_points_per_atom(3,l,k,j) r(3) = grid_points_per_atom(3,l,k,j)
accu = 0.d0 accu = 0.d0
! For each of these points in space, ou need to evaluate the P_n(r) ! For each of these points in space, ou need to evaluate the P_n(r)
do i = 1, nucl_num do i = 1, nucl_num
! function defined for each atom "i" by equation (13) and (21) with k == 3 ! function defined for each atom "i" by equation (13) and (21) with k == 3
tmp_array(i) = cell_function_becke(r,i) ! P_n(r) tmp_array(i) = cell_function_becke(r, i) ! P_n(r)
! Then you compute the summ the P_n(r) function for each of the "r" points ! Then you compute the summ the P_n(r) function for each of the "r" points
accu += tmp_array(i) accu += tmp_array(i)
enddo enddo
accu = 1.d0/accu accu = 1.d0/accu
weight_at_r(l,k,j) = tmp_array(j) * accu weight_at_r(l,k,j) = tmp_array(j) * accu
if(isnan(weight_at_r(l,k,j)))then
print*,'isnan(weight_at_r(l,k,j))' if(isnan(weight_at_r(l,k,j))) then
print*,l,k,j print*,'isnan(weight_at_r(l,k,j))'
accu = 0.d0 print*,l,k,j
do i = 1, nucl_num accu = 0.d0
! function defined for each atom "i" by equation (13) and (21) with k == 3 do i = 1, nucl_num
tmp_array(i) = cell_function_becke(r,i) ! P_n(r) ! function defined for each atom "i" by equation (13) and (21) with k == 3
print*,i,tmp_array(i) tmp_array(i) = cell_function_becke(r,i) ! P_n(r)
! Then you compute the summ the P_n(r) function for each of the "r" points print*,i,tmp_array(i)
accu += tmp_array(i) ! Then you compute the summ the P_n(r) function for each of the "r" points
enddo accu += tmp_array(i)
write(*,'(100(F16.10,X))')tmp_array(j) , accu enddo
write(*,'(100(F16.10,X))')tmp_array(j) , accu
stop stop
endif endif
enddo enddo
@ -151,35 +229,76 @@ BEGIN_PROVIDER [double precision, weight_at_r, (n_points_integration_angular,n_p
END_PROVIDER END_PROVIDER
! ---
BEGIN_PROVIDER [double precision, final_weight_at_r, (n_points_integration_angular,n_points_radial_grid,nucl_num)]
BEGIN_PROVIDER [double precision, final_weight_at_r, (n_points_integration_angular,n_points_radial_grid,nucl_num) ]
BEGIN_DOC BEGIN_DOC
! Total weight on each grid point which takes into account all Lebedev, Voronoi and radial weights. ! Total weight on each grid point which takes into account all Lebedev, Voronoi and radial weights.
END_DOC END_DOC
implicit none implicit none
integer :: i,j,k,l,m integer :: i, j, k, l, m
double precision :: r(3) double precision :: r(3)
double precision :: accu,cell_function_becke double precision :: tmp_array(nucl_num)
double precision :: tmp_array(nucl_num) double precision :: contrib_integration, x, tmp
double precision :: contrib_integration,x double precision, external :: derivative_knowles_function, knowles_function
double precision :: derivative_knowles_function,knowles_function
! run over all points in space final_weight_at_r = 0.d0
do j = 1, nucl_num ! that are referred to each atom
do i = 1, n_points_radial_grid -1 !for each radial grid attached to the "jth" atom PROVIDE rad_grid_type
x = grid_points_radial(i) ! x value for the mapping of the [0, +\infty] to [0,1] if(rad_grid_type .eq. "KNOWLES") then
do k = 1, n_points_integration_angular ! for each angular point attached to the "jth" atom
contrib_integration = derivative_knowles_function(alpha_knowles(grid_atomic_number(j)),m_knowles,x)& ! run over all points in space
*knowles_function(alpha_knowles(grid_atomic_number(j)),m_knowles,x)**2 do j = 1, nucl_num ! that are referred to each atom
final_weight_at_r(k,i,j) = weights_angular_points(k) * weight_at_r(k,i,j) * contrib_integration * dr_radial_integral do i = 1, n_points_radial_grid -1 !for each radial grid attached to the "jth" atom
if(isnan(final_weight_at_r(k,i,j)))then x = grid_points_radial(i) ! x value for the mapping of the [0, +\infty] to [0,1]
print*,'isnan(final_weight_at_r(k,i,j))'
print*,k,i,j do k = 1, n_points_integration_angular ! for each angular point attached to the "jth" atom
write(*,'(100(F16.10,X))')weights_angular_points(k) , weight_at_r(k,i,j) , contrib_integration , dr_radial_integral contrib_integration = derivative_knowles_function(alpha_knowles(grid_atomic_number(j)), m_knowles, x) &
stop * knowles_function(alpha_knowles(grid_atomic_number(j)), m_knowles, x)**2
endif
final_weight_at_r(k,i,j) = weights_angular_points(k) * weight_at_r(k,i,j) * contrib_integration * dr_radial_integral
if(isnan(final_weight_at_r(k,i,j))) then
print*,'isnan(final_weight_at_r(k,i,j))'
print*,k,i,j
write(*,'(100(F16.10,X))') weights_angular_points(k), weight_at_r(k,i,j), contrib_integration
stop
endif
enddo
enddo enddo
enddo enddo
enddo
elseif(rad_grid_type .eq. "GILL") then
! GILL & CHIEN, 2002
tmp = 2.d0 * R_gill * R_gill * R_gill * dble(n_points_radial_grid)
! run over all points in space
do j = 1, nucl_num ! that are referred to each atom
do i = 1, n_points_radial_grid - 1 !for each radial grid attached to the "jth" atom
contrib_integration = tmp * dble(i-1)**5 / dble(n_points_radial_grid-i+1)**7
do k = 1, n_points_integration_angular ! for each angular point attached to the "jth" atom
final_weight_at_r(k,i,j) = weights_angular_points(k) * weight_at_r(k,i,j) * contrib_integration
if(isnan(final_weight_at_r(k,i,j))) then
print*,'isnan(final_weight_at_r(k,i,j))'
print*,k,i,j
write(*,'(100(F16.10,X))') weights_angular_points(k), weight_at_r(k,i,j), contrib_integration, dr_radial_integral
stop
endif
enddo
enddo
enddo
else
print*, " rad_grid_type = ", rad_grid_type, ' is not implemented'
stop
endif
END_PROVIDER END_PROVIDER

74
src/becke_numerical_grid/grid_becke_vector.irp.f
View File

@ -1,10 +1,13 @@
BEGIN_PROVIDER [integer, n_points_final_grid] BEGIN_PROVIDER [integer, n_points_final_grid]
implicit none
BEGIN_DOC BEGIN_DOC
! Number of points which are non zero ! Number of points which are non zero
END_DOC END_DOC
integer :: i,j,k,l
implicit none
integer :: i, j, k, l
n_points_final_grid = 0 n_points_final_grid = 0
do j = 1, nucl_num do j = 1, nucl_num
do i = 1, n_points_radial_grid -1 do i = 1, n_points_radial_grid -1
@ -16,27 +19,38 @@ BEGIN_PROVIDER [integer, n_points_final_grid]
enddo enddo
enddo enddo
enddo enddo
print*,'n_points_final_grid = ',n_points_final_grid
print*,'n max point = ',n_points_integration_angular*(n_points_radial_grid*nucl_num - 1) print*,' n_points_final_grid = ', n_points_final_grid
print*,' n max point = ', n_points_integration_angular*(n_points_radial_grid*nucl_num - 1)
call ezfio_set_becke_numerical_grid_n_points_final_grid(n_points_final_grid) call ezfio_set_becke_numerical_grid_n_points_final_grid(n_points_final_grid)
END_PROVIDER END_PROVIDER
BEGIN_PROVIDER [double precision, final_grid_points, (3,n_points_final_grid)] ! ---
&BEGIN_PROVIDER [double precision, final_weight_at_r_vector, (n_points_final_grid) ]
&BEGIN_PROVIDER [integer, index_final_points, (3,n_points_final_grid) ] BEGIN_PROVIDER [double precision, final_grid_points, (3,n_points_final_grid)]
&BEGIN_PROVIDER [integer, index_final_points_reverse, (n_points_integration_angular,n_points_radial_grid,nucl_num) ] &BEGIN_PROVIDER [double precision, final_weight_at_r_vector, (n_points_final_grid)]
implicit none &BEGIN_PROVIDER [integer, index_final_points, (3,n_points_final_grid)]
&BEGIN_PROVIDER [integer, index_final_points_reverse, (n_points_integration_angular,n_points_radial_grid,nucl_num)]
BEGIN_DOC BEGIN_DOC
! final_grid_points(1:3,j) = (/ x, y, z /) of the jth grid point ! final_grid_points(1:3,j) = (/ x, y, z /) of the jth grid point
! !
! final_weight_at_r_vector(i) = Total weight function of the ith grid point which contains the Lebedev, Voronoi and radial weights contributions ! final_weight_at_r_vector(i) = Total weight function of the ith grid point which contains the Lebedev, Voronoi and radial weights contributions
! !
! index_final_points(1:3,i) = gives the angular, radial and atomic indices associated to the ith grid point ! index_final_points(1:3,i) = gives the angular, radial and atomic indices associated to the ith grid point
! !
! index_final_points_reverse(i,j,k) = index of the grid point having i as angular, j as radial and l as atomic indices ! index_final_points_reverse(i,j,k) = index of the grid point having i as angular, j as radial and l as atomic indices
END_DOC END_DOC
integer :: i,j,k,l,i_count
double precision :: r(3) implicit none
integer :: i, j, k, l, i_count
double precision :: r(3)
double precision :: wall0, wall1
call wall_time(wall0)
print *, ' Providing final_grid_points ...'
i_count = 0 i_count = 0
do j = 1, nucl_num do j = 1, nucl_num
do i = 1, n_points_radial_grid -1 do i = 1, n_points_radial_grid -1
@ -57,18 +71,34 @@ END_PROVIDER
enddo enddo
enddo enddo
FREE grid_points_per_atom
FREE final_weight_at_r
call wall_time(wall1)
print *, ' wall time for final_grid_points,', wall1 - wall0
call print_memory_usage()
END_PROVIDER END_PROVIDER
! ---
BEGIN_PROVIDER [double precision, final_grid_points_transp, (n_points_final_grid,3)] BEGIN_PROVIDER [double precision, final_grid_points_transp, (n_points_final_grid,3)]
implicit none
BEGIN_DOC BEGIN_DOC
! Transposed final_grid_points ! Transposed final_grid_points
END_DOC END_DOC
implicit none
integer :: i,j integer :: i,j
do j=1,3
do i=1,n_points_final_grid do j = 1, 3
do i = 1, n_points_final_grid
final_grid_points_transp(i,j) = final_grid_points(j,i) final_grid_points_transp(i,j) = final_grid_points(j,i)
enddo enddo
enddo enddo
END_PROVIDER END_PROVIDER
! ---

142
src/becke_numerical_grid/integration_radial.irp.f
View File

@ -1,71 +1,93 @@
double precision function knowles_function(alpha,m,x)
implicit none
BEGIN_DOC
! Function proposed by Knowles (JCP, 104, 1996) for distributing the radial points :
! the Log "m" function ( equation (7) in the paper )
END_DOC
double precision, intent(in) :: alpha,x
integer, intent(in) :: m
!print*, x
knowles_function = -alpha * dlog(1.d0-x**m)
end
double precision function derivative_knowles_function(alpha,m,x) ! ---
implicit none
BEGIN_DOC
! Derivative of the function proposed by Knowles (JCP, 104, 1996) for distributing the radial points
END_DOC
double precision, intent(in) :: alpha,x
integer, intent(in) :: m
double precision :: f
f = x**(m-1)
derivative_knowles_function = alpha * dble(m) * f / (1.d0 - x*f)
end
BEGIN_PROVIDER [double precision, alpha_knowles, (100)] double precision function knowles_function(alpha, m, x)
implicit none
integer :: i
BEGIN_DOC
! Recommended values for the alpha parameters according to the paper of Knowles (JCP, 104, 1996)
! as a function of the nuclear charge
END_DOC
! H-He BEGIN_DOC
alpha_knowles(1) = 5.d0 ! Function proposed by Knowles (JCP, 104, 1996) for distributing the radial points :
alpha_knowles(2) = 5.d0 ! the Log "m" function ( equation (7) in the paper )
END_DOC
implicit none
double precision, intent(in) :: alpha, x
integer, intent(in) :: m
! Li-Be !print*, x
alpha_knowles(3) = 7.d0 knowles_function = -alpha * dlog(1.d0-x**m)
alpha_knowles(4) = 7.d0
! B-Ne return
do i = 5, 10 end
alpha_knowles(i) = 5.d0
enddo
! Na-Mg ! ---
do i = 11, 12
alpha_knowles(i) = 7.d0
enddo
! Al-Ar double precision function derivative_knowles_function(alpha, m, x)
do i = 13, 18
alpha_knowles(i) = 5.d0
enddo
! K-Ca BEGIN_DOC
do i = 19, 20 ! Derivative of the function proposed by Knowles (JCP, 104, 1996) for distributing the radial points
alpha_knowles(i) = 7.d0 END_DOC
enddo
! Sc-Zn implicit none
do i = 21, 30 double precision, intent(in) :: alpha, x
alpha_knowles(i) = 5.d0 integer, intent(in) :: m
enddo double precision :: f
! Ga-Kr f = x**(m-1)
do i = 31, 100 derivative_knowles_function = alpha * dble(m) * f / (1.d0 - x*f)
alpha_knowles(i) = 7.d0
enddo return
end
! ---
BEGIN_PROVIDER [double precision, alpha_knowles, (100)]
BEGIN_DOC
! Recommended values for the alpha parameters according to the paper of Knowles (JCP, 104, 1996)
! as a function of the nuclear charge
END_DOC
implicit none
integer :: i
! H-He
alpha_knowles(1) = 5.d0
alpha_knowles(2) = 5.d0
! Li-Be
alpha_knowles(3) = 7.d0
alpha_knowles(4) = 7.d0
! B-Ne
do i = 5, 10
alpha_knowles(i) = 5.d0
enddo
! Na-Mg
do i = 11, 12
alpha_knowles(i) = 7.d0
enddo
! Al-Ar
do i = 13, 18
alpha_knowles(i) = 5.d0
enddo
! K-Ca
do i = 19, 20
alpha_knowles(i) = 7.d0
enddo
! Sc-Zn
do i = 21, 30
alpha_knowles(i) = 5.d0
enddo
! Ga-Kr
do i = 31, 100
alpha_knowles(i) = 7.d0
enddo
END_PROVIDER
! ---
END_PROVIDER

43
src/becke_numerical_grid/step_function_becke.irp.f
View File

@ -20,31 +20,42 @@ double precision function f_function_becke(x)
f_function_becke = 1.5d0 * x - 0.5d0 * x*x*x f_function_becke = 1.5d0 * x - 0.5d0 * x*x*x
end end
double precision function cell_function_becke(r,atom_number) ! ---
implicit none
double precision, intent(in) :: r(3) double precision function cell_function_becke(r, atom_number)
integer, intent(in) :: atom_number
BEGIN_DOC BEGIN_DOC
! atom_number :: atom on which the cell function of Becke (1988, JCP,88(4)) ! atom_number :: atom on which the cell function of Becke (1988, JCP,88(4))
! r(1:3) :: x,y,z coordinantes of the current point ! r(1:3) :: x,y,z coordinantes of the current point
END_DOC END_DOC
double precision :: mu_ij,nu_ij
double precision :: distance_i,distance_j,step_function_becke implicit none
integer :: j double precision, intent(in) :: r(3)
distance_i = (r(1) - nucl_coord_transp(1,atom_number) ) * (r(1) - nucl_coord_transp(1,atom_number)) integer, intent(in) :: atom_number
integer :: j
double precision :: mu_ij, nu_ij
double precision :: distance_i, distance_j, step_function_becke
distance_i = (r(1) - nucl_coord_transp(1,atom_number) ) * (r(1) - nucl_coord_transp(1,atom_number))
distance_i += (r(2) - nucl_coord_transp(2,atom_number) ) * (r(2) - nucl_coord_transp(2,atom_number)) distance_i += (r(2) - nucl_coord_transp(2,atom_number) ) * (r(2) - nucl_coord_transp(2,atom_number))
distance_i += (r(3) - nucl_coord_transp(3,atom_number) ) * (r(3) - nucl_coord_transp(3,atom_number)) distance_i += (r(3) - nucl_coord_transp(3,atom_number) ) * (r(3) - nucl_coord_transp(3,atom_number))
distance_i = dsqrt(distance_i) distance_i = dsqrt(distance_i)
cell_function_becke = 1.d0 cell_function_becke = 1.d0
do j = 1, nucl_num do j = 1, nucl_num
if(j==atom_number)cycle if(j==atom_number) cycle
distance_j = (r(1) - nucl_coord_transp(1,j) ) * (r(1) - nucl_coord_transp(1,j))
distance_j+= (r(2) - nucl_coord_transp(2,j) ) * (r(2) - nucl_coord_transp(2,j)) distance_j = (r(1) - nucl_coord_transp(1,j) ) * (r(1) - nucl_coord_transp(1,j))
distance_j+= (r(3) - nucl_coord_transp(3,j) ) * (r(3) - nucl_coord_transp(3,j)) distance_j += (r(2) - nucl_coord_transp(2,j) ) * (r(2) - nucl_coord_transp(2,j))
distance_j = dsqrt(distance_j) distance_j += (r(3) - nucl_coord_transp(3,j) ) * (r(3) - nucl_coord_transp(3,j))
mu_ij = (distance_i - distance_j)*nucl_dist_inv(atom_number,j) distance_j = dsqrt(distance_j)
mu_ij = (distance_i - distance_j) * nucl_dist_inv(atom_number,j)
nu_ij = mu_ij + slater_bragg_type_inter_distance_ua(atom_number,j) * (1.d0 - mu_ij*mu_ij) nu_ij = mu_ij + slater_bragg_type_inter_distance_ua(atom_number,j) * (1.d0 - mu_ij*mu_ij)
cell_function_becke *= step_function_becke(nu_ij) cell_function_becke *= step_function_becke(nu_ij)
enddo enddo
return
end end

447
src/bi_ort_ints/bi_ort_ints.irp.f
View File

@ -1,13 +1,37 @@
! ---
program bi_ort_ints program bi_ort_ints
implicit none
BEGIN_DOC BEGIN_DOC
! TODO : Put the documentation of the program here ! TODO : Put the documentation of the program here
END_DOC END_DOC
implicit none
my_grid_becke = .True. my_grid_becke = .True.
my_n_pt_r_grid = 10 PROVIDE tc_grid1_a tc_grid1_r
my_n_pt_a_grid = 14 my_n_pt_r_grid = tc_grid1_r
touch my_grid_becke my_n_pt_r_grid my_n_pt_a_grid my_n_pt_a_grid = tc_grid1_a
call test_3e touch my_grid_becke my_n_pt_r_grid my_n_pt_a_grid
! call test_3e
! call test_5idx
! call test_5idx2
call test_4idx()
!call test_4idx_n4()
!call test_4idx2()
!call test_5idx2
!call test_5idx
end
subroutine test_5idx2
PROVIDE three_e_5_idx_cycle_2_bi_ort
end
subroutine test_4idx2()
!PROVIDE three_e_4_idx_direct_bi_ort
PROVIDE three_e_4_idx_exch23_bi_ort
end end
subroutine test_3e subroutine test_3e
@ -16,11 +40,12 @@ subroutine test_3e
double precision :: accu, contrib,new,ref double precision :: accu, contrib,new,ref
i = 1 i = 1
k = 1 k = 1
n = 0
accu = 0.d0 accu = 0.d0
do i = 1, mo_num do i = 1, mo_num
do k = 1, mo_num do k = 1, mo_num
do j = 1, mo_num do j = 1, mo_num
do l = 1, mo_num do l = 1, mo_num
do m = 1, mo_num do m = 1, mo_num
do n = 1, mo_num do n = 1, mo_num
call give_integrals_3_body_bi_ort(n, l, k, m, j, i, new) call give_integrals_3_body_bi_ort(n, l, k, m, j, i, new)
@ -31,6 +56,7 @@ subroutine test_3e
print*,'pb !!' print*,'pb !!'
print*,i,k,j,l,m,n print*,i,k,j,l,m,n
print*,ref,new,contrib print*,ref,new,contrib
stop
endif endif
enddo enddo
enddo enddo
@ -42,3 +68,408 @@ subroutine test_3e
end end
subroutine test_5idx
implicit none
integer :: i,k,j,l,m,n,ipoint
double precision :: accu, contrib,new,ref
double precision, external :: three_e_5_idx_exch12_bi_ort
i = 1
k = 1
n = 0
accu = 0.d0
PROVIDE three_e_5_idx_direct_bi_ort_old
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
! if (dabs(three_e_5_idx_direct_bi_ort(m,l,j,k,i) - three_e_5_idx_exch12_bi_ort(m,l,i,k,j)) > 1.d-10) then
! stop
! endif
new = three_e_5_idx_direct_bi_ort(m,l,j,k,i)
ref = three_e_5_idx_direct_bi_ort_old(m,l,j,k,i)
contrib = dabs(new - ref)
accu += contrib
if(contrib .gt. 1.d-10)then
print*,'direct'
print*,i,k,j,l,m
print*,ref,new,contrib
stop
endif
!
! new = three_e_5_idx_exch12_bi_ort(m,l,j,k,i)
! ref = three_e_5_idx_exch12_bi_ort_old(m,l,j,k,i)
! contrib = dabs(new - ref)
! accu += contrib
! if(contrib .gt. 1.d-10)then
! print*,'exch12'
! print*,i,k,j,l,m
! print*,ref,new,contrib
! stop
! endif
!
!
! new = three_e_5_idx_cycle_1_bi_ort(m,l,j,k,i)
! ref = three_e_5_idx_cycle_1_bi_ort_old(m,l,j,k,i)
! contrib = dabs(new - ref)
! accu += contrib
! if(contrib .gt. 1.d-10)then
! print*,'cycle1'
! print*,i,k,j,l,m
! print*,ref,new,contrib
! stop
! endif
!
! new = three_e_5_idx_cycle_2_bi_ort(m,l,j,k,i)
! ref = three_e_5_idx_cycle_2_bi_ort_old(m,l,j,k,i)
! contrib = dabs(new - ref)
! accu += contrib
! if(contrib .gt. 1.d-10)then
! print*,'cycle2'
! print*,i,k,j,l,m
! print*,ref,new,contrib
! stop
! endif
!
! new = three_e_5_idx_exch23_bi_ort(m,l,j,k,i)
! ref = three_e_5_idx_exch23_bi_ort_old(m,l,j,k,i)
! contrib = dabs(new - ref)
! accu += contrib
! if(contrib .gt. 1.d-10)then
! print*,'exch23'
! print*,i,k,j,l,m
! print*,ref,new,contrib
! stop
! endif
!
! new = three_e_5_idx_exch13_bi_ort(m,l,j,k,i)
! ref = three_e_5_idx_exch13_bi_ort_old(m,l,j,k,i)
! contrib = dabs(new - ref)
! accu += contrib
! if(contrib .gt. 1.d-10)then
! print*,'exch13'
! print*,i,k,j,l,m
! print*,ref,new,contrib
! stop
! endif
!
! new = three_e_5_idx_cycle_1_bi_ort(m,l,j,k,i)
! ref = three_e_5_idx_cycle_1_bi_ort_old(m,l,j,k,i)
! contrib = dabs(new - ref)
! accu += contrib
! if(contrib .gt. 1.d-10)then
! print*,'cycle1'
! print*,i,k,j,l,m
! print*,ref,new,contrib
! stop
! endif
!
! new = three_e_5_idx_cycle_2_bi_ort(m,l,j,k,i)
! ref = three_e_5_idx_cycle_2_bi_ort_old(m,l,j,k,i)
! contrib = dabs(new - ref)
! accu += contrib
! if(contrib .gt. 1.d-10)then
! print*,'cycle2'
! print*,i,k,j,l,m
! print*,ref,new,contrib
! stop
! endif
!
! new = three_e_5_idx_exch23_bi_ort(m,l,j,k,i)
! ref = three_e_5_idx_exch23_bi_ort_old(m,l,j,k,i)
! contrib = dabs(new - ref)
! accu += contrib
! if(contrib .gt. 1.d-10)then
! print*,'exch23'
! print*,i,k,j,l,m
! print*,ref,new,contrib
! stop
! endif
!
! new = three_e_5_idx_exch13_bi_ort(m,l,j,k,i)
! ref = three_e_5_idx_exch13_bi_ort_old(m,l,j,k,i)
! contrib = dabs(new - ref)
! accu += contrib
! if(contrib .gt. 1.d-10)then
! print*,'exch13'
! print*,i,k,j,l,m
! print*,ref,new,contrib
! stop
! endif
!
enddo
enddo
enddo
enddo
enddo
print*,'accu = ',accu/dble(mo_num)**5
end
! ---
subroutine test_4idx_n4()
implicit none
integer :: i, j, k, l
double precision :: accu, contrib, new, ref, thr
thr = 1d-10
PROVIDE three_e_4_idx_direct_bi_ort_old
PROVIDE three_e_4_idx_direct_bi_ort_n4
accu = 0.d0
do i = 1, mo_num
do j = 1, mo_num
do k = 1, mo_num
do l = 1, mo_num
new = three_e_4_idx_direct_bi_ort_n4 (l,k,j,i)
ref = three_e_4_idx_direct_bi_ort_old(l,k,j,i)
contrib = dabs(new - ref)
accu += contrib
if(contrib .gt. thr) then
print*, ' problem in three_e_4_idx_direct_bi_ort_n4'
print*, l, k, j, i
print*, ref, new, contrib
stop
endif
enddo
enddo
enddo
enddo
print*, ' accu on three_e_4_idx_direct_bi_ort_n4 = ', accu / dble(mo_num)**4
! ---
PROVIDE three_e_4_idx_exch13_bi_ort_old
PROVIDE three_e_4_idx_exch13_bi_ort_n4
accu = 0.d0
do i = 1, mo_num
do j = 1, mo_num
do k = 1, mo_num
do l = 1, mo_num
new = three_e_4_idx_exch13_bi_ort_n4 (l,k,j,i)
ref = three_e_4_idx_exch13_bi_ort_old(l,k,j,i)
contrib = dabs(new - ref)
accu += contrib
if(contrib .gt. thr) then
print*, ' problem in three_e_4_idx_exch13_bi_ort_n4'
print*, l, k, j, i
print*, ref, new, contrib
stop
endif
enddo
enddo
enddo
enddo
print*, ' accu on three_e_4_idx_exch13_bi_ort_n4 = ', accu / dble(mo_num)**4
! ---
PROVIDE three_e_4_idx_cycle_1_bi_ort_old
PROVIDE three_e_4_idx_cycle_1_bi_ort_n4
accu = 0.d0
do i = 1, mo_num
do j = 1, mo_num
do k = 1, mo_num
do l = 1, mo_num
new = three_e_4_idx_cycle_1_bi_ort_n4 (l,k,j,i)
ref = three_e_4_idx_cycle_1_bi_ort_old(l,k,j,i)
contrib = dabs(new - ref)
accu += contrib
if(contrib .gt. thr) then
print*, ' problem in three_e_4_idx_cycle_1_bi_ort_n4'
print*, l, k, j, i
print*, ref, new, contrib
stop
endif
enddo
enddo
enddo
enddo
print*, ' accu on three_e_4_idx_cycle_1_bi_ort_n4 = ', accu / dble(mo_num)**4
! ---
PROVIDE three_e_4_idx_exch23_bi_ort_old
PROVIDE three_e_4_idx_exch23_bi_ort_n4
accu = 0.d0
do i = 1, mo_num
do j = 1, mo_num
do k = 1, mo_num
do l = 1, mo_num
new = three_e_4_idx_exch23_bi_ort_n4 (l,k,j,i)
ref = three_e_4_idx_exch23_bi_ort_old(l,k,j,i)
contrib = dabs(new - ref)
accu += contrib
if(contrib .gt. thr) then
print*, ' problem in three_e_4_idx_exch23_bi_ort_n4'
print*, l, k, j, i
print*, ref, new, contrib
stop
endif
enddo
enddo
enddo
enddo
print*, ' accu on three_e_4_idx_exch23_bi_ort_n4 = ', accu / dble(mo_num)**4
! ---
return
end
! ---
subroutine test_4idx()
implicit none
integer :: i, j, k, l
double precision :: accu, contrib, new, ref, thr, norm
thr = 1d-10
PROVIDE three_e_4_idx_direct_bi_ort_old
PROVIDE three_e_4_idx_direct_bi_ort
accu = 0.d0
norm = 0.d0
do i = 1, mo_num
do j = 1, mo_num
do k = 1, mo_num
do l = 1, mo_num
new = three_e_4_idx_direct_bi_ort (l,k,j,i)
ref = three_e_4_idx_direct_bi_ort_old(l,k,j,i)
contrib = dabs(new - ref)
if(contrib .gt. thr) then
print*, ' problem in three_e_4_idx_direct_bi_ort'
print*, l, k, j, i
print*, ref, new, contrib
stop
endif
accu += contrib
norm += dabs(ref)
enddo
enddo
enddo
enddo
print*, ' accu on three_e_4_idx_direct_bi_ort (%) = ', 100.d0 * accu / norm
! ---
PROVIDE three_e_4_idx_exch13_bi_ort_old
PROVIDE three_e_4_idx_exch13_bi_ort
accu = 0.d0
norm = 0.d0
do i = 1, mo_num
do j = 1, mo_num
do k = 1, mo_num
do l = 1, mo_num
new = three_e_4_idx_exch13_bi_ort (l,k,j,i)
ref = three_e_4_idx_exch13_bi_ort_old(l,k,j,i)
contrib = dabs(new - ref)
if(contrib .gt. thr) then
print*, ' problem in three_e_4_idx_exch13_bi_ort'
print*, l, k, j, i
print*, ref, new, contrib
stop
endif
accu += contrib
norm += dabs(ref)
enddo
enddo
enddo
enddo
print*, ' accu on three_e_4_idx_exch13_bi_ort (%) = ', 100.d0 * accu / norm
! ---
PROVIDE three_e_4_idx_cycle_1_bi_ort_old
PROVIDE three_e_4_idx_cycle_1_bi_ort
accu = 0.d0
norm = 0.d0
do i = 1, mo_num
do j = 1, mo_num
do k = 1, mo_num
do l = 1, mo_num
new = three_e_4_idx_cycle_1_bi_ort (l,k,j,i)
ref = three_e_4_idx_cycle_1_bi_ort_old(l,k,j,i)
contrib = dabs(new - ref)
if(contrib .gt. thr) then
print*, ' problem in three_e_4_idx_cycle_1_bi_ort'
print*, l, k, j, i
print*, ref, new, contrib
stop
endif
accu += contrib
norm += dabs(ref)
enddo
enddo
enddo
enddo
print*, ' accu on three_e_4_idx_cycle_1_bi_ort (%) = ', 100.d0 * accu / norm
! ---
PROVIDE three_e_4_idx_exch23_bi_ort_old
PROVIDE three_e_4_idx_exch23_bi_ort
accu = 0.d0
norm = 0.d0
do i = 1, mo_num
do j = 1, mo_num
do k = 1, mo_num
do l = 1, mo_num
new = three_e_4_idx_exch23_bi_ort (l,k,j,i)
ref = three_e_4_idx_exch23_bi_ort_old(l,k,j,i)
contrib = dabs(new - ref)
if(contrib .gt. thr) then
print*, ' problem in three_e_4_idx_exch23_bi_ort'
print*, l, k, j, i
print*, ref, new, contrib
stop
endif
accu += contrib
norm += dabs(ref)
enddo
enddo
enddo
enddo
print*, ' accu on three_e_4_idx_exch23_bi_ort (%) = ', 100.d0 * accu / norm
! ---
return
end

1610
src/bi_ort_ints/no_dressing.irp.f Normal file
View File

File diff suppressed because it is too large Load Diff

66
src/bi_ort_ints/no_dressing_energy.irp.f Normal file
View File

@ -0,0 +1,66 @@
! ---
BEGIN_PROVIDER [double precision, energy_1e_noL_HF]
implicit none
integer :: i
PROVIDE mo_bi_ortho_tc_one_e
energy_1e_noL_HF = 0.d0
do i = 1, elec_beta_num
energy_1e_noL_HF += mo_bi_ortho_tc_one_e(i,i)
enddo
do i = 1, elec_alpha_num
energy_1e_noL_HF += mo_bi_ortho_tc_one_e(i,i)
enddo
print*, "energy_1e_noL_HF = ", energy_1e_noL_HF
END_PROVIDER
! ---
BEGIN_PROVIDER [double precision, energy_2e_noL_HF]
implicit none
integer :: i, j
PROVIDE mo_bi_ortho_tc_two_e
energy_2e_noL_HF = 0.d0
! down-down & down-down
do i = 1, elec_beta_num
do j = 1, elec_beta_num
energy_2e_noL_HF += (mo_bi_ortho_tc_two_e(i,j,i,j) - mo_bi_ortho_tc_two_e(j,i,i,j))
enddo
enddo
! down-down & up-up
do i = 1, elec_beta_num
do j = 1, elec_alpha_num
energy_2e_noL_HF += mo_bi_ortho_tc_two_e(i,j,i,j)
enddo
enddo
! up-up & down-down
do i = 1, elec_alpha_num
do j = 1, elec_beta_num
energy_2e_noL_HF += mo_bi_ortho_tc_two_e(i,j,i,j)
enddo
enddo
! up-up & up-up
do i = 1, elec_alpha_num
do j = 1, elec_alpha_num
energy_2e_noL_HF += (mo_bi_ortho_tc_two_e(i,j,i,j) - mo_bi_ortho_tc_two_e(j,i,i,j))
enddo
enddo
! 0.5 x is in the Slater-Condon rules and not in the integrals
energy_2e_noL_HF = 0.5d0 * energy_2e_noL_HF
print*, "energy_2e_noL_HF = ", energy_2e_noL_HF
END_PROVIDER
! ---

512
src/bi_ort_ints/no_dressing_naive.irp.f Normal file
View File

@ -0,0 +1,512 @@
! ---
BEGIN_PROVIDER [double precision, noL_0e_naive]
implicit none
integer :: ii, jj, kk
integer :: i, j, k
double precision :: sigma_i, sigma_j, sigma_k
double precision :: I_ijk_ijk, I_ijk_kij, I_ijk_jki, I_ijk_jik, I_ijk_kji, I_ijk_ikj
double precision :: t0, t1
double precision, allocatable :: tmp(:)
print*, " Providing noL_0e_naive ..."
call wall_time(t0)
allocate(tmp(elec_num))
!$OMP PARALLEL &
!$OMP DEFAULT (NONE) &
!$OMP PRIVATE (ii, i, sigma_i, jj, j, sigma_j, kk, k, sigma_k, &
!$OMP I_ijk_ijk, I_ijk_kij, I_ijk_jki, I_ijk_jik, &
!$OMP I_ijk_kji, I_ijk_ikj) &
!$OMP SHARED (elec_beta_num, elec_num, tmp)
!$OMP DO
do ii = 1, elec_num
if(ii .le. elec_beta_num) then
i = ii
sigma_i = -1.d0
else
i = ii - elec_beta_num
sigma_i = +1.d0
endif
tmp(ii) = 0.d0
do jj = 1, elec_num
if(jj .le. elec_beta_num) then
j = jj
sigma_j = -1.d0
else
j = jj - elec_beta_num
sigma_j = +1.d0
endif
do kk = 1, elec_num
if(kk .le. elec_beta_num) then
k = kk
sigma_k = -1.d0
else
k = kk - elec_beta_num
sigma_k = +1.d0
endif
call give_integrals_3_body_bi_ort_spin( i, sigma_i, j, sigma_j, k, sigma_k &
, i, sigma_i, j, sigma_j, k, sigma_k &
, I_ijk_ijk)
call give_integrals_3_body_bi_ort_spin( i, sigma_i, j, sigma_j, k, sigma_k &
, k, sigma_k, i, sigma_i, j, sigma_j &
, I_ijk_kij)
call give_integrals_3_body_bi_ort_spin( i, sigma_i, j, sigma_j, k, sigma_k &
, j, sigma_j, k, sigma_k, i, sigma_i &
, I_ijk_jki)
call give_integrals_3_body_bi_ort_spin( i, sigma_i, j, sigma_j, k, sigma_k &
, j, sigma_j, i, sigma_i, k, sigma_k &
, I_ijk_jik)
call give_integrals_3_body_bi_ort_spin( i, sigma_i, j, sigma_j, k, sigma_k &
, k, sigma_k, j, sigma_j, i, sigma_i &
, I_ijk_kji)
call give_integrals_3_body_bi_ort_spin( i, sigma_i, j, sigma_j, k, sigma_k &
, i, sigma_i, k, sigma_k, j, sigma_j &
, I_ijk_ikj)
tmp(ii) = tmp(ii) + I_ijk_ijk + I_ijk_kij + I_ijk_jki - I_ijk_jik - I_ijk_kji - I_ijk_ikj
! = tmp(ii) + I_ijk_ijk + 2.d0 * I_ijk_kij - 3.d0 * I_ijk_jik
enddo
enddo
enddo
!$OMP END DO
!$OMP END PARALLEL
noL_0e_naive = -1.d0 * (sum(tmp)) / 6.d0
deallocate(tmp)
call wall_time(t1)
print*, " Wall time for noL_0e_naive (min) = ", (t1 - t0)/60.d0
print*, " noL_0e_naive = ", noL_0e_naive
END_PROVIDER
! ---
BEGIN_PROVIDER [double precision, noL_1e_naive, (mo_num, mo_num)]
BEGIN_DOC
!
! < p | H(1) | s > is dressed with noL_1e_naive(p,s)
!
END_DOC
implicit none
integer :: ii, jj
integer :: i, j, p, s
double precision :: sigma_i, sigma_j, sigma_p, sigma_s
double precision :: I_pij_sji, I_pij_sij, I_pij_jis, I_pij_ijs, I_pij_isj, I_pij_jsi
double precision :: t0, t1
print*, " Providing noL_1e_naive ..."
call wall_time(t0)
! ----
! up-up part
sigma_p = +1.d0
sigma_s = +1.d0
!$OMP PARALLEL &
!$OMP DEFAULT (NONE) &
!$OMP PRIVATE (ii, i, sigma_i, jj, j, sigma_j, &
!$OMP I_pij_sji, I_pij_sij, I_pij_jis, &
!$OMP I_pij_ijs, I_pij_isj, I_pij_jsi ) &
!$OMP SHARED (mo_num, elec_beta_num, elec_num, &
!$OMP sigma_p, sigma_s, noL_1e_naive)
!$OMP DO COLLAPSE (2)
do s = 1, mo_num
do p = 1, mo_num
noL_1e_naive(p,s) = 0.d0
do ii = 1, elec_num
if(ii .le. elec_beta_num) then
i = ii
sigma_i = -1.d0
else
i = ii - elec_beta_num
sigma_i = +1.d0
endif
do jj = 1, elec_num
if(jj .le. elec_beta_num) then
j = jj
sigma_j = -1.d0
else
j = jj - elec_beta_num
sigma_j = +1d0
endif
call give_integrals_3_body_bi_ort_spin( p, sigma_p, i, sigma_i, j, sigma_j &
, s, sigma_s, j, sigma_j, i, sigma_i &
, I_pij_sji)
call give_integrals_3_body_bi_ort_spin( p, sigma_p, i, sigma_i, j, sigma_j &
, s, sigma_s, i, sigma_i, j, sigma_j &
, I_pij_sij)
call give_integrals_3_body_bi_ort_spin( p, sigma_p, i, sigma_i, j, sigma_j &
, j, sigma_j, i, sigma_i, s, sigma_s &
, I_pij_jis)
call give_integrals_3_body_bi_ort_spin( p, sigma_p, i, sigma_i, j, sigma_j &
, i, sigma_i, j, sigma_j, s, sigma_s &
, I_pij_ijs)
call give_integrals_3_body_bi_ort_spin( p, sigma_p, i, sigma_i, j, sigma_j &
, i, sigma_i, s, sigma_s, j, sigma_j &
, I_pij_isj)
call give_integrals_3_body_bi_ort_spin( p, sigma_p, i, sigma_i, j, sigma_j &
, j, sigma_j, s, sigma_s, i, sigma_i &
, I_pij_jsi)
! x 0.5 because we consider 0.5 (up + down)
noL_1e_naive(p,s) = noL_1e_naive(p,s) - 0.25d0 * (I_pij_sji - I_pij_sij + I_pij_jis - I_pij_ijs + I_pij_isj - I_pij_jsi)
enddo ! j
enddo ! i
enddo ! s
enddo ! p
!$OMP END DO
!$OMP END PARALLEL
! ----
! down-down part
sigma_p = -1.d0
sigma_s = -1.d0
!$OMP PARALLEL &
!$OMP DEFAULT (NONE) &
!$OMP PRIVATE (ii, i, sigma_i, jj, j, sigma_j, &
!$OMP I_pij_sji, I_pij_sij, I_pij_jis, &
!$OMP I_pij_ijs, I_pij_isj, I_pij_jsi ) &
!$OMP SHARED (mo_num, elec_beta_num, elec_num, &
!$OMP sigma_p, sigma_s, noL_1e_naive)
!$OMP DO COLLAPSE (2)
do s = 1, mo_num
do p = 1, mo_num
do ii = 1, elec_num
if(ii .le. elec_beta_num) then
i = ii
sigma_i = -1.d0
else
i = ii - elec_beta_num
sigma_i = +1.d0
endif
do jj = 1, elec_num
if(jj .le. elec_beta_num) then
j = jj
sigma_j = -1.d0
else
j = jj - elec_beta_num
sigma_j = +1d0
endif
call give_integrals_3_body_bi_ort_spin( p, sigma_p, i, sigma_i, j, sigma_j &
, s, sigma_s, j, sigma_j, i, sigma_i &
, I_pij_sji)
call give_integrals_3_body_bi_ort_spin( p, sigma_p, i, sigma_i, j, sigma_j &
, s, sigma_s, i, sigma_i, j, sigma_j &
, I_pij_sij)
call give_integrals_3_body_bi_ort_spin( p, sigma_p, i, sigma_i, j, sigma_j &
, j, sigma_j, i, sigma_i, s, sigma_s &
, I_pij_jis)
call give_integrals_3_body_bi_ort_spin( p, sigma_p, i, sigma_i, j, sigma_j &
, i, sigma_i, j, sigma_j, s, sigma_s &
, I_pij_ijs)
call give_integrals_3_body_bi_ort_spin( p, sigma_p, i, sigma_i, j, sigma_j &
, i, sigma_i, s, sigma_s, j, sigma_j &
, I_pij_isj)
call give_integrals_3_body_bi_ort_spin( p, sigma_p, i, sigma_i, j, sigma_j &
, j, sigma_j, s, sigma_s, i, sigma_i &
, I_pij_jsi)
! x 0.5 because we consider 0.5 (up + down)
noL_1e_naive(p,s) = noL_1e_naive(p,s) - 0.25d0 * (I_pij_sji - I_pij_sij + I_pij_jis - I_pij_ijs + I_pij_isj - I_pij_jsi)
enddo ! j
enddo ! i
enddo ! s
enddo ! p
!$OMP END DO
!$OMP END PARALLEL
! ---
call wall_time(t1)
print*, " Wall time for noL_1e_naive (min) = ", (t1 - t0)/60.d0
END_PROVIDER
! ---
BEGIN_PROVIDER [double precision, noL_2e_naive, (mo_num, mo_num, mo_num, mo_num)]
BEGIN_DOC
!
! < p q | H(2) | s t > is dressed with noL_2e_naive(p,q,s,t)
!
END_DOC
implicit none
integer :: ii
integer :: i, p, q, s, t
double precision :: sigma_i, sigma_p, sigma_q, sigma_s, sigma_t
double precision :: I_ipq_ist, I_ipq_sit, I_ipq_tsi
double precision :: t0, t1
print*, " Providing noL_2e_naive ..."
call wall_time(t0)
! ----
! up-up & up-up part
sigma_p = +1.d0
sigma_s = +1.d0
sigma_q = +1.d0
sigma_t = +1.d0
!$OMP PARALLEL &
!$OMP DEFAULT (NONE) &
!$OMP PRIVATE (ii, i, sigma_i, p, q, s, t, &
!$OMP I_ipq_ist, I_ipq_sit, I_ipq_tsi) &
!$OMP SHARED (mo_num, elec_beta_num, elec_num, &
!$OMP sigma_p, sigma_q, sigma_s, sigma_t, &
!$OMP noL_2e_naive)
!$OMP DO COLLAPSE (4)
do t = 1, mo_num
do s = 1, mo_num
do q = 1, mo_num
do p = 1, mo_num
noL_2e_naive(p,q,s,t) = 0.d0
do ii = 1, elec_num
if(ii .le. elec_beta_num) then
i = ii
sigma_i = -1.d0
else
i = ii - elec_beta_num
sigma_i = +1.d0
endif
call give_integrals_3_body_bi_ort_spin( i, sigma_i, p, sigma_p, q, sigma_q &
, i, sigma_i, s, sigma_s, t, sigma_t &
, I_ipq_ist)
call give_integrals_3_body_bi_ort_spin( i, sigma_i, p, sigma_p, q, sigma_q &
, s, sigma_s, i, sigma_i, t, sigma_t &
, I_ipq_sit)
call give_integrals_3_body_bi_ort_spin( i, sigma_i, p, sigma_p, q, sigma_q &
, t, sigma_t, s, sigma_s, i, sigma_i &
, I_ipq_tsi)
! x 0.25 because we consider 0.25 (up-up + up-down + down-up + down-down)
noL_2e_naive(p,q,s,t) = noL_2e_naive(p,q,s,t) - 0.125d0 * (I_ipq_ist - I_ipq_sit - I_ipq_tsi)
enddo ! i
enddo ! p
enddo ! q
enddo ! s
enddo ! t
!$OMP END DO
!$OMP END PARALLEL
! ----
! up-up & down-down part
sigma_p = +1.d0
sigma_s = +1.d0
sigma_q = -1.d0
sigma_t = -1.d0
!$OMP PARALLEL &
!$OMP DEFAULT (NONE) &
!$OMP PRIVATE (ii, i, sigma_i, p, q, s, t, &
!$OMP I_ipq_ist, I_ipq_sit, I_ipq_tsi) &
!$OMP SHARED (mo_num, elec_beta_num, elec_num, &
!$OMP sigma_p, sigma_q, sigma_s, sigma_t, &
!$OMP noL_2e_naive)
!$OMP DO COLLAPSE (4)
do t = 1, mo_num
do s = 1, mo_num
do q = 1, mo_num
do p = 1, mo_num
do ii = 1, elec_num
if(ii .le. elec_beta_num) then
i = ii
sigma_i = -1.d0
else
i = ii - elec_beta_num
sigma_i = +1.d0
endif
call give_integrals_3_body_bi_ort_spin( i, sigma_i, p, sigma_p, q, sigma_q &
, i, sigma_i, s, sigma_s, t, sigma_t &
, I_ipq_ist)
call give_integrals_3_body_bi_ort_spin( i, sigma_i, p, sigma_p, q, sigma_q &
, s, sigma_s, i, sigma_i, t, sigma_t &
, I_ipq_sit)
call give_integrals_3_body_bi_ort_spin( i, sigma_i, p, sigma_p, q, sigma_q &
, t, sigma_t, s, sigma_s, i, sigma_i &
, I_ipq_tsi)
! x 0.25 because we consider 0.25 (up-up + up-down + down-up + down-down)
noL_2e_naive(p,q,s,t) = noL_2e_naive(p,q,s,t) - 0.125d0 * (I_ipq_ist - I_ipq_sit - I_ipq_tsi)
enddo ! i
enddo ! p
enddo ! q
enddo ! s
enddo ! t
!$OMP END DO
!$OMP END PARALLEL
! ----
! down-down & up-up part
sigma_p = -1.d0
sigma_s = -1.d0
sigma_q = +1.d0
sigma_t = +1.d0
!$OMP PARALLEL &
!$OMP DEFAULT (NONE) &
!$OMP PRIVATE (ii, i, sigma_i, p, q, s, t, &
!$OMP I_ipq_ist, I_ipq_sit, I_ipq_tsi) &
!$OMP SHARED (mo_num, elec_beta_num, elec_num, &
!$OMP sigma_p, sigma_q, sigma_s, sigma_t, &
!$OMP noL_2e_naive)
!$OMP DO COLLAPSE (4)
do t = 1, mo_num
do s = 1, mo_num
do q = 1, mo_num
do p = 1, mo_num
do ii = 1, elec_num
if(ii .le. elec_beta_num) then
i = ii
sigma_i = -1.d0
else
i = ii - elec_beta_num
sigma_i = +1.d0
endif
call give_integrals_3_body_bi_ort_spin( i, sigma_i, p, sigma_p, q, sigma_q &
, i, sigma_i, s, sigma_s, t, sigma_t &
, I_ipq_ist)
call give_integrals_3_body_bi_ort_spin( i, sigma_i, p, sigma_p, q, sigma_q &
, s, sigma_s, i, sigma_i, t, sigma_t &
, I_ipq_sit)
call give_integrals_3_body_bi_ort_spin( i, sigma_i, p, sigma_p, q, sigma_q &
, t, sigma_t, s, sigma_s, i, sigma_i &
, I_ipq_tsi)
! x 0.25 because we consider 0.25 (up-up + up-down + down-up + down-down)
noL_2e_naive(p,q,s,t) = noL_2e_naive(p,q,s,t) - 0.125d0 * (I_ipq_ist - I_ipq_sit - I_ipq_tsi)
enddo ! i
enddo ! p
enddo ! q
enddo ! s
enddo ! t
!$OMP END DO
!$OMP END PARALLEL
! ----
! down-down & down-down part
sigma_p = -1.d0
sigma_s = -1.d0
sigma_q = -1.d0
sigma_t = -1.d0
!$OMP PARALLEL &
!$OMP DEFAULT (NONE) &
!$OMP PRIVATE (ii, i, sigma_i, p, q, s, t, &
!$OMP I_ipq_ist, I_ipq_sit, I_ipq_tsi) &
!$OMP SHARED (mo_num, elec_beta_num, elec_num, &
!$OMP sigma_p, sigma_q, sigma_s, sigma_t, &
!$OMP noL_2e_naive)
!$OMP DO COLLAPSE (4)
do t = 1, mo_num
do s = 1, mo_num
do q = 1, mo_num
do p = 1, mo_num
do ii = 1, elec_num
if(ii .le. elec_beta_num) then
i = ii
sigma_i = -1.d0
else
i = ii - elec_beta_num
sigma_i = +1.d0
endif
call give_integrals_3_body_bi_ort_spin( i, sigma_i, p, sigma_p, q, sigma_q &
, i, sigma_i, s, sigma_s, t, sigma_t &
, I_ipq_ist)
call give_integrals_3_body_bi_ort_spin( i, sigma_i, p, sigma_p, q, sigma_q &
, s, sigma_s, i, sigma_i, t, sigma_t &
, I_ipq_sit)
call give_integrals_3_body_bi_ort_spin( i, sigma_i, p, sigma_p, q, sigma_q &
, t, sigma_t, s, sigma_s, i, sigma_i &
, I_ipq_tsi)
! x 0.25 because we consider 0.25 (up-up + up-down + down-up + down-down)
noL_2e_naive(p,q,s,t) = noL_2e_naive(p,q,s,t) - 0.125d0 * (I_ipq_ist - I_ipq_sit - I_ipq_tsi)
enddo ! i
enddo ! p
enddo ! q
enddo ! s
enddo ! t
!$OMP END DO
!$OMP END PARALLEL
call wall_time(t1)
print*, " Wall time for noL_2e_naive (min) = ", (t1 - t0)/60.d0
END_PROVIDER
! ---

46
src/bi_ort_ints/one_e_bi_ort.irp.f
View File

@ -6,27 +6,30 @@ BEGIN_PROVIDER [double precision, ao_one_e_integrals_tc_tot, (ao_num,ao_num)]
implicit none implicit none
integer :: i, j integer :: i, j
ao_one_e_integrals_tc_tot = ao_one_e_integrals ao_one_e_integrals_tc_tot = ao_one_e_integrals
provide j1b_type !provide j1b_type
if( (j1b_type .eq. 1) .or. (j1b_type .eq. 2) ) then !if( (j1b_type .eq. 1) .or. (j1b_type .eq. 2) ) then
!
! print *, ' do things properly !'
! stop
do i = 1, ao_num ! !do i = 1, ao_num
do j = 1, ao_num ! ! do j = 1, ao_num
ao_one_e_integrals_tc_tot(j,i) += ( j1b_gauss_hermI (j,i) & ! ! ao_one_e_integrals_tc_tot(j,i) += ( j1b_gauss_hermI (j,i) &
+ j1b_gauss_hermII (j,i) & ! ! + j1b_gauss_hermII (j,i) &
+ j1b_gauss_nonherm(j,i) ) ! ! + j1b_gauss_nonherm(j,i) )
enddo ! ! enddo
enddo ! !enddo
endif !endif
END_PROVIDER END_PROVIDER
! --- ! ---
BEGIN_PROVIDER [ double precision, mo_bi_ortho_tc_one_e, (mo_num, mo_num)] BEGIN_PROVIDER [double precision, mo_bi_ortho_tc_one_e, (mo_num, mo_num)]
BEGIN_DOC BEGIN_DOC
! !
@ -38,6 +41,11 @@ BEGIN_PROVIDER [ double precision, mo_bi_ortho_tc_one_e, (mo_num, mo_num)]
call ao_to_mo_bi_ortho(ao_one_e_integrals_tc_tot, ao_num, mo_bi_ortho_tc_one_e, mo_num) call ao_to_mo_bi_ortho(ao_one_e_integrals_tc_tot, ao_num, mo_bi_ortho_tc_one_e, mo_num)
if(noL_standard) then
PROVIDE noL_1e
mo_bi_ortho_tc_one_e = mo_bi_ortho_tc_one_e + noL_1e
endif
END_PROVIDER END_PROVIDER
! --- ! ---
@ -45,12 +53,14 @@ END_PROVIDER
BEGIN_PROVIDER [double precision, mo_bi_orth_bipole_x , (mo_num,mo_num)] BEGIN_PROVIDER [double precision, mo_bi_orth_bipole_x , (mo_num,mo_num)]
&BEGIN_PROVIDER [double precision, mo_bi_orth_bipole_y , (mo_num,mo_num)] &BEGIN_PROVIDER [double precision, mo_bi_orth_bipole_y , (mo_num,mo_num)]
&BEGIN_PROVIDER [double precision, mo_bi_orth_bipole_z , (mo_num,mo_num)] &BEGIN_PROVIDER [double precision, mo_bi_orth_bipole_z , (mo_num,mo_num)]
BEGIN_DOC
! array of the integrals of Left MO_i * x Right MO_j BEGIN_DOC
! array of the integrals of Left MO_i * y Right MO_j ! array of the integrals of Left MO_i * x Right MO_j
! array of the integrals of Left MO_i * z Right MO_j ! array of the integrals of Left MO_i * y Right MO_j
END_DOC ! array of the integrals of Left MO_i * z Right MO_j
implicit none END_DOC
implicit none
call ao_to_mo_bi_ortho( & call ao_to_mo_bi_ortho( &
ao_dipole_x, & ao_dipole_x, &

106
src/bi_ort_ints/semi_num_ints_mo.irp.f
View File

@ -54,7 +54,7 @@ BEGIN_PROVIDER [ double precision, mo_v_ki_bi_ortho_erf_rk_cst_mu_transp, (n_poi
enddo enddo
enddo enddo
! FREE mo_v_ki_bi_ortho_erf_rk_cst_mu !FREE mo_v_ki_bi_ortho_erf_rk_cst_mu
END_PROVIDER END_PROVIDER
@ -110,29 +110,41 @@ BEGIN_PROVIDER [ double precision, int2_grad1_u12_ao_transp, (ao_num, ao_num, 3,
print *, ' providing int2_grad1_u12_ao_transp ...' print *, ' providing int2_grad1_u12_ao_transp ...'
call wall_time(wall0) call wall_time(wall0)
if(test_cycle_tc)then if(test_cycle_tc) then
do ipoint = 1, n_points_final_grid
do i = 1, ao_num PROVIDE int2_grad1_u12_ao_test
do j = 1, ao_num
int2_grad1_u12_ao_transp(j,i,1,ipoint) = int2_grad1_u12_ao_test(j,i,ipoint,1) do ipoint = 1, n_points_final_grid
int2_grad1_u12_ao_transp(j,i,2,ipoint) = int2_grad1_u12_ao_test(j,i,ipoint,2) do i = 1, ao_num
int2_grad1_u12_ao_transp(j,i,3,ipoint) = int2_grad1_u12_ao_test(j,i,ipoint,3) do j = 1, ao_num
enddo int2_grad1_u12_ao_transp(j,i,1,ipoint) = int2_grad1_u12_ao_test(j,i,ipoint,1)
enddo int2_grad1_u12_ao_transp(j,i,2,ipoint) = int2_grad1_u12_ao_test(j,i,ipoint,2)
enddo int2_grad1_u12_ao_transp(j,i,3,ipoint) = int2_grad1_u12_ao_test(j,i,ipoint,3)
enddo
enddo
enddo
FREE int2_grad1_u12_ao_test
else else
do ipoint = 1, n_points_final_grid
do i = 1, ao_num PROVIDE int2_grad1_u12_ao
do j = 1, ao_num
int2_grad1_u12_ao_transp(j,i,1,ipoint) = int2_grad1_u12_ao(j,i,ipoint,1) do ipoint = 1, n_points_final_grid
int2_grad1_u12_ao_transp(j,i,2,ipoint) = int2_grad1_u12_ao(j,i,ipoint,2) do i = 1, ao_num
int2_grad1_u12_ao_transp(j,i,3,ipoint) = int2_grad1_u12_ao(j,i,ipoint,3) do j = 1, ao_num
enddo int2_grad1_u12_ao_transp(j,i,1,ipoint) = int2_grad1_u12_ao(j,i,ipoint,1)
enddo int2_grad1_u12_ao_transp(j,i,2,ipoint) = int2_grad1_u12_ao(j,i,ipoint,2)
enddo int2_grad1_u12_ao_transp(j,i,3,ipoint) = int2_grad1_u12_ao(j,i,ipoint,3)
enddo
enddo
enddo
endif endif
call wall_time(wall1) call wall_time(wall1)
print *, ' wall time for int2_grad1_u12_ao_transp ', wall1 - wall0 print *, ' wall time for int2_grad1_u12_ao_transp ', wall1 - wall0
call print_memory_usage()
END_PROVIDER END_PROVIDER
@ -141,12 +153,15 @@ END_PROVIDER
BEGIN_PROVIDER [ double precision, int2_grad1_u12_bimo_transp, (mo_num, mo_num, 3, n_points_final_grid)] BEGIN_PROVIDER [ double precision, int2_grad1_u12_bimo_transp, (mo_num, mo_num, 3, n_points_final_grid)]
implicit none implicit none
integer :: ipoint integer :: ipoint
double precision :: wall0, wall1 double precision :: wall0, wall1
!print *, ' providing int2_grad1_u12_bimo_transp' PROVIDE mo_l_coef mo_r_coef
PROVIDE int2_grad1_u12_ao_transp
!print *, ' providing int2_grad1_u12_bimo_transp'
!call wall_time(wall0)
call wall_time(wall0)
!$OMP PARALLEL & !$OMP PARALLEL &
!$OMP DEFAULT (NONE) & !$OMP DEFAULT (NONE) &
!$OMP PRIVATE (ipoint) & !$OMP PRIVATE (ipoint) &
@ -163,25 +178,42 @@ BEGIN_PROVIDER [ double precision, int2_grad1_u12_bimo_transp, (mo_num, mo_num,
!$OMP END DO !$OMP END DO
!$OMP END PARALLEL !$OMP END PARALLEL
call wall_time(wall1) !call wall_time(wall1)
!print *, ' Wall time for providing int2_grad1_u12_bimo_transp',wall1 - wall0 !print *, ' Wall time for providing int2_grad1_u12_bimo_transp',wall1 - wall0
!call print_memory_usage()
END_PROVIDER END_PROVIDER
! --- ! ---
BEGIN_PROVIDER [ double precision, int2_grad1_u12_bimo_t, (n_points_final_grid,3, mo_num, mo_num )] BEGIN_PROVIDER [ double precision, int2_grad1_u12_bimo_t, (n_points_final_grid, 3, mo_num, mo_num)]
implicit none
integer :: i, j, ipoint implicit none
do ipoint = 1, n_points_final_grid integer :: i, j, ipoint
do i = 1, mo_num double precision :: wall0, wall1
do j = 1, mo_num
int2_grad1_u12_bimo_t(ipoint,1,j,i) = int2_grad1_u12_bimo_transp(j,i,1,ipoint) !call wall_time(wall0)
int2_grad1_u12_bimo_t(ipoint,2,j,i) = int2_grad1_u12_bimo_transp(j,i,2,ipoint) !print *, ' Providing int2_grad1_u12_bimo_t ...'
int2_grad1_u12_bimo_t(ipoint,3,j,i) = int2_grad1_u12_bimo_transp(j,i,3,ipoint)
enddo PROVIDE mo_l_coef mo_r_coef
enddo PROVIDE int2_grad1_u12_bimo_transp
enddo
do ipoint = 1, n_points_final_grid
do i = 1, mo_num
do j = 1, mo_num
int2_grad1_u12_bimo_t(ipoint,1,j,i) = int2_grad1_u12_bimo_transp(j,i,1,ipoint)
int2_grad1_u12_bimo_t(ipoint,2,j,i) = int2_grad1_u12_bimo_transp(j,i,2,ipoint)
int2_grad1_u12_bimo_t(ipoint,3,j,i) = int2_grad1_u12_bimo_transp(j,i,3,ipoint)
enddo
enddo
enddo
FREE int2_grad1_u12_bimo_transp
!call wall_time(wall1)
!print *, ' wall time for int2_grad1_u12_bimo_t,', wall1 - wall0
!call print_memory_usage()
END_PROVIDER END_PROVIDER
! --- ! ---
@ -191,6 +223,8 @@ BEGIN_PROVIDER [ double precision, int2_grad1_u12_ao_t, (n_points_final_grid, 3,
implicit none implicit none
integer :: i, j, ipoint integer :: i, j, ipoint
PROVIDE int2_grad1_u12_ao
do ipoint = 1, n_points_final_grid do ipoint = 1, n_points_final_grid
do i = 1, ao_num do i = 1, ao_num
do j = 1, ao_num do j = 1, ao_num

40
src/bi_ort_ints/three_body_ijm.irp.f
View File

@ -17,17 +17,20 @@ BEGIN_PROVIDER [ double precision, three_e_3_idx_direct_bi_ort, (mo_num, mo_num,
integer :: i, j, m integer :: i, j, m
double precision :: integral, wall1, wall0 double precision :: integral, wall1, wall0
PROVIDE mo_l_coef mo_r_coef
provide mos_r_in_r_array_transp mos_l_in_r_array_transp
three_e_3_idx_direct_bi_ort = 0.d0 three_e_3_idx_direct_bi_ort = 0.d0
print *, ' Providing the three_e_3_idx_direct_bi_ort ...' print *, ' Providing the three_e_3_idx_direct_bi_ort ...'
call wall_time(wall0) call wall_time(wall0)
provide mos_r_in_r_array_transp mos_l_in_r_array_transp call give_integrals_3_body_bi_ort(1, 1, 1, 1, 1, 1, integral)
!$OMP PARALLEL & !$OMP PARALLEL &
!$OMP DEFAULT (NONE) & !$OMP DEFAULT (NONE) &
!$OMP PRIVATE (i,j,m,integral) & !$OMP PRIVATE (i,j,m,integral) &
!$OMP SHARED (mo_num,three_e_3_idx_direct_bi_ort) !$OMP SHARED (mo_num,three_e_3_idx_direct_bi_ort)
!$OMP DO SCHEDULE (dynamic) !$OMP DO SCHEDULE (dynamic)
do i = 1, mo_num do i = 1, mo_num
do j = 1, mo_num do j = 1, mo_num
do m = j, mo_num do m = j, mo_num
@ -36,8 +39,8 @@ BEGIN_PROVIDER [ double precision, three_e_3_idx_direct_bi_ort, (mo_num, mo_num,
enddo enddo
enddo enddo
enddo enddo
!$OMP END DO !$OMP END DO
!$OMP END PARALLEL !$OMP END PARALLEL
do i = 1, mo_num do i = 1, mo_num
do j = 1, mo_num do j = 1, mo_num
@ -49,6 +52,7 @@ BEGIN_PROVIDER [ double precision, three_e_3_idx_direct_bi_ort, (mo_num, mo_num,
call wall_time(wall1) call wall_time(wall1)
print *, ' wall time for three_e_3_idx_direct_bi_ort', wall1 - wall0 print *, ' wall time for three_e_3_idx_direct_bi_ort', wall1 - wall0
call print_memory_usage()
END_PROVIDER END_PROVIDER
@ -76,6 +80,7 @@ BEGIN_PROVIDER [ double precision, three_e_3_idx_cycle_1_bi_ort, (mo_num, mo_num
provide mos_r_in_r_array_transp mos_l_in_r_array_transp provide mos_r_in_r_array_transp mos_l_in_r_array_transp
call give_integrals_3_body_bi_ort(1, 1, 1, 1, 1, 1, integral)
!$OMP PARALLEL & !$OMP PARALLEL &
!$OMP DEFAULT (NONE) & !$OMP DEFAULT (NONE) &
!$OMP PRIVATE (i,j,m,integral) & !$OMP PRIVATE (i,j,m,integral) &
@ -102,6 +107,7 @@ BEGIN_PROVIDER [ double precision, three_e_3_idx_cycle_1_bi_ort, (mo_num, mo_num
call wall_time(wall1) call wall_time(wall1)
print *, ' wall time for three_e_3_idx_cycle_1_bi_ort', wall1 - wall0 print *, ' wall time for three_e_3_idx_cycle_1_bi_ort', wall1 - wall0
call print_memory_usage()
END_PROVIDER END_PROVIDER
@ -123,12 +129,15 @@ BEGIN_PROVIDER [ double precision, three_e_3_idx_cycle_2_bi_ort, (mo_num, mo_num
integer :: i, j, m integer :: i, j, m
double precision :: integral, wall1, wall0 double precision :: integral, wall1, wall0
PROVIDE mo_l_coef mo_r_coef
three_e_3_idx_cycle_2_bi_ort = 0.d0 three_e_3_idx_cycle_2_bi_ort = 0.d0
print *, ' Providing the three_e_3_idx_cycle_2_bi_ort ...' print *, ' Providing the three_e_3_idx_cycle_2_bi_ort ...'
call wall_time(wall0) call wall_time(wall0)
provide mos_r_in_r_array_transp mos_l_in_r_array_transp provide mos_r_in_r_array_transp mos_l_in_r_array_transp
call give_integrals_3_body_bi_ort(1, 1, 1, 1, 1, 1, integral)
!$OMP PARALLEL & !$OMP PARALLEL &
!$OMP DEFAULT (NONE) & !$OMP DEFAULT (NONE) &
!$OMP PRIVATE (i,j,m,integral) & !$OMP PRIVATE (i,j,m,integral) &
@ -155,6 +164,7 @@ BEGIN_PROVIDER [ double precision, three_e_3_idx_cycle_2_bi_ort, (mo_num, mo_num
call wall_time(wall1) call wall_time(wall1)
print *, ' wall time for three_e_3_idx_cycle_2_bi_ort', wall1 - wall0 print *, ' wall time for three_e_3_idx_cycle_2_bi_ort', wall1 - wall0
call print_memory_usage()
END_PROVIDER END_PROVIDER
@ -176,12 +186,15 @@ BEGIN_PROVIDER [ double precision, three_e_3_idx_exch23_bi_ort, (mo_num, mo_num,
integer :: i, j, m integer :: i, j, m
double precision :: integral, wall1, wall0 double precision :: integral, wall1, wall0
PROVIDE mo_l_coef mo_r_coef
three_e_3_idx_exch23_bi_ort = 0.d0 three_e_3_idx_exch23_bi_ort = 0.d0
print*,'Providing the three_e_3_idx_exch23_bi_ort ...' print*,'Providing the three_e_3_idx_exch23_bi_ort ...'
call wall_time(wall0) call wall_time(wall0)
provide mos_r_in_r_array_transp mos_l_in_r_array_transp provide mos_r_in_r_array_transp mos_l_in_r_array_transp
call give_integrals_3_body_bi_ort(1, 1, 1, 1, 1, 1, integral)
!$OMP PARALLEL & !$OMP PARALLEL &
!$OMP DEFAULT (NONE) & !$OMP DEFAULT (NONE) &
!$OMP PRIVATE (i,j,m,integral) & !$OMP PRIVATE (i,j,m,integral) &
@ -208,6 +221,7 @@ BEGIN_PROVIDER [ double precision, three_e_3_idx_exch23_bi_ort, (mo_num, mo_num,
call wall_time(wall1) call wall_time(wall1)
print *, ' wall time for three_e_3_idx_exch23_bi_ort', wall1 - wall0 print *, ' wall time for three_e_3_idx_exch23_bi_ort', wall1 - wall0
call print_memory_usage()
END_PROVIDER END_PROVIDER
@ -229,12 +243,15 @@ BEGIN_PROVIDER [ double precision, three_e_3_idx_exch13_bi_ort, (mo_num, mo_num,
integer :: i,j,m integer :: i,j,m
double precision :: integral, wall1, wall0 double precision :: integral, wall1, wall0
PROVIDE mo_l_coef mo_r_coef
three_e_3_idx_exch13_bi_ort = 0.d0 three_e_3_idx_exch13_bi_ort = 0.d0
print *, ' Providing the three_e_3_idx_exch13_bi_ort ...' print *, ' Providing the three_e_3_idx_exch13_bi_ort ...'
call wall_time(wall0) call wall_time(wall0)
provide mos_r_in_r_array_transp mos_l_in_r_array_transp provide mos_r_in_r_array_transp mos_l_in_r_array_transp
call give_integrals_3_body_bi_ort(1, 1, 1, 1, 1, 1, integral)
!$OMP PARALLEL & !$OMP PARALLEL &
!$OMP DEFAULT (NONE) & !$OMP DEFAULT (NONE) &
!$OMP PRIVATE (i,j,m,integral) & !$OMP PRIVATE (i,j,m,integral) &
@ -261,6 +278,7 @@ BEGIN_PROVIDER [ double precision, three_e_3_idx_exch13_bi_ort, (mo_num, mo_num,
call wall_time(wall1) call wall_time(wall1)
print *, ' wall time for three_e_3_idx_exch13_bi_ort', wall1 - wall0 print *, ' wall time for three_e_3_idx_exch13_bi_ort', wall1 - wall0
call print_memory_usage()
END_PROVIDER END_PROVIDER
@ -282,12 +300,15 @@ BEGIN_PROVIDER [ double precision, three_e_3_idx_exch12_bi_ort, (mo_num, mo_num,
integer :: i, j, m integer :: i, j, m
double precision :: integral, wall1, wall0 double precision :: integral, wall1, wall0
PROVIDE mo_l_coef mo_r_coef
three_e_3_idx_exch12_bi_ort = 0.d0 three_e_3_idx_exch12_bi_ort = 0.d0
print *, ' Providing the three_e_3_idx_exch12_bi_ort ...' print *, ' Providing the three_e_3_idx_exch12_bi_ort ...'
call wall_time(wall0) call wall_time(wall0)
provide mos_r_in_r_array_transp mos_l_in_r_array_transp provide mos_r_in_r_array_transp mos_l_in_r_array_transp
call give_integrals_3_body_bi_ort(1, 1, 1, 1, 1, 1, integral)
!$OMP PARALLEL & !$OMP PARALLEL &
!$OMP DEFAULT (NONE) & !$OMP DEFAULT (NONE) &
!$OMP PRIVATE (i,j,m,integral) & !$OMP PRIVATE (i,j,m,integral) &
@ -306,6 +327,7 @@ BEGIN_PROVIDER [ double precision, three_e_3_idx_exch12_bi_ort, (mo_num, mo_num,
call wall_time(wall1) call wall_time(wall1)
print *, ' wall time for three_e_3_idx_exch12_bi_ort', wall1 - wall0 print *, ' wall time for three_e_3_idx_exch12_bi_ort', wall1 - wall0
call print_memory_usage()
END_PROVIDER END_PROVIDER
@ -333,6 +355,7 @@ BEGIN_PROVIDER [ double precision, three_e_3_idx_exch12_bi_ort_new, (mo_num, mo_
provide mos_r_in_r_array_transp mos_l_in_r_array_transp provide mos_r_in_r_array_transp mos_l_in_r_array_transp
call give_integrals_3_body_bi_ort(1, 1, 1, 1, 1, 1, integral)
!$OMP PARALLEL & !$OMP PARALLEL &
!$OMP DEFAULT (NONE) & !$OMP DEFAULT (NONE) &
!$OMP PRIVATE (i,j,m,integral) & !$OMP PRIVATE (i,j,m,integral) &
@ -359,6 +382,7 @@ BEGIN_PROVIDER [ double precision, three_e_3_idx_exch12_bi_ort_new, (mo_num, mo_
call wall_time(wall1) call wall_time(wall1)
print *, ' wall time for three_e_3_idx_exch12_bi_ort_new', wall1 - wall0 print *, ' wall time for three_e_3_idx_exch12_bi_ort_new', wall1 - wall0
call print_memory_usage()
END_PROVIDER END_PROVIDER

451
src/bi_ort_ints/three_body_ijmk.irp.f
View File

@ -1,284 +1,231 @@
! --- ! ---
BEGIN_PROVIDER [ double precision, three_e_4_idx_direct_bi_ort, (mo_num, mo_num, mo_num, mo_num)] BEGIN_PROVIDER [ double precision, three_e_4_idx_direct_bi_ort , (mo_num, mo_num, mo_num, mo_num)]
&BEGIN_PROVIDER [ double precision, three_e_4_idx_exch13_bi_ort , (mo_num, mo_num, mo_num, mo_num)]
&BEGIN_PROVIDER [ double precision, three_e_4_idx_exch23_bi_ort , (mo_num, mo_num, mo_num, mo_num)]
&BEGIN_PROVIDER [ double precision, three_e_4_idx_cycle_1_bi_ort, (mo_num, mo_num, mo_num, mo_num)]
BEGIN_DOC BEGIN_DOC
! !
! matrix element of the -L three-body operator FOR THE DIRECT TERMS OF SINGLE EXCITATIONS AND BI ORTHO MOs ! matrix element of the -L three-body operator FOR THE DIRECT TERMS OF SINGLE EXCITATIONS AND BI ORTHO MOs
! !
! three_e_4_idx_direct_bi_ort(m,j,k,i) = <mjk|-L|mji> ::: notice that i is the RIGHT MO and k is the LEFT MO ! three_e_4_idx_direct_bi_ort (m,j,k,i) = < m j k | -L | m j i > ::: notice that i is the RIGHT MO and k is the LEFT MO
! three_e_4_idx_exch13_bi_ort (m,j,k,i) = < m j k | -L | i j m > ::: notice that i is the RIGHT MO and k is the LEFT MO
! three_e_4_idx_exch23_bi_ort (m,j,k,i) = < m j k | -L | j m i > ::: notice that i is the RIGHT MO and k is the LEFT MO
! three_e_4_idx_cycle_1_bi_ort(m,j,k,i) = < m j k | -L | j i m > ::: 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 ! notice the -1 sign: in this way three_e_4_idx_direct_bi_ort can be directly used to compute Slater rules with a + sign
! !
END_DOC ! three_e_4_idx_direct_bi_ort (m,j,k,i) : Lk Ri Imm Ijj + Lj Rj Imm Iki + Lm Rm Ijj Iki
! three_e_4_idx_exch13_bi_ort (m,j,k,i) : Lk Rm Imi Ijj + Lj Rj Imi Ikm + Lm Ri Ijj Ikm
implicit none ! three_e_4_idx_exch23_bi_ort (m,j,k,i) : Lk Ri Imj Ijm + Lj Rm Imj Iki + Lm Rj Ijm Iki
integer :: i, j, k, m ! three_e_4_idx_cycle_1_bi_ort(m,j,k,i) : Lk Rm Imj Iji + Lj Ri Imj Ikm + Lm Rj Iji Ikm
double precision :: integral, wall1, wall0
three_e_4_idx_direct_bi_ort = 0.d0
print *, ' Providing the three_e_4_idx_direct_bi_ort ...'
call wall_time(wall0)
provide mos_r_in_r_array_transp mos_l_in_r_array_transp
!$OMP PARALLEL &
!$OMP DEFAULT (NONE) &
!$OMP PRIVATE (i,j,k,m,integral) &
!$OMP SHARED (mo_num,three_e_4_idx_direct_bi_ort)
!$OMP DO SCHEDULE (dynamic) COLLAPSE(2)
do i = 1, mo_num
do k = 1, mo_num
do j = 1, mo_num
do m = 1, mo_num
call give_integrals_3_body_bi_ort(m, j, k, m, j, i, integral)
three_e_4_idx_direct_bi_ort(m,j,k,i) = -1.d0 * integral
enddo
enddo
enddo
enddo
!$OMP END DO
!$OMP END PARALLEL
call wall_time(wall1)
print *, ' wall time for three_e_4_idx_direct_bi_ort', wall1 - wall0
END_PROVIDER
! ---
BEGIN_PROVIDER [ double precision, three_e_4_idx_cycle_1_bi_ort, (mo_num, mo_num, mo_num, mo_num)]
BEGIN_DOC
!
! matrix element of the -L three-body operator FOR THE FIRST CYCLIC PERMUTATION TERMS OF SINGLE EXCITATIONS AND BI ORTHO MOs
!
! three_e_4_idx_cycle_1_bi_ort(m,j,k,i) = <mjk|-L|jim> ::: 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 END_DOC
implicit none implicit none
integer :: i, j, k, m integer :: ipoint, i, j, k, m, n
double precision :: integral, wall1, wall0 double precision :: wall1, wall0
double precision :: tmp_loc_1, tmp_loc_2
double precision, allocatable :: tmp1(:,:,:), tmp2(:,:,:)
double precision, allocatable :: tmp_2d(:,:)
double precision, allocatable :: tmp_aux_1(:,:,:), tmp_aux_2(:,:)
three_e_4_idx_cycle_1_bi_ort = 0.d0 print *, ' Providing the three_e_4_idx_bi_ort ...'
print *, ' Providing the three_e_4_idx_cycle_1_bi_ort ...'
call wall_time(wall0) call wall_time(wall0)
provide mos_r_in_r_array_transp mos_l_in_r_array_transp provide mos_r_in_r_array_transp mos_l_in_r_array_transp
!$OMP PARALLEL &
!$OMP DEFAULT (NONE) &
!$OMP PRIVATE (i,j,k,m,integral) &
!$OMP SHARED (mo_num,three_e_4_idx_cycle_1_bi_ort)
!$OMP DO SCHEDULE (dynamic) COLLAPSE(2)
do i = 1, mo_num
do k = 1, mo_num
do j = 1, mo_num
do m = 1, mo_num
call give_integrals_3_body_bi_ort(m, j, k, j, i, m, integral)
three_e_4_idx_cycle_1_bi_ort(m,j,k,i) = -1.d0 * integral
enddo
enddo
enddo
enddo
!$OMP END DO
!$OMP END PARALLEL
call wall_time(wall1) ! to reduce the number of operations
print *, ' wall time for three_e_4_idx_cycle_1_bi_ort', wall1 - wall0 allocate(tmp_aux_1(n_points_final_grid,4,mo_num))
allocate(tmp_aux_2(n_points_final_grid,mo_num))
END_PROVIDER !$OMP PARALLEL &
!$OMP DEFAULT (NONE) &
!$OMP PRIVATE (n, ipoint) &
!$OMP SHARED (mo_num, n_points_final_grid, &
!$OMP mos_l_in_r_array_transp, mos_r_in_r_array_transp, &
!$OMP int2_grad1_u12_bimo_t, final_weight_at_r_vector, &
!$OMP tmp_aux_1, tmp_aux_2)
!$OMP DO
do n = 1, mo_num
do ipoint = 1, n_points_final_grid
! -- tmp_aux_1(ipoint,1,n) = int2_grad1_u12_bimo_t(ipoint,1,n,n) * final_weight_at_r_vector(ipoint)
tmp_aux_1(ipoint,2,n) = int2_grad1_u12_bimo_t(ipoint,2,n,n) * final_weight_at_r_vector(ipoint)
tmp_aux_1(ipoint,3,n) = int2_grad1_u12_bimo_t(ipoint,3,n,n) * final_weight_at_r_vector(ipoint)
tmp_aux_1(ipoint,4,n) = mos_l_in_r_array_transp(ipoint,n) * mos_r_in_r_array_transp(ipoint,n) * final_weight_at_r_vector(ipoint)
BEGIN_PROVIDER [ double precision, three_e_4_idx_cycle_2_bi_ort, (mo_num, mo_num, mo_num, mo_num)] tmp_aux_2(ipoint,n) = mos_l_in_r_array_transp(ipoint,n) * mos_r_in_r_array_transp(ipoint,n)
BEGIN_DOC
!
! matrix element of the -L three-body operator FOR THE FIRST CYCLIC PERMUTATION TERMS OF SINGLE EXCITATIONS AND BI ORTHO MOs
!
! three_e_4_idx_cycle_2_bi_ort(m,j,k,i) = <mjk|-L|imj> ::: 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
double precision :: integral, wall1, wall0
three_e_4_idx_cycle_2_bi_ort = 0.d0
print *, ' Providing the three_e_4_idx_cycle_2_bi_ort ...'
call wall_time(wall0)
provide mos_r_in_r_array_transp mos_l_in_r_array_transp
!$OMP PARALLEL &
!$OMP DEFAULT (NONE) &
!$OMP PRIVATE (i,j,k,m,integral) &
!$OMP SHARED (mo_num,three_e_4_idx_cycle_2_bi_ort)
!$OMP DO SCHEDULE (dynamic) COLLAPSE(2)
do i = 1, mo_num
do k = 1, mo_num
do j = 1, mo_num
do m = 1, mo_num
call give_integrals_3_body_bi_ort(m, j, k, i, m, j, integral)
three_e_4_idx_cycle_2_bi_ort(m,j,k,i) = -1.d0 * integral
enddo
enddo
enddo
enddo
!$OMP END DO
!$OMP END PARALLEL
call wall_time(wall1)
print *, ' wall time for three_e_4_idx_cycle_2_bi_ort', wall1 - wall0
END_PROVIDER
! ---
BEGIN_PROVIDER [ double precision, three_e_4_idx_exch23_bi_ort, (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_4_idx_exch23_bi_ort(m,j,k,i) = <mjk|-L|jmi> ::: 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
double precision :: integral, wall1, wall0
three_e_4_idx_exch23_bi_ort = 0.d0
print *, ' Providing the three_e_4_idx_exch23_bi_ort ...'
call wall_time(wall0)
provide mos_r_in_r_array_transp mos_l_in_r_array_transp
!$OMP PARALLEL &
!$OMP DEFAULT (NONE) &
!$OMP PRIVATE (i,j,k,m,integral) &
!$OMP SHARED (mo_num,three_e_4_idx_exch23_bi_ort)
!$OMP DO SCHEDULE (dynamic) COLLAPSE(2)
do i = 1, mo_num
do k = 1, mo_num
do j = 1, mo_num
do m = 1, mo_num
call give_integrals_3_body_bi_ort(m, j, k, j, m, i, integral)
three_e_4_idx_exch23_bi_ort(m,j,k,i) = -1.d0 * integral
enddo
enddo
enddo
enddo
!$OMP END DO
!$OMP END PARALLEL
call wall_time(wall1)
print *, ' wall time for three_e_4_idx_exch23_bi_ort', wall1 - wall0
END_PROVIDER
! ---
BEGIN_PROVIDER [ double precision, three_e_4_idx_exch13_bi_ort, (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_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
implicit none
integer :: i, j, k, m
double precision :: integral, wall1, wall0
three_e_4_idx_exch13_bi_ort = 0.d0
print *, ' Providing the three_e_4_idx_exch13_bi_ort ...'
call wall_time(wall0)
provide mos_r_in_r_array_transp mos_l_in_r_array_transp
!$OMP PARALLEL &
!$OMP DEFAULT (NONE) &
!$OMP PRIVATE (i,j,k,m,integral) &
!$OMP SHARED (mo_num,three_e_4_idx_exch13_bi_ort)
!$OMP DO SCHEDULE (dynamic) COLLAPSE(2)
do i = 1, mo_num
do k = 1, mo_num
do j = 1, mo_num
do m = 1, mo_num
call give_integrals_3_body_bi_ort(m, j, k, i, j, m, integral)
three_e_4_idx_exch13_bi_ort(m,j,k,i) = -1.d0 * integral
enddo
enddo
enddo
enddo
!$OMP END DO
!$OMP END PARALLEL
call wall_time(wall1)
print *, ' wall time for three_e_4_idx_exch13_bi_ort', wall1 - wall0
END_PROVIDER
! ---
BEGIN_PROVIDER [ double precision, three_e_4_idx_exch12_bi_ort, (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_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
!
END_DOC
implicit none
integer :: i, j, k, m
double precision :: integral, wall1, wall0
three_e_4_idx_exch12_bi_ort = 0.d0
print *, ' Providing the three_e_4_idx_exch12_bi_ort ...'
call wall_time(wall0)
provide mos_r_in_r_array_transp mos_l_in_r_array_transp
!$OMP PARALLEL &
!$OMP DEFAULT (NONE) &
!$OMP PRIVATE (i,j,k,m,integral) &
!$OMP SHARED (mo_num,three_e_4_idx_exch12_bi_ort)
!$OMP DO SCHEDULE (dynamic) COLLAPSE(2)
do i = 1, mo_num
do k = 1, mo_num
do j = 1, mo_num
do m = 1, mo_num
call give_integrals_3_body_bi_ort(m, j, k, m, i, j, integral)
three_e_4_idx_exch12_bi_ort(m,j,k,i) = -1.d0 * integral
enddo
enddo
enddo enddo
enddo enddo
!$OMP END DO !$OMP END DO
!$OMP END PARALLEL !$OMP END PARALLEL
call wall_time(wall1)
print *, ' wall time for three_e_4_idx_exch12_bi_ort', wall1 - wall0
END_PROVIDER
! loops approach to break the O(N^4) scaling in memory
call set_multiple_levels_omp(.false.)
!$OMP PARALLEL &
!$OMP DEFAULT (NONE) &
!$OMP PRIVATE (k, i, j, m, n, ipoint, tmp_loc_1, tmp_loc_2, tmp_2d, tmp1, tmp2) &
!$OMP SHARED (mo_num, n_points_final_grid, &
!$OMP mos_l_in_r_array_transp, mos_r_in_r_array_transp, &
!$OMP int2_grad1_u12_bimo_t, final_weight_at_r_vector, &
!$OMP tmp_aux_1, tmp_aux_2, &
!$OMP three_e_4_idx_direct_bi_ort, three_e_4_idx_exch13_bi_ort, &
!$OMP three_e_4_idx_exch23_bi_ort, three_e_4_idx_cycle_1_bi_ort)
allocate(tmp_2d(mo_num,mo_num))
allocate(tmp1(n_points_final_grid,4,mo_num))
allocate(tmp2(n_points_final_grid,4,mo_num))
!$OMP DO
do k = 1, mo_num
! ---
do i = 1, mo_num
! ---
do n = 1, mo_num
do ipoint = 1, n_points_final_grid
tmp_loc_1 = mos_l_in_r_array_transp(ipoint,k) * mos_r_in_r_array_transp(ipoint,i)
tmp_loc_2 = tmp_aux_2(ipoint,n)
tmp1(ipoint,1,n) = int2_grad1_u12_bimo_t(ipoint,1,n,n) * tmp_loc_1 + int2_grad1_u12_bimo_t(ipoint,1,k,i) * tmp_loc_2
tmp1(ipoint,2,n) = int2_grad1_u12_bimo_t(ipoint,2,n,n) * tmp_loc_1 + int2_grad1_u12_bimo_t(ipoint,2,k,i) * tmp_loc_2
tmp1(ipoint,3,n) = int2_grad1_u12_bimo_t(ipoint,3,n,n) * tmp_loc_1 + int2_grad1_u12_bimo_t(ipoint,3,k,i) * tmp_loc_2
tmp1(ipoint,4,n) = int2_grad1_u12_bimo_t(ipoint,1,n,n) * int2_grad1_u12_bimo_t(ipoint,1,k,i) &
+ int2_grad1_u12_bimo_t(ipoint,2,n,n) * int2_grad1_u12_bimo_t(ipoint,2,k,i) &
+ int2_grad1_u12_bimo_t(ipoint,3,n,n) * int2_grad1_u12_bimo_t(ipoint,3,k,i)
enddo
enddo
call dgemm( 'T', 'N', mo_num, mo_num, 4*n_points_final_grid, 1.d0 &
, tmp_aux_1(1,1,1), 4*n_points_final_grid, tmp1(1,1,1), 4*n_points_final_grid &
, 0.d0, tmp_2d(1,1), mo_num)
do j = 1, mo_num
do m = 1, mo_num
three_e_4_idx_direct_bi_ort(m,j,k,i) = -tmp_2d(m,j)
enddo
enddo
! ---
do n = 1, mo_num
do ipoint = 1, n_points_final_grid
tmp_loc_1 = mos_l_in_r_array_transp(ipoint,k) * mos_r_in_r_array_transp(ipoint,n)
tmp_loc_2 = mos_l_in_r_array_transp(ipoint,n) * mos_r_in_r_array_transp(ipoint,i)
tmp1(ipoint,1,n) = int2_grad1_u12_bimo_t(ipoint,1,n,i) * tmp_loc_1 + int2_grad1_u12_bimo_t(ipoint,1,k,n) * tmp_loc_2
tmp1(ipoint,2,n) = int2_grad1_u12_bimo_t(ipoint,2,n,i) * tmp_loc_1 + int2_grad1_u12_bimo_t(ipoint,2,k,n) * tmp_loc_2
tmp1(ipoint,3,n) = int2_grad1_u12_bimo_t(ipoint,3,n,i) * tmp_loc_1 + int2_grad1_u12_bimo_t(ipoint,3,k,n) * tmp_loc_2
tmp1(ipoint,4,n) = int2_grad1_u12_bimo_t(ipoint,1,n,i) * int2_grad1_u12_bimo_t(ipoint,1,k,n) &
+ int2_grad1_u12_bimo_t(ipoint,2,n,i) * int2_grad1_u12_bimo_t(ipoint,2,k,n) &
+ int2_grad1_u12_bimo_t(ipoint,3,n,i) * int2_grad1_u12_bimo_t(ipoint,3,k,n)
tmp2(ipoint,1,n) = final_weight_at_r_vector(ipoint) * int2_grad1_u12_bimo_t(ipoint,1,i,n)
tmp2(ipoint,2,n) = final_weight_at_r_vector(ipoint) * int2_grad1_u12_bimo_t(ipoint,2,i,n)
tmp2(ipoint,3,n) = final_weight_at_r_vector(ipoint) * int2_grad1_u12_bimo_t(ipoint,3,i,n)
tmp2(ipoint,4,n) = final_weight_at_r_vector(ipoint) * mos_l_in_r_array_transp(ipoint,i) * mos_r_in_r_array_transp(ipoint,n)
enddo
enddo
! ---
call dgemm( 'T', 'N', mo_num, mo_num, 4*n_points_final_grid, 1.d0 &
, tmp1(1,1,1), 4*n_points_final_grid, tmp_aux_1(1,1,1), 4*n_points_final_grid &
, 0.d0, tmp_2d(1,1), mo_num)
do j = 1, mo_num
do m = 1, mo_num
three_e_4_idx_exch13_bi_ort(m,j,k,i) = -tmp_2d(m,j)
enddo
enddo
! ---
call dgemm( 'T', 'N', mo_num, mo_num, 4*n_points_final_grid, 1.d0 &
, tmp1(1,1,1), 4*n_points_final_grid, tmp2(1,1,1), 4*n_points_final_grid &
, 0.d0, tmp_2d(1,1), mo_num)
do j = 1, mo_num
do m = 1, mo_num
three_e_4_idx_cycle_1_bi_ort(m,i,k,j) = -tmp_2d(m,j)
enddo
enddo
! ---
enddo ! i
! ---
do j = 1, mo_num
do n = 1, mo_num
do ipoint = 1, n_points_final_grid
tmp_loc_1 = final_weight_at_r_vector(ipoint) * mos_l_in_r_array_transp(ipoint,j) * mos_r_in_r_array_transp(ipoint,n)
tmp_loc_2 = final_weight_at_r_vector(ipoint) * mos_l_in_r_array_transp(ipoint,n) * mos_r_in_r_array_transp(ipoint,j)
tmp1(ipoint,1,n) = int2_grad1_u12_bimo_t(ipoint,1,n,j) * tmp_loc_1 + int2_grad1_u12_bimo_t(ipoint,1,j,n) * tmp_loc_2
tmp1(ipoint,2,n) = int2_grad1_u12_bimo_t(ipoint,2,n,j) * tmp_loc_1 + int2_grad1_u12_bimo_t(ipoint,2,j,n) * tmp_loc_2
tmp1(ipoint,3,n) = int2_grad1_u12_bimo_t(ipoint,3,n,j) * tmp_loc_1 + int2_grad1_u12_bimo_t(ipoint,3,j,n) * tmp_loc_2
tmp1(ipoint,4,n) = int2_grad1_u12_bimo_t(ipoint,1,n,j) * int2_grad1_u12_bimo_t(ipoint,1,j,n) &
+ int2_grad1_u12_bimo_t(ipoint,2,n,j) * int2_grad1_u12_bimo_t(ipoint,2,j,n) &
+ int2_grad1_u12_bimo_t(ipoint,3,n,j) * int2_grad1_u12_bimo_t(ipoint,3,j,n)
tmp2(ipoint,1,n) = int2_grad1_u12_bimo_t(ipoint,1,k,n)
tmp2(ipoint,2,n) = int2_grad1_u12_bimo_t(ipoint,2,k,n)
tmp2(ipoint,3,n) = int2_grad1_u12_bimo_t(ipoint,3,k,n)
tmp2(ipoint,4,n) = final_weight_at_r_vector(ipoint) * mos_l_in_r_array_transp(ipoint,k) * mos_r_in_r_array_transp(ipoint,n)
enddo
enddo
call dgemm( 'T', 'N', mo_num, mo_num, 4*n_points_final_grid, 1.d0 &
, tmp1(1,1,1), 4*n_points_final_grid, tmp2(1,1,1), 4*n_points_final_grid &
, 0.d0, tmp_2d(1,1), mo_num)
do i = 1, mo_num
do m = 1, mo_num
three_e_4_idx_exch23_bi_ort(m,j,k,i) = -tmp_2d(m,i)
enddo
enddo
enddo ! j
! ---
enddo !k
!$OMP END DO
deallocate(tmp_2d)
deallocate(tmp1)
deallocate(tmp2)
!$OMP END PARALLEL
deallocate(tmp_aux_1)
deallocate(tmp_aux_2)
call wall_time(wall1)
print *, ' wall time for three_e_4_idx_bi_ort', wall1 - wall0
call print_memory_usage()
END_PROVIDER
! --- ! ---

486
src/bi_ort_ints/three_body_ijmk_n4.irp.f Normal file
View File

@ -0,0 +1,486 @@
! ---
BEGIN_PROVIDER [ double precision, three_e_4_idx_direct_bi_ort_n4 , (mo_num, mo_num, mo_num, mo_num)]
&BEGIN_PROVIDER [ double precision, three_e_4_idx_exch13_bi_ort_n4 , (mo_num, mo_num, mo_num, mo_num)]
&BEGIN_PROVIDER [ double precision, three_e_4_idx_cycle_1_bi_ort_n4, (mo_num, mo_num, mo_num, mo_num)]
!&BEGIN_PROVIDER [ double precision, three_e_4_idx_exch12_bi_ort_n4, (mo_num, mo_num, mo_num, mo_num)]
!&BEGIN_PROVIDER [ double precision, three_e_4_idx_cycle_2_bi_ort_n4, (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_4_idx_direct_bi_ort_n4 (m,j,k,i) = < m j k | -L | m j i > ::: notice that i is the RIGHT MO and k is the LEFT MO
! three_e_4_idx_exch13_bi_ort_n4 (m,j,k,i) = < m j k | -L | i j m > ::: notice that i is the RIGHT MO and k is the LEFT MO
! three_e_4_idx_exch12_bi_ort_n4 (m,j,k,i) = < m j k | -L | m i j > ::: notice that i is the RIGHT MO and k is the LEFT MO
! = three_e_4_idx_exch13_bi_ort_n4 (j,m,k,i)
! three_e_4_idx_cycle_1_bi_ort_n4(m,j,k,i) = < m j k | -L | j i m > ::: notice that i is the RIGHT MO and k is the LEFT MO
! three_e_4_idx_cycle_2_bi_ort_n4(m,j,k,i) = < m j k | -L | i m j > ::: notice that i is the RIGHT MO and k is the LEFT MO
! = three_e_4_idx_cycle_1_bi_ort_n4(j,m,k,i)
!
! notice the -1 sign: in this way three_e_4_idx_direct_bi_ort_n4 can be directly used to compute Slater rules with a + sign
!
! three_e_4_idx_direct_bi_ort_n4 (m,j,k,i) : Lk Ri Imm Ijj + Lj Rj Imm Iki + Lm Rm Ijj Iki
! three_e_4_idx_exch13_bi_ort_n4 (m,j,k,i) : Lk Rm Imi Ijj + Lj Rj Imi Ikm + Lm Ri Ijj Ikm
! three_e_4_idx_cycle_1_bi_ort_n4(m,j,k,i) : Lk Rm Imj Iji + Lj Ri Imj Ikm + Lm Rj Iji Ikm
!
END_DOC
implicit none
integer :: ipoint, i, j, k, l, m
double precision :: wall1, wall0
double precision, allocatable :: tmp1(:,:,:,:), tmp2(:,:,:,:), tmp3(:,:,:,:)
double precision, allocatable :: tmp_4d(:,:,:,:)
double precision, allocatable :: tmp4(:,:,:)
double precision, allocatable :: tmp5(:,:)
double precision, allocatable :: tmp_3d(:,:,:)
print *, ' Providing the O(N^4) three_e_4_idx_bi_ort ...'
call wall_time(wall0)
provide mos_r_in_r_array_transp mos_l_in_r_array_transp
allocate(tmp_4d(mo_num,mo_num,mo_num,mo_num))
allocate(tmp1(n_points_final_grid,3,mo_num,mo_num))
allocate(tmp2(n_points_final_grid,3,mo_num,mo_num))
allocate(tmp3(n_points_final_grid,3,mo_num,mo_num))
!$OMP PARALLEL &
!$OMP DEFAULT (NONE) &
!$OMP PRIVATE (i, l, ipoint) &
!$OMP SHARED (mo_num, n_points_final_grid, &
!$OMP mos_l_in_r_array_transp, mos_r_in_r_array_transp, &
!$OMP int2_grad1_u12_bimo_t, final_weight_at_r_vector, &
!$OMP tmp1, tmp2, tmp3)
!$OMP DO COLLAPSE(2)
do i = 1, mo_num
do l = 1, mo_num
do ipoint = 1, n_points_final_grid
tmp1(ipoint,1,l,i) = int2_grad1_u12_bimo_t(ipoint,1,l,l) * mos_l_in_r_array_transp(ipoint,i) * final_weight_at_r_vector(ipoint)
tmp1(ipoint,2,l,i) = int2_grad1_u12_bimo_t(ipoint,2,l,l) * mos_l_in_r_array_transp(ipoint,i) * final_weight_at_r_vector(ipoint)
tmp1(ipoint,3,l,i) = int2_grad1_u12_bimo_t(ipoint,3,l,l) * mos_l_in_r_array_transp(ipoint,i) * final_weight_at_r_vector(ipoint)
tmp2(ipoint,1,l,i) = int2_grad1_u12_bimo_t(ipoint,1,l,l) * mos_r_in_r_array_transp(ipoint,i)
tmp2(ipoint,2,l,i) = int2_grad1_u12_bimo_t(ipoint,2,l,l) * mos_r_in_r_array_transp(ipoint,i)
tmp2(ipoint,3,l,i) = int2_grad1_u12_bimo_t(ipoint,3,l,l) * mos_r_in_r_array_transp(ipoint,i)
tmp3(ipoint,1,l,i) = int2_grad1_u12_bimo_t(ipoint,1,l,i) * mos_r_in_r_array_transp(ipoint,l)
tmp3(ipoint,2,l,i) = int2_grad1_u12_bimo_t(ipoint,2,l,i) * mos_r_in_r_array_transp(ipoint,l)
tmp3(ipoint,3,l,i) = int2_grad1_u12_bimo_t(ipoint,3,l,i) * mos_r_in_r_array_transp(ipoint,l)
enddo
enddo
enddo
!$OMP END DO
!$OMP END PARALLEL
call dgemm( 'T', 'N', mo_num*mo_num, mo_num*mo_num, 3*n_points_final_grid, 1.d0 &
, tmp1(1,1,1,1), 3*n_points_final_grid, tmp2(1,1,1,1), 3*n_points_final_grid &
, 0.d0, tmp_4d(1,1,1,1), mo_num*mo_num)
!$OMP PARALLEL DO PRIVATE(i,j,k,m)
do i = 1, mo_num
do k = 1, mo_num
do j = 1, mo_num
do m = 1, mo_num
three_e_4_idx_direct_bi_ort_n4(m,j,k,i) = -tmp_4d(m,k,j,i)
enddo
enddo
enddo
enddo
!$OMP END PARALLEL DO
call dgemm( 'T', 'N', mo_num*mo_num, mo_num*mo_num, 3*n_points_final_grid, 1.d0 &
, tmp3(1,1,1,1), 3*n_points_final_grid, tmp1(1,1,1,1), 3*n_points_final_grid &
, 0.d0, tmp_4d(1,1,1,1), mo_num*mo_num)
!$OMP PARALLEL DO PRIVATE(i,j,k,m)
do i = 1, mo_num
do k = 1, mo_num
do j = 1, mo_num
do m = 1, mo_num
three_e_4_idx_exch13_bi_ort_n4(m,j,k,i) = -tmp_4d(m,i,j,k)
enddo
enddo
enddo
enddo
!$OMP END PARALLEL DO
!$OMP PARALLEL &
!$OMP DEFAULT (NONE) &
!$OMP PRIVATE (i, l, ipoint) &
!$OMP SHARED (mo_num, n_points_final_grid, &
!$OMP mos_l_in_r_array_transp, mos_r_in_r_array_transp, &
!$OMP int2_grad1_u12_bimo_t, final_weight_at_r_vector, &
!$OMP tmp1)
!$OMP DO COLLAPSE(2)
do i = 1, mo_num
do l = 1, mo_num
do ipoint = 1, n_points_final_grid
tmp1(ipoint,1,l,i) = int2_grad1_u12_bimo_t(ipoint,1,i,l) * mos_l_in_r_array_transp(ipoint,l) * final_weight_at_r_vector(ipoint)
tmp1(ipoint,2,l,i) = int2_grad1_u12_bimo_t(ipoint,2,i,l) * mos_l_in_r_array_transp(ipoint,l) * final_weight_at_r_vector(ipoint)
tmp1(ipoint,3,l,i) = int2_grad1_u12_bimo_t(ipoint,3,i,l) * mos_l_in_r_array_transp(ipoint,l) * final_weight_at_r_vector(ipoint)
enddo
enddo
enddo
!$OMP END DO
!$OMP END PARALLEL
call dgemm( 'T', 'N', mo_num*mo_num, mo_num*mo_num, 3*n_points_final_grid, 1.d0 &
, tmp1(1,1,1,1), 3*n_points_final_grid, tmp2(1,1,1,1), 3*n_points_final_grid &
, 0.d0, tmp_4d(1,1,1,1), mo_num*mo_num)
deallocate(tmp2)
!$OMP PARALLEL DO PRIVATE(i,j,k,m)
do i = 1, mo_num
do k = 1, mo_num
do j = 1, mo_num
do m = 1, mo_num
three_e_4_idx_exch13_bi_ort_n4(m,j,k,i) = three_e_4_idx_exch13_bi_ort_n4(m,j,k,i) - tmp_4d(m,k,j,i)
enddo
enddo
enddo
enddo
!$OMP END PARALLEL DO
call dgemm( 'T', 'N', mo_num*mo_num, mo_num*mo_num, 3*n_points_final_grid, 1.d0 &
, tmp1(1,1,1,1), 3*n_points_final_grid, tmp3(1,1,1,1), 3*n_points_final_grid &
, 0.d0, tmp_4d(1,1,1,1), mo_num*mo_num)
deallocate(tmp3)
!$OMP PARALLEL DO PRIVATE(i,j,k,m)
do i = 1, mo_num
do k = 1, mo_num
do j = 1, mo_num
do m = 1, mo_num
three_e_4_idx_cycle_1_bi_ort_n4(m,j,k,i) = -tmp_4d(m,k,j,i)
enddo
enddo
enddo
enddo
!$OMP END PARALLEL DO
!$OMP PARALLEL &
!$OMP DEFAULT (NONE) &
!$OMP PRIVATE (i, l, ipoint) &
!$OMP SHARED (mo_num, n_points_final_grid, &
!$OMP mos_l_in_r_array_transp, mos_r_in_r_array_transp, &
!$OMP int2_grad1_u12_bimo_t, final_weight_at_r_vector, &
!$OMP tmp1)
!$OMP DO COLLAPSE(2)
do i = 1, mo_num
do l = 1, mo_num
do ipoint = 1, n_points_final_grid
tmp1(ipoint,1,l,i) = final_weight_at_r_vector(ipoint) * int2_grad1_u12_bimo_t(ipoint,1,l,l) * mos_l_in_r_array_transp(ipoint,i) * mos_r_in_r_array_transp(ipoint,i)
tmp1(ipoint,2,l,i) = final_weight_at_r_vector(ipoint) * int2_grad1_u12_bimo_t(ipoint,2,l,l) * mos_l_in_r_array_transp(ipoint,i) * mos_r_in_r_array_transp(ipoint,i)
tmp1(ipoint,3,l,i) = final_weight_at_r_vector(ipoint) * int2_grad1_u12_bimo_t(ipoint,3,l,l) * mos_l_in_r_array_transp(ipoint,i) * mos_r_in_r_array_transp(ipoint,i)
enddo
enddo
enddo
!$OMP END DO
!$OMP END PARALLEL
call dgemm( 'T', 'N', mo_num*mo_num, mo_num*mo_num, 3*n_points_final_grid, 1.d0 &
, tmp1(1,1,1,1), 3*n_points_final_grid, int2_grad1_u12_bimo_t(1,1,1,1), 3*n_points_final_grid &
, 0.d0, tmp_4d(1,1,1,1), mo_num*mo_num)
deallocate(tmp1)
!$OMP PARALLEL DO PRIVATE(i,j,k,m)
do i = 1, mo_num
do k = 1, mo_num
do j = 1, mo_num
do m = 1, mo_num
three_e_4_idx_direct_bi_ort_n4(m,j,k,i) = three_e_4_idx_direct_bi_ort_n4(m,j,k,i) - tmp_4d(m,j,k,i) - tmp_4d(j,m,k,i)
enddo
enddo
enddo
enddo
!$OMP END PARALLEL DO
deallocate(tmp_4d)
allocate(tmp_3d(mo_num,mo_num,mo_num))
allocate(tmp5(n_points_final_grid,mo_num))
!$OMP PARALLEL &
!$OMP DEFAULT (NONE) &
!$OMP PRIVATE (i, ipoint) &
!$OMP SHARED (mo_num, n_points_final_grid, &
!$OMP mos_l_in_r_array_transp, mos_r_in_r_array_transp, &
!$OMP final_weight_at_r_vector, &
!$OMP tmp5)
!$OMP DO
do i = 1, mo_num
do ipoint = 1, n_points_final_grid
tmp5(ipoint,i) = final_weight_at_r_vector(ipoint) * mos_l_in_r_array_transp(ipoint,i) * mos_r_in_r_array_transp(ipoint,i)
enddo
enddo
!$OMP END DO
!$OMP END PARALLEL
allocate(tmp4(n_points_final_grid,mo_num,mo_num))
do m = 1, mo_num
!$OMP PARALLEL &
!$OMP DEFAULT (NONE) &
!$OMP PRIVATE (i, k, ipoint) &
!$OMP SHARED (mo_num, n_points_final_grid, m, &
!$OMP int2_grad1_u12_bimo_t, &
!$OMP tmp4)
!$OMP DO COLLAPSE(2)
do i = 1, mo_num
do k = 1, mo_num
do ipoint = 1, n_points_final_grid
tmp4(ipoint,k,i) = int2_grad1_u12_bimo_t(ipoint,1,k,m) * int2_grad1_u12_bimo_t(ipoint,1,m,i) &
+ int2_grad1_u12_bimo_t(ipoint,2,k,m) * int2_grad1_u12_bimo_t(ipoint,2,m,i) &
+ int2_grad1_u12_bimo_t(ipoint,3,k,m) * int2_grad1_u12_bimo_t(ipoint,3,m,i)
enddo
enddo
enddo
!$OMP END DO
!$OMP END PARALLEL
call dgemm( 'T', 'N', mo_num, mo_num*mo_num, n_points_final_grid, 1.d0 &
, tmp5(1,1), n_points_final_grid, tmp4(1,1,1), n_points_final_grid &
, 0.d0, tmp_3d(1,1,1), mo_num)
!$OMP PARALLEL DO PRIVATE(i,j,k)
do i = 1, mo_num
do k = 1, mo_num
do j = 1, mo_num
three_e_4_idx_exch13_bi_ort_n4(m,j,k,i) = three_e_4_idx_exch13_bi_ort_n4(m,j,k,i) - tmp_3d(j,k,i)
enddo
enddo
enddo
!$OMP END PARALLEL DO
!$OMP PARALLEL &
!$OMP DEFAULT (NONE) &
!$OMP PRIVATE (j, k, ipoint) &
!$OMP SHARED (mo_num, n_points_final_grid, m, &
!$OMP mos_l_in_r_array_transp, &
!$OMP int2_grad1_u12_bimo_t, final_weight_at_r_vector, &
!$OMP tmp4)
!$OMP DO COLLAPSE(2)
do k = 1, mo_num
do j = 1, mo_num
do ipoint = 1, n_points_final_grid
tmp4(ipoint,j,k) = final_weight_at_r_vector(ipoint) * mos_l_in_r_array_transp(ipoint,j) &
* ( int2_grad1_u12_bimo_t(ipoint,1,m,j) * int2_grad1_u12_bimo_t(ipoint,1,k,m) &
+ int2_grad1_u12_bimo_t(ipoint,2,m,j) * int2_grad1_u12_bimo_t(ipoint,2,k,m) &
+ int2_grad1_u12_bimo_t(ipoint,3,m,j) * int2_grad1_u12_bimo_t(ipoint,3,k,m) )
enddo
enddo
enddo
!$OMP END DO
!$OMP END PARALLEL
call dgemm( 'T', 'N', mo_num*mo_num, mo_num, n_points_final_grid, 1.d0 &
, tmp4(1,1,1), n_points_final_grid, mos_r_in_r_array_transp(1,1), n_points_final_grid &
, 0.d0, tmp_3d(1,1,1), mo_num*mo_num)
!$OMP PARALLEL DO PRIVATE(i,j,k)
do i = 1, mo_num
do k = 1, mo_num
do j = 1, mo_num
three_e_4_idx_cycle_1_bi_ort_n4(m,j,k,i) = three_e_4_idx_cycle_1_bi_ort_n4(m,j,k,i) - tmp_3d(j,k,i)
enddo
enddo
enddo
!$OMP END PARALLEL DO
enddo
deallocate(tmp5)
deallocate(tmp_3d)
do i = 1, mo_num
!$OMP PARALLEL &
!$OMP DEFAULT (NONE) &
!$OMP PRIVATE (m, j, ipoint) &
!$OMP SHARED (mo_num, n_points_final_grid, i, &
!$OMP mos_r_in_r_array_transp, &
!$OMP int2_grad1_u12_bimo_t, final_weight_at_r_vector, &
!$OMP tmp4)
!$OMP DO COLLAPSE(2)
do j = 1, mo_num
do m = 1, mo_num
do ipoint = 1, n_points_final_grid
tmp4(ipoint,m,j) = final_weight_at_r_vector(ipoint) * mos_r_in_r_array_transp(ipoint,m) &
* ( int2_grad1_u12_bimo_t(ipoint,1,m,j) * int2_grad1_u12_bimo_t(ipoint,1,j,i) &
+ int2_grad1_u12_bimo_t(ipoint,2,m,j) * int2_grad1_u12_bimo_t(ipoint,2,j,i) &
+ int2_grad1_u12_bimo_t(ipoint,3,m,j) * int2_grad1_u12_bimo_t(ipoint,3,j,i) )
enddo
enddo
enddo
!$OMP END DO
!$OMP END PARALLEL
call dgemm( 'T', 'N', mo_num*mo_num, mo_num, n_points_final_grid, -1.d0 &
, tmp4(1,1,1), n_points_final_grid, mos_l_in_r_array_transp(1,1), n_points_final_grid &
, 1.d0, three_e_4_idx_cycle_1_bi_ort_n4(1,1,1,i), mo_num*mo_num)
enddo
deallocate(tmp4)
! !$OMP PARALLEL DO PRIVATE(i,j,k,m)
! do i = 1, mo_num
! do k = 1, mo_num
! do j = 1, mo_num
! do m = 1, mo_num
! three_e_4_idx_exch12_bi_ort_n4 (m,j,k,i) = three_e_4_idx_exch13_bi_ort_n4 (j,m,k,i)
! three_e_4_idx_cycle_2_bi_ort_n4(m,j,k,i) = three_e_4_idx_cycle_1_bi_ort_n4(j,m,k,i)
! enddo
! enddo
! enddo
! enddo
! !$OMP END PARALLEL DO
call wall_time(wall1)
print *, ' wall time for O(N^4) three_e_4_idx_bi_ort', wall1 - wall0
call print_memory_usage()
END_PROVIDER
! ---
BEGIN_PROVIDER [ double precision, three_e_4_idx_exch23_bi_ort_n4 , (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_4_idx_exch23_bi_ort_n4 (m,j,k,i) = < m j k | -L | j m i > ::: notice that i is the RIGHT MO and k is the LEFT MO
!
! notice the -1 sign: in this way three_e_4_idx_direct_bi_ort_n4 can be directly used to compute Slater rules with a + sign
!
! three_e_4_idx_exch23_bi_ort_n4 (m,j,k,i) : Lk Ri Imj Ijm + Lj Rm Imj Iki + Lm Rj Ijm Iki
!
END_DOC
implicit none
integer :: i, j, k, l, m, ipoint
double precision :: wall1, wall0
double precision, allocatable :: tmp1(:,:,:,:), tmp_4d(:,:,:,:)
double precision, allocatable :: tmp5(:,:,:), tmp6(:,:,:)
print *, ' Providing the O(N^4) three_e_4_idx_exch23_bi_ort_n4 ...'
call wall_time(wall0)
provide mos_r_in_r_array_transp mos_l_in_r_array_transp
allocate(tmp5(n_points_final_grid,mo_num,mo_num))
allocate(tmp6(n_points_final_grid,mo_num,mo_num))
!$OMP PARALLEL &
!$OMP DEFAULT (NONE) &
!$OMP PRIVATE (i, l, ipoint) &
!$OMP SHARED (mo_num, n_points_final_grid, &
!$OMP mos_l_in_r_array_transp, mos_r_in_r_array_transp, &
!$OMP int2_grad1_u12_bimo_t, final_weight_at_r_vector, &
!$OMP tmp5, tmp6)
!$OMP DO COLLAPSE(2)
do i = 1, mo_num
do l = 1, mo_num
do ipoint = 1, n_points_final_grid
tmp5(ipoint,l,i) = int2_grad1_u12_bimo_t(ipoint,1,l,i) * int2_grad1_u12_bimo_t(ipoint,1,i,l) &
+ int2_grad1_u12_bimo_t(ipoint,2,l,i) * int2_grad1_u12_bimo_t(ipoint,2,i,l) &
+ int2_grad1_u12_bimo_t(ipoint,3,l,i) * int2_grad1_u12_bimo_t(ipoint,3,i,l)
tmp6(ipoint,l,i) = final_weight_at_r_vector(ipoint) * mos_l_in_r_array_transp(ipoint,l) * mos_r_in_r_array_transp(ipoint,i)
enddo
enddo
enddo
!$OMP END DO
!$OMP END PARALLEL
call dgemm( 'T', 'N', mo_num*mo_num, mo_num*mo_num, n_points_final_grid, -1.d0 &
, tmp5(1,1,1), n_points_final_grid, tmp6(1,1,1), n_points_final_grid &
, 0.d0, three_e_4_idx_exch23_bi_ort_n4(1,1,1,1), mo_num*mo_num)
deallocate(tmp5)
deallocate(tmp6)
allocate(tmp_4d(mo_num,mo_num,mo_num,mo_num))
allocate(tmp1(n_points_final_grid,3,mo_num,mo_num))
!$OMP PARALLEL &
!$OMP DEFAULT (NONE) &
!$OMP PRIVATE (i, l, ipoint) &
!$OMP SHARED (mo_num, n_points_final_grid, &
!$OMP mos_l_in_r_array_transp, mos_r_in_r_array_transp, &
!$OMP int2_grad1_u12_bimo_t, final_weight_at_r_vector, &
!$OMP tmp1)
!$OMP DO COLLAPSE(2)
do i = 1, mo_num
do l = 1, mo_num
do ipoint = 1, n_points_final_grid
tmp1(ipoint,1,l,i) = final_weight_at_r_vector(ipoint) * int2_grad1_u12_bimo_t(ipoint,1,l,i) * mos_l_in_r_array_transp(ipoint,i) * mos_r_in_r_array_transp(ipoint,l)
tmp1(ipoint,2,l,i) = final_weight_at_r_vector(ipoint) * int2_grad1_u12_bimo_t(ipoint,2,l,i) * mos_l_in_r_array_transp(ipoint,i) * mos_r_in_r_array_transp(ipoint,l)
tmp1(ipoint,3,l,i) = final_weight_at_r_vector(ipoint) * int2_grad1_u12_bimo_t(ipoint,3,l,i) * mos_l_in_r_array_transp(ipoint,i) * mos_r_in_r_array_transp(ipoint,l)
enddo
enddo
enddo
!$OMP END DO
!$OMP END PARALLEL
call dgemm( 'T', 'N', mo_num*mo_num, mo_num*mo_num, 3*n_points_final_grid, 1.d0 &
, tmp1(1,1,1,1), 3*n_points_final_grid, int2_grad1_u12_bimo_t(1,1,1,1), 3*n_points_final_grid &
, 0.d0, tmp_4d(1,1,1,1), mo_num*mo_num)
deallocate(tmp1)
!$OMP PARALLEL DO PRIVATE(i,j,k,m)
do i = 1, mo_num
do k = 1, mo_num
do j = 1, mo_num
do m = 1, mo_num
three_e_4_idx_exch23_bi_ort_n4(m,j,k,i) = three_e_4_idx_exch23_bi_ort_n4(m,j,k,i) - tmp_4d(m,j,k,i) - tmp_4d(j,m,k,i)
enddo
enddo
enddo
enddo
!$OMP END PARALLEL DO
deallocate(tmp_4d)
call wall_time(wall1)
print *, ' wall time for O(N^4) three_e_4_idx_exch23_bi_ort_n4', wall1 - wall0
call print_memory_usage()
END_PROVIDER
! ---

290
src/bi_ort_ints/three_body_ijmk_old.irp.f Normal file
View File

@ -0,0 +1,290 @@
! ---
BEGIN_PROVIDER [ double precision, three_e_4_idx_direct_bi_ort_old, (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_4_idx_direct_bi_ort_old(m,j,k,i) = <mjk|-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
double precision :: integral, wall1, wall0
three_e_4_idx_direct_bi_ort_old = 0.d0
print *, ' Providing the three_e_4_idx_direct_bi_ort_old ...'
call wall_time(wall0)
provide mos_r_in_r_array_transp mos_l_in_r_array_transp
!$OMP PARALLEL &
!$OMP DEFAULT (NONE) &
!$OMP PRIVATE (i,j,k,m,integral) &
!$OMP SHARED (mo_num,three_e_4_idx_direct_bi_ort_old)
!$OMP DO SCHEDULE (dynamic) COLLAPSE(2)
do i = 1, mo_num
do k = 1, mo_num
do j = 1, mo_num
do m = 1, mo_num
call give_integrals_3_body_bi_ort(m, j, k, m, j, i, integral)
three_e_4_idx_direct_bi_ort_old(m,j,k,i) = -1.d0 * integral
enddo
enddo
enddo
enddo
!$OMP END DO
!$OMP END PARALLEL
call wall_time(wall1)
print *, ' wall time for three_e_4_idx_direct_bi_ort_old', wall1 - wall0
call print_memory_usage()
END_PROVIDER
! ---
BEGIN_PROVIDER [ double precision, three_e_4_idx_cycle_1_bi_ort_old, (mo_num, mo_num, mo_num, mo_num)]
BEGIN_DOC
!
! matrix element of the -L three-body operator FOR THE FIRST CYCLIC PERMUTATION TERMS OF SINGLE EXCITATIONS AND BI ORTHO MOs
!
! three_e_4_idx_cycle_1_bi_ort_old(m,j,k,i) = <mjk|-L|jim> ::: 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
double precision :: integral, wall1, wall0
three_e_4_idx_cycle_1_bi_ort_old = 0.d0
print *, ' Providing the three_e_4_idx_cycle_1_bi_ort_old ...'
call wall_time(wall0)
provide mos_r_in_r_array_transp mos_l_in_r_array_transp
!$OMP PARALLEL &
!$OMP DEFAULT (NONE) &
!$OMP PRIVATE (i,j,k,m,integral) &
!$OMP SHARED (mo_num,three_e_4_idx_cycle_1_bi_ort_old)
!$OMP DO SCHEDULE (dynamic) COLLAPSE(2)
do i = 1, mo_num
do k = 1, mo_num
do j = 1, mo_num
do m = 1, mo_num
call give_integrals_3_body_bi_ort(m, j, k, j, i, m, integral)
three_e_4_idx_cycle_1_bi_ort_old(m,j,k,i) = -1.d0 * integral
enddo
enddo
enddo
enddo
!$OMP END DO
!$OMP END PARALLEL
call wall_time(wall1)
print *, ' wall time for three_e_4_idx_cycle_1_bi_ort_old', wall1 - wall0
call print_memory_usage()
END_PROVIDER
! --
BEGIN_PROVIDER [ double precision, three_e_4_idx_cycle_2_bi_ort_old, (mo_num, mo_num, mo_num, mo_num)]
BEGIN_DOC
!
! matrix element of the -L three-body operator FOR THE FIRST CYCLIC PERMUTATION TERMS OF SINGLE EXCITATIONS AND BI ORTHO MOs
!
! three_e_4_idx_cycle_2_bi_ort_old(m,j,k,i) = <mjk|-L|imj> ::: 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
double precision :: integral, wall1, wall0
three_e_4_idx_cycle_2_bi_ort_old = 0.d0
print *, ' Providing the three_e_4_idx_cycle_2_bi_ort_old ...'
call wall_time(wall0)
provide mos_r_in_r_array_transp mos_l_in_r_array_transp
!$OMP PARALLEL &
!$OMP DEFAULT (NONE) &
!$OMP PRIVATE (i,j,k,m,integral) &
!$OMP SHARED (mo_num,three_e_4_idx_cycle_2_bi_ort_old)
!$OMP DO SCHEDULE (dynamic) COLLAPSE(2)
do i = 1, mo_num
do k = 1, mo_num
do j = 1, mo_num
do m = 1, mo_num
call give_integrals_3_body_bi_ort(m, j, k, i, m, j, integral)
three_e_4_idx_cycle_2_bi_ort_old(m,j,k,i) = -1.d0 * integral
enddo
enddo
enddo
enddo
!$OMP END DO
!$OMP END PARALLEL
call wall_time(wall1)
print *, ' wall time for three_e_4_idx_cycle_2_bi_ort_old', wall1 - wall0
call print_memory_usage()
END_PROVIDER
! ---
BEGIN_PROVIDER [ double precision, three_e_4_idx_exch23_bi_ort_old, (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_4_idx_exch23_bi_ort_old(m,j,k,i) = <mjk|-L|jmi> ::: 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
double precision :: integral, wall1, wall0
three_e_4_idx_exch23_bi_ort_old = 0.d0
print *, ' Providing the three_e_4_idx_exch23_bi_ort_old ...'
call wall_time(wall0)
provide mos_r_in_r_array_transp mos_l_in_r_array_transp
!$OMP PARALLEL &
!$OMP DEFAULT (NONE) &
!$OMP PRIVATE (i,j,k,m,integral) &
!$OMP SHARED (mo_num,three_e_4_idx_exch23_bi_ort_old)
!$OMP DO SCHEDULE (dynamic) COLLAPSE(2)
do i = 1, mo_num
do k = 1, mo_num
do j = 1, mo_num
do m = 1, mo_num
call give_integrals_3_body_bi_ort(m, j, k, j, m, i, integral)
three_e_4_idx_exch23_bi_ort_old(m,j,k,i) = -1.d0 * integral
enddo
enddo
enddo
enddo
!$OMP END DO
!$OMP END PARALLEL
call wall_time(wall1)
print *, ' wall time for three_e_4_idx_exch23_bi_ort_old', wall1 - wall0
call print_memory_usage()
END_PROVIDER
! ---
BEGIN_PROVIDER [ double precision, three_e_4_idx_exch13_bi_ort_old, (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_4_idx_exch13_bi_ort_old(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
implicit none
integer :: i, j, k, m
double precision :: integral, wall1, wall0
three_e_4_idx_exch13_bi_ort_old = 0.d0
print *, ' Providing the three_e_4_idx_exch13_bi_ort_old ...'
call wall_time(wall0)
provide mos_r_in_r_array_transp mos_l_in_r_array_transp
!$OMP PARALLEL &
!$OMP DEFAULT (NONE) &
!$OMP PRIVATE (i,j,k,m,integral) &
!$OMP SHARED (mo_num,three_e_4_idx_exch13_bi_ort_old)
!$OMP DO SCHEDULE (dynamic) COLLAPSE(2)
do i = 1, mo_num
do k = 1, mo_num
do j = 1, mo_num
do m = 1, mo_num
call give_integrals_3_body_bi_ort(m, j, k, i, j, m, integral)
three_e_4_idx_exch13_bi_ort_old(m,j,k,i) = -1.d0 * integral
enddo
enddo
enddo
enddo
!$OMP END DO
!$OMP END PARALLEL
call wall_time(wall1)
print *, ' wall time for three_e_4_idx_exch13_bi_ort_old', wall1 - wall0
call print_memory_usage()
END_PROVIDER
! ---
BEGIN_PROVIDER [ double precision, three_e_4_idx_exch12_bi_ort_old, (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_4_idx_exch12_bi_ort_old(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
!
END_DOC
implicit none
integer :: i, j, k, m
double precision :: integral, wall1, wall0
three_e_4_idx_exch12_bi_ort_old = 0.d0
print *, ' Providing the three_e_4_idx_exch12_bi_ort_old ...'
call wall_time(wall0)
provide mos_r_in_r_array_transp mos_l_in_r_array_transp
!$OMP PARALLEL &
!$OMP DEFAULT (NONE) &
!$OMP PRIVATE (i,j,k,m,integral) &
!$OMP SHARED (mo_num,three_e_4_idx_exch12_bi_ort_old)
!$OMP DO SCHEDULE (dynamic) COLLAPSE(2)
do i = 1, mo_num
do k = 1, mo_num
do j = 1, mo_num
do m = 1, mo_num
call give_integrals_3_body_bi_ort(m, j, k, m, i, j, integral)
three_e_4_idx_exch12_bi_ort_old(m,j,k,i) = -1.d0 * integral
enddo
enddo
enddo
enddo
!$OMP END DO
!$OMP END PARALLEL
call wall_time(wall1)
print *, ' wall time for three_e_4_idx_exch12_bi_ort_old', wall1 - wall0
call print_memory_usage()
END_PROVIDER
! ---

413
src/bi_ort_ints/three_body_ijmkl.irp.f
View File

@ -1,296 +1,245 @@
! --- ! ---
double precision function three_e_5_idx_exch12_bi_ort(m,l,i,k,j) result(integral)
implicit none
integer, intent(in) :: m,l,j,k,i
integral = three_e_5_idx_direct_bi_ort(m,l,j,k,i)
end
BEGIN_PROVIDER [ double precision, three_e_5_idx_direct_bi_ort, (mo_num, mo_num, mo_num, mo_num, mo_num)] BEGIN_PROVIDER [ double precision, three_e_5_idx_direct_bi_ort , (mo_num, mo_num, mo_num, mo_num, mo_num)]
&BEGIN_PROVIDER [ double precision, three_e_5_idx_exch23_bi_ort , (mo_num, mo_num, mo_num, mo_num, mo_num)]
&BEGIN_PROVIDER [ double precision, three_e_5_idx_exch13_bi_ort , (mo_num, mo_num, mo_num, mo_num, mo_num)]
&BEGIN_PROVIDER [ double precision, three_e_5_idx_cycle_1_bi_ort, (mo_num, mo_num, mo_num, mo_num, mo_num)]
&BEGIN_PROVIDER [ double precision, three_e_5_idx_cycle_2_bi_ort, (mo_num, mo_num, mo_num, mo_num, mo_num)]
BEGIN_DOC BEGIN_DOC
! !
! matrix element of the -L three-body operator FOR THE DIRECT TERMS OF DOUBLE EXCITATIONS AND BI ORTHO MOs ! 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) = <mlk|-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 ! 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 END_DOC
implicit none implicit none
integer :: i, j, k, m, l
double precision :: integral, wall1, wall0
three_e_5_idx_direct_bi_ort = 0.d0 integer :: i, j, k, m, l
print *, ' Providing the three_e_5_idx_direct_bi_ort ...' double precision :: wall1, wall0
call wall_time(wall0) integer :: ipoint
double precision, allocatable :: grad_mli(:,:), orb_mat(:,:,:)
double precision, allocatable :: lk_grad_mi(:,:,:,:), rk_grad_im(:,:,:)
double precision, allocatable :: lm_grad_ik(:,:,:,:), rm_grad_ik(:,:,:)
double precision, allocatable :: tmp_mat(:,:,:)
provide mos_r_in_r_array_transp mos_l_in_r_array_transp provide mos_r_in_r_array_transp mos_l_in_r_array_transp
PROVIDE mo_l_coef mo_r_coef int2_grad1_u12_bimo_t
call print_memory_usage
print *, ' Providing the three_e_5_idx_bi_ort ...'
call wall_time(wall0)
three_e_5_idx_direct_bi_ort (:,:,:,:,:) = 0.d0
three_e_5_idx_cycle_1_bi_ort(:,:,:,:,:) = 0.d0
three_e_5_idx_cycle_2_bi_ort(:,:,:,:,:) = 0.d0
three_e_5_idx_exch23_bi_ort (:,:,:,:,:) = 0.d0
three_e_5_idx_exch13_bi_ort (:,:,:,:,:) = 0.d0
call print_memory_usage
allocate(tmp_mat(mo_num,mo_num,mo_num))
allocate(orb_mat(n_points_final_grid,mo_num,mo_num))
!$OMP PARALLEL DO PRIVATE (i,l,ipoint)
do i=1,mo_num
do l=1,mo_num
do ipoint=1, n_points_final_grid
orb_mat(ipoint,l,i) = final_weight_at_r_vector(ipoint) &
* mos_l_in_r_array_transp(ipoint,l) &
* mos_r_in_r_array_transp(ipoint,i)
!$OMP PARALLEL &
!$OMP DEFAULT (NONE) &
!$OMP PRIVATE (i,j,k,m,l,integral) &
!$OMP SHARED (mo_num,three_e_5_idx_direct_bi_ort)
!$OMP DO SCHEDULE (dynamic) COLLAPSE(2)
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
call give_integrals_3_body_bi_ort(m, l, k, m, j, i, integral)
three_e_5_idx_direct_bi_ort(m,l,j,k,i) = -1.d0 * integral
enddo
enddo
enddo enddo
enddo enddo
enddo enddo
!$OMP END DO !$OMP END PARALLEL DO
!$OMP END PARALLEL
call wall_time(wall1) tmp_mat = 0.d0
print *, ' wall time for three_e_5_idx_direct_bi_ort', wall1 - wall0 call print_memory_usage
END_PROVIDER do m = 1, mo_num
! --- allocate(grad_mli(n_points_final_grid,mo_num))
BEGIN_PROVIDER [ double precision, three_e_5_idx_cycle_1_bi_ort, (mo_num, mo_num, mo_num, mo_num, mo_num)] do i=1,mo_num
!$OMP PARALLEL DO PRIVATE (l,ipoint)
do l=1,mo_num
do ipoint=1, n_points_final_grid
BEGIN_DOC grad_mli(ipoint,l) = &
! int2_grad1_u12_bimo_t(ipoint,1,m,m) * int2_grad1_u12_bimo_t(ipoint,1,l,i) +&
! matrix element of the -L three-body operator FOR THE FIRST CYCLIC PERMUTATION TERMS OF DOUBLE EXCITATIONS AND BI ORTHO MOs int2_grad1_u12_bimo_t(ipoint,2,m,m) * int2_grad1_u12_bimo_t(ipoint,2,l,i) +&
! int2_grad1_u12_bimo_t(ipoint,3,m,m) * int2_grad1_u12_bimo_t(ipoint,3,l,i)
! three_e_5_idx_cycle_1_bi_ort(m,l,j,k,i) = <mlk|-L|jim> ::: 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_5_idx_cycle_1_bi_ort = 0.d0
print *, ' Providing the three_e_5_idx_cycle_1_bi_ort ...'
call wall_time(wall0)
provide mos_r_in_r_array_transp mos_l_in_r_array_transp
!$OMP PARALLEL &
!$OMP DEFAULT (NONE) &
!$OMP PRIVATE (i,j,k,m,l,integral) &
!$OMP SHARED (mo_num,three_e_5_idx_cycle_1_bi_ort)
!$OMP DO SCHEDULE (dynamic) COLLAPSE(2)
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
call give_integrals_3_body_bi_ort(m, l, k, j, i, m, integral)
three_e_5_idx_cycle_1_bi_ort(m,l,j,k,i) = -1.d0 * integral
enddo
enddo enddo
enddo enddo
enddo !$OMP END PARALLEL DO
enddo
!$OMP END DO
!$OMP END PARALLEL
call wall_time(wall1) call dgemm('T','N', mo_num*mo_num, mo_num, n_points_final_grid, 1.d0,&
print *, ' wall time for three_e_5_idx_cycle_1_bi_ort', wall1 - wall0 orb_mat, n_points_final_grid, &
grad_mli, n_points_final_grid, 0.d0, &
tmp_mat, mo_num*mo_num)
END_PROVIDER !$OMP PARALLEL PRIVATE(j,k,l)
!$OMP DO
! --- do k = 1, mo_num
do j = 1, mo_num
BEGIN_PROVIDER [ double precision, three_e_5_idx_cycle_2_bi_ort, (mo_num, mo_num, mo_num, mo_num, mo_num)]
BEGIN_DOC
!
! matrix element of the -L three-body operator FOR THE FIRST CYCLIC PERMUTATION TERMS OF DOUBLE EXCITATIONS AND BI ORTHO MOs
!
! three_e_5_idx_cycle_2_bi_ort(m,l,j,k,i) = <mlk|-L|imj> ::: 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_5_idx_cycle_2_bi_ort = 0.d0
print *, ' Providing the three_e_5_idx_cycle_2_bi_ort ...'
call wall_time(wall0)
provide mos_r_in_r_array_transp mos_l_in_r_array_transp
!$OMP PARALLEL &
!$OMP DEFAULT (NONE) &
!$OMP PRIVATE (i,j,k,m,l,integral) &
!$OMP SHARED (mo_num,three_e_5_idx_cycle_2_bi_ort)
!$OMP DO SCHEDULE (dynamic) COLLAPSE(2)
do i = 1, mo_num
do k = 1, mo_num
do j = 1, mo_num
do m = 1, mo_num
do l = 1, mo_num do l = 1, mo_num
call give_integrals_3_body_bi_ort(m, l, k, i, m, j, integral) three_e_5_idx_direct_bi_ort(m,l,j,k,i) = three_e_5_idx_direct_bi_ort(m,l,j,k,i) - tmp_mat(l,j,k)
three_e_5_idx_cycle_2_bi_ort(m,l,j,k,i) = -1.d0 * integral
enddo enddo
enddo enddo
enddo enddo
enddo !$OMP END DO
enddo !$OMP DO
!$OMP END DO
!$OMP END PARALLEL
call wall_time(wall1)
print *, ' wall time for three_e_5_idx_cycle_2_bi_ort', wall1 - wall0
END_PROVIDER
! ---
BEGIN_PROVIDER [ double precision, three_e_5_idx_exch23_bi_ort, (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_5_idx_exch23_bi_ort(m,l,j,k,i) = <mlk|-L|jmi> ::: 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_5_idx_exch23_bi_ort = 0.d0
print *, ' Providing the three_e_5_idx_exch23_bi_ort ...'
call wall_time(wall0)
provide mos_r_in_r_array_transp mos_l_in_r_array_transp
!$OMP PARALLEL &
!$OMP DEFAULT (NONE) &
!$OMP PRIVATE (i,j,k,m,l,integral) &
!$OMP SHARED (mo_num,three_e_5_idx_exch23_bi_ort)
!$OMP DO SCHEDULE (dynamic) COLLAPSE(2)
do i = 1, mo_num
do k = 1, mo_num
do j = 1, mo_num do j = 1, mo_num
do l = 1, mo_num do l = 1, mo_num
do m = 1, mo_num do k = 1, mo_num
call give_integrals_3_body_bi_ort(m, l, k, j, m, i, integral) three_e_5_idx_direct_bi_ort(m,k,i,l,j) = three_e_5_idx_direct_bi_ort(m,k,i,l,j) - tmp_mat(l,j,k)
three_e_5_idx_exch23_bi_ort(m,l,j,k,i) = -1.d0 * integral
enddo enddo
enddo enddo
enddo enddo
!$OMP END DO
!$OMP END PARALLEL
enddo enddo
enddo
!$OMP END DO
!$OMP END PARALLEL
call wall_time(wall1) deallocate(grad_mli)
print *, ' wall time for three_e_5_idx_exch23_bi_ort', wall1 - wall0
END_PROVIDER allocate(lm_grad_ik(n_points_final_grid,3,mo_num,mo_num))
allocate(lk_grad_mi(n_points_final_grid,3,mo_num,mo_num))
! --- !$OMP PARALLEL DO PRIVATE (i,l,ipoint)
do i=1,mo_num
do l=1,mo_num
do ipoint=1, n_points_final_grid
BEGIN_PROVIDER [ double precision, three_e_5_idx_exch13_bi_ort, (mo_num, mo_num, mo_num, mo_num, mo_num)] lm_grad_ik(ipoint,1,l,i) = mos_l_in_r_array_transp(ipoint,m) * int2_grad1_u12_bimo_t(ipoint,1,l,i) * final_weight_at_r_vector(ipoint)
lm_grad_ik(ipoint,2,l,i) = mos_l_in_r_array_transp(ipoint,m) * int2_grad1_u12_bimo_t(ipoint,2,l,i) * final_weight_at_r_vector(ipoint)
lm_grad_ik(ipoint,3,l,i) = mos_l_in_r_array_transp(ipoint,m) * int2_grad1_u12_bimo_t(ipoint,3,l,i) * final_weight_at_r_vector(ipoint)
BEGIN_DOC lk_grad_mi(ipoint,1,l,i) = mos_l_in_r_array_transp(ipoint,l) * int2_grad1_u12_bimo_t(ipoint,1,m,i) * final_weight_at_r_vector(ipoint)
! lk_grad_mi(ipoint,2,l,i) = mos_l_in_r_array_transp(ipoint,l) * int2_grad1_u12_bimo_t(ipoint,2,m,i) * final_weight_at_r_vector(ipoint)
! matrix element of the -L three-body operator FOR THE DIRECT TERMS OF DOUBLE EXCITATIONS AND BI ORTHO MOs lk_grad_mi(ipoint,3,l,i) = mos_l_in_r_array_transp(ipoint,l) * int2_grad1_u12_bimo_t(ipoint,3,m,i) * final_weight_at_r_vector(ipoint)
!
! 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
!
END_DOC
implicit none
integer :: i, j, k, m, l
double precision :: integral, wall1, wall0
three_e_5_idx_exch13_bi_ort = 0.d0
print *, ' Providing the three_e_5_idx_exch13_bi_ort ...'
call wall_time(wall0)
provide mos_r_in_r_array_transp mos_l_in_r_array_transp
!$OMP PARALLEL &
!$OMP DEFAULT (NONE) &
!$OMP PRIVATE (i,j,k,m,l,integral) &
!$OMP SHARED (mo_num,three_e_5_idx_exch13_bi_ort)
!$OMP DO SCHEDULE (dynamic) COLLAPSE(2)
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
call give_integrals_3_body_bi_ort(m, l, k, i, j, m, integral)
three_e_5_idx_exch13_bi_ort(m,l,j,k,i) = -1.d0 * integral
enddo
enddo enddo
enddo enddo
enddo enddo
enddo !$OMP END PARALLEL DO
!$OMP END DO
!$OMP END PARALLEL
call wall_time(wall1) allocate(rm_grad_ik(n_points_final_grid,3,mo_num))
print *, ' wall time for three_e_5_idx_exch13_bi_ort', wall1 - wall0 allocate(rk_grad_im(n_points_final_grid,3,mo_num))
END_PROVIDER do i=1,mo_num
!$OMP PARALLEL DO PRIVATE (l,ipoint)
do l=1,mo_num
do ipoint=1, n_points_final_grid
! --- rm_grad_ik(ipoint,1,l) = mos_r_in_r_array_transp(ipoint,m) * int2_grad1_u12_bimo_t(ipoint,1,l,i)
rm_grad_ik(ipoint,2,l) = mos_r_in_r_array_transp(ipoint,m) * int2_grad1_u12_bimo_t(ipoint,2,l,i)
rm_grad_ik(ipoint,3,l) = mos_r_in_r_array_transp(ipoint,m) * int2_grad1_u12_bimo_t(ipoint,3,l,i)
BEGIN_PROVIDER [ double precision, three_e_5_idx_exch12_bi_ort, (mo_num, mo_num, mo_num, mo_num, mo_num)] rk_grad_im(ipoint,1,l) = mos_r_in_r_array_transp(ipoint,l) * int2_grad1_u12_bimo_t(ipoint,1,i,m)
rk_grad_im(ipoint,2,l) = mos_r_in_r_array_transp(ipoint,l) * int2_grad1_u12_bimo_t(ipoint,2,i,m)
rk_grad_im(ipoint,3,l) = mos_r_in_r_array_transp(ipoint,l) * int2_grad1_u12_bimo_t(ipoint,3,i,m)
BEGIN_DOC enddo
! enddo
! matrix element of the -L three-body operator FOR THE DIRECT TERMS OF DOUBLE EXCITATIONS AND BI ORTHO MOs !$OMP END PARALLEL DO
!
! 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
!
END_DOC
implicit none call dgemm('T','N', mo_num*mo_num, mo_num, 3*n_points_final_grid, 1.d0,&
integer :: i, j, k, m, l lm_grad_ik, 3*n_points_final_grid, &
double precision :: integral, wall1, wall0 rm_grad_ik, 3*n_points_final_grid, 0.d0, &
tmp_mat, mo_num*mo_num)
three_e_5_idx_exch12_bi_ort = 0.d0 !$OMP PARALLEL DO PRIVATE(j,k,l)
print *, ' Providing the three_e_5_idx_exch12_bi_ort ...' do k = 1, mo_num
call wall_time(wall0) do j = 1, mo_num
do l = 1, mo_num
provide mos_r_in_r_array_transp mos_l_in_r_array_transp three_e_5_idx_direct_bi_ort(m,l,j,k,i) = three_e_5_idx_direct_bi_ort(m,l,j,k,i) - tmp_mat(l,j,k)
!$OMP PARALLEL &
!$OMP DEFAULT (NONE) &
!$OMP PRIVATE (i,j,k,m,l,integral) &
!$OMP SHARED (mo_num,three_e_5_idx_exch12_bi_ort)
!$OMP DO SCHEDULE (dynamic) COLLAPSE(2)
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
call give_integrals_3_body_bi_ort(m, l, k, m, i, j, integral)
three_e_5_idx_exch12_bi_ort(m,l,j,k,i) = -1.d0 * integral
enddo enddo
enddo enddo
enddo enddo
!$OMP END PARALLEL DO
call dgemm('T','N', mo_num*mo_num, mo_num, 3*n_points_final_grid, 1.d0,&
lm_grad_ik, 3*n_points_final_grid, &
rk_grad_im, 3*n_points_final_grid, 0.d0, &
tmp_mat, mo_num*mo_num)
!$OMP PARALLEL DO PRIVATE(j,k,l)
do k = 1, mo_num
do j = 1, mo_num
do l = 1, mo_num
three_e_5_idx_cycle_1_bi_ort(m,l,j,i,k) = three_e_5_idx_cycle_1_bi_ort(m,l,j,i,k) - tmp_mat(l,k,j)
three_e_5_idx_cycle_2_bi_ort(m,i,j,k,l) = three_e_5_idx_cycle_2_bi_ort(m,i,j,k,l) - tmp_mat(k,j,l)
three_e_5_idx_exch23_bi_ort (m,i,j,k,l) = three_e_5_idx_exch23_bi_ort (m,i,j,k,l) - tmp_mat(k,l,j)
three_e_5_idx_exch13_bi_ort (m,l,j,i,k) = three_e_5_idx_exch13_bi_ort (m,l,j,i,k) - tmp_mat(l,j,k)
enddo
enddo
enddo
!$OMP END PARALLEL DO
call dgemm('T','N', mo_num*mo_num, mo_num, 3*n_points_final_grid, 1.d0,&
lk_grad_mi, 3*n_points_final_grid, &
rm_grad_ik, 3*n_points_final_grid, 0.d0, &
tmp_mat, mo_num*mo_num)
!$OMP PARALLEL DO PRIVATE(j,k,l)
do k = 1, mo_num
do j = 1, mo_num
do l = 1, mo_num
three_e_5_idx_cycle_1_bi_ort(m,l,j,k,i) = three_e_5_idx_cycle_1_bi_ort(m,l,j,k,i) - tmp_mat(k,j,l)
three_e_5_idx_cycle_2_bi_ort(m,l,i,k,j) = three_e_5_idx_cycle_2_bi_ort(m,l,i,k,j) - tmp_mat(l,j,k)
three_e_5_idx_exch23_bi_ort (m,l,j,k,i) = three_e_5_idx_exch23_bi_ort (m,l,j,k,i) - tmp_mat(l,j,k)
three_e_5_idx_exch13_bi_ort (m,l,i,k,j) = three_e_5_idx_exch13_bi_ort (m,l,i,k,j) - tmp_mat(k,j,l)
enddo
enddo
enddo
!$OMP END PARALLEL DO
call dgemm('T','N', mo_num*mo_num, mo_num, 3*n_points_final_grid, 1.d0,&
lk_grad_mi, 3*n_points_final_grid, &
rk_grad_im, 3*n_points_final_grid, 0.d0, &
tmp_mat, mo_num*mo_num)
!$OMP PARALLEL DO PRIVATE(j,k,l)
do k = 1, mo_num
do j = 1, mo_num
do l = 1, mo_num
three_e_5_idx_cycle_1_bi_ort(m,l,j,i,k) = three_e_5_idx_cycle_1_bi_ort(m,l,j,i,k) - tmp_mat(l,j,k)
three_e_5_idx_cycle_2_bi_ort(m,i,j,k,l) = three_e_5_idx_cycle_2_bi_ort(m,i,j,k,l) - tmp_mat(k,l,j)
three_e_5_idx_exch23_bi_ort (m,i,j,k,l) = three_e_5_idx_exch23_bi_ort (m,i,j,k,l) - tmp_mat(k,j,l)
three_e_5_idx_exch13_bi_ort (m,l,j,i,k) = three_e_5_idx_exch13_bi_ort (m,l,j,i,k) - tmp_mat(l,k,j)
enddo
enddo
enddo
!$OMP END PARALLEL DO
enddo enddo
deallocate(rm_grad_ik)
deallocate(rk_grad_im)
deallocate(lk_grad_mi)
deallocate(lm_grad_ik)
enddo enddo
!$OMP END DO
!$OMP END PARALLEL deallocate(tmp_mat)
deallocate(orb_mat)
call wall_time(wall1) call wall_time(wall1)
print *, ' wall time for three_e_5_idx_exch12_bi_ort', wall1 - wall0 print *, ' wall time for three_e_5_idx_bi_ort', wall1 - wall0
call print_memory_usage()
END_PROVIDER END_PROVIDER
! ---

295
src/bi_ort_ints/three_body_ijmkl_old.irp.f Normal file
View File

@ -0,0 +1,295 @@
! ---
BEGIN_PROVIDER [ double precision, three_e_5_idx_direct_bi_ort_old, (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_5_idx_direct_bi_ort_old(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_5_idx_direct_bi_ort_old = 0.d0
print *, ' Providing the three_e_5_idx_direct_bi_ort_old ...'
call wall_time(wall0)
provide mos_r_in_r_array_transp mos_l_in_r_array_transp
!$OMP PARALLEL &
!$OMP DEFAULT (NONE) &
!$OMP PRIVATE (i,j,k,m,l,integral) &
!$OMP SHARED (mo_num,three_e_5_idx_direct_bi_ort_old)
!$OMP DO SCHEDULE (dynamic) COLLAPSE(2)
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
call give_integrals_3_body_bi_ort(m, l, k, m, j, i, integral)
three_e_5_idx_direct_bi_ort_old(m,l,j,k,i) = -1.d0 * integral
enddo
enddo
enddo
enddo
enddo
!$OMP END DO
!$OMP END PARALLEL
call wall_time(wall1)
print *, ' wall time for three_e_5_idx_direct_bi_ort_old', wall1 - wall0
END_PROVIDER
! ---
BEGIN_PROVIDER [ double precision, three_e_5_idx_cycle_1_bi_ort_old, (mo_num, mo_num, mo_num, mo_num, mo_num)]
BEGIN_DOC
!
! matrix element of the -L three-body operator FOR THE FIRST CYCLIC PERMUTATION TERMS OF DOUBLE EXCITATIONS AND BI ORTHO MOs
!
! three_e_5_idx_cycle_1_bi_ort_old(m,l,j,k,i) = <mlk|-L|jim> ::: 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_5_idx_cycle_1_bi_ort_old = 0.d0
print *, ' Providing the three_e_5_idx_cycle_1_bi_ort_old ...'
call wall_time(wall0)
provide mos_r_in_r_array_transp mos_l_in_r_array_transp
!$OMP PARALLEL &
!$OMP DEFAULT (NONE) &
!$OMP PRIVATE (i,j,k,m,l,integral) &
!$OMP SHARED (mo_num,three_e_5_idx_cycle_1_bi_ort_old)
!$OMP DO SCHEDULE (dynamic) COLLAPSE(2)
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
call give_integrals_3_body_bi_ort(m, l, k, j, i, m, integral)
three_e_5_idx_cycle_1_bi_ort_old(m,l,j,k,i) = -1.d0 * integral
enddo
enddo
enddo
enddo
enddo
!$OMP END DO
!$OMP END PARALLEL
call wall_time(wall1)
print *, ' wall time for three_e_5_idx_cycle_1_bi_ort_old', wall1 - wall0
END_PROVIDER
! ---
BEGIN_PROVIDER [ double precision, three_e_5_idx_cycle_2_bi_ort_old, (mo_num, mo_num, mo_num, mo_num, mo_num)]
BEGIN_DOC
!
! matrix element of the -L three-body operator FOR THE FIRST CYCLIC PERMUTATION TERMS OF DOUBLE EXCITATIONS AND BI ORTHO MOs
!
! three_e_5_idx_cycle_2_bi_ort_old(m,l,j,k,i) = <mlk|-L|imj> ::: 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_5_idx_cycle_2_bi_ort_old = 0.d0
print *, ' Providing the three_e_5_idx_cycle_2_bi_ort_old ...'
call wall_time(wall0)
provide mos_r_in_r_array_transp mos_l_in_r_array_transp
!$OMP PARALLEL &
!$OMP DEFAULT (NONE) &
!$OMP PRIVATE (i,j,k,m,l,integral) &
!$OMP SHARED (mo_num,three_e_5_idx_cycle_2_bi_ort_old)
!$OMP DO SCHEDULE (dynamic) COLLAPSE(2)
do i = 1, mo_num
do k = 1, mo_num
do j = 1, mo_num
do m = 1, mo_num
do l = 1, mo_num
call give_integrals_3_body_bi_ort(m, l, k, i, m, j, integral)
three_e_5_idx_cycle_2_bi_ort_old(m,l,j,k,i) = -1.d0 * integral
enddo
enddo
enddo
enddo
enddo
!$OMP END DO
!$OMP END PARALLEL
call wall_time(wall1)
print *, ' wall time for three_e_5_idx_cycle_2_bi_ort_old', wall1 - wall0
END_PROVIDER
! ---
BEGIN_PROVIDER [ double precision, three_e_5_idx_exch23_bi_ort_old, (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_5_idx_exch23_bi_ort_old(m,l,j,k,i) = <mlk|-L|jmi> ::: 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_5_idx_exch23_bi_ort_old = 0.d0
print *, ' Providing the three_e_5_idx_exch23_bi_ort_old ...'
call wall_time(wall0)
provide mos_r_in_r_array_transp mos_l_in_r_array_transp
!$OMP PARALLEL &
!$OMP DEFAULT (NONE) &
!$OMP PRIVATE (i,j,k,m,l,integral) &
!$OMP SHARED (mo_num,three_e_5_idx_exch23_bi_ort_old)
!$OMP DO SCHEDULE (dynamic) COLLAPSE(2)
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
call give_integrals_3_body_bi_ort(m, l, k, j, m, i, integral)
three_e_5_idx_exch23_bi_ort_old(m,l,j,k,i) = -1.d0 * integral
enddo
enddo
enddo
enddo
enddo
!$OMP END DO
!$OMP END PARALLEL
call wall_time(wall1)
print *, ' wall time for three_e_5_idx_exch23_bi_ort_old', wall1 - wall0
END_PROVIDER
! ---
BEGIN_PROVIDER [ double precision, three_e_5_idx_exch13_bi_ort_old, (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_5_idx_exch13_bi_ort_old(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
!
END_DOC
implicit none
integer :: i, j, k, m, l
double precision :: integral, wall1, wall0
three_e_5_idx_exch13_bi_ort_old = 0.d0
print *, ' Providing the three_e_5_idx_exch13_bi_ort_old ...'
call wall_time(wall0)
provide mos_r_in_r_array_transp mos_l_in_r_array_transp
!$OMP PARALLEL &
!$OMP DEFAULT (NONE) &
!$OMP PRIVATE (i,j,k,m,l,integral) &
!$OMP SHARED (mo_num,three_e_5_idx_exch13_bi_ort_old)
!$OMP DO SCHEDULE (dynamic) COLLAPSE(2)
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
call give_integrals_3_body_bi_ort(m, l, k, i, j, m, integral)
three_e_5_idx_exch13_bi_ort_old(m,l,j,k,i) = -1.d0 * integral
enddo
enddo
enddo
enddo
enddo
!$OMP END DO
!$OMP END PARALLEL
call wall_time(wall1)
print *, ' wall time for three_e_5_idx_exch13_bi_ort_old', wall1 - wall0
END_PROVIDER
! ---
BEGIN_PROVIDER [ double precision, three_e_5_idx_exch12_bi_ort_old, (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_5_idx_exch12_bi_ort_old(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
!
END_DOC
implicit none
integer :: i, j, k, m, l
double precision :: integral, wall1, wall0
provide mos_r_in_r_array_transp mos_l_in_r_array_transp
PROVIDE mo_l_coef mo_r_coef int2_grad1_u12_bimo_t
three_e_5_idx_exch12_bi_ort_old = 0.d0
print *, ' Providing the three_e_5_idx_exch12_bi_ort_old ...'
call wall_time(wall0)
!$OMP PARALLEL &
!$OMP DEFAULT (NONE) &
!$OMP PRIVATE (i,j,k,m,l,integral) &
!$OMP SHARED (mo_num,three_e_5_idx_exch12_bi_ort_old)
!$OMP DO SCHEDULE (dynamic) COLLAPSE(2)
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
call give_integrals_3_body_bi_ort(m, l, k, m, i, j, integral)
three_e_5_idx_exch12_bi_ort_old(m,l,j,k,i) = -1.d0 * integral
enddo
enddo
enddo
enddo
enddo
!$OMP END DO
!$OMP END PARALLEL
call wall_time(wall1)
print *, ' wall time for three_e_5_idx_exch12_bi_ort_old', wall1 - wall0
END_PROVIDER

153
src/bi_ort_ints/three_body_ints_bi_ort.irp.f
View File

@ -4,7 +4,7 @@
BEGIN_PROVIDER [ double precision, three_body_ints_bi_ort, (mo_num, mo_num, mo_num, mo_num, mo_num, mo_num)] BEGIN_PROVIDER [ double precision, three_body_ints_bi_ort, (mo_num, mo_num, mo_num, mo_num, mo_num, mo_num)]
BEGIN_DOC BEGIN_DOC
! matrix element of the -L three-body operator ! matrix element of the -L three-body operator
! !
! notice the -1 sign: in this way three_body_ints_bi_ort can be directly used to compute Slater rules :) ! notice the -1 sign: in this way three_body_ints_bi_ort can be directly used to compute Slater rules :)
END_DOC END_DOC
@ -12,7 +12,7 @@ BEGIN_PROVIDER [ double precision, three_body_ints_bi_ort, (mo_num, mo_num, mo_n
implicit none implicit none
integer :: i, j, k, l, m, n integer :: i, j, k, l, m, n
double precision :: integral, wall1, wall0 double precision :: integral, wall1, wall0
character*(128) :: name_file character*(128) :: name_file
three_body_ints_bi_ort = 0.d0 three_body_ints_bi_ort = 0.d0
print *, ' Providing the three_body_ints_bi_ort ...' print *, ' Providing the three_body_ints_bi_ort ...'
@ -27,12 +27,15 @@ BEGIN_PROVIDER [ double precision, three_body_ints_bi_ort, (mo_num, mo_num, mo_n
! call read_array_6_index_tensor(mo_num,three_body_ints_bi_ort,name_file) ! call read_array_6_index_tensor(mo_num,three_body_ints_bi_ort,name_file)
! else ! else
!provide x_W_ki_bi_ortho_erf_rk !provide x_W_ki_bi_ortho_erf_rk
provide mos_r_in_r_array_transp mos_l_in_r_array_transp provide mos_r_in_r_array_transp mos_l_in_r_array_transp
provide int2_grad1_u12_ao_transp final_grid_points int2_grad1_u12_bimo_t
provide mo_l_coef mo_r_coef mos_l_in_r_array_transp mos_r_in_r_array_transp n_points_final_grid
!$OMP PARALLEL & !$OMP PARALLEL &
!$OMP DEFAULT (NONE) & !$OMP DEFAULT (NONE) &
!$OMP PRIVATE (i,j,k,l,m,n,integral) & !$OMP PRIVATE (i,j,k,l,m,n,integral) &
!$OMP SHARED (mo_num,three_body_ints_bi_ort) !$OMP SHARED (mo_num,three_body_ints_bi_ort)
!$OMP DO SCHEDULE (dynamic) !$OMP DO SCHEDULE (dynamic)
do i = 1, mo_num do i = 1, mo_num
@ -43,7 +46,7 @@ BEGIN_PROVIDER [ double precision, three_body_ints_bi_ort, (mo_num, mo_num, mo_n
do n = 1, mo_num do n = 1, mo_num
call give_integrals_3_body_bi_ort(n, l, k, m, j, i, integral) call give_integrals_3_body_bi_ort(n, l, k, m, j, i, integral)
three_body_ints_bi_ort(n,l,k,m,j,i) = -1.d0 * integral three_body_ints_bi_ort(n,l,k,m,j,i) = -1.d0 * integral
enddo enddo
enddo enddo
enddo enddo
@ -57,13 +60,70 @@ BEGIN_PROVIDER [ double precision, three_body_ints_bi_ort, (mo_num, mo_num, mo_n
call wall_time(wall1) call wall_time(wall1)
print *, ' wall time for three_body_ints_bi_ort', wall1 - wall0 print *, ' wall time for three_body_ints_bi_ort', wall1 - wall0
call print_memory_usage()
! if(write_three_body_ints_bi_ort)then ! if(write_three_body_ints_bi_ort)then
! print*,'Writing three_body_ints_bi_ort on disk ...' ! print*,'Writing three_body_ints_bi_ort on disk ...'
! call write_array_6_index_tensor(mo_num,three_body_ints_bi_ort,name_file) ! call write_array_6_index_tensor(mo_num,three_body_ints_bi_ort,name_file)
! call ezfio_set_three_body_ints_bi_ort_io_three_body_ints_bi_ort("Read") ! call ezfio_set_three_body_ints_bi_ort_io_three_body_ints_bi_ort("Read")
! endif ! endif
END_PROVIDER END_PROVIDER
! ---
subroutine give_integrals_3_body_bi_ort_spin( n, sigma_n, l, sigma_l, k, sigma_k &
, m, sigma_m, j, sigma_j, i, sigma_i &
, integral)
BEGIN_DOC
!
! < n l k | L | m j i > with a BI-ORTHONORMAL SPIN-ORBITALS
!
! /!\ L is defined without the 1/6 factor
!
END_DOC
implicit none
integer, intent(in) :: n, l, k, m, j, i
double precision, intent(in) :: sigma_n, sigma_l, sigma_k, sigma_m, sigma_j, sigma_i
double precision, intent(out) :: integral
integer :: ipoint
double precision :: weight, tmp
logical, external :: is_same_spin
integral = 0.d0
if( is_same_spin(sigma_n, sigma_m) .and. &
is_same_spin(sigma_l, sigma_j) .and. &
is_same_spin(sigma_k, sigma_i) ) then
PROVIDE mo_l_coef mo_r_coef
PROVIDE int2_grad1_u12_bimo_t
do ipoint = 1, n_points_final_grid
tmp = mos_l_in_r_array_transp(ipoint,k) * mos_r_in_r_array_transp(ipoint,i) &
* ( int2_grad1_u12_bimo_t(ipoint,1,n,m) * int2_grad1_u12_bimo_t(ipoint,1,l,j) &
+ int2_grad1_u12_bimo_t(ipoint,2,n,m) * int2_grad1_u12_bimo_t(ipoint,2,l,j) &
+ int2_grad1_u12_bimo_t(ipoint,3,n,m) * int2_grad1_u12_bimo_t(ipoint,3,l,j) )
tmp = tmp + mos_l_in_r_array_transp(ipoint,l) * mos_r_in_r_array_transp(ipoint,j) &
* ( int2_grad1_u12_bimo_t(ipoint,1,n,m) * int2_grad1_u12_bimo_t(ipoint,1,k,i) &
+ int2_grad1_u12_bimo_t(ipoint,2,n,m) * int2_grad1_u12_bimo_t(ipoint,2,k,i) &
+ int2_grad1_u12_bimo_t(ipoint,3,n,m) * int2_grad1_u12_bimo_t(ipoint,3,k,i) )
tmp = tmp + mos_l_in_r_array_transp(ipoint,n) * mos_r_in_r_array_transp(ipoint,m) &
* ( int2_grad1_u12_bimo_t(ipoint,1,l,j) * int2_grad1_u12_bimo_t(ipoint,1,k,i) &
+ int2_grad1_u12_bimo_t(ipoint,2,l,j) * int2_grad1_u12_bimo_t(ipoint,2,k,i) &
+ int2_grad1_u12_bimo_t(ipoint,3,l,j) * int2_grad1_u12_bimo_t(ipoint,3,k,i) )
integral = integral + tmp * final_weight_at_r_vector(ipoint)
enddo
endif
return
end subroutine give_integrals_3_body_bi_ort_spin
! --- ! ---
@ -71,7 +131,9 @@ subroutine give_integrals_3_body_bi_ort(n, l, k, m, j, i, integral)
BEGIN_DOC BEGIN_DOC
! !
! < n l k | -L | m j i > with a BI-ORTHONORMAL MOLECULAR ORBITALS ! < n l k | L | m j i > with a BI-ORTHONORMAL MOLECULAR ORBITALS
!
! /!\ L is defined without the 1/6 factor
! !
END_DOC END_DOC
@ -79,25 +141,31 @@ subroutine give_integrals_3_body_bi_ort(n, l, k, m, j, i, integral)
integer, intent(in) :: n, l, k, m, j, i integer, intent(in) :: n, l, k, m, j, i
double precision, intent(out) :: integral double precision, intent(out) :: integral
integer :: ipoint integer :: ipoint
double precision :: weight double precision :: weight, tmp
PROVIDE mo_l_coef mo_r_coef
PROVIDE int2_grad1_u12_bimo_t
integral = 0.d0 integral = 0.d0
! (n, l, k, m, j, i)
do ipoint = 1, n_points_final_grid do ipoint = 1, n_points_final_grid
weight = final_weight_at_r_vector(ipoint)
integral += weight * mos_l_in_r_array_transp(ipoint,k) * mos_r_in_r_array_transp(ipoint,i) & tmp = mos_l_in_r_array_transp(ipoint,k) * mos_r_in_r_array_transp(ipoint,i) &
* ( int2_grad1_u12_bimo_t(ipoint,1,n,m) * int2_grad1_u12_bimo_t(ipoint,1,l,j) & * ( int2_grad1_u12_bimo_t(ipoint,1,n,m) * int2_grad1_u12_bimo_t(ipoint,1,l,j) &
+ int2_grad1_u12_bimo_t(ipoint,2,n,m) * int2_grad1_u12_bimo_t(ipoint,2,l,j) & + int2_grad1_u12_bimo_t(ipoint,2,n,m) * int2_grad1_u12_bimo_t(ipoint,2,l,j) &
+ int2_grad1_u12_bimo_t(ipoint,3,n,m) * int2_grad1_u12_bimo_t(ipoint,3,l,j) ) + int2_grad1_u12_bimo_t(ipoint,3,n,m) * int2_grad1_u12_bimo_t(ipoint,3,l,j) )
integral += weight * mos_l_in_r_array_transp(ipoint,l) * mos_r_in_r_array_transp(ipoint,j) &
* ( int2_grad1_u12_bimo_t(ipoint,1,n,m) * int2_grad1_u12_bimo_t(ipoint,1,k,i) & tmp = tmp + mos_l_in_r_array_transp(ipoint,l) * mos_r_in_r_array_transp(ipoint,j) &
+ int2_grad1_u12_bimo_t(ipoint,2,n,m) * int2_grad1_u12_bimo_t(ipoint,2,k,i) & * ( int2_grad1_u12_bimo_t(ipoint,1,n,m) * int2_grad1_u12_bimo_t(ipoint,1,k,i) &
+ int2_grad1_u12_bimo_t(ipoint,2,n,m) * int2_grad1_u12_bimo_t(ipoint,2,k,i) &
+ int2_grad1_u12_bimo_t(ipoint,3,n,m) * int2_grad1_u12_bimo_t(ipoint,3,k,i) ) + int2_grad1_u12_bimo_t(ipoint,3,n,m) * int2_grad1_u12_bimo_t(ipoint,3,k,i) )
integral += weight * mos_l_in_r_array_transp(ipoint,n) * mos_r_in_r_array_transp(ipoint,m) &
* ( int2_grad1_u12_bimo_t(ipoint,1,l,j) * int2_grad1_u12_bimo_t(ipoint,1,k,i) & tmp = tmp + mos_l_in_r_array_transp(ipoint,n) * mos_r_in_r_array_transp(ipoint,m) &
+ int2_grad1_u12_bimo_t(ipoint,2,l,j) * int2_grad1_u12_bimo_t(ipoint,2,k,i) & * ( int2_grad1_u12_bimo_t(ipoint,1,l,j) * int2_grad1_u12_bimo_t(ipoint,1,k,i) &
+ int2_grad1_u12_bimo_t(ipoint,2,l,j) * int2_grad1_u12_bimo_t(ipoint,2,k,i) &
+ int2_grad1_u12_bimo_t(ipoint,3,l,j) * int2_grad1_u12_bimo_t(ipoint,3,k,i) ) + int2_grad1_u12_bimo_t(ipoint,3,l,j) * int2_grad1_u12_bimo_t(ipoint,3,k,i) )
integral = integral + tmp * final_weight_at_r_vector(ipoint)
enddo enddo
end subroutine give_integrals_3_body_bi_ort end subroutine give_integrals_3_body_bi_ort
@ -108,7 +176,9 @@ subroutine give_integrals_3_body_bi_ort_old(n, l, k, m, j, i, integral)
BEGIN_DOC BEGIN_DOC
! !
! < n l k | -L | m j i > with a BI-ORTHONORMAL MOLECULAR ORBITALS ! < n l k | L | m j i > with a BI-ORTHONORMAL MOLECULAR ORBITALS
!
! /!\ L is defined without the 1/6 factor
! !
END_DOC END_DOC
@ -120,41 +190,12 @@ subroutine give_integrals_3_body_bi_ort_old(n, l, k, m, j, i, integral)
integral = 0.d0 integral = 0.d0
do ipoint = 1, n_points_final_grid do ipoint = 1, n_points_final_grid
weight = final_weight_at_r_vector(ipoint) weight = final_weight_at_r_vector(ipoint)
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! integral += weight * mos_l_in_r_array_transp(ipoint,k) * mos_r_in_r_array_transp(ipoint,i) &
! integral += weight * mos_l_in_r_array_transp(ipoint,k) * mos_r_in_r_array_transp(ipoint,i) &
! * ( x_W_ki_bi_ortho_erf_rk(ipoint,1,n,m) * x_W_ki_bi_ortho_erf_rk(ipoint,1,l,j) &
! + x_W_ki_bi_ortho_erf_rk(ipoint,2,n,m) * x_W_ki_bi_ortho_erf_rk(ipoint,2,l,j) &
! + x_W_ki_bi_ortho_erf_rk(ipoint,3,n,m) * x_W_ki_bi_ortho_erf_rk(ipoint,3,l,j) )
! integral += weight * mos_l_in_r_array_transp(ipoint,l) * mos_r_in_r_array_transp(ipoint,j) &
! * ( x_W_ki_bi_ortho_erf_rk(ipoint,1,n,m) * x_W_ki_bi_ortho_erf_rk(ipoint,1,k,i) &
! + x_W_ki_bi_ortho_erf_rk(ipoint,2,n,m) * x_W_ki_bi_ortho_erf_rk(ipoint,2,k,i) &
! + x_W_ki_bi_ortho_erf_rk(ipoint,3,n,m) * x_W_ki_bi_ortho_erf_rk(ipoint,3,k,i) )
! integral += weight * mos_l_in_r_array_transp(ipoint,n) * mos_r_in_r_array_transp(ipoint,m) &
! * ( x_W_ki_bi_ortho_erf_rk(ipoint,1,l,j) * x_W_ki_bi_ortho_erf_rk(ipoint,1,k,i) &
! + x_W_ki_bi_ortho_erf_rk(ipoint,2,l,j) * x_W_ki_bi_ortho_erf_rk(ipoint,2,k,i) &
! + x_W_ki_bi_ortho_erf_rk(ipoint,3,l,j) * x_W_ki_bi_ortho_erf_rk(ipoint,3,k,i) )
! integral += weight * mos_l_in_r_array_transp(ipoint,k) * mos_r_in_r_array_transp(ipoint,i) &
! * ( int2_grad1_u12_bimo(1,n,m,ipoint) * int2_grad1_u12_bimo(1,l,j,ipoint) &
! + int2_grad1_u12_bimo(2,n,m,ipoint) * int2_grad1_u12_bimo(2,l,j,ipoint) &
! + int2_grad1_u12_bimo(3,n,m,ipoint) * int2_grad1_u12_bimo(3,l,j,ipoint) )
! integral += weight * mos_l_in_r_array_transp(ipoint,l) * mos_r_in_r_array_transp(ipoint,j) &
! * ( int2_grad1_u12_bimo(1,n,m,ipoint) * int2_grad1_u12_bimo(1,k,i,ipoint) &
! + int2_grad1_u12_bimo(2,n,m,ipoint) * int2_grad1_u12_bimo(2,k,i,ipoint) &
! + int2_grad1_u12_bimo(3,n,m,ipoint) * int2_grad1_u12_bimo(3,k,i,ipoint) )
! integral += weight * mos_l_in_r_array_transp(ipoint,n) * mos_r_in_r_array_transp(ipoint,m) &
! * ( int2_grad1_u12_bimo(1,l,j,ipoint) * int2_grad1_u12_bimo(1,k,i,ipoint) &
! + int2_grad1_u12_bimo(2,l,j,ipoint) * int2_grad1_u12_bimo(2,k,i,ipoint) &
! + int2_grad1_u12_bimo(3,l,j,ipoint) * int2_grad1_u12_bimo(3,k,i,ipoint) )
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
integral += weight * mos_l_in_r_array_transp(ipoint,k) * mos_r_in_r_array_transp(ipoint,i) &
* ( int2_grad1_u12_bimo_transp(n,m,1,ipoint) * int2_grad1_u12_bimo_transp(l,j,1,ipoint) & * ( int2_grad1_u12_bimo_transp(n,m,1,ipoint) * int2_grad1_u12_bimo_transp(l,j,1,ipoint) &
+ int2_grad1_u12_bimo_transp(n,m,2,ipoint) * int2_grad1_u12_bimo_transp(l,j,2,ipoint) & + int2_grad1_u12_bimo_transp(n,m,2,ipoint) * int2_grad1_u12_bimo_transp(l,j,2,ipoint) &
+ int2_grad1_u12_bimo_transp(n,m,3,ipoint) * int2_grad1_u12_bimo_transp(l,j,3,ipoint) ) + int2_grad1_u12_bimo_transp(n,m,3,ipoint) * int2_grad1_u12_bimo_transp(l,j,3,ipoint) )
integral += weight * mos_l_in_r_array_transp(ipoint,l) * mos_r_in_r_array_transp(ipoint,j) & integral += weight * mos_l_in_r_array_transp(ipoint,l) * mos_r_in_r_array_transp(ipoint,j) &
* ( int2_grad1_u12_bimo_transp(n,m,1,ipoint) * int2_grad1_u12_bimo_transp(k,i,1,ipoint) & * ( int2_grad1_u12_bimo_transp(n,m,1,ipoint) * int2_grad1_u12_bimo_transp(k,i,1,ipoint) &
+ int2_grad1_u12_bimo_transp(n,m,2,ipoint) * int2_grad1_u12_bimo_transp(k,i,2,ipoint) & + int2_grad1_u12_bimo_transp(n,m,2,ipoint) * int2_grad1_u12_bimo_transp(k,i,2,ipoint) &
+ int2_grad1_u12_bimo_transp(n,m,3,ipoint) * int2_grad1_u12_bimo_transp(k,i,3,ipoint) ) + int2_grad1_u12_bimo_transp(n,m,3,ipoint) * int2_grad1_u12_bimo_transp(k,i,3,ipoint) )
@ -173,7 +214,9 @@ subroutine give_integrals_3_body_bi_ort_ao(n, l, k, m, j, i, integral)
BEGIN_DOC BEGIN_DOC
! !
! < n l k | -L | m j i > with a BI-ORTHONORMAL ATOMIC ORBITALS ! < n l k | L | m j i > with a BI-ORTHONORMAL ATOMIC ORBITALS
!
! /!\ L is defined without the 1/6 factor
! !
END_DOC END_DOC
@ -185,13 +228,13 @@ subroutine give_integrals_3_body_bi_ort_ao(n, l, k, m, j, i, integral)
integral = 0.d0 integral = 0.d0
do ipoint = 1, n_points_final_grid do ipoint = 1, n_points_final_grid
weight = final_weight_at_r_vector(ipoint) weight = final_weight_at_r_vector(ipoint)
integral += weight * aos_in_r_array_transp(ipoint,k) * aos_in_r_array_transp(ipoint,i) & 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,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,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) ) + 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) & 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,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,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) ) + int2_grad1_u12_ao_t(ipoint,3,n,m) * int2_grad1_u12_ao_t(ipoint,3,k,i) )

256
src/bi_ort_ints/total_twoe_pot.irp.f
View File

@ -20,6 +20,7 @@ BEGIN_PROVIDER [double precision, ao_two_e_vartc_tot, (ao_num, ao_num, ao_num, a
enddo enddo
END_PROVIDER END_PROVIDER
! --- ! ---
BEGIN_PROVIDER [double precision, ao_two_e_tc_tot, (ao_num, ao_num, ao_num, ao_num) ] BEGIN_PROVIDER [double precision, ao_two_e_tc_tot, (ao_num, ao_num, ao_num, ao_num) ]
@ -40,20 +41,7 @@ BEGIN_PROVIDER [double precision, ao_two_e_tc_tot, (ao_num, ao_num, ao_num, ao_n
provide j1b_type provide j1b_type
if(j1b_type .eq. 3) then if(j1b_type .eq. 0) then
do j = 1, ao_num
do l = 1, ao_num
do i = 1, ao_num
do k = 1, ao_num
ao_two_e_tc_tot(k,i,l,j) = ao_tc_int_chemist(k,i,l,j)
!write(222,*) ao_two_e_tc_tot(k,i,l,j)
enddo
enddo
enddo
enddo
else
PROVIDE ao_tc_sym_two_e_pot_in_map PROVIDE ao_tc_sym_two_e_pot_in_map
@ -77,6 +65,23 @@ BEGIN_PROVIDER [double precision, ao_two_e_tc_tot, (ao_num, ao_num, ao_num, ao_n
enddo enddo
enddo enddo
else
PROVIDE ao_tc_int_chemist
do j = 1, ao_num
do l = 1, ao_num
do i = 1, ao_num
do k = 1, ao_num
ao_two_e_tc_tot(k,i,l,j) = ao_tc_int_chemist(k,i,l,j)
!write(222,*) ao_two_e_tc_tot(k,i,l,j)
enddo
enddo
enddo
enddo
FREE ao_tc_int_chemist
endif endif
END_PROVIDER END_PROVIDER
@ -125,69 +130,99 @@ BEGIN_PROVIDER [double precision, mo_bi_ortho_tc_two_e_chemist, (mo_num, mo_num,
implicit none implicit none
integer :: i, j, k, l, m, n, p, q integer :: i, j, k, l, m, n, p, q
double precision, allocatable :: mo_tmp_1(:,:,:,:), mo_tmp_2(:,:,:,:) double precision, allocatable :: a1(:,:,:,:), a2(:,:,:,:)
allocate(mo_tmp_1(mo_num,ao_num,ao_num,ao_num)) PROVIDE mo_r_coef mo_l_coef
mo_tmp_1 = 0.d0
do m = 1, ao_num allocate(a2(ao_num,ao_num,ao_num,mo_num))
do p = 1, ao_num
do n = 1, ao_num
do q = 1, ao_num
do k = 1, mo_num
! (k n|p m) = sum_q c_qk * (q n|p m)
mo_tmp_1(k,n,p,m) += mo_l_coef_transp(k,q) * ao_two_e_tc_tot(q,n,p,m)
enddo
enddo
enddo
enddo
enddo
allocate(mo_tmp_2(mo_num,mo_num,ao_num,ao_num)) call dgemm( 'T', 'N', ao_num*ao_num*ao_num, mo_num, ao_num, 1.d0 &
mo_tmp_2 = 0.d0 , ao_two_e_tc_tot(1,1,1,1), ao_num, mo_l_coef(1,1), ao_num &
, 0.d0 , a2(1,1,1,1), ao_num*ao_num*ao_num)
do m = 1, ao_num allocate(a1(ao_num,ao_num,mo_num,mo_num))
do p = 1, ao_num
do n = 1, ao_num
do i = 1, mo_num
do k = 1, mo_num
! (k i|p m) = sum_n c_ni * (k n|p m)
mo_tmp_2(k,i,p,m) += mo_r_coef_transp(i,n) * mo_tmp_1(k,n,p,m)
enddo
enddo
enddo
enddo
enddo
deallocate(mo_tmp_1)
allocate(mo_tmp_1(mo_num,mo_num,mo_num,ao_num)) call dgemm( 'T', 'N', ao_num*ao_num*mo_num, mo_num, ao_num, 1.d0 &
mo_tmp_1 = 0.d0 , a2(1,1,1,1), ao_num, mo_r_coef(1,1), ao_num &
do m = 1, ao_num , 0.d0, a1(1,1,1,1), ao_num*ao_num*mo_num)
do p = 1, ao_num
do l = 1, mo_num
do i = 1, mo_num
do k = 1, mo_num
mo_tmp_1(k,i,l,m) += mo_l_coef_transp(l,p) * mo_tmp_2(k,i,p,m)
enddo
enddo
enddo
enddo
enddo
deallocate(mo_tmp_2)
mo_bi_ortho_tc_two_e_chemist = 0.d0 deallocate(a2)
do m = 1, ao_num allocate(a2(ao_num,mo_num,mo_num,mo_num))
do j = 1, mo_num
do l = 1, mo_num call dgemm( 'T', 'N', ao_num*mo_num*mo_num, mo_num, ao_num, 1.d0 &
do i = 1, mo_num , a1(1,1,1,1), ao_num, mo_l_coef(1,1), ao_num &
do k = 1, mo_num , 0.d0, a2(1,1,1,1), ao_num*mo_num*mo_num)
mo_bi_ortho_tc_two_e_chemist(k,i,l,j) += mo_r_coef_transp(j,m) * mo_tmp_1(k,i,l,m)
enddo deallocate(a1)
enddo
enddo call dgemm( 'T', 'N', mo_num*mo_num*mo_num, mo_num, ao_num, 1.d0 &
enddo , a2(1,1,1,1), ao_num, mo_r_coef(1,1), ao_num &
enddo , 0.d0, mo_bi_ortho_tc_two_e_chemist(1,1,1,1), mo_num*mo_num*mo_num)
deallocate(mo_tmp_1)
deallocate(a2)
!allocate(a1(mo_num,ao_num,ao_num,ao_num))
!a1 = 0.d0
!do m = 1, ao_num
! do p = 1, ao_num
! do n = 1, ao_num
! do q = 1, ao_num
! do k = 1, mo_num
! ! (k n|p m) = sum_q c_qk * (q n|p m)
! a1(k,n,p,m) += mo_l_coef_transp(k,q) * ao_two_e_tc_tot(q,n,p,m)
! enddo
! enddo
! enddo
! enddo
!enddo
!allocate(a2(mo_num,mo_num,ao_num,ao_num))
!a2 = 0.d0
!do m = 1, ao_num
! do p = 1, ao_num
! do n = 1, ao_num
! do i = 1, mo_num
! do k = 1, mo_num
! ! (k i|p m) = sum_n c_ni * (k n|p m)
! a2(k,i,p,m) += mo_r_coef_transp(i,n) * a1(k,n,p,m)
! enddo
! enddo
! enddo
! enddo
!enddo
!deallocate(a1)
!allocate(a1(mo_num,mo_num,mo_num,ao_num))
!a1 = 0.d0
!do m = 1, ao_num
! do p = 1, ao_num
! do l = 1, mo_num
! do i = 1, mo_num
! do k = 1, mo_num
! a1(k,i,l,m) += mo_l_coef_transp(l,p) * a2(k,i,p,m)
! enddo
! enddo
! enddo
! enddo
!enddo
!deallocate(a2)
!mo_bi_ortho_tc_two_e_chemist = 0.d0
!do m = 1, ao_num
! do j = 1, mo_num
! do l = 1, mo_num
! do i = 1, mo_num
! do k = 1, mo_num
! mo_bi_ortho_tc_two_e_chemist(k,i,l,j) += mo_r_coef_transp(j,m) * a1(k,i,l,m)
! enddo
! enddo
! enddo
! enddo
!enddo
!deallocate(a1)
END_PROVIDER END_PROVIDER
@ -206,6 +241,8 @@ BEGIN_PROVIDER [double precision, mo_bi_ortho_tc_two_e, (mo_num, mo_num, mo_num,
implicit none implicit none
integer :: i, j, k, l integer :: i, j, k, l
PROVIDE mo_bi_ortho_tc_two_e_chemist
do j = 1, mo_num do j = 1, mo_num
do i = 1, mo_num do i = 1, mo_num
do l = 1, mo_num do l = 1, mo_num
@ -217,56 +254,71 @@ BEGIN_PROVIDER [double precision, mo_bi_ortho_tc_two_e, (mo_num, mo_num, mo_num,
enddo enddo
enddo enddo
FREE mo_bi_ortho_tc_two_e_chemist
if(noL_standard) then
PROVIDE noL_2e
! x 2 because of the Slater-Condon rules convention
mo_bi_ortho_tc_two_e = mo_bi_ortho_tc_two_e + 2.d0 * noL_2e
FREE noL_2e
endif
END_PROVIDER 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, (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_exchange, (mo_num,mo_num)]
&BEGIN_PROVIDER [ double precision, mo_bi_ortho_tc_two_e_jj_anti, (mo_num,mo_num) ] &BEGIN_PROVIDER [ double precision, mo_bi_ortho_tc_two_e_jj_anti, (mo_num,mo_num)]
implicit none
BEGIN_DOC BEGIN_DOC
! mo_bi_ortho_tc_two_e_jj(i,j) = J_ij = <ji|W-K|ji> !
! 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_exchange(i,j) = K_ij = <ij|W-K|ji>
! mo_bi_ortho_tc_two_e_jj_anti(i,j) = J_ij - K_ij ! mo_bi_ortho_tc_two_e_jj_anti (i,j) = J_ij - K_ij
!
END_DOC END_DOC
integer :: i,j implicit none
double precision :: get_two_e_integral integer :: i, j
mo_bi_ortho_tc_two_e_jj = 0.d0 mo_bi_ortho_tc_two_e_jj = 0.d0
mo_bi_ortho_tc_two_e_jj_exchange = 0.d0 mo_bi_ortho_tc_two_e_jj_exchange = 0.d0
do i=1,mo_num do i = 1, mo_num
do j=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 (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_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) 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
enddo enddo
END_PROVIDER 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 BEGIN_PROVIDER [double precision, tc_2e_3idx_coulomb_integrals , (mo_num,mo_num,mo_num)]
do k = 1, mo_num &BEGIN_PROVIDER [double precision, tc_2e_3idx_exchange_integrals, (mo_num,mo_num,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 ) BEGIN_DOC
tc_2e_3idx_exchange_integrals(j,k,i) = mo_bi_ortho_tc_two_e(k ,j ,j ,i ) ! tc_2e_3idx_coulomb_integrals (j,k,i) = <jk|ji>
enddo ! tc_2e_3idx_exchange_integrals(j,k,i) = <kj|ji>
END_DOC
implicit none
integer :: i, j, k
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 enddo
enddo
END_PROVIDER END_PROVIDER
! ---

2
src/bi_ortho_mos/bi_density.irp.f
View File

@ -15,7 +15,6 @@ BEGIN_PROVIDER [double precision, TCSCF_bi_ort_dm_ao_alpha, (ao_num, ao_num) ]
call dgemm( 'N', 'T', ao_num, ao_num, elec_alpha_num, 1.d0 & 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_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) ) , 0.d0, TCSCF_bi_ort_dm_ao_alpha, size(TCSCF_bi_ort_dm_ao_alpha, 1) )
END_PROVIDER END_PROVIDER
@ -36,7 +35,6 @@ BEGIN_PROVIDER [ double precision, TCSCF_bi_ort_dm_ao_beta, (ao_num, ao_num) ]
call dgemm( 'N', 'T', ao_num, ao_num, elec_beta_num, 1.d0 & 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_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) ) , 0.d0, TCSCF_bi_ort_dm_ao_beta, size(TCSCF_bi_ort_dm_ao_beta, 1) )
END_PROVIDER END_PROVIDER

6
src/bi_ortho_mos/bi_ort_mos_in_r.irp.f
View File

@ -46,7 +46,7 @@ BEGIN_PROVIDER[double precision, mos_r_in_r_array_transp, (n_points_final_grid,
mos_r_in_r_array_transp(i,j) = mos_r_in_r_array(j,i) mos_r_in_r_array_transp(i,j) = mos_r_in_r_array(j,i)
enddo enddo
enddo enddo
END_PROVIDER END_PROVIDER
! --- ! ---
@ -116,7 +116,7 @@ end subroutine give_all_mos_l_at_r
! --- ! ---
BEGIN_PROVIDER[double precision, mos_l_in_r_array_transp,(n_points_final_grid,mo_num)] BEGIN_PROVIDER[double precision, mos_l_in_r_array_transp, (n_points_final_grid,mo_num)]
BEGIN_DOC BEGIN_DOC
! mos_l_in_r_array_transp(i,j) = value of the jth mo on the ith grid point ! mos_l_in_r_array_transp(i,j) = value of the jth mo on the ith grid point
@ -130,7 +130,7 @@ BEGIN_PROVIDER[double precision, mos_l_in_r_array_transp,(n_points_final_grid,mo
mos_l_in_r_array_transp(i,j) = mos_l_in_r_array(j,i) mos_l_in_r_array_transp(i,j) = mos_l_in_r_array(j,i)
enddo enddo
enddo enddo
END_PROVIDER END_PROVIDER
! --- ! ---

7
src/bi_ortho_mos/mos_rl.irp.f
View File

@ -17,6 +17,8 @@ subroutine ao_to_mo_bi_ortho(A_ao, LDA_ao, A_mo, LDA_mo)
double precision, intent(out) :: A_mo(LDA_mo,mo_num) double precision, intent(out) :: A_mo(LDA_mo,mo_num)
double precision, allocatable :: T(:,:) double precision, allocatable :: T(:,:)
PROVIDE mo_l_coef mo_r_coef
allocate ( T(ao_num,mo_num) ) allocate ( T(ao_num,mo_num) )
!DIR$ ATTRIBUTES ALIGN : $IRP_ALIGN :: T !DIR$ ATTRIBUTES ALIGN : $IRP_ALIGN :: T
@ -30,7 +32,6 @@ subroutine ao_to_mo_bi_ortho(A_ao, LDA_ao, A_mo, LDA_mo)
, mo_l_coef, size(mo_l_coef, 1), T, size(T, 1) & , mo_l_coef, size(mo_l_coef, 1), T, size(T, 1) &
, 0.d0, A_mo, LDA_mo ) , 0.d0, A_mo, LDA_mo )
! call restore_symmetry(mo_num,mo_num,A_mo,size(A_mo,1),1.d-12)
deallocate(T) deallocate(T)
end subroutine ao_to_mo_bi_ortho end subroutine ao_to_mo_bi_ortho
@ -54,6 +55,8 @@ subroutine mo_to_ao_bi_ortho(A_mo, LDA_mo, A_ao, LDA_ao)
double precision, intent(out) :: A_ao(LDA_ao,ao_num) double precision, intent(out) :: A_ao(LDA_ao,ao_num)
double precision, allocatable :: tmp_1(:,:), tmp_2(:,:) double precision, allocatable :: tmp_1(:,:), tmp_2(:,:)
PROVIDE mo_l_coef mo_r_coef
! ao_overlap x mo_r_coef ! ao_overlap x mo_r_coef
allocate( tmp_1(ao_num,mo_num) ) allocate( tmp_1(ao_num,mo_num) )
call dgemm( 'N', 'N', ao_num, mo_num, ao_num, 1.d0 & call dgemm( 'N', 'N', ao_num, mo_num, ao_num, 1.d0 &
@ -132,6 +135,7 @@ BEGIN_PROVIDER [ double precision, mo_r_coef, (ao_num, mo_num) ]
mo_r_coef(j,i) = mo_coef(j,i) mo_r_coef(j,i) = mo_coef(j,i)
enddo enddo
enddo enddo
call ezfio_set_bi_ortho_mos_mo_r_coef(mo_r_coef)
endif endif
END_PROVIDER END_PROVIDER
@ -187,6 +191,7 @@ BEGIN_PROVIDER [ double precision, mo_l_coef, (ao_num, mo_num) ]
mo_l_coef(j,i) = mo_coef(j,i) mo_l_coef(j,i) = mo_coef(j,i)
enddo enddo
enddo enddo
call ezfio_set_bi_ortho_mos_mo_l_coef(mo_l_coef)
endif endif
END_PROVIDER END_PROVIDER

92
src/bi_ortho_mos/overlap.irp.f
View File

@ -12,32 +12,27 @@
double precision :: accu_d, accu_nd double precision :: accu_d, accu_nd
double precision, allocatable :: tmp(:,:) double precision, allocatable :: tmp(:,:)
! TODO : re do the DEGEMM ! overlap_bi_ortho = 0.d0
! do i = 1, mo_num
! do k = 1, mo_num
! do m = 1, ao_num
! do n = 1, ao_num
! overlap_bi_ortho(k,i) += ao_overlap(n,m) * mo_l_coef(n,k) * mo_r_coef(m,i)
! enddo
! enddo
! enddo
! enddo
overlap_bi_ortho = 0.d0 allocate( tmp(mo_num,ao_num) )
do i = 1, mo_num ! tmp <-- L.T x S_ao
do k = 1, mo_num call dgemm( "T", "N", mo_num, ao_num, ao_num, 1.d0 &
do m = 1, ao_num , mo_l_coef(1,1), size(mo_l_coef, 1), ao_overlap(1,1), size(ao_overlap, 1) &
do n = 1, ao_num , 0.d0, tmp(1,1), size(tmp, 1) )
overlap_bi_ortho(k,i) += ao_overlap(n,m) * mo_l_coef(n,k) * mo_r_coef(m,i) ! S <-- tmp x R
enddo call dgemm( "N", "N", mo_num, mo_num, ao_num, 1.d0 &
enddo , tmp(1,1), size(tmp, 1), mo_r_coef(1,1), size(mo_r_coef, 1) &
enddo , 0.d0, overlap_bi_ortho(1,1), size(overlap_bi_ortho, 1) )
enddo deallocate(tmp)
! allocate( tmp(mo_num,ao_num) )
!
! ! tmp <-- L.T x S_ao
! call dgemm( "T", "N", mo_num, ao_num, ao_num, 1.d0 &
! , mo_l_coef, size(mo_l_coef, 1), ao_overlap, size(ao_overlap, 1) &
! , 0.d0, tmp, size(tmp, 1) )
!
! ! S <-- tmp x R
! call dgemm( "N", "N", mo_num, mo_num, ao_num, 1.d0 &
! , tmp, size(tmp, 1), mo_r_coef, size(mo_r_coef, 1) &
! , 0.d0, overlap_bi_ortho, size(overlap_bi_ortho, 1) )
!
! deallocate( tmp )
do i = 1, mo_num do i = 1, mo_num
overlap_diag_bi_ortho(i) = overlap_bi_ortho(i,i) overlap_diag_bi_ortho(i) = overlap_bi_ortho(i,i)
@ -84,20 +79,41 @@ END_PROVIDER
END_DOC END_DOC
implicit none implicit none
integer :: i, j, p, q integer :: i, j, p, q
double precision, allocatable :: tmp(:,:)
overlap_mo_r = 0.d0 !overlap_mo_r = 0.d0
overlap_mo_l = 0.d0 !overlap_mo_l = 0.d0
do i = 1, mo_num !do i = 1, mo_num
do j = 1, mo_num ! do j = 1, mo_num
do p = 1, ao_num ! do p = 1, ao_num
do q = 1, ao_num ! do q = 1, ao_num
overlap_mo_r(j,i) += mo_r_coef(q,i) * mo_r_coef(p,j) * ao_overlap(q,p) ! overlap_mo_r(j,i) += mo_r_coef(q,i) * mo_r_coef(p,j) * ao_overlap(q,p)
overlap_mo_l(j,i) += mo_l_coef(q,i) * mo_l_coef(p,j) * ao_overlap(q,p) ! overlap_mo_l(j,i) += mo_l_coef(q,i) * mo_l_coef(p,j) * ao_overlap(q,p)
enddo ! enddo
enddo ! enddo
enddo ! enddo
enddo !enddo
allocate( tmp(mo_num,ao_num) )
tmp = 0.d0
call dgemm( "T", "N", mo_num, ao_num, ao_num, 1.d0 &
, mo_r_coef(1,1), size(mo_r_coef, 1), ao_overlap(1,1), size(ao_overlap, 1) &
, 0.d0, tmp(1,1), size(tmp, 1) )
call dgemm( "N", "N", mo_num, mo_num, ao_num, 1.d0 &
, tmp(1,1), size(tmp, 1), mo_r_coef(1,1), size(mo_r_coef, 1) &
, 0.d0, overlap_mo_r(1,1), size(overlap_mo_r, 1) )
tmp = 0.d0
call dgemm( "T", "N", mo_num, ao_num, ao_num, 1.d0 &
, mo_l_coef(1,1), size(mo_l_coef, 1), ao_overlap(1,1), size(ao_overlap, 1) &
, 0.d0, tmp(1,1), size(tmp, 1) )
call dgemm( "N", "N", mo_num, mo_num, ao_num, 1.d0 &
, tmp(1,1), size(tmp, 1), mo_l_coef(1,1), size(mo_l_coef, 1) &
, 0.d0, overlap_mo_l(1,1), size(overlap_mo_l, 1) )
deallocate(tmp)
END_PROVIDER END_PROVIDER

49
src/casscf_cipsi/50.casscf.bats Normal file
View File

@ -0,0 +1,49 @@
#!/usr/bin/env bats
source $QP_ROOT/tests/bats/common.bats.sh
source $QP_ROOT/quantum_package.rc
function run_stoch() {
thresh=$2
test_exe casscf || skip
qp set perturbation do_pt2 True
qp set determinants n_det_max $3
qp set davidson threshold_davidson 1.e-10
qp set davidson n_states_diag 4
qp run casscf | tee casscf.out
energy1="$(ezfio get casscf energy_pt2 | tr '[]' ' ' | cut -d ',' -f 1)"
eq $energy1 $1 $thresh
}
@test "F2" { # 18.0198s
rm -rf f2_casscf
qp_create_ezfio -b aug-cc-pvdz ../input/f2.zmt -o f2_casscf
qp set_file f2_casscf
qp run scf
qp set_mo_class --core="[1-6,8-9]" --act="[7,10]" --virt="[11-46]"
run_stoch -198.773366970 1.e-4 100000
}
@test "N2" { # 18.0198s
rm -rf n2_casscf
qp_create_ezfio -b aug-cc-pvdz ../input/n2.xyz -o n2_casscf
qp set_file n2_casscf
qp run scf
qp set_mo_class --core="[1-4]" --act="[5-10]" --virt="[11-46]"
run_stoch -109.0961643162 1.e-4 100000
}
@test "N2_stretched" {
rm -rf n2_stretched_casscf
qp_create_ezfio -b aug-cc-pvdz -m 7 ../input/n2_stretched.xyz -o n2_stretched_casscf
qp set_file n2_stretched_casscf
qp run scf | tee scf.out
qp set_mo_class --core="[1-4]" --act="[5-10]" --virt="[11-46]"
qp set electrons elec_alpha_num 7
qp set electrons elec_beta_num 7
run_stoch -108.7860471300 1.e-4 100000
#
}

81
src/casscf_cipsi/EZFIO.cfg Normal file
View File

@ -0,0 +1,81 @@
[energy]
type: double precision
doc: Calculated Selected |FCI| energy
interface: ezfio
size: (determinants.n_states)
[energy_pt2]
type: double precision
doc: Calculated |FCI| energy + |PT2|
interface: ezfio
size: (determinants.n_states)
[state_following_casscf]
type: logical
doc: If |true|, the CASSCF will try to follow the guess CI vector and orbitals
interface: ezfio,provider,ocaml
default: False
[diag_hess_cas]
type: logical
doc: If |true|, only the DIAGONAL part of the hessian is retained for the CASSCF
interface: ezfio,provider,ocaml
default: False
[hess_cv_cv]
type: logical
doc: If |true|, the core-virtual - core-virtual part of the hessian is computed
interface: ezfio,provider,ocaml
default: True
[level_shift_casscf]
type: Positive_float
doc: Energy shift on the virtual MOs to improve SCF convergence
interface: ezfio,provider,ocaml
default: 0.005
[fast_2rdm]
type: logical
doc: If true, the two-rdm are computed with a fast algo
interface: ezfio,provider,ocaml
default: True
[criterion_casscf]
type: character*(32)
doc: choice of the criterion for the convergence of the casscf: can be energy or gradients or e_pt2
interface: ezfio, provider, ocaml
default: e_pt2
[thresh_casscf]
type: Threshold
doc: Threshold on the convergence of the CASCF energy.
interface: ezfio,provider,ocaml
default: 1.e-06
[pt2_min_casscf]
type: Threshold
doc: Minimum value of the pt2_max parameter for the CIPSI in the CASSCF iterations.
interface: ezfio,provider,ocaml
default: 1.e-04
[n_big_act_orb]
type: integer
doc: Number of active orbitals from which the active space is considered as large, and therefore pt2_min_casscf is activated.
interface: ezfio,provider,ocaml
default: 16
[adaptive_pt2_max]
type: logical
doc: If |true|, the pt2_max value in the CIPSI iterations will automatically adapt, otherwise it is fixed at the value given in the EZFIO folder
interface: ezfio,provider,ocaml
default: True
[small_active_space]
type: logical
doc: If |true|, the pt2_max value in the CIPSI is set to 10-10 and will not change
interface: ezfio,provider,ocaml
default: False

5
src/casscf_cipsi/NEED Normal file
View File

@ -0,0 +1,5 @@
cipsi
selectors_full
generators_cas
two_body_rdm
dav_general_mat

47
src/casscf_cipsi/README.rst Normal file
View File

@ -0,0 +1,47 @@
======
casscf
======
|CASSCF| program with the CIPSI algorithm.
Example of inputs
-----------------
a) Small active space : standard CASSCF
---------------------------------------
Let's do O2 (triplet) in aug-cc-pvdz with the following geometry (xyz format, Bohr units)
3
O 0.0000000000 0.0000000000 -1.1408000000
O 0.0000000000 0.0000000000 1.1408000000
# Create the ezfio folder
qp create_ezfio -b aug-cc-pvdz O2.xyz -m 3 -a -o O2_avdz
# Start with an ROHF guess
qp run scf | tee ${EZFIO_FILE}.rohf.out
# Get the ROHF energy for check
qp get hartree_fock energy # should be -149.4684509
# Define the full valence active space: the two 1s are doubly occupied, the other 8 valence orbitals are active
# CASSCF(12e,10orb)
qp set_mo_class -c "[1-2]" -a "[3-10]" -v "[11-46]"
# Specify that you want an near exact CASSCF, i.e. the CIPSI selection will stop at pt2_max = 10^-10
qp set casscf_cipsi small_active_space True
# RUN THE CASSCF
qp run casscf | tee ${EZFIO_FILE}.casscf.out
# you should find around -149.7243542
b) Large active space : Exploit the selected CI in the active space
-------------------------------------------------------------------
#Let us start from the small active space calculation orbitals and add another 10 virtuals: CASSCF(12e,20orb)
qp set_mo_class -c "[1-2]" -a "[3-20]" -v "[21-46]"
# As this active space is larger, you unset the small_active_space feature
qp set casscf_cipsi small_active_space False
# As it is a large active space, the energy convergence thereshold is set to be 0.0001
qp run casscf | tee ${EZFIO_FILE}.casscf_large.out
# you should find around -149.9046

6
src/casscf_cipsi/bavard.irp.f Normal file
View File

@ -0,0 +1,6 @@
! -*- F90 -*-
BEGIN_PROVIDER [logical, bavard]
! bavard=.true.
bavard=.false.
END_PROVIDER

155
src/casscf_cipsi/bielec.irp.f Normal file
View File

@ -0,0 +1,155 @@
BEGIN_PROVIDER [real*8, bielec_PQxx, (mo_num, mo_num,n_core_inact_act_orb,n_core_inact_act_orb)]
BEGIN_DOC
! bielec_PQxx : integral (pq|xx) with p,q arbitrary, x core or active
! indices are unshifted orbital numbers
END_DOC
implicit none
integer :: i,j,ii,jj,p,q,i3,j3,t3,v3
real*8 :: mo_two_e_integral
bielec_PQxx(:,:,:,:) = 0.d0
PROVIDE mo_two_e_integrals_in_map
!$OMP PARALLEL DEFAULT(NONE) &
!$OMP PRIVATE(i,ii,j,jj,i3,j3) &
!$OMP SHARED(n_core_inact_orb,list_core_inact,mo_num,bielec_PQxx, &
!$OMP n_act_orb,mo_integrals_map,list_act)
!$OMP DO
do i=1,n_core_inact_orb
ii=list_core_inact(i)
do j=i,n_core_inact_orb
jj=list_core_inact(j)
call get_mo_two_e_integrals_i1j1(ii,jj,mo_num,bielec_PQxx(1,1,i,j),mo_integrals_map)
bielec_PQxx(:,:,j,i)=bielec_PQxx(:,:,i,j)
end do
do j=1,n_act_orb
jj=list_act(j)
j3=j+n_core_inact_orb
call get_mo_two_e_integrals_i1j1(ii,jj,mo_num,bielec_PQxx(1,1,i,j3),mo_integrals_map)
bielec_PQxx(:,:,j3,i)=bielec_PQxx(:,:,i,j3)
end do
end do
!$OMP END DO
!$OMP DO
do i=1,n_act_orb
ii=list_act(i)
i3=i+n_core_inact_orb
do j=i,n_act_orb
jj=list_act(j)
j3=j+n_core_inact_orb
call get_mo_two_e_integrals_i1j1(ii,jj,mo_num,bielec_PQxx(1,1,i3,j3),mo_integrals_map)
bielec_PQxx(:,:,j3,i3)=bielec_PQxx(:,:,i3,j3)
end do
end do
!$OMP END DO
!$OMP END PARALLEL
END_PROVIDER
BEGIN_PROVIDER [real*8, bielec_PxxQ, (mo_num,n_core_inact_act_orb,n_core_inact_act_orb, mo_num)]
BEGIN_DOC
! bielec_PxxQ : integral (px|xq) with p,q arbitrary, x core or active
! indices are unshifted orbital numbers
END_DOC
implicit none
integer :: i,j,ii,jj,p,q,i3,j3,t3,v3
double precision, allocatable :: integrals_array(:,:)
real*8 :: mo_two_e_integral
PROVIDE mo_two_e_integrals_in_map
bielec_PxxQ = 0.d0
!$OMP PARALLEL DEFAULT(NONE) &
!$OMP PRIVATE(i,ii,j,jj,i3,j3,integrals_array) &
!$OMP SHARED(n_core_inact_orb,list_core_inact,mo_num,bielec_PxxQ, &
!$OMP n_act_orb,mo_integrals_map,list_act)
allocate(integrals_array(mo_num,mo_num))
!$OMP DO
do i=1,n_core_inact_orb
ii=list_core_inact(i)
do j=i,n_core_inact_orb
jj=list_core_inact(j)
call get_mo_two_e_integrals_ij(ii,jj,mo_num,integrals_array,mo_integrals_map)
do q=1,mo_num
do p=1,mo_num
bielec_PxxQ(p,i,j,q)=integrals_array(p,q)
bielec_PxxQ(p,j,i,q)=integrals_array(q,p)
end do
end do
end do
do j=1,n_act_orb
jj=list_act(j)
j3=j+n_core_inact_orb
call get_mo_two_e_integrals_ij(ii,jj,mo_num,integrals_array,mo_integrals_map)
do q=1,mo_num
do p=1,mo_num
bielec_PxxQ(p,i,j3,q)=integrals_array(p,q)
bielec_PxxQ(p,j3,i,q)=integrals_array(q,p)
end do
end do
end do
end do
!$OMP END DO
! (ip|qj)
!$OMP DO
do i=1,n_act_orb
ii=list_act(i)
i3=i+n_core_inact_orb
do j=i,n_act_orb
jj=list_act(j)
j3=j+n_core_inact_orb
call get_mo_two_e_integrals_ij(ii,jj,mo_num,integrals_array,mo_integrals_map)
do q=1,mo_num
do p=1,mo_num
bielec_PxxQ(p,i3,j3,q)=integrals_array(p,q)
bielec_PxxQ(p,j3,i3,q)=integrals_array(q,p)
end do
end do
end do
end do
!$OMP END DO
deallocate(integrals_array)
!$OMP END PARALLEL
END_PROVIDER
BEGIN_PROVIDER [real*8, bielecCI, (n_act_orb,n_act_orb,n_act_orb, mo_num)]
BEGIN_DOC
! bielecCI : integrals (tu|vp) with p arbitrary, tuv active
! index p runs over the whole basis, t,u,v only over the active orbitals
END_DOC
implicit none
integer :: i,j,k,p,t,u,v
double precision, external :: mo_two_e_integral
PROVIDE mo_two_e_integrals_in_map
!$OMP PARALLEL DO DEFAULT(NONE) &
!$OMP PRIVATE(i,j,k,p,t,u,v) &
!$OMP SHARED(mo_num,n_act_orb,list_act,bielecCI)
do p=1,mo_num
do j=1,n_act_orb
u=list_act(j)
do k=1,n_act_orb
v=list_act(k)
do i=1,n_act_orb
t=list_act(i)
bielecCI(i,k,j,p) = mo_two_e_integral(t,u,v,p)
end do
end do
end do
end do
!$OMP END PARALLEL DO
END_PROVIDER

369
src/casscf_cipsi/bielec_natorb.irp.f Normal file
View File

@ -0,0 +1,369 @@
BEGIN_PROVIDER [real*8, bielec_PQxx_no, (mo_num, mo_num,n_core_inact_act_orb,n_core_inact_act_orb)]
BEGIN_DOC
! integral (pq|xx) in the basis of natural MOs
! indices are unshifted orbital numbers
END_DOC
implicit none
integer :: i,j,k,l,t,u,p,q
double precision, allocatable :: f(:,:,:), d(:,:,:)
!$OMP PARALLEL DEFAULT(NONE) &
!$OMP PRIVATE(j,k,l,p,d,f) &
!$OMP SHARED(n_core_inact_act_orb,mo_num,n_act_orb,n_core_inact_orb, &
!$OMP bielec_PQxx_no,bielec_PQxx,list_act,natorbsCI)
allocate (f(n_act_orb,mo_num,n_core_inact_act_orb), &
d(n_act_orb,mo_num,n_core_inact_act_orb))
!$OMP DO
do l=1,n_core_inact_act_orb
bielec_PQxx_no(:,:,:,l) = bielec_PQxx(:,:,:,l)
do k=1,n_core_inact_act_orb
do j=1,mo_num
do p=1,n_act_orb
f(p,j,k)=bielec_PQxx_no(list_act(p),j,k,l)
end do
end do
end do
call dgemm('T','N',n_act_orb,mo_num*n_core_inact_act_orb,n_act_orb,1.d0, &
natorbsCI, size(natorbsCI,1), &
f, n_act_orb, &
0.d0, &
d, n_act_orb)
do k=1,n_core_inact_act_orb
do j=1,mo_num
do p=1,n_act_orb
bielec_PQxx_no(list_act(p),j,k,l)=d(p,j,k)
end do
end do
do j=1,mo_num
do p=1,n_act_orb
f(p,j,k)=bielec_PQxx_no(j,list_act(p),k,l)
end do
end do
end do
call dgemm('T','N',n_act_orb,mo_num*n_core_inact_act_orb,n_act_orb,1.d0, &
natorbsCI, n_act_orb, &
f, n_act_orb, &
0.d0, &
d, n_act_orb)
do k=1,n_core_inact_act_orb
do p=1,n_act_orb
do j=1,mo_num
bielec_PQxx_no(j,list_act(p),k,l)=d(p,j,k)
end do
end do
end do
end do
!$OMP END DO NOWAIT
deallocate (f,d)
allocate (f(mo_num,mo_num,n_act_orb),d(mo_num,mo_num,n_act_orb))
!$OMP DO
do l=1,n_core_inact_act_orb
do p=1,n_act_orb
do k=1,mo_num
do j=1,mo_num
f(j,k,p) = bielec_PQxx_no(j,k,n_core_inact_orb+p,l)
end do
end do
end do
call dgemm('N','N',mo_num*mo_num,n_act_orb,n_act_orb,1.d0, &
f, mo_num*mo_num, &
natorbsCI, n_act_orb, &
0.d0, &
d, mo_num*mo_num)
do p=1,n_act_orb
do k=1,mo_num
do j=1,mo_num
bielec_PQxx_no(j,k,n_core_inact_orb+p,l)=d(j,k,p)
end do
end do
end do
end do
!$OMP END DO NOWAIT
!$OMP BARRIER
!$OMP DO
do l=1,n_core_inact_act_orb
do p=1,n_act_orb
do k=1,mo_num
do j=1,mo_num
f(j,k,p) = bielec_PQxx_no(j,k,l,n_core_inact_orb+p)
end do
end do
end do
call dgemm('N','N',mo_num*mo_num,n_act_orb,n_act_orb,1.d0, &
f, mo_num*mo_num, &
natorbsCI, n_act_orb, &
0.d0, &
d, mo_num*mo_num)
do p=1,n_act_orb
do k=1,mo_num
do j=1,mo_num
bielec_PQxx_no(j,k,l,n_core_inact_orb+p)=d(j,k,p)
end do
end do
end do
end do
!$OMP END DO
deallocate (f,d)
!$OMP END PARALLEL
END_PROVIDER
BEGIN_PROVIDER [real*8, bielec_PxxQ_no, (mo_num,n_core_inact_act_orb,n_core_inact_act_orb, mo_num)]
BEGIN_DOC
! integral (px|xq) in the basis of natural MOs
! indices are unshifted orbital numbers
END_DOC
implicit none
integer :: i,j,k,l,t,u,p,q
double precision, allocatable :: f(:,:,:), d(:,:,:)
!$OMP PARALLEL DEFAULT(NONE) &
!$OMP PRIVATE(j,k,l,p,d,f) &
!$OMP SHARED(n_core_inact_act_orb,mo_num,n_act_orb,n_core_inact_orb, &
!$OMP bielec_PxxQ_no,bielec_PxxQ,list_act,natorbsCI)
allocate (f(n_act_orb,n_core_inact_act_orb,n_core_inact_act_orb), &
d(n_act_orb,n_core_inact_act_orb,n_core_inact_act_orb))
!$OMP DO
do j=1,mo_num
bielec_PxxQ_no(:,:,:,j) = bielec_PxxQ(:,:,:,j)
do l=1,n_core_inact_act_orb
do k=1,n_core_inact_act_orb
do p=1,n_act_orb
f(p,k,l) = bielec_PxxQ_no(list_act(p),k,l,j)
end do
end do
end do
call dgemm('T','N',n_act_orb,n_core_inact_act_orb**2,n_act_orb,1.d0, &
natorbsCI, size(natorbsCI,1), &
f, n_act_orb, &
0.d0, &
d, n_act_orb)
do l=1,n_core_inact_act_orb
do k=1,n_core_inact_act_orb
do p=1,n_act_orb
bielec_PxxQ_no(list_act(p),k,l,j)=d(p,k,l)
end do
end do
end do
end do
!$OMP END DO NOWAIT
deallocate (f,d)
allocate (f(n_act_orb,mo_num,n_core_inact_act_orb), &
d(n_act_orb,mo_num,n_core_inact_act_orb))
!$OMP DO
do k=1,mo_num
do l=1,n_core_inact_act_orb
do j=1,mo_num
do p=1,n_act_orb
f(p,j,l) = bielec_PxxQ_no(j,n_core_inact_orb+p,l,k)
end do
end do
end do
call dgemm('T','N',n_act_orb,mo_num*n_core_inact_act_orb,n_act_orb,1.d0, &
natorbsCI, size(natorbsCI,1), &
f, n_act_orb, &
0.d0, &
d, n_act_orb)
do l=1,n_core_inact_act_orb
do j=1,mo_num
do p=1,n_act_orb
bielec_PxxQ_no(j,n_core_inact_orb+p,l,k)=d(p,j,l)
end do
end do
end do
end do
!$OMP END DO NOWAIT
deallocate(f,d)
allocate(f(mo_num,n_core_inact_act_orb,n_act_orb), &
d(mo_num,n_core_inact_act_orb,n_act_orb) )
!$OMP DO
do k=1,mo_num
do p=1,n_act_orb
do l=1,n_core_inact_act_orb
do j=1,mo_num
f(j,l,p) = bielec_PxxQ_no(j,l,n_core_inact_orb+p,k)
end do
end do
end do
call dgemm('N','N',mo_num*n_core_inact_act_orb,n_act_orb,n_act_orb,1.d0, &
f, mo_num*n_core_inact_act_orb, &
natorbsCI, size(natorbsCI,1), &
0.d0, &
d, mo_num*n_core_inact_act_orb)
do p=1,n_act_orb
do l=1,n_core_inact_act_orb
do j=1,mo_num
bielec_PxxQ_no(j,l,n_core_inact_orb+p,k)=d(j,l,p)
end do
end do
end do
end do
!$OMP END DO NOWAIT
!$OMP BARRIER
!$OMP DO
do l=1,n_core_inact_act_orb
do p=1,n_act_orb
do k=1,n_core_inact_act_orb
do j=1,mo_num
f(j,k,p) = bielec_PxxQ_no(j,k,l,n_core_inact_orb+p)
end do
end do
end do
call dgemm('N','N',mo_num*n_core_inact_act_orb,n_act_orb,n_act_orb,1.d0, &
f, mo_num*n_core_inact_act_orb, &
natorbsCI, size(natorbsCI,1), &
0.d0, &
d, mo_num*n_core_inact_act_orb)
do p=1,n_act_orb
do k=1,n_core_inact_act_orb
do j=1,mo_num
bielec_PxxQ_no(j,k,l,n_core_inact_orb+p)=d(j,k,p)
end do
end do
end do
end do
!$OMP END DO NOWAIT
deallocate(f,d)
!$OMP END PARALLEL
END_PROVIDER
BEGIN_PROVIDER [real*8, bielecCI_no, (n_act_orb,n_act_orb,n_act_orb, mo_num)]
BEGIN_DOC
! integrals (tu|vp) in the basis of natural MOs
! index p runs over the whole basis, t,u,v only over the active orbitals
END_DOC
implicit none
integer :: i,j,k,l,t,u,p,q
double precision, allocatable :: f(:,:,:), d(:,:,:)
!$OMP PARALLEL DEFAULT(NONE) &
!$OMP PRIVATE(j,k,l,p,d,f) &
!$OMP SHARED(n_core_inact_act_orb,mo_num,n_act_orb,n_core_inact_orb, &
!$OMP bielecCI_no,bielecCI,list_act,natorbsCI)
allocate (f(n_act_orb,n_act_orb,mo_num), &
d(n_act_orb,n_act_orb,mo_num))
!$OMP DO
do l=1,mo_num
bielecCI_no(:,:,:,l) = bielecCI(:,:,:,l)
do k=1,n_act_orb
do j=1,n_act_orb
do p=1,n_act_orb
f(p,j,k)=bielecCI_no(p,j,k,l)
end do
end do
end do
call dgemm('T','N',n_act_orb,n_act_orb*n_act_orb,n_act_orb,1.d0, &
natorbsCI, size(natorbsCI,1), &
f, n_act_orb, &
0.d0, &
d, n_act_orb)
do k=1,n_act_orb
do j=1,n_act_orb
do p=1,n_act_orb
bielecCI_no(p,j,k,l)=d(p,j,k)
end do
end do
do j=1,n_act_orb
do p=1,n_act_orb
f(p,j,k)=bielecCI_no(j,p,k,l)
end do
end do
end do
call dgemm('T','N',n_act_orb,n_act_orb*n_act_orb,n_act_orb,1.d0, &
natorbsCI, n_act_orb, &
f, n_act_orb, &
0.d0, &
d, n_act_orb)
do k=1,n_act_orb
do p=1,n_act_orb
do j=1,n_act_orb
bielecCI_no(j,p,k,l)=d(p,j,k)
end do
end do
end do
do p=1,n_act_orb
do k=1,n_act_orb
do j=1,n_act_orb
f(j,k,p)=bielecCI_no(j,k,p,l)
end do
end do
end do
call dgemm('N','N',n_act_orb*n_act_orb,n_act_orb,n_act_orb,1.d0, &
f, n_act_orb*n_act_orb, &
natorbsCI, n_act_orb, &
0.d0, &
d, n_act_orb*n_act_orb)
do p=1,n_act_orb
do k=1,n_act_orb
do j=1,n_act_orb
bielecCI_no(j,k,p,l)=d(j,k,p)
end do
end do
end do
end do
!$OMP END DO
!$OMP DO
do l=1,n_act_orb
do p=1,n_act_orb
do k=1,n_act_orb
do j=1,n_act_orb
f(j,k,p)=bielecCI_no(j,k,l,list_act(p))
end do
end do
end do
call dgemm('N','N',n_act_orb*n_act_orb,n_act_orb,n_act_orb,1.d0, &
f, n_act_orb*n_act_orb, &
natorbsCI, n_act_orb, &
0.d0, &
d, n_act_orb*n_act_orb)
do p=1,n_act_orb
do k=1,n_act_orb
do j=1,n_act_orb
bielecCI_no(j,k,l,list_act(p))=d(j,k,p)
end do
end do
end do
end do
!$OMP END DO
deallocate(d,f)
!$OMP END PARALLEL
END_PROVIDER

147
src/casscf_cipsi/casscf.irp.f Normal file
View File

@ -0,0 +1,147 @@
program casscf
implicit none
BEGIN_DOC
! TODO : Put the documentation of the program here
END_DOC
call reorder_orbitals_for_casscf
! no_vvvv_integrals = .True.
! touch no_vvvv_integrals
n_det_max_full = 500
touch n_det_max_full
if(small_active_space)then
pt2_relative_error = 0.00001
else
thresh_scf = 1.d-4
pt2_relative_error = 0.04
endif
touch pt2_relative_error
call run
end
subroutine run
implicit none
double precision :: energy_old, energy, pt2_max_before,delta_E
logical :: converged,state_following_casscf_cipsi_save
integer :: iteration,istate
double precision, allocatable :: E_PT2(:), PT2(:), Ev(:), ept2_before(:)
allocate(E_PT2(N_states), PT2(N_states), Ev(N_states), ept2_before(N_states))
converged = .False.
energy = 0.d0
mo_label = "MCSCF"
iteration = 1
state_following_casscf_cipsi_save = state_following_casscf
state_following_casscf = .True.
touch state_following_casscf
ept2_before = 0.d0
if(small_active_space)then
pt2_max = 1.d-10
SOFT_TOUCH pt2_max
else
if(adaptive_pt2_max)then
pt2_max = 0.005
SOFT_TOUCH pt2_max
endif
endif
do while (.not.converged)
print*,'pt2_max = ',pt2_max
call run_stochastic_cipsi(Ev,PT2)
print*,'Ev,PT2',Ev(1),PT2(1)
E_PT2(1:N_states) = Ev(1:N_states) + PT2(1:N_states)
energy_old = energy
energy = eone+etwo+ecore
pt2_max_before = pt2_max
call write_time(6)
call write_int(6,iteration,'CAS-SCF iteration = ')
call write_double(6,energy,'CAS-SCF energy = ')
! if(n_states == 1)then
! call ezfio_get_casscf_cipsi_energy_pt2(E_PT2)
! call ezfio_get_casscf_cipsi_energy(PT2)
call write_double(6,E_PT2(1:N_states),'E + PT2 energy = ')
call write_double(6,PT2(1:N_states),' PT2 = ')
call write_double(6,pt2_max,' PT2_MAX = ')
! endif
print*,''
call write_double(6,norm_grad_vec2,'Norm of gradients = ')
call write_double(6,norm_grad_vec2_tab(1), ' Core-active gradients = ')
call write_double(6,norm_grad_vec2_tab(2), ' Core-virtual gradients = ')
call write_double(6,norm_grad_vec2_tab(3), ' Active-virtual gradients = ')
print*,''
call write_double(6,energy_improvement, 'Predicted energy improvement = ')
if(criterion_casscf == "energy")then
converged = dabs(energy_improvement) < thresh_scf
else if (criterion_casscf == "gradients")then
converged = norm_grad_vec2 < thresh_scf
else if (criterion_casscf == "e_pt2")then
delta_E = 0.d0
do istate = 1, N_states
delta_E += dabs(E_PT2(istate) - ept2_before(istate))
enddo
converged = dabs(delta_E) < thresh_casscf
endif
ept2_before = E_PT2
if(.not.small_active_space)then
if(adaptive_pt2_max)then
pt2_max = dabs(energy_improvement / (pt2_relative_error))
pt2_max = min(pt2_max, pt2_max_before)
if(n_act_orb.ge.n_big_act_orb)then
pt2_max = max(pt2_max,pt2_min_casscf)
endif
endif
endif
print*,''
call write_double(6,pt2_max, 'PT2_MAX for next iteration = ')
mo_coef = NewOrbs
mo_occ = occnum
call save_mos
if(.not.converged)then
iteration += 1
if(norm_grad_vec2.gt.0.01d0)then
N_det = N_states
else
N_det = max(N_det/8 ,N_states)
endif
psi_det = psi_det_sorted
psi_coef = psi_coef_sorted
read_wf = .True.
call clear_mo_map
SOFT_TOUCH mo_coef N_det psi_det psi_coef
if(.not.small_active_space)then
if(adaptive_pt2_max)then
SOFT_TOUCH pt2_max
endif
endif
if(iteration .gt. 3)then
state_following_casscf = state_following_casscf_cipsi_save
soft_touch state_following_casscf
endif
endif
enddo
integer :: i
print*,'Converged CASSCF '
print*,'--------------------------'
write(6,*) ' occupation numbers of orbitals '
do i=1,mo_num
write(6,*) i,occnum(i)
end do
print*,'--------------'
!
! write(6,*)
! write(6,*) ' the diagonal of the inactive effective Fock matrix '
! write(6,'(5(i3,F12.5))') (i,Fipq(i,i),i=1,mo_num)
! write(6,*)
print*,'Fock MCSCF'
do i = 1, mo_num
write(*,*)i,mcscf_fock_diag_mo(i)
! write(*,*)mcscf_fock_alpha_mo(i,i)
enddo
end

12
src/casscf_cipsi/class.irp.f Normal file
View File

@ -0,0 +1,12 @@
BEGIN_PROVIDER [ logical, do_only_1h1p ]
&BEGIN_PROVIDER [ logical, do_only_cas ]
&BEGIN_PROVIDER [ logical, do_ddci ]
implicit none
BEGIN_DOC
! In the CAS case, all those are always false except do_only_cas
END_DOC
do_only_cas = .True.
do_only_1h1p = .False.
do_ddci = .False.
END_PROVIDER

45
src/casscf_cipsi/dav_sx_mat.irp.f Normal file
View File

@ -0,0 +1,45 @@
subroutine davidson_diag_sx_mat(N_st, u_in, energies)
implicit none
integer, intent(in) :: N_st
double precision, intent(out) :: u_in(nMonoEx+1,n_states_diag), energies(N_st)
integer :: i,j,N_st_tmp, dim_in, sze, N_st_diag_in
integer, allocatable :: list_guess(:)
double precision, allocatable :: H_jj(:)
logical :: converged
N_st_diag_in = n_states_diag
provide SXmatrix
sze = nMonoEx+1
dim_in = sze
allocate(H_jj(sze), list_guess(sze))
H_jj(1) = 0.d0
N_st_tmp = 1
list_guess(1) = 1
do j = 2, nMonoEx+1
H_jj(j) = SXmatrix(j,j)
if(H_jj(j).lt.0.d0)then
list_guess(N_st_tmp) = j
N_st_tmp += 1
endif
enddo
if(N_st_tmp .ne. N_st)then
print*,'Pb in davidson_diag_sx_mat'
print*,'N_st_tmp .ne. N_st'
print*,N_st_tmp, N_st
stop
endif
print*,'Number of possibly interesting states = ',N_st
print*,'Corresponding diagonal elements of the SX matrix '
u_in = 0.d0
do i = 1, min(N_st, N_st_diag_in)
! do i = 1, N_st
j = list_guess(i)
print*,'i,j',i,j
print*,'SX(i,i) = ',H_jj(j)
u_in(j,i) = 1.d0
enddo
call davidson_general(u_in,H_jj,energies,dim_in,sze,N_st,N_st_diag_in,converged,SXmatrix)
print*,'energies = ',energies
end

96
src/casscf_cipsi/densities.irp.f Normal file
View File

@ -0,0 +1,96 @@
use bitmasks
BEGIN_PROVIDER [real*8, D0tu, (n_act_orb,n_act_orb) ]
implicit none
BEGIN_DOC
! the first-order density matrix in the basis of the starting MOs.
! matrix is state averaged.
END_DOC
integer :: t,u
do u=1,n_act_orb
do t=1,n_act_orb
D0tu(t,u) = one_e_dm_mo_alpha_average( list_act(t), list_act(u) ) + &
one_e_dm_mo_beta_average ( list_act(t), list_act(u) )
enddo
enddo
END_PROVIDER
BEGIN_PROVIDER [double precision, D0tu_alpha_ao, (ao_num, ao_num)]
&BEGIN_PROVIDER [double precision, D0tu_beta_ao, (ao_num, ao_num)]
implicit none
integer :: i,ii,j,u,t,uu,tt
double precision, allocatable :: D0_tmp_alpha(:,:),D0_tmp_beta(:,:)
allocate(D0_tmp_alpha(mo_num, mo_num),D0_tmp_beta(mo_num, mo_num))
D0_tmp_beta = 0.d0
D0_tmp_alpha = 0.d0
do i = 1, n_core_inact_orb
ii = list_core_inact(i)
D0_tmp_alpha(ii,ii) = 1.d0
D0_tmp_beta(ii,ii) = 1.d0
enddo
print*,'Diagonal elements of the 1RDM in the active space'
do u=1,n_act_orb
uu = list_act(u)
print*,uu,one_e_dm_mo_alpha_average(uu,uu),one_e_dm_mo_beta_average(uu,uu)
do t=1,n_act_orb
tt = list_act(t)
D0_tmp_alpha(tt,uu) = one_e_dm_mo_alpha_average(tt,uu)
D0_tmp_beta(tt,uu) = one_e_dm_mo_beta_average(tt,uu)
enddo
enddo
call mo_to_ao_no_overlap(D0_tmp_alpha,mo_num,D0tu_alpha_ao,ao_num)
call mo_to_ao_no_overlap(D0_tmp_beta,mo_num,D0tu_beta_ao,ao_num)
END_PROVIDER
BEGIN_PROVIDER [real*8, P0tuvx, (n_act_orb,n_act_orb,n_act_orb,n_act_orb) ]
BEGIN_DOC
! The second-order density matrix in the basis of the starting MOs ONLY IN THE RANGE OF ACTIVE MOS
! The values are state averaged
!
! We use the spin-free generators of mono-excitations
! E_pq destroys q and creates p
! D_pq = <0|E_pq|0> = D_qp
! P_pqrs = 1/2 <0|E_pq E_rs - delta_qr E_ps|0>
!
! P0tuvx(p,q,r,s) = chemist notation : 1/2 <0|E_pq E_rs - delta_qr E_ps|0>
END_DOC
implicit none
integer :: t,u,v,x
integer :: tt,uu,vv,xx
integer :: mu,nu,istate,ispin,jspin,ihole,ipart,jhole,jpart
integer :: ierr
real*8 :: phase1,phase11,phase12,phase2,phase21,phase22
integer :: nu1,nu2,nu11,nu12,nu21,nu22
integer :: ierr1,ierr2,ierr11,ierr12,ierr21,ierr22
real*8 :: cI_mu(N_states),term
integer(bit_kind), dimension(N_int,2) :: det_mu, det_mu_ex
integer(bit_kind), dimension(N_int,2) :: det_mu_ex1, det_mu_ex11, det_mu_ex12
integer(bit_kind), dimension(N_int,2) :: det_mu_ex2, det_mu_ex21, det_mu_ex22
if (bavard) then
write(6,*) ' providing the 2 body RDM on the active part'
endif
P0tuvx= 0.d0
if(fast_2rdm)then
do istate=1,N_states
do x = 1, n_act_orb
do v = 1, n_act_orb
do u = 1, n_act_orb
do t = 1, n_act_orb
! 1 1 2 2 1 2 1 2
P0tuvx(t,u,v,x) = 0.5d0 * state_av_act_2_rdm_spin_trace_mo(t,v,u,x)
enddo
enddo
enddo
enddo
enddo
else
P0tuvx = P0tuvx_peter
endif
END_PROVIDER

150
src/casscf_cipsi/densities_peter.irp.f Normal file
View File

@ -0,0 +1,150 @@
use bitmasks
BEGIN_PROVIDER [real*8, P0tuvx_peter, (n_act_orb,n_act_orb,n_act_orb,n_act_orb) ]
BEGIN_DOC
! the second-order density matrix in the basis of the starting MOs
! matrices are state averaged
!
! we use the spin-free generators of mono-excitations
! E_pq destroys q and creates p
! D_pq = <0|E_pq|0> = D_qp
! P_pqrs = 1/2 <0|E_pq E_rs - delta_qr E_ps|0>
!
END_DOC
implicit none
integer :: t,u,v,x,mu,nu,istate,ispin,jspin,ihole,ipart,jhole,jpart
integer :: ierr
real*8 :: phase1,phase11,phase12,phase2,phase21,phase22
integer :: nu1,nu2,nu11,nu12,nu21,nu22
integer :: ierr1,ierr2,ierr11,ierr12,ierr21,ierr22
real*8 :: cI_mu(N_states),term
integer(bit_kind), dimension(N_int,2) :: det_mu, det_mu_ex
integer(bit_kind), dimension(N_int,2) :: det_mu_ex1, det_mu_ex11, det_mu_ex12
integer(bit_kind), dimension(N_int,2) :: det_mu_ex2, det_mu_ex21, det_mu_ex22
if (bavard) then
write(6,*) ' providing density matrix P0'
endif
P0tuvx_peter = 0.d0
! first loop: we apply E_tu, once for D_tu, once for -P_tvvu
do mu=1,n_det
call det_extract(det_mu,mu,N_int)
do istate=1,n_states
cI_mu(istate)=psi_coef(mu,istate)
end do
do t=1,n_act_orb
ipart=list_act(t)
do u=1,n_act_orb
ihole=list_act(u)
! apply E_tu
call det_copy(det_mu,det_mu_ex1,N_int)
call det_copy(det_mu,det_mu_ex2,N_int)
call do_spinfree_mono_excitation(det_mu,det_mu_ex1 &
,det_mu_ex2,nu1,nu2,ihole,ipart,phase1,phase2,ierr1,ierr2)
! det_mu_ex1 is in the list
if (nu1.ne.-1) then
do istate=1,n_states
term=cI_mu(istate)*psi_coef(nu1,istate)*phase1
! and we fill P0_tvvu
do v=1,n_act_orb
P0tuvx_peter(t,v,v,u)-=term
end do
end do
end if
! det_mu_ex2 is in the list
if (nu2.ne.-1) then
do istate=1,n_states
term=cI_mu(istate)*psi_coef(nu2,istate)*phase2
do v=1,n_act_orb
P0tuvx_peter(t,v,v,u)-=term
end do
end do
end if
end do
end do
end do
! now we do the double excitation E_tu E_vx |0>
do mu=1,n_det
call det_extract(det_mu,mu,N_int)
do istate=1,n_states
cI_mu(istate)=psi_coef(mu,istate)
end do
do v=1,n_act_orb
ipart=list_act(v)
do x=1,n_act_orb
ihole=list_act(x)
! apply E_vx
call det_copy(det_mu,det_mu_ex1,N_int)
call det_copy(det_mu,det_mu_ex2,N_int)
call do_spinfree_mono_excitation(det_mu,det_mu_ex1 &
,det_mu_ex2,nu1,nu2,ihole,ipart,phase1,phase2,ierr1,ierr2)
! we apply E_tu to the first resultant determinant, thus E_tu E_vx |0>
if (ierr1.eq.1) then
do t=1,n_act_orb
jpart=list_act(t)
do u=1,n_act_orb
jhole=list_act(u)
call det_copy(det_mu_ex1,det_mu_ex11,N_int)
call det_copy(det_mu_ex1,det_mu_ex12,N_int)
call do_spinfree_mono_excitation(det_mu_ex1,det_mu_ex11&
,det_mu_ex12,nu11,nu12,jhole,jpart,phase11,phase12,ierr11,ierr12)
if (nu11.ne.-1) then
do istate=1,n_states
P0tuvx_peter(t,u,v,x)+=cI_mu(istate)*psi_coef(nu11,istate)&
*phase11*phase1
end do
end if
if (nu12.ne.-1) then
do istate=1,n_states
P0tuvx_peter(t,u,v,x)+=cI_mu(istate)*psi_coef(nu12,istate)&
*phase12*phase1
end do
end if
end do
end do
end if
! we apply E_tu to the second resultant determinant
if (ierr2.eq.1) then
do t=1,n_act_orb
jpart=list_act(t)
do u=1,n_act_orb
jhole=list_act(u)
call det_copy(det_mu_ex2,det_mu_ex21,N_int)
call det_copy(det_mu_ex2,det_mu_ex22,N_int)
call do_spinfree_mono_excitation(det_mu_ex2,det_mu_ex21&
,det_mu_ex22,nu21,nu22,jhole,jpart,phase21,phase22,ierr21,ierr22)
if (nu21.ne.-1) then
do istate=1,n_states
P0tuvx_peter(t,u,v,x)+=cI_mu(istate)*psi_coef(nu21,istate)&
*phase21*phase2
end do
end if
if (nu22.ne.-1) then
do istate=1,n_states
P0tuvx_peter(t,u,v,x)+=cI_mu(istate)*psi_coef(nu22,istate)&
*phase22*phase2
end do
end if
end do
end do
end if
end do
end do
end do
! we average by just dividing by the number of states
do x=1,n_act_orb
do v=1,n_act_orb
do u=1,n_act_orb
do t=1,n_act_orb
P0tuvx_peter(t,u,v,x)*=0.5D0/dble(N_states)
end do
end do
end do
end do
END_PROVIDER

125
src/casscf_cipsi/det_manip.irp.f Normal file
View File

@ -0,0 +1,125 @@
use bitmasks
subroutine do_signed_mono_excitation(key1,key2,nu,ihole,ipart, &
ispin,phase,ierr)
BEGIN_DOC
! we create the mono-excitation, and determine, if possible,
! the phase and the number in the list of determinants
END_DOC
implicit none
integer(bit_kind) :: key1(N_int,2),key2(N_int,2)
integer(bit_kind), allocatable :: keytmp(:,:)
integer :: exc(0:2,2,2),ihole,ipart,ierr,nu,ispin
real*8 :: phase
logical :: found
allocate(keytmp(N_int,2))
nu=-1
phase=1.D0
ierr=0
call det_copy(key1,key2,N_int)
! write(6,*) ' key2 before excitation ',ihole,' -> ',ipart,' spin = ',ispin
! call print_det(key2,N_int)
call do_single_excitation(key2,ihole,ipart,ispin,ierr)
! write(6,*) ' key2 after ',ihole,' -> ',ipart,' spin = ',ispin
! call print_det(key2,N_int)
! write(6,*) ' excitation ',ihole,' -> ',ipart,' gives ierr = ',ierr
if (ierr.eq.1) then
! excitation is possible
! get the phase
call get_single_excitation(key1,key2,exc,phase,N_int)
! get the number in the list
found=.false.
nu=0
!TODO BOTTLENECK
do while (.not.found)
nu+=1
if (nu.gt.N_det) then
! the determinant is possible, but not in the list
found=.true.
nu=-1
else
call det_extract(keytmp,nu,N_int)
integer :: i,ii
found=.true.
do ii=1,2
do i=1,N_int
if (keytmp(i,ii).ne.key2(i,ii)) then
found=.false.
end if
end do
end do
end if
end do
end if
!
! we found the new string, the phase, and possibly the number in the list
!
end subroutine do_signed_mono_excitation
subroutine det_extract(key,nu,Nint)
BEGIN_DOC
! extract a determinant from the list of determinants
END_DOC
implicit none
integer :: ispin,i,nu,Nint
integer(bit_kind) :: key(Nint,2)
do ispin=1,2
do i=1,Nint
key(i,ispin)=psi_det(i,ispin,nu)
end do
end do
end subroutine det_extract
subroutine det_copy(key1,key2,Nint)
use bitmasks ! you need to include the bitmasks_module.f90 features
BEGIN_DOC
! copy a determinant from key1 to key2
END_DOC
implicit none
integer :: ispin,i,Nint
integer(bit_kind) :: key1(Nint,2),key2(Nint,2)
do ispin=1,2
do i=1,Nint
key2(i,ispin)=key1(i,ispin)
end do
end do
end subroutine det_copy
subroutine do_spinfree_mono_excitation(key_in,key_out1,key_out2 &
,nu1,nu2,ihole,ipart,phase1,phase2,ierr,jerr)
BEGIN_DOC
! we create the spin-free mono-excitation E_pq=(a^+_p a_q + a^+_P a_Q)
! we may create two determinants as result
!
END_DOC
implicit none
integer(bit_kind) :: key_in(N_int,2),key_out1(N_int,2)
integer(bit_kind) :: key_out2(N_int,2)
integer :: ihole,ipart,ierr,jerr,nu1,nu2
integer :: ispin
real*8 :: phase1,phase2
! write(6,*) ' applying E_',ipart,ihole,' on determinant '
! call print_det(key_in,N_int)
! spin alpha
ispin=1
call do_signed_mono_excitation(key_in,key_out1,nu1,ihole &
,ipart,ispin,phase1,ierr)
! if (ierr.eq.1) then
! write(6,*) ' 1 result is ',nu1,phase1
! call print_det(key_out1,N_int)
! end if
! spin beta
ispin=2
call do_signed_mono_excitation(key_in,key_out2,nu2,ihole &
,ipart,ispin,phase2,jerr)
! if (jerr.eq.1) then
! write(6,*) ' 2 result is ',nu2,phase2
! call print_det(key_out2,N_int)
! end if
end subroutine do_spinfree_mono_excitation

3
src/casscf_cipsi/driver_optorb.irp.f Normal file
View File

@ -0,0 +1,3 @@
subroutine driver_optorb
implicit none
end

51
src/casscf_cipsi/get_energy.irp.f Normal file
View File

@ -0,0 +1,51 @@
program print_2rdm
implicit none
BEGIN_DOC
! get the active part of the bielectronic energy on a given wave function.
!
! useful to test the active part of the spin trace 2 rdms
END_DOC
!no_vvvv_integrals = .True.
read_wf = .True.
!touch read_wf no_vvvv_integrals
!call routine
!call routine_bis
call print_grad
end
subroutine print_grad
implicit none
integer :: i
do i = 1, nMonoEx
if(dabs(gradvec2(i)).gt.1.d-5)then
print*,''
print*,i,gradvec2(i),excit(:,i)
endif
enddo
end
subroutine routine
integer :: i,j,k,l
integer :: ii,jj,kk,ll
double precision :: accu(4),twodm,thr,act_twodm2,integral,get_two_e_integral
thr = 1.d-10
accu = 0.d0
do ll = 1, n_act_orb
l = list_act(ll)
do kk = 1, n_act_orb
k = list_act(kk)
do jj = 1, n_act_orb
j = list_act(jj)
do ii = 1, n_act_orb
i = list_act(ii)
integral = get_two_e_integral(i,j,k,l,mo_integrals_map)
accu(1) += state_av_act_2_rdm_spin_trace_mo(ii,jj,kk,ll) * integral
enddo
enddo
enddo
enddo
print*,'accu = ',accu(1)
end

74
src/casscf_cipsi/grad_old.irp.f Normal file
View File

@ -0,0 +1,74 @@
BEGIN_PROVIDER [real*8, gradvec_old, (nMonoEx)]
BEGIN_DOC
! calculate the orbital gradient <Psi| H E_pq |Psi> by hand, i.e. for
! each determinant I we determine the string E_pq |I> (alpha and beta
! separately) and generate <Psi|H E_pq |I>
! sum_I c_I <Psi|H E_pq |I> is then the pq component of the orbital
! gradient
! E_pq = a^+_pa_q + a^+_Pa_Q
END_DOC
implicit none
integer :: ii,tt,aa,indx,ihole,ipart,istate
real*8 :: res
do indx=1,nMonoEx
ihole=excit(1,indx)
ipart=excit(2,indx)
call calc_grad_elem(ihole,ipart,res)
gradvec_old(indx)=res
end do
real*8 :: norm_grad
norm_grad=0.d0
do indx=1,nMonoEx
norm_grad+=gradvec_old(indx)*gradvec_old(indx)
end do
norm_grad=sqrt(norm_grad)
if (bavard) then
write(6,*)
write(6,*) ' Norm of the orbital gradient (via <0|EH|0>) : ', norm_grad
write(6,*)
endif
END_PROVIDER
subroutine calc_grad_elem(ihole,ipart,res)
BEGIN_DOC
! eq 18 of Siegbahn et al, Physica Scripta 1980
! we calculate 2 <Psi| H E_pq | Psi>, q=hole, p=particle
END_DOC
implicit none
integer :: ihole,ipart,mu,iii,ispin,ierr,nu,istate
real*8 :: res
integer(bit_kind), allocatable :: det_mu(:,:),det_mu_ex(:,:)
real*8 :: i_H_psi_array(N_states),phase
allocate(det_mu(N_int,2))
allocate(det_mu_ex(N_int,2))
res=0.D0
do mu=1,n_det
! get the string of the determinant
call det_extract(det_mu,mu,N_int)
do ispin=1,2
! do the monoexcitation on it
call det_copy(det_mu,det_mu_ex,N_int)
call do_signed_mono_excitation(det_mu,det_mu_ex,nu &
,ihole,ipart,ispin,phase,ierr)
if (ierr.eq.1) then
call i_H_psi(det_mu_ex,psi_det,psi_coef,N_int &
,N_det,N_det,N_states,i_H_psi_array)
do istate=1,N_states
res+=i_H_psi_array(istate)*psi_coef(mu,istate)*phase
end do
end if
end do
end do
! state-averaged gradient
res*=2.D0/dble(N_states)
end subroutine calc_grad_elem

215
src/casscf_cipsi/gradient.irp.f Normal file
View File

@ -0,0 +1,215 @@
use bitmasks
BEGIN_PROVIDER [ integer, nMonoEx ]
BEGIN_DOC
! Number of single excitations
END_DOC
implicit none
nMonoEx=n_core_inact_orb*n_act_orb+n_core_inact_orb*n_virt_orb+n_act_orb*n_virt_orb
END_PROVIDER
BEGIN_PROVIDER [integer, n_c_a_prov]
&BEGIN_PROVIDER [integer, n_c_v_prov]
&BEGIN_PROVIDER [integer, n_a_v_prov]
implicit none
n_c_a_prov = n_core_inact_orb * n_act_orb
n_c_v_prov = n_core_inact_orb * n_virt_orb
n_a_v_prov = n_act_orb * n_virt_orb
END_PROVIDER
BEGIN_PROVIDER [integer, excit, (2,nMonoEx)]
&BEGIN_PROVIDER [character*3, excit_class, (nMonoEx)]
&BEGIN_PROVIDER [integer, list_idx_c_a, (3,n_c_a_prov) ]
&BEGIN_PROVIDER [integer, list_idx_c_v, (3,n_c_v_prov) ]
&BEGIN_PROVIDER [integer, list_idx_a_v, (3,n_a_v_prov) ]
&BEGIN_PROVIDER [integer, mat_idx_c_a, (n_core_inact_orb,n_act_orb)
&BEGIN_PROVIDER [integer, mat_idx_c_v, (n_core_inact_orb,n_virt_orb)
&BEGIN_PROVIDER [integer, mat_idx_a_v, (n_act_orb,n_virt_orb)
BEGIN_DOC
! a list of the orbitals involved in the excitation
END_DOC
implicit none
integer :: i,t,a,ii,tt,aa,indx,indx_tmp
indx=0
indx_tmp = 0
do ii=1,n_core_inact_orb
i=list_core_inact(ii)
do tt=1,n_act_orb
t=list_act(tt)
indx+=1
excit(1,indx)=i
excit(2,indx)=t
excit_class(indx)='c-a'
indx_tmp += 1
list_idx_c_a(1,indx_tmp) = indx
list_idx_c_a(2,indx_tmp) = ii
list_idx_c_a(3,indx_tmp) = tt
mat_idx_c_a(ii,tt) = indx
end do
end do
indx_tmp = 0
do ii=1,n_core_inact_orb
i=list_core_inact(ii)
do aa=1,n_virt_orb
a=list_virt(aa)
indx+=1
excit(1,indx)=i
excit(2,indx)=a
excit_class(indx)='c-v'
indx_tmp += 1
list_idx_c_v(1,indx_tmp) = indx
list_idx_c_v(2,indx_tmp) = ii
list_idx_c_v(3,indx_tmp) = aa
mat_idx_c_v(ii,aa) = indx
end do
end do
indx_tmp = 0
do tt=1,n_act_orb
t=list_act(tt)
do aa=1,n_virt_orb
a=list_virt(aa)
indx+=1
excit(1,indx)=t
excit(2,indx)=a
excit_class(indx)='a-v'
indx_tmp += 1
list_idx_a_v(1,indx_tmp) = indx
list_idx_a_v(2,indx_tmp) = tt
list_idx_a_v(3,indx_tmp) = aa
mat_idx_a_v(tt,aa) = indx
end do
end do
if (bavard) then
write(6,*) ' Filled the table of the Monoexcitations '
do indx=1,nMonoEx
write(6,*) ' ex ',indx,' : ',excit(1,indx),' -> ' &
,excit(2,indx),' ',excit_class(indx)
end do
end if
END_PROVIDER
BEGIN_PROVIDER [real*8, gradvec2, (nMonoEx)]
&BEGIN_PROVIDER [real*8, norm_grad_vec2]
&BEGIN_PROVIDER [real*8, norm_grad_vec2_tab, (3)]
BEGIN_DOC
! calculate the orbital gradient <Psi| H E_pq |Psi> from density
! matrices and integrals; Siegbahn et al, Phys Scr 1980
! eqs 14 a,b,c
END_DOC
implicit none
integer :: i,t,a,indx
real*8 :: gradvec_it,gradvec_ia,gradvec_ta
indx=0
norm_grad_vec2_tab = 0.d0
do i=1,n_core_inact_orb
do t=1,n_act_orb
indx+=1
gradvec2(indx)=gradvec_it(i,t)
norm_grad_vec2_tab(1) += gradvec2(indx)*gradvec2(indx)
end do
end do
do i=1,n_core_inact_orb
do a=1,n_virt_orb
indx+=1
gradvec2(indx)=gradvec_ia(i,a)
norm_grad_vec2_tab(2) += gradvec2(indx)*gradvec2(indx)
end do
end do
do t=1,n_act_orb
do a=1,n_virt_orb
indx+=1
gradvec2(indx)=gradvec_ta(t,a)
norm_grad_vec2_tab(3) += gradvec2(indx)*gradvec2(indx)
end do
end do
norm_grad_vec2=0.d0
do indx=1,nMonoEx
norm_grad_vec2+=gradvec2(indx)*gradvec2(indx)
end do
do i = 1, 3
norm_grad_vec2_tab(i) = dsqrt(norm_grad_vec2_tab(i))
enddo
norm_grad_vec2=sqrt(norm_grad_vec2)
if(bavard)then
write(6,*)
write(6,*) ' Norm of the orbital gradient (via D, P and integrals): ', norm_grad_vec2
write(6,*)
endif
END_PROVIDER
real*8 function gradvec_it(i,t)
BEGIN_DOC
! the orbital gradient core/inactive -> active
! we assume natural orbitals
END_DOC
implicit none
integer :: i,t
integer :: ii,tt,v,vv,x,y
integer :: x3,y3
ii=list_core_inact(i)
tt=list_act(t)
gradvec_it=2.D0*(Fipq(tt,ii)+Fapq(tt,ii))
gradvec_it-=occnum(tt)*Fipq(ii,tt)
do v=1,n_act_orb ! active
vv=list_act(v)
do x=1,n_act_orb ! active
x3=x+n_core_inact_orb ! list_act(x)
do y=1,n_act_orb ! active
y3=y+n_core_inact_orb ! list_act(y)
! Gamma(2) a a a a 1/r12 i a a a
gradvec_it-=2.D0*P0tuvx_no(t,v,x,y)*bielec_PQxx_no(ii,vv,x3,y3)
end do
end do
end do
gradvec_it*=2.D0
end function gradvec_it
real*8 function gradvec_ia(i,a)
BEGIN_DOC
! the orbital gradient core/inactive -> virtual
END_DOC
implicit none
integer :: i,a,ii,aa
ii=list_core_inact(i)
aa=list_virt(a)
gradvec_ia=2.D0*(Fipq(aa,ii)+Fapq(aa,ii))
gradvec_ia*=2.D0
end function gradvec_ia
real*8 function gradvec_ta(t,a)
BEGIN_DOC
! the orbital gradient active -> virtual
! we assume natural orbitals
END_DOC
implicit none
integer :: t,a,tt,aa,v,vv,x,y
tt=list_act(t)
aa=list_virt(a)
gradvec_ta=0.D0
gradvec_ta+=occnum(tt)*Fipq(aa,tt)
do v=1,n_act_orb
do x=1,n_act_orb
do y=1,n_act_orb
gradvec_ta+=2.D0*P0tuvx_no(t,v,x,y)*bielecCI_no(x,y,v,aa)
end do
end do
end do
gradvec_ta*=2.D0
end function gradvec_ta

539
src/casscf_cipsi/hessian.irp.f Normal file
View File

@ -0,0 +1,539 @@
use bitmasks
real*8 function hessmat_itju(i,t,j,u)
BEGIN_DOC
! the orbital hessian for core/inactive -> active, core/inactive -> active
! i, t, j, u are list indices, the corresponding orbitals are ii,tt,jj,uu
!
! we assume natural orbitals
END_DOC
implicit none
integer :: i,t,j,u,ii,tt,uu,v,vv,x,xx,y,jj
real*8 :: term,t2
ii=list_core_inact(i)
tt=list_act(t)
if (i.eq.j) then
if (t.eq.u) then
! diagonal element
term=occnum(tt)*Fipq(ii,ii)+2.D0*(Fipq(tt,tt)+Fapq(tt,tt)) &
-2.D0*(Fipq(ii,ii)+Fapq(ii,ii))
term+=2.D0*(3.D0*bielec_pxxq_no(tt,i,i,tt)-bielec_pqxx_no(tt,tt,i,i))
term-=2.D0*occnum(tt)*(3.D0*bielec_pxxq_no(tt,i,i,tt) &
-bielec_pqxx_no(tt,tt,i,i))
term-=occnum(tt)*Fipq(tt,tt)
do v=1,n_act_orb
vv=list_act(v)
do x=1,n_act_orb
xx=list_act(x)
term+=2.D0*(P0tuvx_no(t,t,v,x)*bielec_pqxx_no(vv,xx,i,i) &
+(P0tuvx_no(t,x,v,t)+P0tuvx_no(t,x,t,v))* &
bielec_pxxq_no(vv,i,i,xx))
do y=1,n_act_orb
term-=2.D0*P0tuvx_no(t,v,x,y)*bielecCI_no(t,v,y,xx)
end do
end do
end do
else
! it/iu, t != u
uu=list_act(u)
term=2.D0*(Fipq(tt,uu)+Fapq(tt,uu))
term+=2.D0*(4.D0*bielec_PxxQ_no(tt,i,j,uu)-bielec_PxxQ_no(uu,i,j,tt) &
-bielec_PQxx_no(tt,uu,i,j))
term-=occnum(tt)*Fipq(uu,tt)
term-=(occnum(tt)+occnum(uu)) &
*(3.D0*bielec_PxxQ_no(tt,i,i,uu)-bielec_PQxx_no(uu,tt,i,i))
do v=1,n_act_orb
vv=list_act(v)
! term-=D0tu(u,v)*Fipq(tt,vv) ! published, but inverting t and u seems more correct
do x=1,n_act_orb
xx=list_act(x)
term+=2.D0*(P0tuvx_no(u,t,v,x)*bielec_pqxx_no(vv,xx,i,i) &
+(P0tuvx_no(u,x,v,t)+P0tuvx_no(u,x,t,v)) &
*bielec_pxxq_no(vv,i,i,xx))
do y=1,n_act_orb
term-=2.D0*P0tuvx_no(t,v,x,y)*bielecCI_no(u,v,y,xx)
end do
end do
end do
end if
else
! it/ju
jj=list_core_inact(j)
uu=list_act(u)
if (t.eq.u) then
term=occnum(tt)*Fipq(ii,jj)
term-=2.D0*(Fipq(ii,jj)+Fapq(ii,jj))
else
term=0.D0
end if
term+=2.D0*(4.D0*bielec_PxxQ_no(tt,i,j,uu)-bielec_PxxQ_no(uu,i,j,tt) &
-bielec_PQxx_no(tt,uu,i,j))
term-=(occnum(tt)+occnum(uu))* &
(4.D0*bielec_PxxQ_no(tt,i,j,uu)-bielec_PxxQ_no(uu,i,j,tt) &
-bielec_PQxx_no(uu,tt,i,j))
do v=1,n_act_orb
vv=list_act(v)
do x=1,n_act_orb
xx=list_act(x)
term+=2.D0*(P0tuvx_no(u,t,v,x)*bielec_pqxx_no(vv,xx,i,j) &
+(P0tuvx_no(u,x,v,t)+P0tuvx_no(u,x,t,v)) &
*bielec_pxxq_no(vv,i,j,xx))
end do
end do
end if
term*=2.D0
hessmat_itju=term
end function hessmat_itju
real*8 function hessmat_itja(i,t,j,a)
BEGIN_DOC
! the orbital hessian for core/inactive -> active, core/inactive -> virtual
END_DOC
implicit none
integer :: i,t,j,a,ii,tt,jj,aa,v,vv,x,y
real*8 :: term
! it/ja
ii=list_core_inact(i)
tt=list_act(t)
jj=list_core_inact(j)
aa=list_virt(a)
term=2.D0*(4.D0*bielec_pxxq_no(aa,j,i,tt) &
-bielec_pqxx_no(aa,tt,i,j) -bielec_pxxq_no(aa,i,j,tt))
term-=occnum(tt)*(4.D0*bielec_pxxq_no(aa,j,i,tt) &
-bielec_pqxx_no(aa,tt,i,j) -bielec_pxxq_no(aa,i,j,tt))
if (i.eq.j) then
term+=2.D0*(Fipq(aa,tt)+Fapq(aa,tt))
term-=0.5D0*occnum(tt)*Fipq(aa,tt)
do v=1,n_act_orb
do x=1,n_act_orb
do y=1,n_act_orb
term-=P0tuvx_no(t,v,x,y)*bielecCI_no(x,y,v,aa)
end do
end do
end do
end if
term*=2.D0
hessmat_itja=term
end function hessmat_itja
real*8 function hessmat_itua(i,t,u,a)
BEGIN_DOC
! the orbital hessian for core/inactive -> active, active -> virtual
END_DOC
implicit none
integer :: i,t,u,a,ii,tt,uu,aa,v,vv,x,xx,u3,t3,v3
real*8 :: term
ii=list_core_inact(i)
tt=list_act(t)
t3=t+n_core_inact_orb
uu=list_act(u)
u3=u+n_core_inact_orb
aa=list_virt(a)
if (t.eq.u) then
term=-occnum(tt)*Fipq(aa,ii)
else
term=0.D0
end if
term-=occnum(uu)*(bielec_pqxx_no(aa,ii,t3,u3)-4.D0*bielec_pqxx_no(aa,uu,t3,i)&
+bielec_pxxq_no(aa,t3,u3,ii))
do v=1,n_act_orb
vv=list_act(v)
v3=v+n_core_inact_orb
do x=1,n_act_orb
integer :: x3
xx=list_act(x)
x3=x+n_core_inact_orb
term-=2.D0*(P0tuvx_no(t,u,v,x)*bielec_pqxx_no(aa,ii,v3,x3) &
+(P0tuvx_no(t,v,u,x)+P0tuvx_no(t,v,x,u)) &
*bielec_pqxx_no(aa,xx,v3,i))
end do
end do
if (t.eq.u) then
term+=Fipq(aa,ii)+Fapq(aa,ii)
end if
term*=2.D0
hessmat_itua=term
end function hessmat_itua
real*8 function hessmat_iajb(i,a,j,b)
BEGIN_DOC
! the orbital hessian for core/inactive -> virtual, core/inactive -> virtual
END_DOC
implicit none
integer :: i,a,j,b,ii,aa,jj,bb
real*8 :: term
ii=list_core_inact(i)
aa=list_virt(a)
if (i.eq.j) then
if (a.eq.b) then
! ia/ia
term=2.D0*(Fipq(aa,aa)+Fapq(aa,aa)-Fipq(ii,ii)-Fapq(ii,ii))
term+=2.D0*(3.D0*bielec_pxxq_no(aa,i,i,aa)-bielec_pqxx_no(aa,aa,i,i))
else
bb=list_virt(b)
! ia/ib
term=2.D0*(Fipq(aa,bb)+Fapq(aa,bb))
term+=2.D0*(3.D0*bielec_pxxq_no(aa,i,i,bb)-bielec_pqxx_no(aa,bb,i,i))
end if
else
! ia/jb
jj=list_core_inact(j)
bb=list_virt(b)
term=2.D0*(4.D0*bielec_pxxq_no(aa,i,j,bb)-bielec_pqxx_no(aa,bb,i,j) &
-bielec_pxxq_no(aa,j,i,bb))
if (a.eq.b) then
term-=2.D0*(Fipq(ii,jj)+Fapq(ii,jj))
end if
end if
term*=2.D0
hessmat_iajb=term
end function hessmat_iajb
real*8 function hessmat_iatb(i,a,t,b)
BEGIN_DOC
! the orbital hessian for core/inactive -> virtual, active -> virtual
END_DOC
implicit none
integer :: i,a,t,b,ii,aa,tt,bb,v,vv,x,y,v3,t3
real*8 :: term
ii=list_core_inact(i)
aa=list_virt(a)
tt=list_act(t)
bb=list_virt(b)
t3=t+n_core_inact_orb
term=occnum(tt)*(4.D0*bielec_pxxq_no(aa,i,t3,bb)-bielec_pxxq_no(aa,t3,i,bb)&
-bielec_pqxx_no(aa,bb,i,t3))
if (a.eq.b) then
term-=Fipq(tt,ii)+Fapq(tt,ii)
term-=0.5D0*occnum(tt)*Fipq(tt,ii)
do v=1,n_act_orb
do x=1,n_act_orb
do y=1,n_act_orb
term-=P0tuvx_no(t,v,x,y)*bielecCI_no(x,y,v,ii)
end do
end do
end do
end if
term*=2.D0
hessmat_iatb=term
end function hessmat_iatb
real*8 function hessmat_taub(t,a,u,b)
BEGIN_DOC
! the orbital hessian for act->virt,act->virt
END_DOC
implicit none
integer :: t,a,u,b,tt,aa,uu,bb,v,vv,x,xx,y
integer :: v3,x3
real*8 :: term,t1,t2,t3
tt=list_act(t)
aa=list_virt(a)
if (t == u) then
if (a == b) then
! ta/ta
t1=occnum(tt)*Fipq(aa,aa)
t2=0.D0
t3=0.D0
t1-=occnum(tt)*Fipq(tt,tt)
do v=1,n_act_orb
vv=list_act(v)
v3=v+n_core_inact_orb
do x=1,n_act_orb
xx=list_act(x)
x3=x+n_core_inact_orb
t2+=2.D0*(P0tuvx_no(t,t,v,x)*bielec_pqxx_no(aa,aa,v3,x3) &
+(P0tuvx_no(t,x,v,t)+P0tuvx_no(t,x,t,v))* &
bielec_pxxq_no(aa,x3,v3,aa))
do y=1,n_act_orb
t3-=2.D0*P0tuvx_no(t,v,x,y)*bielecCI_no(t,v,y,xx)
end do
end do
end do
term=t1+t2+t3
else
bb=list_virt(b)
! ta/tb b/=a
term=occnum(tt)*Fipq(aa,bb)
do v=1,n_act_orb
vv=list_act(v)
v3=v+n_core_inact_orb
do x=1,n_act_orb
xx=list_act(x)
x3=x+n_core_inact_orb
term+=2.D0*(P0tuvx_no(t,t,v,x)*bielec_pqxx_no(aa,bb,v3,x3) &
+(P0tuvx_no(t,x,v,t)+P0tuvx_no(t,x,t,v)) &
*bielec_pxxq_no(aa,x3,v3,bb))
end do
end do
end if
else
! ta/ub t/=u
uu=list_act(u)
bb=list_virt(b)
term=0.D0
do v=1,n_act_orb
vv=list_act(v)
v3=v+n_core_inact_orb
do x=1,n_act_orb
xx=list_act(x)
x3=x+n_core_inact_orb
term+=2.D0*(P0tuvx_no(t,u,v,x)*bielec_pqxx_no(aa,bb,v3,x3) &
+(P0tuvx_no(t,x,v,u)+P0tuvx_no(t,x,u,v)) &
*bielec_pxxq_no(aa,x3,v3,bb))
end do
end do
if (a.eq.b) then
term-=0.5D0*(occnum(tt)*Fipq(uu,tt)+occnum(uu)*Fipq(tt,uu))
do v=1,n_act_orb
do y=1,n_act_orb
do x=1,n_act_orb
term-=P0tuvx_no(t,v,x,y)*bielecCI_no(x,y,v,uu)
term-=P0tuvx_no(u,v,x,y)*bielecCI_no(x,y,v,tt)
end do
end do
end do
end if
end if
term*=2.D0
hessmat_taub=term
end function hessmat_taub
BEGIN_PROVIDER [real*8, hessdiag, (nMonoEx)]
BEGIN_DOC
! the diagonal of the Hessian, needed for the Davidson procedure
END_DOC
implicit none
integer :: i,t,a,indx,indx_shift
real*8 :: hessmat_itju,hessmat_iajb,hessmat_taub
!$OMP PARALLEL DEFAULT(NONE) &
!$OMP SHARED(hessdiag,n_core_inact_orb,n_act_orb,n_virt_orb,nMonoEx) &
!$OMP PRIVATE(i,indx,t,a,indx_shift)
!$OMP DO
do i=1,n_core_inact_orb
do t=1,n_act_orb
indx = t + (i-1)*n_act_orb
hessdiag(indx)=hessmat_itju(i,t,i,t)
end do
end do
!$OMP END DO NOWAIT
indx_shift = n_core_inact_orb*n_act_orb
!$OMP DO
do a=1,n_virt_orb
do i=1,n_core_inact_orb
indx = a + (i-1)*n_virt_orb + indx_shift
hessdiag(indx)=hessmat_iajb(i,a,i,a)
end do
end do
!$OMP END DO NOWAIT
indx_shift += n_core_inact_orb*n_virt_orb
!$OMP DO
do a=1,n_virt_orb
do t=1,n_act_orb
indx = a + (t-1)*n_virt_orb + indx_shift
hessdiag(indx)=hessmat_taub(t,a,t,a)
end do
end do
!$OMP END DO
!$OMP END PARALLEL
END_PROVIDER
BEGIN_PROVIDER [double precision, hessmat, (nMonoEx,nMonoEx)]
implicit none
integer :: i,j,t,u,a,b
integer :: indx,indx_tmp, jndx, jndx_tmp
integer :: ustart,bstart
real*8 :: hessmat_itju
real*8 :: hessmat_itja
real*8 :: hessmat_itua
real*8 :: hessmat_iajb
real*8 :: hessmat_iatb
real*8 :: hessmat_taub
! c-a c-v a-v
! c-a | X X X
! c-v | X X
! a-v | X
provide mo_two_e_integrals_in_map
hessmat = 0.d0
!$OMP PARALLEL DEFAULT(NONE) &
!$OMP SHARED(hessmat,n_c_a_prov,list_idx_c_a,n_core_inact_orb,n_act_orb,mat_idx_c_a) &
!$OMP PRIVATE(indx_tmp,indx,i,t,j,u,ustart,jndx)
!$OMP DO
!!!! < Core-active| H |Core-active >
! Core-active excitations
do indx_tmp = 1, n_c_a_prov
indx = list_idx_c_a(1,indx_tmp)
i = list_idx_c_a(2,indx_tmp)
t = list_idx_c_a(3,indx_tmp)
! Core-active excitations
do j = 1, n_core_inact_orb
if (i.eq.j) then
ustart=t
else
ustart=1
end if
do u=ustart,n_act_orb
jndx = mat_idx_c_a(j,u)
hessmat(jndx,indx) = hessmat_itju(i,t,j,u)
hessmat(indx,jndx) = hessmat(jndx,indx)
enddo
enddo
enddo
!$OMP END DO NOWAIT
!$OMP END PARALLEL
!$OMP PARALLEL DEFAULT(NONE) &
!$OMP SHARED(hessmat,n_c_a_prov,n_c_v_prov,list_idx_c_a,list_idx_c_v) &
!$OMP PRIVATE(indx_tmp,jndx_tmp,indx,i,t,j,a,jndx)
!$OMP DO
!!!! < Core-active| H |Core-VIRTUAL >
! Core-active excitations
do indx_tmp = 1, n_c_a_prov
indx = list_idx_c_a(1,indx_tmp)
i = list_idx_c_a(2,indx_tmp)
t = list_idx_c_a(3,indx_tmp)
! Core-VIRTUAL excitations
do jndx_tmp = 1, n_c_v_prov
jndx = list_idx_c_v(1,jndx_tmp)
j = list_idx_c_v(2,jndx_tmp)
a = list_idx_c_v(3,jndx_tmp)
hessmat(jndx,indx) = hessmat_itja(i,t,j,a)
hessmat(indx,jndx) = hessmat(jndx,indx)
enddo
enddo
!$OMP END DO NOWAIT
!$OMP END PARALLEL
!$OMP PARALLEL DEFAULT(NONE) &
!$OMP SHARED(hessmat,n_c_a_prov,n_a_v_prov,list_idx_c_a,list_idx_a_v) &
!$OMP PRIVATE(indx_tmp,jndx_tmp,indx,i,t,u,a,jndx)
!$OMP DO
!!!! < Core-active| H |ACTIVE-VIRTUAL >
! Core-active excitations
do indx_tmp = 1, n_c_a_prov
indx = list_idx_c_a(1,indx_tmp)
i = list_idx_c_a(2,indx_tmp)
t = list_idx_c_a(3,indx_tmp)
! ACTIVE-VIRTUAL excitations
do jndx_tmp = 1, n_a_v_prov
jndx = list_idx_a_v(1,jndx_tmp)
u = list_idx_a_v(2,jndx_tmp)
a = list_idx_a_v(3,jndx_tmp)
hessmat(jndx,indx) = hessmat_itua(i,t,u,a)
hessmat(indx,jndx) = hessmat(jndx,indx)
enddo
enddo
!$OMP END DO NOWAIT
!$OMP END PARALLEL
if(hess_cv_cv)then
!$OMP PARALLEL DEFAULT(NONE) &
!$OMP SHARED(hessmat,n_c_v_prov,list_idx_c_v,n_core_inact_orb,n_virt_orb,mat_idx_c_v) &
!$OMP PRIVATE(indx_tmp,indx,i,a,j,b,bstart,jndx)
!$OMP DO
!!!!! < Core-VIRTUAL | H |Core-VIRTUAL >
! Core-VIRTUAL excitations
do indx_tmp = 1, n_c_v_prov
indx = list_idx_c_v(1,indx_tmp)
i = list_idx_c_v(2,indx_tmp)
a = list_idx_c_v(3,indx_tmp)
! Core-VIRTUAL excitations
do j = 1, n_core_inact_orb
if (i.eq.j) then
bstart=a
else
bstart=1
end if
do b=bstart,n_virt_orb
jndx = mat_idx_c_v(j,b)
hessmat(jndx,indx) = hessmat_iajb(i,a,j,b)
hessmat(indx,jndx) = hessmat(jndx,indx)
enddo
enddo
enddo
!$OMP END DO NOWAIT
!$OMP END PARALLEL
endif
!$OMP PARALLEL DEFAULT(NONE) &
!$OMP SHARED(hessmat,n_c_v_prov,n_a_v_prov,list_idx_c_v,list_idx_a_v) &
!$OMP PRIVATE(indx_tmp,jndx_tmp,indx,i,a,t,b,jndx)
!$OMP DO
!!!! < Core-VIRTUAL | H |Active-VIRTUAL >
! Core-VIRTUAL excitations
do indx_tmp = 1, n_c_v_prov
indx = list_idx_c_v(1,indx_tmp)
i = list_idx_c_v(2,indx_tmp)
a = list_idx_c_v(3,indx_tmp)
! Active-VIRTUAL excitations
do jndx_tmp = 1, n_a_v_prov
jndx = list_idx_a_v(1,jndx_tmp)
t = list_idx_a_v(2,jndx_tmp)
b = list_idx_a_v(3,jndx_tmp)
hessmat(jndx,indx) = hessmat_iatb(i,a,t,b)
hessmat(indx,jndx) = hessmat(jndx,indx)
enddo
enddo
!$OMP END DO NOWAIT
!$OMP END PARALLEL
!$OMP PARALLEL DEFAULT(NONE) &
!$OMP SHARED(hessmat,n_a_v_prov,list_idx_a_v,n_act_orb,n_virt_orb,mat_idx_a_v) &
!$OMP PRIVATE(indx_tmp,indx,t,a,u,b,bstart,jndx)
!$OMP DO
!!!! < Active-VIRTUAL | H |Active-VIRTUAL >
! Active-VIRTUAL excitations
do indx_tmp = 1, n_a_v_prov
indx = list_idx_a_v(1,indx_tmp)
t = list_idx_a_v(2,indx_tmp)
a = list_idx_a_v(3,indx_tmp)
! Active-VIRTUAL excitations
do u=t,n_act_orb
if (t.eq.u) then
bstart=a
else
bstart=1
end if
do b=bstart,n_virt_orb
jndx = mat_idx_a_v(u,b)
hessmat(jndx,indx) = hessmat_taub(t,a,u,b)
hessmat(indx,jndx) = hessmat(jndx,indx)
enddo
enddo
enddo
!$OMP END DO NOWAIT
!$OMP END PARALLEL
END_PROVIDER

310
src/casscf_cipsi/hessian_old.irp.f Normal file
View File

@ -0,0 +1,310 @@
use bitmasks
BEGIN_PROVIDER [real*8, hessmat_old, (nMonoEx,nMonoEx)]
BEGIN_DOC
! calculate the orbital hessian 2 <Psi| E_pq H E_rs |Psi>
! + <Psi| E_pq E_rs H |Psi> + <Psi| E_rs E_pq H |Psi> by hand,
! determinant per determinant, as for the gradient
!
! we assume that we have natural active orbitals
END_DOC
implicit none
integer :: indx,ihole,ipart
integer :: jndx,jhole,jpart
character*3 :: iexc,jexc
real*8 :: res
if (bavard) then
write(6,*) ' providing Hessian matrix hessmat_old '
write(6,*) ' nMonoEx = ',nMonoEx
endif
do indx=1,nMonoEx
do jndx=1,nMonoEx
hessmat_old(indx,jndx)=0.D0
end do
end do
do indx=1,nMonoEx
ihole=excit(1,indx)
ipart=excit(2,indx)
iexc=excit_class(indx)
do jndx=indx,nMonoEx
jhole=excit(1,jndx)
jpart=excit(2,jndx)
jexc=excit_class(jndx)
call calc_hess_elem(ihole,ipart,jhole,jpart,res)
hessmat_old(indx,jndx)=res
hessmat_old(jndx,indx)=res
end do
end do
END_PROVIDER
subroutine calc_hess_elem(ihole,ipart,jhole,jpart,res)
BEGIN_DOC
! eq 19 of Siegbahn et al, Physica Scripta 1980
! we calculate 2 <Psi| E_pq H E_rs |Psi>
! + <Psi| E_pq E_rs H |Psi> + <Psi| E_rs E_pq H |Psi>
! average over all states is performed.
! no transition between states.
END_DOC
implicit none
integer :: ihole,ipart,ispin,mu,istate
integer :: jhole,jpart,jspin
integer :: mu_pq, mu_pqrs, mu_rs, mu_rspq, nu_rs,nu
real*8 :: res
integer(bit_kind), allocatable :: det_mu(:,:)
integer(bit_kind), allocatable :: det_nu(:,:)
integer(bit_kind), allocatable :: det_mu_pq(:,:)
integer(bit_kind), allocatable :: det_mu_rs(:,:)
integer(bit_kind), allocatable :: det_nu_rs(:,:)
integer(bit_kind), allocatable :: det_mu_pqrs(:,:)
integer(bit_kind), allocatable :: det_mu_rspq(:,:)
real*8 :: i_H_psi_array(N_states),phase,phase2,phase3
real*8 :: i_H_j_element
allocate(det_mu(N_int,2))
allocate(det_nu(N_int,2))
allocate(det_mu_pq(N_int,2))
allocate(det_mu_rs(N_int,2))
allocate(det_nu_rs(N_int,2))
allocate(det_mu_pqrs(N_int,2))
allocate(det_mu_rspq(N_int,2))
integer :: mu_pq_possible
integer :: mu_rs_possible
integer :: nu_rs_possible
integer :: mu_pqrs_possible
integer :: mu_rspq_possible
res=0.D0
! the terms <0|E E H |0>
do mu=1,n_det
! get the string of the determinant
call det_extract(det_mu,mu,N_int)
do ispin=1,2
! do the monoexcitation pq on it
call det_copy(det_mu,det_mu_pq,N_int)
call do_signed_mono_excitation(det_mu,det_mu_pq,mu_pq &
,ihole,ipart,ispin,phase,mu_pq_possible)
if (mu_pq_possible.eq.1) then
! possible, but not necessarily in the list
! do the second excitation
do jspin=1,2
call det_copy(det_mu_pq,det_mu_pqrs,N_int)
call do_signed_mono_excitation(det_mu_pq,det_mu_pqrs,mu_pqrs&
,jhole,jpart,jspin,phase2,mu_pqrs_possible)
! excitation possible
if (mu_pqrs_possible.eq.1) then
call i_H_psi(det_mu_pqrs,psi_det,psi_coef,N_int &
,N_det,N_det,N_states,i_H_psi_array)
do istate=1,N_states
res+=i_H_psi_array(istate)*psi_coef(mu,istate)*phase*phase2
end do
end if
! try the de-excitation with opposite sign
call det_copy(det_mu_pq,det_mu_pqrs,N_int)
call do_signed_mono_excitation(det_mu_pq,det_mu_pqrs,mu_pqrs&
,jpart,jhole,jspin,phase2,mu_pqrs_possible)
phase2=-phase2
! excitation possible
if (mu_pqrs_possible.eq.1) then
call i_H_psi(det_mu_pqrs,psi_det,psi_coef,N_int &
,N_det,N_det,N_states,i_H_psi_array)
do istate=1,N_states
res+=i_H_psi_array(istate)*psi_coef(mu,istate)*phase*phase2
end do
end if
end do
end if
! exchange the notion of pq and rs
! do the monoexcitation rs on the initial determinant
call det_copy(det_mu,det_mu_rs,N_int)
call do_signed_mono_excitation(det_mu,det_mu_rs,mu_rs &
,jhole,jpart,ispin,phase2,mu_rs_possible)
if (mu_rs_possible.eq.1) then
! do the second excitation
do jspin=1,2
call det_copy(det_mu_rs,det_mu_rspq,N_int)
call do_signed_mono_excitation(det_mu_rs,det_mu_rspq,mu_rspq&
,ihole,ipart,jspin,phase3,mu_rspq_possible)
! excitation possible (of course, the result is outside the CAS)
if (mu_rspq_possible.eq.1) then
call i_H_psi(det_mu_rspq,psi_det,psi_coef,N_int &
,N_det,N_det,N_states,i_H_psi_array)
do istate=1,N_states
res+=i_H_psi_array(istate)*psi_coef(mu,istate)*phase2*phase3
end do
end if
! we may try the de-excitation, with opposite sign
call det_copy(det_mu_rs,det_mu_rspq,N_int)
call do_signed_mono_excitation(det_mu_rs,det_mu_rspq,mu_rspq&
,ipart,ihole,jspin,phase3,mu_rspq_possible)
phase3=-phase3
! excitation possible (of course, the result is outside the CAS)
if (mu_rspq_possible.eq.1) then
call i_H_psi(det_mu_rspq,psi_det,psi_coef,N_int &
,N_det,N_det,N_states,i_H_psi_array)
do istate=1,N_states
res+=i_H_psi_array(istate)*psi_coef(mu,istate)*phase2*phase3
end do
end if
end do
end if
!
! the operator E H E, we have to do a double loop over the determinants
! we still have the determinant mu_pq and the phase in memory
if (mu_pq_possible.eq.1) then
do nu=1,N_det
call det_extract(det_nu,nu,N_int)
do jspin=1,2
call det_copy(det_nu,det_nu_rs,N_int)
call do_signed_mono_excitation(det_nu,det_nu_rs,nu_rs &
,jhole,jpart,jspin,phase2,nu_rs_possible)
! excitation possible ?
if (nu_rs_possible.eq.1) then
call i_H_j(det_mu_pq,det_nu_rs,N_int,i_H_j_element)
do istate=1,N_states
res+=2.D0*i_H_j_element*psi_coef(mu,istate) &
*psi_coef(nu,istate)*phase*phase2
end do
end if
end do
end do
end if
end do
end do
! state-averaged Hessian
res*=1.D0/dble(N_states)
end subroutine calc_hess_elem
BEGIN_PROVIDER [real*8, hessmat_peter, (nMonoEx,nMonoEx)]
BEGIN_DOC
! explicit hessian matrix from density matrices and integrals
! of course, this will be used for a direct Davidson procedure later
! we will not store the matrix in real life
! formulas are broken down as functions for the 6 classes of matrix elements
!
END_DOC
implicit none
integer :: i,j,t,u,a,b,indx,jndx,bstart,ustart,indx_shift
real*8 :: hessmat_itju
real*8 :: hessmat_itja
real*8 :: hessmat_itua
real*8 :: hessmat_iajb
real*8 :: hessmat_iatb
real*8 :: hessmat_taub
if (bavard) then
write(6,*) ' providing Hessian matrix hessmat_peter '
write(6,*) ' nMonoEx = ',nMonoEx
endif
provide mo_two_e_integrals_in_map
!$OMP PARALLEL DEFAULT(NONE) &
!$OMP SHARED(hessmat_peter,n_core_inact_orb,n_act_orb,n_virt_orb,nMonoEx) &
!$OMP PRIVATE(i,indx,jndx,j,ustart,t,u,a,bstart,indx_shift)
!$OMP DO
! (DOUBLY OCCUPIED ---> ACT )
do i=1,n_core_inact_orb
do t=1,n_act_orb
indx = t + (i-1)*n_act_orb
jndx=indx
! (DOUBLY OCCUPIED ---> ACT )
do j=i,n_core_inact_orb
if (i.eq.j) then
ustart=t
else
ustart=1
end if
do u=ustart,n_act_orb
hessmat_peter(jndx,indx)=hessmat_itju(i,t,j,u)
jndx+=1
end do
end do
! (DOUBLY OCCUPIED ---> VIRTUAL)
do j=1,n_core_inact_orb
do a=1,n_virt_orb
hessmat_peter(jndx,indx)=hessmat_itja(i,t,j,a)
jndx+=1
end do
end do
! (ACTIVE ---> VIRTUAL)
do u=1,n_act_orb
do a=1,n_virt_orb
hessmat_peter(jndx,indx)=hessmat_itua(i,t,u,a)
jndx+=1
end do
end do
end do
end do
!$OMP END DO NOWAIT
indx_shift = n_core_inact_orb*n_act_orb
!$OMP DO
! (DOUBLY OCCUPIED ---> VIRTUAL)
do a=1,n_virt_orb
do i=1,n_core_inact_orb
indx = a + (i-1)*n_virt_orb + indx_shift
jndx=indx
! (DOUBLY OCCUPIED ---> VIRTUAL)
do j=i,n_core_inact_orb
if (i.eq.j) then
bstart=a
else
bstart=1
end if
do b=bstart,n_virt_orb
hessmat_peter(jndx,indx)=hessmat_iajb(i,a,j,b)
jndx+=1
end do
end do
! (ACT ---> VIRTUAL)
do t=1,n_act_orb
do b=1,n_virt_orb
hessmat_peter(jndx,indx)=hessmat_iatb(i,a,t,b)
jndx+=1
end do
end do
end do
end do
!$OMP END DO NOWAIT
indx_shift += n_core_inact_orb*n_virt_orb
!$OMP DO
! (ACT ---> VIRTUAL)
do a=1,n_virt_orb
do t=1,n_act_orb
indx = a + (t-1)*n_virt_orb + indx_shift
jndx=indx
! (ACT ---> VIRTUAL)
do u=t,n_act_orb
if (t.eq.u) then
bstart=a
else
bstart=1
end if
do b=bstart,n_virt_orb
hessmat_peter(jndx,indx)=hessmat_taub(t,a,u,b)
jndx+=1
end do
end do
end do
end do
!$OMP END DO
!$OMP END PARALLEL
do jndx=1,nMonoEx
do indx=1,jndx-1
hessmat_peter(indx,jndx) = hessmat_peter(jndx,indx)
enddo
enddo
END_PROVIDER

195
src/casscf_cipsi/mcscf_fock.irp.f Normal file
View File

@ -0,0 +1,195 @@
BEGIN_PROVIDER [real*8, Fipq, (mo_num,mo_num) ]
BEGIN_DOC
! the inactive Fock matrix, in molecular orbitals
END_DOC
implicit none
integer :: p,q,k,kk,t,tt,u,uu
do q=1,mo_num
do p=1,mo_num
Fipq(p,q)=one_ints_no(p,q)
end do
end do
! the inactive Fock matrix
do k=1,n_core_inact_orb
kk=list_core_inact(k)
do q=1,mo_num
do p=1,mo_num
Fipq(p,q)+=2.D0*bielec_pqxx_no(p,q,k,k) -bielec_pxxq_no(p,k,k,q)
end do
end do
end do
if (bavard) then
integer :: i
write(6,*)
write(6,*) ' the diagonal of the inactive effective Fock matrix '
write(6,'(5(i3,F12.5))') (i,Fipq(i,i),i=1,mo_num)
write(6,*)
end if
END_PROVIDER
BEGIN_PROVIDER [real*8, Fapq, (mo_num,mo_num) ]
BEGIN_DOC
! the active active Fock matrix, in molecular orbitals
! we create them in MOs, quite expensive
!
! for an implementation in AOs we need first the natural orbitals
! for forming an active density matrix in AOs
!
END_DOC
implicit none
integer :: p,q,k,kk,t,tt,u,uu
Fapq = 0.d0
! the active Fock matrix, D0tu is diagonal
do t=1,n_act_orb
tt=list_act(t)
do q=1,mo_num
do p=1,mo_num
Fapq(p,q)+=occnum(tt) &
*(bielec_pqxx_no(p,q,tt,tt)-0.5D0*bielec_pxxq_no(p,tt,tt,q))
end do
end do
end do
if (bavard) then
integer :: i
write(6,*)
write(6,*) ' the effective Fock matrix over MOs'
write(6,*)
write(6,*)
write(6,*) ' the diagonal of the inactive effective Fock matrix '
write(6,'(5(i3,F12.5))') (i,Fipq(i,i),i=1,mo_num)
write(6,*)
write(6,*)
write(6,*) ' the diagonal of the active Fock matrix '
write(6,'(5(i3,F12.5))') (i,Fapq(i,i),i=1,mo_num)
write(6,*)
end if
END_PROVIDER
BEGIN_PROVIDER [ double precision, mcscf_fock_alpha_ao, (ao_num, ao_num)]
&BEGIN_PROVIDER [ double precision, mcscf_fock_beta_ao, (ao_num, ao_num)]
implicit none
BEGIN_DOC
! mcscf_fock_alpha_ao are set to usual Fock like operator but computed with the MCSCF densities on the AO basis
END_DOC
SCF_density_matrix_ao_alpha = D0tu_alpha_ao
SCF_density_matrix_ao_beta = D0tu_beta_ao
soft_touch SCF_density_matrix_ao_alpha SCF_density_matrix_ao_beta
mcscf_fock_beta_ao = fock_matrix_ao_beta
mcscf_fock_alpha_ao = fock_matrix_ao_alpha
END_PROVIDER
BEGIN_PROVIDER [ double precision, mcscf_fock_alpha_mo, (mo_num, mo_num)]
&BEGIN_PROVIDER [ double precision, mcscf_fock_beta_mo, (mo_num, mo_num)]
implicit none
BEGIN_DOC
! Mo_mcscf_fock_alpha are set to usual Fock like operator but computed with the MCSCF densities on the MO basis
END_DOC
call ao_to_mo(mcscf_fock_alpha_ao,ao_num,mcscf_fock_alpha_mo,mo_num)
call ao_to_mo(mcscf_fock_beta_ao,ao_num,mcscf_fock_beta_mo,mo_num)
END_PROVIDER
BEGIN_PROVIDER [ double precision, mcscf_fock_mo, (mo_num,mo_num) ]
&BEGIN_PROVIDER [ double precision, mcscf_fock_diag_mo, (mo_num)]
implicit none
BEGIN_DOC
! MCSF Fock matrix on the MO basis.
! For open shells, the ROHF Fock Matrix is ::
!
! | Rcc | F^b | Fcv |
! |-----------------------|
! | F^b | Roo | F^a |
! |-----------------------|
! | Fcv | F^a | Rvv |
!
! C: Core, O: Open, V: Virtual
!
! Rcc = Acc Fcc^a + Bcc Fcc^b
! Roo = Aoo Foo^a + Boo Foo^b
! Rvv = Avv Fvv^a + Bvv Fvv^b
! Fcv = (F^a + F^b)/2
!
! F^a: Fock matrix alpha (MO), F^b: Fock matrix beta (MO)
! A,B: Coupling parameters
!
! J. Chem. Phys. 133, 141102 (2010), https://doi.org/10.1063/1.3503173
! Coupling parameters from J. Chem. Phys. 125, 204110 (2006); https://doi.org/10.1063/1.2393223.
! cc oo vv
! A -0.5 0.5 1.5
! B 1.5 0.5 -0.5
!
END_DOC
integer :: i,j,n
if (elec_alpha_num == elec_beta_num) then
mcscf_fock_mo = mcscf_fock_alpha_mo
else
! Core
do j = 1, elec_beta_num
! Core
do i = 1, elec_beta_num
mcscf_fock_mo(i,j) = - 0.5d0 * mcscf_fock_alpha_mo(i,j) &
+ 1.5d0 * mcscf_fock_beta_mo(i,j)
enddo
! Open
do i = elec_beta_num+1, elec_alpha_num
mcscf_fock_mo(i,j) = mcscf_fock_beta_mo(i,j)
enddo
! Virtual
do i = elec_alpha_num+1, mo_num
mcscf_fock_mo(i,j) = 0.5d0 * mcscf_fock_alpha_mo(i,j) &
+ 0.5d0 * mcscf_fock_beta_mo(i,j)
enddo
enddo
! Open
do j = elec_beta_num+1, elec_alpha_num
! Core
do i = 1, elec_beta_num
mcscf_fock_mo(i,j) = mcscf_fock_beta_mo(i,j)
enddo
! Open
do i = elec_beta_num+1, elec_alpha_num
mcscf_fock_mo(i,j) = 0.5d0 * mcscf_fock_alpha_mo(i,j) &
+ 0.5d0 * mcscf_fock_beta_mo(i,j)
enddo
! Virtual
do i = elec_alpha_num+1, mo_num
mcscf_fock_mo(i,j) = mcscf_fock_alpha_mo(i,j)
enddo
enddo
! Virtual
do j = elec_alpha_num+1, mo_num
! Core
do i = 1, elec_beta_num
mcscf_fock_mo(i,j) = 0.5d0 * mcscf_fock_alpha_mo(i,j) &
+ 0.5d0 * mcscf_fock_beta_mo(i,j)
enddo
! Open
do i = elec_beta_num+1, elec_alpha_num
mcscf_fock_mo(i,j) = mcscf_fock_alpha_mo(i,j)
enddo
! Virtual
do i = elec_alpha_num+1, mo_num
mcscf_fock_mo(i,j) = 1.5d0 * mcscf_fock_alpha_mo(i,j) &
- 0.5d0 * mcscf_fock_beta_mo(i,j)
enddo
enddo
endif
do i = 1, mo_num
mcscf_fock_diag_mo(i) = mcscf_fock_mo(i,i)
enddo
END_PROVIDER

231
src/casscf_cipsi/natorb.irp.f Normal file
View File

@ -0,0 +1,231 @@
BEGIN_PROVIDER [real*8, occnum, (mo_num)]
implicit none
BEGIN_DOC
! MO occupation numbers
END_DOC
integer :: i
occnum=0.D0
do i=1,n_core_inact_orb
occnum(list_core_inact(i))=2.D0
end do
do i=1,n_act_orb
occnum(list_act(i))=occ_act(i)
end do
if (bavard) then
write(6,*) ' occupation numbers '
do i=1,mo_num
write(6,*) i,occnum(i)
end do
endif
END_PROVIDER
BEGIN_PROVIDER [ real*8, natorbsCI, (n_act_orb,n_act_orb) ]
&BEGIN_PROVIDER [ real*8, occ_act, (n_act_orb) ]
implicit none
BEGIN_DOC
! Natural orbitals of CI
END_DOC
integer :: i, j
double precision :: Vt(n_act_orb,n_act_orb)
! call lapack_diag(occ_act,natorbsCI,D0tu,n_act_orb,n_act_orb)
call svd(D0tu, size(D0tu,1), natorbsCI,size(natorbsCI,1), occ_act, Vt, size(Vt,1),n_act_orb,n_act_orb)
if (bavard) then
write(6,*) ' found occupation numbers as '
do i=1,n_act_orb
write(6,*) i,occ_act(i)
end do
integer :: nmx
real*8 :: xmx
do i=1,n_act_orb
! largest element of the eigenvector should be positive
xmx=0.D0
nmx=0
do j=1,n_act_orb
if (abs(natOrbsCI(j,i)).gt.xmx) then
nmx=j
xmx=abs(natOrbsCI(j,i))
end if
end do
xmx=sign(1.D0,natOrbsCI(nmx,i))
do j=1,n_act_orb
natOrbsCI(j,i)*=xmx
end do
write(6,*) ' Eigenvector No ',i
write(6,'(5(I3,F12.5))') (j,natOrbsCI(j,i),j=1,n_act_orb)
end do
end if
END_PROVIDER
BEGIN_PROVIDER [real*8, P0tuvx_no, (n_act_orb,n_act_orb,n_act_orb,n_act_orb)]
implicit none
BEGIN_DOC
! 4-index transformation of 2part matrices
END_DOC
integer :: i,j,k,l,p,q
real*8 :: d(n_act_orb)
! index per index
! first quarter
P0tuvx_no(:,:,:,:) = P0tuvx(:,:,:,:)
do j=1,n_act_orb
do k=1,n_act_orb
do l=1,n_act_orb
do p=1,n_act_orb
d(p)=0.D0
end do
do p=1,n_act_orb
do q=1,n_act_orb
d(p)+=P0tuvx_no(q,j,k,l)*natorbsCI(q,p)
end do
end do
do p=1,n_act_orb
P0tuvx_no(p,j,k,l)=d(p)
end do
end do
end do
end do
! 2nd quarter
do j=1,n_act_orb
do k=1,n_act_orb
do l=1,n_act_orb
do p=1,n_act_orb
d(p)=0.D0
end do
do p=1,n_act_orb
do q=1,n_act_orb
d(p)+=P0tuvx_no(j,q,k,l)*natorbsCI(q,p)
end do
end do
do p=1,n_act_orb
P0tuvx_no(j,p,k,l)=d(p)
end do
end do
end do
end do
! 3rd quarter
do j=1,n_act_orb
do k=1,n_act_orb
do l=1,n_act_orb
do p=1,n_act_orb
d(p)=0.D0
end do
do p=1,n_act_orb
do q=1,n_act_orb
d(p)+=P0tuvx_no(j,k,q,l)*natorbsCI(q,p)
end do
end do
do p=1,n_act_orb
P0tuvx_no(j,k,p,l)=d(p)
end do
end do
end do
end do
! 4th quarter
do j=1,n_act_orb
do k=1,n_act_orb
do l=1,n_act_orb
do p=1,n_act_orb
d(p)=0.D0
end do
do p=1,n_act_orb
do q=1,n_act_orb
d(p)+=P0tuvx_no(j,k,l,q)*natorbsCI(q,p)
end do
end do
do p=1,n_act_orb
P0tuvx_no(j,k,l,p)=d(p)
end do
end do
end do
end do
END_PROVIDER
BEGIN_PROVIDER [real*8, one_ints_no, (mo_num,mo_num)]
implicit none
BEGIN_DOC
! Transformed one-e integrals
END_DOC
integer :: i,j, p, q
real*8 :: d(n_act_orb)
one_ints_no(:,:)=mo_one_e_integrals(:,:)
! 1st half-trf
do j=1,mo_num
do p=1,n_act_orb
d(p)=0.D0
end do
do p=1,n_act_orb
do q=1,n_act_orb
d(p)+=one_ints_no(list_act(q),j)*natorbsCI(q,p)
end do
end do
do p=1,n_act_orb
one_ints_no(list_act(p),j)=d(p)
end do
end do
! 2nd half-trf
do j=1,mo_num
do p=1,n_act_orb
d(p)=0.D0
end do
do p=1,n_act_orb
do q=1,n_act_orb
d(p)+=one_ints_no(j,list_act(q))*natorbsCI(q,p)
end do
end do
do p=1,n_act_orb
one_ints_no(j,list_act(p))=d(p)
end do
end do
END_PROVIDER
BEGIN_PROVIDER [ double precision, NatOrbsCI_mos, (mo_num, mo_num) ]
implicit none
BEGIN_DOC
! Rotation matrix from current MOs to the CI natural MOs
END_DOC
integer :: p,q
NatOrbsCI_mos(:,:) = 0.d0
do q = 1,mo_num
NatOrbsCI_mos(q,q) = 1.d0
enddo
do q = 1,n_act_orb
do p = 1,n_act_orb
NatOrbsCI_mos(list_act(p),list_act(q)) = natorbsCI(p,q)
enddo
enddo
END_PROVIDER
BEGIN_PROVIDER [real*8, NatOrbsFCI, (ao_num,mo_num)]
implicit none
BEGIN_DOC
! FCI natural orbitals
END_DOC
call dgemm('N','N', ao_num,mo_num,mo_num,1.d0, &
mo_coef, size(mo_coef,1), &
NatOrbsCI_mos, size(NatOrbsCI_mos,1), 0.d0, &
NatOrbsFCI, size(NatOrbsFCI,1))
END_PROVIDER

253
src/casscf_cipsi/neworbs.irp.f Normal file
View File

@ -0,0 +1,253 @@
BEGIN_PROVIDER [real*8, SXmatrix, (nMonoEx+1,nMonoEx+1)]
&BEGIN_PROVIDER [integer, n_guess_sx_mat ]
implicit none
BEGIN_DOC
! Single-excitation matrix
END_DOC
integer :: i,j
do i=1,nMonoEx+1
do j=1,nMonoEx+1
SXmatrix(i,j)=0.D0
end do
end do
do i=1,nMonoEx
SXmatrix(1,i+1)=gradvec2(i)
SXmatrix(1+i,1)=gradvec2(i)
end do
if(diag_hess_cas)then
do i = 1, nMonoEx
SXmatrix(i+1,i+1) = hessdiag(i)
enddo
else
do i=1,nMonoEx
do j=1,nMonoEx
SXmatrix(i+1,j+1)=hessmat(i,j)
SXmatrix(j+1,i+1)=hessmat(i,j)
end do
end do
endif
do i = 1, nMonoEx
SXmatrix(i+1,i+1) += level_shift_casscf
enddo
n_guess_sx_mat = 1
do i = 1, nMonoEx
if(SXmatrix(i+1,i+1).lt.0.d0 )then
n_guess_sx_mat += 1
endif
enddo
if (bavard) then
do i=2,nMonoEx
write(6,*) ' diagonal of the Hessian : ',i,hessmat(i,i)
end do
end if
END_PROVIDER
BEGIN_PROVIDER [real*8, SXeigenvec, (nMonoEx+1,nMonoEx+1)]
&BEGIN_PROVIDER [real*8, SXeigenval, (nMonoEx+1)]
implicit none
BEGIN_DOC
! Eigenvectors/eigenvalues of the single-excitation matrix
END_DOC
if(nMonoEx+1.gt.n_det_max_full)then
if(bavard)then
print*,'Using the Davidson algorithm to diagonalize the SXmatrix'
endif
double precision, allocatable :: u_in(:,:),energies(:)
allocate(u_in(nMonoEx+1,n_states_diag),energies(n_guess_sx_mat))
call davidson_diag_sx_mat(n_guess_sx_mat, u_in, energies)
integer :: i,j
SXeigenvec = 0.d0
SXeigenval = 0.d0
do i = 1, n_guess_sx_mat
SXeigenval(i) = energies(i)
do j = 1, nMonoEx+1
SXeigenvec(j,i) = u_in(j,i)
enddo
enddo
else
if(bavard)then
print*,'Diagonalize the SXmatrix with Jacobi'
endif
call lapack_diag(SXeigenval,SXeigenvec,SXmatrix,nMonoEx+1,nMonoEx+1)
endif
if (bavard) then
write(6,*) ' SXdiag : lowest eigenvalues '
write(6,*) ' 1 - ',SXeigenval(1),SXeigenvec(1,1)
if(n_guess_sx_mat.gt.0)then
write(6,*) ' 2 - ',SXeigenval(2),SXeigenvec(1,2)
write(6,*) ' 3 - ',SXeigenval(3),SXeigenvec(1,3)
write(6,*) ' 4 - ',SXeigenval(4),SXeigenvec(1,4)
write(6,*) ' 5 - ',SXeigenval(5),SXeigenvec(1,5)
endif
write(6,*)
write(6,*) ' SXdiag : lowest eigenvalue = ',SXeigenval(1)
endif
END_PROVIDER
BEGIN_PROVIDER [real*8, energy_improvement]
implicit none
if(state_following_casscf)then
energy_improvement = SXeigenval(best_vector_ovrlp_casscf)
else
energy_improvement = SXeigenval(1)
endif
END_PROVIDER
BEGIN_PROVIDER [ integer, best_vector_ovrlp_casscf ]
&BEGIN_PROVIDER [ double precision, best_overlap_casscf ]
implicit none
integer :: i
double precision :: c0
best_overlap_casscf = 0.D0
best_vector_ovrlp_casscf = -1000
do i=1,nMonoEx+1
if (SXeigenval(i).lt.0.D0) then
if (dabs(SXeigenvec(1,i)).gt.best_overlap_casscf) then
best_overlap_casscf=dabs(SXeigenvec(1,i))
best_vector_ovrlp_casscf = i
end if
end if
end do
if(best_vector_ovrlp_casscf.lt.0)then
best_vector_ovrlp_casscf = minloc(SXeigenval,nMonoEx+1)
endif
c0=SXeigenvec(1,best_vector_ovrlp_casscf)
if (bavard) then
write(6,*) ' SXdiag : eigenvalue for best overlap with '
write(6,*) ' previous orbitals = ',SXeigenval(best_vector_ovrlp_casscf)
write(6,*) ' weight of the 1st element ',c0
endif
END_PROVIDER
BEGIN_PROVIDER [double precision, SXvector, (nMonoEx+1)]
implicit none
BEGIN_DOC
! Best eigenvector of the single-excitation matrix
END_DOC
integer :: i
double precision :: c0
c0=SXeigenvec(1,best_vector_ovrlp_casscf)
do i=1,nMonoEx+1
SXvector(i)=SXeigenvec(i,best_vector_ovrlp_casscf)/c0
end do
END_PROVIDER
BEGIN_PROVIDER [double precision, NewOrbs, (ao_num,mo_num) ]
implicit none
BEGIN_DOC
! Updated orbitals
END_DOC
integer :: i,j,ialph
if(state_following_casscf)then
print*,'Using the state following casscf '
call dgemm('N','T', ao_num,mo_num,mo_num,1.d0, &
NatOrbsFCI, size(NatOrbsFCI,1), &
Umat, size(Umat,1), 0.d0, &
NewOrbs, size(NewOrbs,1))
level_shift_casscf *= 0.5D0
level_shift_casscf = max(level_shift_casscf,0.002d0)
!touch level_shift_casscf
else
if(best_vector_ovrlp_casscf.ne.1.and.n_orb_swap.ne.0)then
print*,'Taking the lowest root for the CASSCF'
print*,'!!! SWAPPING MOS !!!!!!'
level_shift_casscf *= 2.D0
level_shift_casscf = min(level_shift_casscf,0.5d0)
print*,'level_shift_casscf = ',level_shift_casscf
NewOrbs = switch_mo_coef
!mo_coef = switch_mo_coef
!soft_touch mo_coef
!call save_mos_no_occ
!stop
else
level_shift_casscf *= 0.5D0
level_shift_casscf = max(level_shift_casscf,0.002d0)
!touch level_shift_casscf
call dgemm('N','T', ao_num,mo_num,mo_num,1.d0, &
NatOrbsFCI, size(NatOrbsFCI,1), &
Umat, size(Umat,1), 0.d0, &
NewOrbs, size(NewOrbs,1))
endif
endif
END_PROVIDER
BEGIN_PROVIDER [real*8, Umat, (mo_num,mo_num) ]
implicit none
BEGIN_DOC
! Orbital rotation matrix
END_DOC
integer :: i,j,indx,k,iter,t,a,ii,tt,aa
logical :: converged
real*8 :: Tpotmat (mo_num,mo_num), Tpotmat2 (mo_num,mo_num)
real*8 :: Tmat(mo_num,mo_num)
real*8 :: f
! the orbital rotation matrix T
Tmat(:,:)=0.D0
indx=1
do i=1,n_core_inact_orb
ii=list_core_inact(i)
do t=1,n_act_orb
tt=list_act(t)
indx+=1
Tmat(ii,tt)= SXvector(indx)
Tmat(tt,ii)=-SXvector(indx)
end do
end do
do i=1,n_core_inact_orb
ii=list_core_inact(i)
do a=1,n_virt_orb
aa=list_virt(a)
indx+=1
Tmat(ii,aa)= SXvector(indx)
Tmat(aa,ii)=-SXvector(indx)
end do
end do
do t=1,n_act_orb
tt=list_act(t)
do a=1,n_virt_orb
aa=list_virt(a)
indx+=1
Tmat(tt,aa)= SXvector(indx)
Tmat(aa,tt)=-SXvector(indx)
end do
end do
! Form the exponential
Tpotmat(:,:)=0.D0
Umat(:,:) =0.D0
do i=1,mo_num
Tpotmat(i,i)=1.D0
Umat(i,i) =1.d0
end do
iter=0
converged=.false.
do while (.not.converged)
iter+=1
f = 1.d0 / dble(iter)
Tpotmat2(:,:) = Tpotmat(:,:) * f
call dgemm('N','N', mo_num,mo_num,mo_num,1.d0, &
Tpotmat2, size(Tpotmat2,1), &
Tmat, size(Tmat,1), 0.d0, &
Tpotmat, size(Tpotmat,1))
Umat(:,:) = Umat(:,:) + Tpotmat(:,:)
converged = ( sum(abs(Tpotmat(:,:))) < 1.d-6).or.(iter>30)
end do
END_PROVIDER

70
src/casscf_cipsi/reorder_orb.irp.f Normal file
View File

@ -0,0 +1,70 @@
subroutine reorder_orbitals_for_casscf
implicit none
BEGIN_DOC
! routine that reorders the orbitals of the CASSCF in terms block of core, active and virtual
END_DOC
integer :: i,j,iorb
integer, allocatable :: iorder(:),array(:)
allocate(iorder(mo_num),array(mo_num))
do i = 1, n_core_orb
iorb = list_core(i)
array(iorb) = i
enddo
do i = 1, n_inact_orb
iorb = list_inact(i)
array(iorb) = mo_num + i
enddo
do i = 1, n_act_orb
iorb = list_act(i)
array(iorb) = 2 * mo_num + i
enddo
do i = 1, n_virt_orb
iorb = list_virt(i)
array(iorb) = 3 * mo_num + i
enddo
do i = 1, mo_num
iorder(i) = i
enddo
call isort(array,iorder,mo_num)
double precision, allocatable :: mo_coef_new(:,:)
allocate(mo_coef_new(ao_num,mo_num))
do i = 1, mo_num
mo_coef_new(:,i) = mo_coef(:,iorder(i))
enddo
mo_coef = mo_coef_new
touch mo_coef
list_core_reverse = 0
do i = 1, n_core_orb
list_core(i) = i
list_core_reverse(i) = i
mo_class(i) = "Core"
enddo
list_inact_reverse = 0
do i = 1, n_inact_orb
list_inact(i) = i + n_core_orb
list_inact_reverse(i+n_core_orb) = i
mo_class(i+n_core_orb) = "Inactive"
enddo
list_act_reverse = 0
do i = 1, n_act_orb
list_act(i) = n_core_inact_orb + i
list_act_reverse(n_core_inact_orb + i) = i
mo_class(n_core_inact_orb + i) = "Active"
enddo
list_virt_reverse = 0
do i = 1, n_virt_orb
list_virt(i) = n_core_inact_orb + n_act_orb + i
list_virt_reverse(n_core_inact_orb + n_act_orb + i) = i
mo_class(n_core_inact_orb + n_act_orb + i) = "Virtual"
enddo
touch list_core_reverse list_core list_inact list_inact_reverse list_act list_act_reverse list_virt list_virt_reverse
end

Some files were not shown because too many files have changed in this diff Show More