diff --git a/.github/workflows/compilation.yml b/.github/workflows/compilation.yml index 85daf7db..43e0b901 100644 --- a/.github/workflows/compilation.yml +++ b/.github/workflows/compilation.yml @@ -49,6 +49,7 @@ jobs: ./configure -i resultsFile || : ./configure -i bats || : ./configure -i trexio-nohdf5 || : + ./configure -i qmckl || : ./configure -c ./config/gfortran_debug.cfg - name: Compilation run: | diff --git a/.github/workflows/configuration.yml b/.github/workflows/configuration.yml index 178b394e..15b66f2b 100644 --- a/.github/workflows/configuration.yml +++ b/.github/workflows/configuration.yml @@ -56,6 +56,9 @@ jobs: - name: trexio run: | ./configure -i trexio || echo OK + - name: qmckl + run: | + ./configure -i qmckl || echo OK - name: Final check run: | ./configure -c config/gfortran_debug.cfg diff --git a/bin/python b/bin/python new file mode 100755 index 00000000..c5b1d08f --- /dev/null +++ b/bin/python @@ -0,0 +1,4 @@ +#!/bin/bash + +exec python3 $@ + diff --git a/bin/qp_plugins b/bin/qp_plugins index c9158422..e53b08e9 100755 --- a/bin/qp_plugins +++ b/bin/qp_plugins @@ -127,6 +127,7 @@ def main(arguments): l_repository = list(d_tmp.keys()) if l_repository == []: l_result = [] + l_plugins = [] else: m_instance = ModuleHandler(l_repository) l_plugins = [module for module in m_instance.l_module] diff --git a/bin/qp_reset b/bin/qp_reset index d94ab24c..b144c4ce 100755 --- a/bin/qp_reset +++ b/bin/qp_reset @@ -97,6 +97,8 @@ if [[ $dets -eq 1 ]] ; then rm --force -- ${ezfio}/determinants/psi_{det,coef}.gz rm --force -- ${ezfio}/determinants/n_det_qp_edit rm --force -- ${ezfio}/determinants/psi_{det,coef}_qp_edit.gz + rm --force -- ${ezfio}/tc_bi_ortho/psi_{l,r}_coef_bi_ortho.gz + fi if [[ $mos -eq 1 ]] ; then diff --git a/bin/qpsh b/bin/qpsh index 1c511248..8db562bb 100755 --- a/bin/qpsh +++ b/bin/qpsh @@ -1,6 +1,7 @@ #!/bin/bash -export QP_ROOT=$(dirname "$(readlink -f "$0")")/.. +REALPATH=$( cd "$(dirname "$0")" ; pwd -P ) +export QP_ROOT=${REALPATH}/.. bash --init-file <(cat << EOF [[ -f /etc/bashrc ]] && source /etc/bashrc diff --git a/bin/zcat b/bin/zcat new file mode 100755 index 00000000..7ccecf07 --- /dev/null +++ b/bin/zcat @@ -0,0 +1,23 @@ +#!/bin/bash + +# On Darwin: try gzcat if available, otherwise use Python + +if [[ $(uname -s) = Darwin ]] ; then + which gzcat &> /dev/null + if [[ $? -eq 0 ]] ; then + exec gzcat $@ + else + + exec python3 << EOF +import sys +import gzip +with gzip.open("$1", "rt") as f: + print(f.read()) +EOF + fi +else + SCRIPTPATH="$( cd -- "$(dirname "$0")" >/dev/null 2>&1 ; pwd -P )" + command=$(which -a zcat | grep -v "$SCRIPTPATH/" | head -1) + exec $command $@ +fi + diff --git a/config/flang_avx.cfg b/config/flang_avx.cfg new file mode 100644 index 00000000..625c3843 --- /dev/null +++ b/config/flang_avx.cfg @@ -0,0 +1,62 @@ +# Common flags +############## +# +# -ffree-line-length-none : Needed for IRPF90 which produces long lines +# -lblas -llapack : Link with libblas and liblapack libraries provided by the system +# -I . : Include the curent directory (Mandatory) +# +# --ninja : Allow the utilisation of ninja. (Mandatory) +# --align=32 : Align all provided arrays on a 32-byte boundary +# +# +[COMMON] +FC : 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 + diff --git a/config/gfortran.cfg b/config/gfortran.cfg index 33ce48ba..41181c32 100644 --- a/config/gfortran.cfg +++ b/config/gfortran.cfg @@ -10,7 +10,7 @@ # # [COMMON] -FC : gfortran -g -ffree-line-length-none -I . -fPIC -march=native +FC : gfortran -g -ffree-line-length-none -I . -fPIC -march=native -std=legacy LAPACK_LIB : -lblas -llapack IRPF90 : irpf90 IRPF90_FLAGS : --ninja --align=32 --assert -DSET_NESTED diff --git a/config/gfortran10.cfg b/config/gfortran10.cfg new file mode 100644 index 00000000..03eaccd1 --- /dev/null +++ b/config/gfortran10.cfg @@ -0,0 +1,62 @@ +# Common flags +############## +# +# -ffree-line-length-none : Needed for IRPF90 which produces long lines +# -lblas -llapack : Link with libblas and liblapack libraries provided by the system +# -I . : Include the curent directory (Mandatory) +# +# --ninja : Allow the utilisation of ninja. (Mandatory) +# --align=32 : Align all provided arrays on a 32-byte boundary +# +# +[COMMON] +FC : gfortran-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 + diff --git a/config/gfortran_armpl.cfg b/config/gfortran_armpl.cfg index 370e396e..245cc8ea 100644 --- a/config/gfortran_armpl.cfg +++ b/config/gfortran_armpl.cfg @@ -13,7 +13,7 @@ # # [COMMON] -FC : gfortran -g -ffree-line-length-none -I . -fPIC -march=native +FC : gfortran -g -ffree-line-length-none -I . -fPIC -march=native -std=legacy LAPACK_LIB : -larmpl_lp64_mp IRPF90 : irpf90 IRPF90_FLAGS : --ninja --align=32 --assert -DSET_NESTED diff --git a/config/gfortran_avx.cfg b/config/gfortran_avx.cfg index 747dff67..5b51c640 100644 --- a/config/gfortran_avx.cfg +++ b/config/gfortran_avx.cfg @@ -10,7 +10,7 @@ # # [COMMON] -FC : gfortran -ffree-line-length-none -I . -mavx -g -fPIC +FC : gfortran -ffree-line-length-none -I . -mavx -g -fPIC -std=legacy LAPACK_LIB : -llapack -lblas IRPF90 : irpf90 IRPF90_FLAGS : --ninja --align=32 -DSET_NESTED diff --git a/config/gfortran_debug.cfg b/config/gfortran_debug.cfg index 51e5a500..f903142a 100644 --- a/config/gfortran_debug.cfg +++ b/config/gfortran_debug.cfg @@ -10,7 +10,7 @@ # # [COMMON] -FC : gfortran -g -ffree-line-length-none -I . -fPIC +FC : gfortran -g -ffree-line-length-none -I . -fPIC -std=legacy LAPACK_LIB : -lblas -llapack IRPF90 : irpf90 IRPF90_FLAGS : --ninja --align=32 --assert -DSET_NESTED diff --git a/config/gfortran_macos.cfg b/config/gfortran_macos.cfg new file mode 100644 index 00000000..4fffca29 --- /dev/null +++ b/config/gfortran_macos.cfg @@ -0,0 +1,62 @@ +# Common flags +############## +# +# -ffree-line-length-none : Needed for IRPF90 which produces long lines +# -lblas -llapack : Link with libblas and liblapack libraries provided by the system +# -I . : Include the curent directory (Mandatory) +# +# --ninja : Allow the utilisation of ninja. (Mandatory) +# --align=32 : Align all provided arrays on a 32-byte boundary +# +# +[COMMON] +FC : gfortran -ffree-line-length-none -I . -g -fPIC -std=legacy +LAPACK_LIB : -llapack -lblas +IRPF90 : irpf90 +IRPF90_FLAGS : --ninja --align=32 -DSET_NESTED -DMACOS + +# Global options +################ +# +# 1 : Activate +# 0 : Deactivate +# +[OPTION] +MODE : OPT ; [ OPT | PROFILE | DEBUG ] : Chooses the section below +CACHE : 0 ; Enable cache_compile.py +OPENMP : 1 ; Append OpenMP flags + +# Optimization flags +#################### +# +# -Ofast : Disregard strict standards compliance. Enables all -O3 optimizations. +# It also enables optimizations that are not valid +# for all standard-compliant programs. It turns on +# -ffast-math and the Fortran-specific +# -fno-protect-parens and -fstack-arrays. +[OPT] +FCFLAGS : -Ofast -march=native + +# Profiling flags +################# +# +[PROFILE] +FC : -p -g +FCFLAGS : -Ofast + +# Debugging flags +################# +# +# -fcheck=all : Checks uninitialized variables, array subscripts, etc... +# -g : Extra debugging information +# +[DEBUG] +FCFLAGS : -fcheck=all -g + +# OpenMP flags +################# +# +[OPENMP] +FC : -fopenmp +IRPF90_FLAGS : --openmp + diff --git a/config/gfortran_mpi.cfg b/config/gfortran_mpi.cfg index 1af3ca45..7cc88f1f 100644 --- a/config/gfortran_mpi.cfg +++ b/config/gfortran_mpi.cfg @@ -10,7 +10,7 @@ # # [COMMON] -FC : mpif90 -ffree-line-length-none -I . -g -fPIC +FC : mpif90 -ffree-line-length-none -I . -g -fPIC -std=legacy LAPACK_LIB : -lblas -llapack IRPF90 : irpf90 IRPF90_FLAGS : --ninja --align=32 -DMPI -DSET_NESTED diff --git a/config/gfortran_mpi_mkl.cfg b/config/gfortran_mpi_mkl.cfg new file mode 100644 index 00000000..7cc88f1f --- /dev/null +++ b/config/gfortran_mpi_mkl.cfg @@ -0,0 +1,62 @@ +# Common flags +############## +# +# -ffree-line-length-none : Needed for IRPF90 which produces long lines +# -lblas -llapack : Link with libblas and liblapack libraries provided by the system +# -I . : Include the curent directory (Mandatory) +# +# --ninja : Allow the utilisation of ninja. (Mandatory) +# --align=32 : Align all provided arrays on a 32-byte boundary +# +# +[COMMON] +FC : 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 + diff --git a/config/gfortran_openblas.cfg b/config/gfortran_openblas.cfg index ab67d8c3..5db46fce 100644 --- a/config/gfortran_openblas.cfg +++ b/config/gfortran_openblas.cfg @@ -10,7 +10,7 @@ # # [COMMON] -FC : gfortran -g -ffree-line-length-none -I . -fPIC -march=native +FC : gfortran -g -ffree-line-length-none -I . -fPIC -march=native -std=legacy LAPACK_LIB : -lopenblas IRPF90 : irpf90 IRPF90_FLAGS : --ninja --align=32 --assert -DSET_NESTED diff --git a/config/ifort_2019_avx_notz.cfg b/config/ifort_2019_avx_notz.cfg new file mode 100644 index 00000000..f68b256d --- /dev/null +++ b/config/ifort_2019_avx_notz.cfg @@ -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 + diff --git a/config/ifort_2019_debug.cfg b/config/ifort_2019_debug.cfg index cb14f467..8c16c4ac 100644 --- a/config/ifort_2019_debug.cfg +++ b/config/ifort_2019_debug.cfg @@ -7,7 +7,7 @@ # [COMMON] FC : ifort -fpic -LAPACK_LIB : -mkl=parallel -lirc -lsvml -limf -lipps +LAPACK_LIB : -mkl=parallel IRPF90 : irpf90 IRPF90_FLAGS : --ninja --align=32 --assert -DINTEL -DSET_NESTED diff --git a/config/ifort_2021_avx_notz.cfg b/config/ifort_2021_avx_notz.cfg new file mode 100644 index 00000000..1fa595d7 --- /dev/null +++ b/config/ifort_2021_avx_notz.cfg @@ -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 + diff --git a/config/ifort_2021_debug.cfg b/config/ifort_2021_debug.cfg index d70b1465..80802f33 100644 --- a/config/ifort_2021_debug.cfg +++ b/config/ifort_2021_debug.cfg @@ -7,7 +7,7 @@ # [COMMON] FC : ifort -fpic -LAPACK_LIB : -mkl=parallel -lirc -lsvml -limf -lipps +LAPACK_LIB : -mkl=parallel IRPF90 : irpf90 IRPF90_FLAGS : --ninja --align=32 --assert -DINTEL diff --git a/configure b/configure index 48e6fd12..e211cfd7 100755 --- a/configure +++ b/configure @@ -19,7 +19,11 @@ git submodule init git submodule update # Update ARM or x86 dependencies -ARCHITECTURE=$(uname -m) +SYSTEM=$(uname -s) +if [[ $SYSTEM = "Linux" ]] ; then + SYSTEM="" +fi +ARCHITECTURE=$(uname -m)$SYSTEM cd ${QP_ROOT}/external/qp2-dependencies git checkout master git pull @@ -211,9 +215,10 @@ EOF execute << EOF cd "\${QP_ROOT}"/external 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} - ./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 tar -zxvf "\${QP_ROOT}"/external/qp2-dependencies/${ARCHITECTURE}/ninja.tar.gz mv ninja "\${QP_ROOT}"/bin/ @@ -224,11 +229,36 @@ EOF execute << EOF cd "\${QP_ROOT}"/external 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} - ./configure --prefix=\${QP_ROOT} + ./configure --prefix=\${QP_ROOT} CFLAGS="-g" make -j 8 && make -j 8 check && make -j 8 install 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 elif [[ ${PACKAGE} = gmp ]] ; then @@ -249,6 +279,7 @@ EOF cd "\${QP_ROOT}"/external tar --gunzip --extract --file qp2-dependencies/zeromq-4.2.5.tar.gz cd zeromq-* + [[ "${SYSTEM}" = "Darwin" ]] && ./autogen.sh ./configure --prefix="\$QP_ROOT" --without-libsodium --enable-libunwind=no make -j 8 make install @@ -367,10 +398,16 @@ fi TREXIO=$(find_lib -ltrexio) if [[ ${TREXIO} = $(not_found) ]] ; then - error "TREXIO (trexio,trexio-nohdf5) is not installed. If you don't have HDF5, use trexio-nohdf5" + error "TREXIO (trexio | trexio-nohdf5) is not installed. If you don't have HDF5, use trexio-nohdf5" fail fi +#QMCKL=$(find_lib -lqmckl) +#if [[ ${QMCKL} = $(not_found) ]] ; then +# error "QMCkl (qmckl | qmckl-intel) is not installed." +# fail +#fi + F77ZMQ=$(find_lib -lzmq -lf77zmq -lpthread) if [[ ${F77ZMQ} = $(not_found) ]] ; then error "Fortran binding of ZeroMQ (f77zmq) is not installed." diff --git a/data/basis/cc-pv5z_ecp_bfd b/data/basis/cc-pv5z_ecp_bfd index 84b0300e..1d4cebff 100644 --- a/data/basis/cc-pv5z_ecp_bfd +++ b/data/basis/cc-pv5z_ecp_bfd @@ -1,5 +1,5 @@ ALUMINUM -s 9 1.00 +s 9 1 0.045518 0.206193 2 0.100308 0.559887 3 0.221051 0.407852 @@ -9,15 +9,15 @@ s 9 1.00 7 5.213294 -0.003935 8 11.488606 0.000470 9 25.317597 -0.000014 -s 1 1.00 +s 1 1 0.056415 1.000000 -s 1 1.00 +s 1 1 0.155063 1.000000 -s 1 1.00 +s 1 1 0.332041 1.000000 -s 1 1.00 +s 1 1 0.725343 1.000000 -p 9 1.00 +p 9 1 0.014848 0.009932 2 0.030967 0.160212 3 0.064586 0.389171 @@ -27,37 +27,37 @@ p 9 1.00 7 1.221985 -0.053293 8 2.548578 0.004846 9 5.315330 -0.000726 -p 1 1.00 +p 1 1 0.033949 1.000000 -p 1 1.00 +p 1 1 0.083154 1.000000 -p 1 1.00 +p 1 1 0.251360 1.000000 -p 1 1.00 +p 1 1 0.314422 1.000000 -d 1 1.00 +d 1 1 0.088651 1.000000 -d 1 1.00 +d 1 1 0.241216 1.000000 -d 1 1.00 +d 1 1 0.575129 1.000000 -d 1 1.00 +d 1 1 0.989127 1.000000 -f 1 1.00 +f 1 1 0.148598 1.000000 -f 1 1.00 +f 1 1 0.374850 1.000000 -f 1 1.00 +f 1 1 0.781006 1.000000 -g 1 1.00 +g 1 1 0.259548 1.000000 -g 1 1.00 +g 1 1 0.561381 1.000000 -h 1 1.00 +h 1 1 0.328731 1.000000 ARSENIC -s 9 1.00 +s 9 1 0.147347 0.155473 2 0.312164 0.494617 3 0.661339 0.526705 @@ -67,15 +67,15 @@ s 9 1.00 7 13.322677 -0.000115 8 28.224956 -0.000595 9 59.796402 0.000127 -s 1 1.00 +s 1 1 0.189594 1.000000 -s 1 1.00 +s 1 1 0.778040 1.000000 -s 1 1.00 +s 1 1 0.971266 1.000000 -s 1 1.00 +s 1 1 1.979612 1.000000 -p 9 1.00 +p 9 1 0.090580 0.079101 2 0.188085 0.260718 3 0.390548 0.395065 @@ -85,37 +85,37 @@ p 9 1.00 7 7.260371 -0.001407 8 15.075781 0.001710 9 31.304069 -0.000275 -p 1 1.00 +p 1 1 0.133916 1.000000 -p 1 1.00 +p 1 1 0.356186 1.000000 -p 1 1.00 +p 1 1 0.833562 1.000000 -p 1 1.00 +p 1 1 1.430927 1.000000 -d 1 1.00 +d 1 1 0.268113 1.000000 -d 1 1.00 +d 1 1 0.697753 1.000000 -d 1 1.00 +d 1 1 1.185366 1.000000 -d 1 1.00 +d 1 1 2.118102 1.000000 -f 1 1.00 +f 1 1 0.422461 1.000000 -f 1 1.00 +f 1 1 0.973776 1.000000 -f 1 1.00 +f 1 1 2.020616 1.000000 -g 1 1.00 +g 1 1 0.695217 1.000000 -g 1 1.00 +g 1 1 1.690111 1.000000 -h 1 1.00 +h 1 1 1.258944 1.000000 BERYLLIUM -s 9 1.00 +s 9 1 0.030068 0.025105 2 0.054002 0.178890 3 0.096986 0.263939 @@ -125,15 +125,15 @@ s 9 1.00 7 1.009077 -0.114576 8 1.812290 -0.067207 9 3.254852 0.017250 -s 1 1.00 +s 1 1 0.012778 1.000000 -s 1 1.00 +s 1 1 0.108807 1.000000 -s 1 1.00 +s 1 1 0.216157 1.000000 -s 1 1.00 +s 1 1 1.207279 1.000000 -p 9 1.00 +p 9 1 0.015064 0.735052 2 0.028584 -0.476214 3 0.054236 0.564806 @@ -143,37 +143,37 @@ p 9 1.00 7 0.703030 0.067510 8 1.333967 -0.002868 9 2.531139 0.017869 -p 1 1.00 +p 1 1 0.072561 1.000000 -p 1 1.00 +p 1 1 0.501715 1.000000 -p 1 1.00 +p 1 1 0.184471 1.000000 -p 1 1.00 +p 1 1 2.128672 1.000000 -d 1 1.00 +d 1 1 0.090175 1.000000 -d 1 1.00 +d 1 1 0.743653 1.000000 -d 1 1.00 +d 1 1 0.238494 1.000000 -d 1 1.00 +d 1 1 0.933001 1.000000 -f 1 1.00 +f 1 1 0.129140 1.000000 -f 1 1.00 +f 1 1 0.299150 1.000000 -f 1 1.00 +f 1 1 0.739023 1.000000 -g 1 1.00 +g 1 1 0.316080 1.000000 -g 1 1.00 +g 1 1 0.863442 1.000000 -h 1 1.00 +h 1 1 0.409080 1.000000 BORON -s 9 1.00 +s 9 1 0.040569 0.032031 2 0.081044 0.243317 3 0.161898 0.434636 @@ -183,15 +183,15 @@ s 9 1.00 7 2.578276 -0.098781 8 5.150520 0.016164 9 10.288990 -0.000016 -s 1 1.00 +s 1 1 0.070664 1.000000 -s 1 1.00 +s 1 1 0.170896 1.000000 -s 1 1.00 +s 1 1 0.375720 1.000000 -s 1 1.00 +s 1 1 0.614105 1.000000 -p 9 1.00 +p 9 1 0.029207 0.019909 2 0.058408 0.141775 3 0.116803 0.294463 @@ -201,37 +201,37 @@ p 9 1.00 7 1.868068 0.066454 8 3.735743 0.021248 9 7.470701 0.002837 -p 1 1.00 +p 1 1 0.057917 1.000000 -p 1 1.00 +p 1 1 0.143772 1.000000 -p 1 1.00 +p 1 1 0.436327 1.000000 -p 1 1.00 +p 1 1 0.566611 1.000000 -d 1 1.00 +d 1 1 0.134838 1.000000 -d 1 1.00 +d 1 1 0.380163 1.000000 -d 1 1.00 +d 1 1 0.808233 1.000000 -d 1 1.00 +d 1 1 1.022256 1.000000 -f 1 1.00 +f 1 1 0.272717 1.000000 -f 1 1.00 +f 1 1 0.799174 1.000000 -f 1 1.00 +f 1 1 1.002171 1.000000 -g 1 1.00 +g 1 1 0.486131 1.000000 -g 1 1.00 +g 1 1 0.824366 1.000000 -h 1 1.00 +h 1 1 0.632779 1.000000 CHLORINE -s 9 1.00 +s 9 1 0.119944 0.148917 2 0.257348 0.503616 3 0.552157 0.523995 @@ -241,15 +241,15 @@ s 9 1.00 7 11.701243 -0.001301 8 25.105812 -0.000294 9 53.866226 0.000076 -s 1 1.00 +s 1 1 0.152049 1.000000 -s 1 1.00 +s 1 1 0.639110 1.000000 -s 1 1.00 +s 1 1 0.801438 1.000000 -s 1 1.00 +s 1 1 1.671380 1.000000 -p 9 1.00 +p 9 1 0.074374 0.084925 2 0.155084 0.270658 3 0.323378 0.396022 @@ -259,37 +259,37 @@ p 9 1.00 7 6.113450 -0.000951 8 12.747651 0.001501 9 26.581165 -0.000249 -p 1 1.00 +p 1 1 0.103926 1.000000 -p 1 1.00 +p 1 1 0.275582 1.000000 -p 1 1.00 +p 1 1 0.667436 1.000000 -p 1 1.00 +p 1 1 1.171614 1.000000 -d 1 1.00 +d 1 1 0.237419 1.000000 -d 1 1.00 +d 1 1 0.729517 1.000000 -d 1 1.00 +d 1 1 0.924049 1.000000 -d 1 1.00 +d 1 1 1.522182 1.000000 -f 1 1.00 +f 1 1 0.335123 1.000000 -f 1 1.00 +f 1 1 0.789116 1.000000 -f 1 1.00 +f 1 1 1.609975 1.000000 -g 1 1.00 +g 1 1 0.576133 1.000000 -g 1 1.00 +g 1 1 1.402971 1.000000 -h 1 1.00 +h 1 1 1.099609 1.000000 CARBON -s 9 1.00 +s 9 1 0.051344 0.013991 2 0.102619 0.169852 3 0.205100 0.397529 @@ -299,15 +299,15 @@ s 9 1.00 7 3.272791 -0.121499 8 6.541187 0.015176 9 13.073594 -0.000705 -s 1 1.00 +s 1 1 0.098302 1.000000 -s 1 1.00 +s 1 1 0.232034 1.000000 -s 1 1.00 +s 1 1 0.744448 1.000000 -s 1 1.00 +s 1 1 1.009914 1.000000 -p 9 1.00 +p 9 1 0.029281 0.001787 2 0.058547 0.050426 3 0.117063 0.191634 @@ -317,37 +317,37 @@ p 9 1.00 7 1.871016 0.112024 8 3.741035 0.054425 9 7.480076 0.021931 -p 1 1.00 +p 1 1 0.084047 1.000000 -p 1 1.00 +p 1 1 0.216618 1.000000 -p 1 1.00 +p 1 1 0.576869 1.000000 -p 1 1.00 +p 1 1 1.006252 1.000000 -d 1 1.00 +d 1 1 0.206619 1.000000 -d 1 1.00 +d 1 1 0.606933 1.000000 -d 1 1.00 +d 1 1 1.001526 1.000000 -d 1 1.00 +d 1 1 1.504882 1.000000 -f 1 1.00 +f 1 1 0.400573 1.000000 -f 1 1.00 +f 1 1 1.099564 1.000000 -f 1 1.00 +f 1 1 1.501091 1.000000 -g 1 1.00 +g 1 1 0.797648 1.000000 -g 1 1.00 +g 1 1 1.401343 1.000000 -h 1 1.00 +h 1 1 1.001703 1.000000 FLUORINE -s 9 1.00 +s 9 1 0.172723 0.070240 2 0.364875 0.311088 3 0.770795 0.444675 @@ -357,15 +357,15 @@ s 9 1.00 7 15.350300 0.009104 8 32.427348 0.000810 9 68.502433 -0.000133 -s 1 1.00 +s 1 1 0.191146 1.000000 -s 1 1.00 +s 1 1 0.459697 1.000000 -s 1 1.00 +s 1 1 1.250265 1.000000 -s 1 1.00 +s 1 1 2.542428 1.000000 -p 9 1.00 +p 9 1 0.101001 0.035321 2 0.204414 0.136924 3 0.413707 0.249353 @@ -375,37 +375,37 @@ p 9 1.00 7 6.941026 0.088542 8 14.047737 0.039843 9 28.430799 0.003378 -p 1 1.00 +p 1 1 0.170574 1.000000 -p 1 1.00 +p 1 1 0.489019 1.000000 -p 1 1.00 +p 1 1 1.505085 1.000000 -p 1 1.00 +p 1 1 2.018698 1.000000 -d 1 1.00 +d 1 1 0.517711 1.000000 -d 1 1.00 +d 1 1 1.523306 1.000000 -d 1 1.00 +d 1 1 3.901897 1.000000 -d 1 1.00 +d 1 1 5.603581 1.000000 -f 1 1.00 +f 1 1 0.981494 1.000000 -f 1 1.00 +f 1 1 2.950321 1.000000 -f 1 1.00 +f 1 1 4.297889 1.000000 -g 1 1.00 +g 1 1 1.638933 1.000000 -g 1 1.00 +g 1 1 4.619953 1.000000 -h 1 1.00 +h 1 1 2.963127 1.000000 HELIUM -s 9 1.00 +s 9 1 0.077786 0.012425 2 0.161528 0.128251 3 0.335425 0.282221 @@ -415,15 +415,15 @@ s 9 1.00 7 6.237154 0.064912 8 12.951926 0.038892 9 26.895662 0.002531 -s 1 1.00 +s 1 1 1.324312 1.000000 -s 1 1.00 +s 1 1 0.876976 1.000000 -s 1 1.00 +s 1 1 0.294075 1.000000 -s 1 1.00 +s 1 1 0.116506 1.000000 -p 8 1.00 +p 8 1 0.228528 -0.000116 2 0.422019 2.116950 3 0.779333 -2.182954 @@ -432,27 +432,27 @@ p 8 1.00 6 4.907934 0.469710 7 9.063386 -0.224631 8 16.737180 0.098422 -p 1 1.00 +p 1 1 6.741009 1.000000 -p 1 1.00 +p 1 1 2.647340 1.000000 -p 1 1.00 +p 1 1 0.893850 1.000000 -d 1 1.00 +d 1 1 1.842278 1.000000 -d 1 1.00 +d 1 1 2.175208 1.000000 -d 1 1.00 +d 1 1 4.285515 1.000000 -f 1 1.00 +f 1 1 0.749734 1.000000 -f 1 1.00 +f 1 1 1.632074 1.000000 -g 1 1.00 +g 1 1 0.623669 1.000000 HYDROGEN -s 9 1.00 +s 9 1 0.013000 0.000706 2 0.029900 -0.002119 3 0.068770 0.057693 @@ -462,15 +462,15 @@ s 9 1.00 7 1.924458 0.097443 8 4.426254 0.029966 9 10.180385 -0.000452 -s 1 1.00 +s 1 1 0.122344 1.000000 -s 1 1.00 +s 1 1 0.402892 1.000000 -s 1 1.00 +s 1 1 0.715047 1.000000 -s 1 1.00 +s 1 1 1.379838 1.000000 -p 9 1.00 +p 9 1 0.003000 0.001242 2 0.007800 -0.000913 3 0.020281 -0.000054 @@ -480,27 +480,27 @@ p 9 1.00 7 0.926774 -0.013929 8 2.409612 -0.009395 9 6.264991 -0.000347 -p 1 1.00 +p 1 1 0.784765 1.000000 -p 1 1.00 +p 1 1 0.173606 1.000000 -p 1 1.00 +p 1 1 0.513665 1.000000 -d 1 1.00 +d 1 1 2.917388 1.000000 -d 1 1.00 +d 1 1 0.466379 1.000000 -d 1 1.00 +d 1 1 1.132171 1.000000 -f 1 1.00 +f 1 1 1.649608 1.000000 -f 1 1.00 +f 1 1 0.793185 1.000000 -g 1 1.00 +g 1 1 1.606813 1.000000 LITHIUM -s 9 1.00 +s 9 1 0.010125 0.007841 2 0.023437 0.258118 3 0.054251 0.423307 @@ -510,15 +510,15 @@ s 9 1.00 7 1.557659 0.007736 8 3.605689 0.003630 9 8.346494 -0.000646 -s 1 1.00 +s 1 1 0.025010 1.000000 -s 1 1.00 +s 1 1 0.104917 1.000000 -s 1 1.00 +s 1 1 0.670681 1.000000 -s 1 1.00 +s 1 1 1.004881 1.000000 -p 9 1.00 +p 9 1 0.018300 -0.005906 2 0.031699 -0.031422 3 0.054908 -0.043628 @@ -528,35 +528,35 @@ p 9 1.00 7 0.494330 -0.030830 8 0.856273 0.006185 9 1.483225 -0.008621 -p 1 1.00 +p 1 1 0.081041 1.000000 -p 1 1.00 +p 1 1 0.138470 1.000000 -p 1 1.00 +p 1 1 0.404355 1.000000 -p 1 1.00 +p 1 1 0.806184 1.000000 -d 1 1.00 +d 1 1 0.065574 1.000000 -d 1 1.00 +d 1 1 0.835758 1.000000 -d 1 1.00 +d 1 1 0.161784 1.000000 -d 1 1.00 +d 1 1 0.986350 1.000000 -f 1 1.00 +f 1 1 0.152988 1.000000 -f 1 1.00 +f 1 1 0.420698 1.000000 -f 1 1.00 +f 1 1 0.856748 1.000000 -g 1 1.00 +g 1 1 0.254479 1.000000 -g 1 1.00 +g 1 1 0.457496 1.000000 MAGNESIUM -s 9 1.00 +s 9 1 0.030975 0.165290 2 0.062959 0.506272 3 0.127970 0.333197 @@ -566,15 +566,15 @@ s 9 1.00 7 2.184285 0.048310 8 4.439759 -0.005312 9 9.024217 0.000465 -s 1 1.00 +s 1 1 0.023503 1.000000 -s 1 1.00 +s 1 1 0.061201 1.000000 -s 1 1.00 +s 1 1 0.764885 1.000000 -s 1 1.00 +s 1 1 1.054291 1.000000 -p 9 1.00 +p 9 1 0.047055 1.502038 2 0.083253 -1.433944 3 0.147298 1.318987 @@ -584,37 +584,37 @@ p 9 1.00 7 1.443383 0.086774 8 2.553745 -0.028677 9 4.518286 0.006085 -p 1 1.00 +p 1 1 0.082386 1.000000 -p 1 1.00 +p 1 1 0.177931 1.000000 -p 1 1.00 +p 1 1 0.385451 1.000000 -p 1 1.00 +p 1 1 0.833239 1.000000 -d 1 1.00 +d 1 1 0.102058 1.000000 -d 1 1.00 +d 1 1 0.815528 1.000000 -d 1 1.00 +d 1 1 0.222855 1.000000 -d 1 1.00 +d 1 1 0.973775 1.000000 -f 1 1.00 +f 1 1 0.141691 1.000000 -f 1 1.00 +f 1 1 0.425441 1.000000 -f 1 1.00 +f 1 1 0.847636 1.000000 -g 1 1.00 +g 1 1 0.171110 1.000000 -g 1 1.00 +g 1 1 0.438459 1.000000 -h 1 1.00 +h 1 1 0.360937 1.000000 SODIUM -s 9 1.00 +s 9 1 0.013061 0.200118 2 0.030041 0.467652 3 0.069092 0.227738 @@ -624,15 +624,15 @@ s 9 1.00 7 1.933315 0.003741 8 4.446533 -0.001117 9 10.226816 0.000244 -s 1 1.00 +s 1 1 0.063999 1.000000 -s 1 1.00 +s 1 1 0.414207 1.000000 -s 1 1.00 +s 1 1 0.848058 1.000000 -s 1 1.00 +s 1 1 1.097178 1.000000 -p 9 1.00 +p 9 1 0.002593 -0.002840 2 0.006741 0.005340 3 0.017525 -0.025936 @@ -642,35 +642,35 @@ p 9 1.00 7 0.800738 0.006199 8 2.081847 -0.001026 9 5.412617 0.000168 -p 1 1.00 +p 1 1 0.062027 1.000000 -p 1 1.00 +p 1 1 0.098643 1.000000 -p 1 1.00 +p 1 1 0.404379 1.000000 -p 1 1.00 +p 1 1 0.845826 1.000000 -d 1 1.00 +d 1 1 0.058125 1.000000 -d 1 1.00 +d 1 1 0.824577 1.000000 -d 1 1.00 +d 1 1 0.131674 1.000000 -d 1 1.00 +d 1 1 0.979694 1.000000 -f 1 1.00 +f 1 1 0.112793 1.000000 -f 1 1.00 +f 1 1 0.429471 1.000000 -f 1 1.00 +f 1 1 0.848460 1.000000 -g 1 1.00 +g 1 1 0.285680 1.000000 -g 1 1.00 +g 1 1 0.467702 1.000000 NEON -s 9 1.00 +s 9 1 0.205835 0.057514 2 0.391384 0.215776 3 0.744196 0.374799 @@ -680,15 +680,15 @@ s 9 1.00 7 9.727994 -0.085909 8 18.497256 0.006816 9 35.171534 0.000206 -s 1 1.00 +s 1 1 0.318678 1.000000 -s 1 1.00 +s 1 1 0.830178 1.000000 -s 1 1.00 +s 1 1 1.591904 1.000000 -s 1 1.00 +s 1 1 2.744999 1.000000 -p 9 1.00 +p 9 1 0.121772 0.029943 2 0.238248 0.114200 3 0.466136 0.219618 @@ -698,37 +698,37 @@ p 9 1.00 7 6.830378 0.112176 8 13.363732 0.063317 9 26.146332 0.008057 -p 1 1.00 +p 1 1 0.218226 1.000000 -p 1 1.00 +p 1 1 0.636921 1.000000 -p 1 1.00 +p 1 1 1.888191 1.000000 -p 1 1.00 +p 1 1 3.020108 1.000000 -d 1 1.00 +d 1 1 0.654924 1.000000 -d 1 1.00 +d 1 1 1.931502 1.000000 -d 1 1.00 +d 1 1 5.027566 1.000000 -d 1 1.00 +d 1 1 6.989700 1.000000 -f 1 1.00 +f 1 1 1.314297 1.000000 -f 1 1.00 +f 1 1 4.065928 1.000000 -f 1 1.00 +f 1 1 5.587487 1.000000 -g 1 1.00 +g 1 1 2.070925 1.000000 -g 1 1.00 +g 1 1 6.073107 1.000000 -h 1 1.00 +h 1 1 3.743118 1.000000 NITROGEN -s 9 1.00 +s 9 1 0.098869 0.067266 2 0.211443 0.334290 3 0.452197 0.454257 @@ -738,15 +738,15 @@ s 9 1.00 7 9.459462 0.014437 8 20.230246 0.000359 9 43.264919 -0.000094 -s 1 1.00 +s 1 1 0.115320 1.000000 -s 1 1.00 +s 1 1 0.286632 1.000000 -s 1 1.00 +s 1 1 0.702011 1.000000 -s 1 1.00 +s 1 1 1.532221 1.000000 -p 9 1.00 +p 9 1 0.073234 0.035758 2 0.145867 0.153945 3 0.290535 0.277656 @@ -756,37 +756,37 @@ p 9 1.00 7 4.572652 0.067219 8 9.107739 0.031594 9 18.140657 0.003301 -p 1 1.00 +p 1 1 0.120601 1.000000 -p 1 1.00 +p 1 1 0.322697 1.000000 -p 1 1.00 +p 1 1 0.978538 1.000000 -p 1 1.00 +p 1 1 1.272759 1.000000 -d 1 1.00 +d 1 1 0.305579 1.000000 -d 1 1.00 +d 1 1 0.891436 1.000000 -d 1 1.00 +d 1 1 1.542532 1.000000 -d 1 1.00 +d 1 1 2.798122 1.000000 -f 1 1.00 +f 1 1 0.587676 1.000000 -f 1 1.00 +f 1 1 1.592967 1.000000 -f 1 1.00 +f 1 1 2.443045 1.000000 -g 1 1.00 +g 1 1 1.038637 1.000000 -g 1 1.00 +g 1 1 2.842018 1.000000 -h 1 1.00 +h 1 1 2.272542 1.000000 OXYGEN -s 9 1.00 +s 9 1 0.125346 0.055741 2 0.268022 0.304848 3 0.573098 0.453752 @@ -796,15 +796,15 @@ s 9 1.00 7 11.980245 0.012024 8 25.616801 0.000407 9 54.775216 -0.000076 -s 1 1.00 +s 1 1 0.160664 1.000000 -s 1 1.00 +s 1 1 0.384526 1.000000 -s 1 1.00 +s 1 1 0.935157 1.000000 -s 1 1.00 +s 1 1 1.937532 1.000000 -p 9 1.00 +p 9 1 0.083598 0.044958 2 0.167017 0.150175 3 0.333673 0.255999 @@ -814,37 +814,37 @@ p 9 1.00 7 5.315785 0.082308 8 10.620108 0.039899 9 21.217318 0.004679 -p 1 1.00 +p 1 1 0.130580 1.000000 -p 1 1.00 +p 1 1 0.372674 1.000000 -p 1 1.00 +p 1 1 1.178227 1.000000 -p 1 1.00 +p 1 1 1.589967 1.000000 -d 1 1.00 +d 1 1 0.401152 1.000000 -d 1 1.00 +d 1 1 1.174596 1.000000 -d 1 1.00 +d 1 1 2.823972 1.000000 -d 1 1.00 +d 1 1 4.292433 1.000000 -f 1 1.00 +f 1 1 0.708666 1.000000 -f 1 1.00 +f 1 1 2.006788 1.000000 -f 1 1.00 +f 1 1 3.223721 1.000000 -g 1 1.00 +g 1 1 1.207657 1.000000 -g 1 1.00 +g 1 1 3.584495 1.000000 -h 1 1.00 +h 1 1 2.615818 1.000000 PHOSPHORUS -s 9 1.00 +s 9 1 0.074718 0.140225 2 0.160834 0.506746 3 0.346202 0.499893 @@ -854,15 +854,15 @@ s 9 1.00 7 7.432561 0.001798 8 15.998924 -0.000314 9 34.438408 0.000088 -s 1 1.00 +s 1 1 0.082092 1.000000 -s 1 1.00 +s 1 1 0.195525 1.000000 -s 1 1.00 +s 1 1 0.434767 1.000000 -s 1 1.00 +s 1 1 1.027573 1.000000 -p 9 1.00 +p 9 1 0.050242 0.072095 2 0.102391 0.278735 3 0.208669 0.411034 @@ -872,37 +872,37 @@ p 9 1.00 7 3.599410 -0.005103 8 7.335418 0.000328 9 14.949217 -0.000046 -p 1 1.00 +p 1 1 0.074159 1.000000 -p 1 1.00 +p 1 1 0.189382 1.000000 -p 1 1.00 +p 1 1 0.470798 1.000000 -p 1 1.00 +p 1 1 0.815677 1.000000 -d 1 1.00 +d 1 1 0.167800 1.000000 -d 1 1.00 +d 1 1 0.457307 1.000000 -d 1 1.00 +d 1 1 1.021650 1.000000 -d 1 1.00 +d 1 1 1.598720 1.000000 -f 1 1.00 +f 1 1 0.214751 1.000000 -f 1 1.00 +f 1 1 0.482380 1.000000 -f 1 1.00 +f 1 1 0.984966 1.000000 -g 1 1.00 +g 1 1 0.406484 1.000000 -g 1 1.00 +g 1 1 0.924507 1.000000 -h 1 1.00 +h 1 1 0.831913 1.000000 SILICON -s 9 1.00 +s 9 1 0.059887 0.167492 2 0.130108 0.532550 3 0.282668 0.464290 @@ -912,15 +912,15 @@ s 9 1.00 7 6.297493 -0.000106 8 13.681707 -0.000145 9 29.724387 0.000067 -s 1 1.00 +s 1 1 0.075500 1.000000 -s 1 1.00 +s 1 1 0.196459 1.000000 -s 1 1.00 +s 1 1 0.424036 1.000000 -s 1 1.00 +s 1 1 0.920486 1.000000 -p 9 1.00 +p 9 1 0.036525 0.078761 2 0.076137 0.308331 3 0.158712 0.417773 @@ -930,37 +930,37 @@ p 9 1.00 7 2.996797 0.000744 8 6.246966 -0.000259 9 13.022097 -0.000022 -p 1 1.00 +p 1 1 0.048136 1.000000 -p 1 1.00 +p 1 1 0.115813 1.000000 -p 1 1.00 +p 1 1 0.238594 1.000000 -p 1 1.00 +p 1 1 0.496918 1.000000 -d 1 1.00 +d 1 1 0.127945 1.000000 -d 1 1.00 +d 1 1 0.353096 1.000000 -d 1 1.00 +d 1 1 0.805426 1.000000 -d 1 1.00 +d 1 1 1.247695 1.000000 -f 1 1.00 +f 1 1 0.172876 1.000000 -f 1 1.00 +f 1 1 0.402208 1.000000 -f 1 1.00 +f 1 1 0.833081 1.000000 -g 1 1.00 +g 1 1 0.299885 1.000000 -g 1 1.00 +g 1 1 0.647054 1.000000 -h 1 1.00 +h 1 1 0.557542 1.000000 SULFUR -s 9 1.00 +s 9 1 0.095120 0.140074 2 0.202385 0.490942 3 0.430611 0.515297 @@ -970,15 +970,15 @@ s 9 1.00 7 8.824926 0.007266 8 18.776623 -0.001602 9 39.950656 0.000271 -s 1 1.00 +s 1 1 0.113918 1.000000 -s 1 1.00 +s 1 1 0.282790 1.000000 -s 1 1.00 +s 1 1 0.626702 1.000000 -s 1 1.00 +s 1 1 1.338226 1.000000 -p 9 1.00 +p 9 1 0.057087 0.081938 2 0.115901 0.251826 3 0.235305 0.376344 @@ -988,32 +988,32 @@ p 9 1.00 7 3.997726 -0.017191 8 8.116307 0.002580 9 16.477979 -0.000222 -p 1 1.00 +p 1 1 0.079101 1.000000 -p 1 1.00 +p 1 1 0.210632 1.000000 -p 1 1.00 +p 1 1 0.522537 1.000000 -p 1 1.00 +p 1 1 0.924454 1.000000 -d 1 1.00 +d 1 1 0.186546 1.000000 -d 1 1.00 +d 1 1 0.462328 1.000000 -d 1 1.00 +d 1 1 0.955579 1.000000 -d 1 1.00 +d 1 1 2.334308 1.000000 -f 1 1.00 +f 1 1 0.274343 1.000000 -f 1 1.00 +f 1 1 0.661568 1.000000 -f 1 1.00 +f 1 1 1.389533 1.000000 -g 1 1.00 +g 1 1 0.486698 1.000000 -g 1 1.00 +g 1 1 1.166495 1.000000 -h 1 1.00 +h 1 1 0.839494 1.000000 diff --git a/data/pseudo/def2 b/data/pseudo/def2 new file mode 100644 index 00000000..4278e77b --- /dev/null +++ b/data/pseudo/def2 @@ -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 diff --git a/etc/paths.rc b/etc/paths.rc index 84c2d12f..dc1741e8 100644 --- a/etc/paths.rc +++ b/etc/paths.rc @@ -32,7 +32,7 @@ export PYTHONPATH=$(qp_prepend_export "PYTHONPATH" "${QP_EZFIO}/Python":"${QP_PY export PATH=$(qp_prepend_export "PATH" "${QP_PYTHON}":"${QP_ROOT}"/bin:"${QP_ROOT}"/ocaml) -export LD_LIBRARY_PATH=$(qp_prepend_export "LD_LIBRARY_PATH" "${QP_ROOT}"/lib) +export LD_LIBRARY_PATH=$(qp_prepend_export "LD_LIBRARY_PATH" "${QP_ROOT}"/lib:"${QP_ROOT}"/lib64) export LIBRARY_PATH=$(qp_prepend_export "LIBRARY_PATH" "${QP_ROOT}"/lib:"${QP_ROOT}"/lib64) diff --git a/external/ezfio b/external/ezfio index ed1df9f3..dba01c4f 160000 --- a/external/ezfio +++ b/external/ezfio @@ -1 +1 @@ -Subproject commit ed1df9f3c1f51752656ca98da5693a4119add05c +Subproject commit dba01c4fe0ff7b84c5ecfb1c7c77ec68781311b3 diff --git a/external/irpf90 b/external/irpf90 index 33ca5e10..4ab1b175 160000 --- a/external/irpf90 +++ b/external/irpf90 @@ -1 +1 @@ -Subproject commit 33ca5e1018f3bbb5e695e6ee558f5dac0753b271 +Subproject commit 4ab1b175fc7ed0d96c1912f13dc53579b24157a6 diff --git a/ocaml/qptypes_generator.ml b/ocaml/qptypes_generator.ml index a5ac22f2..32506650 100644 --- a/ocaml/qptypes_generator.ml +++ b/ocaml/qptypes_generator.ml @@ -154,8 +154,8 @@ let input_ezfio = " * N_int_number : int determinants_n_int - 1 : 30 - N_int > 30 + 1 : 128 + N_int > 128 * Det_number : int determinants_n_det diff --git a/ocaml/tests/test_pub.py b/ocaml/tests/test_pub.py index e4a883ee..be577685 100755 --- a/ocaml/tests/test_pub.py +++ b/ocaml/tests/test_pub.py @@ -1,4 +1,4 @@ -#!/usr/bin/python +#!/usr/bin/env python3 import zmq import sys, os diff --git a/ocaml/tests/test_task_server.py b/ocaml/tests/test_task_server.py index dac14083..ebbb07ae 100755 --- a/ocaml/tests/test_task_server.py +++ b/ocaml/tests/test_task_server.py @@ -1,4 +1,4 @@ -#!/usr/bin/python +#!/usr/bin/env python3 import zmq import sys, os diff --git a/plugins/.gitignore b/plugins/.gitignore index 241e560d..8b137891 100644 --- a/plugins/.gitignore +++ b/plugins/.gitignore @@ -1,2 +1 @@ -* diff --git a/src/ao_many_one_e_ints/NEED b/plugins/local/ao_many_one_e_ints/NEED similarity index 100% rename from src/ao_many_one_e_ints/NEED rename to plugins/local/ao_many_one_e_ints/NEED diff --git a/src/ao_many_one_e_ints/README.rst b/plugins/local/ao_many_one_e_ints/README.rst similarity index 100% rename from src/ao_many_one_e_ints/README.rst rename to plugins/local/ao_many_one_e_ints/README.rst diff --git a/src/ao_many_one_e_ints/ao_erf_gauss.irp.f b/plugins/local/ao_many_one_e_ints/ao_erf_gauss.irp.f similarity index 87% rename from src/ao_many_one_e_ints/ao_erf_gauss.irp.f rename to plugins/local/ao_many_one_e_ints/ao_erf_gauss.irp.f index b1077161..823536cc 100644 --- a/src/ao_many_one_e_ints/ao_erf_gauss.irp.f +++ b/plugins/local/ao_many_one_e_ints/ao_erf_gauss.irp.f @@ -1245,3 +1245,157 @@ 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 + +! --- + diff --git a/src/ao_many_one_e_ints/ao_erf_gauss_grad.irp.f b/plugins/local/ao_many_one_e_ints/ao_erf_gauss_grad.irp.f similarity index 100% rename from src/ao_many_one_e_ints/ao_erf_gauss_grad.irp.f rename to plugins/local/ao_many_one_e_ints/ao_erf_gauss_grad.irp.f diff --git a/src/ao_many_one_e_ints/ao_gaus_gauss.irp.f b/plugins/local/ao_many_one_e_ints/ao_gaus_gauss.irp.f similarity index 100% rename from src/ao_many_one_e_ints/ao_gaus_gauss.irp.f rename to plugins/local/ao_many_one_e_ints/ao_gaus_gauss.irp.f diff --git a/src/ao_many_one_e_ints/fit_slat_gauss.irp.f b/plugins/local/ao_many_one_e_ints/fit_slat_gauss.irp.f similarity index 100% rename from src/ao_many_one_e_ints/fit_slat_gauss.irp.f rename to plugins/local/ao_many_one_e_ints/fit_slat_gauss.irp.f diff --git a/src/ao_many_one_e_ints/grad2_jmu_manu.irp.f b/plugins/local/ao_many_one_e_ints/grad2_jmu_manu.irp.f similarity index 100% rename from src/ao_many_one_e_ints/grad2_jmu_manu.irp.f rename to plugins/local/ao_many_one_e_ints/grad2_jmu_manu.irp.f diff --git a/src/ao_many_one_e_ints/grad2_jmu_modif.irp.f b/plugins/local/ao_many_one_e_ints/grad2_jmu_modif.irp.f similarity index 100% rename from src/ao_many_one_e_ints/grad2_jmu_modif.irp.f rename to plugins/local/ao_many_one_e_ints/grad2_jmu_modif.irp.f diff --git a/src/ao_many_one_e_ints/grad2_jmu_modif_vect.irp.f b/plugins/local/ao_many_one_e_ints/grad2_jmu_modif_vect.irp.f similarity index 100% rename from src/ao_many_one_e_ints/grad2_jmu_modif_vect.irp.f rename to plugins/local/ao_many_one_e_ints/grad2_jmu_modif_vect.irp.f diff --git a/src/ao_many_one_e_ints/grad_lapl_jmu_manu.irp.f b/plugins/local/ao_many_one_e_ints/grad_lapl_jmu_manu.irp.f similarity index 100% rename from src/ao_many_one_e_ints/grad_lapl_jmu_manu.irp.f rename to plugins/local/ao_many_one_e_ints/grad_lapl_jmu_manu.irp.f diff --git a/src/ao_many_one_e_ints/grad_lapl_jmu_modif.irp.f b/plugins/local/ao_many_one_e_ints/grad_lapl_jmu_modif.irp.f similarity index 76% rename from src/ao_many_one_e_ints/grad_lapl_jmu_modif.irp.f rename to plugins/local/ao_many_one_e_ints/grad_lapl_jmu_modif.irp.f index 9af3f9a9..24b33eb5 100644 --- a/src/ao_many_one_e_ints/grad_lapl_jmu_modif.irp.f +++ b/plugins/local/ao_many_one_e_ints/grad_lapl_jmu_modif.irp.f @@ -299,15 +299,12 @@ END_PROVIDER ! --- -BEGIN_PROVIDER [ double precision, v_ij_u_cst_mu_j1b_an, (ao_num, ao_num, n_points_final_grid)] +BEGIN_PROVIDER [double precision, v_ij_u_cst_mu_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) ! - ! TODO - ! one subroutine for all integrals - ! END_DOC include 'constants.include.F' @@ -325,7 +322,7 @@ BEGIN_PROVIDER [ double precision, v_ij_u_cst_mu_j1b_an, (ao_num, ao_num, n_poin double precision, external :: overlap_gauss_r12_ao_with1s double precision, external :: NAI_pol_mult_erf_ao_with1s - print*, ' providing v_ij_u_cst_mu_j1b_an ...' + print*, ' providing v_ij_u_cst_mu_j1b_an_old ...' call wall_time(wall0) provide mu_erf final_grid_points j1b_pen @@ -333,7 +330,7 @@ BEGIN_PROVIDER [ double precision, v_ij_u_cst_mu_j1b_an, (ao_num, ao_num, n_poin ct = inv_sq_pi_2 / mu_erf - v_ij_u_cst_mu_j1b_an = 0.d0 + 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, & @@ -342,7 +339,7 @@ BEGIN_PROVIDER [ double precision, v_ij_u_cst_mu_j1b_an, (ao_num, ao_num, n_poin !$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 List_all_comb_b2_cent, v_ij_u_cst_mu_j1b_an_old) !$OMP DO do ipoint = 1, n_points_final_grid @@ -413,6 +410,125 @@ BEGIN_PROVIDER [ double precision, v_ij_u_cst_mu_j1b_an, (ao_num, ao_num, n_poin ! --- + 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 @@ -434,4 +550,3 @@ BEGIN_PROVIDER [ double precision, v_ij_u_cst_mu_j1b_an, (ao_num, ao_num, n_poin END_PROVIDER ! --- - diff --git a/src/ao_many_one_e_ints/grad_related_ints.irp.f b/plugins/local/ao_many_one_e_ints/grad_related_ints.irp.f similarity index 100% rename from src/ao_many_one_e_ints/grad_related_ints.irp.f rename to plugins/local/ao_many_one_e_ints/grad_related_ints.irp.f diff --git a/src/ao_many_one_e_ints/list_grid.irp.f b/plugins/local/ao_many_one_e_ints/list_grid.irp.f similarity index 100% rename from src/ao_many_one_e_ints/list_grid.irp.f rename to plugins/local/ao_many_one_e_ints/list_grid.irp.f diff --git a/src/ao_many_one_e_ints/listj1b.irp.f b/plugins/local/ao_many_one_e_ints/listj1b.irp.f similarity index 100% rename from src/ao_many_one_e_ints/listj1b.irp.f rename to plugins/local/ao_many_one_e_ints/listj1b.irp.f diff --git a/src/ao_many_one_e_ints/listj1b_sorted.irp.f b/plugins/local/ao_many_one_e_ints/listj1b_sorted.irp.f similarity index 100% rename from src/ao_many_one_e_ints/listj1b_sorted.irp.f rename to plugins/local/ao_many_one_e_ints/listj1b_sorted.irp.f diff --git a/src/ao_many_one_e_ints/prim_int_erf_gauss.irp.f b/plugins/local/ao_many_one_e_ints/prim_int_erf_gauss.irp.f similarity index 100% rename from src/ao_many_one_e_ints/prim_int_erf_gauss.irp.f rename to plugins/local/ao_many_one_e_ints/prim_int_erf_gauss.irp.f diff --git a/src/ao_many_one_e_ints/prim_int_gauss_gauss.irp.f b/plugins/local/ao_many_one_e_ints/prim_int_gauss_gauss.irp.f similarity index 100% rename from src/ao_many_one_e_ints/prim_int_gauss_gauss.irp.f rename to plugins/local/ao_many_one_e_ints/prim_int_gauss_gauss.irp.f diff --git a/src/ao_many_one_e_ints/stg_gauss_int.irp.f b/plugins/local/ao_many_one_e_ints/stg_gauss_int.irp.f similarity index 100% rename from src/ao_many_one_e_ints/stg_gauss_int.irp.f rename to plugins/local/ao_many_one_e_ints/stg_gauss_int.irp.f diff --git a/src/ao_many_one_e_ints/taylor_exp.irp.f b/plugins/local/ao_many_one_e_ints/taylor_exp.irp.f similarity index 100% rename from src/ao_many_one_e_ints/taylor_exp.irp.f rename to plugins/local/ao_many_one_e_ints/taylor_exp.irp.f diff --git a/src/ao_many_one_e_ints/xyz_grad_xyz_ao_pol.irp.f b/plugins/local/ao_many_one_e_ints/xyz_grad_xyz_ao_pol.irp.f similarity index 100% rename from src/ao_many_one_e_ints/xyz_grad_xyz_ao_pol.irp.f rename to plugins/local/ao_many_one_e_ints/xyz_grad_xyz_ao_pol.irp.f diff --git a/src/ao_tc_eff_map/NEED b/plugins/local/ao_tc_eff_map/NEED similarity index 76% rename from src/ao_tc_eff_map/NEED rename to plugins/local/ao_tc_eff_map/NEED index d9edb325..f768b75f 100644 --- a/src/ao_tc_eff_map/NEED +++ b/plugins/local/ao_tc_eff_map/NEED @@ -1,4 +1,4 @@ -ao_two_e_erf_ints +ao_two_e_ints mo_one_e_ints ao_many_one_e_ints dft_utils_in_r diff --git a/src/ao_tc_eff_map/README.rst b/plugins/local/ao_tc_eff_map/README.rst similarity index 100% rename from src/ao_tc_eff_map/README.rst rename to plugins/local/ao_tc_eff_map/README.rst diff --git a/src/ao_tc_eff_map/compute_ints_eff_pot.irp.f b/plugins/local/ao_tc_eff_map/compute_ints_eff_pot.irp.f similarity index 100% rename from src/ao_tc_eff_map/compute_ints_eff_pot.irp.f rename to plugins/local/ao_tc_eff_map/compute_ints_eff_pot.irp.f diff --git a/src/ao_tc_eff_map/fit_j.irp.f b/plugins/local/ao_tc_eff_map/fit_j.irp.f similarity index 100% rename from src/ao_tc_eff_map/fit_j.irp.f rename to plugins/local/ao_tc_eff_map/fit_j.irp.f diff --git a/src/ao_tc_eff_map/integrals_eff_pot_in_map_slave.irp.f b/plugins/local/ao_tc_eff_map/integrals_eff_pot_in_map_slave.irp.f similarity index 100% rename from src/ao_tc_eff_map/integrals_eff_pot_in_map_slave.irp.f rename to plugins/local/ao_tc_eff_map/integrals_eff_pot_in_map_slave.irp.f diff --git a/src/ao_tc_eff_map/map_integrals_eff_pot.irp.f b/plugins/local/ao_tc_eff_map/map_integrals_eff_pot.irp.f similarity index 100% rename from src/ao_tc_eff_map/map_integrals_eff_pot.irp.f rename to plugins/local/ao_tc_eff_map/map_integrals_eff_pot.irp.f diff --git a/src/ao_tc_eff_map/one_e_1bgauss_grad2.irp.f b/plugins/local/ao_tc_eff_map/one_e_1bgauss_grad2.irp.f similarity index 100% rename from src/ao_tc_eff_map/one_e_1bgauss_grad2.irp.f rename to plugins/local/ao_tc_eff_map/one_e_1bgauss_grad2.irp.f diff --git a/src/ao_tc_eff_map/one_e_1bgauss_lap.irp.f b/plugins/local/ao_tc_eff_map/one_e_1bgauss_lap.irp.f similarity index 100% rename from src/ao_tc_eff_map/one_e_1bgauss_lap.irp.f rename to plugins/local/ao_tc_eff_map/one_e_1bgauss_lap.irp.f diff --git a/src/ao_tc_eff_map/one_e_1bgauss_nonherm.irp.f b/plugins/local/ao_tc_eff_map/one_e_1bgauss_nonherm.irp.f similarity index 100% rename from src/ao_tc_eff_map/one_e_1bgauss_nonherm.irp.f rename to plugins/local/ao_tc_eff_map/one_e_1bgauss_nonherm.irp.f diff --git a/src/ao_tc_eff_map/potential.irp.f b/plugins/local/ao_tc_eff_map/potential.irp.f similarity index 100% rename from src/ao_tc_eff_map/potential.irp.f rename to plugins/local/ao_tc_eff_map/potential.irp.f diff --git a/src/ao_tc_eff_map/providers_ao_eff_pot.irp.f b/plugins/local/ao_tc_eff_map/providers_ao_eff_pot.irp.f similarity index 100% rename from src/ao_tc_eff_map/providers_ao_eff_pot.irp.f rename to plugins/local/ao_tc_eff_map/providers_ao_eff_pot.irp.f diff --git a/src/ao_tc_eff_map/two_e_1bgauss_j1.irp.f b/plugins/local/ao_tc_eff_map/two_e_1bgauss_j1.irp.f similarity index 100% rename from src/ao_tc_eff_map/two_e_1bgauss_j1.irp.f rename to plugins/local/ao_tc_eff_map/two_e_1bgauss_j1.irp.f diff --git a/src/ao_tc_eff_map/two_e_1bgauss_j2.irp.f b/plugins/local/ao_tc_eff_map/two_e_1bgauss_j2.irp.f similarity index 100% rename from src/ao_tc_eff_map/two_e_1bgauss_j2.irp.f rename to plugins/local/ao_tc_eff_map/two_e_1bgauss_j2.irp.f diff --git a/src/ao_tc_eff_map/two_e_ints_gauss.irp.f b/plugins/local/ao_tc_eff_map/two_e_ints_gauss.irp.f similarity index 100% rename from src/ao_tc_eff_map/two_e_ints_gauss.irp.f rename to plugins/local/ao_tc_eff_map/two_e_ints_gauss.irp.f diff --git a/src/ao_tc_eff_map/useful_sub.irp.f b/plugins/local/ao_tc_eff_map/useful_sub.irp.f similarity index 100% rename from src/ao_tc_eff_map/useful_sub.irp.f rename to plugins/local/ao_tc_eff_map/useful_sub.irp.f diff --git a/src/basis_correction/51.basis_c.bats b/plugins/local/basis_correction/51.basis_c.bats similarity index 93% rename from src/basis_correction/51.basis_c.bats rename to plugins/local/basis_correction/51.basis_c.bats index 2682361b..914b482b 100644 --- a/src/basis_correction/51.basis_c.bats +++ b/plugins/local/basis_correction/51.basis_c.bats @@ -10,8 +10,8 @@ function run() { qp set perturbation do_pt2 False qp set determinants n_det_max 8000 qp set determinants n_states 1 - qp set davidson threshold_davidson 1.e-10 - qp set davidson n_states_diag 8 + qp set davidson_keywords threshold_davidson 1.e-10 + qp set davidson_keywords n_states_diag 8 qp run fci energy1="$(ezfio get fci energy | tr '[]' ' ' | cut -d ',' -f 1)" eq $energy1 $1 $thresh diff --git a/src/basis_correction/NEED b/plugins/local/basis_correction/NEED similarity index 100% rename from src/basis_correction/NEED rename to plugins/local/basis_correction/NEED diff --git a/src/basis_correction/README.rst b/plugins/local/basis_correction/README.rst similarity index 94% rename from src/basis_correction/README.rst rename to plugins/local/basis_correction/README.rst index 311fec1c..7669a9b2 100644 --- a/src/basis_correction/README.rst +++ b/plugins/local/basis_correction/README.rst @@ -12,7 +12,7 @@ This basis set correction relies mainy on : When HF is a qualitative representation of the electron pairs (i.e. weakly correlated systems), such an approach for \mu(r) is OK. See for instance JPCL, 10, 2931-2937 (2019) for typical flavours of the results. Thanks to the trivial nature of such a two-body rdm, the equation (22) of J. Chem. Phys. 149, 194301 (2018) can be rewritten in a very efficient way, and therefore the limiting factor of such an approach is the AO->MO four-index transformation of the two-electron integrals. - b) "mu_of_r_potential = cas_ful" uses the two-body rdm of CAS-like wave function (i.e. linear combination of Slater determinants developped in an active space with the MOs stored in the EZFIO folder). + b) "mu_of_r_potential = cas_full" uses the two-body rdm of CAS-like wave function (i.e. linear combination of Slater determinants developped in an active space with the MOs stored in the EZFIO folder). If the CAS is properly chosen (i.e. the CAS-like wave function qualitatively represents the wave function of the systems), then such an approach is OK for \mu(r) even in the case of strong correlation. +) The use of DFT correlation functionals with multi-determinant reference (Ecmd). These functionals are originally defined in the RS-DFT framework (see for instance Theor. Chem. Acc.114, 305(2005)) and design to capture short-range correlation effects. A important quantity arising in the Ecmd is the exact on-top pair density of the system, and the main differences of approximated Ecmd relies on different approximations for the exact on-top pair density. diff --git a/src/basis_correction/TODO b/plugins/local/basis_correction/TODO similarity index 100% rename from src/basis_correction/TODO rename to plugins/local/basis_correction/TODO diff --git a/src/basis_correction/basis_correction.irp.f b/plugins/local/basis_correction/basis_correction.irp.f similarity index 100% rename from src/basis_correction/basis_correction.irp.f rename to plugins/local/basis_correction/basis_correction.irp.f diff --git a/src/basis_correction/eff_xi_based_func.irp.f b/plugins/local/basis_correction/eff_xi_based_func.irp.f similarity index 100% rename from src/basis_correction/eff_xi_based_func.irp.f rename to plugins/local/basis_correction/eff_xi_based_func.irp.f diff --git a/src/basis_correction/pbe_on_top.irp.f b/plugins/local/basis_correction/pbe_on_top.irp.f similarity index 98% rename from src/basis_correction/pbe_on_top.irp.f rename to plugins/local/basis_correction/pbe_on_top.irp.f index 9167f459..be3a23d7 100644 --- a/src/basis_correction/pbe_on_top.irp.f +++ b/plugins/local/basis_correction/pbe_on_top.irp.f @@ -39,7 +39,7 @@ grad_rho_a(1:3) = one_e_dm_and_grad_alpha_in_r(1:3,ipoint,istate) grad_rho_b(1:3) = one_e_dm_and_grad_beta_in_r(1:3,ipoint,istate) - if(mu_of_r_potential == "cas_ful")then + if(mu_of_r_potential == "cas_full")then ! You take the on-top of the CAS wave function which is computed with mu(r) on_top = on_top_cas_mu_r(ipoint,istate) else @@ -101,7 +101,7 @@ grad_rho_a(1:3) = one_e_dm_and_grad_alpha_in_r(1:3,ipoint,istate) grad_rho_b(1:3) = one_e_dm_and_grad_beta_in_r(1:3,ipoint,istate) - if(mu_of_r_potential == "cas_ful")then + if(mu_of_r_potential == "cas_full")then ! You take the on-top of the CAS wave function which is computed with mu(r) on_top = on_top_cas_mu_r(ipoint,istate) else @@ -163,7 +163,7 @@ grad_rho_a(1:3) = one_e_dm_and_grad_alpha_in_r(1:3,ipoint,istate) grad_rho_b(1:3) = one_e_dm_and_grad_beta_in_r(1:3,ipoint,istate) - if(mu_of_r_potential == "cas_ful")then + if(mu_of_r_potential == "cas_full")then ! You take the on-top of the CAS wave function which is computed with mu(r) on_top = on_top_cas_mu_r(ipoint,istate) else diff --git a/src/basis_correction/print_routine.irp.f b/plugins/local/basis_correction/print_routine.irp.f similarity index 91% rename from src/basis_correction/print_routine.irp.f rename to plugins/local/basis_correction/print_routine.irp.f index c2558d22..96faba30 100644 --- a/src/basis_correction/print_routine.irp.f +++ b/plugins/local/basis_correction/print_routine.irp.f @@ -4,8 +4,8 @@ subroutine print_basis_correction provide mu_average_prov if(mu_of_r_potential.EQ."hf")then provide ecmd_lda_mu_of_r ecmd_pbe_ueg_mu_of_r - else if(mu_of_r_potential.EQ."cas_ful".or.mu_of_r_potential.EQ."cas_truncated")then - provide ecmd_lda_mu_of_r ecmd_pbe_ueg_mu_of_r + else if(mu_of_r_potential.EQ."cas_full".or.mu_of_r_potential.EQ."cas_truncated")then + provide ecmd_lda_mu_of_r ecmd_pbe_ueg_mu_of_r provide ecmd_pbe_on_top_mu_of_r ecmd_pbe_on_top_su_mu_of_r endif @@ -25,7 +25,7 @@ subroutine print_basis_correction if(mu_of_r_potential.EQ."hf")then print*, '' print*,'Using a HF-like two-body density to define mu(r)' - print*,'This assumes that HF is a qualitative representation of the wave function ' + print*,'This assumes that HF is a qualitative representation of the wave function ' print*,'********************************************' print*,'Functionals more suited for weak correlation' print*,'********************************************' @@ -38,10 +38,10 @@ subroutine print_basis_correction write(*, '(A29,X,I3,X,A3,X,F16.10)') ' ECMD PBE-UEG , state ',istate,' = ',ecmd_pbe_ueg_mu_of_r(istate) enddo - else if(mu_of_r_potential.EQ."cas_ful".or.mu_of_r_potential.EQ."cas_truncated".or.mu_of_r_potential.EQ."pure_act")then + else if(mu_of_r_potential.EQ."cas_full".or.mu_of_r_potential.EQ."cas_truncated".or.mu_of_r_potential.EQ."pure_act")then print*, '' print*,'Using a CAS-like two-body density to define mu(r)' - print*,'This assumes that the CAS is a qualitative representation of the wave function ' + print*,'This assumes that the CAS is a qualitative representation of the wave function ' print*,'********************************************' print*,'Functionals more suited for weak correlation' print*,'********************************************' @@ -56,14 +56,14 @@ subroutine print_basis_correction print*,'' print*,'********************************************' print*,'********************************************' - print*,'+) PBE-on-top Ecmd functional : JCP, 152, 174104 (2020) ' + print*,'+) PBE-on-top Ecmd functional : JCP, 152, 174104 (2020) ' print*,'PBE at mu=0, extrapolated ontop pair density at large mu, usual spin-polarization' do istate = 1, N_states write(*, '(A29,X,I3,X,A3,X,F16.10)') ' ECMD PBE-OT , state ',istate,' = ',ecmd_pbe_on_top_mu_of_r(istate) enddo print*,'' print*,'********************************************' - print*,'+) PBE-on-top no spin polarization Ecmd functional : JCP, 152, 174104 (2020)' + print*,'+) PBE-on-top no spin polarization Ecmd functional : JCP, 152, 174104 (2020)' print*,'PBE at mu=0, extrapolated ontop pair density at large mu, and ZERO SPIN POLARIZATION' do istate = 1, N_states write(*, '(A29,X,I3,X,A3,X,F16.10)') ' ECMD SU-PBE-OT , state ',istate,' = ',ecmd_pbe_on_top_su_mu_of_r(istate) diff --git a/src/basis_correction/print_su_pbe_ot.irp.f b/plugins/local/basis_correction/print_su_pbe_ot.irp.f similarity index 100% rename from src/basis_correction/print_su_pbe_ot.irp.f rename to plugins/local/basis_correction/print_su_pbe_ot.irp.f diff --git a/src/basis_correction/weak_corr_func.irp.f b/plugins/local/basis_correction/weak_corr_func.irp.f similarity index 100% rename from src/basis_correction/weak_corr_func.irp.f rename to plugins/local/basis_correction/weak_corr_func.irp.f diff --git a/src/bi_ort_ints/NEED b/plugins/local/bi_ort_ints/NEED similarity index 100% rename from src/bi_ort_ints/NEED rename to plugins/local/bi_ort_ints/NEED diff --git a/src/bi_ort_ints/README.rst b/plugins/local/bi_ort_ints/README.rst similarity index 100% rename from src/bi_ort_ints/README.rst rename to plugins/local/bi_ort_ints/README.rst diff --git a/src/bi_ort_ints/bi_ort_ints.irp.f b/plugins/local/bi_ort_ints/bi_ort_ints.irp.f similarity index 94% rename from src/bi_ort_ints/bi_ort_ints.irp.f rename to plugins/local/bi_ort_ints/bi_ort_ints.irp.f index cac46b18..0349c731 100644 --- a/src/bi_ort_ints/bi_ort_ints.irp.f +++ b/plugins/local/bi_ort_ints/bi_ort_ints.irp.f @@ -18,10 +18,11 @@ program bi_ort_ints ! call test_5idx ! call test_5idx2 call test_4idx() - call test_4idx_n4() + !call test_4idx_n4() !call test_4idx2() !call test_5idx2 !call test_5idx + end subroutine test_5idx2 @@ -340,7 +341,7 @@ subroutine test_4idx() implicit none integer :: i, j, k, l - double precision :: accu, contrib, new, ref, thr + double precision :: accu, contrib, new, ref, thr, norm thr = 1d-10 @@ -348,6 +349,7 @@ subroutine test_4idx() 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 @@ -356,7 +358,6 @@ subroutine test_4idx() 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) - accu += contrib if(contrib .gt. thr) then print*, ' problem in three_e_4_idx_direct_bi_ort' print*, l, k, j, i @@ -364,11 +365,14 @@ subroutine test_4idx() stop endif + accu += contrib + norm += dabs(ref) enddo enddo enddo enddo - print*, ' accu on three_e_4_idx_direct_bi_ort = ', accu / dble(mo_num)**4 + + print*, ' accu on three_e_4_idx_direct_bi_ort (%) = ', 100.d0 * accu / norm ! --- @@ -376,6 +380,7 @@ subroutine test_4idx() 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 @@ -384,7 +389,6 @@ subroutine test_4idx() 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) - accu += contrib if(contrib .gt. thr) then print*, ' problem in three_e_4_idx_exch13_bi_ort' print*, l, k, j, i @@ -392,11 +396,14 @@ subroutine test_4idx() stop endif + accu += contrib + norm += dabs(ref) enddo enddo enddo enddo - print*, ' accu on three_e_4_idx_exch13_bi_ort = ', accu / dble(mo_num)**4 + + print*, ' accu on three_e_4_idx_exch13_bi_ort (%) = ', 100.d0 * accu / norm ! --- @@ -404,6 +411,7 @@ subroutine test_4idx() 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 @@ -412,7 +420,6 @@ subroutine test_4idx() 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) - accu += contrib if(contrib .gt. thr) then print*, ' problem in three_e_4_idx_cycle_1_bi_ort' print*, l, k, j, i @@ -420,11 +427,14 @@ subroutine test_4idx() stop endif + accu += contrib + norm += dabs(ref) enddo enddo enddo enddo - print*, ' accu on three_e_4_idx_cycle_1_bi_ort = ', accu / dble(mo_num)**4 + + print*, ' accu on three_e_4_idx_cycle_1_bi_ort (%) = ', 100.d0 * accu / norm ! --- @@ -432,6 +442,7 @@ subroutine test_4idx() 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 @@ -440,7 +451,6 @@ subroutine test_4idx() 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) - accu += contrib if(contrib .gt. thr) then print*, ' problem in three_e_4_idx_exch23_bi_ort' print*, l, k, j, i @@ -448,13 +458,18 @@ subroutine test_4idx() stop endif + accu += contrib + norm += dabs(ref) enddo enddo enddo enddo - print*, ' accu on three_e_4_idx_exch23_bi_ort = ', accu / dble(mo_num)**4 + + print*, ' accu on three_e_4_idx_exch23_bi_ort (%) = ', 100.d0 * accu / norm ! --- return end + + diff --git a/src/bi_ort_ints/biorthog_mo_for_h.irp.f b/plugins/local/bi_ort_ints/biorthog_mo_for_h.irp.f similarity index 100% rename from src/bi_ort_ints/biorthog_mo_for_h.irp.f rename to plugins/local/bi_ort_ints/biorthog_mo_for_h.irp.f diff --git a/plugins/local/bi_ort_ints/no_dressing.irp.f b/plugins/local/bi_ort_ints/no_dressing.irp.f new file mode 100644 index 00000000..bd225274 --- /dev/null +++ b/plugins/local/bi_ort_ints/no_dressing.irp.f @@ -0,0 +1,1610 @@ + +! --- + +BEGIN_PROVIDER [double precision, noL_0e_v0] + + implicit none + integer :: i, j, k + double precision :: I_ijk_ijk, I_ijk_kij, I_ijk_jik, I_ijk_jki, I_ijk_ikj, I_ijk_kji + double precision :: t0, t1 + double precision, allocatable :: tmp(:) + + call wall_time(t0) + print*, " Providing noL_0e_v0 ..." + + if(elec_alpha_num .eq. elec_beta_num) then + + allocate(tmp(elec_beta_num)) + + !$OMP PARALLEL & + !$OMP DEFAULT (NONE) & + !$OMP PRIVATE (i, j, k, & + !$OMP I_ijk_ijk, I_ijk_kij, I_ijk_jik) & + !$OMP SHARED (elec_beta_num, tmp) + + !$OMP DO + do i = 1, elec_beta_num + + tmp(i) = 0.d0 + do j = 1, elec_beta_num + do k = 1, elec_beta_num + + call give_integrals_3_body_bi_ort(i, j, k, i, j, k, I_ijk_ijk) + call give_integrals_3_body_bi_ort(i, j, k, k, i, j, I_ijk_kij) + call give_integrals_3_body_bi_ort(i, j, k, j, i, k, I_ijk_jik) + + tmp(i) = tmp(i) + 4.d0 * (2.d0 * I_ijk_ijk + I_ijk_kij - 3.d0 * I_ijk_jik) + enddo + enddo + enddo + !$OMP END DO + !$OMP END PARALLEL + + noL_0e_v0 = -1.d0 * (sum(tmp)) / 6.d0 + + deallocate(tmp) + + else + + allocate(tmp(elec_alpha_num)) + + !$OMP PARALLEL & + !$OMP DEFAULT (NONE) & + !$OMP PRIVATE (i, j, k, & + !$OMP I_ijk_ijk, I_ijk_kij, I_ijk_jik, & + !$OMP I_ijk_jki, I_ijk_ikj, I_ijk_kji) & + !$OMP SHARED (elec_beta_num, elec_alpha_num, tmp) + + !$OMP DO + do i = 1, elec_beta_num + + tmp(i) = 0.d0 + do j = 1, elec_beta_num + do k = 1, elec_beta_num + + call give_integrals_3_body_bi_ort(i, j, k, i, j, k, I_ijk_ijk) + call give_integrals_3_body_bi_ort(i, j, k, k, i, j, I_ijk_kij) + call give_integrals_3_body_bi_ort(i, j, k, j, i, k, I_ijk_jik) + + tmp(i) = tmp(i) + 4.d0 * (2.d0 * I_ijk_ijk + I_ijk_kij - 3.d0 * I_ijk_jik) + enddo + enddo + enddo + !$OMP END DO + + !$OMP DO + do i = elec_beta_num+1, elec_alpha_num + + tmp(i) = 0.d0 + do j = elec_beta_num+1, elec_alpha_num + do k = elec_beta_num+1, elec_alpha_num + + call give_integrals_3_body_bi_ort(i, j, k, i, j, k, I_ijk_ijk) + call give_integrals_3_body_bi_ort(i, j, k, k, i, j, I_ijk_kij) + call give_integrals_3_body_bi_ort(i, j, k, j, i, k, I_ijk_jik) + + tmp(i) = tmp(i) + I_ijk_ijk + 2.d0 * I_ijk_kij - 3.d0 * I_ijk_jik + enddo ! k + enddo ! j + + do j = 1, elec_beta_num + do k = 1, elec_beta_num + + call give_integrals_3_body_bi_ort(i, j, k, i, j, k, I_ijk_ijk) + call give_integrals_3_body_bi_ort(i, j, k, j, k, i, I_ijk_jki) + call give_integrals_3_body_bi_ort(i, j, k, i, k, j, I_ijk_ikj) + call give_integrals_3_body_bi_ort(i, j, k, j, i, k, I_ijk_jik) + + tmp(i) = tmp(i) + 6.d0 * (2.d0 * I_ijk_ijk + I_ijk_jki - I_ijk_ikj - 2.d0 * I_ijk_jik) + enddo ! k + + do k = elec_beta_num+1, elec_alpha_num + + call give_integrals_3_body_bi_ort(i, j, k, i, j, k, I_ijk_ijk) + call give_integrals_3_body_bi_ort(i, j, k, j, k, i, I_ijk_jki) + call give_integrals_3_body_bi_ort(i, j, k, i, k, j, I_ijk_ikj) + call give_integrals_3_body_bi_ort(i, j, k, k, j, i, I_ijk_kji) + + tmp(i) = tmp(i) + 6.d0 * (I_ijk_ijk + I_ijk_jki - I_ijk_ikj - I_ijk_kji) + enddo ! k + enddo ! j + enddo ! i + !$OMP END DO + !$OMP END PARALLEL + + noL_0e_v0 = -1.d0 * (sum(tmp)) / 6.d0 + + deallocate(tmp) + + endif + + call wall_time(t1) + print*, " Wall time for noL_0e_v0 (min) = ", (t1 - t0)/60.d0 + + print*, " noL_0e_v0 = ", noL_0e_v0 + +END_PROVIDER + +! --- + +BEGIN_PROVIDER [double precision, noL_1e_v0, (mo_num, mo_num)] + + implicit none + integer :: p, s, i, j + double precision :: I_pij_sij, I_pij_isj, I_pij_ijs, I_pij_sji, I_pij_jsi, I_pij_jis + double precision :: t0, t1 + + call wall_time(t0) + print*, " Providing noL_1e_v0 ..." + + if(elec_alpha_num .eq. elec_beta_num) then + + !$OMP PARALLEL & + !$OMP DEFAULT (NONE) & + !$OMP PRIVATE (p, s, i, j, & + !$OMP I_pij_sij, I_pij_isj, I_pij_ijs, & + !$OMP I_pij_sji) & + !$OMP SHARED (mo_num, elec_beta_num, noL_1e_v0) + + !$OMP DO COLLAPSE(2) + do s = 1, mo_num + do p = 1, mo_num + + noL_1e_v0(p,s) = 0.d0 + do i = 1, elec_beta_num + do j = 1, elec_beta_num + + call give_integrals_3_body_bi_ort(p, i, j, s, i, j, I_pij_sij) + call give_integrals_3_body_bi_ort(p, i, j, i, s, j, I_pij_isj) + call give_integrals_3_body_bi_ort(p, i, j, i, j, s, I_pij_ijs) + call give_integrals_3_body_bi_ort(p, i, j, s, j, i, I_pij_sji) + + noL_1e_v0(p,s) = noL_1e_v0(p,s) + (2.d0*I_pij_sij - 2.d0*I_pij_isj + I_pij_ijs - I_pij_sji) + enddo + enddo + enddo + enddo + !$OMP END DO + !$OMP END PARALLEL + + else + + !$OMP PARALLEL & + !$OMP DEFAULT (NONE) & + !$OMP PRIVATE (p, s, i, j, & + !$OMP I_pij_sij, I_pij_isj, I_pij_ijs, & + !$OMP I_pij_sji, I_pij_jsi, I_pij_jis) & + !$OMP SHARED (mo_num, elec_beta_num, elec_alpha_num, noL_1e_v0) + + !$OMP DO COLLAPSE(2) + do s = 1, mo_num + do p = 1, mo_num + + noL_1e_v0(p,s) = 0.d0 + do i = 1, elec_beta_num + do j = 1, elec_beta_num + + call give_integrals_3_body_bi_ort(p, i, j, s, i, j, I_pij_sij) + call give_integrals_3_body_bi_ort(p, i, j, i, s, j, I_pij_isj) + call give_integrals_3_body_bi_ort(p, i, j, i, j, s, I_pij_ijs) + call give_integrals_3_body_bi_ort(p, i, j, s, j, i, I_pij_sji) + + noL_1e_v0(p,s) = noL_1e_v0(p,s) + (2.d0*I_pij_sij - 2.d0*I_pij_isj + I_pij_ijs - I_pij_sji) + enddo ! j + enddo ! i + + do i = elec_beta_num+1, elec_alpha_num + do j = 1, elec_beta_num + + call give_integrals_3_body_bi_ort(p, i, j, s, j, i, I_pij_sji) + call give_integrals_3_body_bi_ort(p, i, j, j, s, i, I_pij_jsi) + call give_integrals_3_body_bi_ort(p, i, j, j, i, s, I_pij_jis) + call give_integrals_3_body_bi_ort(p, i, j, s, i, j, I_pij_sij) + call give_integrals_3_body_bi_ort(p, i, j, i, s, j, I_pij_isj) + call give_integrals_3_body_bi_ort(p, i, j, i, j, s, I_pij_ijs) + + noL_1e_v0(p,s) = noL_1e_v0(p,s) - 0.5d0 * (2.d0*I_pij_sji - I_pij_jsi + 2.d0*I_pij_jis - 4.d0*I_pij_sij + 2.d0*I_pij_isj - I_pij_ijs) + enddo ! j + + do j = elec_beta_num+1, elec_alpha_num + + call give_integrals_3_body_bi_ort(p, i, j, s, i, j, I_pij_sij) + call give_integrals_3_body_bi_ort(p, i, j, i, s, j, I_pij_isj) + call give_integrals_3_body_bi_ort(p, i, j, i, j, s, I_pij_ijs) + call give_integrals_3_body_bi_ort(p, i, j, s, j, i, I_pij_sji) + + noL_1e_v0(p,s) = noL_1e_v0(p,s) + 0.5d0 * (I_pij_sij - I_pij_isj + I_pij_ijs - I_pij_sji) + enddo ! j + enddo ! i + + enddo ! p + enddo ! s + !$OMP END DO + !$OMP END PARALLEL + + endif + + call wall_time(t1) + print*, " Wall time for noL_1e_v0 (min) = ", (t1 - t0)/60.d0 + +END_PROVIDER + +! --- + +BEGIN_PROVIDER [double precision, noL_2e_v0, (mo_num, mo_num, mo_num, mo_num)] + + implicit none + integer :: p, q, s, t, i + double precision :: I_ipq_sit, I_ipq_tsi, I_ipq_ist + double precision :: t0, t1 + + call wall_time(t0) + print*, " Providing noL_2e_v0 ..." + + if(elec_alpha_num .eq. elec_beta_num) then + + !$OMP PARALLEL & + !$OMP DEFAULT (NONE) & + !$OMP PRIVATE (p, q, s, t, i, & + !$OMP I_ipq_sit, I_ipq_tsi, I_ipq_ist) & + !$OMP SHARED (mo_num, elec_beta_num, noL_2e_v0) + + !$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_v0(p,q,s,t) = 0.d0 + do i = 1, elec_beta_num + + call give_integrals_3_body_bi_ort(i, p, q, s, i, t, I_ipq_sit) + call give_integrals_3_body_bi_ort(i, p, q, t, s, i, I_ipq_tsi) + call give_integrals_3_body_bi_ort(i, p, q, i, s, t, I_ipq_ist) + + noL_2e_v0(p,q,s,t) = noL_2e_v0(p,q,s,t) + 0.5d0 * (I_ipq_sit + I_ipq_tsi - 2.d0*I_ipq_ist) + enddo + enddo + enddo + enddo + enddo + !$OMP END DO + !$OMP END PARALLEL + + else + + !$OMP PARALLEL & + !$OMP DEFAULT (NONE) & + !$OMP PRIVATE (p, q, s, t, i, & + !$OMP I_ipq_sit, I_ipq_tsi, I_ipq_ist) & + !$OMP SHARED (mo_num, elec_beta_num, elec_alpha_num, noL_2e_v0) + + !$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_v0(p,q,s,t) = 0.d0 + do i = 1, elec_beta_num + + call give_integrals_3_body_bi_ort(i, p, q, s, i, t, I_ipq_sit) + call give_integrals_3_body_bi_ort(i, p, q, t, s, i, I_ipq_tsi) + call give_integrals_3_body_bi_ort(i, p, q, i, s, t, I_ipq_ist) + + noL_2e_v0(p,q,s,t) = noL_2e_v0(p,q,s,t) + 0.5d0 * (I_ipq_sit + I_ipq_tsi - 2.d0*I_ipq_ist) + enddo ! i + + do i = elec_beta_num+1, elec_alpha_num + + call give_integrals_3_body_bi_ort(i, p, q, s, i, t, I_ipq_sit) + call give_integrals_3_body_bi_ort(i, p, q, t, s, i, I_ipq_tsi) + call give_integrals_3_body_bi_ort(i, p, q, i, s, t, I_ipq_ist) + + noL_2e_v0(p,q,s,t) = noL_2e_v0(p,q,s,t) + 0.25d0 * (I_ipq_sit + I_ipq_tsi - 2.d0*I_ipq_ist) + enddo ! i + + enddo ! p + enddo ! q + enddo ! s + enddo ! t + !$OMP END DO + !$OMP END PARALLEL + + endif + + call wall_time(t1) + print*, " Wall time for noL_2e_v0 (min) = ", (t1 - t0)/60.d0 + +END_PROVIDER + +! --- + +BEGIN_PROVIDER [double precision, noL_0e] + + implicit none + integer :: i, j, k, ipoint + double precision :: t0, t1 + double precision, allocatable :: tmp(:) + double precision, allocatable :: tmp_L(:,:), tmp_R(:,:) + double precision, allocatable :: tmp_M(:,:), tmp_S(:), tmp_O(:), tmp_J(:,:) + double precision, allocatable :: tmp_M_priv(:,:), tmp_S_priv(:), tmp_O_priv(:), tmp_J_priv(:,:) + + + call wall_time(t0) + print*, " Providing noL_0e ..." + + if(elec_alpha_num .eq. elec_beta_num) then + + allocate(tmp(elec_beta_num)) + allocate(tmp_L(n_points_final_grid,3), tmp_R(n_points_final_grid,3)) + + !$OMP PARALLEL & + !$OMP DEFAULT(NONE) & + !$OMP PRIVATE(j, i, ipoint, tmp_L, tmp_R) & + !$OMP SHARED(elec_beta_num, n_points_final_grid, & + !$OMP mos_l_in_r_array_transp, mos_r_in_r_array_transp, & + !$OMP int2_grad1_u12_bimo_t, tmp, final_weight_at_r_vector) + + !$OMP DO + do j = 1, elec_beta_num + + tmp_L = 0.d0 + tmp_R = 0.d0 + do i = 1, elec_beta_num + do ipoint = 1, n_points_final_grid + + tmp_L(ipoint,1) = tmp_L(ipoint,1) + int2_grad1_u12_bimo_t(ipoint,1,j,i) * mos_l_in_r_array_transp(ipoint,i) + tmp_L(ipoint,2) = tmp_L(ipoint,2) + int2_grad1_u12_bimo_t(ipoint,2,j,i) * mos_l_in_r_array_transp(ipoint,i) + tmp_L(ipoint,3) = tmp_L(ipoint,3) + int2_grad1_u12_bimo_t(ipoint,3,j,i) * mos_l_in_r_array_transp(ipoint,i) + + tmp_R(ipoint,1) = tmp_R(ipoint,1) + int2_grad1_u12_bimo_t(ipoint,1,i,j) * mos_r_in_r_array_transp(ipoint,i) + tmp_R(ipoint,2) = tmp_R(ipoint,2) + int2_grad1_u12_bimo_t(ipoint,2,i,j) * mos_r_in_r_array_transp(ipoint,i) + tmp_R(ipoint,3) = tmp_R(ipoint,3) + int2_grad1_u12_bimo_t(ipoint,3,i,j) * mos_r_in_r_array_transp(ipoint,i) + enddo + enddo + + tmp(j) = 0.d0 + do ipoint = 1, n_points_final_grid + tmp(j) = tmp(j) + final_weight_at_r_vector(ipoint) * (tmp_L(ipoint,1)*tmp_R(ipoint,1) + tmp_L(ipoint,2)*tmp_R(ipoint,2) + tmp_L(ipoint,3)*tmp_R(ipoint,3)) + enddo + enddo ! j + !$OMP END DO + !$OMP END PARALLEL + + noL_0e = -2.d0 * sum(tmp) + + deallocate(tmp) + deallocate(tmp_L, tmp_R) + + ! --- + + allocate(tmp_O(n_points_final_grid), tmp_J(n_points_final_grid,3)) + tmp_O = 0.d0 + tmp_J = 0.d0 + + !$OMP PARALLEL & + !$OMP DEFAULT(NONE) & + !$OMP PRIVATE(i, ipoint, tmp_O_priv, tmp_J_priv) & + !$OMP SHARED(elec_beta_num, n_points_final_grid, & + !$OMP mos_l_in_r_array_transp, mos_r_in_r_array_transp, & + !$OMP int2_grad1_u12_bimo_t, tmp_O, tmp_J) + + allocate(tmp_O_priv(n_points_final_grid), tmp_J_priv(n_points_final_grid,3)) + tmp_O_priv = 0.d0 + tmp_J_priv = 0.d0 + + !$OMP DO + do i = 1, elec_beta_num + do ipoint = 1, n_points_final_grid + tmp_O_priv(ipoint) = tmp_O_priv(ipoint) + mos_l_in_r_array_transp(ipoint,i) * mos_r_in_r_array_transp(ipoint,i) + tmp_J_priv(ipoint,1) = tmp_J_priv(ipoint,1) + int2_grad1_u12_bimo_t(ipoint,1,i,i) + tmp_J_priv(ipoint,2) = tmp_J_priv(ipoint,2) + int2_grad1_u12_bimo_t(ipoint,2,i,i) + tmp_J_priv(ipoint,3) = tmp_J_priv(ipoint,3) + int2_grad1_u12_bimo_t(ipoint,3,i,i) + enddo + enddo + !$OMP END DO NOWAIT + + !$OMP CRITICAL + tmp_O = tmp_O + tmp_O_priv + tmp_J = tmp_J + tmp_J_priv + !$OMP END CRITICAL + + deallocate(tmp_O_priv, tmp_J_priv) + !$OMP END PARALLEL + + allocate(tmp_M(n_points_final_grid,3), tmp_S(n_points_final_grid)) + tmp_M = 0.d0 + tmp_S = 0.d0 + + !$OMP PARALLEL & + !$OMP DEFAULT(NONE) & + !$OMP PRIVATE(i, j, ipoint, tmp_M_priv, tmp_S_priv) & + !$OMP SHARED(elec_beta_num, n_points_final_grid, & + !$OMP mos_l_in_r_array_transp, mos_r_in_r_array_transp, & + !$OMP int2_grad1_u12_bimo_t, tmp_M, tmp_S) + + allocate(tmp_M_priv(n_points_final_grid,3), tmp_S_priv(n_points_final_grid)) + tmp_M_priv = 0.d0 + tmp_S_priv = 0.d0 + + !$OMP DO COLLAPSE(2) + do i = 1, elec_beta_num + do j = 1, elec_beta_num + do ipoint = 1, n_points_final_grid + + tmp_M_priv(ipoint,1) = tmp_M_priv(ipoint,1) + int2_grad1_u12_bimo_t(ipoint,1,j,i) * mos_l_in_r_array_transp(ipoint,i) * mos_r_in_r_array_transp(ipoint,j) + tmp_M_priv(ipoint,2) = tmp_M_priv(ipoint,2) + int2_grad1_u12_bimo_t(ipoint,2,j,i) * mos_l_in_r_array_transp(ipoint,i) * mos_r_in_r_array_transp(ipoint,j) + tmp_M_priv(ipoint,3) = tmp_M_priv(ipoint,3) + int2_grad1_u12_bimo_t(ipoint,3,j,i) * mos_l_in_r_array_transp(ipoint,i) * mos_r_in_r_array_transp(ipoint,j) + + tmp_S_priv(ipoint) = tmp_S_priv(ipoint) + int2_grad1_u12_bimo_t(ipoint,1,i,j) * int2_grad1_u12_bimo_t(ipoint,1,j,i) & + + int2_grad1_u12_bimo_t(ipoint,2,i,j) * int2_grad1_u12_bimo_t(ipoint,2,j,i) & + + int2_grad1_u12_bimo_t(ipoint,3,i,j) * int2_grad1_u12_bimo_t(ipoint,3,j,i) + enddo + enddo + enddo + !$OMP END DO NOWAIT + + !$OMP CRITICAL + tmp_M = tmp_M + tmp_M_priv + tmp_S = tmp_S + tmp_S_priv + !$OMP END CRITICAL + + deallocate(tmp_M_priv, tmp_S_priv) + !$OMP END PARALLEL + + allocate(tmp(n_points_final_grid)) + + do ipoint = 1, n_points_final_grid + + tmp_S(ipoint) = 2.d0 * (tmp_J(ipoint,1)*tmp_J(ipoint,1) + tmp_J(ipoint,2)*tmp_J(ipoint,2) + tmp_J(ipoint,3)*tmp_J(ipoint,3)) - tmp_S(ipoint) + + tmp(ipoint) = final_weight_at_r_vector(ipoint) * ( tmp_O(ipoint) * tmp_S(ipoint) & + - 2.d0 * ( tmp_J(ipoint,1) * tmp_M(ipoint,1) & + + tmp_J(ipoint,2) * tmp_M(ipoint,2) & + + tmp_J(ipoint,3) * tmp_M(ipoint,3))) + enddo + + noL_0e = noL_0e -2.d0 * (sum(tmp)) + + deallocate(tmp) + + else + + allocate(tmp(elec_alpha_num)) + allocate(tmp_L(n_points_final_grid,3), tmp_R(n_points_final_grid,3)) + + !$OMP PARALLEL & + !$OMP DEFAULT(NONE) & + !$OMP PRIVATE(j, i, ipoint, tmp_L, tmp_R) & + !$OMP SHARED(elec_beta_num, elec_alpha_num, n_points_final_grid, & + !$OMP mos_l_in_r_array_transp, mos_r_in_r_array_transp, & + !$OMP int2_grad1_u12_bimo_t, tmp, final_weight_at_r_vector) + + !$OMP DO + do j = 1, elec_beta_num + + tmp_L = 0.d0 + tmp_R = 0.d0 + do i = elec_beta_num+1, elec_alpha_num + do ipoint = 1, n_points_final_grid + + tmp_L(ipoint,1) = tmp_L(ipoint,1) + 0.5d0 * int2_grad1_u12_bimo_t(ipoint,1,j,i) * mos_l_in_r_array_transp(ipoint,i) + tmp_L(ipoint,2) = tmp_L(ipoint,2) + 0.5d0 * int2_grad1_u12_bimo_t(ipoint,2,j,i) * mos_l_in_r_array_transp(ipoint,i) + tmp_L(ipoint,3) = tmp_L(ipoint,3) + 0.5d0 * int2_grad1_u12_bimo_t(ipoint,3,j,i) * mos_l_in_r_array_transp(ipoint,i) + + tmp_R(ipoint,1) = tmp_R(ipoint,1) + 0.5d0 * int2_grad1_u12_bimo_t(ipoint,1,i,j) * mos_r_in_r_array_transp(ipoint,i) + tmp_R(ipoint,2) = tmp_R(ipoint,2) + 0.5d0 * int2_grad1_u12_bimo_t(ipoint,2,i,j) * mos_r_in_r_array_transp(ipoint,i) + tmp_R(ipoint,3) = tmp_R(ipoint,3) + 0.5d0 * int2_grad1_u12_bimo_t(ipoint,3,i,j) * mos_r_in_r_array_transp(ipoint,i) + enddo + enddo + + tmp(j) = 0.d0 + do ipoint = 1, n_points_final_grid + tmp(j) = tmp(j) + final_weight_at_r_vector(ipoint) * (tmp_L(ipoint,1)*tmp_R(ipoint,1) + tmp_L(ipoint,2)*tmp_R(ipoint,2) + tmp_L(ipoint,3)*tmp_R(ipoint,3)) + enddo + + do i = 1, elec_beta_num + do ipoint = 1, n_points_final_grid + + tmp_L(ipoint,1) = tmp_L(ipoint,1) + int2_grad1_u12_bimo_t(ipoint,1,j,i) * mos_l_in_r_array_transp(ipoint,i) + tmp_L(ipoint,2) = tmp_L(ipoint,2) + int2_grad1_u12_bimo_t(ipoint,2,j,i) * mos_l_in_r_array_transp(ipoint,i) + tmp_L(ipoint,3) = tmp_L(ipoint,3) + int2_grad1_u12_bimo_t(ipoint,3,j,i) * mos_l_in_r_array_transp(ipoint,i) + + tmp_R(ipoint,1) = tmp_R(ipoint,1) + int2_grad1_u12_bimo_t(ipoint,1,i,j) * mos_r_in_r_array_transp(ipoint,i) + tmp_R(ipoint,2) = tmp_R(ipoint,2) + int2_grad1_u12_bimo_t(ipoint,2,i,j) * mos_r_in_r_array_transp(ipoint,i) + tmp_R(ipoint,3) = tmp_R(ipoint,3) + int2_grad1_u12_bimo_t(ipoint,3,i,j) * mos_r_in_r_array_transp(ipoint,i) + enddo + enddo + + do ipoint = 1, n_points_final_grid + tmp(j) = tmp(j) + final_weight_at_r_vector(ipoint) * (tmp_L(ipoint,1)*tmp_R(ipoint,1) + tmp_L(ipoint,2)*tmp_R(ipoint,2) + tmp_L(ipoint,3)*tmp_R(ipoint,3)) + enddo + enddo ! j + !$OMP END DO + !$OMP END PARALLEL + + ! --- + + !$OMP PARALLEL & + !$OMP DEFAULT(NONE) & + !$OMP PRIVATE(j, i, ipoint, tmp_L, tmp_R) & + !$OMP SHARED(elec_beta_num, elec_alpha_num, n_points_final_grid, & + !$OMP mos_l_in_r_array_transp, mos_r_in_r_array_transp, & + !$OMP int2_grad1_u12_bimo_t, tmp, final_weight_at_r_vector) + + !$OMP DO + do j = elec_beta_num+1, elec_alpha_num + + tmp_L = 0.d0 + tmp_R = 0.d0 + do i = 1, elec_alpha_num + do ipoint = 1, n_points_final_grid + tmp_L(ipoint,1) = tmp_L(ipoint,1) + int2_grad1_u12_bimo_t(ipoint,1,j,i) * mos_l_in_r_array_transp(ipoint,i) + tmp_L(ipoint,2) = tmp_L(ipoint,2) + int2_grad1_u12_bimo_t(ipoint,2,j,i) * mos_l_in_r_array_transp(ipoint,i) + tmp_L(ipoint,3) = tmp_L(ipoint,3) + int2_grad1_u12_bimo_t(ipoint,3,j,i) * mos_l_in_r_array_transp(ipoint,i) + + tmp_R(ipoint,1) = tmp_R(ipoint,1) + int2_grad1_u12_bimo_t(ipoint,1,i,j) * mos_r_in_r_array_transp(ipoint,i) + tmp_R(ipoint,2) = tmp_R(ipoint,2) + int2_grad1_u12_bimo_t(ipoint,2,i,j) * mos_r_in_r_array_transp(ipoint,i) + tmp_R(ipoint,3) = tmp_R(ipoint,3) + int2_grad1_u12_bimo_t(ipoint,3,i,j) * mos_r_in_r_array_transp(ipoint,i) + enddo + enddo + + tmp(j) = 0.d0 + do ipoint = 1, n_points_final_grid + tmp(j) = tmp(j) + 0.5d0 * final_weight_at_r_vector(ipoint) * (tmp_L(ipoint,1)*tmp_R(ipoint,1) + tmp_L(ipoint,2)*tmp_R(ipoint,2) + tmp_L(ipoint,3)*tmp_R(ipoint,3)) + enddo + enddo ! j + !$OMP END DO + !$OMP END PARALLEL + + noL_0e = -2.d0 * sum(tmp) + + deallocate(tmp) + deallocate(tmp_L, tmp_R) + + ! --- + + allocate(tmp_O(n_points_final_grid), tmp_J(n_points_final_grid,3)) + tmp_O = 0.d0 + tmp_J = 0.d0 + + !$OMP PARALLEL & + !$OMP DEFAULT(NONE) & + !$OMP PRIVATE(i, ipoint, tmp_O_priv, tmp_J_priv) & + !$OMP SHARED(elec_beta_num, elec_alpha_num, n_points_final_grid, & + !$OMP mos_l_in_r_array_transp, mos_r_in_r_array_transp, & + !$OMP int2_grad1_u12_bimo_t, tmp_O, tmp_J) + + allocate(tmp_O_priv(n_points_final_grid), tmp_J_priv(n_points_final_grid,3)) + tmp_O_priv = 0.d0 + tmp_J_priv = 0.d0 + + !$OMP DO + do i = 1, elec_beta_num + do ipoint = 1, n_points_final_grid + tmp_O_priv(ipoint) = tmp_O_priv(ipoint) + mos_l_in_r_array_transp(ipoint,i) * mos_r_in_r_array_transp(ipoint,i) + tmp_J_priv(ipoint,1) = tmp_J_priv(ipoint,1) + int2_grad1_u12_bimo_t(ipoint,1,i,i) + tmp_J_priv(ipoint,2) = tmp_J_priv(ipoint,2) + int2_grad1_u12_bimo_t(ipoint,2,i,i) + tmp_J_priv(ipoint,3) = tmp_J_priv(ipoint,3) + int2_grad1_u12_bimo_t(ipoint,3,i,i) + enddo + enddo + !$OMP END DO NOWAIT + + !$OMP DO + do i = elec_beta_num+1, elec_alpha_num + do ipoint = 1, n_points_final_grid + tmp_O_priv(ipoint) = tmp_O_priv(ipoint) + 0.5d0 * mos_l_in_r_array_transp(ipoint,i) * mos_r_in_r_array_transp(ipoint,i) + tmp_J_priv(ipoint,1) = tmp_J_priv(ipoint,1) + 0.5d0 * int2_grad1_u12_bimo_t(ipoint,1,i,i) + tmp_J_priv(ipoint,2) = tmp_J_priv(ipoint,2) + 0.5d0 * int2_grad1_u12_bimo_t(ipoint,2,i,i) + tmp_J_priv(ipoint,3) = tmp_J_priv(ipoint,3) + 0.5d0 * int2_grad1_u12_bimo_t(ipoint,3,i,i) + enddo + enddo + !$OMP END DO NOWAIT + + !$OMP CRITICAL + tmp_O = tmp_O + tmp_O_priv + tmp_J = tmp_J + tmp_J_priv + !$OMP END CRITICAL + + deallocate(tmp_O_priv, tmp_J_priv) + !$OMP END PARALLEL + + ! --- + + allocate(tmp_M(n_points_final_grid,3), tmp_S(n_points_final_grid)) + tmp_M = 0.d0 + tmp_S = 0.d0 + + !$OMP PARALLEL & + !$OMP DEFAULT(NONE) & + !$OMP PRIVATE(i, j, ipoint, tmp_M_priv, tmp_S_priv) & + !$OMP SHARED(elec_beta_num, elec_alpha_num, n_points_final_grid, & + !$OMP mos_l_in_r_array_transp, mos_r_in_r_array_transp, & + !$OMP int2_grad1_u12_bimo_t, tmp_M, tmp_S) + + allocate(tmp_M_priv(n_points_final_grid,3), tmp_S_priv(n_points_final_grid)) + tmp_M_priv = 0.d0 + tmp_S_priv = 0.d0 + + !$OMP DO COLLAPSE(2) + do i = 1, elec_beta_num + do j = 1, elec_beta_num + do ipoint = 1, n_points_final_grid + + tmp_M_priv(ipoint,1) = tmp_M_priv(ipoint,1) + int2_grad1_u12_bimo_t(ipoint,1,j,i) * mos_l_in_r_array_transp(ipoint,i) * mos_r_in_r_array_transp(ipoint,j) + tmp_M_priv(ipoint,2) = tmp_M_priv(ipoint,2) + int2_grad1_u12_bimo_t(ipoint,2,j,i) * mos_l_in_r_array_transp(ipoint,i) * mos_r_in_r_array_transp(ipoint,j) + tmp_M_priv(ipoint,3) = tmp_M_priv(ipoint,3) + int2_grad1_u12_bimo_t(ipoint,3,j,i) * mos_l_in_r_array_transp(ipoint,i) * mos_r_in_r_array_transp(ipoint,j) + + tmp_S_priv(ipoint) = tmp_S_priv(ipoint) + int2_grad1_u12_bimo_t(ipoint,1,i,j) * int2_grad1_u12_bimo_t(ipoint,1,j,i) & + + int2_grad1_u12_bimo_t(ipoint,2,i,j) * int2_grad1_u12_bimo_t(ipoint,2,j,i) & + + int2_grad1_u12_bimo_t(ipoint,3,i,j) * int2_grad1_u12_bimo_t(ipoint,3,j,i) + enddo + enddo + enddo + !$OMP END DO NOWAIT + + !$OMP DO COLLAPSE(2) + do i = elec_beta_num+1, elec_alpha_num + do j = 1, elec_beta_num + do ipoint = 1, n_points_final_grid + + tmp_M_priv(ipoint,1) = tmp_M_priv(ipoint,1) + 0.5d0 * int2_grad1_u12_bimo_t(ipoint,1,j,i) * mos_l_in_r_array_transp(ipoint,i) * mos_r_in_r_array_transp(ipoint,j) + tmp_M_priv(ipoint,2) = tmp_M_priv(ipoint,2) + 0.5d0 * int2_grad1_u12_bimo_t(ipoint,2,j,i) * mos_l_in_r_array_transp(ipoint,i) * mos_r_in_r_array_transp(ipoint,j) + tmp_M_priv(ipoint,3) = tmp_M_priv(ipoint,3) + 0.5d0 * int2_grad1_u12_bimo_t(ipoint,3,j,i) * mos_l_in_r_array_transp(ipoint,i) * mos_r_in_r_array_transp(ipoint,j) + + tmp_M_priv(ipoint,1) = tmp_M_priv(ipoint,1) + 0.5d0 * int2_grad1_u12_bimo_t(ipoint,1,i,j) * mos_l_in_r_array_transp(ipoint,j) * mos_r_in_r_array_transp(ipoint,i) + tmp_M_priv(ipoint,2) = tmp_M_priv(ipoint,2) + 0.5d0 * int2_grad1_u12_bimo_t(ipoint,2,i,j) * mos_l_in_r_array_transp(ipoint,j) * mos_r_in_r_array_transp(ipoint,i) + tmp_M_priv(ipoint,3) = tmp_M_priv(ipoint,3) + 0.5d0 * int2_grad1_u12_bimo_t(ipoint,3,i,j) * mos_l_in_r_array_transp(ipoint,j) * mos_r_in_r_array_transp(ipoint,i) + + tmp_S_priv(ipoint) = tmp_S_priv(ipoint) + int2_grad1_u12_bimo_t(ipoint,1,i,j) * int2_grad1_u12_bimo_t(ipoint,1,j,i) & + + int2_grad1_u12_bimo_t(ipoint,2,i,j) * int2_grad1_u12_bimo_t(ipoint,2,j,i) & + + int2_grad1_u12_bimo_t(ipoint,3,i,j) * int2_grad1_u12_bimo_t(ipoint,3,j,i) + enddo + enddo + enddo + !$OMP END DO NOWAIT + + !$OMP DO COLLAPSE(2) + do i = elec_beta_num+1, elec_alpha_num + do j = elec_beta_num+1, elec_alpha_num + do ipoint = 1, n_points_final_grid + + tmp_M_priv(ipoint,1) = tmp_M_priv(ipoint,1) + 0.5d0 * int2_grad1_u12_bimo_t(ipoint,1,j,i) * mos_l_in_r_array_transp(ipoint,i) * mos_r_in_r_array_transp(ipoint,j) + tmp_M_priv(ipoint,2) = tmp_M_priv(ipoint,2) + 0.5d0 * int2_grad1_u12_bimo_t(ipoint,2,j,i) * mos_l_in_r_array_transp(ipoint,i) * mos_r_in_r_array_transp(ipoint,j) + tmp_M_priv(ipoint,3) = tmp_M_priv(ipoint,3) + 0.5d0 * int2_grad1_u12_bimo_t(ipoint,3,j,i) * mos_l_in_r_array_transp(ipoint,i) * mos_r_in_r_array_transp(ipoint,j) + + tmp_S_priv(ipoint) = tmp_S_priv(ipoint) + 0.5d0 * int2_grad1_u12_bimo_t(ipoint,1,i,j) * int2_grad1_u12_bimo_t(ipoint,1,j,i) & + + 0.5d0 * int2_grad1_u12_bimo_t(ipoint,2,i,j) * int2_grad1_u12_bimo_t(ipoint,2,j,i) & + + 0.5d0 * int2_grad1_u12_bimo_t(ipoint,3,i,j) * int2_grad1_u12_bimo_t(ipoint,3,j,i) + enddo + enddo + enddo + !$OMP END DO NOWAIT + + !$OMP CRITICAL + tmp_M = tmp_M + tmp_M_priv + tmp_S = tmp_S + tmp_S_priv + !$OMP END CRITICAL + + deallocate(tmp_M_priv, tmp_S_priv) + !$OMP END PARALLEL + + allocate(tmp(n_points_final_grid)) + + do ipoint = 1, n_points_final_grid + + tmp_S(ipoint) = 2.d0 * (tmp_J(ipoint,1)*tmp_J(ipoint,1) + tmp_J(ipoint,2)*tmp_J(ipoint,2) + tmp_J(ipoint,3)*tmp_J(ipoint,3)) - tmp_S(ipoint) + + tmp(ipoint) = final_weight_at_r_vector(ipoint) * ( tmp_O(ipoint) * tmp_S(ipoint) & + - 2.d0 * ( tmp_J(ipoint,1) * tmp_M(ipoint,1) & + + tmp_J(ipoint,2) * tmp_M(ipoint,2) & + + tmp_J(ipoint,3) * tmp_M(ipoint,3))) + enddo + + noL_0e = noL_0e -2.d0 * (sum(tmp)) + + deallocate(tmp) + + endif + + call wall_time(t1) + print*, " Wall time for noL_0e (min) = ", (t1 - t0)/60.d0 + + print*, " noL_0e = ", noL_0e + +END_PROVIDER + +! --- + +BEGIN_PROVIDER [double precision, noL_1e, (mo_num, mo_num)] + + implicit none + integer :: p, s, i, j, ipoint + double precision :: t0, t1 + double precision, allocatable :: tmp1(:,:,:,:), tmp2(:,:), tmp3(:,:,:), tmp4(:,:,:) + double precision, allocatable :: tmp_L(:,:,:), tmp_R(:,:,:), tmp_M(:,:), tmp_S(:), tmp_O(:), tmp_J(:,:) + double precision, allocatable :: tmp_L0(:,:,:), tmp_R0(:,:,:) + double precision, allocatable :: tmp_M_priv(:,:), tmp_S_priv(:), tmp_O_priv(:), tmp_J_priv(:,:) + + + PROVIDE int2_grad1_u12_bimo_t + PROVIDE mos_l_in_r_array_transp mos_r_in_r_array_transp + + call wall_time(t0) + print*, " Providing noL_1e ..." + + if(elec_alpha_num .eq. elec_beta_num) then + + allocate(tmp_O(n_points_final_grid), tmp_J(n_points_final_grid,3)) + tmp_O = 0.d0 + tmp_J = 0.d0 + + !$OMP PARALLEL & + !$OMP DEFAULT(NONE) & + !$OMP PRIVATE(i, ipoint, tmp_O_priv, tmp_J_priv) & + !$OMP SHARED(elec_beta_num, n_points_final_grid, & + !$OMP mos_l_in_r_array_transp, mos_r_in_r_array_transp, & + !$OMP int2_grad1_u12_bimo_t, tmp_O, tmp_J) + + allocate(tmp_O_priv(n_points_final_grid), tmp_J_priv(n_points_final_grid,3)) + tmp_O_priv = 0.d0 + tmp_J_priv = 0.d0 + + !$OMP DO + do i = 1, elec_beta_num + do ipoint = 1, n_points_final_grid + tmp_O_priv(ipoint) = tmp_O_priv(ipoint) + mos_l_in_r_array_transp(ipoint,i) * mos_r_in_r_array_transp(ipoint,i) + tmp_J_priv(ipoint,1) = tmp_J_priv(ipoint,1) + int2_grad1_u12_bimo_t(ipoint,1,i,i) + tmp_J_priv(ipoint,2) = tmp_J_priv(ipoint,2) + int2_grad1_u12_bimo_t(ipoint,2,i,i) + tmp_J_priv(ipoint,3) = tmp_J_priv(ipoint,3) + int2_grad1_u12_bimo_t(ipoint,3,i,i) + enddo + enddo + !$OMP END DO NOWAIT + + !$OMP CRITICAL + tmp_O = tmp_O + tmp_O_priv + tmp_J = tmp_J + tmp_J_priv + !$OMP END CRITICAL + + deallocate(tmp_O_priv, tmp_J_priv) + !$OMP END PARALLEL + + ! --- + + allocate(tmp_M(n_points_final_grid,3), tmp_S(n_points_final_grid)) + tmp_M = 0.d0 + tmp_S = 0.d0 + + !$OMP PARALLEL & + !$OMP DEFAULT(NONE) & + !$OMP PRIVATE(i, j, ipoint, tmp_M_priv, tmp_S_priv) & + !$OMP SHARED(elec_beta_num, n_points_final_grid, & + !$OMP mos_l_in_r_array_transp, mos_r_in_r_array_transp, & + !$OMP int2_grad1_u12_bimo_t, tmp_M, tmp_S) + + allocate(tmp_M_priv(n_points_final_grid,3), tmp_S_priv(n_points_final_grid)) + tmp_M_priv = 0.d0 + tmp_S_priv = 0.d0 + + !$OMP DO COLLAPSE(2) + do i = 1, elec_beta_num + do j = 1, elec_beta_num + do ipoint = 1, n_points_final_grid + + tmp_M_priv(ipoint,1) = tmp_M_priv(ipoint,1) + int2_grad1_u12_bimo_t(ipoint,1,j,i) * mos_l_in_r_array_transp(ipoint,i) * mos_r_in_r_array_transp(ipoint,j) + tmp_M_priv(ipoint,2) = tmp_M_priv(ipoint,2) + int2_grad1_u12_bimo_t(ipoint,2,j,i) * mos_l_in_r_array_transp(ipoint,i) * mos_r_in_r_array_transp(ipoint,j) + tmp_M_priv(ipoint,3) = tmp_M_priv(ipoint,3) + int2_grad1_u12_bimo_t(ipoint,3,j,i) * mos_l_in_r_array_transp(ipoint,i) * mos_r_in_r_array_transp(ipoint,j) + + tmp_S_priv(ipoint) = tmp_S_priv(ipoint) + int2_grad1_u12_bimo_t(ipoint,1,i,j) * int2_grad1_u12_bimo_t(ipoint,1,j,i) & + + int2_grad1_u12_bimo_t(ipoint,2,i,j) * int2_grad1_u12_bimo_t(ipoint,2,j,i) & + + int2_grad1_u12_bimo_t(ipoint,3,i,j) * int2_grad1_u12_bimo_t(ipoint,3,j,i) + enddo + enddo + enddo + !$OMP END DO NOWAIT + + !$OMP CRITICAL + tmp_M = tmp_M + tmp_M_priv + tmp_S = tmp_S + tmp_S_priv + !$OMP END CRITICAL + + deallocate(tmp_M_priv, tmp_S_priv) + !$OMP END PARALLEL + + ! --- + + allocate(tmp2(n_points_final_grid,4)) + allocate(tmp1(n_points_final_grid,4,mo_num,mo_num)) + + do ipoint = 1, n_points_final_grid + + tmp2(ipoint,1) = final_weight_at_r_vector(ipoint) * (2.d0 * tmp_O(ipoint) * tmp_J(ipoint,1) - tmp_M(ipoint,1)) + tmp2(ipoint,2) = final_weight_at_r_vector(ipoint) * (2.d0 * tmp_O(ipoint) * tmp_J(ipoint,2) - tmp_M(ipoint,2)) + tmp2(ipoint,3) = final_weight_at_r_vector(ipoint) * (2.d0 * tmp_O(ipoint) * tmp_J(ipoint,3) - tmp_M(ipoint,3)) + tmp2(ipoint,4) = -final_weight_at_r_vector(ipoint) * tmp_O(ipoint) + + tmp_S(ipoint) = 2.d0 * (tmp_J(ipoint,1) * tmp_J(ipoint,1) + tmp_J(ipoint,2) * tmp_J(ipoint,2) + tmp_J(ipoint,3) * tmp_J(ipoint,3)) - tmp_S(ipoint) + enddo + + deallocate(tmp_O, tmp_M) + + !$OMP PARALLEL & + !$OMP DEFAULT(NONE) & + !$OMP PRIVATE(p, s, i, ipoint) & + !$OMP SHARED(mo_num, elec_beta_num, n_points_final_grid, & + !$OMP int2_grad1_u12_bimo_t, tmp1) + + !$OMP DO COLLAPSE(2) + do s = 1, mo_num + do p = 1, mo_num + + do ipoint = 1, n_points_final_grid + tmp1(ipoint,1,p,s) = int2_grad1_u12_bimo_t(ipoint,1,p,s) + tmp1(ipoint,2,p,s) = int2_grad1_u12_bimo_t(ipoint,2,p,s) + tmp1(ipoint,3,p,s) = int2_grad1_u12_bimo_t(ipoint,3,p,s) + enddo + + tmp1(:,4,p,s) = 0.d0 + do i = 1, elec_beta_num + do ipoint = 1, n_points_final_grid + tmp1(ipoint,4,p,s) = tmp1(ipoint,4,p,s) + int2_grad1_u12_bimo_t(ipoint,1,p,i) * int2_grad1_u12_bimo_t(ipoint,1,i,s) & + + int2_grad1_u12_bimo_t(ipoint,2,p,i) * int2_grad1_u12_bimo_t(ipoint,2,i,s) & + + int2_grad1_u12_bimo_t(ipoint,3,p,i) * int2_grad1_u12_bimo_t(ipoint,3,i,s) + enddo + enddo + + enddo ! p + enddo ! s + !$OMP END DO + !$OMP END PARALLEL + + call dgemv( 'T', 4*n_points_final_grid, mo_num*mo_num, 2.d0 & + , tmp1(1,1,1,1), size(tmp1, 1) * size(tmp1, 2) & + , tmp2(1,1), 1 & + , 0.d0, noL_1e(1,1), 1) + + deallocate(tmp1, tmp2) + + ! --- + + allocate(tmp_L(n_points_final_grid,3,mo_num)) + allocate(tmp_R(n_points_final_grid,3,mo_num)) + + !$OMP PARALLEL & + !$OMP DEFAULT(NONE) & + !$OMP PRIVATE(p, i, ipoint) & + !$OMP SHARED(elec_beta_num, n_points_final_grid, mo_num, & + !$OMP mos_l_in_r_array_transp, mos_r_in_r_array_transp, & + !$OMP int2_grad1_u12_bimo_t, tmp_L, tmp_R) + + !$OMP DO + do p = 1, mo_num + + tmp_L(:,1:3,p) = 0.d0 + tmp_R(:,1:3,p) = 0.d0 + + do i = 1, elec_beta_num + do ipoint = 1, n_points_final_grid + + tmp_L(ipoint,1,p) = tmp_L(ipoint,1,p) + int2_grad1_u12_bimo_t(ipoint,1,p,i) * mos_l_in_r_array_transp(ipoint,i) + tmp_L(ipoint,2,p) = tmp_L(ipoint,2,p) + int2_grad1_u12_bimo_t(ipoint,2,p,i) * mos_l_in_r_array_transp(ipoint,i) + tmp_L(ipoint,3,p) = tmp_L(ipoint,3,p) + int2_grad1_u12_bimo_t(ipoint,3,p,i) * mos_l_in_r_array_transp(ipoint,i) + + tmp_R(ipoint,1,p) = tmp_R(ipoint,1,p) + int2_grad1_u12_bimo_t(ipoint,1,i,p) * mos_r_in_r_array_transp(ipoint,i) + tmp_R(ipoint,2,p) = tmp_R(ipoint,2,p) + int2_grad1_u12_bimo_t(ipoint,2,i,p) * mos_r_in_r_array_transp(ipoint,i) + tmp_R(ipoint,3,p) = tmp_R(ipoint,3,p) + int2_grad1_u12_bimo_t(ipoint,3,i,p) * mos_r_in_r_array_transp(ipoint,i) + enddo + enddo + enddo ! p + !$OMP END DO + !$OMP END PARALLEL + + ! --- + + allocate(tmp3(n_points_final_grid,5,mo_num)) + allocate(tmp4(n_points_final_grid,5,mo_num)) + + !$OMP PARALLEL & + !$OMP DEFAULT(NONE) & + !$OMP PRIVATE(p, i, j, ipoint) & + !$OMP SHARED(elec_beta_num, n_points_final_grid, mo_num, & + !$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_L, tmp_R, tmp_J, tmp_S, tmp3, tmp4) + + !$OMP DO + do p = 1, mo_num + + do ipoint = 1, n_points_final_grid + + tmp3(ipoint,1,p) = final_weight_at_r_vector(ipoint) * mos_l_in_r_array_transp(ipoint,p) + tmp3(ipoint,2,p) = -2.d0 * (tmp_L(ipoint,1,p) * tmp_J(ipoint,1) + tmp_L(ipoint,2,p) * tmp_J(ipoint,2) + tmp_L(ipoint,3,p) * tmp_J(ipoint,3)) + tmp3(ipoint,3,p) = final_weight_at_r_vector(ipoint) * tmp_L(ipoint,1,p) + tmp3(ipoint,4,p) = final_weight_at_r_vector(ipoint) * tmp_L(ipoint,2,p) + tmp3(ipoint,5,p) = final_weight_at_r_vector(ipoint) * tmp_L(ipoint,3,p) + + tmp4(ipoint,1,p) = -2.d0 * (tmp_R(ipoint,1,p) * tmp_J(ipoint,1) + tmp_R(ipoint,2,p) * tmp_J(ipoint,2) + tmp_R(ipoint,3,p) * tmp_J(ipoint,3)) & + + mos_r_in_r_array_transp(ipoint,p) * tmp_S(ipoint) + tmp4(ipoint,2,p) = final_weight_at_r_vector(ipoint) * mos_r_in_r_array_transp(ipoint,p) + tmp4(ipoint,3,p) = tmp_R(ipoint,1,p) + tmp4(ipoint,4,p) = tmp_R(ipoint,2,p) + tmp4(ipoint,5,p) = tmp_R(ipoint,3,p) + enddo + + do i = 1, elec_beta_num + do j = 1, elec_beta_num + do ipoint = 1, n_points_final_grid + + tmp3(ipoint,2,p) = tmp3(ipoint,2,p) + mos_l_in_r_array_transp(ipoint,j) * ( int2_grad1_u12_bimo_t(ipoint,1,p,i) * int2_grad1_u12_bimo_t(ipoint,1,i,j) & + + int2_grad1_u12_bimo_t(ipoint,2,p,i) * int2_grad1_u12_bimo_t(ipoint,2,i,j) & + + int2_grad1_u12_bimo_t(ipoint,3,p,i) * int2_grad1_u12_bimo_t(ipoint,3,i,j) ) + + tmp4(ipoint,1,p) = tmp4(ipoint,1,p) + mos_r_in_r_array_transp(ipoint,i) * ( int2_grad1_u12_bimo_t(ipoint,1,i,j) * int2_grad1_u12_bimo_t(ipoint,1,j,p) & + + int2_grad1_u12_bimo_t(ipoint,2,i,j) * int2_grad1_u12_bimo_t(ipoint,2,j,p) & + + int2_grad1_u12_bimo_t(ipoint,3,i,j) * int2_grad1_u12_bimo_t(ipoint,3,j,p) ) + enddo ! ipoint + enddo ! j + enddo ! i + + enddo ! p + !$OMP END DO + !$OMP END PARALLEL + + deallocate(tmp_L, tmp_R, tmp_J, tmp_S) + + call dgemm( 'T', 'N', mo_num, mo_num, 5*n_points_final_grid, 1.d0 & + , tmp3(1,1,1), 5*n_points_final_grid, tmp4(1,1,1), 5*n_points_final_grid & + , 1.d0, noL_1e(1,1), mo_num) + + deallocate(tmp3, tmp4) + + ! --- + + else + + allocate(tmp_O(n_points_final_grid), tmp_J(n_points_final_grid,3)) + tmp_O = 0.d0 + tmp_J = 0.d0 + + !$OMP PARALLEL & + !$OMP DEFAULT(NONE) & + !$OMP PRIVATE(i, ipoint, tmp_O_priv, tmp_J_priv) & + !$OMP SHARED(elec_beta_num, elec_alpha_num, n_points_final_grid, & + !$OMP mos_l_in_r_array_transp, mos_r_in_r_array_transp, & + !$OMP int2_grad1_u12_bimo_t, tmp_O, tmp_J) + + allocate(tmp_O_priv(n_points_final_grid), tmp_J_priv(n_points_final_grid,3)) + tmp_O_priv = 0.d0 + tmp_J_priv = 0.d0 + + !$OMP DO + do i = 1, elec_beta_num + do ipoint = 1, n_points_final_grid + tmp_O_priv(ipoint) = tmp_O_priv(ipoint) + mos_l_in_r_array_transp(ipoint,i) * mos_r_in_r_array_transp(ipoint,i) + tmp_J_priv(ipoint,1) = tmp_J_priv(ipoint,1) + int2_grad1_u12_bimo_t(ipoint,1,i,i) + tmp_J_priv(ipoint,2) = tmp_J_priv(ipoint,2) + int2_grad1_u12_bimo_t(ipoint,2,i,i) + tmp_J_priv(ipoint,3) = tmp_J_priv(ipoint,3) + int2_grad1_u12_bimo_t(ipoint,3,i,i) + enddo + enddo + !$OMP END DO NOWAIT + + !$OMP DO + do i = elec_beta_num+1, elec_alpha_num + do ipoint = 1, n_points_final_grid + tmp_O_priv(ipoint) = tmp_O_priv(ipoint) + 0.5d0 * mos_l_in_r_array_transp(ipoint,i) * mos_r_in_r_array_transp(ipoint,i) + tmp_J_priv(ipoint,1) = tmp_J_priv(ipoint,1) + 0.5d0 * int2_grad1_u12_bimo_t(ipoint,1,i,i) + tmp_J_priv(ipoint,2) = tmp_J_priv(ipoint,2) + 0.5d0 * int2_grad1_u12_bimo_t(ipoint,2,i,i) + tmp_J_priv(ipoint,3) = tmp_J_priv(ipoint,3) + 0.5d0 * int2_grad1_u12_bimo_t(ipoint,3,i,i) + enddo + enddo + !$OMP END DO NOWAIT + + !$OMP CRITICAL + tmp_O = tmp_O + tmp_O_priv + tmp_J = tmp_J + tmp_J_priv + !$OMP END CRITICAL + + deallocate(tmp_O_priv, tmp_J_priv) + !$OMP END PARALLEL + + ! --- + + allocate(tmp_M(n_points_final_grid,3), tmp_S(n_points_final_grid)) + tmp_M = 0.d0 + tmp_S = 0.d0 + + !$OMP PARALLEL & + !$OMP DEFAULT(NONE) & + !$OMP PRIVATE(i, j, ipoint, tmp_M_priv, tmp_S_priv) & + !$OMP SHARED(elec_beta_num, elec_alpha_num, n_points_final_grid, & + !$OMP mos_l_in_r_array_transp, mos_r_in_r_array_transp, & + !$OMP int2_grad1_u12_bimo_t, tmp_M, tmp_S) + + allocate(tmp_M_priv(n_points_final_grid,3), tmp_S_priv(n_points_final_grid)) + tmp_M_priv = 0.d0 + tmp_S_priv = 0.d0 + + !$OMP DO COLLAPSE(2) + do i = 1, elec_beta_num + do j = 1, elec_beta_num + do ipoint = 1, n_points_final_grid + + tmp_M_priv(ipoint,1) = tmp_M_priv(ipoint,1) + int2_grad1_u12_bimo_t(ipoint,1,j,i) * mos_l_in_r_array_transp(ipoint,i) * mos_r_in_r_array_transp(ipoint,j) + tmp_M_priv(ipoint,2) = tmp_M_priv(ipoint,2) + int2_grad1_u12_bimo_t(ipoint,2,j,i) * mos_l_in_r_array_transp(ipoint,i) * mos_r_in_r_array_transp(ipoint,j) + tmp_M_priv(ipoint,3) = tmp_M_priv(ipoint,3) + int2_grad1_u12_bimo_t(ipoint,3,j,i) * mos_l_in_r_array_transp(ipoint,i) * mos_r_in_r_array_transp(ipoint,j) + + tmp_S_priv(ipoint) = tmp_S_priv(ipoint) + int2_grad1_u12_bimo_t(ipoint,1,i,j) * int2_grad1_u12_bimo_t(ipoint,1,j,i) & + + int2_grad1_u12_bimo_t(ipoint,2,i,j) * int2_grad1_u12_bimo_t(ipoint,2,j,i) & + + int2_grad1_u12_bimo_t(ipoint,3,i,j) * int2_grad1_u12_bimo_t(ipoint,3,j,i) + enddo + enddo + enddo + !$OMP END DO NOWAIT + + !$OMP DO COLLAPSE(2) + do i = elec_beta_num+1, elec_alpha_num + do j = 1, elec_beta_num + do ipoint = 1, n_points_final_grid + + tmp_M_priv(ipoint,1) = tmp_M_priv(ipoint,1) + 0.5d0 * int2_grad1_u12_bimo_t(ipoint,1,j,i) * mos_l_in_r_array_transp(ipoint,i) * mos_r_in_r_array_transp(ipoint,j) + tmp_M_priv(ipoint,2) = tmp_M_priv(ipoint,2) + 0.5d0 * int2_grad1_u12_bimo_t(ipoint,2,j,i) * mos_l_in_r_array_transp(ipoint,i) * mos_r_in_r_array_transp(ipoint,j) + tmp_M_priv(ipoint,3) = tmp_M_priv(ipoint,3) + 0.5d0 * int2_grad1_u12_bimo_t(ipoint,3,j,i) * mos_l_in_r_array_transp(ipoint,i) * mos_r_in_r_array_transp(ipoint,j) + + tmp_M_priv(ipoint,1) = tmp_M_priv(ipoint,1) + 0.5d0 * int2_grad1_u12_bimo_t(ipoint,1,i,j) * mos_l_in_r_array_transp(ipoint,j) * mos_r_in_r_array_transp(ipoint,i) + tmp_M_priv(ipoint,2) = tmp_M_priv(ipoint,2) + 0.5d0 * int2_grad1_u12_bimo_t(ipoint,2,i,j) * mos_l_in_r_array_transp(ipoint,j) * mos_r_in_r_array_transp(ipoint,i) + tmp_M_priv(ipoint,3) = tmp_M_priv(ipoint,3) + 0.5d0 * int2_grad1_u12_bimo_t(ipoint,3,i,j) * mos_l_in_r_array_transp(ipoint,j) * mos_r_in_r_array_transp(ipoint,i) + + tmp_S_priv(ipoint) = tmp_S_priv(ipoint) + int2_grad1_u12_bimo_t(ipoint,1,i,j) * int2_grad1_u12_bimo_t(ipoint,1,j,i) & + + int2_grad1_u12_bimo_t(ipoint,2,i,j) * int2_grad1_u12_bimo_t(ipoint,2,j,i) & + + int2_grad1_u12_bimo_t(ipoint,3,i,j) * int2_grad1_u12_bimo_t(ipoint,3,j,i) + enddo + enddo + enddo + !$OMP END DO NOWAIT + + !$OMP DO COLLAPSE(2) + do i = elec_beta_num+1, elec_alpha_num + do j = elec_beta_num+1, elec_alpha_num + do ipoint = 1, n_points_final_grid + + tmp_M_priv(ipoint,1) = tmp_M_priv(ipoint,1) + 0.5d0 * int2_grad1_u12_bimo_t(ipoint,1,j,i) * mos_l_in_r_array_transp(ipoint,i) * mos_r_in_r_array_transp(ipoint,j) + tmp_M_priv(ipoint,2) = tmp_M_priv(ipoint,2) + 0.5d0 * int2_grad1_u12_bimo_t(ipoint,2,j,i) * mos_l_in_r_array_transp(ipoint,i) * mos_r_in_r_array_transp(ipoint,j) + tmp_M_priv(ipoint,3) = tmp_M_priv(ipoint,3) + 0.5d0 * int2_grad1_u12_bimo_t(ipoint,3,j,i) * mos_l_in_r_array_transp(ipoint,i) * mos_r_in_r_array_transp(ipoint,j) + + tmp_S_priv(ipoint) = tmp_S_priv(ipoint) + 0.5d0 * int2_grad1_u12_bimo_t(ipoint,1,i,j) * int2_grad1_u12_bimo_t(ipoint,1,j,i) & + + 0.5d0 * int2_grad1_u12_bimo_t(ipoint,2,i,j) * int2_grad1_u12_bimo_t(ipoint,2,j,i) & + + 0.5d0 * int2_grad1_u12_bimo_t(ipoint,3,i,j) * int2_grad1_u12_bimo_t(ipoint,3,j,i) + enddo + enddo + enddo + !$OMP END DO NOWAIT + + !$OMP CRITICAL + tmp_M = tmp_M + tmp_M_priv + tmp_S = tmp_S + tmp_S_priv + !$OMP END CRITICAL + + deallocate(tmp_M_priv, tmp_S_priv) + !$OMP END PARALLEL + + ! --- + + allocate(tmp2(n_points_final_grid,4)) + allocate(tmp1(n_points_final_grid,4,mo_num,mo_num)) + + do ipoint = 1, n_points_final_grid + + tmp2(ipoint,1) = final_weight_at_r_vector(ipoint) * (2.d0 * tmp_O(ipoint) * tmp_J(ipoint,1) - tmp_M(ipoint,1)) + tmp2(ipoint,2) = final_weight_at_r_vector(ipoint) * (2.d0 * tmp_O(ipoint) * tmp_J(ipoint,2) - tmp_M(ipoint,2)) + tmp2(ipoint,3) = final_weight_at_r_vector(ipoint) * (2.d0 * tmp_O(ipoint) * tmp_J(ipoint,3) - tmp_M(ipoint,3)) + tmp2(ipoint,4) = -final_weight_at_r_vector(ipoint) * tmp_O(ipoint) + + tmp_S(ipoint) = 2.d0 * (tmp_J(ipoint,1) * tmp_J(ipoint,1) + tmp_J(ipoint,2) * tmp_J(ipoint,2) + tmp_J(ipoint,3) * tmp_J(ipoint,3)) - tmp_S(ipoint) + enddo + + deallocate(tmp_O, tmp_M) + + !$OMP PARALLEL & + !$OMP DEFAULT(NONE) & + !$OMP PRIVATE(p, s, i, ipoint) & + !$OMP SHARED(mo_num, elec_beta_num, n_points_final_grid, & + !$OMP elec_alpha_num, int2_grad1_u12_bimo_t, tmp1) + + !$OMP DO COLLAPSE(2) + do s = 1, mo_num + do p = 1, mo_num + + do ipoint = 1, n_points_final_grid + tmp1(ipoint,1,p,s) = int2_grad1_u12_bimo_t(ipoint,1,p,s) + tmp1(ipoint,2,p,s) = int2_grad1_u12_bimo_t(ipoint,2,p,s) + tmp1(ipoint,3,p,s) = int2_grad1_u12_bimo_t(ipoint,3,p,s) + enddo + + tmp1(:,4,p,s) = 0.d0 + do i = 1, elec_beta_num + do ipoint = 1, n_points_final_grid + tmp1(ipoint,4,p,s) = tmp1(ipoint,4,p,s) + int2_grad1_u12_bimo_t(ipoint,1,p,i) * int2_grad1_u12_bimo_t(ipoint,1,i,s) & + + int2_grad1_u12_bimo_t(ipoint,2,p,i) * int2_grad1_u12_bimo_t(ipoint,2,i,s) & + + int2_grad1_u12_bimo_t(ipoint,3,p,i) * int2_grad1_u12_bimo_t(ipoint,3,i,s) + enddo + enddo + do i = elec_beta_num+1, elec_alpha_num + do ipoint = 1, n_points_final_grid + tmp1(ipoint,4,p,s) = tmp1(ipoint,4,p,s) + 0.5d0 * int2_grad1_u12_bimo_t(ipoint,1,p,i) * int2_grad1_u12_bimo_t(ipoint,1,i,s) & + + 0.5d0 * int2_grad1_u12_bimo_t(ipoint,2,p,i) * int2_grad1_u12_bimo_t(ipoint,2,i,s) & + + 0.5d0 * int2_grad1_u12_bimo_t(ipoint,3,p,i) * int2_grad1_u12_bimo_t(ipoint,3,i,s) + enddo + enddo + + enddo ! p + enddo ! s + !$OMP END DO + !$OMP END PARALLEL + + call dgemv( 'T', 4*n_points_final_grid, mo_num*mo_num, 2.d0 & + , tmp1(1,1,1,1), size(tmp1, 1) * size(tmp1, 2) & + , tmp2(1,1), 1 & + , 0.d0, noL_1e(1,1), 1) + + deallocate(tmp1, tmp2) + + ! --- + + allocate(tmp_L(n_points_final_grid,3,mo_num), tmp_L0(n_points_final_grid,3,mo_num)) + allocate(tmp_R(n_points_final_grid,3,mo_num), tmp_R0(n_points_final_grid,3,mo_num)) + + !$OMP PARALLEL & + !$OMP DEFAULT(NONE) & + !$OMP PRIVATE(p, i, ipoint) & + !$OMP SHARED(elec_beta_num, elec_alpha_num, n_points_final_grid, mo_num, & + !$OMP mos_l_in_r_array_transp, mos_r_in_r_array_transp, & + !$OMP int2_grad1_u12_bimo_t, tmp_L0, tmp_R0, tmp_L, tmp_R) + + !$OMP DO + do p = 1, mo_num + + tmp_L0(:,1:3,p) = 0.d0 + tmp_R0(:,1:3,p) = 0.d0 + do i = elec_beta_num+1, elec_alpha_num + do ipoint = 1, n_points_final_grid + + tmp_L0(ipoint,1,p) = tmp_L0(ipoint,1,p) + 0.5d0 * int2_grad1_u12_bimo_t(ipoint,1,p,i) * mos_l_in_r_array_transp(ipoint,i) + tmp_L0(ipoint,2,p) = tmp_L0(ipoint,2,p) + 0.5d0 * int2_grad1_u12_bimo_t(ipoint,2,p,i) * mos_l_in_r_array_transp(ipoint,i) + tmp_L0(ipoint,3,p) = tmp_L0(ipoint,3,p) + 0.5d0 * int2_grad1_u12_bimo_t(ipoint,3,p,i) * mos_l_in_r_array_transp(ipoint,i) + + tmp_R0(ipoint,1,p) = tmp_R0(ipoint,1,p) + 0.5d0 * int2_grad1_u12_bimo_t(ipoint,1,i,p) * mos_r_in_r_array_transp(ipoint,i) + tmp_R0(ipoint,2,p) = tmp_R0(ipoint,2,p) + 0.5d0 * int2_grad1_u12_bimo_t(ipoint,2,i,p) * mos_r_in_r_array_transp(ipoint,i) + tmp_R0(ipoint,3,p) = tmp_R0(ipoint,3,p) + 0.5d0 * int2_grad1_u12_bimo_t(ipoint,3,i,p) * mos_r_in_r_array_transp(ipoint,i) + enddo + enddo + + tmp_L(:,1:3,p) = tmp_L0(:,1:3,p) + tmp_R(:,1:3,p) = tmp_R0(:,1:3,p) + do i = 1, elec_beta_num + do ipoint = 1, n_points_final_grid + + tmp_L(ipoint,1,p) = tmp_L(ipoint,1,p) + int2_grad1_u12_bimo_t(ipoint,1,p,i) * mos_l_in_r_array_transp(ipoint,i) + tmp_L(ipoint,2,p) = tmp_L(ipoint,2,p) + int2_grad1_u12_bimo_t(ipoint,2,p,i) * mos_l_in_r_array_transp(ipoint,i) + tmp_L(ipoint,3,p) = tmp_L(ipoint,3,p) + int2_grad1_u12_bimo_t(ipoint,3,p,i) * mos_l_in_r_array_transp(ipoint,i) + + tmp_R(ipoint,1,p) = tmp_R(ipoint,1,p) + int2_grad1_u12_bimo_t(ipoint,1,i,p) * mos_r_in_r_array_transp(ipoint,i) + tmp_R(ipoint,2,p) = tmp_R(ipoint,2,p) + int2_grad1_u12_bimo_t(ipoint,2,i,p) * mos_r_in_r_array_transp(ipoint,i) + tmp_R(ipoint,3,p) = tmp_R(ipoint,3,p) + int2_grad1_u12_bimo_t(ipoint,3,i,p) * mos_r_in_r_array_transp(ipoint,i) + enddo + enddo + + enddo ! p + !$OMP END DO + !$OMP END PARALLEL + + ! --- + + allocate(tmp3(n_points_final_grid,8,mo_num)) + allocate(tmp4(n_points_final_grid,8,mo_num)) + + !$OMP PARALLEL & + !$OMP DEFAULT(NONE) & + !$OMP PRIVATE(p, i, j, ipoint) & + !$OMP SHARED(elec_beta_num, elec_alpha_num, n_points_final_grid, mo_num, & + !$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_L, tmp_L0, tmp_R, tmp_R0, tmp_J, tmp_S, tmp3, tmp4) + + !$OMP DO + do p = 1, mo_num + + do ipoint = 1, n_points_final_grid + + tmp3(ipoint,1,p) = final_weight_at_r_vector(ipoint) * mos_l_in_r_array_transp(ipoint,p) + tmp3(ipoint,2,p) = -2.d0 * (tmp_L(ipoint,1,p) * tmp_J(ipoint,1) + tmp_L(ipoint,2,p) * tmp_J(ipoint,2) + tmp_L(ipoint,3,p) * tmp_J(ipoint,3)) + tmp3(ipoint,3,p) = final_weight_at_r_vector(ipoint) * tmp_L(ipoint,1,p) + tmp3(ipoint,4,p) = final_weight_at_r_vector(ipoint) * tmp_L(ipoint,2,p) + tmp3(ipoint,5,p) = final_weight_at_r_vector(ipoint) * tmp_L(ipoint,3,p) + tmp3(ipoint,6,p) = final_weight_at_r_vector(ipoint) * tmp_L0(ipoint,1,p) + tmp3(ipoint,7,p) = final_weight_at_r_vector(ipoint) * tmp_L0(ipoint,2,p) + tmp3(ipoint,8,p) = final_weight_at_r_vector(ipoint) * tmp_L0(ipoint,3,p) + + tmp4(ipoint,1,p) = -2.d0 * (tmp_R(ipoint,1,p) * tmp_J(ipoint,1) + tmp_R(ipoint,2,p) * tmp_J(ipoint,2) + tmp_R(ipoint,3,p) * tmp_J(ipoint,3)) & + + mos_r_in_r_array_transp(ipoint,p) * tmp_S(ipoint) + tmp4(ipoint,2,p) = final_weight_at_r_vector(ipoint) * mos_r_in_r_array_transp(ipoint,p) + tmp4(ipoint,3,p) = tmp_R(ipoint,1,p) + tmp4(ipoint,4,p) = tmp_R(ipoint,2,p) + tmp4(ipoint,5,p) = tmp_R(ipoint,3,p) + tmp4(ipoint,6,p) = tmp_R0(ipoint,1,p) + tmp4(ipoint,7,p) = tmp_R0(ipoint,2,p) + tmp4(ipoint,8,p) = tmp_R0(ipoint,3,p) + enddo + + do i = 1, elec_beta_num + do j = 1, elec_beta_num + do ipoint = 1, n_points_final_grid + + tmp3(ipoint,2,p) = tmp3(ipoint,2,p) + mos_l_in_r_array_transp(ipoint,j) * ( int2_grad1_u12_bimo_t(ipoint,1,p,i) * int2_grad1_u12_bimo_t(ipoint,1,i,j) & + + int2_grad1_u12_bimo_t(ipoint,2,p,i) * int2_grad1_u12_bimo_t(ipoint,2,i,j) & + + int2_grad1_u12_bimo_t(ipoint,3,p,i) * int2_grad1_u12_bimo_t(ipoint,3,i,j) ) + + tmp4(ipoint,1,p) = tmp4(ipoint,1,p) + mos_r_in_r_array_transp(ipoint,i) * ( int2_grad1_u12_bimo_t(ipoint,1,i,j) * int2_grad1_u12_bimo_t(ipoint,1,j,p) & + + int2_grad1_u12_bimo_t(ipoint,2,i,j) * int2_grad1_u12_bimo_t(ipoint,2,j,p) & + + int2_grad1_u12_bimo_t(ipoint,3,i,j) * int2_grad1_u12_bimo_t(ipoint,3,j,p) ) + enddo ! ipoint + enddo ! j + enddo ! i + + do i = elec_beta_num+1, elec_alpha_num + do j = 1, elec_beta_num + do ipoint = 1, n_points_final_grid + + tmp3(ipoint,2,p) = tmp3(ipoint,2,p) + 0.5d0 * mos_l_in_r_array_transp(ipoint,j) * ( int2_grad1_u12_bimo_t(ipoint,1,p,i) * int2_grad1_u12_bimo_t(ipoint,1,i,j) & + + int2_grad1_u12_bimo_t(ipoint,2,p,i) * int2_grad1_u12_bimo_t(ipoint,2,i,j) & + + int2_grad1_u12_bimo_t(ipoint,3,p,i) * int2_grad1_u12_bimo_t(ipoint,3,i,j) ) + tmp3(ipoint,2,p) = tmp3(ipoint,2,p) + 0.5d0 * mos_l_in_r_array_transp(ipoint,i) * ( int2_grad1_u12_bimo_t(ipoint,1,p,j) * int2_grad1_u12_bimo_t(ipoint,1,j,i) & + + int2_grad1_u12_bimo_t(ipoint,2,p,j) * int2_grad1_u12_bimo_t(ipoint,2,j,i) & + + int2_grad1_u12_bimo_t(ipoint,3,p,j) * int2_grad1_u12_bimo_t(ipoint,3,j,i) ) + + tmp4(ipoint,1,p) = tmp4(ipoint,1,p) + 0.5d0 * mos_r_in_r_array_transp(ipoint,i) * ( int2_grad1_u12_bimo_t(ipoint,1,i,j) * int2_grad1_u12_bimo_t(ipoint,1,j,p) & + + int2_grad1_u12_bimo_t(ipoint,2,i,j) * int2_grad1_u12_bimo_t(ipoint,2,j,p) & + + int2_grad1_u12_bimo_t(ipoint,3,i,j) * int2_grad1_u12_bimo_t(ipoint,3,j,p) ) + tmp4(ipoint,1,p) = tmp4(ipoint,1,p) + 0.5d0 * mos_r_in_r_array_transp(ipoint,j) * ( int2_grad1_u12_bimo_t(ipoint,1,j,i) * int2_grad1_u12_bimo_t(ipoint,1,i,p) & + + int2_grad1_u12_bimo_t(ipoint,2,j,i) * int2_grad1_u12_bimo_t(ipoint,2,i,p) & + + int2_grad1_u12_bimo_t(ipoint,3,j,i) * int2_grad1_u12_bimo_t(ipoint,3,i,p) ) + enddo ! ipoint + enddo ! j + enddo ! i + + do i = elec_beta_num+1, elec_alpha_num + do j = elec_beta_num+1, elec_alpha_num + do ipoint = 1, n_points_final_grid + + tmp3(ipoint,2,p) = tmp3(ipoint,2,p) + 0.5d0 * mos_l_in_r_array_transp(ipoint,j) * ( int2_grad1_u12_bimo_t(ipoint,1,p,i) * int2_grad1_u12_bimo_t(ipoint,1,i,j) & + + int2_grad1_u12_bimo_t(ipoint,2,p,i) * int2_grad1_u12_bimo_t(ipoint,2,i,j) & + + int2_grad1_u12_bimo_t(ipoint,3,p,i) * int2_grad1_u12_bimo_t(ipoint,3,i,j) ) + + tmp4(ipoint,1,p) = tmp4(ipoint,1,p) + 0.5d0 * mos_r_in_r_array_transp(ipoint,i) * ( int2_grad1_u12_bimo_t(ipoint,1,i,j) * int2_grad1_u12_bimo_t(ipoint,1,j,p) & + + int2_grad1_u12_bimo_t(ipoint,2,i,j) * int2_grad1_u12_bimo_t(ipoint,2,j,p) & + + int2_grad1_u12_bimo_t(ipoint,3,i,j) * int2_grad1_u12_bimo_t(ipoint,3,j,p) ) + enddo ! ipoint + enddo ! j + enddo ! i + + enddo ! p + !$OMP END DO + !$OMP END PARALLEL + + deallocate(tmp_L0, tmp_L, tmp_R0, tmp_R, tmp_J, tmp_S) + + call dgemm( 'T', 'N', mo_num, mo_num, 8*n_points_final_grid, 1.d0 & + , tmp3(1,1,1), 8*n_points_final_grid, tmp4(1,1,1), 8*n_points_final_grid & + , 1.d0, noL_1e(1,1), mo_num) + + deallocate(tmp3, tmp4) + + endif + + call wall_time(t1) + print*, " Wall time for noL_1e (min) = ", (t1 - t0)/60.d0 + +END_PROVIDER + +! --- + +BEGIN_PROVIDER [double precision, noL_2e, (mo_num, mo_num, mo_num, mo_num)] + + implicit none + integer :: p, q, s, t, i, ipoint + double precision :: t0, t1 + double precision, allocatable :: tmp_O(:), tmp_J(:,:) + double precision, allocatable :: tmp_A(:,:,:), tmp_B(:,:,:) + double precision, allocatable :: tmp1(:,:,:,:), tmp2(:,:,:,:) + double precision, allocatable :: tmp(:,:,:,:) + + PROVIDE int2_grad1_u12_bimo_t + PROVIDE mos_l_in_r_array_transp mos_r_in_r_array_transp + + call wall_time(t0) + print*, " Providing noL_2e ..." + + if(elec_alpha_num .eq. elec_beta_num) then + + allocate(tmp_O(n_points_final_grid), tmp_J(n_points_final_grid,3)) + allocate(tmp_A(n_points_final_grid,3,mo_num), tmp_B(n_points_final_grid,3,mo_num)) + allocate(tmp1(n_points_final_grid,4,mo_num,mo_num), tmp2(n_points_final_grid,4,mo_num,mo_num)) + allocate(tmp(mo_num,mo_num,mo_num,mo_num)) + + tmp_O = 0.d0 + tmp_J = 0.d0 + do i = 1, elec_beta_num + do ipoint = 1, n_points_final_grid + tmp_O(ipoint) = tmp_O(ipoint) + final_weight_at_r_vector(ipoint) * mos_l_in_r_array_transp(ipoint,i) * mos_r_in_r_array_transp(ipoint,i) + tmp_J(ipoint,1) = tmp_J(ipoint,1) + final_weight_at_r_vector(ipoint) * int2_grad1_u12_bimo_t(ipoint,1,i,i) + tmp_J(ipoint,2) = tmp_J(ipoint,2) + final_weight_at_r_vector(ipoint) * int2_grad1_u12_bimo_t(ipoint,2,i,i) + tmp_J(ipoint,3) = tmp_J(ipoint,3) + final_weight_at_r_vector(ipoint) * int2_grad1_u12_bimo_t(ipoint,3,i,i) + enddo + enddo + + !$OMP PARALLEL & + !$OMP DEFAULT(NONE) & + !$OMP PRIVATE(p, i, ipoint) & + !$OMP SHARED(mo_num, elec_beta_num, n_points_final_grid, & + !$OMP final_weight_at_r_vector, mos_l_in_r_array_transp, & + !$OMP mos_r_in_r_array_transp, int2_grad1_u12_bimo_t, & + !$OMP tmp_A, tmp_B) + + !$OMP DO + do p = 1, mo_num + + tmp_A(:,:,p) = 0.d0 + tmp_B(:,:,p) = 0.d0 + do i = 1, elec_beta_num + do ipoint = 1, n_points_final_grid + tmp_A(ipoint,1,p) = tmp_A(ipoint,1,p) + final_weight_at_r_vector(ipoint) * mos_l_in_r_array_transp(ipoint,i) * int2_grad1_u12_bimo_t(ipoint,1,p,i) + tmp_A(ipoint,2,p) = tmp_A(ipoint,2,p) + final_weight_at_r_vector(ipoint) * mos_l_in_r_array_transp(ipoint,i) * int2_grad1_u12_bimo_t(ipoint,2,p,i) + tmp_A(ipoint,3,p) = tmp_A(ipoint,3,p) + final_weight_at_r_vector(ipoint) * mos_l_in_r_array_transp(ipoint,i) * int2_grad1_u12_bimo_t(ipoint,3,p,i) + tmp_B(ipoint,1,p) = tmp_B(ipoint,1,p) + final_weight_at_r_vector(ipoint) * mos_r_in_r_array_transp(ipoint,i) * int2_grad1_u12_bimo_t(ipoint,1,i,p) + tmp_B(ipoint,2,p) = tmp_B(ipoint,2,p) + final_weight_at_r_vector(ipoint) * mos_r_in_r_array_transp(ipoint,i) * int2_grad1_u12_bimo_t(ipoint,2,i,p) + tmp_B(ipoint,3,p) = tmp_B(ipoint,3,p) + final_weight_at_r_vector(ipoint) * mos_r_in_r_array_transp(ipoint,i) * int2_grad1_u12_bimo_t(ipoint,3,i,p) + enddo + enddo + enddo + !$OMP END DO + !$OMP END PARALLEL + + + !$OMP PARALLEL & + !$OMP DEFAULT(NONE) & + !$OMP PRIVATE(p, s, i, ipoint) & + !$OMP SHARED(mo_num, elec_beta_num, n_points_final_grid, & + !$OMP final_weight_at_r_vector, mos_l_in_r_array_transp, & + !$OMP mos_r_in_r_array_transp, int2_grad1_u12_bimo_t, & + !$OMP tmp_A, tmp_B, tmp_O, tmp_J, tmp1, tmp2) + + !$OMP DO COLLAPSE(2) + do s = 1, mo_num + do p = 1, mo_num + + do ipoint = 1, n_points_final_grid + + tmp1(ipoint,1,p,s) = mos_r_in_r_array_transp(ipoint,s) * tmp_A(ipoint,1,p) & + + mos_l_in_r_array_transp(ipoint,p) * tmp_B(ipoint,1,s) & + - tmp_O(ipoint) * int2_grad1_u12_bimo_t(ipoint,1,p,s) & + - 2.d0 * mos_l_in_r_array_transp(ipoint,p) * mos_r_in_r_array_transp(ipoint,s) * tmp_J(ipoint,1) + tmp1(ipoint,2,p,s) = mos_r_in_r_array_transp(ipoint,s) * tmp_A(ipoint,2,p) & + + mos_l_in_r_array_transp(ipoint,p) * tmp_B(ipoint,2,s) & + - tmp_O(ipoint) * int2_grad1_u12_bimo_t(ipoint,2,p,s) & + - 2.d0 * mos_l_in_r_array_transp(ipoint,p) * mos_r_in_r_array_transp(ipoint,s) * tmp_J(ipoint,2) + tmp1(ipoint,3,p,s) = mos_r_in_r_array_transp(ipoint,s) * tmp_A(ipoint,3,p) & + + mos_l_in_r_array_transp(ipoint,p) * tmp_B(ipoint,3,s) & + - tmp_O(ipoint) * int2_grad1_u12_bimo_t(ipoint,3,p,s) & + - 2.d0 * mos_l_in_r_array_transp(ipoint,p) * mos_r_in_r_array_transp(ipoint,s) * tmp_J(ipoint,3) + + tmp2(ipoint,1,p,s) = int2_grad1_u12_bimo_t(ipoint,1,p,s) + tmp2(ipoint,2,p,s) = int2_grad1_u12_bimo_t(ipoint,2,p,s) + tmp2(ipoint,3,p,s) = int2_grad1_u12_bimo_t(ipoint,3,p,s) + tmp2(ipoint,4,p,s) = final_weight_at_r_vector(ipoint) * mos_l_in_r_array_transp(ipoint,p) * mos_r_in_r_array_transp(ipoint,s) + + enddo ! ipoint + + tmp1(:,4,p,s) = 0.d0 + do i = 1, elec_beta_num + do ipoint = 1, n_points_final_grid + tmp1(ipoint,4,p,s) = tmp1(ipoint,4,p,s) + int2_grad1_u12_bimo_t(ipoint,1,p,i) * int2_grad1_u12_bimo_t(ipoint,1,i,s) & + + int2_grad1_u12_bimo_t(ipoint,2,p,i) * int2_grad1_u12_bimo_t(ipoint,2,i,s) & + + int2_grad1_u12_bimo_t(ipoint,3,p,i) * int2_grad1_u12_bimo_t(ipoint,3,i,s) + enddo ! ipoint + enddo ! i + + enddo ! p + enddo ! s + !$OMP END DO + !$OMP END PARALLEL + + deallocate(tmp_O, tmp_J, tmp_A, tmp_B) + + + call dgemm( 'T', 'N', mo_num*mo_num, mo_num*mo_num, 4*n_points_final_grid, 0.5d0 & + , tmp1(1,1,1,1), 4*n_points_final_grid, tmp2(1,1,1,1), 4*n_points_final_grid & + , 0.d0, tmp(1,1,1,1), mo_num*mo_num) + + deallocate(tmp1, tmp2) + + call sum_a_at(tmp, mo_num*mo_num) + + !$OMP PARALLEL & + !$OMP DEFAULT(NONE) & + !$OMP PRIVATE(t, s, q, p) & + !$OMP SHARED(mo_num, tmp, noL_2e) + + !$OMP DO COLLAPSE(3) + do t = 1, mo_num + do s = 1, mo_num + do q = 1, mo_num + do p = 1, mo_num + noL_2e(p,q,s,t) = tmp(p,s,q,t) + enddo + enddo + enddo + enddo + !$OMP END DO + !$OMP END PARALLEL + + deallocate(tmp) + + else + + allocate(tmp_O(n_points_final_grid), tmp_J(n_points_final_grid,3)) + allocate(tmp_A(n_points_final_grid,3,mo_num), tmp_B(n_points_final_grid,3,mo_num)) + allocate(tmp1(n_points_final_grid,4,mo_num,mo_num), tmp2(n_points_final_grid,4,mo_num,mo_num)) + allocate(tmp(mo_num,mo_num,mo_num,mo_num)) + + tmp_O = 0.d0 + tmp_J = 0.d0 + do i = 1, elec_beta_num + do ipoint = 1, n_points_final_grid + tmp_O(ipoint) = tmp_O(ipoint) + final_weight_at_r_vector(ipoint) * mos_l_in_r_array_transp(ipoint,i) * mos_r_in_r_array_transp(ipoint,i) + tmp_J(ipoint,1) = tmp_J(ipoint,1) + final_weight_at_r_vector(ipoint) * int2_grad1_u12_bimo_t(ipoint,1,i,i) + tmp_J(ipoint,2) = tmp_J(ipoint,2) + final_weight_at_r_vector(ipoint) * int2_grad1_u12_bimo_t(ipoint,2,i,i) + tmp_J(ipoint,3) = tmp_J(ipoint,3) + final_weight_at_r_vector(ipoint) * int2_grad1_u12_bimo_t(ipoint,3,i,i) + enddo + enddo + do i = elec_beta_num+1, elec_alpha_num + do ipoint = 1, n_points_final_grid + tmp_O(ipoint) = tmp_O(ipoint) + 0.5d0 * final_weight_at_r_vector(ipoint) * mos_l_in_r_array_transp(ipoint,i) * mos_r_in_r_array_transp(ipoint,i) + tmp_J(ipoint,1) = tmp_J(ipoint,1) + 0.5d0 * final_weight_at_r_vector(ipoint) * int2_grad1_u12_bimo_t(ipoint,1,i,i) + tmp_J(ipoint,2) = tmp_J(ipoint,2) + 0.5d0 * final_weight_at_r_vector(ipoint) * int2_grad1_u12_bimo_t(ipoint,2,i,i) + tmp_J(ipoint,3) = tmp_J(ipoint,3) + 0.5d0 * final_weight_at_r_vector(ipoint) * int2_grad1_u12_bimo_t(ipoint,3,i,i) + enddo + enddo + + !$OMP PARALLEL & + !$OMP DEFAULT(NONE) & + !$OMP PRIVATE(p, i, ipoint) & + !$OMP SHARED(mo_num, elec_alpha_num, elec_beta_num, n_points_final_grid, & + !$OMP final_weight_at_r_vector, mos_l_in_r_array_transp, & + !$OMP mos_r_in_r_array_transp, int2_grad1_u12_bimo_t, & + !$OMP tmp_A, tmp_B) + + !$OMP DO + do p = 1, mo_num + + tmp_A(:,:,p) = 0.d0 + tmp_B(:,:,p) = 0.d0 + do i = 1, elec_beta_num + do ipoint = 1, n_points_final_grid + tmp_A(ipoint,1,p) = tmp_A(ipoint,1,p) + final_weight_at_r_vector(ipoint) * mos_l_in_r_array_transp(ipoint,i) * int2_grad1_u12_bimo_t(ipoint,1,p,i) + tmp_A(ipoint,2,p) = tmp_A(ipoint,2,p) + final_weight_at_r_vector(ipoint) * mos_l_in_r_array_transp(ipoint,i) * int2_grad1_u12_bimo_t(ipoint,2,p,i) + tmp_A(ipoint,3,p) = tmp_A(ipoint,3,p) + final_weight_at_r_vector(ipoint) * mos_l_in_r_array_transp(ipoint,i) * int2_grad1_u12_bimo_t(ipoint,3,p,i) + tmp_B(ipoint,1,p) = tmp_B(ipoint,1,p) + final_weight_at_r_vector(ipoint) * mos_r_in_r_array_transp(ipoint,i) * int2_grad1_u12_bimo_t(ipoint,1,i,p) + tmp_B(ipoint,2,p) = tmp_B(ipoint,2,p) + final_weight_at_r_vector(ipoint) * mos_r_in_r_array_transp(ipoint,i) * int2_grad1_u12_bimo_t(ipoint,2,i,p) + tmp_B(ipoint,3,p) = tmp_B(ipoint,3,p) + final_weight_at_r_vector(ipoint) * mos_r_in_r_array_transp(ipoint,i) * int2_grad1_u12_bimo_t(ipoint,3,i,p) + enddo + enddo + do i = elec_beta_num+1, elec_alpha_num + do ipoint = 1, n_points_final_grid + tmp_A(ipoint,1,p) = tmp_A(ipoint,1,p) + 0.5d0 * final_weight_at_r_vector(ipoint) * mos_l_in_r_array_transp(ipoint,i) * int2_grad1_u12_bimo_t(ipoint,1,p,i) + tmp_A(ipoint,2,p) = tmp_A(ipoint,2,p) + 0.5d0 * final_weight_at_r_vector(ipoint) * mos_l_in_r_array_transp(ipoint,i) * int2_grad1_u12_bimo_t(ipoint,2,p,i) + tmp_A(ipoint,3,p) = tmp_A(ipoint,3,p) + 0.5d0 * final_weight_at_r_vector(ipoint) * mos_l_in_r_array_transp(ipoint,i) * int2_grad1_u12_bimo_t(ipoint,3,p,i) + tmp_B(ipoint,1,p) = tmp_B(ipoint,1,p) + 0.5d0 * final_weight_at_r_vector(ipoint) * mos_r_in_r_array_transp(ipoint,i) * int2_grad1_u12_bimo_t(ipoint,1,i,p) + tmp_B(ipoint,2,p) = tmp_B(ipoint,2,p) + 0.5d0 * final_weight_at_r_vector(ipoint) * mos_r_in_r_array_transp(ipoint,i) * int2_grad1_u12_bimo_t(ipoint,2,i,p) + tmp_B(ipoint,3,p) = tmp_B(ipoint,3,p) + 0.5d0 * final_weight_at_r_vector(ipoint) * mos_r_in_r_array_transp(ipoint,i) * int2_grad1_u12_bimo_t(ipoint,3,i,p) + enddo + enddo + enddo + !$OMP END DO + !$OMP END PARALLEL + + + !$OMP PARALLEL & + !$OMP DEFAULT(NONE) & + !$OMP PRIVATE(p, s, i, ipoint) & + !$OMP SHARED(mo_num, elec_alpha_num, elec_beta_num, n_points_final_grid, & + !$OMP final_weight_at_r_vector, mos_l_in_r_array_transp, & + !$OMP mos_r_in_r_array_transp, int2_grad1_u12_bimo_t, & + !$OMP tmp_A, tmp_B, tmp_O, tmp_J, tmp1, tmp2) + + !$OMP DO COLLAPSE(2) + do s = 1, mo_num + do p = 1, mo_num + + do ipoint = 1, n_points_final_grid + + tmp1(ipoint,1,p,s) = mos_r_in_r_array_transp(ipoint,s) * tmp_A(ipoint,1,p) & + + mos_l_in_r_array_transp(ipoint,p) * tmp_B(ipoint,1,s) & + - tmp_O(ipoint) * int2_grad1_u12_bimo_t(ipoint,1,p,s) & + - 2.d0 * mos_l_in_r_array_transp(ipoint,p) * mos_r_in_r_array_transp(ipoint,s) * tmp_J(ipoint,1) + tmp1(ipoint,2,p,s) = mos_r_in_r_array_transp(ipoint,s) * tmp_A(ipoint,2,p) & + + mos_l_in_r_array_transp(ipoint,p) * tmp_B(ipoint,2,s) & + - tmp_O(ipoint) * int2_grad1_u12_bimo_t(ipoint,2,p,s) & + - 2.d0 * mos_l_in_r_array_transp(ipoint,p) * mos_r_in_r_array_transp(ipoint,s) * tmp_J(ipoint,2) + tmp1(ipoint,3,p,s) = mos_r_in_r_array_transp(ipoint,s) * tmp_A(ipoint,3,p) & + + mos_l_in_r_array_transp(ipoint,p) * tmp_B(ipoint,3,s) & + - tmp_O(ipoint) * int2_grad1_u12_bimo_t(ipoint,3,p,s) & + - 2.d0 * mos_l_in_r_array_transp(ipoint,p) * mos_r_in_r_array_transp(ipoint,s) * tmp_J(ipoint,3) + + tmp2(ipoint,1,p,s) = int2_grad1_u12_bimo_t(ipoint,1,p,s) + tmp2(ipoint,2,p,s) = int2_grad1_u12_bimo_t(ipoint,2,p,s) + tmp2(ipoint,3,p,s) = int2_grad1_u12_bimo_t(ipoint,3,p,s) + tmp2(ipoint,4,p,s) = final_weight_at_r_vector(ipoint) * mos_l_in_r_array_transp(ipoint,p) * mos_r_in_r_array_transp(ipoint,s) + + enddo ! ipoint + + tmp1(:,4,p,s) = 0.d0 + do i = 1, elec_beta_num + do ipoint = 1, n_points_final_grid + tmp1(ipoint,4,p,s) = tmp1(ipoint,4,p,s) + int2_grad1_u12_bimo_t(ipoint,1,p,i) * int2_grad1_u12_bimo_t(ipoint,1,i,s) & + + int2_grad1_u12_bimo_t(ipoint,2,p,i) * int2_grad1_u12_bimo_t(ipoint,2,i,s) & + + int2_grad1_u12_bimo_t(ipoint,3,p,i) * int2_grad1_u12_bimo_t(ipoint,3,i,s) + enddo ! ipoint + enddo ! i + do i = elec_beta_num+1, elec_alpha_num + do ipoint = 1, n_points_final_grid + tmp1(ipoint,4,p,s) = tmp1(ipoint,4,p,s) + 0.5d0 * int2_grad1_u12_bimo_t(ipoint,1,p,i) * int2_grad1_u12_bimo_t(ipoint,1,i,s) & + + 0.5d0 * int2_grad1_u12_bimo_t(ipoint,2,p,i) * int2_grad1_u12_bimo_t(ipoint,2,i,s) & + + 0.5d0 * int2_grad1_u12_bimo_t(ipoint,3,p,i) * int2_grad1_u12_bimo_t(ipoint,3,i,s) + enddo ! ipoint + enddo ! i + + enddo ! p + enddo ! s + !$OMP END DO + !$OMP END PARALLEL + + deallocate(tmp_O, tmp_J, tmp_A, tmp_B) + + + call dgemm( 'T', 'N', mo_num*mo_num, mo_num*mo_num, 4*n_points_final_grid, 0.5d0 & + , tmp1(1,1,1,1), 4*n_points_final_grid, tmp2(1,1,1,1), 4*n_points_final_grid & + , 0.d0, tmp(1,1,1,1), mo_num*mo_num) + + deallocate(tmp1, tmp2) + + call sum_a_at(tmp, mo_num*mo_num) + + !$OMP PARALLEL & + !$OMP DEFAULT(NONE) & + !$OMP PRIVATE(t, s, q, p) & + !$OMP SHARED(mo_num, tmp, noL_2e) + + !$OMP DO COLLAPSE(3) + do t = 1, mo_num + do s = 1, mo_num + do q = 1, mo_num + do p = 1, mo_num + noL_2e(p,q,s,t) = tmp(p,s,q,t) + enddo + enddo + enddo + enddo + !$OMP END DO + !$OMP END PARALLEL + + deallocate(tmp) + + endif + + call wall_time(t1) + print*, " Wall time for noL_2e (min) = ", (t1 - t0)/60.d0 + +END_PROVIDER + +! --- + diff --git a/plugins/local/bi_ort_ints/no_dressing_energy.irp.f b/plugins/local/bi_ort_ints/no_dressing_energy.irp.f new file mode 100644 index 00000000..30b2fa04 --- /dev/null +++ b/plugins/local/bi_ort_ints/no_dressing_energy.irp.f @@ -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 + +! --- + diff --git a/plugins/local/bi_ort_ints/no_dressing_naive.irp.f b/plugins/local/bi_ort_ints/no_dressing_naive.irp.f new file mode 100644 index 00000000..abc80632 --- /dev/null +++ b/plugins/local/bi_ort_ints/no_dressing_naive.irp.f @@ -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 + +! --- + + diff --git a/src/bi_ort_ints/one_e_bi_ort.irp.f b/plugins/local/bi_ort_ints/one_e_bi_ort.irp.f similarity index 85% rename from src/bi_ort_ints/one_e_bi_ort.irp.f rename to plugins/local/bi_ort_ints/one_e_bi_ort.irp.f index 49181182..0ecc2a84 100644 --- a/src/bi_ort_ints/one_e_bi_ort.irp.f +++ b/plugins/local/bi_ort_ints/one_e_bi_ort.irp.f @@ -29,7 +29,7 @@ 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 ! @@ -41,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) + if(noL_standard) then + PROVIDE noL_1e + mo_bi_ortho_tc_one_e = mo_bi_ortho_tc_one_e + noL_1e + endif + END_PROVIDER ! --- @@ -48,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_y , (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 - ! array of the integrals of Left MO_i * y Right MO_j - ! array of the integrals of Left MO_i * z Right MO_j - END_DOC - implicit none + + BEGIN_DOC + ! array of the integrals of Left MO_i * x Right MO_j + ! array of the integrals of Left MO_i * y Right MO_j + ! array of the integrals of Left MO_i * z Right MO_j + END_DOC + + implicit none call ao_to_mo_bi_ortho( & ao_dipole_x, & diff --git a/src/bi_ort_ints/semi_num_ints_mo.irp.f b/plugins/local/bi_ort_ints/semi_num_ints_mo.irp.f similarity index 100% rename from src/bi_ort_ints/semi_num_ints_mo.irp.f rename to plugins/local/bi_ort_ints/semi_num_ints_mo.irp.f diff --git a/src/bi_ort_ints/three_body_ijm.irp.f b/plugins/local/bi_ort_ints/three_body_ijm.irp.f similarity index 95% rename from src/bi_ort_ints/three_body_ijm.irp.f rename to plugins/local/bi_ort_ints/three_body_ijm.irp.f index 5de33a76..cc1b6ea0 100644 --- a/src/bi_ort_ints/three_body_ijm.irp.f +++ b/plugins/local/bi_ort_ints/three_body_ijm.irp.f @@ -18,12 +18,13 @@ BEGIN_PROVIDER [ double precision, three_e_3_idx_direct_bi_ort, (mo_num, mo_num, 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 print *, ' Providing the three_e_3_idx_direct_bi_ort ...' 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 DEFAULT (NONE) & @@ -79,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 + call give_integrals_3_body_bi_ort(1, 1, 1, 1, 1, 1, integral) !$OMP PARALLEL & !$OMP DEFAULT (NONE) & !$OMP PRIVATE (i,j,m,integral) & @@ -135,6 +137,7 @@ BEGIN_PROVIDER [ double precision, three_e_3_idx_cycle_2_bi_ort, (mo_num, mo_num 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 DEFAULT (NONE) & !$OMP PRIVATE (i,j,m,integral) & @@ -191,6 +194,7 @@ BEGIN_PROVIDER [ double precision, three_e_3_idx_exch23_bi_ort, (mo_num, mo_num, 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 DEFAULT (NONE) & !$OMP PRIVATE (i,j,m,integral) & @@ -247,6 +251,7 @@ BEGIN_PROVIDER [ double precision, three_e_3_idx_exch13_bi_ort, (mo_num, mo_num, 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 DEFAULT (NONE) & !$OMP PRIVATE (i,j,m,integral) & @@ -303,6 +308,7 @@ BEGIN_PROVIDER [ double precision, three_e_3_idx_exch12_bi_ort, (mo_num, mo_num, 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 DEFAULT (NONE) & !$OMP PRIVATE (i,j,m,integral) & @@ -349,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 + call give_integrals_3_body_bi_ort(1, 1, 1, 1, 1, 1, integral) !$OMP PARALLEL & !$OMP DEFAULT (NONE) & !$OMP PRIVATE (i,j,m,integral) & diff --git a/src/bi_ort_ints/three_body_ijmk.irp.f b/plugins/local/bi_ort_ints/three_body_ijmk.irp.f similarity index 52% rename from src/bi_ort_ints/three_body_ijmk.irp.f rename to plugins/local/bi_ort_ints/three_body_ijmk.irp.f index 669861b7..c1f2af60 100644 --- a/src/bi_ort_ints/three_body_ijmk.irp.f +++ b/plugins/local/bi_ort_ints/three_body_ijmk.irp.f @@ -17,10 +17,10 @@ ! ! 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 ! - ! 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 + ! 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 ! three_e_4_idx_exch23_bi_ort (m,j,k,i) : Lk Ri Imj Ijm + Lj Rm Imj Iki + Lm Rj Ijm Iki - ! three_e_4_idx_cycle_1_bi_ort(m,j,k,i) : Lk Rm Imj Iji + Lj Ri Imj Ikm + Lm Rj Iji Ikm + ! three_e_4_idx_cycle_1_bi_ort(m,j,k,i) : Lk Rm Imj Iji + Lj Ri Imj Ikm + Lm Rj Iji Ikm ! END_DOC @@ -64,120 +64,117 @@ !$OMP END DO !$OMP END PARALLEL + + + + + ! 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)) - ! loops approach to break the O(N^4) scaling in memory + !$OMP DO do k = 1, mo_num + + ! --- + do i = 1, mo_num - !$OMP PARALLEL & - !$OMP DEFAULT (NONE) & - !$OMP PRIVATE (n, ipoint, tmp_loc_1, tmp_loc_2) & - !$OMP SHARED (mo_num, n_points_final_grid, i, k, & - !$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_2, tmp1) - !$OMP DO - 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) + do n = 1, mo_num + do ipoint = 1, n_points_final_grid - 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) + 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 - enddo - !$OMP END DO - !$OMP END PARALLEL - 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) + 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) - !$OMP PARALLEL DO PRIVATE(j,m) - 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) + 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 - enddo - !$OMP END PARALLEL DO + ! --- + do n = 1, mo_num + do ipoint = 1, n_points_final_grid - !$OMP PARALLEL & - !$OMP DEFAULT (NONE) & - !$OMP PRIVATE (n, ipoint, tmp_loc_1, tmp_loc_2) & - !$OMP SHARED (mo_num, n_points_final_grid, i, k, & - !$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) - !$OMP DO - 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) - 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) - 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) + 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 - enddo - !$OMP END DO - !$OMP END PARALLEL - 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) + ! --- - !$OMP PARALLEL DO PRIVATE(j,m) - 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) + 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 - enddo - !$OMP END PARALLEL DO - 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) + ! --- - !$OMP PARALLEL DO PRIVATE(j,m) - 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) + 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 - !$OMP END PARALLEL DO - enddo ! i + ! --- + + enddo ! i + + ! --- do j = 1, mo_num - !$OMP PARALLEL & - !$OMP DEFAULT (NONE) & - !$OMP PRIVATE (n, ipoint, tmp_loc_1, tmp_loc_2) & - !$OMP SHARED (mo_num, n_points_final_grid, j, k, & - !$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) - !$OMP DO do n = 1, mo_num do ipoint = 1, n_points_final_grid @@ -197,36 +194,38 @@ 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 - !$OMP END DO - !$OMP END PARALLEL 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) - !$OMP PARALLEL DO PRIVATE(i,m) 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 - !$OMP END PARALLEL DO 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 +END_PROVIDER ! --- diff --git a/src/bi_ort_ints/three_body_ijmk_n4.irp.f b/plugins/local/bi_ort_ints/three_body_ijmk_n4.irp.f similarity index 100% rename from src/bi_ort_ints/three_body_ijmk_n4.irp.f rename to plugins/local/bi_ort_ints/three_body_ijmk_n4.irp.f diff --git a/src/bi_ort_ints/three_body_ijmk_old.irp.f b/plugins/local/bi_ort_ints/three_body_ijmk_old.irp.f similarity index 100% rename from src/bi_ort_ints/three_body_ijmk_old.irp.f rename to plugins/local/bi_ort_ints/three_body_ijmk_old.irp.f diff --git a/src/bi_ort_ints/three_body_ijmkl.irp.f b/plugins/local/bi_ort_ints/three_body_ijmkl.irp.f similarity index 100% rename from src/bi_ort_ints/three_body_ijmkl.irp.f rename to plugins/local/bi_ort_ints/three_body_ijmkl.irp.f diff --git a/src/bi_ort_ints/three_body_ijmkl_old.irp.f b/plugins/local/bi_ort_ints/three_body_ijmkl_old.irp.f similarity index 100% rename from src/bi_ort_ints/three_body_ijmkl_old.irp.f rename to plugins/local/bi_ort_ints/three_body_ijmkl_old.irp.f diff --git a/src/bi_ort_ints/three_body_ints_bi_ort.irp.f b/plugins/local/bi_ort_ints/three_body_ints_bi_ort.irp.f similarity index 71% rename from src/bi_ort_ints/three_body_ints_bi_ort.irp.f rename to plugins/local/bi_ort_ints/three_body_ints_bi_ort.irp.f index d8145c3e..726e48ba 100644 --- a/src/bi_ort_ints/three_body_ints_bi_ort.irp.f +++ b/plugins/local/bi_ort_ints/three_body_ints_bi_ort.irp.f @@ -29,6 +29,9 @@ BEGIN_PROVIDER [ double precision, three_body_ints_bi_ort, (mo_num, mo_num, mo_n !provide x_W_ki_bi_ortho_erf_rk 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 DEFAULT (NONE) & @@ -68,11 +71,69 @@ 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 + +! --- + subroutine give_integrals_3_body_bi_ort(n, l, k, m, j, i, integral) BEGIN_DOC ! - ! < n l k | -L | m j i > with a BI-ORTHONORMAL 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 @@ -115,7 +176,9 @@ subroutine give_integrals_3_body_bi_ort_old(n, l, k, m, j, i, integral) BEGIN_DOC ! - ! < n l k | -L | m j i > with a BI-ORTHONORMAL 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 @@ -128,35 +191,6 @@ subroutine give_integrals_3_body_bi_ort_old(n, l, k, m, j, i, integral) integral = 0.d0 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) & -! * ( 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,2,ipoint) * int2_grad1_u12_bimo_transp(l,j,2,ipoint) & @@ -180,7 +214,9 @@ subroutine give_integrals_3_body_bi_ort_ao(n, l, k, m, j, i, integral) BEGIN_DOC ! - ! < n l k | -L | m j i > with a BI-ORTHONORMAL ATOMIC ORBITALS + ! < n l k | L | m j i > with a BI-ORTHONORMAL ATOMIC ORBITALS + ! + ! /!\ L is defined without the 1/6 factor ! END_DOC diff --git a/src/bi_ort_ints/total_twoe_pot.irp.f b/plugins/local/bi_ort_ints/total_twoe_pot.irp.f similarity index 94% rename from src/bi_ort_ints/total_twoe_pot.irp.f rename to plugins/local/bi_ort_ints/total_twoe_pot.irp.f index f03e8a34..37a31a51 100644 --- a/src/bi_ort_ints/total_twoe_pot.irp.f +++ b/plugins/local/bi_ort_ints/total_twoe_pot.irp.f @@ -256,6 +256,13 @@ BEGIN_PROVIDER [double precision, mo_bi_ortho_tc_two_e, (mo_num, mo_num, mo_num, 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 ! --- @@ -266,9 +273,11 @@ END_PROVIDER &BEGIN_PROVIDER [ double precision, mo_bi_ortho_tc_two_e_jj_anti, (mo_num,mo_num)] BEGIN_DOC - ! mo_bi_ortho_tc_two_e_jj(i,j) = J_ij = + ! + ! mo_bi_ortho_tc_two_e_jj (i,j) = J_ij = ! mo_bi_ortho_tc_two_e_jj_exchange(i,j) = K_ij = - ! 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 implicit none @@ -279,9 +288,9 @@ END_PROVIDER do i = 1, mo_num do j = 1, mo_num - mo_bi_ortho_tc_two_e_jj(i,j) = mo_bi_ortho_tc_two_e(j,i,j,i) + mo_bi_ortho_tc_two_e_jj (i,j) = mo_bi_ortho_tc_two_e(j,i,j,i) mo_bi_ortho_tc_two_e_jj_exchange(i,j) = mo_bi_ortho_tc_two_e(i,j,j,i) - mo_bi_ortho_tc_two_e_jj_anti(i,j) = mo_bi_ortho_tc_two_e_jj(i,j) - mo_bi_ortho_tc_two_e_jj_exchange(i,j) + 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 diff --git a/src/bi_ortho_mos/EZFIO.cfg b/plugins/local/bi_ortho_mos/EZFIO.cfg similarity index 100% rename from src/bi_ortho_mos/EZFIO.cfg rename to plugins/local/bi_ortho_mos/EZFIO.cfg diff --git a/src/bi_ortho_mos/NEED b/plugins/local/bi_ortho_mos/NEED similarity index 100% rename from src/bi_ortho_mos/NEED rename to plugins/local/bi_ortho_mos/NEED diff --git a/src/bi_ortho_mos/bi_density.irp.f b/plugins/local/bi_ortho_mos/bi_density.irp.f similarity index 93% rename from src/bi_ortho_mos/bi_density.irp.f rename to plugins/local/bi_ortho_mos/bi_density.irp.f index 2dad9485..90fe9634 100644 --- a/src/bi_ortho_mos/bi_density.irp.f +++ b/plugins/local/bi_ortho_mos/bi_density.irp.f @@ -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 & , mo_l_coef, size(mo_l_coef, 1), mo_r_coef, size(mo_r_coef, 1) & - !, mo_r_coef, size(mo_r_coef, 1), mo_l_coef, size(mo_l_coef, 1) & , 0.d0, TCSCF_bi_ort_dm_ao_alpha, size(TCSCF_bi_ort_dm_ao_alpha, 1) ) END_PROVIDER @@ -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 & , mo_l_coef, size(mo_l_coef, 1), mo_r_coef, size(mo_r_coef, 1) & - !, mo_r_coef, size(mo_r_coef, 1), mo_l_coef, size(mo_l_coef, 1) & , 0.d0, TCSCF_bi_ort_dm_ao_beta, size(TCSCF_bi_ort_dm_ao_beta, 1) ) END_PROVIDER diff --git a/src/bi_ortho_mos/bi_ort_mos_in_r.irp.f b/plugins/local/bi_ortho_mos/bi_ort_mos_in_r.irp.f similarity index 100% rename from src/bi_ortho_mos/bi_ort_mos_in_r.irp.f rename to plugins/local/bi_ortho_mos/bi_ort_mos_in_r.irp.f diff --git a/src/bi_ortho_mos/grad_bi_ort_mos_in_r.irp.f b/plugins/local/bi_ortho_mos/grad_bi_ort_mos_in_r.irp.f similarity index 100% rename from src/bi_ortho_mos/grad_bi_ort_mos_in_r.irp.f rename to plugins/local/bi_ortho_mos/grad_bi_ort_mos_in_r.irp.f diff --git a/src/bi_ortho_mos/mos_rl.irp.f b/plugins/local/bi_ortho_mos/mos_rl.irp.f similarity index 98% rename from src/bi_ortho_mos/mos_rl.irp.f rename to plugins/local/bi_ortho_mos/mos_rl.irp.f index 13eedfb7..73913426 100644 --- a/src/bi_ortho_mos/mos_rl.irp.f +++ b/plugins/local/bi_ortho_mos/mos_rl.irp.f @@ -32,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) & , 0.d0, A_mo, LDA_mo ) -! call restore_symmetry(mo_num,mo_num,A_mo,size(A_mo,1),1.d-12) deallocate(T) end subroutine ao_to_mo_bi_ortho diff --git a/src/bi_ortho_mos/overlap.irp.f b/plugins/local/bi_ortho_mos/overlap.irp.f similarity index 100% rename from src/bi_ortho_mos/overlap.irp.f rename to plugins/local/bi_ortho_mos/overlap.irp.f diff --git a/plugins/local/casscf_tc_bi/NEED b/plugins/local/casscf_tc_bi/NEED new file mode 100644 index 00000000..b4c958e6 --- /dev/null +++ b/plugins/local/casscf_tc_bi/NEED @@ -0,0 +1,3 @@ +determinants +tc_bi_ortho +fci_tc_bi diff --git a/src/casscf_tc_bi/det_manip.irp.f b/plugins/local/casscf_tc_bi/det_manip.irp.f similarity index 100% rename from src/casscf_tc_bi/det_manip.irp.f rename to plugins/local/casscf_tc_bi/det_manip.irp.f diff --git a/src/casscf_tc_bi/grad_dm.irp.f b/plugins/local/casscf_tc_bi/grad_dm.irp.f similarity index 100% rename from src/casscf_tc_bi/grad_dm.irp.f rename to plugins/local/casscf_tc_bi/grad_dm.irp.f diff --git a/src/casscf_tc_bi/grad_old.irp.f b/plugins/local/casscf_tc_bi/grad_old.irp.f similarity index 100% rename from src/casscf_tc_bi/grad_old.irp.f rename to plugins/local/casscf_tc_bi/grad_old.irp.f diff --git a/src/casscf_tc_bi/gradient.irp.f b/plugins/local/casscf_tc_bi/gradient.irp.f similarity index 100% rename from src/casscf_tc_bi/gradient.irp.f rename to plugins/local/casscf_tc_bi/gradient.irp.f diff --git a/src/casscf_tc_bi/test_tc_casscf.irp.f b/plugins/local/casscf_tc_bi/test_tc_casscf.irp.f similarity index 100% rename from src/casscf_tc_bi/test_tc_casscf.irp.f rename to plugins/local/casscf_tc_bi/test_tc_casscf.irp.f diff --git a/src/cipsi_tc_bi_ortho/EZFIO.cfg b/plugins/local/cipsi_tc_bi_ortho/EZFIO.cfg similarity index 100% rename from src/cipsi_tc_bi_ortho/EZFIO.cfg rename to plugins/local/cipsi_tc_bi_ortho/EZFIO.cfg diff --git a/src/cipsi_tc_bi_ortho/NEED b/plugins/local/cipsi_tc_bi_ortho/NEED similarity index 100% rename from src/cipsi_tc_bi_ortho/NEED rename to plugins/local/cipsi_tc_bi_ortho/NEED diff --git a/src/cipsi_tc_bi_ortho/cipsi.irp.f b/plugins/local/cipsi_tc_bi_ortho/cipsi.irp.f similarity index 100% rename from src/cipsi_tc_bi_ortho/cipsi.irp.f rename to plugins/local/cipsi_tc_bi_ortho/cipsi.irp.f diff --git a/src/cipsi_tc_bi_ortho/energy.irp.f b/plugins/local/cipsi_tc_bi_ortho/energy.irp.f similarity index 100% rename from src/cipsi_tc_bi_ortho/energy.irp.f rename to plugins/local/cipsi_tc_bi_ortho/energy.irp.f diff --git a/src/cipsi_tc_bi_ortho/environment.irp.f b/plugins/local/cipsi_tc_bi_ortho/environment.irp.f similarity index 100% rename from src/cipsi_tc_bi_ortho/environment.irp.f rename to plugins/local/cipsi_tc_bi_ortho/environment.irp.f diff --git a/src/cipsi_tc_bi_ortho/fock_diag.irp.f b/plugins/local/cipsi_tc_bi_ortho/fock_diag.irp.f similarity index 100% rename from src/cipsi_tc_bi_ortho/fock_diag.irp.f rename to plugins/local/cipsi_tc_bi_ortho/fock_diag.irp.f diff --git a/src/cipsi_tc_bi_ortho/get_d.irp.f b/plugins/local/cipsi_tc_bi_ortho/get_d.irp.f similarity index 100% rename from src/cipsi_tc_bi_ortho/get_d.irp.f rename to plugins/local/cipsi_tc_bi_ortho/get_d.irp.f diff --git a/src/cipsi_tc_bi_ortho/get_d0_good.irp.f b/plugins/local/cipsi_tc_bi_ortho/get_d0_good.irp.f similarity index 100% rename from src/cipsi_tc_bi_ortho/get_d0_good.irp.f rename to plugins/local/cipsi_tc_bi_ortho/get_d0_good.irp.f diff --git a/src/cipsi_tc_bi_ortho/get_d1_good.irp.f b/plugins/local/cipsi_tc_bi_ortho/get_d1_good.irp.f similarity index 100% rename from src/cipsi_tc_bi_ortho/get_d1_good.irp.f rename to plugins/local/cipsi_tc_bi_ortho/get_d1_good.irp.f diff --git a/src/cipsi_tc_bi_ortho/get_d2_good.irp.f b/plugins/local/cipsi_tc_bi_ortho/get_d2_good.irp.f similarity index 100% rename from src/cipsi_tc_bi_ortho/get_d2_good.irp.f rename to plugins/local/cipsi_tc_bi_ortho/get_d2_good.irp.f diff --git a/src/cipsi_tc_bi_ortho/lock_2rdm.irp.f b/plugins/local/cipsi_tc_bi_ortho/lock_2rdm.irp.f similarity index 100% rename from src/cipsi_tc_bi_ortho/lock_2rdm.irp.f rename to plugins/local/cipsi_tc_bi_ortho/lock_2rdm.irp.f diff --git a/src/cipsi_tc_bi_ortho/pouet b/plugins/local/cipsi_tc_bi_ortho/pouet similarity index 100% rename from src/cipsi_tc_bi_ortho/pouet rename to plugins/local/cipsi_tc_bi_ortho/pouet diff --git a/src/cipsi_tc_bi_ortho/pt2.irp.f b/plugins/local/cipsi_tc_bi_ortho/pt2.irp.f similarity index 100% rename from src/cipsi_tc_bi_ortho/pt2.irp.f rename to plugins/local/cipsi_tc_bi_ortho/pt2.irp.f diff --git a/src/cipsi_tc_bi_ortho/pt2_stoch_routines.irp.f b/plugins/local/cipsi_tc_bi_ortho/pt2_stoch_routines.irp.f similarity index 100% rename from src/cipsi_tc_bi_ortho/pt2_stoch_routines.irp.f rename to plugins/local/cipsi_tc_bi_ortho/pt2_stoch_routines.irp.f diff --git a/src/cipsi_tc_bi_ortho/pt2_type.irp.f b/plugins/local/cipsi_tc_bi_ortho/pt2_type.irp.f similarity index 100% rename from src/cipsi_tc_bi_ortho/pt2_type.irp.f rename to plugins/local/cipsi_tc_bi_ortho/pt2_type.irp.f diff --git a/src/cipsi_tc_bi_ortho/run_pt2_slave.irp.f b/plugins/local/cipsi_tc_bi_ortho/run_pt2_slave.irp.f similarity index 100% rename from src/cipsi_tc_bi_ortho/run_pt2_slave.irp.f rename to plugins/local/cipsi_tc_bi_ortho/run_pt2_slave.irp.f diff --git a/src/cipsi_tc_bi_ortho/run_selection_slave.irp.f b/plugins/local/cipsi_tc_bi_ortho/run_selection_slave.irp.f similarity index 100% rename from src/cipsi_tc_bi_ortho/run_selection_slave.irp.f rename to plugins/local/cipsi_tc_bi_ortho/run_selection_slave.irp.f diff --git a/src/cipsi_tc_bi_ortho/selection.irp.f b/plugins/local/cipsi_tc_bi_ortho/selection.irp.f similarity index 100% rename from src/cipsi_tc_bi_ortho/selection.irp.f rename to plugins/local/cipsi_tc_bi_ortho/selection.irp.f diff --git a/src/cipsi_tc_bi_ortho/selection_buffer.irp.f b/plugins/local/cipsi_tc_bi_ortho/selection_buffer.irp.f similarity index 100% rename from src/cipsi_tc_bi_ortho/selection_buffer.irp.f rename to plugins/local/cipsi_tc_bi_ortho/selection_buffer.irp.f diff --git a/src/cipsi_tc_bi_ortho/selection_types.f90 b/plugins/local/cipsi_tc_bi_ortho/selection_types.f90 similarity index 100% rename from src/cipsi_tc_bi_ortho/selection_types.f90 rename to plugins/local/cipsi_tc_bi_ortho/selection_types.f90 diff --git a/src/cipsi_tc_bi_ortho/selection_weight.irp.f b/plugins/local/cipsi_tc_bi_ortho/selection_weight.irp.f similarity index 100% rename from src/cipsi_tc_bi_ortho/selection_weight.irp.f rename to plugins/local/cipsi_tc_bi_ortho/selection_weight.irp.f diff --git a/src/cipsi_tc_bi_ortho/slave_cipsi.irp.f b/plugins/local/cipsi_tc_bi_ortho/slave_cipsi.irp.f similarity index 100% rename from src/cipsi_tc_bi_ortho/slave_cipsi.irp.f rename to plugins/local/cipsi_tc_bi_ortho/slave_cipsi.irp.f diff --git a/src/cipsi_tc_bi_ortho/stochastic_cipsi.irp.f b/plugins/local/cipsi_tc_bi_ortho/stochastic_cipsi.irp.f similarity index 100% rename from src/cipsi_tc_bi_ortho/stochastic_cipsi.irp.f rename to plugins/local/cipsi_tc_bi_ortho/stochastic_cipsi.irp.f diff --git a/src/cipsi_tc_bi_ortho/write_cipsi_json.irp.f b/plugins/local/cipsi_tc_bi_ortho/write_cipsi_json.irp.f similarity index 100% rename from src/cipsi_tc_bi_ortho/write_cipsi_json.irp.f rename to plugins/local/cipsi_tc_bi_ortho/write_cipsi_json.irp.f diff --git a/src/cipsi_tc_bi_ortho/zmq_selection.irp.f b/plugins/local/cipsi_tc_bi_ortho/zmq_selection.irp.f similarity index 100% rename from src/cipsi_tc_bi_ortho/zmq_selection.irp.f rename to plugins/local/cipsi_tc_bi_ortho/zmq_selection.irp.f diff --git a/src/fci_tc_bi/13.fci_tc_bi_ortho.bats b/plugins/local/fci_tc_bi/13.fci_tc_bi_ortho.bats similarity index 100% rename from src/fci_tc_bi/13.fci_tc_bi_ortho.bats rename to plugins/local/fci_tc_bi/13.fci_tc_bi_ortho.bats diff --git a/src/fci_tc_bi/EZFIO.cfg b/plugins/local/fci_tc_bi/EZFIO.cfg similarity index 100% rename from src/fci_tc_bi/EZFIO.cfg rename to plugins/local/fci_tc_bi/EZFIO.cfg diff --git a/src/fci_tc_bi/NEED b/plugins/local/fci_tc_bi/NEED similarity index 100% rename from src/fci_tc_bi/NEED rename to plugins/local/fci_tc_bi/NEED diff --git a/src/fci_tc_bi/class.irp.f b/plugins/local/fci_tc_bi/class.irp.f similarity index 100% rename from src/fci_tc_bi/class.irp.f rename to plugins/local/fci_tc_bi/class.irp.f diff --git a/src/fci_tc_bi/copy_wf.irp.f b/plugins/local/fci_tc_bi/copy_wf.irp.f similarity index 100% rename from src/fci_tc_bi/copy_wf.irp.f rename to plugins/local/fci_tc_bi/copy_wf.irp.f diff --git a/src/fci_tc_bi/diagonalize_ci.irp.f b/plugins/local/fci_tc_bi/diagonalize_ci.irp.f similarity index 100% rename from src/fci_tc_bi/diagonalize_ci.irp.f rename to plugins/local/fci_tc_bi/diagonalize_ci.irp.f diff --git a/src/fci_tc_bi/fci_tc_bi_ortho.irp.f b/plugins/local/fci_tc_bi/fci_tc_bi_ortho.irp.f similarity index 100% rename from src/fci_tc_bi/fci_tc_bi_ortho.irp.f rename to plugins/local/fci_tc_bi/fci_tc_bi_ortho.irp.f diff --git a/src/fci_tc_bi/generators.irp.f b/plugins/local/fci_tc_bi/generators.irp.f similarity index 100% rename from src/fci_tc_bi/generators.irp.f rename to plugins/local/fci_tc_bi/generators.irp.f diff --git a/src/fci_tc_bi/pt2_tc.irp.f b/plugins/local/fci_tc_bi/pt2_tc.irp.f similarity index 100% rename from src/fci_tc_bi/pt2_tc.irp.f rename to plugins/local/fci_tc_bi/pt2_tc.irp.f diff --git a/src/fci_tc_bi/save_energy.irp.f b/plugins/local/fci_tc_bi/save_energy.irp.f similarity index 100% rename from src/fci_tc_bi/save_energy.irp.f rename to plugins/local/fci_tc_bi/save_energy.irp.f diff --git a/src/fci_tc_bi/scripts_fci_tc/CH2.xyz b/plugins/local/fci_tc_bi/scripts_fci_tc/CH2.xyz similarity index 100% rename from src/fci_tc_bi/scripts_fci_tc/CH2.xyz rename to plugins/local/fci_tc_bi/scripts_fci_tc/CH2.xyz diff --git a/src/fci_tc_bi/scripts_fci_tc/FH.xyz b/plugins/local/fci_tc_bi/scripts_fci_tc/FH.xyz similarity index 100% rename from src/fci_tc_bi/scripts_fci_tc/FH.xyz rename to plugins/local/fci_tc_bi/scripts_fci_tc/FH.xyz diff --git a/src/fci_tc_bi/scripts_fci_tc/extract_tables.sh b/plugins/local/fci_tc_bi/scripts_fci_tc/extract_tables.sh similarity index 100% rename from src/fci_tc_bi/scripts_fci_tc/extract_tables.sh rename to plugins/local/fci_tc_bi/scripts_fci_tc/extract_tables.sh diff --git a/src/fci_tc_bi/scripts_fci_tc/h2o.sh b/plugins/local/fci_tc_bi/scripts_fci_tc/h2o.sh similarity index 92% rename from src/fci_tc_bi/scripts_fci_tc/h2o.sh rename to plugins/local/fci_tc_bi/scripts_fci_tc/h2o.sh index d0afca30..697beeb5 100644 --- a/src/fci_tc_bi/scripts_fci_tc/h2o.sh +++ b/plugins/local/fci_tc_bi/scripts_fci_tc/h2o.sh @@ -23,10 +23,10 @@ cd $StartDir ############################################################################ #### EXAMPLE OF SCRIPT TO RUN A CIPSI CALCULATION ON 5 STATES ON THE Ne^+ CATION -#### USING NATURAL ORBITALS OF A SMALL CIPSI AS MOS +#### USING NATURAL ORBITALS OF A SMALL CIPSI AS MOS #### ALL STATES WILL HAVE THE SAME SPIN SIMETRY : A DOUBLET -####### YOU PUT THE PATH TO YOUR +####### YOU PUT THE PATH TO YOUR QP_ROOT=/home_lct/eginer/programs/qp2 source ${QP_ROOT}/quantum_package.rc ####### YOU LOAD SOME LIBRARIES diff --git a/src/fci_tc_bi/scripts_fci_tc/h2o.xyz b/plugins/local/fci_tc_bi/scripts_fci_tc/h2o.xyz similarity index 100% rename from src/fci_tc_bi/scripts_fci_tc/h2o.xyz rename to plugins/local/fci_tc_bi/scripts_fci_tc/h2o.xyz diff --git a/src/fci_tc_bi/scripts_fci_tc/script.sh b/plugins/local/fci_tc_bi/scripts_fci_tc/script.sh similarity index 100% rename from src/fci_tc_bi/scripts_fci_tc/script.sh rename to plugins/local/fci_tc_bi/scripts_fci_tc/script.sh diff --git a/src/fci_tc_bi/selectors.irp.f b/plugins/local/fci_tc_bi/selectors.irp.f similarity index 100% rename from src/fci_tc_bi/selectors.irp.f rename to plugins/local/fci_tc_bi/selectors.irp.f diff --git a/src/fci_tc_bi/zmq.irp.f b/plugins/local/fci_tc_bi/zmq.irp.f similarity index 100% rename from src/fci_tc_bi/zmq.irp.f rename to plugins/local/fci_tc_bi/zmq.irp.f diff --git a/plugins/local/jastrow/EZFIO.cfg b/plugins/local/jastrow/EZFIO.cfg new file mode 100644 index 00000000..b41185a3 --- /dev/null +++ b/plugins/local/jastrow/EZFIO.cfg @@ -0,0 +1,69 @@ +[jast_type] +doc: Type of Jastrow [None| Mu | Qmckl] +type: character*(32) +interface: ezfio, provider, ocaml +default: None + +[jast_qmckl_type_nucl_num] +doc: Number of different nuclei types in QMCkl jastrow +type: integer +interface: ezfio, provider + +[jast_qmckl_type_nucl_vector] +doc: Nucleus type in QMCkl jastrow +type: integer +size: (nuclei.nucl_num) +interface: ezfio, provider + +[jast_qmckl_rescale_ee] +doc: Rescaling factor for electron-electron in QMCkl Jastrow +type: double precision +interface: ezfio, provider + +[jast_qmckl_rescale_en] +doc: Rescaling factor for electron-nucleus in QMCkl Jastrow +type: double precision +size: (jastrow.jast_qmckl_type_nucl_num) +interface: ezfio, provider + +[jast_qmckl_aord_num] +doc: Order of polynomials in e-n parameters of QMCkl jastrow +type: integer +interface: ezfio, provider + +[jast_qmckl_bord_num] +doc: Order of polynomials in e-e parameters of QMCkl jastrow +type: integer +interface: ezfio, provider + +[jast_qmckl_cord_num] +doc: Order of polynomials in e-e-n parameters of QMCkl jastrow +type: integer +interface: ezfio, provider + +[jast_qmckl_c_vector_size] +doc: Number of parameters for c_vector +type: integer +interface: ezfio, provider + +[jast_qmckl_a_vector] +doc: electron-nucleus parameters in QMCkl Jastrow +type: double precision +size: (jastrow.jast_qmckl_type_nucl_num*jastrow.jast_qmckl_aord_num+jastrow.jast_qmckl_type_nucl_num) +interface: ezfio, provider + +[jast_qmckl_b_vector] +doc: electron-electron parameters in QMCkl Jastrow +type: double precision +size: (jastrow.jast_qmckl_bord_num+1) +interface: ezfio, provider + +[jast_qmckl_c_vector] +doc: electron-electron-nucleus parameters in QMCkl Jastrow +type: double precision +size: (jastrow.jast_qmckl_c_vector_size) +interface: ezfio, provider + + + + diff --git a/plugins/local/jastrow/NEED b/plugins/local/jastrow/NEED new file mode 100644 index 00000000..f03c11fd --- /dev/null +++ b/plugins/local/jastrow/NEED @@ -0,0 +1,2 @@ +nuclei +electrons diff --git a/plugins/local/jastrow/README.md b/plugins/local/jastrow/README.md new file mode 100644 index 00000000..aefb6ad5 --- /dev/null +++ b/plugins/local/jastrow/README.md @@ -0,0 +1,3 @@ +# Jastrow + +Information relative to the Jastrow factor in trans-correlated calculations. diff --git a/src/mo_localization/84.mo_localization.bats b/plugins/local/mo_localization/84.mo_localization.bats similarity index 100% rename from src/mo_localization/84.mo_localization.bats rename to plugins/local/mo_localization/84.mo_localization.bats diff --git a/src/mo_localization/EZFIO.cfg b/plugins/local/mo_localization/EZFIO.cfg similarity index 100% rename from src/mo_localization/EZFIO.cfg rename to plugins/local/mo_localization/EZFIO.cfg diff --git a/src/mo_localization/NEED b/plugins/local/mo_localization/NEED similarity index 100% rename from src/mo_localization/NEED rename to plugins/local/mo_localization/NEED diff --git a/src/mo_localization/README.md b/plugins/local/mo_localization/README.md similarity index 100% rename from src/mo_localization/README.md rename to plugins/local/mo_localization/README.md diff --git a/src/mo_localization/break_spatial_sym.irp.f b/plugins/local/mo_localization/break_spatial_sym.irp.f similarity index 100% rename from src/mo_localization/break_spatial_sym.irp.f rename to plugins/local/mo_localization/break_spatial_sym.irp.f diff --git a/src/mo_localization/debug_gradient_loc.irp.f b/plugins/local/mo_localization/debug_gradient_loc.irp.f similarity index 100% rename from src/mo_localization/debug_gradient_loc.irp.f rename to plugins/local/mo_localization/debug_gradient_loc.irp.f diff --git a/src/mo_localization/debug_hessian_loc.irp.f b/plugins/local/mo_localization/debug_hessian_loc.irp.f similarity index 100% rename from src/mo_localization/debug_hessian_loc.irp.f rename to plugins/local/mo_localization/debug_hessian_loc.irp.f diff --git a/src/mo_localization/kick_the_mos.irp.f b/plugins/local/mo_localization/kick_the_mos.irp.f similarity index 100% rename from src/mo_localization/kick_the_mos.irp.f rename to plugins/local/mo_localization/kick_the_mos.irp.f diff --git a/src/mo_localization/localization.irp.f b/plugins/local/mo_localization/localization.irp.f similarity index 100% rename from src/mo_localization/localization.irp.f rename to plugins/local/mo_localization/localization.irp.f diff --git a/src/mo_localization/localization_sub.irp.f b/plugins/local/mo_localization/localization_sub.irp.f similarity index 100% rename from src/mo_localization/localization_sub.irp.f rename to plugins/local/mo_localization/localization_sub.irp.f diff --git a/src/mo_localization/org/TANGLE_org_mode.sh b/plugins/local/mo_localization/org/TANGLE_org_mode.sh similarity index 100% rename from src/mo_localization/org/TANGLE_org_mode.sh rename to plugins/local/mo_localization/org/TANGLE_org_mode.sh diff --git a/src/mo_localization/org/break_spatial_sym.org b/plugins/local/mo_localization/org/break_spatial_sym.org similarity index 100% rename from src/mo_localization/org/break_spatial_sym.org rename to plugins/local/mo_localization/org/break_spatial_sym.org diff --git a/src/mo_localization/org/debug_gradient_loc.org b/plugins/local/mo_localization/org/debug_gradient_loc.org similarity index 100% rename from src/mo_localization/org/debug_gradient_loc.org rename to plugins/local/mo_localization/org/debug_gradient_loc.org diff --git a/src/mo_localization/org/debug_hessian_loc.org b/plugins/local/mo_localization/org/debug_hessian_loc.org similarity index 100% rename from src/mo_localization/org/debug_hessian_loc.org rename to plugins/local/mo_localization/org/debug_hessian_loc.org diff --git a/src/mo_localization/org/kick_the_mos.org b/plugins/local/mo_localization/org/kick_the_mos.org similarity index 100% rename from src/mo_localization/org/kick_the_mos.org rename to plugins/local/mo_localization/org/kick_the_mos.org diff --git a/src/mo_localization/org/localization.org b/plugins/local/mo_localization/org/localization.org similarity index 100% rename from src/mo_localization/org/localization.org rename to plugins/local/mo_localization/org/localization.org diff --git a/src/non_h_ints_mu/NEED b/plugins/local/non_h_ints_mu/NEED similarity index 65% rename from src/non_h_ints_mu/NEED rename to plugins/local/non_h_ints_mu/NEED index d09ab4a5..c44c65af 100644 --- a/src/non_h_ints_mu/NEED +++ b/plugins/local/non_h_ints_mu/NEED @@ -1,2 +1,4 @@ +qmckl +jastrow ao_tc_eff_map bi_ortho_mos diff --git a/src/non_h_ints_mu/README.rst b/plugins/local/non_h_ints_mu/README.rst similarity index 100% rename from src/non_h_ints_mu/README.rst rename to plugins/local/non_h_ints_mu/README.rst diff --git a/src/non_h_ints_mu/debug_fit.irp.f b/plugins/local/non_h_ints_mu/debug_fit.irp.f similarity index 85% rename from src/non_h_ints_mu/debug_fit.irp.f rename to plugins/local/non_h_ints_mu/debug_fit.irp.f index 05d2db68..d3152836 100644 --- a/src/non_h_ints_mu/debug_fit.irp.f +++ b/plugins/local/non_h_ints_mu/debug_fit.irp.f @@ -13,17 +13,27 @@ program debug_fit PROVIDE mu_erf j1b_pen + if(j1b_type .ge. 100) then + my_extra_grid_becke = .True. + PROVIDE tc_grid2_a tc_grid2_r + my_n_pt_r_extra_grid = tc_grid2_r + my_n_pt_a_extra_grid = tc_grid2_a + touch my_extra_grid_becke my_n_pt_r_extra_grid my_n_pt_a_extra_grid + endif + !call test_j1b_nucl() !call test_grad_j1b_nucl() !call test_lapl_j1b_nucl() !call test_list_b2() - call test_list_b3() + !call test_list_b3() !call test_fit_u() !call test_fit_u2() !call test_fit_ugradu() + call test_grad1_u12_withsq_num() + end ! --- @@ -643,4 +653,69 @@ end subroutine test_fit_u2 ! --- +subroutine test_grad1_u12_withsq_num() + + implicit none + integer :: ipoint, jpoint, m + double precision :: acc_ij, acc_tot, eps_ij, i_exc, i_num, normalz + double precision, allocatable :: tmp_grad1_u12_squared(:,:), tmp_grad1_u12(:,:,:) + + print*, ' test_grad1_u12_withsq_num ...' + + PROVIDE grad1_u12_num grad1_u12_squared_num + + allocate(tmp_grad1_u12_squared(n_points_extra_final_grid,n_points_final_grid)) + allocate(tmp_grad1_u12(n_points_extra_final_grid,n_points_final_grid,3)) + + eps_ij = 1d-7 + acc_tot = 0.d0 + normalz = 0.d0 + + do ipoint = 1, n_points_final_grid + + call get_grad1_u12_withsq_r1_seq(final_grid_points(1,ipoint), n_points_extra_final_grid, tmp_grad1_u12(1,ipoint,1) & + , tmp_grad1_u12(1,ipoint,2) & + , tmp_grad1_u12(1,ipoint,3) & + , tmp_grad1_u12_squared(1,ipoint)) + do jpoint = 1, n_points_extra_final_grid + + i_exc = grad1_u12_squared_num(jpoint,ipoint) + i_num = tmp_grad1_u12_squared(jpoint,ipoint) + acc_ij = dabs(i_exc - i_num) + if(acc_ij .gt. eps_ij) then + print *, ' problem in grad1_u12_squared_num on', ipoint, jpoint + print *, ' analyt = ', i_exc + print *, ' numeri = ', i_num + print *, ' diff = ', acc_ij + stop + endif + acc_tot += acc_ij + normalz += dabs(i_num) + + do m = 1, 3 + i_exc = grad1_u12_num(jpoint,ipoint,m) + i_num = tmp_grad1_u12(jpoint,ipoint,m) + acc_ij = dabs(i_exc - i_num) + if(acc_ij .gt. eps_ij) then + print *, ' problem in grad1_u12_num on', ipoint, jpoint, m + print *, ' analyt = ', i_exc + print *, ' numeri = ', i_num + print *, ' diff = ', acc_ij + stop + endif + acc_tot += acc_ij + normalz += dabs(i_num) + enddo + enddo + enddo + + !print*, ' acc_tot = ', acc_tot + !print*, ' normalz = ', normalz + print*, ' accuracy (%) = ', 100.d0 * acc_tot / normalz + + return +end subroutine test_grad1_u12_withsq_num + +! --- + diff --git a/src/non_h_ints_mu/debug_integ_jmu_modif.irp.f b/plugins/local/non_h_ints_mu/debug_integ_jmu_modif.irp.f similarity index 100% rename from src/non_h_ints_mu/debug_integ_jmu_modif.irp.f rename to plugins/local/non_h_ints_mu/debug_integ_jmu_modif.irp.f diff --git a/src/non_h_ints_mu/grad_squared.irp.f b/plugins/local/non_h_ints_mu/grad_squared.irp.f similarity index 96% rename from src/non_h_ints_mu/grad_squared.irp.f rename to plugins/local/non_h_ints_mu/grad_squared.irp.f index 44a6ae65..8c6d35dc 100644 --- a/src/non_h_ints_mu/grad_squared.irp.f +++ b/plugins/local/non_h_ints_mu/grad_squared.irp.f @@ -425,7 +425,6 @@ BEGIN_PROVIDER [double precision, tc_grad_square_ao, (ao_num, ao_num, ao_num, ao ! an additional term is added here directly instead of ! being added in int2_grad1_u12_square_ao for performance - ! note that the factor PROVIDE int2_u2_j1b2 @@ -465,25 +464,8 @@ BEGIN_PROVIDER [double precision, tc_grad_square_ao, (ao_num, ao_num, ao_num, ao ! --- deallocate(b_mat) - call sum_A_At(tc_grad_square_ao(1,1,1,1), ao_num*ao_num) - !!$OMP PARALLEL & - !!$OMP DEFAULT (NONE) & - !!$OMP PRIVATE (i, j, k, l) & - !!$OMP SHARED (ac_mat, tc_grad_square_ao, ao_num) - !!$OMP DO SCHEDULE (static) - ! do j = 1, ao_num - ! do l = 1, ao_num - ! do i = 1, ao_num - ! do k = 1, ao_num - ! tc_grad_square_ao(k,i,l,j) = ac_mat(k,i,l,j) + ac_mat(l,j,k,i) - ! enddo - ! enddo - ! enddo - ! enddo - !!$OMP END DO - !!$OMP END PARALLEL endif if(write_tc_integ.and.mpi_master) then diff --git a/src/non_h_ints_mu/grad_squared_manu.irp.f b/plugins/local/non_h_ints_mu/grad_squared_manu.irp.f similarity index 81% rename from src/non_h_ints_mu/grad_squared_manu.irp.f rename to plugins/local/non_h_ints_mu/grad_squared_manu.irp.f index 66f3c693..dcfeff47 100644 --- a/src/non_h_ints_mu/grad_squared_manu.irp.f +++ b/plugins/local/non_h_ints_mu/grad_squared_manu.irp.f @@ -67,72 +67,6 @@ BEGIN_PROVIDER [double precision, tc_grad_square_ao_test, (ao_num, ao_num, ao_nu deallocate(tmp, b_mat) call sum_A_At(tc_grad_square_ao_test(1,1,1,1), ao_num*ao_num) - !do i = 1, ao_num - ! do j = 1, ao_num - ! do k = i, ao_num - - ! do l = max(j,k), ao_num - ! tc_grad_square_ao_test(i,j,k,l) = 0.5d0 * (tc_grad_square_ao_test(i,j,k,l) + tc_grad_square_ao_test(k,l,i,j)) - ! tc_grad_square_ao_test(k,l,i,j) = tc_grad_square_ao_test(i,j,k,l) - ! end do - - ! !if (j.eq.k) then - ! ! do l = j+1, ao_num - ! ! tc_grad_square_ao_test(i,j,k,l) = 0.5d0 * (tc_grad_square_ao_test(i,j,k,l) + tc_grad_square_ao_test(k,l,i,j)) - ! ! tc_grad_square_ao_test(k,l,i,j) = tc_grad_square_ao_test(i,j,k,l) - ! ! end do - ! !else - ! ! do l = j, ao_num - ! ! tc_grad_square_ao_test(i,j,k,l) = 0.5d0 * (tc_grad_square_ao_test(i,j,k,l) + tc_grad_square_ao_test(k,l,i,j)) - ! ! tc_grad_square_ao_test(k,l,i,j) = tc_grad_square_ao_test(i,j,k,l) - ! ! enddo - ! !endif - - ! enddo - ! enddo - !enddo - !tc_grad_square_ao_test = 2.d0 * tc_grad_square_ao_test - ! !$OMP PARALLEL & - ! !$OMP DEFAULT (NONE) & - ! !$OMP PRIVATE (i, j, k, l) & - ! !$OMP SHARED (tc_grad_square_ao_test, ao_num) - ! !$OMP DO SCHEDULE (static) - ! integer :: ii - ! ii = 0 - ! do j = 1, ao_num - ! do l = 1, ao_num - ! do i = 1, ao_num - ! do k = 1, ao_num - ! if((i.lt.j) .and. (k.lt.l)) cycle - ! ii = ii + 1 - ! tc_grad_square_ao_test(k,i,l,j) = tc_grad_square_ao_test(k,i,l,j) + tc_grad_square_ao_test(l,j,k,i) - ! enddo - ! enddo - ! enddo - ! enddo - ! print *, ' ii =', ii - ! !$OMP END DO - ! !$OMP END PARALLEL - - ! !$OMP PARALLEL & - ! !$OMP DEFAULT (NONE) & - ! !$OMP PRIVATE (i, j, k, l) & - ! !$OMP SHARED (tc_grad_square_ao_test, ao_num) - ! !$OMP DO SCHEDULE (static) - ! do j = 1, ao_num - ! do l = 1, ao_num - ! do i = 1, j-1 - ! do k = 1, l-1 - ! ii = ii + 1 - ! tc_grad_square_ao_test(k,i,l,j) = tc_grad_square_ao_test(l,j,k,i) - ! enddo - ! enddo - ! enddo - ! enddo - ! print *, ' ii =', ii - ! print *, ao_num * ao_num * ao_num * ao_num - ! !$OMP END DO - ! !$OMP END PARALLEL endif diff --git a/src/non_h_ints_mu/grad_tc_int.irp.f b/plugins/local/non_h_ints_mu/grad_tc_int.irp.f similarity index 100% rename from src/non_h_ints_mu/grad_tc_int.irp.f rename to plugins/local/non_h_ints_mu/grad_tc_int.irp.f diff --git a/src/non_h_ints_mu/j12_nucl_utils.irp.f b/plugins/local/non_h_ints_mu/j12_nucl_utils.irp.f similarity index 100% rename from src/non_h_ints_mu/j12_nucl_utils.irp.f rename to plugins/local/non_h_ints_mu/j12_nucl_utils.irp.f diff --git a/plugins/local/non_h_ints_mu/jast_deriv.irp.f b/plugins/local/non_h_ints_mu/jast_deriv.irp.f new file mode 100644 index 00000000..19b900da --- /dev/null +++ b/plugins/local/non_h_ints_mu/jast_deriv.irp.f @@ -0,0 +1,241 @@ + +! --- + + BEGIN_PROVIDER [ double precision, grad1_u12_num, (n_points_extra_final_grid, n_points_final_grid, 3)] +&BEGIN_PROVIDER [ double precision, grad1_u12_squared_num, (n_points_extra_final_grid, n_points_final_grid)] + + BEGIN_DOC + ! + ! grad_1 u(r1,r2) + ! + ! this will be integrated numerically over r2: + ! we use grid for r1 and extra_grid for r2 + ! + ! for 99 < j1b_type < 199 + ! + ! u(r1,r2) = j12_mu(r12) x v(r1) x v(r2) + ! grad1 u(r1, r2) = [(grad1 j12_mu) v(r1) + j12_mu grad1 v(r1)] v(r2) + ! + END_DOC + + implicit none + integer :: ipoint, jpoint + double precision :: r1(3), r2(3) + double precision :: v1b_r1, v1b_r2, u2b_r12 + double precision :: grad1_v1b(3), grad1_u2b(3) + double precision :: dx, dy, dz + double precision :: time0, time1 + double precision, external :: j12_mu, j1b_nucl + + PROVIDE j1b_type + PROVIDE final_grid_points_extra + + print*, ' providing grad1_u12_num & grad1_u12_squared_num ...' + call wall_time(time0) + + grad1_u12_num = 0.d0 + grad1_u12_squared_num = 0.d0 + + if( (j1b_type .eq. 100) .or. & + (j1b_type .ge. 200) .and. (j1b_type .lt. 300) ) then + + !$OMP PARALLEL & + !$OMP DEFAULT (NONE) & + !$OMP PRIVATE (ipoint, jpoint, r1, r2, v1b_r1, v1b_r2, u2b_r12, grad1_v1b, grad1_u2b, dx, dy, dz) & + !$OMP SHARED (n_points_final_grid, n_points_extra_final_grid, final_grid_points, & + !$OMP final_grid_points_extra, grad1_u12_num, grad1_u12_squared_num) + !$OMP DO SCHEDULE (static) + do ipoint = 1, n_points_final_grid ! r1 + + r1(1) = final_grid_points(1,ipoint) + r1(2) = final_grid_points(2,ipoint) + r1(3) = final_grid_points(3,ipoint) + + do jpoint = 1, n_points_extra_final_grid ! r2 + + r2(1) = final_grid_points_extra(1,jpoint) + r2(2) = final_grid_points_extra(2,jpoint) + r2(3) = final_grid_points_extra(3,jpoint) + + call grad1_j12_mu(r1, r2, grad1_u2b) + + dx = grad1_u2b(1) + dy = grad1_u2b(2) + dz = grad1_u2b(3) + + grad1_u12_num(jpoint,ipoint,1) = dx + grad1_u12_num(jpoint,ipoint,2) = dy + grad1_u12_num(jpoint,ipoint,3) = dz + + grad1_u12_squared_num(jpoint,ipoint) = dx*dx + dy*dy + dz*dz + enddo + enddo + !$OMP END DO + !$OMP END PARALLEL + + elseif((j1b_type .gt. 100) .and. (j1b_type .lt. 200)) then + + PROVIDE final_grid_points + + !$OMP PARALLEL & + !$OMP DEFAULT (NONE) & + !$OMP PRIVATE (ipoint, jpoint, r1, r2, v1b_r1, v1b_r2, u2b_r12, grad1_v1b, grad1_u2b, dx, dy, dz) & + !$OMP SHARED (n_points_final_grid, n_points_extra_final_grid, final_grid_points, & + !$OMP final_grid_points_extra, grad1_u12_num, grad1_u12_squared_num) + !$OMP DO SCHEDULE (static) + do ipoint = 1, n_points_final_grid ! r1 + + r1(1) = final_grid_points(1,ipoint) + r1(2) = final_grid_points(2,ipoint) + r1(3) = final_grid_points(3,ipoint) + + v1b_r1 = j1b_nucl(r1) + call grad1_j1b_nucl(r1, grad1_v1b) + + do jpoint = 1, n_points_extra_final_grid ! r2 + + r2(1) = final_grid_points_extra(1,jpoint) + r2(2) = final_grid_points_extra(2,jpoint) + r2(3) = final_grid_points_extra(3,jpoint) + + v1b_r2 = j1b_nucl(r2) + u2b_r12 = j12_mu(r1, r2) + call grad1_j12_mu(r1, r2, grad1_u2b) + + dx = (grad1_u2b(1) * v1b_r1 + u2b_r12 * grad1_v1b(1)) * v1b_r2 + dy = (grad1_u2b(2) * v1b_r1 + u2b_r12 * grad1_v1b(2)) * v1b_r2 + dz = (grad1_u2b(3) * v1b_r1 + u2b_r12 * grad1_v1b(3)) * v1b_r2 + + grad1_u12_num(jpoint,ipoint,1) = dx + grad1_u12_num(jpoint,ipoint,2) = dy + grad1_u12_num(jpoint,ipoint,3) = dz + + grad1_u12_squared_num(jpoint,ipoint) = dx*dx + dy*dy + dz*dz + enddo + enddo + !$OMP END DO + !$OMP END PARALLEL + + elseif (j1b_type .eq. 1000) then + + double precision :: f + f = 1.d0 / dble(elec_num - 1) + + integer*8 :: n_points, n_points_max, k + integer :: ipoint_block, ipoint_end + + n_points_max = n_points_extra_final_grid * n_points_final_grid + n_points = 100_8*n_points_extra_final_grid + + double precision, allocatable :: rij(:,:,:) + allocate( rij(3, 2, n_points) ) + + use qmckl + integer(qmckl_exit_code) :: rc + + double precision, allocatable :: gl(:,:,:) + + allocate( gl(2,4,n_points) ) + + do ipoint_block = 1, n_points_final_grid, 100 ! r1 + ipoint_end = min(n_points_final_grid, ipoint_block+99) + + k=0 + do ipoint = ipoint_block, ipoint_end + do jpoint = 1, n_points_extra_final_grid ! r2 + k=k+1 + rij(1:3, 1, k) = final_grid_points (1:3, ipoint) + rij(1:3, 2, k) = final_grid_points_extra(1:3, jpoint) + end do + enddo + + rc = qmckl_set_electron_coord(qmckl_ctx_jastrow, 'N', n_points, rij, n_points*6_8) + if (rc /= QMCKL_SUCCESS) then + print *, irp_here, 'qmckl error in set_electron_coord' + rc = qmckl_check(qmckl_ctx_jastrow, rc) + stop -1 + endif + + ! --- + ! e-e term + + rc = qmckl_get_jastrow_champ_factor_ee_gl(qmckl_ctx_jastrow, gl, 8_8*n_points) + if (rc /= QMCKL_SUCCESS) then + print *, irp_here, ' qmckl error in fact_ee_gl' + rc = qmckl_check(qmckl_ctx_jastrow, rc) + stop -1 + endif + + k=0 + do ipoint = ipoint_block, ipoint_end + do jpoint = 1, n_points_extra_final_grid ! r2 + k=k+1 + grad1_u12_num(jpoint,ipoint,1) = gl(1,1,k) + grad1_u12_num(jpoint,ipoint,2) = gl(1,2,k) + grad1_u12_num(jpoint,ipoint,3) = gl(1,3,k) + enddo + enddo + + ! --- + ! e-e-n term + +! rc = qmckl_get_jastrow_champ_factor_een_gl(qmckl_ctx_jastrow, gl, 8_8*n_points) +! if (rc /= QMCKL_SUCCESS) then +! print *, irp_here, 'qmckl error in fact_een_gl' +! rc = qmckl_check(qmckl_ctx_jastrow, rc) +! stop -1 +! endif +! +! k=0 +! do ipoint = 1, n_points_final_grid ! r1 +! do jpoint = 1, n_points_extra_final_grid ! r2 +! k=k+1 +! grad1_u12_num(jpoint,ipoint,1) = grad1_u12_num(jpoint,ipoint,1) + gl(1,1,k) +! grad1_u12_num(jpoint,ipoint,2) = grad1_u12_num(jpoint,ipoint,2) + gl(1,2,k) +! grad1_u12_num(jpoint,ipoint,3) = grad1_u12_num(jpoint,ipoint,3) + gl(1,3,k) +! enddo +! enddo + + ! --- + ! e-n term + + rc = qmckl_get_jastrow_champ_factor_en_gl(qmckl_ctx_jastrow, gl, 8_8*n_points) + if (rc /= QMCKL_SUCCESS) then + print *, irp_here, 'qmckl error in fact_en_gl' + rc = qmckl_check(qmckl_ctx_jastrow, rc) + stop -1 + endif + + k=0 + do ipoint = ipoint_block, ipoint_end ! r1 + do jpoint = 1, n_points_extra_final_grid ! r2 + k = k+1 + grad1_u12_num(jpoint,ipoint,1) = grad1_u12_num(jpoint,ipoint,1) + f * gl(1,1,k) + grad1_u12_num(jpoint,ipoint,2) = grad1_u12_num(jpoint,ipoint,2) + f * gl(1,2,k) + grad1_u12_num(jpoint,ipoint,3) = grad1_u12_num(jpoint,ipoint,3) + f * gl(1,3,k) + + dx = grad1_u12_num(jpoint,ipoint,1) + dy = grad1_u12_num(jpoint,ipoint,2) + dz = grad1_u12_num(jpoint,ipoint,3) + grad1_u12_squared_num(jpoint,ipoint) = dx*dx + dy*dy + dz*dz + enddo + enddo + + enddo !ipoint_block + + deallocate(gl, rij) + + else + + print *, ' j1b_type = ', j1b_type, 'not implemented yet' + stop + + endif + + call wall_time(time1) + print*, ' Wall time for grad1_u12_num & grad1_u12_squared_num (min) =', (time1-time0)/60.d0 + +END_PROVIDER + +! --- + diff --git a/src/non_h_ints_mu/jast_deriv.irp.f b/plugins/local/non_h_ints_mu/jast_deriv_utils.irp.f similarity index 75% rename from src/non_h_ints_mu/jast_deriv.irp.f rename to plugins/local/non_h_ints_mu/jast_deriv_utils.irp.f index 859f2aa5..745d00ad 100644 --- a/src/non_h_ints_mu/jast_deriv.irp.f +++ b/plugins/local/non_h_ints_mu/jast_deriv_utils.irp.f @@ -1,161 +1,4 @@ -! --- - - BEGIN_PROVIDER [ double precision, grad1_u12_num, (n_points_extra_final_grid, n_points_final_grid, 3)] -&BEGIN_PROVIDER [ double precision, grad1_u12_squared_num, (n_points_extra_final_grid, n_points_final_grid)] - - BEGIN_DOC - ! - ! grad_1 u(r1,r2) - ! - ! this will be integrated numerically over r2: - ! we use grid for r1 and extra_grid for r2 - ! - ! for 99 < j1b_type < 199 - ! - ! u(r1,r2) = j12_mu(r12) x v(r1) x v(r2) - ! grad1 u(r1, r2) = [(grad1 j12_mu) v(r1) + j12_mu grad1 v(r1)] v(r2) - ! - END_DOC - - implicit none - integer :: ipoint, jpoint - double precision :: r1(3), r2(3) - double precision :: v1b_r1, v1b_r2, u2b_r12 - double precision :: grad1_v1b(3), grad1_u2b(3) - double precision :: dx, dy, dz - double precision, external :: j12_mu, j1b_nucl - - PROVIDE j1b_type - PROVIDE final_grid_points_extra - - grad1_u12_num = 0.d0 - grad1_u12_squared_num = 0.d0 - - if(j1b_type .eq. 100) then - - !$OMP PARALLEL & - !$OMP DEFAULT (NONE) & - !$OMP PRIVATE (ipoint, jpoint, r1, r2, v1b_r1, v1b_r2, u2b_r12, grad1_v1b, grad1_u2b, dx, dy, dz) & - !$OMP SHARED (n_points_final_grid, n_points_extra_final_grid, final_grid_points, & - !$OMP final_grid_points_extra, grad1_u12_num, grad1_u12_squared_num) - !$OMP DO SCHEDULE (static) - do ipoint = 1, n_points_final_grid ! r1 - - r1(1) = final_grid_points(1,ipoint) - r1(2) = final_grid_points(2,ipoint) - r1(3) = final_grid_points(3,ipoint) - - do jpoint = 1, n_points_extra_final_grid ! r2 - - r2(1) = final_grid_points_extra(1,jpoint) - r2(2) = final_grid_points_extra(2,jpoint) - r2(3) = final_grid_points_extra(3,jpoint) - - call grad1_j12_mu(r1, r2, grad1_u2b) - - dx = grad1_u2b(1) - dy = grad1_u2b(2) - dz = grad1_u2b(3) - - grad1_u12_num(jpoint,ipoint,1) = dx - grad1_u12_num(jpoint,ipoint,2) = dy - grad1_u12_num(jpoint,ipoint,3) = dz - - grad1_u12_squared_num(jpoint,ipoint) = dx*dx + dy*dy + dz*dz - enddo - enddo - !$OMP END DO - !$OMP END PARALLEL - - elseif((j1b_type .gt. 100) .and. (j1b_type .lt. 200)) then - - PROVIDE final_grid_points - - !$OMP PARALLEL & - !$OMP DEFAULT (NONE) & - !$OMP PRIVATE (ipoint, jpoint, r1, r2, v1b_r1, v1b_r2, u2b_r12, grad1_v1b, grad1_u2b, dx, dy, dz) & - !$OMP SHARED (n_points_final_grid, n_points_extra_final_grid, final_grid_points, & - !$OMP final_grid_points_extra, grad1_u12_num, grad1_u12_squared_num) - !$OMP DO SCHEDULE (static) - do ipoint = 1, n_points_final_grid ! r1 - - r1(1) = final_grid_points(1,ipoint) - r1(2) = final_grid_points(2,ipoint) - r1(3) = final_grid_points(3,ipoint) - - v1b_r1 = j1b_nucl(r1) - call grad1_j1b_nucl(r1, grad1_v1b) - - do jpoint = 1, n_points_extra_final_grid ! r2 - - r2(1) = final_grid_points_extra(1,jpoint) - r2(2) = final_grid_points_extra(2,jpoint) - r2(3) = final_grid_points_extra(3,jpoint) - - v1b_r2 = j1b_nucl(r2) - u2b_r12 = j12_mu(r1, r2) - call grad1_j12_mu(r1, r2, grad1_u2b) - - dx = (grad1_u2b(1) * v1b_r1 + u2b_r12 * grad1_v1b(1)) * v1b_r2 - dy = (grad1_u2b(2) * v1b_r1 + u2b_r12 * grad1_v1b(2)) * v1b_r2 - dz = (grad1_u2b(3) * v1b_r1 + u2b_r12 * grad1_v1b(3)) * v1b_r2 - - grad1_u12_num(jpoint,ipoint,1) = dx - grad1_u12_num(jpoint,ipoint,2) = dy - grad1_u12_num(jpoint,ipoint,3) = dz - - grad1_u12_squared_num(jpoint,ipoint) = dx*dx + dy*dy + dz*dz - enddo - enddo - !$OMP END DO - !$OMP END PARALLEL - - elseif((j1b_type .ge. 200) .and. (j1b_type .lt. 300)) then - - !$OMP PARALLEL & - !$OMP DEFAULT (NONE) & - !$OMP PRIVATE (ipoint, jpoint, r1, r2, grad1_u2b, dx, dy, dz) & - !$OMP SHARED (n_points_final_grid, n_points_extra_final_grid, final_grid_points, & - !$OMP final_grid_points_extra, grad1_u12_num, grad1_u12_squared_num) - !$OMP DO SCHEDULE (static) - do ipoint = 1, n_points_final_grid ! r1 - - r1(1) = final_grid_points(1,ipoint) - r1(2) = final_grid_points(2,ipoint) - r1(3) = final_grid_points(3,ipoint) - - do jpoint = 1, n_points_extra_final_grid ! r2 - - r2(1) = final_grid_points_extra(1,jpoint) - r2(2) = final_grid_points_extra(2,jpoint) - r2(3) = final_grid_points_extra(3,jpoint) - - call grad1_j12_mu(r1, r2, grad1_u2b) - - dx = grad1_u2b(1) - dy = grad1_u2b(2) - dz = grad1_u2b(3) - - grad1_u12_num(jpoint,ipoint,1) = dx - grad1_u12_num(jpoint,ipoint,2) = dy - grad1_u12_num(jpoint,ipoint,3) = dz - - grad1_u12_squared_num(jpoint,ipoint) = dx*dx + dy*dy + dz*dz - enddo - enddo - !$OMP END DO - !$OMP END PARALLEL - - else - - print *, ' j1b_type = ', j1b_type, 'not implemented yet' - stop - - endif - -END_PROVIDER - ! --- double precision function j12_mu(r1, r2) @@ -190,18 +33,20 @@ end function j12_mu subroutine grad1_j12_mu(r1, r2, grad) BEGIN_DOC -! gradient of j(mu(r1,r2),r12) form of jastrow. -! -! if mu(r1,r2) = cst ---> j1b_type < 200 and -! -! d/dx1 j(mu,r12) = 0.5 * (1 - erf(mu *r12))/r12 * (x1 - x2) -! -! if mu(r1,r2) /= cst ---> 200 < j1b_type < 300 and -! -! d/dx1 j(mu(r1,r2),r12) = exp(-(mu(r1,r2)*r12)**2) /(2 *sqrt(pi) * mu(r1,r2)**2 ) d/dx1 mu(r1,r2) -! -! + 0.5 * (1 - erf(mu(r1,r2) *r12))/r12 * (x1 - x2) + ! + ! gradient of j(mu(r1,r2),r12) form of jastrow. + ! + ! if mu(r1,r2) = cst ---> j1b_type < 200 and + ! + ! d/dx1 j(mu,r12) = 0.5 * (1 - erf(mu *r12))/r12 * (x1 - x2) + ! + ! if mu(r1,r2) /= cst ---> 200 < j1b_type < 300 and + ! + ! d/dx1 j(mu(r1,r2),r12) = exp(-(mu(r1,r2)*r12)**2) /(2 *sqrt(pi) * mu(r1,r2)**2 ) d/dx1 mu(r1,r2) + ! + 0.5 * (1 - erf(mu(r1,r2) *r12))/r12 * (x1 - x2) + ! END_DOC + include 'constants.include.F' implicit none @@ -254,6 +99,7 @@ subroutine grad1_j12_mu(r1, r2, grad) stop endif + grad = -grad return end subroutine grad1_j12_mu @@ -641,6 +487,13 @@ subroutine mu_r_val_and_grad(r1, r2, mu_val, mu_der) !!!!!!!!! rho1,rho2,rho1+rho2 call get_all_rho_grad_rho(r1,r2,rho1,rho2,grad_rho1) rho_tot = rho1 + rho2 +! if(rho_tot.lt.1.d-10)rho_tot = 1.d-10 + if(rho_tot.lt.1.d-10)then + mu_val = mu_erf + mu_der = 0.d0 + return + endif + if(rho_tot.lt.1.d-10)rho_tot = 1.d-10 inv_rho_tot = 1.d0/rho_tot ! f(rho) = mu_r_ct * rho**beta_rho_power + mu_erf @@ -661,18 +514,26 @@ subroutine mu_r_val_and_grad(r1, r2, mu_val, mu_der) ! d/dx1 f[rho(r1)] = [0.5 alpha / sqrt(rho(r1)) ] (d rho(r1) / dx1) ! ! d/dx1 (rho(r1) f[rho(r1)] = rho(r1) * d/dx1 f[rho(r1)] + f[rho(r1)] * d/dx1 rho(r1) - !!!!!!!!! rho1,rho2,rho1+rho2 call get_all_rho_grad_rho(r1,r2,rho1,rho2,grad_rho1) rho_tot = rho1 + rho2 +! if(rho_tot.lt.1.d-10)rho_tot = 1.d-10 + if(rho_tot.lt.1.d-10)then + mu_val = mu_erf + mu_der = 0.d0 + return + endif + if(rho_tot.lt.1.d-10)rho_tot = 1.d-10 inv_rho_tot = 1.d0/rho_tot - ! f(rho) = mu_r_ct * rho**beta_rho_power + mu_erf - call get_all_f_rho_simple(rho1,rho2,mu_r_ct,mu_erf,beta_rho_power,f_rho1,d_drho_f_rho1,f_rho2) + ! f(rho) = (mu_r_ct* rho)**beta_rho_power * erf(zeta_erf_mu_of_r * rho) + mu_eff * (1 - erf(zeta_erf_mu_of_r*rho)) + call get_all_f_rho_erf(rho1,rho2,mu_r_ct,beta_rho_power,mu_erf,zeta_erf_mu_of_r,f_rho1,d_drho_f_rho1,f_rho2) d_dx1_f_rho1(1:3) = d_drho_f_rho1 * grad_rho1(1:3) d_dx_rho_f_rho(1:3) = rho1 * d_dx1_f_rho1(1:3) + f_rho1 * grad_rho1(1:3) - mu_val = 0.5d0 * ( f_rho1 + f_rho2) - mu_der(1:3) = d_dx_rho_f_rho(1:3) + nume = rho1 * f_rho1 + rho2 * f_rho2 + mu_val = nume * inv_rho_tot + mu_der(1:3) = inv_rho_tot*inv_rho_tot * (rho_tot * d_dx_rho_f_rho(1:3) - grad_rho1(1:3) * nume) + else print *, ' j1b_type = ', j1b_type, 'not implemented yet' stop @@ -831,8 +692,17 @@ subroutine get_all_f_rho_simple(rho1,rho2,alpha,mu0,beta,f_rho1,d_drho_f_rho1,f_ double precision, intent(in) :: rho1,rho2,alpha,mu0,beta double precision, intent(out):: f_rho1,d_drho_f_rho1,f_rho2 double precision :: tmp - call f_mu_and_deriv_mu_simple(rho1,alpha,mu0,beta,f_rho1,d_drho_f_rho1) - call f_mu_and_deriv_mu_simple(rho2,alpha,mu0,beta,f_rho2,tmp) + if(rho1.lt.1.d-10)then + f_rho1 = 0.d0 + d_drho_f_rho1 = 0.d0 + else + call f_mu_and_deriv_mu_simple(rho1,alpha,mu0,beta,f_rho1,d_drho_f_rho1) + endif + if(rho2.lt.1.d-10)then + f_rho2 = 0.d0 + else + call f_mu_and_deriv_mu_simple(rho2,alpha,mu0,beta,f_rho2,tmp) + endif end subroutine f_mu_and_deriv_mu_simple(rho,alpha,mu0,beta,f_mu,d_drho_f_mu) @@ -846,8 +716,53 @@ subroutine f_mu_and_deriv_mu_simple(rho,alpha,mu0,beta,f_mu,d_drho_f_mu) END_DOC double precision, intent(in) :: rho,alpha,mu0,beta double precision, intent(out) :: f_mu,d_drho_f_mu - f_mu = alpha * (rho)**beta + mu0 - d_drho_f_mu = alpha * beta * rho**(beta-1.d0) + f_mu = alpha**beta * (rho)**beta + mu0 + d_drho_f_mu = alpha**beta * beta * rho**(beta-1.d0) end +! --- + +subroutine f_mu_and_deriv_mu_erf(rho,alpha,zeta,mu0,beta,f_mu,d_drho_f_mu) + implicit none + include 'constants.include.F' + BEGIN_DOC +! function giving mu as a function of rho +! +! f_mu = (alpha * rho)**zeta * erf(beta * rho) + mu0 * (1 - erf(beta*rho)) +! +! and its derivative with respect to rho d_drho_f_mu +! +! d_drho_f_mu = 2 beta/sqrt(pi) * exp(-(beta*rho)**2) * ( (alpha*rho)**zeta - mu0) +! + alpha * zeta * (alpha *rho)**(zeta-1) * erf(beta*rho) + END_DOC + double precision, intent(in) :: rho,alpha,mu0,beta,zeta + double precision, intent(out) :: f_mu,d_drho_f_mu + f_mu = (alpha * rho)**zeta * derf(beta * rho) + mu0 * (1.d0 - derf(beta*rho)) + d_drho_f_mu = 2.d0 * beta * inv_sq_pi * dexp(-(beta*rho)**2) * ( (alpha*rho)**zeta - mu0) & + + alpha * zeta * (alpha *rho)**(zeta-1) * derf(beta*rho) + +end + + +subroutine get_all_f_rho_erf(rho1,rho2,alpha,zeta,mu0,beta,f_rho1,d_drho_f_rho1,f_rho2) + implicit none + BEGIN_DOC +! returns the values f(mu(r1)), f(mu(r2)) and d/drho(1) f(mu(r1)) +! with f_mu = (alpha * rho)**zeta * erf(beta * rho) + mu0 * (1 - erf(beta*rho)) + END_DOC + double precision, intent(in) :: rho1,rho2,alpha,mu0,beta,zeta + double precision, intent(out):: f_rho1,d_drho_f_rho1,f_rho2 + double precision :: tmp + if(rho1.lt.1.d-10)then + f_rho1 = mu_erf + d_drho_f_rho1 = 0.d0 + else + call f_mu_and_deriv_mu_erf(rho1,alpha,zeta,mu0,beta,f_rho1,d_drho_f_rho1) + endif + if(rho2.lt.1.d-10)then + f_rho2 = mu_erf + else + call f_mu_and_deriv_mu_erf(rho2,alpha,zeta,mu0,beta,f_rho2,tmp) + endif +end diff --git a/plugins/local/non_h_ints_mu/jast_deriv_utils_vect.irp.f b/plugins/local/non_h_ints_mu/jast_deriv_utils_vect.irp.f new file mode 100644 index 00000000..f9512827 --- /dev/null +++ b/plugins/local/non_h_ints_mu/jast_deriv_utils_vect.irp.f @@ -0,0 +1,332 @@ + +! --- + +subroutine get_grad1_u12_withsq_r1_seq(r1, n_grid2, resx, resy, resz, res) + + BEGIN_DOC + ! + ! grad_1 u(r1,r2) + ! + ! this will be integrated numerically over r2: + ! we use grid for r1 and extra_grid for r2 + ! + ! for 99 < j1b_type < 199 + ! + ! u(r1,r2) = j12_mu(r12) x v(r1) x v(r2) + ! grad1 u(r1, r2) = [(grad1 j12_mu) v(r1) + j12_mu grad1 v(r1)] v(r2) + ! + END_DOC + + implicit none + integer, intent(in) :: n_grid2 + double precision, intent(in) :: r1(3) + double precision, intent(out) :: resx(n_grid2), resy(n_grid2), resz(n_grid2), res(n_grid2) + + integer :: jpoint + double precision :: v1b_r1 + double precision :: grad1_v1b(3) + double precision, allocatable :: v1b_r2(:) + double precision, allocatable :: u2b_r12(:) + double precision, allocatable :: gradx1_u2b(:), grady1_u2b(:), gradz1_u2b(:) + double precision, external :: j1b_nucl + + PROVIDE j1b_type + PROVIDE final_grid_points_extra + + if( (j1b_type .eq. 100) .or. & + (j1b_type .ge. 200) .and. (j1b_type .lt. 300) ) then + + call grad1_j12_mu_r1_seq(r1, n_grid2, resx, resy, resz) + do jpoint = 1, n_points_extra_final_grid + res(jpoint) = resx(jpoint) * resx(jpoint) & + + resy(jpoint) * resy(jpoint) & + + resz(jpoint) * resz(jpoint) + enddo + + elseif((j1b_type .gt. 100) .and. (j1b_type .lt. 200)) then + + allocate(v1b_r2(n_grid2)) + allocate(u2b_r12(n_grid2)) + allocate(gradx1_u2b(n_grid2)) + allocate(grady1_u2b(n_grid2)) + allocate(gradz1_u2b(n_grid2)) + + v1b_r1 = j1b_nucl(r1) + call grad1_j1b_nucl(r1, grad1_v1b) + + call j1b_nucl_r1_seq(n_grid2, v1b_r2) + call j12_mu_r1_seq(r1, n_grid2, u2b_r12) + call grad1_j12_mu_r1_seq(r1, n_grid2, gradx1_u2b, grady1_u2b, gradz1_u2b) + + do jpoint = 1, n_points_extra_final_grid + resx(jpoint) = (gradx1_u2b(jpoint) * v1b_r1 + u2b_r12(jpoint) * grad1_v1b(1)) * v1b_r2(jpoint) + resy(jpoint) = (grady1_u2b(jpoint) * v1b_r1 + u2b_r12(jpoint) * grad1_v1b(2)) * v1b_r2(jpoint) + resz(jpoint) = (gradz1_u2b(jpoint) * v1b_r1 + u2b_r12(jpoint) * grad1_v1b(3)) * v1b_r2(jpoint) + res (jpoint) = resx(jpoint) * resx(jpoint) & + + resy(jpoint) * resy(jpoint) & + + resz(jpoint) * resz(jpoint) + enddo + + deallocate(v1b_r2, u2b_r12, gradx1_u2b, grady1_u2b, gradz1_u2b) + + else + + print *, ' j1b_type = ', j1b_type, 'not implemented yet' + stop + + endif + + return +end subroutine get_grad1_u12_withsq_r1_seq + +! --- + +subroutine grad1_j12_mu_r1_seq(r1, n_grid2, gradx, grady, gradz) + + BEGIN_DOC + ! + ! gradient of j(mu(r1,r2),r12) form of jastrow. + ! + ! if mu(r1,r2) = cst ---> j1b_type < 200 and + ! + ! d/dx1 j(mu,r12) = 0.5 * (1 - erf(mu *r12))/r12 * (x1 - x2) + ! + ! if mu(r1,r2) /= cst ---> 200 < j1b_type < 300 and + ! + ! d/dx1 j(mu(r1,r2),r12) = exp(-(mu(r1,r2)*r12)**2) /(2 *sqrt(pi) * mu(r1,r2)**2 ) d/dx1 mu(r1,r2) + ! + 0.5 * (1 - erf(mu(r1,r2) *r12))/r12 * (x1 - x2) + ! + END_DOC + + include 'constants.include.F' + + implicit none + integer , intent(in) :: n_grid2 + double precision, intent(in) :: r1(3) + double precision, intent(out) :: gradx(n_grid2) + double precision, intent(out) :: grady(n_grid2) + double precision, intent(out) :: gradz(n_grid2) + + integer :: jpoint + double precision :: r2(3) + double precision :: dx, dy, dz, r12, tmp + + if((j1b_type .ge. 0) .and. (j1b_type .lt. 200)) then + + do jpoint = 1, n_points_extra_final_grid ! r2 + + r2(1) = final_grid_points_extra(1,jpoint) + r2(2) = final_grid_points_extra(2,jpoint) + r2(3) = final_grid_points_extra(3,jpoint) + + dx = r1(1) - r2(1) + dy = r1(2) - r2(2) + dz = r1(3) - r2(3) + + r12 = dsqrt(dx * dx + dy * dy + dz * dz) + if(r12 .lt. 1d-10) then + gradx(jpoint) = 0.d0 + grady(jpoint) = 0.d0 + gradz(jpoint) = 0.d0 + cycle + endif + + tmp = 0.5d0 * (1.d0 - derf(mu_erf * r12)) / r12 + + gradx(jpoint) = tmp * dx + grady(jpoint) = tmp * dy + gradz(jpoint) = tmp * dz + enddo + + elseif((j1b_type .ge. 200) .and. (j1b_type .lt. 300)) then + + double precision :: mu_val, mu_tmp, mu_der(3) + + do jpoint = 1, n_points_extra_final_grid ! r2 + + r2(1) = final_grid_points_extra(1,jpoint) + r2(2) = final_grid_points_extra(2,jpoint) + r2(3) = final_grid_points_extra(3,jpoint) + + dx = r1(1) - r2(1) + dy = r1(2) - r2(2) + dz = r1(3) - r2(3) + r12 = dsqrt(dx * dx + dy * dy + dz * dz) + + call mu_r_val_and_grad(r1, r2, mu_val, mu_der) + mu_tmp = mu_val * r12 + tmp = inv_sq_pi_2 * dexp(-mu_tmp*mu_tmp) / (mu_val * mu_val) + gradx(jpoint) = tmp * mu_der(1) + grady(jpoint) = tmp * mu_der(2) + gradz(jpoint) = tmp * mu_der(3) + + if(r12 .lt. 1d-10) then + gradx(jpoint) = 0.d0 + grady(jpoint) = 0.d0 + gradz(jpoint) = 0.d0 + cycle + endif + + tmp = 0.5d0 * (1.d0 - derf(mu_tmp)) / r12 + + gradx(jpoint) = gradx(jpoint) + tmp * dx + grady(jpoint) = grady(jpoint) + tmp * dy + gradz(jpoint) = gradz(jpoint) + tmp * dz + enddo + + else + + print *, ' j1b_type = ', j1b_type, 'not implemented yet' + stop + + endif + + return +end subroutine grad1_j12_mu_r1_seq + +! --- + +subroutine j12_mu_r1_seq(r1, n_grid2, res) + + include 'constants.include.F' + + implicit none + integer, intent(in) :: n_grid2 + double precision, intent(in) :: r1(3) + double precision, intent(out) :: res(n_grid2) + + integer :: jpoint + double precision :: r2(3) + double precision :: mu_tmp, r12 + + PROVIDE final_grid_points_extra + + if((j1b_type .ge. 0) .and. (j1b_type .lt. 200)) then + + do jpoint = 1, n_points_extra_final_grid ! r2 + + r2(1) = final_grid_points_extra(1,jpoint) + r2(2) = final_grid_points_extra(2,jpoint) + r2(3) = final_grid_points_extra(3,jpoint) + + r12 = dsqrt( (r1(1) - r2(1)) * (r1(1) - r2(1)) & + + (r1(2) - r2(2)) * (r1(2) - r2(2)) & + + (r1(3) - r2(3)) * (r1(3) - r2(3)) ) + mu_tmp = mu_erf * r12 + + res(jpoint) = 0.5d0 * r12 * (1.d0 - derf(mu_tmp)) - inv_sq_pi_2 * dexp(-mu_tmp*mu_tmp) / mu_erf + enddo + + else + + print *, ' j1b_type = ', j1b_type, 'not implemented for j12_mu_r1_seq' + stop + + endif + + return +end subroutine j12_mu_r1_seq + +! --- + +subroutine j1b_nucl_r1_seq(n_grid2, res) + + ! TODO + ! change loops order + + implicit none + integer, intent(in) :: n_grid2 + double precision, intent(out) :: res(n_grid2) + + double precision :: r(3) + integer :: i, jpoint + double precision :: a, d, e, x, y, z + + if((j1b_type .eq. 2) .or. (j1b_type .eq. 102)) then + + res = 1.d0 + + do jpoint = 1, n_points_extra_final_grid ! r2 + r(1) = final_grid_points_extra(1,jpoint) + r(2) = final_grid_points_extra(2,jpoint) + r(3) = final_grid_points_extra(3,jpoint) + + do i = 1, nucl_num + a = j1b_pen(i) + d = ( (r(1) - nucl_coord(i,1)) * (r(1) - nucl_coord(i,1)) & + + (r(2) - nucl_coord(i,2)) * (r(2) - nucl_coord(i,2)) & + + (r(3) - nucl_coord(i,3)) * (r(3) - nucl_coord(i,3)) ) + + res(jpoint) -= dexp(-a*dsqrt(d)) + enddo + enddo + + elseif((j1b_type .eq. 3) .or. (j1b_type .eq. 103)) then + + res = 1.d0 + + do jpoint = 1, n_points_extra_final_grid ! r2 + r(1) = final_grid_points_extra(1,jpoint) + r(2) = final_grid_points_extra(2,jpoint) + r(3) = final_grid_points_extra(3,jpoint) + + do i = 1, nucl_num + a = j1b_pen(i) + d = ( (r(1) - nucl_coord(i,1)) * (r(1) - nucl_coord(i,1)) & + + (r(2) - nucl_coord(i,2)) * (r(2) - nucl_coord(i,2)) & + + (r(3) - nucl_coord(i,3)) * (r(3) - nucl_coord(i,3)) ) + e = 1.d0 - dexp(-a*d) + + res(jpoint) *= e + enddo + enddo + + elseif((j1b_type .eq. 4) .or. (j1b_type .eq. 104)) then + + res = 1.d0 + + do jpoint = 1, n_points_extra_final_grid ! r2 + r(1) = final_grid_points_extra(1,jpoint) + r(2) = final_grid_points_extra(2,jpoint) + r(3) = final_grid_points_extra(3,jpoint) + + do i = 1, nucl_num + a = j1b_pen(i) + d = ( (r(1) - nucl_coord(i,1)) * (r(1) - nucl_coord(i,1)) & + + (r(2) - nucl_coord(i,2)) * (r(2) - nucl_coord(i,2)) & + + (r(3) - nucl_coord(i,3)) * (r(3) - nucl_coord(i,3)) ) + res(jpoint) -= j1b_pen_coef(i) * dexp(-a*d) + enddo + enddo + + elseif((j1b_type .eq. 5) .or. (j1b_type .eq. 105)) then + + res = 1.d0 + + do jpoint = 1, n_points_extra_final_grid ! r2 + r(1) = final_grid_points_extra(1,jpoint) + r(2) = final_grid_points_extra(2,jpoint) + r(3) = final_grid_points_extra(3,jpoint) + + do i = 1, nucl_num + a = j1b_pen(i) + x = r(1) - nucl_coord(i,1) + y = r(2) - nucl_coord(i,2) + z = r(3) - nucl_coord(i,3) + d = x*x + y*y + z*z + res(jpoint) -= dexp(-a*d*d) + enddo + enddo + + else + + print *, ' j1b_type = ', j1b_type, 'not implemented for j1b_nucl_r1_seq' + stop + + endif + + return +end subroutine j1b_nucl_r1_seq + +! --- + diff --git a/src/non_h_ints_mu/new_grad_tc.irp.f b/plugins/local/non_h_ints_mu/new_grad_tc.irp.f similarity index 92% rename from src/non_h_ints_mu/new_grad_tc.irp.f rename to plugins/local/non_h_ints_mu/new_grad_tc.irp.f index dc76431d..ab3cc3be 100644 --- a/src/non_h_ints_mu/new_grad_tc.irp.f +++ b/plugins/local/non_h_ints_mu/new_grad_tc.irp.f @@ -149,22 +149,6 @@ BEGIN_PROVIDER [double precision, tc_grad_and_lapl_ao, (ao_num, ao_num, ao_num, deallocate(b_mat) call sum_A_At(tc_grad_and_lapl_ao(1,1,1,1), ao_num*ao_num) - ! !$OMP PARALLEL & - ! !$OMP DEFAULT (NONE) & - ! !$OMP PRIVATE (i, j, k, l) & - ! !$OMP SHARED (ac_mat, tc_grad_and_lapl_ao, ao_num) - ! !$OMP DO SCHEDULE (static) - ! do j = 1, ao_num - ! do l = 1, ao_num - ! do i = 1, ao_num - ! do k = 1, ao_num - ! tc_grad_and_lapl_ao(k,i,l,j) = ac_mat(k,i,l,j) + ac_mat(l,j,k,i) - ! enddo - ! enddo - ! enddo - ! enddo - ! !$OMP END DO - ! !$OMP END PARALLEL endif diff --git a/src/non_h_ints_mu/new_grad_tc_manu.irp.f b/plugins/local/non_h_ints_mu/new_grad_tc_manu.irp.f similarity index 100% rename from src/non_h_ints_mu/new_grad_tc_manu.irp.f rename to plugins/local/non_h_ints_mu/new_grad_tc_manu.irp.f diff --git a/src/non_h_ints_mu/numerical_integ.irp.f b/plugins/local/non_h_ints_mu/numerical_integ.irp.f similarity index 100% rename from src/non_h_ints_mu/numerical_integ.irp.f rename to plugins/local/non_h_ints_mu/numerical_integ.irp.f diff --git a/src/non_h_ints_mu/plot_mu_of_r.irp.f b/plugins/local/non_h_ints_mu/plot_mu_of_r.irp.f similarity index 65% rename from src/non_h_ints_mu/plot_mu_of_r.irp.f rename to plugins/local/non_h_ints_mu/plot_mu_of_r.irp.f index 1100cd7c..3a5984bd 100644 --- a/src/non_h_ints_mu/plot_mu_of_r.irp.f +++ b/plugins/local/non_h_ints_mu/plot_mu_of_r.irp.f @@ -13,9 +13,9 @@ subroutine routine_print integer :: i_unit_output,getUnitAndOpen output=trim(ezfio_filename)//'.mu_of_r' i_unit_output = getUnitAndOpen(output,'w') - integer :: ipoint,nx - double precision :: xmax,xmin,r(3),dx - double precision :: mu_val, mu_der(3),dm_a,dm_b,grad + integer :: ipoint,nx,i + double precision :: xmax,xmin,r(3),dx,sigma + double precision :: mu_val, mu_der(3),dm_a,dm_b,grad,grad_dm_a(3), grad_dm_b(3) xmax = 5.D0 xmin = -5.D0 nx = 10000 @@ -24,10 +24,15 @@ subroutine routine_print r(1) = xmin do ipoint = 1, nx call mu_r_val_and_grad(r, r, mu_val, mu_der) - call dm_dft_alpha_beta_at_r(r,dm_a,dm_b) + call density_and_grad_alpha_beta(r,dm_a,dm_b, grad_dm_a, grad_dm_b) + sigma = 0.d0 + do i = 1,3 + sigma += grad_dm_a(i)**2 + enddo + sigma=dsqrt(sigma) grad = mu_der(1)**2 + mu_der(2)**2 + mu_der(3)**2 grad = dsqrt(grad) - write(i_unit_output,'(100(F16.7,X))')r(1),mu_val,dm_a+dm_b,grad + write(i_unit_output,'(100(F16.7,X))')r(1),mu_val,dm_a+dm_b,grad,sigma/dm_a r(1) += dx enddo end diff --git a/plugins/local/non_h_ints_mu/qmckl.irp.f b/plugins/local/non_h_ints_mu/qmckl.irp.f new file mode 100644 index 00000000..1df80457 --- /dev/null +++ b/plugins/local/non_h_ints_mu/qmckl.irp.f @@ -0,0 +1,77 @@ +BEGIN_PROVIDER [ integer*8, qmckl_ctx_jastrow ] + use qmckl + use iso_c_binding + implicit none + BEGIN_DOC + ! Context for the QMCKL library + END_DOC + integer(qmckl_exit_code) :: rc + + qmckl_ctx_jastrow = qmckl_context_create() + + rc = qmckl_set_jastrow_champ_spin_independent(qmckl_ctx_jastrow, 1) + rc = qmckl_check(qmckl_ctx_jastrow, rc) + if (rc /= QMCKL_SUCCESS) stop -1 + + rc = qmckl_set_nucleus_num(qmckl_ctx_jastrow, nucl_num*1_8) + rc = qmckl_check(qmckl_ctx_jastrow, rc) + if (rc /= QMCKL_SUCCESS) stop -1 + + rc = qmckl_set_nucleus_charge(qmckl_ctx_jastrow, nucl_charge, nucl_num*1_8) + rc = qmckl_check(qmckl_ctx_jastrow, rc) + if (rc /= QMCKL_SUCCESS) stop -1 + + rc = qmckl_set_nucleus_coord(qmckl_ctx_jastrow, 'T', nucl_coord, nucl_num*3_8) + rc = qmckl_check(qmckl_ctx_jastrow, rc) + if (rc /= QMCKL_SUCCESS) stop -1 + + rc = qmckl_set_electron_num(qmckl_ctx_jastrow, 1_8, 1_8) + rc = qmckl_check(qmckl_ctx_jastrow, rc) + if (rc /= QMCKL_SUCCESS) stop -1 + + + ! Jastrow parameters + rc = qmckl_set_jastrow_champ_type_nucl_num(qmckl_ctx_jastrow, 1_8*jast_qmckl_type_nucl_num) + rc = qmckl_check(qmckl_ctx_jastrow, rc) + if (rc /= QMCKL_SUCCESS) stop -1 + + rc = qmckl_set_jastrow_champ_type_nucl_vector(qmckl_ctx_jastrow, 1_8*jast_qmckl_type_nucl_vector-1_8, 1_8*nucl_num) + rc = qmckl_check(qmckl_ctx_jastrow, rc) + if (rc /= QMCKL_SUCCESS) stop -1 + + rc = qmckl_set_jastrow_champ_rescale_factor_ee(qmckl_ctx_jastrow, jast_qmckl_rescale_ee) + rc = qmckl_check(qmckl_ctx_jastrow, rc) + if (rc /= QMCKL_SUCCESS) stop -1 + + rc = qmckl_set_jastrow_champ_rescale_factor_en(qmckl_ctx_jastrow, jast_qmckl_rescale_en, 1_8*jast_qmckl_type_nucl_num) + rc = qmckl_check(qmckl_ctx_jastrow, rc) + if (rc /= QMCKL_SUCCESS) stop -1 + + rc = qmckl_set_jastrow_champ_aord_num(qmckl_ctx_jastrow, jast_qmckl_aord_num*1_8) + rc = qmckl_check(qmckl_ctx_jastrow, rc) + if (rc /= QMCKL_SUCCESS) stop -1 + + rc = qmckl_set_jastrow_champ_a_vector(qmckl_ctx_jastrow, jast_qmckl_a_vector, 1_8*size(jast_qmckl_a_vector)) + rc = qmckl_check(qmckl_ctx_jastrow, rc) + if (rc /= QMCKL_SUCCESS) stop -1 + + rc = qmckl_set_jastrow_champ_bord_num(qmckl_ctx_jastrow, jast_qmckl_bord_num*1_8) + rc = qmckl_check(qmckl_ctx_jastrow, rc) + if (rc /= QMCKL_SUCCESS) stop -1 + + rc = qmckl_set_jastrow_champ_b_vector(qmckl_ctx_jastrow, jast_qmckl_b_vector, 1_8*size(jast_qmckl_b_vector)) + rc = qmckl_check(qmckl_ctx_jastrow, rc) + if (rc /= QMCKL_SUCCESS) stop -1 + + + rc = qmckl_set_jastrow_champ_cord_num(qmckl_ctx_jastrow, jast_qmckl_cord_num*1_8) + rc = qmckl_check(qmckl_ctx_jastrow, rc) + if (rc /= QMCKL_SUCCESS) stop -1 + + if (jast_qmckl_cord_num > 0) then + rc = qmckl_set_jastrow_champ_c_vector(qmckl_ctx_jastrow, jast_qmckl_c_vector, 1_8*jast_qmckl_c_vector_size) + rc = qmckl_check(qmckl_ctx_jastrow, rc) + if (rc /= QMCKL_SUCCESS) stop -1 + endif + +END_PROVIDER diff --git a/src/non_h_ints_mu/tc_integ.irp.f b/plugins/local/non_h_ints_mu/tc_integ_an.irp.f similarity index 62% rename from src/non_h_ints_mu/tc_integ.irp.f rename to plugins/local/non_h_ints_mu/tc_integ_an.irp.f index d569b25c..a6459761 100644 --- a/src/non_h_ints_mu/tc_integ.irp.f +++ b/plugins/local/non_h_ints_mu/tc_integ_an.irp.f @@ -1,10 +1,11 @@ -! --- - BEGIN_PROVIDER [double precision, int2_grad1_u12_ao, (ao_num, ao_num, n_points_final_grid, 3)] BEGIN_DOC ! + ! TODO + ! combine with int2_grad1_u12_square_ao to avoid repeated calculation ? + ! ! int2_grad1_u12_ao(i,j,ipoint,:) = \int dr2 [-1 * \grad_r1 J(r1,r2)] \phi_i(r2) \phi_j(r2) ! ! where r1 = r(ipoint) @@ -104,63 +105,13 @@ BEGIN_PROVIDER [double precision, int2_grad1_u12_ao, (ao_num, ao_num, n_points_f FREE v_ij_erf_rk_cst_mu_j1b v_ij_u_cst_mu_j1b_an x_v_ij_erf_rk_cst_mu_j1b elseif(j1b_type .ge. 100) then + +! PROVIDE int2_grad1_u12_ao_num +! int2_grad1_u12_ao = int2_grad1_u12_ao_num - PROVIDE final_weight_at_r_vector_extra aos_in_r_array_extra - PROVIDE grad1_u12_num + PROVIDE int2_grad1_u12_ao_num_1shot + int2_grad1_u12_ao = int2_grad1_u12_ao_num_1shot - double precision, allocatable :: tmp(:,:,:) - allocate(tmp(n_points_extra_final_grid,ao_num,ao_num)) - tmp = 0.d0 - !$OMP PARALLEL & - !$OMP DEFAULT (NONE) & - !$OMP PRIVATE (j, i, jpoint) & - !$OMP SHARED (tmp, ao_num, n_points_extra_final_grid, final_weight_at_r_vector_extra, aos_in_r_array_extra_transp) - !$OMP DO SCHEDULE (static) - do j = 1, ao_num - do i = 1, ao_num - do jpoint = 1, n_points_extra_final_grid - tmp(jpoint,i,j) = final_weight_at_r_vector_extra(jpoint) * aos_in_r_array_extra_transp(jpoint,i) * aos_in_r_array_extra_transp(jpoint,j) - enddo - enddo - enddo - !$OMP END DO - !$OMP END PARALLEL - - int2_grad1_u12_ao = 0.d0 - do m = 1, 3 - !call dgemm( "T", "N", ao_num*ao_num, n_points_final_grid, n_points_extra_final_grid, +1.d0 & - ! this work also because of the symmetry in K(1,2) and sign compensation in L(1,2,3) - call dgemm( "T", "N", ao_num*ao_num, n_points_final_grid, n_points_extra_final_grid, -1.d0 & - , tmp(1,1,1), n_points_extra_final_grid, grad1_u12_num(1,1,m), n_points_extra_final_grid & - , 0.d0, int2_grad1_u12_ao(1,1,1,m), ao_num*ao_num) - enddo - - !! these dgemm are equivalent to - !!$OMP PARALLEL & - !!$OMP DEFAULT (NONE) & - !!$OMP PRIVATE (j, i, ipoint, jpoint, w) & - !!$OMP SHARED (int2_grad1_u12_ao, ao_num, n_points_final_grid, & - !!$OMP n_points_extra_final_grid, final_weight_at_r_vector_extra, & - !!$OMP aos_in_r_array_extra_transp, grad1_u12_num, tmp) - !!$OMP DO SCHEDULE (static) - !do ipoint = 1, n_points_final_grid - ! do j = 1, ao_num - ! do i = 1, ao_num - ! do jpoint = 1, n_points_extra_final_grid - ! w = -tmp(jpoint,i,j) - ! !w = tmp(jpoint,i,j) this work also because of the symmetry in K(1,2) - ! ! and sign compensation in L(1,2,3) - ! int2_grad1_u12_ao(i,j,ipoint,1) += w * grad1_u12_num(jpoint,ipoint,1) - ! int2_grad1_u12_ao(i,j,ipoint,2) += w * grad1_u12_num(jpoint,ipoint,2) - ! int2_grad1_u12_ao(i,j,ipoint,3) += w * grad1_u12_num(jpoint,ipoint,3) - ! enddo - ! enddo - ! enddo - !enddo - !!$OMP END DO - !!$OMP END PARALLEL - - deallocate(tmp) else print *, ' j1b_type = ', j1b_type, 'not implemented yet' @@ -274,55 +225,12 @@ BEGIN_PROVIDER [double precision, int2_grad1_u12_square_ao, (ao_num, ao_num, n_p elseif(j1b_type .ge. 100) then - PROVIDE final_weight_at_r_vector_extra aos_in_r_array_extra - PROVIDE grad1_u12_squared_num + ! PROVIDE int2_grad1_u12_square_ao_num + ! int2_grad1_u12_square_ao = int2_grad1_u12_square_ao_num - double precision, allocatable :: tmp(:,:,:) - allocate(tmp(n_points_extra_final_grid,ao_num,ao_num)) - tmp = 0.d0 - !$OMP PARALLEL & - !$OMP DEFAULT (NONE) & - !$OMP PRIVATE (j, i, jpoint) & - !$OMP SHARED (tmp, ao_num, n_points_extra_final_grid, final_weight_at_r_vector_extra, aos_in_r_array_extra_transp) - !$OMP DO SCHEDULE (static) - do j = 1, ao_num - do i = 1, ao_num - do jpoint = 1, n_points_extra_final_grid - tmp(jpoint,i,j) = final_weight_at_r_vector_extra(jpoint) * aos_in_r_array_extra_transp(jpoint,i) * aos_in_r_array_extra_transp(jpoint,j) - enddo - enddo - enddo - !$OMP END DO - !$OMP END PARALLEL + PROVIDE int2_grad1_u12_square_ao_num_1shot + int2_grad1_u12_square_ao = int2_grad1_u12_square_ao_num_1shot - int2_grad1_u12_square_ao = 0.d0 - call dgemm( "T", "N", ao_num*ao_num, n_points_final_grid, n_points_extra_final_grid, -0.5d0 & - , tmp(1,1,1), n_points_extra_final_grid, grad1_u12_squared_num(1,1), n_points_extra_final_grid & - , 0.d0, int2_grad1_u12_square_ao(1,1,1), ao_num*ao_num) - - !! this dgemm is equivalen to - !!$OMP PARALLEL & - !!$OMP DEFAULT (NONE) & - !!$OMP PRIVATE (i, j, ipoint, jpoint, w) & - !!$OMP SHARED (int2_grad1_u12_square_ao, ao_num, n_points_final_grid, & - !!$OMP n_points_extra_final_grid, final_weight_at_r_vector_extra, & - !!$OMP aos_in_r_array_extra_transp, grad1_u12_squared_num, tmp) - !!$OMP DO SCHEDULE (static) - !do ipoint = 1, n_points_final_grid - ! do j = 1, ao_num - ! do i = 1, ao_num - ! do jpoint = 1, n_points_extra_final_grid - ! w = -0.5d0 * tmp(jpoint,i,j) - ! int2_grad1_u12_square_ao(i,j,ipoint) += w * grad1_u12_squared_num(jpoint,ipoint) - ! enddo - ! enddo - ! enddo - !enddo - !!$OMP END DO - !!$OMP END PARALLEL - - deallocate(tmp) - else print *, ' j1b_type = ', j1b_type, 'not implemented yet' diff --git a/plugins/local/non_h_ints_mu/tc_integ_num.irp.f b/plugins/local/non_h_ints_mu/tc_integ_num.irp.f new file mode 100644 index 00000000..5a088331 --- /dev/null +++ b/plugins/local/non_h_ints_mu/tc_integ_num.irp.f @@ -0,0 +1,201 @@ + + BEGIN_PROVIDER [double precision, int2_grad1_u12_ao_num , (ao_num,ao_num,n_points_final_grid,3)] +&BEGIN_PROVIDER [double precision, int2_grad1_u12_square_ao_num, (ao_num,ao_num,n_points_final_grid) ] + + BEGIN_DOC + ! + ! int2_grad1_u12_ao_num(i,j,ipoint,:) = \int dr2 [-1 * \grad_r1 J(r1,r2)] \phi_i(r2) \phi_j(r2) + ! + ! int2_grad1_u12_square_ao_num = -(1/2) x int dr2 chi_l(r2) chi_j(r2) [grad_1 u(r1,r2)]^2 + ! + END_DOC + + implicit none + integer :: ipoint, i, j, m, jpoint + integer :: n_blocks, n_rest, n_pass + integer :: i_blocks, i_rest, i_pass, ii + double precision :: time0, time1 + double precision :: mem, n_double + double precision, allocatable :: tmp(:,:,:) + double precision, allocatable :: tmp_grad1_u12(:,:,:), tmp_grad1_u12_squared(:,:) + + ! TODO + ! tmp_grad1_u12_squared get be obtained from tmp_grad1_u12 + + print*, ' providing int2_grad1_u12_ao_num & int2_grad1_u12_square_ao_num ...' + call wall_time(time0) + + PROVIDE final_weight_at_r_vector_extra aos_in_r_array_extra + + allocate(tmp(n_points_extra_final_grid,ao_num,ao_num)) + !$OMP PARALLEL & + !$OMP DEFAULT (NONE) & + !$OMP PRIVATE (j, i, jpoint) & + !$OMP SHARED (tmp, ao_num, n_points_extra_final_grid, final_weight_at_r_vector_extra, aos_in_r_array_extra_transp) + !$OMP DO SCHEDULE (static) + do j = 1, ao_num + do i = 1, ao_num + do jpoint = 1, n_points_extra_final_grid + tmp(jpoint,i,j) = final_weight_at_r_vector_extra(jpoint) * aos_in_r_array_extra_transp(jpoint,i) * aos_in_r_array_extra_transp(jpoint,j) + enddo + enddo + enddo + !$OMP END DO + !$OMP END PARALLEL + + ! n_points_final_grid = n_blocks * n_pass + n_rest + call total_memory(mem) + mem = max(1.d0, qp_max_mem - mem) + n_double = mem * 1.d8 + n_blocks = int(min(n_double / (n_points_extra_final_grid * 4.d0), 1.d0*n_points_final_grid)) + n_rest = int(mod(n_points_final_grid, n_blocks)) + n_pass = int((n_points_final_grid - n_rest) / n_blocks) + + call write_int(6, n_pass, 'Number of passes') + call write_int(6, n_blocks, 'Size of the blocks') + call write_int(6, n_rest, 'Size of the last block') + + + allocate(tmp_grad1_u12_squared(n_points_extra_final_grid,n_blocks)) + allocate(tmp_grad1_u12(n_points_extra_final_grid,n_blocks,3)) + + do i_pass = 1, n_pass + ii = (i_pass-1)*n_blocks + 1 + + !$OMP PARALLEL & + !$OMP DEFAULT (NONE) & + !$OMP PRIVATE (i_blocks, ipoint) & + !$OMP SHARED (n_blocks, n_points_extra_final_grid, ii, & + !$OMP final_grid_points, tmp_grad1_u12, & + !$OMP tmp_grad1_u12_squared) + !$OMP DO + do i_blocks = 1, n_blocks + ipoint = ii - 1 + i_blocks ! r1 + call get_grad1_u12_withsq_r1_seq(final_grid_points(1,ipoint), n_points_extra_final_grid, tmp_grad1_u12(1,i_blocks,1) & + , tmp_grad1_u12(1,i_blocks,2) & + , tmp_grad1_u12(1,i_blocks,3) & + , tmp_grad1_u12_squared(1,i_blocks)) + enddo + !$OMP END DO + !$OMP END PARALLEL + + do m = 1, 3 + call dgemm( "T", "N", ao_num*ao_num, n_blocks, n_points_extra_final_grid, 1.d0 & + , tmp(1,1,1), n_points_extra_final_grid, tmp_grad1_u12(1,1,m), n_points_extra_final_grid & + , 0.d0, int2_grad1_u12_ao_num(1,1,ii,m), ao_num*ao_num) + enddo + call dgemm( "T", "N", ao_num*ao_num, n_blocks, n_points_extra_final_grid, -0.5d0 & + , tmp(1,1,1), n_points_extra_final_grid, tmp_grad1_u12_squared(1,1), n_points_extra_final_grid & + , 0.d0, int2_grad1_u12_square_ao_num(1,1,ii), ao_num*ao_num) + enddo + + deallocate(tmp_grad1_u12, tmp_grad1_u12_squared) + + if(n_rest .gt. 0) then + + allocate(tmp_grad1_u12_squared(n_points_extra_final_grid,n_rest)) + allocate(tmp_grad1_u12(n_points_extra_final_grid,n_rest,3)) + + ii = n_pass*n_blocks + 1 + + !$OMP PARALLEL & + !$OMP DEFAULT (NONE) & + !$OMP PRIVATE (i_rest, ipoint) & + !$OMP SHARED (n_rest, n_points_extra_final_grid, ii, & + !$OMP final_grid_points, tmp_grad1_u12, & + !$OMP tmp_grad1_u12_squared) + !$OMP DO + do i_rest = 1, n_rest + ipoint = ii - 1 + i_rest ! r1 + call get_grad1_u12_withsq_r1_seq(final_grid_points(1,ipoint), n_points_extra_final_grid, tmp_grad1_u12(1,i_rest,1) & + , tmp_grad1_u12(1,i_rest,2) & + , tmp_grad1_u12(1,i_rest,3) & + , tmp_grad1_u12_squared(1,i_rest)) + enddo + !$OMP END DO + !$OMP END PARALLEL + + do m = 1, 3 + call dgemm( "T", "N", ao_num*ao_num, n_rest, n_points_extra_final_grid, 1.d0 & + , tmp(1,1,1), n_points_extra_final_grid, tmp_grad1_u12(1,1,m), n_points_extra_final_grid & + , 0.d0, int2_grad1_u12_ao_num(1,1,ii,m), ao_num*ao_num) + enddo + call dgemm( "T", "N", ao_num*ao_num, n_rest, n_points_extra_final_grid, -0.5d0 & + , tmp(1,1,1), n_points_extra_final_grid, tmp_grad1_u12_squared(1,1), n_points_extra_final_grid & + , 0.d0, int2_grad1_u12_square_ao_num(1,1,ii), ao_num*ao_num) + + deallocate(tmp_grad1_u12, tmp_grad1_u12_squared) + endif + + deallocate(tmp) + + call wall_time(time1) + print*, ' wall time for int2_grad1_u12_ao_num & int2_grad1_u12_square_ao_num =', time1-time0 + call print_memory_usage() + +END_PROVIDER + +! --- + + BEGIN_PROVIDER [double precision, int2_grad1_u12_ao_num_1shot , (ao_num,ao_num,n_points_final_grid,3)] +&BEGIN_PROVIDER [double precision, int2_grad1_u12_square_ao_num_1shot, (ao_num,ao_num,n_points_final_grid) ] + + BEGIN_DOC + ! + ! int2_grad1_u12_ao_num_1shot(i,j,ipoint,:) = \int dr2 [-1 * \grad_r1 J(r1,r2)] \phi_i(r2) \phi_j(r2) + ! + ! int2_grad1_u12_square_ao_num_1shot = -(1/2) x int dr2 chi_l(r2) chi_j(r2) [grad_1 u(r1,r2)]^2 + ! + END_DOC + + implicit none + integer :: ipoint, i, j, m, jpoint + double precision :: time0, time1 + double precision, allocatable :: tmp(:,:,:) + + print*, ' providing int2_grad1_u12_ao_num_1shot & int2_grad1_u12_square_ao_num_1shot ...' + call wall_time(time0) + + PROVIDE final_weight_at_r_vector_extra aos_in_r_array_extra + PROVIDE grad1_u12_num grad1_u12_squared_num + + allocate(tmp(n_points_extra_final_grid,ao_num,ao_num)) + !$OMP PARALLEL & + !$OMP DEFAULT (NONE) & + !$OMP PRIVATE (j, i, jpoint) & + !$OMP SHARED (tmp, ao_num, n_points_extra_final_grid, final_weight_at_r_vector_extra, aos_in_r_array_extra_transp) + !$OMP DO SCHEDULE (static) + do j = 1, ao_num + do i = 1, ao_num + do jpoint = 1, n_points_extra_final_grid + tmp(jpoint,i,j) = final_weight_at_r_vector_extra(jpoint) * aos_in_r_array_extra_transp(jpoint,i) * aos_in_r_array_extra_transp(jpoint,j) + enddo + enddo + enddo + !$OMP END DO + !$OMP END PARALLEL + + do m = 1, 3 + !call dgemm( "T", "N", ao_num*ao_num, n_points_final_grid, n_points_extra_final_grid, -1.d0 & + ! this work also because of the symmetry in K(1,2) and sign compensation in L(1,2,3) + call dgemm( "T", "N", ao_num*ao_num, n_points_final_grid, n_points_extra_final_grid, +1.d0 & + , tmp(1,1,1), n_points_extra_final_grid, grad1_u12_num(1,1,m), n_points_extra_final_grid & + , 0.d0, int2_grad1_u12_ao_num_1shot(1,1,1,m), ao_num*ao_num) + enddo + FREE grad1_u12_num + + call dgemm( "T", "N", ao_num*ao_num, n_points_final_grid, n_points_extra_final_grid, -0.5d0 & + , tmp(1,1,1), n_points_extra_final_grid, grad1_u12_squared_num(1,1), n_points_extra_final_grid & + , 0.d0, int2_grad1_u12_square_ao_num_1shot(1,1,1), ao_num*ao_num) + FREE grad1_u12_squared_num + + deallocate(tmp) + + call wall_time(time1) + print*, ' wall time for int2_grad1_u12_ao_num_1shot & int2_grad1_u12_square_ao_num_1shot =', time1-time0 + call print_memory_usage() + +END_PROVIDER + +! --- + diff --git a/src/non_h_ints_mu/test_non_h_ints.irp.f b/plugins/local/non_h_ints_mu/test_non_h_ints.irp.f similarity index 84% rename from src/non_h_ints_mu/test_non_h_ints.irp.f rename to plugins/local/non_h_ints_mu/test_non_h_ints.irp.f index aff53c2d..84674fa0 100644 --- a/src/non_h_ints_mu/test_non_h_ints.irp.f +++ b/plugins/local/non_h_ints_mu/test_non_h_ints.irp.f @@ -11,10 +11,24 @@ program test_non_h my_n_pt_a_grid = tc_grid1_a touch my_grid_becke my_n_pt_r_grid my_n_pt_a_grid + if(j1b_type .ge. 100) then + my_extra_grid_becke = .True. + PROVIDE tc_grid2_a tc_grid2_r + my_n_pt_r_extra_grid = tc_grid2_r + my_n_pt_a_extra_grid = tc_grid2_a + touch my_extra_grid_becke my_n_pt_r_extra_grid my_n_pt_a_extra_grid + endif + + !call routine_grad_squared() !call routine_fit() - call test_ipp() + !call test_ipp() + + !call test_v_ij_u_cst_mu_j1b_an() + + call test_int2_grad1_u12_square_ao() + call test_int2_grad1_u12_ao() end ! --- @@ -545,9 +559,129 @@ end subroutine grad1_aos_ik_grad1_esquare ! --- +subroutine test_v_ij_u_cst_mu_j1b_an() + implicit none + integer :: i, j, ipoint + double precision :: I_old, I_new + double precision :: norm, accu, thr, diff + PROVIDE v_ij_u_cst_mu_j1b_an_old v_ij_u_cst_mu_j1b_an + thr = 1d-12 + norm = 0.d0 + accu = 0.d0 + do ipoint = 1, n_points_final_grid + do i = 1, ao_num + do j = 1, ao_num + I_old = v_ij_u_cst_mu_j1b_an_old(j,i,ipoint) + I_new = v_ij_u_cst_mu_j1b_an (j,i,ipoint) + diff = dabs(I_new-I_old) + if(diff .gt. thr) then + print *, ' problem on:', j, i, ipoint + print *, ' old value :', I_old + print *, ' new value :', I_new + stop + endif + + accu += diff + norm += dabs(I_old) + enddo + enddo + enddo + + print*, ' accuracy(%) = ', 100.d0 * accu / norm + + return +end subroutine test_v_ij_u_cst_mu_j1b_an + +! --- + +subroutine test_int2_grad1_u12_square_ao() + + implicit none + integer :: i, j, ipoint + double precision :: I_old, I_new + double precision :: norm, accu, thr, diff + + PROVIDE int2_grad1_u12_square_ao + PROVIDE int2_grad1_u12_square_ao_num_1shot + + thr = 1d-8 + norm = 0.d0 + accu = 0.d0 + do ipoint = 1, n_points_final_grid + do i = 1, ao_num + do j = 1, ao_num + + I_old = int2_grad1_u12_square_ao_num_1shot(j,i,ipoint) + I_new = int2_grad1_u12_square_ao (j,i,ipoint) + !I_new = int2_grad1_u12_square_ao_num (j,i,ipoint) + + diff = dabs(I_new-I_old) + if(diff .gt. thr) then + print *, ' problem on:', j, i, ipoint + print *, ' old value :', I_old + print *, ' new value :', I_new + !stop + endif + + accu += diff + norm += dabs(I_old) + enddo + enddo + enddo + + print*, ' accuracy(%) = ', 100.d0 * accu / norm + + return +end subroutine test_int2_grad1_u12_square_ao + +! --- + +subroutine test_int2_grad1_u12_ao() + + implicit none + integer :: i, j, ipoint, m + double precision :: I_old, I_new + double precision :: norm, accu, thr, diff + + PROVIDE int2_grad1_u12_ao + PROVIDE int2_grad1_u12_ao_num_1shot + + thr = 1d-8 + norm = 0.d0 + accu = 0.d0 + do ipoint = 1, n_points_final_grid + do i = 1, ao_num + do j = 1, ao_num + + do m = 1, 3 + I_old = int2_grad1_u12_ao_num_1shot(j,i,ipoint,m) + I_new = int2_grad1_u12_ao (j,i,ipoint,m) + !I_new = int2_grad1_u12_ao_num (j,i,ipoint,m) + + diff = dabs(I_new-I_old) + if(diff .gt. thr) then + print *, ' problem on:', j, i, ipoint, m + print *, ' old value :', I_old + print *, ' new value :', I_new + !stop + endif + + accu += diff + norm += dabs(I_old) + enddo + enddo + enddo + enddo + + print*, ' accuracy(%) = ', 100.d0 * accu / norm + + return +end subroutine test_int2_grad1_u12_ao + +! --- diff --git a/src/non_h_ints_mu/total_tc_int.irp.f b/plugins/local/non_h_ints_mu/total_tc_int.irp.f similarity index 91% rename from src/non_h_ints_mu/total_tc_int.irp.f rename to plugins/local/non_h_ints_mu/total_tc_int.irp.f index 158ee2fb..9c19e0ac 100644 --- a/src/non_h_ints_mu/total_tc_int.irp.f +++ b/plugins/local/non_h_ints_mu/total_tc_int.irp.f @@ -1,7 +1,4 @@ -! TODO -! remove ao_two_e_coul and use map directly - ! --- BEGIN_PROVIDER [double precision, ao_vartc_int_chemist, (ao_num, ao_num, ao_num, ao_num)] @@ -58,12 +55,13 @@ BEGIN_PROVIDER [double precision, ao_tc_int_chemist, (ao_num, ao_num, ao_num, ao integer :: i, j, k, l double precision :: wall1, wall0 + PROVIDE j1b_type + print *, ' providing ao_tc_int_chemist ...' call wall_time(wall0) if(test_cycle_tc) then - PROVIDE j1b_type if(j1b_type .ne. 3) then print*, ' TC integrals with cycle can not be used for j1b_type =', j1b_type stop @@ -89,6 +87,11 @@ BEGIN_PROVIDER [double precision, ao_tc_int_chemist, (ao_num, ao_num, ao_num, ao FREE tc_grad_square_ao tc_grad_and_lapl_ao ao_two_e_coul + if(j1b_type .ge. 100) then + FREE int2_grad1_u12_ao_num int2_grad1_u12_square_ao_num + endif + + call wall_time(wall1) print *, ' wall time for ao_tc_int_chemist ', wall1 - wall0 call print_memory_usage() @@ -160,24 +163,26 @@ BEGIN_PROVIDER [double precision, ao_two_e_coul, (ao_num, ao_num, ao_num, ao_num END_DOC integer :: i, j, k, l - double precision :: integral double precision, external :: get_ao_two_e_integral PROVIDE ao_integrals_map + !$OMP PARALLEL DEFAULT(NONE) & + !$OMP SHARED(ao_num, ao_two_e_coul, ao_integrals_map) & + !$OMP PRIVATE(i, j, k, l) + !$OMP DO do j = 1, ao_num do l = 1, ao_num do i = 1, ao_num do k = 1, ao_num - ! < 1:k, 2:l | 1:i, 2:j > - integral = get_ao_two_e_integral(i, j, k, l, ao_integrals_map) - - ao_two_e_coul(k,i,l,j) = integral + ao_two_e_coul(k,i,l,j) = get_ao_two_e_integral(i, j, k, l, ao_integrals_map) enddo enddo enddo enddo + !$OMP END DO + !$OMP END PARALLEL END_PROVIDER diff --git a/src/non_hermit_dav/NEED b/plugins/local/non_hermit_dav/NEED similarity index 100% rename from src/non_hermit_dav/NEED rename to plugins/local/non_hermit_dav/NEED diff --git a/src/non_hermit_dav/biorthog.irp.f b/plugins/local/non_hermit_dav/biorthog.irp.f similarity index 90% rename from src/non_hermit_dav/biorthog.irp.f rename to plugins/local/non_hermit_dav/biorthog.irp.f index 78fddf54..13917c5a 100644 --- a/src/non_hermit_dav/biorthog.irp.f +++ b/plugins/local/non_hermit_dav/biorthog.irp.f @@ -270,7 +270,7 @@ subroutine non_hrmt_bieig(n, A, thr_d, thr_nd, leigvec, reigvec, n_real_eigv, ei integer, intent(out) :: n_real_eigv double precision, intent(out) :: reigvec(n,n), leigvec(n,n), eigval(n) - integer :: i, j + integer :: i, j,k integer :: n_good double precision :: thr, thr_cut, thr_diag, thr_norm double precision :: accu_d, accu_nd @@ -278,6 +278,8 @@ subroutine non_hrmt_bieig(n, A, thr_d, thr_nd, leigvec, reigvec, n_real_eigv, ei integer, allocatable :: list_good(:), iorder(:) double precision, allocatable :: WR(:), WI(:), VL(:,:), VR(:,:) double precision, allocatable :: S(:,:) + double precision, allocatable :: phi_1_tilde(:),phi_2_tilde(:),chi_1_tilde(:),chi_2_tilde(:) + allocate(phi_1_tilde(n),phi_2_tilde(n),chi_1_tilde(n),chi_2_tilde(n)) ! ------------------------------------------------------------------------------------- @@ -301,11 +303,78 @@ subroutine non_hrmt_bieig(n, A, thr_d, thr_nd, leigvec, reigvec, n_real_eigv, ei call lapack_diag_non_sym(n, A, WR, WI, VL, VR) !call lapack_diag_non_sym_new(n, A, WR, WI, VL, VR) - !print *, ' ' - !print *, ' eigenvalues' - !do i = 1, n - ! write(*, '(1000(F16.10,X))') WR(i), WI(i) - !enddo + + + print *, ' ' + print *, ' eigenvalues' + i = 1 + do while(i .le. n) + write(*, '(I3,X,1000(F16.10,X))')i, WR(i), WI(i) + if(.false.)then + if(WI(i).ne.0.d0)then + print*,'*****************' + print*,'WARNING ! IMAGINARY EIGENVALUES !!!' + write(*, '(1000(F16.10,X))') WR(i), WI(i+1) + ! phi = VR(:,i), psi = VR(:,i+1), |Phi_i> = phi + j psi , |Phi_i+1> = phi - j psi + ! chi = VL(:,i), xhi = VL(:,i+1), |Chi_i> = chi + j xhi , |Chi_i+1> = chi - j xhi + ! + accu_chi_phi = 0.d0 + accu_xhi_psi = 0.d0 + accu_chi_psi = 0.d0 + accu_xhi_phi = 0.d0 + double precision :: accu_chi_phi, accu_xhi_psi, accu_chi_psi, accu_xhi_phi + double precision :: mat_ovlp(2,2),eigval_tmp(2),eigvec(2,2),mat_ovlp_orig(2,2) + do j = 1, n + accu_chi_phi += VL(j,i) * VR(j,i) + accu_xhi_psi += VL(j,i+1) * VR(j,i+1) + accu_chi_psi += VL(j,i) * VR(j,i+1) + accu_xhi_phi += VL(j,i+1) * VR(j,i) + enddo + mat_ovlp_orig(1,1) = accu_chi_phi + mat_ovlp_orig(2,1) = accu_xhi_phi + mat_ovlp_orig(1,2) = accu_chi_psi + mat_ovlp_orig(2,2) = accu_xhi_psi + print*,'old overlap matrix ' + write(*,'(100(F16.10,X))')mat_ovlp_orig(1:2,1) + write(*,'(100(F16.10,X))')mat_ovlp_orig(1:2,2) + + + mat_ovlp(1,1) = accu_xhi_phi + mat_ovlp(2,1) = accu_chi_phi + mat_ovlp(1,2) = accu_xhi_psi + mat_ovlp(2,2) = accu_chi_psi + !print*,'accu_chi_phi = ',accu_chi_phi + !print*,'accu_xhi_psi = ',accu_xhi_psi + !print*,'accu_chi_psi = ',accu_chi_psi + !print*,'accu_xhi_phi = ',accu_xhi_phi + print*,'new overlap matrix ' + write(*,'(100(F16.10,X))')mat_ovlp(1:2,1) + write(*,'(100(F16.10,X))')mat_ovlp(1:2,2) + call lapack_diag(eigval_tmp,eigvec,mat_ovlp,2,2) + print*,'eigval_tmp(1) = ',eigval_tmp(1) + print*,'eigvec(1) = ',eigvec(1:2,1) + print*,'eigval_tmp(2) = ',eigval_tmp(2) + print*,'eigvec(2) = ',eigvec(1:2,2) + print*,'*****************' + phi_1_tilde = 0.d0 + phi_2_tilde = 0.d0 + chi_1_tilde = 0.d0 + chi_2_tilde = 0.d0 + do j = 1, n + phi_1_tilde(j) += VR(j,i) * eigvec(1,1) + VR(j,i+1) * eigvec(2,1) + phi_2_tilde(j) += VR(j,i) * eigvec(1,2) + VR(j,i+1) * eigvec(2,2) + chi_1_tilde(j) += VL(j,i+1) * eigvec(1,1) + VL(j,i) * eigvec(2,1) + chi_2_tilde(j) += VL(j,i+1) * eigvec(1,2) + VL(j,i) * eigvec(2,2) + enddo + VR(1:n,i) = phi_1_tilde(1:n) + VR(1:n,i+1) = phi_2_tilde(1:n) +! Vl(1:n,i) = -chi_1_tilde(1:n) +! Vl(1:n,i+1) = chi_2_tilde(1:n) + i+=1 + endif + endif + i+=1 + enddo !print *, ' right eigenvect bef' !do i = 1, n ! write(*, '(1000(F16.10,X))') VR(:,i) @@ -331,7 +400,7 @@ subroutine non_hrmt_bieig(n, A, thr_d, thr_nd, leigvec, reigvec, n_real_eigv, ei !thr = 100d0 thr = Im_thresh_tcscf do i = 1, n - !print*, 'Re(i) + Im(i)', WR(i), WI(i) + print*, 'Re(i) + Im(i)', WR(i), WI(i) if(dabs(WI(i)) .lt. thr) then n_good += 1 else @@ -405,7 +474,7 @@ subroutine non_hrmt_bieig(n, A, thr_d, thr_nd, leigvec, reigvec, n_real_eigv, ei if( (accu_nd .lt. thr_nd) .and. (dabs(accu_d-dble(n_real_eigv))/dble(n_real_eigv) .lt. thr_d) ) then - !print *, ' lapack vectors are normalized and bi-orthogonalized' + print *, ' lapack vectors are normalized and bi-orthogonalized' deallocate(S) return @@ -422,13 +491,14 @@ subroutine non_hrmt_bieig(n, A, thr_d, thr_nd, leigvec, reigvec, n_real_eigv, ei else - !print *, ' lapack vectors are not normalized neither bi-orthogonalized' + print *, ' lapack vectors are not normalized neither bi-orthogonalized' ! --- ! call impose_orthog_degen_eigvec(n, eigval, reigvec) ! call impose_orthog_degen_eigvec(n, eigval, leigvec) + call reorder_degen_eigvec(n, eigval, leigvec, reigvec) call impose_biorthog_degen_eigvec(n, eigval, leigvec, reigvec) diff --git a/src/non_hermit_dav/gram_schmit.irp.f b/plugins/local/non_hermit_dav/gram_schmit.irp.f similarity index 100% rename from src/non_hermit_dav/gram_schmit.irp.f rename to plugins/local/non_hermit_dav/gram_schmit.irp.f diff --git a/src/non_hermit_dav/htilde_mat.irp.f b/plugins/local/non_hermit_dav/htilde_mat.irp.f similarity index 100% rename from src/non_hermit_dav/htilde_mat.irp.f rename to plugins/local/non_hermit_dav/htilde_mat.irp.f diff --git a/src/non_hermit_dav/lapack_diag_non_hermit.irp.f b/plugins/local/non_hermit_dav/lapack_diag_non_hermit.irp.f similarity index 95% rename from src/non_hermit_dav/lapack_diag_non_hermit.irp.f rename to plugins/local/non_hermit_dav/lapack_diag_non_hermit.irp.f index 0d652af4..836bf707 100644 --- a/src/non_hermit_dav/lapack_diag_non_hermit.irp.f +++ b/plugins/local/non_hermit_dav/lapack_diag_non_hermit.irp.f @@ -1857,7 +1857,7 @@ subroutine check_biorthog(n, m, Vl, Vr, accu_d, accu_nd, S, thr_d, thr_nd, stop_ integer :: i, j double precision, allocatable :: SS(:,:) - !print *, ' check bi-orthogonality' + print *, ' check bi-orthogonality' ! --- @@ -1865,10 +1865,10 @@ subroutine check_biorthog(n, m, Vl, Vr, accu_d, accu_nd, S, thr_d, thr_nd, stop_ , Vl, size(Vl, 1), Vr, size(Vr, 1) & , 0.d0, S, size(S, 1) ) - !print *, ' overlap matrix:' - !do i = 1, m - ! write(*,'(1000(F16.10,X))') S(i,:) - !enddo + print *, ' overlap matrix:' + do i = 1, m + write(*,'(1000(F16.10,X))') S(i,:) + enddo accu_d = 0.d0 accu_nd = 0.d0 @@ -1883,8 +1883,8 @@ subroutine check_biorthog(n, m, Vl, Vr, accu_d, accu_nd, S, thr_d, thr_nd, stop_ enddo accu_nd = dsqrt(accu_nd) / dble(m) - !print *, ' accu_nd = ', accu_nd - !print *, ' accu_d = ', dabs(accu_d-dble(m))/dble(m) + print *, ' accu_nd = ', accu_nd + print *, ' accu_d = ', dabs(accu_d-dble(m))/dble(m) ! --- @@ -1944,6 +1944,96 @@ subroutine check_orthog(n, m, V, accu_d, accu_nd, S) end subroutine check_orthog ! --- +subroutine reorder_degen_eigvec(n, e0, L0, R0) + + implicit none + + integer, intent(in) :: n + double precision, intent(in) :: e0(n) + double precision, intent(inout) :: L0(n,n), R0(n,n) + + logical :: complex_root + integer :: i, j, k, m + double precision :: ei, ej, de, de_thr + double precision :: accu_d, accu_nd + integer, allocatable :: deg_num(:) + double precision, allocatable :: L(:,:), R(:,:), S(:,:), S_inv_half(:,:) + + ! --- + + allocate( deg_num(n) ) + do i = 1, n + deg_num(i) = 1 + enddo + + de_thr = thr_degen_tc + + do i = 1, n-1 + ei = e0(i) + + ! already considered in degen vectors + if(deg_num(i).eq.0) cycle + + do j = i+1, n + ej = e0(j) + de = dabs(ei - ej) + + if(de .lt. de_thr) then + deg_num(i) = deg_num(i) + 1 + deg_num(j) = 0 + endif + + enddo + enddo + + do i = 1, n + if(deg_num(i) .gt. 1) then + print *, ' degen on', i, deg_num(i), e0(i) + endif + enddo + + ! --- + + do i = 1, n + m = deg_num(i) + + if(m .gt. 1) then + + allocate(L(n,m)) + allocate(R(n,m),S(m,m)) + + do j = 1, m + L(1:n,j) = L0(1:n,i+j-1) + R(1:n,j) = R0(1:n,i+j-1) + enddo + + call dgemm( 'T', 'N', m, m, n, 1.d0 & + , L, size(L, 1), R, size(R, 1) & + , 0.d0, S, size(S, 1) ) + print*,'Overlap matrix ' + accu_nd = 0.D0 + do j = 1, m + write(*,'(100(F16.10,X))')S(1:m,j) + do k = 1, m + if(j==k)cycle + accu_nd += dabs(S(j,k)) + enddo + enddo + print*,'accu_nd = ',accu_nd +! if(accu_nd .gt.1.d-10)then +! stop +! endif + do j = 1, m + L0(1:n,i+j-1) = L(1:n,j) + R0(1:n,i+j-1) = R(1:n,j) + enddo + + deallocate(L, R,S) + + endif + enddo + +end subroutine reorder_degen_eigvec subroutine impose_biorthog_degen_eigvec(n, e0, L0, R0) @@ -1987,11 +2077,11 @@ subroutine impose_biorthog_degen_eigvec(n, e0, L0, R0) enddo enddo - !do i = 1, n - ! if(deg_num(i) .gt. 1) then - ! print *, ' degen on', i, deg_num(i), e0(i) - ! endif - !enddo + do i = 1, n + if(deg_num(i) .gt. 1) then + print *, ' degen on', i, deg_num(i), e0(i) + endif + enddo ! --- @@ -2010,7 +2100,7 @@ subroutine impose_biorthog_degen_eigvec(n, e0, L0, R0) ! --- - call impose_orthog_svd(n, m, L) +! call impose_orthog_svd(n, m, L) call impose_orthog_svd(n, m, R) !call impose_orthog_GramSchmidt(n, m, L) !call impose_orthog_GramSchmidt(n, m, R) @@ -2031,6 +2121,7 @@ subroutine impose_biorthog_degen_eigvec(n, e0, L0, R0) !deallocate(S, S_inv_half) call impose_biorthog_svd(n, m, L, R) +! call impose_biorthog_inverse(n, m, L, R) !call impose_biorthog_qr(n, m, thr_d, thr_nd, L, R) @@ -2045,6 +2136,7 @@ subroutine impose_biorthog_degen_eigvec(n, e0, L0, R0) endif enddo +! call impose_biorthog_inverse(n, n, L0, R0) end subroutine impose_biorthog_degen_eigvec @@ -2420,10 +2512,10 @@ subroutine impose_biorthog_svd(n, m, L, R) , L, size(L, 1), R, size(R, 1) & , 0.d0, S, size(S, 1) ) - !print *, ' overlap bef SVD: ' - !do i = 1, m - ! write(*, '(1000(F16.10,X))') S(i,:) - !enddo + print *, ' overlap bef SVD: ' + do i = 1, m + write(*, '(1000(F16.10,X))') S(i,:) + enddo ! --- @@ -2495,10 +2587,10 @@ subroutine impose_biorthog_svd(n, m, L, R) , L, size(L, 1), R, size(R, 1) & , 0.d0, S, size(S, 1) ) - !print *, ' overlap aft SVD: ' - !do i = 1, m - ! write(*, '(1000(F16.10,X))') S(i,:) - !enddo + print *, ' overlap aft SVD: ' + do i = 1, m + write(*, '(1000(F16.10,X))') S(i,:) + enddo deallocate(S) @@ -2506,6 +2598,50 @@ subroutine impose_biorthog_svd(n, m, L, R) end subroutine impose_biorthog_svd +subroutine impose_biorthog_inverse(n, m, L, R) + + implicit none + + integer, intent(in) :: n, m + double precision, intent(inout) :: L(n,m) + double precision, intent(in) :: R(n,m) + double precision, allocatable :: Lt(:,:),S(:,:) + integer :: i,j + allocate(Lt(m,n)) + allocate(S(m,m)) + + call dgemm( 'T', 'N', m, m, n, 1.d0 & + , L, size(L, 1), R, size(R, 1) & + , 0.d0, S, size(S, 1) ) + + print *, ' overlap bef SVD: ' + do i = 1, m + write(*, '(1000(F16.10,X))') S(i,:) + enddo + + call get_pseudo_inverse(R,n,n,m,Lt,m,1.d-6) + do i = 1, m + do j = 1, n + L(j,i) = Lt(i,j) + enddo + enddo + ! --- + + call dgemm( 'T', 'N', m, m, n, 1.d0 & + , L, size(L, 1), R, size(R, 1) & + , 0.d0, S, size(S, 1) ) + + print *, ' overlap aft SVD: ' + do i = 1, m + write(*, '(1000(F16.10,X))') S(i,:) + enddo + + deallocate(S,Lt) + + +end subroutine impose_biorthog_svd + + ! --- subroutine impose_weighted_biorthog_qr(m, n, thr_d, thr_nd, Vl, W, Vr) diff --git a/src/non_hermit_dav/new_routines.irp.f b/plugins/local/non_hermit_dav/new_routines.irp.f similarity index 100% rename from src/non_hermit_dav/new_routines.irp.f rename to plugins/local/non_hermit_dav/new_routines.irp.f diff --git a/src/non_hermit_dav/project.irp.f b/plugins/local/non_hermit_dav/project.irp.f similarity index 100% rename from src/non_hermit_dav/project.irp.f rename to plugins/local/non_hermit_dav/project.irp.f diff --git a/src/non_hermit_dav/utils.irp.f b/plugins/local/non_hermit_dav/utils.irp.f similarity index 100% rename from src/non_hermit_dav/utils.irp.f rename to plugins/local/non_hermit_dav/utils.irp.f diff --git a/src/ortho_three_e_ints/NEED b/plugins/local/ortho_three_e_ints/NEED similarity index 100% rename from src/ortho_three_e_ints/NEED rename to plugins/local/ortho_three_e_ints/NEED diff --git a/src/ortho_three_e_ints/io_6_index_tensor.irp.f b/plugins/local/ortho_three_e_ints/io_6_index_tensor.irp.f similarity index 100% rename from src/ortho_three_e_ints/io_6_index_tensor.irp.f rename to plugins/local/ortho_three_e_ints/io_6_index_tensor.irp.f diff --git a/src/ortho_three_e_ints/mu_j_ints_usual_mos.irp.f b/plugins/local/ortho_three_e_ints/mu_j_ints_usual_mos.irp.f similarity index 100% rename from src/ortho_three_e_ints/mu_j_ints_usual_mos.irp.f rename to plugins/local/ortho_three_e_ints/mu_j_ints_usual_mos.irp.f diff --git a/plugins/local/qmckl/LIB b/plugins/local/qmckl/LIB new file mode 100644 index 00000000..a9fabb84 --- /dev/null +++ b/plugins/local/qmckl/LIB @@ -0,0 +1 @@ +-lqmckl diff --git a/plugins/local/qmckl/NEED b/plugins/local/qmckl/NEED new file mode 100644 index 00000000..d2066b18 --- /dev/null +++ b/plugins/local/qmckl/NEED @@ -0,0 +1 @@ +nuclei diff --git a/plugins/local/qmckl/README.md b/plugins/local/qmckl/README.md new file mode 100644 index 00000000..ebc4b089 --- /dev/null +++ b/plugins/local/qmckl/README.md @@ -0,0 +1,4 @@ +#QMCkl + +Info related to the QMCkl library. + diff --git a/plugins/local/qmckl/qmckl.F90 b/plugins/local/qmckl/qmckl.F90 new file mode 100644 index 00000000..94ac962f --- /dev/null +++ b/plugins/local/qmckl/qmckl.F90 @@ -0,0 +1 @@ +#include diff --git a/src/tc_bi_ortho/31.tc_bi_ortho.bats b/plugins/local/tc_bi_ortho/31.tc_bi_ortho.bats similarity index 100% rename from src/tc_bi_ortho/31.tc_bi_ortho.bats rename to plugins/local/tc_bi_ortho/31.tc_bi_ortho.bats diff --git a/src/tc_bi_ortho/EZFIO.cfg b/plugins/local/tc_bi_ortho/EZFIO.cfg similarity index 100% rename from src/tc_bi_ortho/EZFIO.cfg rename to plugins/local/tc_bi_ortho/EZFIO.cfg diff --git a/src/tc_bi_ortho/NEED b/plugins/local/tc_bi_ortho/NEED similarity index 100% rename from src/tc_bi_ortho/NEED rename to plugins/local/tc_bi_ortho/NEED diff --git a/src/tc_bi_ortho/compute_deltamu_right.irp.f b/plugins/local/tc_bi_ortho/compute_deltamu_right.irp.f similarity index 100% rename from src/tc_bi_ortho/compute_deltamu_right.irp.f rename to plugins/local/tc_bi_ortho/compute_deltamu_right.irp.f diff --git a/src/tc_bi_ortho/dav_h_tc_s2.irp.f b/plugins/local/tc_bi_ortho/dav_h_tc_s2.irp.f similarity index 100% rename from src/tc_bi_ortho/dav_h_tc_s2.irp.f rename to plugins/local/tc_bi_ortho/dav_h_tc_s2.irp.f diff --git a/src/tc_bi_ortho/dressing_vectors_lr.irp.f b/plugins/local/tc_bi_ortho/dressing_vectors_lr.irp.f similarity index 100% rename from src/tc_bi_ortho/dressing_vectors_lr.irp.f rename to plugins/local/tc_bi_ortho/dressing_vectors_lr.irp.f diff --git a/src/tc_bi_ortho/e_corr_bi_ortho.irp.f b/plugins/local/tc_bi_ortho/e_corr_bi_ortho.irp.f similarity index 100% rename from src/tc_bi_ortho/e_corr_bi_ortho.irp.f rename to plugins/local/tc_bi_ortho/e_corr_bi_ortho.irp.f diff --git a/src/tc_bi_ortho/h_biortho.irp.f b/plugins/local/tc_bi_ortho/h_biortho.irp.f similarity index 100% rename from src/tc_bi_ortho/h_biortho.irp.f rename to plugins/local/tc_bi_ortho/h_biortho.irp.f diff --git a/plugins/local/tc_bi_ortho/h_mat_triple.irp.f b/plugins/local/tc_bi_ortho/h_mat_triple.irp.f new file mode 100644 index 00000000..6f5697a2 --- /dev/null +++ b/plugins/local/tc_bi_ortho/h_mat_triple.irp.f @@ -0,0 +1,391 @@ +subroutine get_excitation_general(key_i,key_j, Nint,degree_array,holes_array, particles_array,phase) + use bitmasks + BEGIN_DOC +! returns the array, for each spin, of holes/particles between key_i and key_j +! +! with the following convention: a^+_{particle} a_{hole}|key_i> = |key_j> + END_DOC + include 'utils/constants.include.F' + implicit none + integer, intent(in) :: Nint + integer(bit_kind), intent(in) :: key_j(Nint,2),key_i(Nint,2) + integer, intent(out) :: holes_array(100,2),particles_array(100,2),degree_array(2) + double precision, intent(out) :: phase + integer :: ispin,k,i,pos + integer(bit_kind) :: key_hole, key_particle + integer(bit_kind) :: xorvec(N_int_max,2) + holes_array = -1 + particles_array = -1 + degree_array = 0 + do i = 1, N_int + xorvec(i,1) = xor( key_i(i,1), key_j(i,1)) + xorvec(i,2) = xor( key_i(i,2), key_j(i,2)) + degree_array(1) += popcnt(xorvec(i,1)) + degree_array(2) += popcnt(xorvec(i,2)) + enddo + degree_array(1) = shiftr(degree_array(1),1) + degree_array(2) = shiftr(degree_array(2),1) + + do ispin = 1, 2 + k = 1 + !!! GETTING THE HOLES + do i = 1, N_int + key_hole = iand(xorvec(i,ispin),key_i(i,ispin)) + do while(key_hole .ne.0_bit_kind) + pos = trailz(key_hole) + holes_array(k,ispin) = 1+ bit_kind_size * (i-1) + pos + key_hole = ibclr(key_hole,pos) + k += 1 + if(k .gt.100)then + print*,'WARNING in get_excitation_general' + print*,'More than a 100-th excitation for spin ',ispin + print*,'stoping ...' + stop + endif + enddo + enddo + enddo + do ispin = 1, 2 + k = 1 + !!! GETTING THE PARTICLES + do i = 1, N_int + key_particle = iand(xor(key_i(i,ispin),key_j(i,ispin)),key_j(i,ispin)) + do while(key_particle .ne.0_bit_kind) + pos = trailz(key_particle) + particles_array(k,ispin) = 1+ bit_kind_size * (i-1) + pos + key_particle = ibclr(key_particle,pos) + k += 1 + if(k .gt.100)then + print*,'WARNING in get_excitation_general ' + print*,'More than a 100-th excitation for spin ',ispin + print*,'stoping ...' + stop + endif + enddo + enddo + enddo + integer :: h,p, i_ok + integer(bit_kind), allocatable :: det_i(:,:),det_ip(:,:) + integer :: exc(0:2,2,2) + double precision :: phase_tmp + allocate(det_i(Nint,2),det_ip(N_int,2)) + det_i = key_i + phase = 1.d0 + do ispin = 1, 2 + do i = 1, degree_array(ispin) + h = holes_array(i,ispin) + p = particles_array(i,ispin) + det_ip = det_i + call do_single_excitation(det_ip,h,p,ispin,i_ok) + if(i_ok == -1)then + print*,'excitation was not possible ' + stop + endif + call get_single_excitation(det_i,det_ip,exc,phase_tmp,Nint) + phase *= phase_tmp + det_i = det_ip + enddo + enddo + +end + +subroutine get_holes_general(key_i, key_j,Nint, holes_array) + use bitmasks + BEGIN_DOC +! returns the array, per spin, of holes between key_i and key_j +! +! with the following convention: a_{hole}|key_i> --> |key_j> + END_DOC + implicit none + integer, intent(in) :: Nint + integer(bit_kind), intent(in) :: key_j(Nint,2),key_i(Nint,2) + integer, intent(out) :: holes_array(100,2) + integer(bit_kind) :: key_hole + integer :: ispin,k,i,pos + holes_array = -1 + do ispin = 1, 2 + k = 1 + do i = 1, N_int + key_hole = iand(xor(key_i(i,ispin),key_j(i,ispin)),key_i(i,ispin)) + do while(key_hole .ne.0_bit_kind) + pos = trailz(key_hole) + holes_array(k,ispin) = 1+ bit_kind_size * (i-1) + pos + key_hole = ibclr(key_hole,pos) + k += 1 + if(k .gt.100)then + print*,'WARNING in get_holes_general' + print*,'More than a 100-th excitation for spin ',ispin + print*,'stoping ...' + stop + endif + enddo + enddo + enddo +end + +subroutine get_particles_general(key_i, key_j,Nint,particles_array) + use bitmasks + BEGIN_DOC +! returns the array, per spin, of particles between key_i and key_j +! +! with the following convention: a^dagger_{particle}|key_i> --> |key_j> + END_DOC + implicit none + integer, intent(in) :: Nint + integer(bit_kind), intent(in) :: key_j(Nint,2),key_i(Nint,2) + integer, intent(out) :: particles_array(100,2) + integer(bit_kind) :: key_particle + integer :: ispin,k,i,pos + particles_array = -1 + do ispin = 1, 2 + k = 1 + do i = 1, N_int + key_particle = iand(xor(key_i(i,ispin),key_j(i,ispin)),key_j(i,ispin)) + do while(key_particle .ne.0_bit_kind) + pos = trailz(key_particle) + particles_array(k,ispin) = 1+ bit_kind_size * (i-1) + pos + key_particle = ibclr(key_particle,pos) + k += 1 + if(k .gt.100)then + print*,'WARNING in get_holes_general' + print*,'More than a 100-th excitation for spin ',ispin + print*,'Those are the two determinants' + call debug_det(key_i, N_int) + call debug_det(key_j, N_int) + print*,'stoping ...' + stop + endif + enddo + enddo + enddo +end + +subroutine get_phase_general(key_i,Nint,degree, holes_array, particles_array,phase) + implicit none + integer, intent(in) :: degree(2), Nint + integer(bit_kind), intent(in) :: key_i(Nint,2) + integer, intent(in) :: holes_array(100,2),particles_array(100,2) + double precision, intent(out) :: phase + integer :: i,ispin,h,p, i_ok + integer(bit_kind), allocatable :: det_i(:,:),det_ip(:,:) + integer :: exc(0:2,2,2) + double precision :: phase_tmp + allocate(det_i(Nint,2),det_ip(N_int,2)) + det_i = key_i + phase = 1.d0 + do ispin = 1, 2 + do i = 1, degree(ispin) + h = holes_array(i,ispin) + p = particles_array(i,ispin) + det_ip = det_i + call do_single_excitation(det_ip,h,p,ispin,i_ok) + if(i_ok == -1)then + print*,'excitation was not possible ' + stop + endif + call get_single_excitation(det_i,det_ip,exc,phase_tmp,Nint) + phase *= phase_tmp + det_i = det_ip + enddo + enddo + +end + +subroutine H_tc_s2_u_0_with_pure_three(v_0, s_0, u_0, N_st, sze) + BEGIN_DOC + ! Computes $v_0 = H^TC | u_0\rangle$ WITH PURE TRIPLE EXCITATION TERMS + ! + ! Assumes that the determinants are in psi_det + ! + ! istart, iend, ishift, istep are used in ZMQ parallelization. + END_DOC + + use bitmasks + implicit none + + integer, intent(in) :: N_st,sze + double precision, intent(in) :: u_0(sze,N_st) + double precision, intent(out) :: v_0(sze,N_st), s_0(sze,N_st) + call H_tc_s2_u_0_opt(v_0, s_0, u_0, N_st, sze) + integer :: i,j,degree,ist + double precision :: hmono, htwoe, hthree, htot + do i = 1, N_det + do j = 1, N_det + call get_excitation_degree(psi_det(1,1,i),psi_det(1,1,j),degree,N_int) + if(degree .ne. 3)cycle + call triple_htilde_mu_mat_fock_bi_ortho(N_int, psi_det(1,1,i), psi_det(1,1,j), hmono, htwoe, hthree, htot) + do ist = 1, N_st + v_0(i,ist) += htot * u_0(j,ist) + enddo + enddo + enddo +end + +subroutine H_tc_s2_u_0_with_pure_three_omp(v_0, s_0, u_0, N_st, sze) + BEGIN_DOC + ! Computes $v_0 = H^TC | u_0\rangle$ WITH PURE TRIPLE EXCITATION TERMS + ! + ! Assumes that the determinants are in psi_det + ! + ! istart, iend, ishift, istep are used in ZMQ parallelization. + END_DOC + + use bitmasks + implicit none + + integer, intent(in) :: N_st,sze + double precision, intent(in) :: u_0(sze,N_st) + double precision, intent(out) :: v_0(sze,N_st), s_0(sze,N_st) + call H_tc_s2_u_0_opt(v_0, s_0, u_0, N_st, sze) + integer :: i,j,degree,ist + double precision :: hmono, htwoe, hthree, htot + !$OMP PARALLEL DO DEFAULT(NONE) SCHEDULE(dynamic,8) & + !$OMP SHARED(N_st, N_det, N_int, psi_det, u_0, v_0) & + !$OMP PRIVATE(ist, i, j, degree, hmono, htwoe, hthree,htot) + do i = 1, N_det + do j = 1, N_det + call get_excitation_degree(psi_det(1,1,i),psi_det(1,1,j),degree,N_int) + if(degree .ne. 3)cycle + call triple_htilde_mu_mat_fock_bi_ortho(N_int, psi_det(1,1,i), psi_det(1,1,j), hmono, htwoe, hthree, htot) + do ist = 1, N_st + v_0(i,ist) += htot * u_0(j,ist) + enddo + enddo + enddo + !$OMP END PARALLEL DO +end + +! --- + +subroutine H_tc_s2_dagger_u_0_with_pure_three(v_0, s_0, u_0, N_st, sze) + BEGIN_DOC + ! Computes $v_0 = (H^TC)^dagger | u_0\rangle$ WITH PURE TRIPLE EXCITATION TERMS + ! + ! Assumes that the determinants are in psi_det + ! + ! istart, iend, ishift, istep are used in ZMQ parallelization. + END_DOC + + use bitmasks + implicit none + + integer, intent(in) :: N_st,sze + double precision, intent(in) :: u_0(sze,N_st) + double precision, intent(out) :: v_0(sze,N_st), s_0(sze,N_st) + call H_tc_s2_dagger_u_0_opt(v_0, s_0, u_0, N_st, sze) + integer :: i,j,degree,ist + double precision :: hmono, htwoe, hthree, htot + do i = 1, N_det + do j = 1, N_det + call get_excitation_degree(psi_det(1,1,i),psi_det(1,1,j),degree,N_int) + if(degree .ne. 3)cycle + call triple_htilde_mu_mat_fock_bi_ortho(N_int, psi_det(1,1,j), psi_det(1,1,i), hmono, htwoe, hthree, htot) + do ist = 1, N_st + v_0(i,ist) += htot * u_0(j,ist) + enddo + enddo + enddo +end + +subroutine H_tc_s2_dagger_u_0_with_pure_three_omp(v_0, s_0, u_0, N_st, sze) + BEGIN_DOC + ! Computes $v_0 = (H^TC)^dagger | u_0\rangle$ WITH PURE TRIPLE EXCITATION TERMS + ! + ! Assumes that the determinants are in psi_det + ! + ! istart, iend, ishift, istep are used in ZMQ parallelization. + END_DOC + + use bitmasks + implicit none + + integer, intent(in) :: N_st,sze + double precision, intent(in) :: u_0(sze,N_st) + double precision, intent(out) :: v_0(sze,N_st), s_0(sze,N_st) + call H_tc_s2_dagger_u_0_opt(v_0, s_0, u_0, N_st, sze) + integer :: i,j,degree,ist + double precision :: hmono, htwoe, hthree, htot + !$OMP PARALLEL DO DEFAULT(NONE) SCHEDULE(dynamic,8) & + !$OMP SHARED(N_st, N_det, N_int, psi_det, u_0, v_0) & + !$OMP PRIVATE(ist, i, j, degree, hmono, htwoe, hthree,htot) + do i = 1, N_det + do j = 1, N_det + call get_excitation_degree(psi_det(1,1,i),psi_det(1,1,j),degree,N_int) + if(degree .ne. 3)cycle + call triple_htilde_mu_mat_fock_bi_ortho(N_int, psi_det(1,1,j), psi_det(1,1,i), hmono, htwoe, hthree, htot) + do ist = 1, N_st + v_0(i,ist) += htot * u_0(j,ist) + enddo + enddo + enddo + !$OMP END PARALLEL DO +end + +! --- +subroutine triple_htilde_mu_mat_fock_bi_ortho(Nint, key_j, key_i, hmono, htwoe, hthree, htot) + use bitmasks + BEGIN_DOC +! for triple excitation +!! +!! WARNING !! +! +! Genuine triple excitations of the same spin are not yet implemented + END_DOC + implicit none + integer(bit_kind), intent(in) :: key_j(N_int,2),key_i(N_int,2) + integer, intent(in) :: Nint + double precision, intent(out) :: hmono, htwoe, hthree, htot + integer :: degree + integer :: h1, p1, h2, p2, s1, s2, h3, p3, s3 + integer :: holes_array(100,2),particles_array(100,2),degree_array(2) + double precision :: phase,sym_3_e_int_from_6_idx_tensor + + hmono = 0.d0 + htwoe = 0.d0 + hthree = 0.d0 + htot = 0.d0 + call get_excitation_general(key_j, key_i, Nint,degree_array,holes_array, particles_array,phase) + degree = degree_array(1) + degree_array(2) + if(degree .ne. 3)return + if(degree_array(1)==3.or.degree_array(2)==3)then + if(degree_array(1) == 3)then + h1 = holes_array(1,1) + h2 = holes_array(2,1) + h3 = holes_array(3,1) + p1 = particles_array(1,1) + p2 = particles_array(2,1) + p3 = particles_array(3,1) + else + h1 = holes_array(1,2) + h2 = holes_array(2,2) + h3 = holes_array(3,2) + p1 = particles_array(1,2) + p2 = particles_array(2,2) + p3 = particles_array(3,2) + endif + hthree = sym_3_e_int_from_6_idx_tensor(p3, p2, p1, h3, h2, h1) + else + if(degree_array(1) == 2.and.degree_array(2) == 1)then ! double alpha + single beta + h1 = holes_array(1,1) + h2 = holes_array(2,1) + h3 = holes_array(1,2) + p1 = particles_array(1,1) + p2 = particles_array(2,1) + p3 = particles_array(1,2) + else if(degree_array(2) == 2 .and. degree_array(1) == 1)then ! double beta + single alpha + h1 = holes_array(1,2) + h2 = holes_array(2,2) + h3 = holes_array(1,1) + p1 = particles_array(1,2) + p2 = particles_array(2,2) + p3 = particles_array(1,1) + else + print*,'PB !!' + stop + endif + hthree = three_body_ints_bi_ort(p3,p2,p1,h3,h2,h1) - three_body_ints_bi_ort(p3,p2,p1,h3,h1,h2) + endif + hthree *= phase + htot = hthree + end + diff --git a/src/tc_bi_ortho/h_tc_bi_ortho_psi.irp.f b/plugins/local/tc_bi_ortho/h_tc_bi_ortho_psi.irp.f similarity index 100% rename from src/tc_bi_ortho/h_tc_bi_ortho_psi.irp.f rename to plugins/local/tc_bi_ortho/h_tc_bi_ortho_psi.irp.f diff --git a/src/tc_bi_ortho/h_tc_s2_u0.irp.f b/plugins/local/tc_bi_ortho/h_tc_s2_u0.irp.f similarity index 100% rename from src/tc_bi_ortho/h_tc_s2_u0.irp.f rename to plugins/local/tc_bi_ortho/h_tc_s2_u0.irp.f diff --git a/src/tc_bi_ortho/h_tc_u0.irp.f b/plugins/local/tc_bi_ortho/h_tc_u0.irp.f similarity index 100% rename from src/tc_bi_ortho/h_tc_u0.irp.f rename to plugins/local/tc_bi_ortho/h_tc_u0.irp.f diff --git a/plugins/local/tc_bi_ortho/normal_ordered.irp.f b/plugins/local/tc_bi_ortho/normal_ordered.irp.f new file mode 100644 index 00000000..e65df450 --- /dev/null +++ b/plugins/local/tc_bi_ortho/normal_ordered.irp.f @@ -0,0 +1,911 @@ + +! --- + +BEGIN_PROVIDER [ double precision, normal_two_body_bi_orth, (mo_num, mo_num, mo_num, mo_num)] + + BEGIN_DOC + ! + ! Normal ordering of the three body interaction on the HF density + ! + END_DOC + + use bitmasks ! you need to include the bitmasks_module.f90 features + + implicit none + + integer :: i, ii, ipoint + integer :: h1, p1, h2, p2 + integer :: hh1, hh2, pp1, pp2 + integer :: Ne(2) + double precision :: wall0, wall1, walli, wallf + integer, allocatable :: occ(:,:) + integer(bit_kind), allocatable :: key_i_core(:,:) + + PROVIDE mo_class + PROVIDE list_act n_act_orb + PROVIDE N_int + + print*,' Providing normal_two_body_bi_orth ...' + call wall_time(walli) + + if(read_tc_norm_ord) then + + open(unit=11, form="unformatted", file=trim(ezfio_filename)//'/work/normal_two_body_bi_orth', action="read") + read(11) normal_two_body_bi_orth + close(11) + + else + + double precision, allocatable :: tmp_3d(:,:,:) + double precision, allocatable :: tmp1(:,:,:), tmp2(:,:) + double precision, allocatable :: tmpval_1(:), tmpval_2(:), tmpvec_1(:,:), tmpvec_2(:,:), tmpvec_3(:,:) + double precision, allocatable :: tmp(:,:,:,:) + double precision, allocatable :: int2_grad1_u12_bimo_t_tmp(:,:,:,:), mos_l_in_r_array_transp_tmp(:,:), mos_r_in_r_array_transp_tmp(:,:) + + PROVIDE int2_grad1_u12_bimo_t + PROVIDE mos_l_in_r_array_transp mos_r_in_r_array_transp + + allocate(int2_grad1_u12_bimo_t_tmp(n_points_final_grid,3,mo_num,mo_num)) + allocate(mos_l_in_r_array_transp_tmp(n_points_final_grid,mo_num)) + allocate(mos_r_in_r_array_transp_tmp(n_points_final_grid,mo_num)) + + !$OMP PARALLEL & + !$OMP DEFAULT (NONE) & + !$OMP PRIVATE (h1, p1) & + !$OMP SHARED (mo_num, mo_class, & + !$OMP int2_grad1_u12_bimo_t, int2_grad1_u12_bimo_t_tmp, & + !$OMP mos_l_in_r_array_transp, mos_l_in_r_array_transp_tmp, & + !$OMP mos_r_in_r_array_transp, mos_r_in_r_array_transp_tmp) + !$OMP DO + do h1 = 1, mo_num + + mos_l_in_r_array_transp_tmp(:,h1) = 0.d0 + mos_r_in_r_array_transp_tmp(:,h1) = 0.d0 + + if(mo_class(h1) .ne. "Active") cycle + + mos_l_in_r_array_transp_tmp(:,h1) = mos_l_in_r_array_transp(:,h1) + mos_r_in_r_array_transp_tmp(:,h1) = mos_r_in_r_array_transp(:,h1) + + do p1 = 1, mo_num + int2_grad1_u12_bimo_t_tmp(:,:,p1,h1) = 0.d0 + if(mo_class(p1) .ne. "Active") cycle + + int2_grad1_u12_bimo_t_tmp(:,:,p1,h1) = int2_grad1_u12_bimo_t(:,:,p1,h1) + enddo + enddo + !$OMP END DO + !$OMP END PARALLEL + + allocate( occ(N_int*bit_kind_size,2) ) + allocate( key_i_core(N_int,2) ) + + if(core_tc_op) then + do i = 1, N_int + key_i_core(i,1) = xor(ref_bitmask(i,1), core_bitmask(i,1)) + key_i_core(i,2) = xor(ref_bitmask(i,2), core_bitmask(i,2)) + enddo + call bitstring_to_list_ab(key_i_core, occ, Ne, N_int) + else + call bitstring_to_list_ab(ref_bitmask, occ, Ne, N_int) + endif + + allocate(tmp(mo_num,mo_num,mo_num,mo_num)) + + ! --- + ! aba contraction + + print*,' Providing aba_contraction ...' + call wall_time(wall0) + + tmp = 0.d0 + + call set_multiple_levels_omp(.false.) + + !$OMP PARALLEL & + !$OMP DEFAULT (NONE) & + !$OMP PRIVATE (ipoint, hh1, pp1, hh2, pp2, h1, p1, h2, p2, i, ii, tmp1, tmp2, & + !$OMP tmpval_1, tmpval_2, tmpvec_1, tmpvec_2) & + !$OMP SHARED (n_points_final_grid, Ne, occ, mo_num, n_act_orb, list_act, & + !$OMP mos_l_in_r_array_transp_tmp, mos_r_in_r_array_transp_tmp, & + !$OMP final_weight_at_r_vector, int2_grad1_u12_bimo_t_tmp, & + !$OMP mos_l_in_r_array_transp, mos_r_in_r_array_transp, int2_grad1_u12_bimo_t, & + !$OMP tmp) + + allocate(tmp1(n_points_final_grid,3,mo_num), tmp2(n_points_final_grid,mo_num)) + allocate(tmpval_1(n_points_final_grid), tmpval_2(n_points_final_grid)) + allocate(tmpvec_1(n_points_final_grid,3), tmpvec_2(n_points_final_grid,3)) + + !$OMP DO + do hh1 = 1, n_act_orb + h1 = list_act(hh1) + + tmp1 = 0.d0 + do ii = 1, Ne(2) + i = occ(ii,2) + + do ipoint = 1, n_points_final_grid + tmpval_1(ipoint) = final_weight_at_r_vector(ipoint) * mos_l_in_r_array_transp(ipoint,i) * mos_r_in_r_array_transp(ipoint,i) + tmpval_2(ipoint) = final_weight_at_r_vector(ipoint) * mos_l_in_r_array_transp(ipoint,i) * mos_r_in_r_array_transp(ipoint,h1) + tmpvec_1(ipoint,1) = final_weight_at_r_vector(ipoint) * int2_grad1_u12_bimo_t(ipoint,1,i,i) * mos_r_in_r_array_transp(ipoint,h1) + tmpvec_1(ipoint,2) = final_weight_at_r_vector(ipoint) * int2_grad1_u12_bimo_t(ipoint,2,i,i) * mos_r_in_r_array_transp(ipoint,h1) + tmpvec_1(ipoint,3) = final_weight_at_r_vector(ipoint) * int2_grad1_u12_bimo_t(ipoint,3,i,i) * mos_r_in_r_array_transp(ipoint,h1) + tmpvec_2(ipoint,1) = final_weight_at_r_vector(ipoint) * int2_grad1_u12_bimo_t(ipoint,1,i,h1) * mos_r_in_r_array_transp(ipoint,i) + tmpvec_2(ipoint,2) = final_weight_at_r_vector(ipoint) * int2_grad1_u12_bimo_t(ipoint,2,i,h1) * mos_r_in_r_array_transp(ipoint,i) + tmpvec_2(ipoint,3) = final_weight_at_r_vector(ipoint) * int2_grad1_u12_bimo_t(ipoint,3,i,h1) * mos_r_in_r_array_transp(ipoint,i) + enddo + + do pp1 = 1, n_act_orb + p1 = list_act(pp1) + do ipoint = 1, n_points_final_grid + tmp1(ipoint,1,p1) = tmp1(ipoint,1,p1) + mos_l_in_r_array_transp(ipoint,p1) * (tmpvec_1(ipoint,1) - tmpvec_2(ipoint,1)) & + + tmpval_1(ipoint) * int2_grad1_u12_bimo_t(ipoint,1,p1,h1) - tmpval_2(ipoint) * int2_grad1_u12_bimo_t(ipoint,1,p1,i) + tmp1(ipoint,2,p1) = tmp1(ipoint,2,p1) + mos_l_in_r_array_transp(ipoint,p1) * (tmpvec_1(ipoint,2) - tmpvec_2(ipoint,2)) & + + tmpval_1(ipoint) * int2_grad1_u12_bimo_t(ipoint,2,p1,h1) - tmpval_2(ipoint) * int2_grad1_u12_bimo_t(ipoint,2,p1,i) + tmp1(ipoint,3,p1) = tmp1(ipoint,3,p1) + mos_l_in_r_array_transp(ipoint,p1) * (tmpvec_1(ipoint,3) - tmpvec_2(ipoint,3)) & + + tmpval_1(ipoint) * int2_grad1_u12_bimo_t(ipoint,3,p1,h1) - tmpval_2(ipoint) * int2_grad1_u12_bimo_t(ipoint,3,p1,i) + enddo + enddo + + enddo ! ii + + call dgemm( 'T', 'N', mo_num*mo_num, mo_num, 3*n_points_final_grid, 1.d0 & + , int2_grad1_u12_bimo_t_tmp(1,1,1,1), 3*n_points_final_grid & + , tmp1(1,1,1), 3*n_points_final_grid & + , 1.d0, tmp(1,1,1,h1), mo_num*mo_num) + + do pp1 = 1, n_act_orb + p1 = list_act(pp1) + + tmp2 = 0.d0 + do ii = 1, Ne(2) + i = occ(ii,2) + + do ipoint = 1, n_points_final_grid + tmpval_1(ipoint) = final_weight_at_r_vector(ipoint) * & + ( int2_grad1_u12_bimo_t(ipoint,1,i,i) * int2_grad1_u12_bimo_t(ipoint,1,p1,h1) & + + int2_grad1_u12_bimo_t(ipoint,2,i,i) * int2_grad1_u12_bimo_t(ipoint,2,p1,h1) & + + int2_grad1_u12_bimo_t(ipoint,3,i,i) * int2_grad1_u12_bimo_t(ipoint,3,p1,h1) & + - int2_grad1_u12_bimo_t(ipoint,1,p1,i) * int2_grad1_u12_bimo_t(ipoint,1,i,h1) & + - int2_grad1_u12_bimo_t(ipoint,2,p1,i) * int2_grad1_u12_bimo_t(ipoint,2,i,h1) & + - int2_grad1_u12_bimo_t(ipoint,3,p1,i) * int2_grad1_u12_bimo_t(ipoint,3,i,h1) ) + enddo + + do hh2 = 1, n_act_orb + h2 = list_act(hh2) + do ipoint = 1, n_points_final_grid + tmp2(ipoint,h2) = tmp2(ipoint,h2) + mos_r_in_r_array_transp(ipoint,h2) * tmpval_1(ipoint) + enddo + enddo + + enddo ! ii + + call dgemm( 'T', 'N', mo_num, mo_num, n_points_final_grid, 1.d0 & + , mos_l_in_r_array_transp_tmp(1,1), n_points_final_grid & + , tmp2(1,1), n_points_final_grid & + , 1.d0, tmp(1,1,p1,h1), mo_num) + + enddo ! p1 + enddo ! h1 + + !$OMP END DO + + deallocate(tmp1, tmp2) + deallocate(tmpval_1, tmpval_2) + deallocate(tmpvec_1, tmpvec_2) + + !$OMP END PARALLEL + + + ! purely open-shell part + if(Ne(2) < Ne(1)) then + + call set_multiple_levels_omp(.false.) + + !$OMP PARALLEL & + !$OMP DEFAULT (NONE) & + !$OMP PRIVATE (ipoint, hh1, pp1, hh2, pp2, h1, p1, h2, p2, i, ii, tmp1, tmp2, & + !$OMP tmpval_1, tmpval_2, tmpvec_1, tmpvec_2) & + !$OMP SHARED (n_points_final_grid, Ne, occ, mo_num, n_act_orb, list_act, & + !$OMP mos_l_in_r_array_transp_tmp, mos_r_in_r_array_transp_tmp, & + !$OMP final_weight_at_r_vector, int2_grad1_u12_bimo_t_tmp, & + !$OMP mos_l_in_r_array_transp, mos_r_in_r_array_transp, int2_grad1_u12_bimo_t, & + !$OMP tmp) + + Allocate(tmp1(n_points_final_grid,3,mo_num), tmp2(n_points_final_grid,mo_num)) + Allocate(tmpval_1(n_points_final_grid), tmpval_2(n_points_final_grid)) + Allocate(tmpvec_1(n_points_final_grid,3), tmpvec_2(n_points_final_grid,3)) + + !$OMP DO + + do hh1 = 1, n_act_orb + h1 = list_act(hh1) + + tmp1 = 0.d0 + do ii = Ne(2) + 1, Ne(1) + i = occ(ii,1) + + do ipoint = 1, n_points_final_grid + tmpval_1(ipoint) = final_weight_at_r_vector(ipoint) * mos_l_in_r_array_transp(ipoint,i) * mos_r_in_r_array_transp(ipoint,i) + tmpval_2(ipoint) = final_weight_at_r_vector(ipoint) * mos_l_in_r_array_transp(ipoint,i) * mos_r_in_r_array_transp(ipoint,h1) + tmpvec_1(ipoint,1) = final_weight_at_r_vector(ipoint) * int2_grad1_u12_bimo_t(ipoint,1,i,i) * mos_r_in_r_array_transp(ipoint,h1) + tmpvec_1(ipoint,2) = final_weight_at_r_vector(ipoint) * int2_grad1_u12_bimo_t(ipoint,2,i,i) * mos_r_in_r_array_transp(ipoint,h1) + tmpvec_1(ipoint,3) = final_weight_at_r_vector(ipoint) * int2_grad1_u12_bimo_t(ipoint,3,i,i) * mos_r_in_r_array_transp(ipoint,h1) + tmpvec_2(ipoint,1) = final_weight_at_r_vector(ipoint) * int2_grad1_u12_bimo_t(ipoint,1,i,h1) * mos_r_in_r_array_transp(ipoint,i) + tmpvec_2(ipoint,2) = final_weight_at_r_vector(ipoint) * int2_grad1_u12_bimo_t(ipoint,2,i,h1) * mos_r_in_r_array_transp(ipoint,i) + tmpvec_2(ipoint,3) = final_weight_at_r_vector(ipoint) * int2_grad1_u12_bimo_t(ipoint,3,i,h1) * mos_r_in_r_array_transp(ipoint,i) + enddo + + do pp1 = 1, n_act_orb + p1 = list_act(pp1) + + do ipoint = 1, n_points_final_grid + tmp1(ipoint,1,p1) = tmp1(ipoint,1,p1) + mos_l_in_r_array_transp(ipoint,p1) * (tmpvec_1(ipoint,1) - tmpvec_2(ipoint,1)) & + + tmpval_1(ipoint) * int2_grad1_u12_bimo_t(ipoint,1,p1,h1) - tmpval_2(ipoint) * int2_grad1_u12_bimo_t(ipoint,1,p1,i) + tmp1(ipoint,2,p1) = tmp1(ipoint,2,p1) + mos_l_in_r_array_transp(ipoint,p1) * (tmpvec_1(ipoint,2) - tmpvec_2(ipoint,2)) & + + tmpval_1(ipoint) * int2_grad1_u12_bimo_t(ipoint,2,p1,h1) - tmpval_2(ipoint) * int2_grad1_u12_bimo_t(ipoint,2,p1,i) + tmp1(ipoint,3,p1) = tmp1(ipoint,3,p1) + mos_l_in_r_array_transp(ipoint,p1) * (tmpvec_1(ipoint,3) - tmpvec_2(ipoint,3)) & + + tmpval_1(ipoint) * int2_grad1_u12_bimo_t(ipoint,3,p1,h1) - tmpval_2(ipoint) * int2_grad1_u12_bimo_t(ipoint,3,p1,i) + enddo + enddo + + enddo ! ii + + call dgemm( 'T', 'N', mo_num*mo_num, mo_num, 3*n_points_final_grid, 0.5d0 & + , int2_grad1_u12_bimo_t_tmp(1,1,1,1), 3*n_points_final_grid & + , tmp1(1,1,1), 3*n_points_final_grid & + , 1.d0, tmp(1,1,1,h1), mo_num*mo_num) + + do pp1 = 1, n_act_orb + p1 = list_act(pp1) + + tmp2 = 0.d0 + do ii = Ne(2) + 1, Ne(1) + i = occ(ii,1) + + do ipoint = 1, n_points_final_grid + tmpval_1(ipoint) = final_weight_at_r_vector(ipoint) * & + ( int2_grad1_u12_bimo_t(ipoint,1,i,i) * int2_grad1_u12_bimo_t(ipoint,1,p1,h1) & + + int2_grad1_u12_bimo_t(ipoint,2,i,i) * int2_grad1_u12_bimo_t(ipoint,2,p1,h1) & + + int2_grad1_u12_bimo_t(ipoint,3,i,i) * int2_grad1_u12_bimo_t(ipoint,3,p1,h1) & + - int2_grad1_u12_bimo_t(ipoint,1,p1,i) * int2_grad1_u12_bimo_t(ipoint,1,i,h1) & + - int2_grad1_u12_bimo_t(ipoint,2,p1,i) * int2_grad1_u12_bimo_t(ipoint,2,i,h1) & + - int2_grad1_u12_bimo_t(ipoint,3,p1,i) * int2_grad1_u12_bimo_t(ipoint,3,i,h1) ) + enddo + + do hh2 = 1, n_act_orb + h2 = list_act(hh2) + do ipoint = 1, n_points_final_grid + tmp2(ipoint,h2) = tmp2(ipoint,h2) + mos_r_in_r_array_transp(ipoint,h2) * tmpval_1(ipoint) + enddo + enddo + + enddo ! ii + + call dgemm( 'T', 'N', mo_num, mo_num, n_points_final_grid, 0.5d0 & + , mos_l_in_r_array_transp_tmp(1,1), n_points_final_grid & + , tmp2(1,1), n_points_final_grid & + , 1.d0, tmp(1,1,p1,h1), mo_num) + + enddo ! p1 + enddo ! h1 + !$OMP END DO + + deallocate(tmp1, tmp2) + deallocate(tmpval_1, tmpval_2) + deallocate(tmpvec_1, tmpvec_2) + + !$OMP END PARALLEL + endif + + tmp = -0.5d0 * tmp + call sum_A_At(tmp(1,1,1,1), mo_num*mo_num) + + call wall_time(wall1) + print*,' Wall time for aba_contraction', wall1-wall0 + + normal_two_body_bi_orth = tmp + + ! --- + ! aab contraction + + print*,' Providing aab_contraction ...' + call wall_time(wall0) + + tmp = 0.d0 + + call set_multiple_levels_omp(.false.) + + !$OMP PARALLEL & + !$OMP DEFAULT (NONE) & + !$OMP PRIVATE (ipoint, hh1, pp1, hh2, pp2, ii, i, h1, p1, h2, p2, tmp1, tmp2, & + !$OMP tmpval_1, tmpvec_1) & + !$OMP SHARED (n_points_final_grid, mo_num, Ne, occ, n_act_orb, list_act, & + !$OMP mos_l_in_r_array_transp_tmp, mos_r_in_r_array_transp_tmp, & + !$OMP final_weight_at_r_vector, int2_grad1_u12_bimo_t_tmp, & + !$OMP mos_l_in_r_array_transp, mos_r_in_r_array_transp, int2_grad1_u12_bimo_t, & + !$OMP tmp) + + allocate(tmp1(n_points_final_grid,3,mo_num)) + allocate(tmp2(n_points_final_grid,mo_num)) + allocate(tmpval_1(n_points_final_grid)) + allocate(tmpvec_1(n_points_final_grid,3)) + + !$OMP DO + + do hh1 = 1, n_act_orb + h1 = list_act(hh1) + + tmp1 = 0.d0 + do ii = 1, Ne(2) + i = occ(ii,2) + + do ipoint = 1, n_points_final_grid + tmpval_1(ipoint) = final_weight_at_r_vector(ipoint) * mos_l_in_r_array_transp(ipoint,i) * mos_r_in_r_array_transp(ipoint,i) + tmpvec_1(ipoint,1) = final_weight_at_r_vector(ipoint) * int2_grad1_u12_bimo_t(ipoint,1,i,i) * mos_r_in_r_array_transp(ipoint,h1) + tmpvec_1(ipoint,2) = final_weight_at_r_vector(ipoint) * int2_grad1_u12_bimo_t(ipoint,2,i,i) * mos_r_in_r_array_transp(ipoint,h1) + tmpvec_1(ipoint,3) = final_weight_at_r_vector(ipoint) * int2_grad1_u12_bimo_t(ipoint,3,i,i) * mos_r_in_r_array_transp(ipoint,h1) + enddo + + do pp1 = 1, n_act_orb + p1 = list_act(pp1) + do ipoint = 1, n_points_final_grid + tmp1(ipoint,1,p1) = tmp1(ipoint,1,p1) + mos_l_in_r_array_transp(ipoint,p1) * tmpvec_1(ipoint,1) + tmpval_1(ipoint) * int2_grad1_u12_bimo_t(ipoint,1,p1,h1) + tmp1(ipoint,2,p1) = tmp1(ipoint,2,p1) + mos_l_in_r_array_transp(ipoint,p1) * tmpvec_1(ipoint,2) + tmpval_1(ipoint) * int2_grad1_u12_bimo_t(ipoint,2,p1,h1) + tmp1(ipoint,3,p1) = tmp1(ipoint,3,p1) + mos_l_in_r_array_transp(ipoint,p1) * tmpvec_1(ipoint,3) + tmpval_1(ipoint) * int2_grad1_u12_bimo_t(ipoint,3,p1,h1) + enddo + enddo + + enddo ! ii + + call dgemm( 'T', 'N', mo_num*mo_num, mo_num, 3*n_points_final_grid, 1.d0 & + , int2_grad1_u12_bimo_t_tmp(1,1,1,1), 3*n_points_final_grid & + , tmp1(1,1,1), 3*n_points_final_grid & + , 1.d0, tmp(1,1,1,h1), mo_num*mo_num) + + do pp1 = 1, n_act_orb + p1 = list_act(pp1) + + tmp2 = 0.d0 + do ii = 1, Ne(2) + i = occ(ii,2) + + do ipoint = 1, n_points_final_grid + tmpval_1(ipoint) = final_weight_at_r_vector(ipoint) * ( int2_grad1_u12_bimo_t(ipoint,1,i,i) * int2_grad1_u12_bimo_t(ipoint,1,p1,h1) & + + int2_grad1_u12_bimo_t(ipoint,2,i,i) * int2_grad1_u12_bimo_t(ipoint,2,p1,h1) & + + int2_grad1_u12_bimo_t(ipoint,3,i,i) * int2_grad1_u12_bimo_t(ipoint,3,p1,h1) ) + enddo + + do hh2 = 1, n_act_orb + h2 = list_act(hh2) + do ipoint = 1, n_points_final_grid + tmp2(ipoint,h2) = tmp2(ipoint,h2) + mos_r_in_r_array_transp(ipoint,h2) * tmpval_1(ipoint) + enddo + enddo + + enddo ! ii + + call dgemm( 'T', 'N', mo_num, mo_num, n_points_final_grid, 1.d0 & + , mos_l_in_r_array_transp_tmp(1,1), n_points_final_grid & + , tmp2(1,1), n_points_final_grid & + , 1.d0, tmp(1,1,p1,h1), mo_num) + + enddo ! p1 + enddo ! h1 + + !$OMP END DO + + deallocate(tmp1, tmp2) + deallocate(tmpval_1) + deallocate(tmpvec_1) + + !$OMP END PARALLEL + + tmp = -0.5d0 * tmp + + !$OMP PARALLEL & + !$OMP DEFAULT (NONE) & + !$OMP PRIVATE (h1, h2, p1, p2) & + !$OMP SHARED (tmp, mo_num) + + !$OMP DO COLLAPSE(2) + do h1 = 1, mo_num + do h2 = 1, mo_num + do p1 = 1, mo_num + do p2 = p1, mo_num + tmp(p2,h2,p1,h1) -= tmp(p1,h2,p2,h1) + enddo + enddo + enddo + enddo + !$OMP END DO + + !$OMP DO COLLAPSE(2) + do h1 = 1, mo_num + do h2 = 1, mo_num + do p1 = 2, mo_num + do p2 = 1, p1-1 + tmp(p2,h2,p1,h1) = -tmp(p1,h2,p2,h1) + enddo + enddo + enddo + enddo + !$OMP END DO + + !$OMP DO + do h1 = 1, mo_num-1 + do h2 = h1+1, mo_num + do p1 = 2, mo_num + do p2 = 1, p1-1 + tmp(p2,h2,p1,h1) *= -1.d0 + enddo + enddo + enddo + enddo + !$OMP END DO + !$OMP END PARALLEL + + call wall_time(wall1) + print*,' Wall time for aab_contraction', wall1-wall0 + + normal_two_body_bi_orth += tmp + + ! --- + ! aaa contraction + + if(Ne(2) .ge. 3) then + + print*,' Providing aaa_contraction ...' + call wall_time(wall0) + + tmp = 0.d0 + + call set_multiple_levels_omp(.false.) + + !$OMP PARALLEL & + !$OMP DEFAULT (NONE) & + !$OMP PRIVATE (ipoint, i, ii, hh1, hh2, pp1, pp2, h1, h2, p1, p2, tmp1, tmp2, tmp_3d, & + !$OMP tmpval_1, tmpval_2, & + !$OMP tmpvec_1, tmpvec_2, tmpvec_3) & + !$OMP SHARED (n_points_final_grid, Ne, occ, mo_num, n_act_orb, list_act, & + !$OMP mos_l_in_r_array_transp_tmp, mos_r_in_r_array_transp_tmp, & + !$OMP final_weight_at_r_vector, int2_grad1_u12_bimo_t_tmp, & + !$OMP mos_l_in_r_array_transp, mos_r_in_r_array_transp, int2_grad1_u12_bimo_t, & + !$OMP tmp) + + allocate(tmp_3d(mo_num,mo_num,mo_num)) + allocate(tmp1(n_points_final_grid,3,mo_num)) + allocate(tmp2(n_points_final_grid,mo_num)) + allocate(tmpval_1(n_points_final_grid)) + allocate(tmpval_2(n_points_final_grid)) + allocate(tmpvec_1(n_points_final_grid,3)) + allocate(tmpvec_2(n_points_final_grid,3)) + allocate(tmpvec_3(n_points_final_grid,3)) + + !$OMP DO + + do hh1 = 1, n_act_orb + h1 = list_act(hh1) + + tmp1 = 0.d0 + do ii = 1, Ne(2) + i = occ(ii,2) + + do ipoint = 1, n_points_final_grid + tmpval_1(ipoint) = final_weight_at_r_vector(ipoint) * mos_l_in_r_array_transp(ipoint,i) * mos_r_in_r_array_transp(ipoint,i) + + tmpvec_1(ipoint,1) = final_weight_at_r_vector(ipoint) * int2_grad1_u12_bimo_t(ipoint,1,i,i) * mos_r_in_r_array_transp(ipoint,h1) + tmpvec_1(ipoint,2) = final_weight_at_r_vector(ipoint) * int2_grad1_u12_bimo_t(ipoint,2,i,i) * mos_r_in_r_array_transp(ipoint,h1) + tmpvec_1(ipoint,3) = final_weight_at_r_vector(ipoint) * int2_grad1_u12_bimo_t(ipoint,3,i,i) * mos_r_in_r_array_transp(ipoint,h1) + enddo + + do pp1 = 1, n_act_orb + p1 = list_act(pp1) + do ipoint = 1, n_points_final_grid + tmp1(ipoint,1,p1) = tmp1(ipoint,1,p1) + mos_l_in_r_array_transp(ipoint,p1) * tmpvec_1(ipoint,1) + tmpval_1(ipoint) * int2_grad1_u12_bimo_t(ipoint,1,p1,h1) + tmp1(ipoint,2,p1) = tmp1(ipoint,2,p1) + mos_l_in_r_array_transp(ipoint,p1) * tmpvec_1(ipoint,2) + tmpval_1(ipoint) * int2_grad1_u12_bimo_t(ipoint,2,p1,h1) + tmp1(ipoint,3,p1) = tmp1(ipoint,3,p1) + mos_l_in_r_array_transp(ipoint,p1) * tmpvec_1(ipoint,3) + tmpval_1(ipoint) * int2_grad1_u12_bimo_t(ipoint,3,p1,h1) + enddo + enddo + + enddo ! ii + + call dgemm( 'T', 'N', mo_num*mo_num, mo_num, 3*n_points_final_grid, 1.d0 & + , int2_grad1_u12_bimo_t_tmp(1,1,1,1), 3*n_points_final_grid & + , tmp1(1,1,1), 3*n_points_final_grid & + , 1.d0, tmp(1,1,1,h1), mo_num*mo_num) + + tmp1 = 0.d0 + do ii = 1, Ne(2) + i = occ(ii,2) + + do ipoint = 1, n_points_final_grid + + tmpval_2(ipoint) = final_weight_at_r_vector(ipoint) * mos_l_in_r_array_transp(ipoint,i) * mos_r_in_r_array_transp(ipoint,h1) + + tmpvec_2(ipoint,1) = final_weight_at_r_vector(ipoint) * int2_grad1_u12_bimo_t(ipoint,1,i,h1) * mos_r_in_r_array_transp(ipoint,i) + tmpvec_2(ipoint,2) = final_weight_at_r_vector(ipoint) * int2_grad1_u12_bimo_t(ipoint,2,i,h1) * mos_r_in_r_array_transp(ipoint,i) + tmpvec_2(ipoint,3) = final_weight_at_r_vector(ipoint) * int2_grad1_u12_bimo_t(ipoint,3,i,h1) * mos_r_in_r_array_transp(ipoint,i) + enddo + + do pp2 = 1, n_act_orb + p2 = list_act(pp2) + do ipoint = 1, n_points_final_grid + tmp1(ipoint,1,p2) = tmp1(ipoint,1,p2) + tmpval_2(ipoint) * int2_grad1_u12_bimo_t(ipoint,1,p2,i) + mos_l_in_r_array_transp(ipoint,p2) * tmpvec_2(ipoint,1) + tmp1(ipoint,2,p2) = tmp1(ipoint,2,p2) + tmpval_2(ipoint) * int2_grad1_u12_bimo_t(ipoint,2,p2,i) + mos_l_in_r_array_transp(ipoint,p2) * tmpvec_2(ipoint,2) + tmp1(ipoint,3,p2) = tmp1(ipoint,3,p2) + tmpval_2(ipoint) * int2_grad1_u12_bimo_t(ipoint,3,p2,i) + mos_l_in_r_array_transp(ipoint,p2) * tmpvec_2(ipoint,3) + enddo + enddo + + enddo ! ii + + call dgemm( 'T', 'N', mo_num, mo_num*mo_num, 3*n_points_final_grid, 1.d0 & + , tmp1(1,1,1), 3*n_points_final_grid & + , int2_grad1_u12_bimo_t_tmp(1,1,1,1), 3*n_points_final_grid & + , 0.d0, tmp_3d(1,1,1), mo_num) + + do p1 = 1, mo_num + do h2 = 1, mo_num + do p2 = 1, mo_num + tmp(p2,h2,p1,h1) = tmp(p2,h2,p1,h1) + tmp_3d(p2,p1,h2) + enddo + enddo + enddo + + do pp1 = 1, n_act_orb + p1 = list_act(pp1) + + tmp2 = 0.d0 + do ii = 1, Ne(2) + i = occ(ii,2) + + do ipoint = 1, n_points_final_grid + + tmpval_1(ipoint) = final_weight_at_r_vector(ipoint) * & + ( int2_grad1_u12_bimo_t(ipoint,1,i,i) * int2_grad1_u12_bimo_t(ipoint,1,p1,h1) & + + int2_grad1_u12_bimo_t(ipoint,2,i,i) * int2_grad1_u12_bimo_t(ipoint,2,p1,h1) & + + int2_grad1_u12_bimo_t(ipoint,3,i,i) * int2_grad1_u12_bimo_t(ipoint,3,p1,h1) ) + + tmpvec_1(ipoint,1) = final_weight_at_r_vector(ipoint) * int2_grad1_u12_bimo_t(ipoint,1,p1,i) * mos_r_in_r_array_transp(ipoint,h1) + tmpvec_1(ipoint,2) = final_weight_at_r_vector(ipoint) * int2_grad1_u12_bimo_t(ipoint,2,p1,i) * mos_r_in_r_array_transp(ipoint,h1) + tmpvec_1(ipoint,3) = final_weight_at_r_vector(ipoint) * int2_grad1_u12_bimo_t(ipoint,3,p1,i) * mos_r_in_r_array_transp(ipoint,h1) + enddo + + do hh2 = 1, n_act_orb + h2 = list_act(hh2) + + do ipoint = 1, n_points_final_grid + + tmp2(ipoint,h2) = tmp2(ipoint,h2) + mos_r_in_r_array_transp(ipoint,h2) * tmpval_1(ipoint) & + + int2_grad1_u12_bimo_t(ipoint,1,i,h2) * tmpvec_1(ipoint,1) & + + int2_grad1_u12_bimo_t(ipoint,2,i,h2) * tmpvec_1(ipoint,2) & + + int2_grad1_u12_bimo_t(ipoint,3,i,h2) * tmpvec_1(ipoint,3) + enddo + enddo + + enddo ! ii + + call dgemm( 'T', 'N', mo_num, mo_num, n_points_final_grid, 1.d0 & + , mos_l_in_r_array_transp_tmp(1,1), n_points_final_grid & + , tmp2(1,1), n_points_final_grid & + , 1.d0, tmp(1,1,p1,h1), mo_num) + + tmp1 = 0.d0 + tmp2 = 0.d0 + do ii = 1, Ne(2) + i = occ(ii,2) + + do ipoint = 1, n_points_final_grid + + tmpval_2(ipoint) = final_weight_at_r_vector(ipoint) * mos_l_in_r_array_transp(ipoint,p1) * mos_r_in_r_array_transp(ipoint,i) + + tmpvec_2(ipoint,1) = final_weight_at_r_vector(ipoint) * int2_grad1_u12_bimo_t(ipoint,1,i,h1) * mos_l_in_r_array_transp(ipoint,p1) + tmpvec_2(ipoint,2) = final_weight_at_r_vector(ipoint) * int2_grad1_u12_bimo_t(ipoint,2,i,h1) * mos_l_in_r_array_transp(ipoint,p1) + tmpvec_2(ipoint,3) = final_weight_at_r_vector(ipoint) * int2_grad1_u12_bimo_t(ipoint,3,i,h1) * mos_l_in_r_array_transp(ipoint,p1) + + tmpvec_3(ipoint,1) = final_weight_at_r_vector(ipoint) * int2_grad1_u12_bimo_t(ipoint,1,p1,i) * mos_l_in_r_array_transp(ipoint,i) + tmpvec_3(ipoint,2) = final_weight_at_r_vector(ipoint) * int2_grad1_u12_bimo_t(ipoint,2,p1,i) * mos_l_in_r_array_transp(ipoint,i) + tmpvec_3(ipoint,3) = final_weight_at_r_vector(ipoint) * int2_grad1_u12_bimo_t(ipoint,3,p1,i) * mos_l_in_r_array_transp(ipoint,i) + enddo + + do pp2 = 1, n_act_orb + p2 = list_act(pp2) + do ipoint = 1, n_points_final_grid + + tmp2(ipoint,p2) = tmp2(ipoint,p2) + int2_grad1_u12_bimo_t(ipoint,1,p2,i) * tmpvec_2(ipoint,1) + int2_grad1_u12_bimo_t(ipoint,1,p2,h1) * tmpvec_3(ipoint,1) & + + int2_grad1_u12_bimo_t(ipoint,2,p2,i) * tmpvec_2(ipoint,2) + int2_grad1_u12_bimo_t(ipoint,2,p2,h1) * tmpvec_3(ipoint,2) & + + int2_grad1_u12_bimo_t(ipoint,3,p2,i) * tmpvec_2(ipoint,3) + int2_grad1_u12_bimo_t(ipoint,3,p2,h1) * tmpvec_3(ipoint,3) + + tmp1(ipoint,1,p2) = tmp1(ipoint,1,p2) + tmpval_2(ipoint) * int2_grad1_u12_bimo_t(ipoint,1,i,p2) + tmp1(ipoint,2,p2) = tmp1(ipoint,2,p2) + tmpval_2(ipoint) * int2_grad1_u12_bimo_t(ipoint,2,i,p2) + tmp1(ipoint,3,p2) = tmp1(ipoint,3,p2) + tmpval_2(ipoint) * int2_grad1_u12_bimo_t(ipoint,3,i,p2) + enddo + enddo + + enddo ! ii + + call dgemm( 'T', 'N', mo_num, mo_num, 3*n_points_final_grid, 1.d0 & + , int2_grad1_u12_bimo_t_tmp(1,1,1,h1), 3*n_points_final_grid & + , tmp1(1,1,1), 3*n_points_final_grid & + , 1.d0, tmp(1,1,p1,h1), mo_num) + + call dgemm( 'T', 'N', mo_num, mo_num, n_points_final_grid, 1.d0 & + , tmp2(1,1), n_points_final_grid & + , mos_r_in_r_array_transp_tmp(1,1), n_points_final_grid & + , 1.d0, tmp(1,1,p1,h1), mo_num) + + enddo ! p1 + enddo ! h1 + !$OMP END DO + + deallocate(tmp_3d) + deallocate(tmp1) + deallocate(tmp2) + deallocate(tmpval_1) + deallocate(tmpval_2) + deallocate(tmpvec_1) + deallocate(tmpvec_2) + deallocate(tmpvec_3) + + !$OMP END PARALLEL + + ! purely open-shell part + if(Ne(2) < Ne(1)) then + + call set_multiple_levels_omp(.false.) + + !$OMP PARALLEL & + !$OMP DEFAULT (NONE) & + !$OMP PRIVATE (ipoint, i, ii, hh1, hh2, pp1, pp2, h1, h2, p1, p2, tmp_3d, tmp1, tmp2, & + !$OMP tmpval_1, tmpval_2, tmpvec_1, tmpvec_2, tmpvec_3) & + !$OMP SHARED (n_points_final_grid, Ne, occ, mo_num, n_act_orb, list_act, & + !$OMP mos_l_in_r_array_transp_tmp, mos_r_in_r_array_transp_tmp, & + !$OMP final_weight_at_r_vector, int2_grad1_u12_bimo_t_tmp, & + !$OMP mos_l_in_r_array_transp, mos_r_in_r_array_transp, int2_grad1_u12_bimo_t, & + !$OMP tmp) + + allocate(tmp_3d(mo_num,mo_num,mo_num)) + allocate(tmp1(n_points_final_grid,3,mo_num)) + allocate(tmp2(n_points_final_grid,mo_num)) + allocate(tmpval_1(n_points_final_grid)) + allocate(tmpval_2(n_points_final_grid)) + allocate(tmpvec_1(n_points_final_grid,3)) + allocate(tmpvec_2(n_points_final_grid,3)) + allocate(tmpvec_3(n_points_final_grid,3)) + + !$OMP DO + + do hh1 = 1, n_act_orb + h1 = list_act(hh1) + + tmp1 = 0.d0 + do ii = Ne(2) + 1, Ne(1) + i = occ(ii,1) + + do ipoint = 1, n_points_final_grid + + tmpval_1(ipoint) = final_weight_at_r_vector(ipoint) * mos_l_in_r_array_transp(ipoint,i) * mos_r_in_r_array_transp(ipoint,i) + + tmpvec_1(ipoint,1) = final_weight_at_r_vector(ipoint) * int2_grad1_u12_bimo_t(ipoint,1,i,i) * mos_r_in_r_array_transp(ipoint,h1) + tmpvec_1(ipoint,2) = final_weight_at_r_vector(ipoint) * int2_grad1_u12_bimo_t(ipoint,2,i,i) * mos_r_in_r_array_transp(ipoint,h1) + tmpvec_1(ipoint,3) = final_weight_at_r_vector(ipoint) * int2_grad1_u12_bimo_t(ipoint,3,i,i) * mos_r_in_r_array_transp(ipoint,h1) + enddo + + do pp1 = 1, n_act_orb + p1 = list_act(pp1) + do ipoint = 1, n_points_final_grid + tmp1(ipoint,1,p1) = tmp1(ipoint,1,p1) + mos_l_in_r_array_transp(ipoint,p1) * tmpvec_1(ipoint,1) + tmpval_1(ipoint) * int2_grad1_u12_bimo_t(ipoint,1,p1,h1) + tmp1(ipoint,2,p1) = tmp1(ipoint,2,p1) + mos_l_in_r_array_transp(ipoint,p1) * tmpvec_1(ipoint,2) + tmpval_1(ipoint) * int2_grad1_u12_bimo_t(ipoint,2,p1,h1) + tmp1(ipoint,3,p1) = tmp1(ipoint,3,p1) + mos_l_in_r_array_transp(ipoint,p1) * tmpvec_1(ipoint,3) + tmpval_1(ipoint) * int2_grad1_u12_bimo_t(ipoint,3,p1,h1) + enddo + enddo + + enddo ! ii + + call dgemm( 'T', 'N', mo_num*mo_num, mo_num, 3*n_points_final_grid, 0.5d0 & + , int2_grad1_u12_bimo_t_tmp(1,1,1,1), 3*n_points_final_grid & + , tmp1(1,1,1), 3*n_points_final_grid & + , 1.d0, tmp(1,1,1,h1), mo_num*mo_num) + + tmp1 = 0.d0 + do ii = Ne(2) + 1, Ne(1) + i = occ(ii,1) + + do ipoint = 1, n_points_final_grid + + tmpval_2(ipoint) = final_weight_at_r_vector(ipoint) * mos_l_in_r_array_transp(ipoint,i) * mos_r_in_r_array_transp(ipoint,h1) + + tmpvec_2(ipoint,1) = final_weight_at_r_vector(ipoint) * int2_grad1_u12_bimo_t(ipoint,1,i,h1) * mos_r_in_r_array_transp(ipoint,i) + tmpvec_2(ipoint,2) = final_weight_at_r_vector(ipoint) * int2_grad1_u12_bimo_t(ipoint,2,i,h1) * mos_r_in_r_array_transp(ipoint,i) + tmpvec_2(ipoint,3) = final_weight_at_r_vector(ipoint) * int2_grad1_u12_bimo_t(ipoint,3,i,h1) * mos_r_in_r_array_transp(ipoint,i) + enddo + + do pp2 = 1, n_act_orb + p2 = list_act(pp2) + do ipoint = 1, n_points_final_grid + tmp1(ipoint,1,p2) = tmp1(ipoint,1,p2) + tmpval_2(ipoint) * int2_grad1_u12_bimo_t(ipoint,1,p2,i) + mos_l_in_r_array_transp(ipoint,p2) * tmpvec_2(ipoint,1) + tmp1(ipoint,2,p2) = tmp1(ipoint,2,p2) + tmpval_2(ipoint) * int2_grad1_u12_bimo_t(ipoint,2,p2,i) + mos_l_in_r_array_transp(ipoint,p2) * tmpvec_2(ipoint,2) + tmp1(ipoint,3,p2) = tmp1(ipoint,3,p2) + tmpval_2(ipoint) * int2_grad1_u12_bimo_t(ipoint,3,p2,i) + mos_l_in_r_array_transp(ipoint,p2) * tmpvec_2(ipoint,3) + enddo + enddo + + enddo ! ii + + call dgemm( 'T', 'N', mo_num, mo_num*mo_num, 3*n_points_final_grid, 0.5d0 & + , tmp1(1,1,1), 3*n_points_final_grid & + , int2_grad1_u12_bimo_t_tmp(1,1,1,1), 3*n_points_final_grid & + , 0.d0, tmp_3d(1,1,1), mo_num) + + do p1 = 1, mo_num + do h2 = 1, mo_num + do p2 = 1, mo_num + tmp(p2,h2,p1,h1) = tmp(p2,h2,p1,h1) + tmp_3d(p2,p1,h2) + enddo + enddo + enddo + + do pp1 = 1, n_act_orb + p1 = list_act(pp1) + + tmp2 = 0.d0 + do ii = Ne(2) + 1, Ne(1) + i = occ(ii,1) + + do ipoint = 1, n_points_final_grid + + tmpval_1(ipoint) = final_weight_at_r_vector(ipoint) * & + ( int2_grad1_u12_bimo_t(ipoint,1,i,i) * int2_grad1_u12_bimo_t(ipoint,1,p1,h1) & + + int2_grad1_u12_bimo_t(ipoint,2,i,i) * int2_grad1_u12_bimo_t(ipoint,2,p1,h1) & + + int2_grad1_u12_bimo_t(ipoint,3,i,i) * int2_grad1_u12_bimo_t(ipoint,3,p1,h1) ) + + tmpvec_1(ipoint,1) = final_weight_at_r_vector(ipoint) * int2_grad1_u12_bimo_t(ipoint,1,p1,i) * mos_r_in_r_array_transp(ipoint,h1) + tmpvec_1(ipoint,2) = final_weight_at_r_vector(ipoint) * int2_grad1_u12_bimo_t(ipoint,2,p1,i) * mos_r_in_r_array_transp(ipoint,h1) + tmpvec_1(ipoint,3) = final_weight_at_r_vector(ipoint) * int2_grad1_u12_bimo_t(ipoint,3,p1,i) * mos_r_in_r_array_transp(ipoint,h1) + enddo + + do hh2 = 1, n_act_orb + h2 = list_act(hh2) + do ipoint = 1, n_points_final_grid + tmp2(ipoint,h2) = tmp2(ipoint,h2) + mos_r_in_r_array_transp(ipoint,h2) * tmpval_1(ipoint) & + + int2_grad1_u12_bimo_t(ipoint,1,i,h2) * tmpvec_1(ipoint,1) & + + int2_grad1_u12_bimo_t(ipoint,2,i,h2) * tmpvec_1(ipoint,2) & + + int2_grad1_u12_bimo_t(ipoint,3,i,h2) * tmpvec_1(ipoint,3) + enddo + enddo + + enddo ! ii + + call dgemm( 'T', 'N', mo_num, mo_num, n_points_final_grid, 0.5d0 & + , mos_l_in_r_array_transp_tmp(1,1), n_points_final_grid & + , tmp2(1,1), n_points_final_grid & + , 1.d0, tmp(1,1,p1,h1), mo_num) + + + tmp1 = 0.d0 + tmp2 = 0.d0 + do ii = Ne(2) + 1, Ne(1) + i = occ(ii,1) + + do ipoint = 1, n_points_final_grid + + tmpval_2(ipoint) = final_weight_at_r_vector(ipoint) * mos_l_in_r_array_transp(ipoint,p1) * mos_r_in_r_array_transp(ipoint,i) + + tmpvec_2(ipoint,1) = final_weight_at_r_vector(ipoint) * int2_grad1_u12_bimo_t(ipoint,1,i,h1) * mos_l_in_r_array_transp(ipoint,p1) + tmpvec_2(ipoint,2) = final_weight_at_r_vector(ipoint) * int2_grad1_u12_bimo_t(ipoint,2,i,h1) * mos_l_in_r_array_transp(ipoint,p1) + tmpvec_2(ipoint,3) = final_weight_at_r_vector(ipoint) * int2_grad1_u12_bimo_t(ipoint,3,i,h1) * mos_l_in_r_array_transp(ipoint,p1) + + tmpvec_3(ipoint,1) = final_weight_at_r_vector(ipoint) * int2_grad1_u12_bimo_t(ipoint,1,p1,i) * mos_l_in_r_array_transp(ipoint,i) + tmpvec_3(ipoint,2) = final_weight_at_r_vector(ipoint) * int2_grad1_u12_bimo_t(ipoint,2,p1,i) * mos_l_in_r_array_transp(ipoint,i) + tmpvec_3(ipoint,3) = final_weight_at_r_vector(ipoint) * int2_grad1_u12_bimo_t(ipoint,3,p1,i) * mos_l_in_r_array_transp(ipoint,i) + enddo + + do pp2 = 1, n_act_orb + p2 = list_act(pp2) + do ipoint = 1, n_points_final_grid + tmp1(ipoint,1,p2) = tmp1(ipoint,1,p2) + tmpval_2(ipoint) * int2_grad1_u12_bimo_t(ipoint,1,i,p2) + tmp1(ipoint,2,p2) = tmp1(ipoint,2,p2) + tmpval_2(ipoint) * int2_grad1_u12_bimo_t(ipoint,2,i,p2) + tmp1(ipoint,3,p2) = tmp1(ipoint,3,p2) + tmpval_2(ipoint) * int2_grad1_u12_bimo_t(ipoint,3,i,p2) + tmp2(ipoint,p2) = tmp2(ipoint,p2) + int2_grad1_u12_bimo_t(ipoint,1,p2,i) * tmpvec_2(ipoint,1) + int2_grad1_u12_bimo_t(ipoint,1,p2,h1) * tmpvec_3(ipoint,1) & + + int2_grad1_u12_bimo_t(ipoint,2,p2,i) * tmpvec_2(ipoint,2) + int2_grad1_u12_bimo_t(ipoint,2,p2,h1) * tmpvec_3(ipoint,2) & + + int2_grad1_u12_bimo_t(ipoint,3,p2,i) * tmpvec_2(ipoint,3) + int2_grad1_u12_bimo_t(ipoint,3,p2,h1) * tmpvec_3(ipoint,3) + enddo + enddo + + enddo ! ii + + call dgemm( 'T', 'N', mo_num, mo_num, n_points_final_grid, 0.5d0 & + , tmp2(1,1), n_points_final_grid & + , mos_r_in_r_array_transp_tmp(1,1), n_points_final_grid & + , 1.d0, tmp(1,1,p1,h1), mo_num) + + call dgemm( 'T', 'N', mo_num, mo_num, 3*n_points_final_grid, 0.5d0 & + , int2_grad1_u12_bimo_t_tmp(1,1,1,h1), 3*n_points_final_grid & + , tmp1(1,1,1), 3*n_points_final_grid & + , 1.d0, tmp(1,1,p1,h1), mo_num) + + enddo ! p1 + enddo ! h1 + !$OMP END DO + + deallocate(tmp_3d) + deallocate(tmp1) + deallocate(tmp2) + deallocate(tmpval_1) + deallocate(tmpval_2) + deallocate(tmpvec_1) + deallocate(tmpvec_2) + deallocate(tmpvec_3) + + !$OMP END PARALLEL + endif + + tmp = -0.5d0 * tmp + + !$OMP PARALLEL & + !$OMP DEFAULT (NONE) & + !$OMP PRIVATE (h1, h2, p1, p2) & + !$OMP SHARED (tmp, mo_num) + + !$OMP DO COLLAPSE(2) + do h1 = 1, mo_num + do h2 = 1, mo_num + do p1 = 1, mo_num + do p2 = p1, mo_num + tmp(p2,h2,p1,h1) -= tmp(p1,h2,p2,h1) + enddo + enddo + enddo + enddo + !$OMP END DO + + !$OMP DO COLLAPSE(2) + do h1 = 1, mo_num + do h2 = 1, mo_num + do p1 = 2, mo_num + do p2 = 1, p1-1 + tmp(p2,h2,p1,h1) = -tmp(p1,h2,p2,h1) + enddo + enddo + enddo + enddo + !$OMP END DO + + !$OMP DO + do h1 = 1, mo_num-1 + do h2 = h1+1, mo_num + do p1 = 2, mo_num + do p2 = 1, p1-1 + tmp(p2,h2,p1,h1) *= -1.d0 + enddo + enddo + enddo + enddo + !$OMP END DO + !$OMP END PARALLEL + + call wall_time(wall1) + print*,' Wall time for aaa_contraction', wall1-wall0 + + normal_two_body_bi_orth += tmp + endif ! Ne(2) .ge. 3 + + deallocate(tmp) + deallocate(int2_grad1_u12_bimo_t_tmp, mos_l_in_r_array_transp_tmp, mos_r_in_r_array_transp_tmp) + + endif ! read_tc_norm_ord + + if(write_tc_norm_ord.and.mpi_master) then + open(unit=11, form="unformatted", file=trim(ezfio_filename)//'/work/normal_two_body_bi_orth', action="write") + call ezfio_set_work_empty(.False.) + write(11) normal_two_body_bi_orth + close(11) + call ezfio_set_tc_keywords_io_tc_integ('Read') + endif + + call wall_time(wallf) + print*,' Wall time for normal_two_body_bi_orth ', wallf-walli + +END_PROVIDER + +! --- + diff --git a/src/tc_bi_ortho/normal_ordered_contractions.irp.f b/plugins/local/tc_bi_ortho/normal_ordered_contractions.irp.f similarity index 100% rename from src/tc_bi_ortho/normal_ordered_contractions.irp.f rename to plugins/local/tc_bi_ortho/normal_ordered_contractions.irp.f diff --git a/src/tc_bi_ortho/normal_ordered_old.irp.f b/plugins/local/tc_bi_ortho/normal_ordered_old.irp.f similarity index 99% rename from src/tc_bi_ortho/normal_ordered_old.irp.f rename to plugins/local/tc_bi_ortho/normal_ordered_old.irp.f index 6ee21a14..f40805a9 100644 --- a/src/tc_bi_ortho/normal_ordered_old.irp.f +++ b/plugins/local/tc_bi_ortho/normal_ordered_old.irp.f @@ -26,7 +26,7 @@ BEGIN_PROVIDER [ double precision, normal_two_body_bi_orth_old, (mo_num, mo_num, if(read_tc_norm_ord) then - open(unit=11, form="unformatted", file=trim(ezfio_filename)//'/work/normal_two_body_bi_orth_old', action="read") + open(unit=11, form="unformatted", file=trim(ezfio_filename)//'/work/normal_two_body_bi_orth', action="read") read(11) normal_two_body_bi_orth_old close(11) @@ -103,7 +103,7 @@ BEGIN_PROVIDER [ double precision, normal_two_body_bi_orth_old, (mo_num, mo_num, endif if(write_tc_norm_ord.and.mpi_master) then - open(unit=11, form="unformatted", file=trim(ezfio_filename)//'/work/normal_two_body_bi_orth_old', action="write") + open(unit=11, form="unformatted", file=trim(ezfio_filename)//'/work/normal_two_body_bi_orth', action="write") call ezfio_set_work_empty(.False.) write(11) normal_two_body_bi_orth_old close(11) diff --git a/plugins/local/tc_bi_ortho/normal_ordered_v0.irp.f b/plugins/local/tc_bi_ortho/normal_ordered_v0.irp.f new file mode 100644 index 00000000..784af9db --- /dev/null +++ b/plugins/local/tc_bi_ortho/normal_ordered_v0.irp.f @@ -0,0 +1,1022 @@ + +! --- + +BEGIN_PROVIDER [ double precision, normal_two_body_bi_orth_v0, (mo_num, mo_num, mo_num, mo_num)] + + BEGIN_DOC + ! + ! Normal ordering of the three body interaction on the HF density + ! + END_DOC + + use bitmasks ! you need to include the bitmasks_module.f90 features + + implicit none + + integer :: i, ii, h1, p1, h2, p2, ipoint + integer :: hh1, hh2, pp1, pp2 + integer :: Ne(2) + double precision :: wall0, wall1, walli, wallf + integer, allocatable :: occ(:,:) + integer(bit_kind), allocatable :: key_i_core(:,:) + + PROVIDE mo_class + PROVIDE N_int + + print*,' Providing normal_two_body_bi_orth_v0 ...' + call wall_time(walli) + + if(read_tc_norm_ord) then + + open(unit=11, form="unformatted", file=trim(ezfio_filename)//'/work/normal_two_body_bi_orth', action="read") + read(11) normal_two_body_bi_orth_v0 + close(11) + + else + + double precision, allocatable :: tmp_2d(:,:), tmp_3d(:,:,:) + double precision, allocatable :: tmp1(:,:,:), tmp2(:,:), tmp3(:,:,:) + double precision, allocatable :: tmpval_1(:), tmpval_2(:), tmpvec_1(:,:), tmpvec_2(:,:), tmpvec_3(:,:) + double precision, allocatable :: tmp(:,:,:,:) + double precision, allocatable :: int2_grad1_u12_bimo_t_tmp(:,:,:,:), mos_l_in_r_array_transp_tmp(:,:), mos_r_in_r_array_transp_tmp(:,:) + + PROVIDE int2_grad1_u12_bimo_t + PROVIDE mos_l_in_r_array_transp mos_r_in_r_array_transp + + allocate(int2_grad1_u12_bimo_t_tmp(n_points_final_grid,3,mo_num,mo_num)) + allocate(mos_l_in_r_array_transp_tmp(n_points_final_grid,mo_num)) + allocate(mos_r_in_r_array_transp_tmp(n_points_final_grid,mo_num)) + + !$OMP PARALLEL & + !$OMP DEFAULT (NONE) & + !$OMP PRIVATE (h1, p1) & + !$OMP SHARED (mo_num, mo_class, & + !$OMP int2_grad1_u12_bimo_t, int2_grad1_u12_bimo_t_tmp, & + !$OMP mos_l_in_r_array_transp, mos_l_in_r_array_transp_tmp, & + !$OMP mos_r_in_r_array_transp, mos_r_in_r_array_transp_tmp) + !$OMP DO + do h1 = 1, mo_num + + mos_l_in_r_array_transp_tmp(:,h1) = 0.d0 + mos_r_in_r_array_transp_tmp(:,h1) = 0.d0 + + if(mo_class(h1) .ne. "Active") cycle + + mos_l_in_r_array_transp_tmp(:,h1) = mos_l_in_r_array_transp(:,h1) + mos_r_in_r_array_transp_tmp(:,h1) = mos_r_in_r_array_transp(:,h1) + + do p1 = 1, mo_num + int2_grad1_u12_bimo_t_tmp(:,:,p1,h1) = 0.d0 + if(mo_class(p1) .ne. "Active") cycle + + int2_grad1_u12_bimo_t_tmp(:,:,p1,h1) = int2_grad1_u12_bimo_t(:,:,p1,h1) + enddo + enddo + !$OMP END DO + !$OMP END PARALLEL + + allocate( occ(N_int*bit_kind_size,2) ) + allocate( key_i_core(N_int,2) ) + + if(core_tc_op) then + do i = 1, N_int + key_i_core(i,1) = xor(ref_bitmask(i,1), core_bitmask(i,1)) + key_i_core(i,2) = xor(ref_bitmask(i,2), core_bitmask(i,2)) + enddo + call bitstring_to_list_ab(key_i_core, occ, Ne, N_int) + else + call bitstring_to_list_ab(ref_bitmask, occ, Ne, N_int) + endif + + allocate(tmp(mo_num,mo_num,mo_num,mo_num)) + + ! --- + ! aba contraction + + print*,' Providing aba_contraction_v0 ...' + call wall_time(wall0) + + call set_multiple_levels_omp(.false.) + + !$OMP PARALLEL & + !$OMP DEFAULT (NONE) & + !$OMP PRIVATE (ipoint, h1, p1, h2, p2, i, ii, & + !$OMP tmp_3d, tmp_2d, tmp1, tmp2, & + !$OMP tmpval_1, tmpval_2, tmpvec_1, tmpvec_2) & + !$OMP SHARED (n_points_final_grid, Ne, occ, mo_num, mo_class, & + !$OMP mos_l_in_r_array_transp_tmp, mos_r_in_r_array_transp_tmp, & + !$OMP int2_grad1_u12_bimo_t_tmp, final_weight_at_r_vector, & + !$OMP mos_l_in_r_array_transp, mos_r_in_r_array_transp, int2_grad1_u12_bimo_t, & + !$OMP tmp) + + allocate(tmp_3d(mo_num,mo_num,mo_num), tmp_2d(mo_num,mo_num)) + allocate(tmp1(n_points_final_grid,3,mo_num), tmp2(n_points_final_grid,mo_num)) + allocate(tmpval_1(n_points_final_grid), tmpval_2(n_points_final_grid)) + allocate(tmpvec_1(n_points_final_grid,3), tmpvec_2(n_points_final_grid,3)) + + tmp_3d = 0.d0 + tmp_2d = 0.d0 + tmp1 = 0.d0 + tmp2 = 0.d0 + tmpval_1 = 0.d0 + tmpval_2 = 0.d0 + tmpvec_1 = 0.d0 + tmpvec_2 = 0.d0 + + ! TODO: active electrons + + !$OMP DO + + do h1 = 1, mo_num + tmp(:,:,:,h1) = 0.d0 + if(mo_class(h1) .ne. "Active") cycle + + do ii = 1, Ne(2) + i = occ(ii,2) + + do ipoint = 1, n_points_final_grid + tmpval_1(ipoint) = final_weight_at_r_vector(ipoint) * mos_l_in_r_array_transp(ipoint,i) * mos_r_in_r_array_transp(ipoint,i) + tmpval_2(ipoint) = final_weight_at_r_vector(ipoint) * mos_l_in_r_array_transp(ipoint,i) * mos_r_in_r_array_transp_tmp(ipoint,h1) + tmpvec_1(ipoint,1) = final_weight_at_r_vector(ipoint) * int2_grad1_u12_bimo_t(ipoint,1,i,i) * mos_r_in_r_array_transp_tmp(ipoint,h1) + tmpvec_1(ipoint,2) = final_weight_at_r_vector(ipoint) * int2_grad1_u12_bimo_t(ipoint,2,i,i) * mos_r_in_r_array_transp_tmp(ipoint,h1) + tmpvec_1(ipoint,3) = final_weight_at_r_vector(ipoint) * int2_grad1_u12_bimo_t(ipoint,3,i,i) * mos_r_in_r_array_transp_tmp(ipoint,h1) + tmpvec_2(ipoint,1) = final_weight_at_r_vector(ipoint) * int2_grad1_u12_bimo_t(ipoint,1,i,h1) * mos_r_in_r_array_transp(ipoint,i) + tmpvec_2(ipoint,2) = final_weight_at_r_vector(ipoint) * int2_grad1_u12_bimo_t(ipoint,2,i,h1) * mos_r_in_r_array_transp(ipoint,i) + tmpvec_2(ipoint,3) = final_weight_at_r_vector(ipoint) * int2_grad1_u12_bimo_t(ipoint,3,i,h1) * mos_r_in_r_array_transp(ipoint,i) + enddo + + do p1 = 1, mo_num + tmp1(:,:,p1) = 0.d0 + if(mo_class(p1) .ne. "Active") cycle + + do ipoint = 1, n_points_final_grid + tmp1(ipoint,1,p1) = mos_l_in_r_array_transp_tmp(ipoint,p1) * (tmpvec_1(ipoint,1) - tmpvec_2(ipoint,1)) & + + tmpval_1(ipoint) * int2_grad1_u12_bimo_t_tmp(ipoint,1,p1,h1) - tmpval_2(ipoint) * int2_grad1_u12_bimo_t(ipoint,1,p1,i) + tmp1(ipoint,2,p1) = mos_l_in_r_array_transp_tmp(ipoint,p1) * (tmpvec_1(ipoint,2) - tmpvec_2(ipoint,2)) & + + tmpval_1(ipoint) * int2_grad1_u12_bimo_t_tmp(ipoint,2,p1,h1) - tmpval_2(ipoint) * int2_grad1_u12_bimo_t(ipoint,2,p1,i) + tmp1(ipoint,3,p1) = mos_l_in_r_array_transp_tmp(ipoint,p1) * (tmpvec_1(ipoint,3) - tmpvec_2(ipoint,3)) & + + tmpval_1(ipoint) * int2_grad1_u12_bimo_t_tmp(ipoint,3,p1,h1) - tmpval_2(ipoint) * int2_grad1_u12_bimo_t(ipoint,3,p1,i) + enddo + enddo + + call dgemm( 'T', 'N', mo_num*mo_num, mo_num, 3*n_points_final_grid, 1.d0 & + , int2_grad1_u12_bimo_t_tmp(1,1,1,1), 3*n_points_final_grid & + , tmp1(1,1,1), 3*n_points_final_grid & + , 0.d0, tmp_3d(1,1,1), mo_num*mo_num) + + do p1 = 1, mo_num + do h2 = 1, mo_num + do p2 = 1, mo_num + tmp(p2,h2,p1,h1) = tmp(p2,h2,p1,h1) + tmp_3d(p2,h2,p1) + enddo + enddo + enddo + + do p1 = 1, mo_num + if(mo_class(p1) .ne. "Active") cycle + + do ipoint = 1, n_points_final_grid + tmpval_1(ipoint) = final_weight_at_r_vector(ipoint) * & + ( int2_grad1_u12_bimo_t(ipoint,1,i,i) * int2_grad1_u12_bimo_t_tmp(ipoint,1,p1,h1) & + + int2_grad1_u12_bimo_t(ipoint,2,i,i) * int2_grad1_u12_bimo_t_tmp(ipoint,2,p1,h1) & + + int2_grad1_u12_bimo_t(ipoint,3,i,i) * int2_grad1_u12_bimo_t_tmp(ipoint,3,p1,h1) & + - int2_grad1_u12_bimo_t(ipoint,1,p1,i) * int2_grad1_u12_bimo_t(ipoint,1,i,h1) & + - int2_grad1_u12_bimo_t(ipoint,2,p1,i) * int2_grad1_u12_bimo_t(ipoint,2,i,h1) & + - int2_grad1_u12_bimo_t(ipoint,3,p1,i) * int2_grad1_u12_bimo_t(ipoint,3,i,h1) ) + enddo + + do h2 = 1, mo_num + tmp2(:,h2) = 0.d0 + if(mo_class(h2) .ne. "Active") cycle + + do ipoint = 1, n_points_final_grid + tmp2(ipoint,h2) = mos_r_in_r_array_transp_tmp(ipoint,h2) * tmpval_1(ipoint) + enddo + enddo + + call dgemm( 'T', 'N', mo_num, mo_num, n_points_final_grid, 1.d0 & + , mos_l_in_r_array_transp_tmp(1,1), n_points_final_grid & + , tmp2(1,1), n_points_final_grid & + , 0.d0, tmp_2d(1,1), mo_num) + + do h2 = 1, mo_num + do p2 = 1, mo_num + tmp(p2,h2,p1,h1) = tmp(p2,h2,p1,h1) + tmp_2d(p2,h2) + enddo + enddo + + enddo ! p1 + enddo ! i + enddo ! h1 + + !$OMP END DO + + deallocate(tmp_3d, tmp_2d) + deallocate(tmp1, tmp2) + deallocate(tmpval_1, tmpval_2) + deallocate(tmpvec_1, tmpvec_2) + + !$OMP END PARALLEL + + + ! purely open-shell part + if(Ne(2) < Ne(1)) then + + call set_multiple_levels_omp(.false.) + + !$OMP PARALLEL & + !$OMP DEFAULT (NONE) & + !$OMP PRIVATE (ipoint, h1, p1, h2, p2, i, ii, & + !$OMP tmp_3d, tmp_2d, tmp1, tmp2, & + !$OMP tmpval_1, tmpval_2, tmpvec_1, tmpvec_2) & + !$OMP SHARED (n_points_final_grid, Ne, occ, mo_num, mo_class, & + !$OMP mos_l_in_r_array_transp_tmp, mos_r_in_r_array_transp_tmp, & + !$OMP int2_grad1_u12_bimo_t_tmp, final_weight_at_r_vector, & + !$OMP mos_l_in_r_array_transp, mos_r_in_r_array_transp, int2_grad1_u12_bimo_t, & + !$OMP tmp) + + Allocate(tmp_3d(mo_num,mo_num,mo_num), tmp_2d(mo_num,mo_num)) + Allocate(tmp1(n_points_final_grid,3,mo_num), tmp2(n_points_final_grid,mo_num)) + Allocate(tmpval_1(n_points_final_grid), tmpval_2(n_points_final_grid)) + Allocate(tmpvec_1(n_points_final_grid,3), tmpvec_2(n_points_final_grid,3)) + + Tmp_3d = 0.d0 + Tmp_2d = 0.d0 + Tmp1 = 0.d0 + Tmp2 = 0.d0 + Tmpval_1 = 0.d0 + Tmpval_2 = 0.d0 + Tmpvec_1 = 0.d0 + Tmpvec_2 = 0.d0 + + !$OMP DO + + do h1 = 1, mo_num + if(mo_class(h1) .ne. "Active") cycle + + do ii = Ne(2) + 1, Ne(1) + i = occ(ii,1) + + do ipoint = 1, n_points_final_grid + tmpval_1(ipoint) = final_weight_at_r_vector(ipoint) * mos_l_in_r_array_transp(ipoint,i) * mos_r_in_r_array_transp(ipoint,i) + tmpval_2(ipoint) = final_weight_at_r_vector(ipoint) * mos_l_in_r_array_transp(ipoint,i) * mos_r_in_r_array_transp_tmp(ipoint,h1) + tmpvec_1(ipoint,1) = final_weight_at_r_vector(ipoint) * int2_grad1_u12_bimo_t(ipoint,1,i,i) * mos_r_in_r_array_transp_tmp(ipoint,h1) + tmpvec_1(ipoint,2) = final_weight_at_r_vector(ipoint) * int2_grad1_u12_bimo_t(ipoint,2,i,i) * mos_r_in_r_array_transp_tmp(ipoint,h1) + tmpvec_1(ipoint,3) = final_weight_at_r_vector(ipoint) * int2_grad1_u12_bimo_t(ipoint,3,i,i) * mos_r_in_r_array_transp_tmp(ipoint,h1) + tmpvec_2(ipoint,1) = final_weight_at_r_vector(ipoint) * int2_grad1_u12_bimo_t(ipoint,1,i,h1) * mos_r_in_r_array_transp(ipoint,i) + tmpvec_2(ipoint,2) = final_weight_at_r_vector(ipoint) * int2_grad1_u12_bimo_t(ipoint,2,i,h1) * mos_r_in_r_array_transp(ipoint,i) + tmpvec_2(ipoint,3) = final_weight_at_r_vector(ipoint) * int2_grad1_u12_bimo_t(ipoint,3,i,h1) * mos_r_in_r_array_transp(ipoint,i) + enddo + + do p1 = 1, mo_num + tmp1(:,:,p1) = 0.d0 + if(mo_class(p1) .ne. "Active") cycle + + do ipoint = 1, n_points_final_grid + tmp1(ipoint,1,p1) = mos_l_in_r_array_transp_tmp(ipoint,p1) * (tmpvec_1(ipoint,1) - tmpvec_2(ipoint,1)) & + + tmpval_1(ipoint) * int2_grad1_u12_bimo_t_tmp(ipoint,1,p1,h1) - tmpval_2(ipoint) * int2_grad1_u12_bimo_t(ipoint,1,p1,i) + tmp1(ipoint,2,p1) = mos_l_in_r_array_transp_tmp(ipoint,p1) * (tmpvec_1(ipoint,2) - tmpvec_2(ipoint,2)) & + + tmpval_1(ipoint) * int2_grad1_u12_bimo_t_tmp(ipoint,2,p1,h1) - tmpval_2(ipoint) * int2_grad1_u12_bimo_t(ipoint,2,p1,i) + tmp1(ipoint,3,p1) = mos_l_in_r_array_transp_tmp(ipoint,p1) * (tmpvec_1(ipoint,3) - tmpvec_2(ipoint,3)) & + + tmpval_1(ipoint) * int2_grad1_u12_bimo_t_tmp(ipoint,3,p1,h1) - tmpval_2(ipoint) * int2_grad1_u12_bimo_t(ipoint,3,p1,i) + enddo + enddo + + call dgemm( 'T', 'N', mo_num*mo_num, mo_num, 3*n_points_final_grid, 0.5d0 & + , int2_grad1_u12_bimo_t_tmp(1,1,1,1), 3*n_points_final_grid & + , tmp1(1,1,1), 3*n_points_final_grid & + , 0.d0, tmp_3d(1,1,1), mo_num*mo_num) + + do p1 = 1, mo_num + do h2 = 1, mo_num + do p2 = 1, mo_num + tmp(p2,h2,p1,h1) = tmp(p2,h2,p1,h1) + tmp_3d(p2,h2,p1) + enddo + enddo + enddo + + do p1 = 1, mo_num + if(mo_class(p1) .ne. "Active") cycle + + do ipoint = 1, n_points_final_grid + tmpval_1(ipoint) = final_weight_at_r_vector(ipoint) * & + ( int2_grad1_u12_bimo_t(ipoint,1,i,i) * int2_grad1_u12_bimo_t_tmp(ipoint,1,p1,h1) & + + int2_grad1_u12_bimo_t(ipoint,2,i,i) * int2_grad1_u12_bimo_t_tmp(ipoint,2,p1,h1) & + + int2_grad1_u12_bimo_t(ipoint,3,i,i) * int2_grad1_u12_bimo_t_tmp(ipoint,3,p1,h1) & + - int2_grad1_u12_bimo_t(ipoint,1,p1,i) * int2_grad1_u12_bimo_t(ipoint,1,i,h1) & + - int2_grad1_u12_bimo_t(ipoint,2,p1,i) * int2_grad1_u12_bimo_t(ipoint,2,i,h1) & + - int2_grad1_u12_bimo_t(ipoint,3,p1,i) * int2_grad1_u12_bimo_t(ipoint,3,i,h1) ) + enddo + + do h2 = 1, mo_num + tmp2(:,h2) = 0.d0 + if(mo_class(h2) .ne. "Active") cycle + + do ipoint = 1, n_points_final_grid + tmp2(ipoint,h2) = mos_r_in_r_array_transp_tmp(ipoint,h2) * tmpval_1(ipoint) + enddo + enddo + + call dgemm( 'T', 'N', mo_num, mo_num, n_points_final_grid, 0.5d0 & + , mos_l_in_r_array_transp_tmp(1,1), n_points_final_grid & + , tmp2(1,1), n_points_final_grid & + , 0.d0, tmp_2d(1,1), mo_num) + + do h2 = 1, mo_num + do p2 = 1, mo_num + tmp(p2,h2,p1,h1) = tmp(p2,h2,p1,h1) + tmp_2d(p2,h2) + enddo + enddo + + enddo ! p1 + enddo ! i + enddo ! h1 + !$OMP END DO + + deallocate(tmp_3d, tmp_2d) + deallocate(tmp1, tmp2) + deallocate(tmpval_1, tmpval_2) + deallocate(tmpvec_1, tmpvec_2) + + !$OMP END PARALLEL + endif + + tmp = -0.5d0 * tmp + call sum_A_At(tmp(1,1,1,1), mo_num*mo_num) + + call wall_time(wall1) + print*,' Wall time for aba_contraction_v0', wall1-wall0 + + normal_two_body_bi_orth_v0 = tmp + + ! --- + ! aab contraction + + print*,' Providing aab_contraction_v0 ...' + call wall_time(wall0) + + call set_multiple_levels_omp(.false.) + + !$OMP PARALLEL & + !$OMP DEFAULT (NONE) & + !$OMP PRIVATE (ipoint, ii, i, h1, p1, h2, p2, & + !$OMP tmp_2d, tmp_3d, tmp1, tmp2, & + !$OMP tmpval_1, tmpvec_1) & + !$OMP SHARED (n_points_final_grid, mo_num, Ne, occ, mo_class, & + !$OMP mos_l_in_r_array_transp_tmp, mos_r_in_r_array_transp_tmp, & + !$OMP int2_grad1_u12_bimo_t_tmp, final_weight_at_r_vector, & + !$OMP mos_l_in_r_array_transp, mos_r_in_r_array_transp, int2_grad1_u12_bimo_t, & + !$OMP tmp) + + allocate(tmp_2d(mo_num,mo_num)) + allocate(tmp_3d(mo_num,mo_num,mo_num)) + allocate(tmp1(n_points_final_grid,3,mo_num)) + allocate(tmp2(n_points_final_grid,mo_num)) + allocate(tmpval_1(n_points_final_grid)) + allocate(tmpvec_1(n_points_final_grid,3)) + + tmp_2d = 0.d0 + tmp_3d = 0.d0 + tmp1 = 0.d0 + tmp2 = 0.d0 + tmpval_1 = 0.d0 + tmpvec_1 = 0.d0 + + !$OMP DO + + do h1 = 1, mo_num + tmp(:,:,:,h1) = 0.d0 + if(mo_class(h1) .ne. "Active") cycle + + do ii = 1, Ne(2) + i = occ(ii,2) + + do ipoint = 1, n_points_final_grid + tmpval_1(ipoint) = final_weight_at_r_vector(ipoint) * mos_l_in_r_array_transp(ipoint,i) * mos_r_in_r_array_transp(ipoint,i) + tmpvec_1(ipoint,1) = final_weight_at_r_vector(ipoint) * int2_grad1_u12_bimo_t(ipoint,1,i,i) * mos_r_in_r_array_transp_tmp(ipoint,h1) + tmpvec_1(ipoint,2) = final_weight_at_r_vector(ipoint) * int2_grad1_u12_bimo_t(ipoint,2,i,i) * mos_r_in_r_array_transp_tmp(ipoint,h1) + tmpvec_1(ipoint,3) = final_weight_at_r_vector(ipoint) * int2_grad1_u12_bimo_t(ipoint,3,i,i) * mos_r_in_r_array_transp_tmp(ipoint,h1) + enddo + + do p1 = 1, mo_num + tmp1(:,:,p1) = 0.d0 + if(mo_class(p1) .ne. "Active") cycle + + do ipoint = 1, n_points_final_grid + tmp1(ipoint,1,p1) = mos_l_in_r_array_transp_tmp(ipoint,p1) * tmpvec_1(ipoint,1) + tmpval_1(ipoint) * int2_grad1_u12_bimo_t_tmp(ipoint,1,p1,h1) + tmp1(ipoint,2,p1) = mos_l_in_r_array_transp_tmp(ipoint,p1) * tmpvec_1(ipoint,2) + tmpval_1(ipoint) * int2_grad1_u12_bimo_t_tmp(ipoint,2,p1,h1) + tmp1(ipoint,3,p1) = mos_l_in_r_array_transp_tmp(ipoint,p1) * tmpvec_1(ipoint,3) + tmpval_1(ipoint) * int2_grad1_u12_bimo_t_tmp(ipoint,3,p1,h1) + enddo + enddo + + call dgemm( 'T', 'N', mo_num*mo_num, mo_num, 3*n_points_final_grid, 1.d0 & + , int2_grad1_u12_bimo_t_tmp(1,1,1,1), 3*n_points_final_grid & + , tmp1(1,1,1), 3*n_points_final_grid & + , 0.d0, tmp_3d(1,1,1), mo_num*mo_num) + + do p1 = 1, mo_num + do h2 = 1, mo_num + do p2 = 1, mo_num + tmp(p2,h2,p1,h1) = tmp(p2,h2,p1,h1) + tmp_3d(p2,h2,p1) + enddo + enddo + enddo + + do p1 = 1, mo_num + if(mo_class(p1) .ne. "Active") cycle + + do ipoint = 1, n_points_final_grid + tmpval_1(ipoint) = final_weight_at_r_vector(ipoint) * ( int2_grad1_u12_bimo_t(ipoint,1,i,i) * int2_grad1_u12_bimo_t_tmp(ipoint,1,p1,h1) & + + int2_grad1_u12_bimo_t(ipoint,2,i,i) * int2_grad1_u12_bimo_t_tmp(ipoint,2,p1,h1) & + + int2_grad1_u12_bimo_t(ipoint,3,i,i) * int2_grad1_u12_bimo_t_tmp(ipoint,3,p1,h1) ) + enddo + + do h2 = 1, mo_num + if(mo_class(h2) .ne. "Active") cycle + tmp2(:,h2) = 0.d0 + + do ipoint = 1, n_points_final_grid + tmp2(ipoint,h2) = mos_r_in_r_array_transp_tmp(ipoint,h2) * tmpval_1(ipoint) + enddo + enddo + + call dgemm( 'T', 'N', mo_num, mo_num, n_points_final_grid, 1.d0 & + , mos_l_in_r_array_transp_tmp(1,1), n_points_final_grid & + , tmp2(1,1), n_points_final_grid & + , 0.d0, tmp_2d(1,1), mo_num) + + do h2 = 1, mo_num + do p2 = 1, mo_num + tmp(p2,h2,p1,h1) = tmp(p2,h2,p1,h1) + tmp_2d(p2,h2) + enddo + enddo + + enddo ! p1 + enddo ! i + enddo ! h1 + + !$OMP END DO + + deallocate(tmp_3d) + deallocate(tmp1, tmp2) + deallocate(tmpval_1) + deallocate(tmpvec_1) + + !$OMP END PARALLEL + + tmp = -0.5d0 * tmp + + !$OMP PARALLEL & + !$OMP DEFAULT (NONE) & + !$OMP PRIVATE (h1, h2, p1, p2) & + !$OMP SHARED (tmp, mo_num) + + !$OMP DO COLLAPSE(2) + do h1 = 1, mo_num + do h2 = 1, mo_num + do p1 = 1, mo_num + do p2 = p1, mo_num + tmp(p2,h2,p1,h1) -= tmp(p1,h2,p2,h1) + enddo + enddo + enddo + enddo + !$OMP END DO + + !$OMP DO COLLAPSE(2) + do h1 = 1, mo_num + do h2 = 1, mo_num + do p1 = 2, mo_num + do p2 = 1, p1-1 + tmp(p2,h2,p1,h1) = -tmp(p1,h2,p2,h1) + enddo + enddo + enddo + enddo + !$OMP END DO + + !$OMP DO + do h1 = 1, mo_num-1 + do h2 = h1+1, mo_num + do p1 = 2, mo_num + do p2 = 1, p1-1 + tmp(p2,h2,p1,h1) *= -1.d0 + enddo + enddo + enddo + enddo + !$OMP END DO + !$OMP END PARALLEL + + call wall_time(wall1) + print*,' Wall time for aab_contraction_v0', wall1-wall0 + + normal_two_body_bi_orth_v0 += tmp + + ! --- + ! aaa contraction + + if(Ne(2) .ge. 3) then + + print*,' Providing aaa_contraction_v0 ...' + call wall_time(wall0) + + call set_multiple_levels_omp(.false.) + + !$OMP PARALLEL & + !$OMP DEFAULT (NONE) & + !$OMP PRIVATE (ipoint, i, ii, h1, h2, p1, p2, & + !$OMP tmp_2d, tmp_3d, tmp1, tmp2, tmp3, & + !$OMP tmpval_1, tmpval_2, & + !$OMP tmpvec_1, tmpvec_2, tmpvec_3) & + !$OMP SHARED (n_points_final_grid, Ne, occ, mo_num, mo_class, & + !$OMP mos_l_in_r_array_transp_tmp, mos_r_in_r_array_transp_tmp, & + !$OMP int2_grad1_u12_bimo_t_tmp, final_weight_at_r_vector, & + !$OMP mos_l_in_r_array_transp, mos_r_in_r_array_transp, int2_grad1_u12_bimo_t, & + !$OMP tmp) + + allocate(tmp_2d(mo_num,mo_num)) + allocate(tmp_3d(mo_num,mo_num,mo_num)) + allocate(tmp1(n_points_final_grid,3,mo_num)) + allocate(tmp2(n_points_final_grid,mo_num)) + allocate(tmp3(n_points_final_grid,3,mo_num)) + allocate(tmpval_1(n_points_final_grid)) + allocate(tmpval_2(n_points_final_grid)) + allocate(tmpvec_1(n_points_final_grid,3)) + allocate(tmpvec_2(n_points_final_grid,3)) + allocate(tmpvec_3(n_points_final_grid,3)) + + tmp_2d = 0.d0 + tmp_3d = 0.d0 + tmp1 = 0.d0 + tmp2 = 0.d0 + tmp3 = 0.d0 + tmpval_1 = 0.d0 + tmpval_2 = 0.d0 + tmpvec_1 = 0.d0 + tmpvec_2 = 0.d0 + tmpvec_3 = 0.d0 + + !$OMP DO + + do h1 = 1, mo_num + tmp(:,:,:,h1) = 0.d0 + if(mo_class(h1) .ne. "Active") cycle + + do ii = 1, Ne(2) + i = occ(ii,2) + + do ipoint = 1, n_points_final_grid + + tmpval_1(ipoint) = final_weight_at_r_vector(ipoint) * mos_l_in_r_array_transp(ipoint,i) * mos_r_in_r_array_transp(ipoint,i) + + tmpval_2(ipoint) = final_weight_at_r_vector(ipoint) * mos_l_in_r_array_transp(ipoint,i) * mos_r_in_r_array_transp_tmp(ipoint,h1) + + tmpvec_1(ipoint,1) = final_weight_at_r_vector(ipoint) * int2_grad1_u12_bimo_t(ipoint,1,i,i) * mos_r_in_r_array_transp_tmp(ipoint,h1) + tmpvec_1(ipoint,2) = final_weight_at_r_vector(ipoint) * int2_grad1_u12_bimo_t(ipoint,2,i,i) * mos_r_in_r_array_transp_tmp(ipoint,h1) + tmpvec_1(ipoint,3) = final_weight_at_r_vector(ipoint) * int2_grad1_u12_bimo_t(ipoint,3,i,i) * mos_r_in_r_array_transp_tmp(ipoint,h1) + + tmpvec_2(ipoint,1) = final_weight_at_r_vector(ipoint) * int2_grad1_u12_bimo_t(ipoint,1,i,h1) * mos_r_in_r_array_transp(ipoint,i) + tmpvec_2(ipoint,2) = final_weight_at_r_vector(ipoint) * int2_grad1_u12_bimo_t(ipoint,2,i,h1) * mos_r_in_r_array_transp(ipoint,i) + tmpvec_2(ipoint,3) = final_weight_at_r_vector(ipoint) * int2_grad1_u12_bimo_t(ipoint,3,i,h1) * mos_r_in_r_array_transp(ipoint,i) + enddo + + do p1 = 1, mo_num + tmp1(:,:,p1) = 0.d0 + if(mo_class(p1) .ne. "Active") cycle + + do ipoint = 1, n_points_final_grid + tmp1(ipoint,1,p1) = mos_l_in_r_array_transp_tmp(ipoint,p1) * tmpvec_1(ipoint,1) + tmpval_1(ipoint) * int2_grad1_u12_bimo_t_tmp(ipoint,1,p1,h1) + tmp1(ipoint,2,p1) = mos_l_in_r_array_transp_tmp(ipoint,p1) * tmpvec_1(ipoint,2) + tmpval_1(ipoint) * int2_grad1_u12_bimo_t_tmp(ipoint,2,p1,h1) + tmp1(ipoint,3,p1) = mos_l_in_r_array_transp_tmp(ipoint,p1) * tmpvec_1(ipoint,3) + tmpval_1(ipoint) * int2_grad1_u12_bimo_t_tmp(ipoint,3,p1,h1) + enddo + enddo + + call dgemm( 'T', 'N', mo_num*mo_num, mo_num, 3*n_points_final_grid, 1.d0 & + , int2_grad1_u12_bimo_t_tmp(1,1,1,1), 3*n_points_final_grid & + , tmp1(1,1,1), 3*n_points_final_grid & + , 0.d0, tmp_3d(1,1,1), mo_num*mo_num) + + do p1 = 1, mo_num + do h2 = 1, mo_num + do p2 = 1, mo_num + tmp(p2,h2,p1,h1) = tmp(p2,h2,p1,h1) + tmp_3d(p2,h2,p1) + enddo + enddo + enddo + + do p2 = 1, mo_num + tmp1(:,:,p2) = 0.d0 + if(mo_class(p2) .ne. "Active") cycle + + do ipoint = 1, n_points_final_grid + tmp1(ipoint,1,p2) = tmpval_2(ipoint) * int2_grad1_u12_bimo_t(ipoint,1,p2,i) + mos_l_in_r_array_transp_tmp(ipoint,p2) * tmpvec_2(ipoint,1) + tmp1(ipoint,2,p2) = tmpval_2(ipoint) * int2_grad1_u12_bimo_t(ipoint,2,p2,i) + mos_l_in_r_array_transp_tmp(ipoint,p2) * tmpvec_2(ipoint,2) + tmp1(ipoint,3,p2) = tmpval_2(ipoint) * int2_grad1_u12_bimo_t(ipoint,3,p2,i) + mos_l_in_r_array_transp_tmp(ipoint,p2) * tmpvec_2(ipoint,3) + enddo + enddo + + call dgemm( 'T', 'N', mo_num, mo_num*mo_num, 3*n_points_final_grid, 1.d0 & + , tmp1(1,1,1), 3*n_points_final_grid & + , int2_grad1_u12_bimo_t_tmp(1,1,1,1), 3*n_points_final_grid & + , 0.d0, tmp_3d(1,1,1), mo_num) + + do p1 = 1, mo_num + do h2 = 1, mo_num + do p2 = 1, mo_num + tmp(p2,h2,p1,h1) = tmp(p2,h2,p1,h1) + tmp_3d(p2,p1,h2) + enddo + enddo + enddo + + do p1 = 1, mo_num + if(mo_class(p1) .ne. "Active") cycle + + do ipoint = 1, n_points_final_grid + + tmpval_1(ipoint) = final_weight_at_r_vector(ipoint) * & + ( int2_grad1_u12_bimo_t(ipoint,1,i,i) * int2_grad1_u12_bimo_t_tmp(ipoint,1,p1,h1) & + + int2_grad1_u12_bimo_t(ipoint,2,i,i) * int2_grad1_u12_bimo_t_tmp(ipoint,2,p1,h1) & + + int2_grad1_u12_bimo_t(ipoint,3,i,i) * int2_grad1_u12_bimo_t_tmp(ipoint,3,p1,h1) ) + + tmpval_2(ipoint) = final_weight_at_r_vector(ipoint) * mos_l_in_r_array_transp_tmp(ipoint,p1) * mos_r_in_r_array_transp(ipoint,i) + + tmpvec_1(ipoint,1) = final_weight_at_r_vector(ipoint) * int2_grad1_u12_bimo_t(ipoint,1,p1,i) * mos_r_in_r_array_transp_tmp(ipoint,h1) + tmpvec_1(ipoint,2) = final_weight_at_r_vector(ipoint) * int2_grad1_u12_bimo_t(ipoint,2,p1,i) * mos_r_in_r_array_transp_tmp(ipoint,h1) + tmpvec_1(ipoint,3) = final_weight_at_r_vector(ipoint) * int2_grad1_u12_bimo_t(ipoint,3,p1,i) * mos_r_in_r_array_transp_tmp(ipoint,h1) + + tmpvec_2(ipoint,1) = final_weight_at_r_vector(ipoint) * int2_grad1_u12_bimo_t(ipoint,1,i,h1) * mos_l_in_r_array_transp_tmp(ipoint,p1) + tmpvec_2(ipoint,2) = final_weight_at_r_vector(ipoint) * int2_grad1_u12_bimo_t(ipoint,2,i,h1) * mos_l_in_r_array_transp_tmp(ipoint,p1) + tmpvec_2(ipoint,3) = final_weight_at_r_vector(ipoint) * int2_grad1_u12_bimo_t(ipoint,3,i,h1) * mos_l_in_r_array_transp_tmp(ipoint,p1) + + tmpvec_3(ipoint,1) = final_weight_at_r_vector(ipoint) * int2_grad1_u12_bimo_t(ipoint,1,p1,i) * mos_l_in_r_array_transp(ipoint,i) + tmpvec_3(ipoint,2) = final_weight_at_r_vector(ipoint) * int2_grad1_u12_bimo_t(ipoint,2,p1,i) * mos_l_in_r_array_transp(ipoint,i) + tmpvec_3(ipoint,3) = final_weight_at_r_vector(ipoint) * int2_grad1_u12_bimo_t(ipoint,3,p1,i) * mos_l_in_r_array_transp(ipoint,i) + enddo + + do h2 = 1, mo_num + tmp2( :,h2) = 0.d0 + tmp1(:,:,h2) = 0.d0 + if(mo_class(h2) .ne. "Active") cycle + + do ipoint = 1, n_points_final_grid + + tmp2(ipoint,h2) = mos_r_in_r_array_transp_tmp(ipoint,h2) * tmpval_1(ipoint) & + + int2_grad1_u12_bimo_t(ipoint,1,i,h2) * tmpvec_1(ipoint,1) & + + int2_grad1_u12_bimo_t(ipoint,2,i,h2) * tmpvec_1(ipoint,2) & + + int2_grad1_u12_bimo_t(ipoint,3,i,h2) * tmpvec_1(ipoint,3) + + tmp1(ipoint,1,h2) = tmpval_2(ipoint) * int2_grad1_u12_bimo_t(ipoint,1,i,h2) + tmp1(ipoint,2,h2) = tmpval_2(ipoint) * int2_grad1_u12_bimo_t(ipoint,2,i,h2) + tmp1(ipoint,3,h2) = tmpval_2(ipoint) * int2_grad1_u12_bimo_t(ipoint,3,i,h2) + + enddo + enddo + + call dgemm( 'T', 'N', mo_num, mo_num, n_points_final_grid, 1.d0 & + , mos_l_in_r_array_transp_tmp(1,1), n_points_final_grid & + , tmp2(1,1), n_points_final_grid & + , 0.d0, tmp_2d(1,1), mo_num) + + do h2 = 1, mo_num + do p2 = 1, mo_num + tmp(p2,h2,p1,h1) = tmp(p2,h2,p1,h1) + tmp_2d(p2,h2) + enddo + enddo + + do p2 = 1, mo_num + tmp2( :,p2) = 0.d0 + tmp3(:,:,p2) = 0.d0 + if(mo_class(p2) .ne. "Active") cycle + + do ipoint = 1, n_points_final_grid + + tmp2(ipoint,p2) = int2_grad1_u12_bimo_t(ipoint,1,p2,i) * tmpvec_2(ipoint,1) + int2_grad1_u12_bimo_t_tmp(ipoint,1,p2,h1) * tmpvec_3(ipoint,1) & + + int2_grad1_u12_bimo_t(ipoint,2,p2,i) * tmpvec_2(ipoint,2) + int2_grad1_u12_bimo_t_tmp(ipoint,2,p2,h1) * tmpvec_3(ipoint,2) & + + int2_grad1_u12_bimo_t(ipoint,3,p2,i) * tmpvec_2(ipoint,3) + int2_grad1_u12_bimo_t_tmp(ipoint,3,p2,h1) * tmpvec_3(ipoint,3) + + tmp3(ipoint,1,p2) = int2_grad1_u12_bimo_t_tmp(ipoint,1,p2,h1) + tmp3(ipoint,2,p2) = int2_grad1_u12_bimo_t_tmp(ipoint,2,p2,h1) + tmp3(ipoint,3,p2) = int2_grad1_u12_bimo_t_tmp(ipoint,3,p2,h1) + enddo + enddo + + call dgemm( 'T', 'N', mo_num, mo_num, n_points_final_grid, 1.d0 & + , tmp2(1,1), n_points_final_grid & + , mos_r_in_r_array_transp_tmp(1,1), n_points_final_grid & + , 0.d0, tmp_2d(1,1), mo_num) + + call dgemm( 'T', 'N', mo_num, mo_num, 3*n_points_final_grid, 1.d0 & + , tmp3(1,1,1), 3*n_points_final_grid & + , tmp1(1,1,1), 3*n_points_final_grid & + , 1.d0, tmp_2d(1,1), mo_num) + + do h2 = 1, mo_num + do p2 = 1, mo_num + tmp(p2,h2,p1,h1) = tmp(p2,h2,p1,h1) + tmp_2d(p2,h2) + enddo + enddo + + enddo ! p1 + enddo ! i + enddo ! h1 + !$OMP END DO + + deallocate(tmp_2d) + deallocate(tmp_3d) + deallocate(tmp1) + deallocate(tmp2) + deallocate(tmp3) + deallocate(tmpval_1) + deallocate(tmpval_2) + deallocate(tmpvec_1) + deallocate(tmpvec_2) + deallocate(tmpvec_3) + + !$OMP END PARALLEL + + ! purely open-shell part + if(Ne(2) < Ne(1)) then + + call set_multiple_levels_omp(.false.) + + !$OMP PARALLEL & + !$OMP DEFAULT (NONE) & + !$OMP PRIVATE (ipoint, i, ii, h1, h2, p1, p2, tmp_2d, tmp_3d, tmp1, tmp2, tmp3, & + !$OMP tmpval_1, tmpval_2, tmpvec_1, tmpvec_2, tmpvec_3) & + !$OMP SHARED (n_points_final_grid, Ne, occ, mo_num, mo_class, & + !$OMP mos_l_in_r_array_transp_tmp, mos_r_in_r_array_transp_tmp, & + !$OMP int2_grad1_u12_bimo_t_tmp, final_weight_at_r_vector, & + !$OMP mos_l_in_r_array_transp, mos_r_in_r_array_transp, int2_grad1_u12_bimo_t, & + !$OMP tmp) + + allocate(tmp_2d(mo_num,mo_num)) + allocate(tmp_3d(mo_num,mo_num,mo_num)) + allocate(tmp1(n_points_final_grid,3,mo_num)) + allocate(tmp2(n_points_final_grid,mo_num)) + allocate(tmp3(n_points_final_grid,3,mo_num)) + allocate(tmpval_1(n_points_final_grid)) + allocate(tmpval_2(n_points_final_grid)) + allocate(tmpvec_1(n_points_final_grid,3)) + allocate(tmpvec_2(n_points_final_grid,3)) + allocate(tmpvec_3(n_points_final_grid,3)) + + tmp_2d = 0.d0 + tmp_3d = 0.d0 + tmp1 = 0.d0 + tmp2 = 0.d0 + tmp3 = 0.d0 + tmpval_1 = 0.d0 + tmpval_2 = 0.d0 + tmpvec_1 = 0.d0 + tmpvec_2 = 0.d0 + tmpvec_3 = 0.d0 + + !$OMP DO + + do h1 = 1, mo_num + if(mo_class(h1) .ne. "Active") cycle + + do ii = Ne(2) + 1, Ne(1) + i = occ(ii,1) + + do ipoint = 1, n_points_final_grid + + tmpval_1(ipoint) = final_weight_at_r_vector(ipoint) * mos_l_in_r_array_transp(ipoint,i) * mos_r_in_r_array_transp(ipoint,i) + + tmpval_2(ipoint) = final_weight_at_r_vector(ipoint) * mos_l_in_r_array_transp(ipoint,i) * mos_r_in_r_array_transp_tmp(ipoint,h1) + + tmpvec_1(ipoint,1) = final_weight_at_r_vector(ipoint) * int2_grad1_u12_bimo_t(ipoint,1,i,i) * mos_r_in_r_array_transp_tmp(ipoint,h1) + tmpvec_1(ipoint,2) = final_weight_at_r_vector(ipoint) * int2_grad1_u12_bimo_t(ipoint,2,i,i) * mos_r_in_r_array_transp_tmp(ipoint,h1) + tmpvec_1(ipoint,3) = final_weight_at_r_vector(ipoint) * int2_grad1_u12_bimo_t(ipoint,3,i,i) * mos_r_in_r_array_transp_tmp(ipoint,h1) + + tmpvec_2(ipoint,1) = final_weight_at_r_vector(ipoint) * int2_grad1_u12_bimo_t(ipoint,1,i,h1) * mos_r_in_r_array_transp(ipoint,i) + tmpvec_2(ipoint,2) = final_weight_at_r_vector(ipoint) * int2_grad1_u12_bimo_t(ipoint,2,i,h1) * mos_r_in_r_array_transp(ipoint,i) + tmpvec_2(ipoint,3) = final_weight_at_r_vector(ipoint) * int2_grad1_u12_bimo_t(ipoint,3,i,h1) * mos_r_in_r_array_transp(ipoint,i) + enddo + + do p1 = 1, mo_num + tmp1(:,:,p1) = 0.d0 + if(mo_class(p1) .ne. "Active") cycle + + do ipoint = 1, n_points_final_grid + tmp1(ipoint,1,p1) = mos_l_in_r_array_transp_tmp(ipoint,p1) * tmpvec_1(ipoint,1) + tmpval_1(ipoint) * int2_grad1_u12_bimo_t_tmp(ipoint,1,p1,h1) + tmp1(ipoint,2,p1) = mos_l_in_r_array_transp_tmp(ipoint,p1) * tmpvec_1(ipoint,2) + tmpval_1(ipoint) * int2_grad1_u12_bimo_t_tmp(ipoint,2,p1,h1) + tmp1(ipoint,3,p1) = mos_l_in_r_array_transp_tmp(ipoint,p1) * tmpvec_1(ipoint,3) + tmpval_1(ipoint) * int2_grad1_u12_bimo_t_tmp(ipoint,3,p1,h1) + enddo + enddo + + call dgemm( 'T', 'N', mo_num*mo_num, mo_num, 3*n_points_final_grid, 0.5d0 & + , int2_grad1_u12_bimo_t_tmp(1,1,1,1), 3*n_points_final_grid & + , tmp1(1,1,1), 3*n_points_final_grid & + , 0.d0, tmp_3d(1,1,1), mo_num*mo_num) + + do p1 = 1, mo_num + do h2 = 1, mo_num + do p2 = 1, mo_num + tmp(p2,h2,p1,h1) = tmp(p2,h2,p1,h1) + tmp_3d(p2,h2,p1) + enddo + enddo + enddo + + do p2 = 1, mo_num + tmp1(:,:,p2) = 0.d0 + if(mo_class(p2) .ne. "Active") cycle + + do ipoint = 1, n_points_final_grid + tmp1(ipoint,1,p2) = tmpval_2(ipoint) * int2_grad1_u12_bimo_t(ipoint,1,p2,i) + mos_l_in_r_array_transp_tmp(ipoint,p2) * tmpvec_2(ipoint,1) + tmp1(ipoint,2,p2) = tmpval_2(ipoint) * int2_grad1_u12_bimo_t(ipoint,2,p2,i) + mos_l_in_r_array_transp_tmp(ipoint,p2) * tmpvec_2(ipoint,2) + tmp1(ipoint,3,p2) = tmpval_2(ipoint) * int2_grad1_u12_bimo_t(ipoint,3,p2,i) + mos_l_in_r_array_transp_tmp(ipoint,p2) * tmpvec_2(ipoint,3) + enddo + enddo + + call dgemm( 'T', 'N', mo_num, mo_num*mo_num, 3*n_points_final_grid, 0.5d0 & + , tmp1(1,1,1), 3*n_points_final_grid & + , int2_grad1_u12_bimo_t_tmp(1,1,1,1), 3*n_points_final_grid & + , 0.d0, tmp_3d(1,1,1), mo_num) + + do p1 = 1, mo_num + do h2 = 1, mo_num + do p2 = 1, mo_num + tmp(p2,h2,p1,h1) = tmp(p2,h2,p1,h1) + tmp_3d(p2,p1,h2) + enddo + enddo + enddo + + do p1 = 1, mo_num + if(mo_class(p1) .ne. "Active") cycle + + do ipoint = 1, n_points_final_grid + + tmpval_1(ipoint) = final_weight_at_r_vector(ipoint) * & + ( int2_grad1_u12_bimo_t(ipoint,1,i,i) * int2_grad1_u12_bimo_t_tmp(ipoint,1,p1,h1) & + + int2_grad1_u12_bimo_t(ipoint,2,i,i) * int2_grad1_u12_bimo_t_tmp(ipoint,2,p1,h1) & + + int2_grad1_u12_bimo_t(ipoint,3,i,i) * int2_grad1_u12_bimo_t_tmp(ipoint,3,p1,h1) ) + + tmpval_2(ipoint) = final_weight_at_r_vector(ipoint) * mos_l_in_r_array_transp_tmp(ipoint,p1) * mos_r_in_r_array_transp(ipoint,i) + + tmpvec_1(ipoint,1) = final_weight_at_r_vector(ipoint) * int2_grad1_u12_bimo_t(ipoint,1,p1,i) * mos_r_in_r_array_transp_tmp(ipoint,h1) + tmpvec_1(ipoint,2) = final_weight_at_r_vector(ipoint) * int2_grad1_u12_bimo_t(ipoint,2,p1,i) * mos_r_in_r_array_transp_tmp(ipoint,h1) + tmpvec_1(ipoint,3) = final_weight_at_r_vector(ipoint) * int2_grad1_u12_bimo_t(ipoint,3,p1,i) * mos_r_in_r_array_transp_tmp(ipoint,h1) + + tmpvec_2(ipoint,1) = final_weight_at_r_vector(ipoint) * int2_grad1_u12_bimo_t(ipoint,1,i,h1) * mos_l_in_r_array_transp_tmp(ipoint,p1) + tmpvec_2(ipoint,2) = final_weight_at_r_vector(ipoint) * int2_grad1_u12_bimo_t(ipoint,2,i,h1) * mos_l_in_r_array_transp_tmp(ipoint,p1) + tmpvec_2(ipoint,3) = final_weight_at_r_vector(ipoint) * int2_grad1_u12_bimo_t(ipoint,3,i,h1) * mos_l_in_r_array_transp_tmp(ipoint,p1) + + tmpvec_3(ipoint,1) = final_weight_at_r_vector(ipoint) * int2_grad1_u12_bimo_t(ipoint,1,p1,i) * mos_l_in_r_array_transp(ipoint,i) + tmpvec_3(ipoint,2) = final_weight_at_r_vector(ipoint) * int2_grad1_u12_bimo_t(ipoint,2,p1,i) * mos_l_in_r_array_transp(ipoint,i) + tmpvec_3(ipoint,3) = final_weight_at_r_vector(ipoint) * int2_grad1_u12_bimo_t(ipoint,3,p1,i) * mos_l_in_r_array_transp(ipoint,i) + enddo + + do h2 = 1, mo_num + tmp2( :,h2) = 0.d0 + tmp1(:,:,h2) = 0.d0 + if(mo_class(h2) .ne. "Active") cycle + + do ipoint = 1, n_points_final_grid + + tmp2(ipoint,h2) = mos_r_in_r_array_transp_tmp(ipoint,h2) * tmpval_1(ipoint) & + + int2_grad1_u12_bimo_t(ipoint,1,i,h2) * tmpvec_1(ipoint,1) & + + int2_grad1_u12_bimo_t(ipoint,2,i,h2) * tmpvec_1(ipoint,2) & + + int2_grad1_u12_bimo_t(ipoint,3,i,h2) * tmpvec_1(ipoint,3) + + tmp1(ipoint,1,h2) = tmpval_2(ipoint) * int2_grad1_u12_bimo_t(ipoint,1,i,h2) + tmp1(ipoint,2,h2) = tmpval_2(ipoint) * int2_grad1_u12_bimo_t(ipoint,2,i,h2) + tmp1(ipoint,3,h2) = tmpval_2(ipoint) * int2_grad1_u12_bimo_t(ipoint,3,i,h2) + + enddo + enddo + + call dgemm( 'T', 'N', mo_num, mo_num, n_points_final_grid, 0.5d0 & + , mos_l_in_r_array_transp_tmp(1,1), n_points_final_grid & + , tmp2(1,1), n_points_final_grid & + , 0.d0, tmp_2d(1,1), mo_num) + + do h2 = 1, mo_num + do p2 = 1, mo_num + tmp(p2,h2,p1,h1) = tmp(p2,h2,p1,h1) + tmp_2d(p2,h2) + enddo + enddo + + do p2 = 1, mo_num + tmp2( :,p2) = 0.d0 + tmp3(:,:,p2) = 0.d0 + if(mo_class(p2) .ne. "Active") cycle + + do ipoint = 1, n_points_final_grid + + tmp2(ipoint,p2) = int2_grad1_u12_bimo_t(ipoint,1,p2,i) * tmpvec_2(ipoint,1) + int2_grad1_u12_bimo_t_tmp(ipoint,1,p2,h1) * tmpvec_3(ipoint,1) & + + int2_grad1_u12_bimo_t(ipoint,2,p2,i) * tmpvec_2(ipoint,2) + int2_grad1_u12_bimo_t_tmp(ipoint,2,p2,h1) * tmpvec_3(ipoint,2) & + + int2_grad1_u12_bimo_t(ipoint,3,p2,i) * tmpvec_2(ipoint,3) + int2_grad1_u12_bimo_t_tmp(ipoint,3,p2,h1) * tmpvec_3(ipoint,3) + + tmp3(ipoint,1,p2) = int2_grad1_u12_bimo_t_tmp(ipoint,1,p2,h1) + tmp3(ipoint,2,p2) = int2_grad1_u12_bimo_t_tmp(ipoint,2,p2,h1) + tmp3(ipoint,3,p2) = int2_grad1_u12_bimo_t_tmp(ipoint,3,p2,h1) + enddo + enddo + + call dgemm( 'T', 'N', mo_num, mo_num, n_points_final_grid, 0.5d0 & + , tmp2(1,1), n_points_final_grid & + , mos_r_in_r_array_transp_tmp(1,1), n_points_final_grid & + , 0.d0, tmp_2d(1,1), mo_num) + + call dgemm( 'T', 'N', mo_num, mo_num, 3*n_points_final_grid, 0.5d0 & + , tmp3(1,1,1), 3*n_points_final_grid & + , tmp1(1,1,1), 3*n_points_final_grid & + , 1.d0, tmp_2d(1,1), mo_num) + + do h2 = 1, mo_num + do p2 = 1, mo_num + tmp(p2,h2,p1,h1) = tmp(p2,h2,p1,h1) + tmp_2d(p2,h2) + enddo + enddo + + enddo ! p1 + enddo ! i + enddo ! h1 + !$OMP END DO + + deallocate(tmp_2d) + deallocate(tmp_3d) + deallocate(tmp1) + deallocate(tmp2) + deallocate(tmp3) + deallocate(tmpval_1) + deallocate(tmpval_2) + deallocate(tmpvec_1) + deallocate(tmpvec_2) + deallocate(tmpvec_3) + + !$OMP END PARALLEL + endif + + tmp = -0.5d0 * tmp + + !$OMP PARALLEL & + !$OMP DEFAULT (NONE) & + !$OMP PRIVATE (h1, h2, p1, p2) & + !$OMP SHARED (tmp, mo_num) + + !$OMP DO COLLAPSE(2) + do h1 = 1, mo_num + do h2 = 1, mo_num + do p1 = 1, mo_num + do p2 = p1, mo_num + tmp(p2,h2,p1,h1) -= tmp(p1,h2,p2,h1) + enddo + enddo + enddo + enddo + !$OMP END DO + + !$OMP DO COLLAPSE(2) + do h1 = 1, mo_num + do h2 = 1, mo_num + do p1 = 2, mo_num + do p2 = 1, p1-1 + tmp(p2,h2,p1,h1) = -tmp(p1,h2,p2,h1) + enddo + enddo + enddo + enddo + !$OMP END DO + + !$OMP DO + do h1 = 1, mo_num-1 + do h2 = h1+1, mo_num + do p1 = 2, mo_num + do p2 = 1, p1-1 + tmp(p2,h2,p1,h1) *= -1.d0 + enddo + enddo + enddo + enddo + !$OMP END DO + !$OMP END PARALLEL + + call wall_time(wall1) + print*,' Wall time for aaa_contraction_v0', wall1-wall0 + + normal_two_body_bi_orth_v0 += tmp + endif ! Ne(2) .ge. 3 + + deallocate(tmp) + deallocate(int2_grad1_u12_bimo_t_tmp, mos_l_in_r_array_transp_tmp, mos_r_in_r_array_transp_tmp) + + endif ! read_tc_norm_ord + + if(write_tc_norm_ord.and.mpi_master) then + open(unit=11, form="unformatted", file=trim(ezfio_filename)//'/work/normal_two_body_bi_orth', action="write") + call ezfio_set_work_empty(.False.) + write(11) normal_two_body_bi_orth_v0 + close(11) + call ezfio_set_tc_keywords_io_tc_integ('Read') + endif + + call wall_time(wallf) + print*,' Wall time for normal_two_body_bi_orth_v0 ', wallf-walli + +END_PROVIDER + +! --- + diff --git a/src/tc_bi_ortho/print_he_tc_energy.irp.f b/plugins/local/tc_bi_ortho/print_he_tc_energy.irp.f similarity index 100% rename from src/tc_bi_ortho/print_he_tc_energy.irp.f rename to plugins/local/tc_bi_ortho/print_he_tc_energy.irp.f diff --git a/src/tc_bi_ortho/print_tc_dump.irp.f b/plugins/local/tc_bi_ortho/print_tc_dump.irp.f similarity index 100% rename from src/tc_bi_ortho/print_tc_dump.irp.f rename to plugins/local/tc_bi_ortho/print_tc_dump.irp.f diff --git a/src/tc_bi_ortho/print_tc_energy.irp.f b/plugins/local/tc_bi_ortho/print_tc_energy.irp.f similarity index 100% rename from src/tc_bi_ortho/print_tc_energy.irp.f rename to plugins/local/tc_bi_ortho/print_tc_energy.irp.f diff --git a/src/tc_bi_ortho/print_tc_spin_dens.irp.f b/plugins/local/tc_bi_ortho/print_tc_spin_dens.irp.f similarity index 100% rename from src/tc_bi_ortho/print_tc_spin_dens.irp.f rename to plugins/local/tc_bi_ortho/print_tc_spin_dens.irp.f diff --git a/src/tc_bi_ortho/print_tc_var.irp.f b/plugins/local/tc_bi_ortho/print_tc_var.irp.f similarity index 100% rename from src/tc_bi_ortho/print_tc_var.irp.f rename to plugins/local/tc_bi_ortho/print_tc_var.irp.f diff --git a/src/tc_bi_ortho/print_tc_wf.irp.f b/plugins/local/tc_bi_ortho/print_tc_wf.irp.f similarity index 100% rename from src/tc_bi_ortho/print_tc_wf.irp.f rename to plugins/local/tc_bi_ortho/print_tc_wf.irp.f diff --git a/src/tc_bi_ortho/psi_det_tc_sorted.irp.f b/plugins/local/tc_bi_ortho/psi_det_tc_sorted.irp.f similarity index 100% rename from src/tc_bi_ortho/psi_det_tc_sorted.irp.f rename to plugins/local/tc_bi_ortho/psi_det_tc_sorted.irp.f diff --git a/src/tc_bi_ortho/psi_left_qmc.irp.f b/plugins/local/tc_bi_ortho/psi_left_qmc.irp.f similarity index 100% rename from src/tc_bi_ortho/psi_left_qmc.irp.f rename to plugins/local/tc_bi_ortho/psi_left_qmc.irp.f diff --git a/src/tc_bi_ortho/psi_r_l_prov.irp.f b/plugins/local/tc_bi_ortho/psi_r_l_prov.irp.f similarity index 100% rename from src/tc_bi_ortho/psi_r_l_prov.irp.f rename to plugins/local/tc_bi_ortho/psi_r_l_prov.irp.f diff --git a/src/tc_bi_ortho/pt2_tc_cisd.irp.f b/plugins/local/tc_bi_ortho/pt2_tc_cisd.irp.f similarity index 100% rename from src/tc_bi_ortho/pt2_tc_cisd.irp.f rename to plugins/local/tc_bi_ortho/pt2_tc_cisd.irp.f diff --git a/src/tc_bi_ortho/save_bitcpsileft_for_qmcchem.irp.f b/plugins/local/tc_bi_ortho/save_bitcpsileft_for_qmcchem.irp.f similarity index 100% rename from src/tc_bi_ortho/save_bitcpsileft_for_qmcchem.irp.f rename to plugins/local/tc_bi_ortho/save_bitcpsileft_for_qmcchem.irp.f diff --git a/src/tc_bi_ortho/save_tc_bi_ortho_nat.irp.f b/plugins/local/tc_bi_ortho/save_tc_bi_ortho_nat.irp.f similarity index 56% rename from src/tc_bi_ortho/save_tc_bi_ortho_nat.irp.f rename to plugins/local/tc_bi_ortho/save_tc_bi_ortho_nat.irp.f index 47ade8df..ffcd9b22 100644 --- a/src/tc_bi_ortho/save_tc_bi_ortho_nat.irp.f +++ b/plugins/local/tc_bi_ortho/save_tc_bi_ortho_nat.irp.f @@ -15,13 +15,27 @@ program tc_natorb_bi_ortho PROVIDE tc_grid1_a tc_grid1_r my_n_pt_r_grid = tc_grid1_r my_n_pt_a_grid = tc_grid1_a - touch my_grid_becke my_n_pt_r_grid my_n_pt_a_grid + touch my_grid_becke my_n_pt_r_grid my_n_pt_a_grid + + if(j1b_type .ge. 100) then + my_extra_grid_becke = .True. + PROVIDE tc_grid2_a tc_grid2_r + my_n_pt_r_extra_grid = tc_grid2_r + my_n_pt_a_extra_grid = tc_grid2_a + touch my_extra_grid_becke my_n_pt_r_extra_grid my_n_pt_a_extra_grid + + call write_int(6, my_n_pt_r_extra_grid, 'radial internal grid over') + call write_int(6, my_n_pt_a_extra_grid, 'angular internal grid over') + endif + + read_wf = .True. touch read_wf call print_energy_and_mos() call save_tc_natorb() + call print_angles_tc() !call minimize_tc_orb_angles() end @@ -35,9 +49,12 @@ subroutine save_tc_natorb() print*,'Saving the natorbs ' provide natorb_tc_leigvec_ao natorb_tc_reigvec_ao + mo_l_coef = natorb_tc_leigvec_ao + mo_r_coef = natorb_tc_reigvec_ao + touch mo_l_coef mo_r_coef - call ezfio_set_bi_ortho_mos_mo_l_coef(natorb_tc_leigvec_ao) - call ezfio_set_bi_ortho_mos_mo_r_coef(natorb_tc_reigvec_ao) + call ezfio_set_bi_ortho_mos_mo_l_coef(mo_l_coef) + call ezfio_set_bi_ortho_mos_mo_r_coef(mo_r_coef) call save_ref_determinant_nstates_1() call ezfio_set_determinants_read_wf(.False.) diff --git a/src/tc_bi_ortho/select_dets_bi_ortho.irp.f b/plugins/local/tc_bi_ortho/select_dets_bi_ortho.irp.f similarity index 100% rename from src/tc_bi_ortho/select_dets_bi_ortho.irp.f rename to plugins/local/tc_bi_ortho/select_dets_bi_ortho.irp.f diff --git a/src/tc_bi_ortho/slater_tc_3e_slow.irp.f b/plugins/local/tc_bi_ortho/slater_tc_3e_slow.irp.f similarity index 100% rename from src/tc_bi_ortho/slater_tc_3e_slow.irp.f rename to plugins/local/tc_bi_ortho/slater_tc_3e_slow.irp.f diff --git a/src/tc_bi_ortho/slater_tc_opt.irp.f b/plugins/local/tc_bi_ortho/slater_tc_opt.irp.f similarity index 66% rename from src/tc_bi_ortho/slater_tc_opt.irp.f rename to plugins/local/tc_bi_ortho/slater_tc_opt.irp.f index 72f55aca..9901a853 100644 --- a/src/tc_bi_ortho/slater_tc_opt.irp.f +++ b/plugins/local/tc_bi_ortho/slater_tc_opt.irp.f @@ -4,10 +4,11 @@ subroutine provide_all_three_ints_bi_ortho() BEGIN_DOC - ! routine that provides all necessary three-electron integrals + ! routine that provides all necessary three-electron integrals END_DOC implicit none + PROVIDE ao_two_e_integrals_in_map if(three_body_h_tc) then @@ -17,11 +18,14 @@ subroutine provide_all_three_ints_bi_ortho() endif if(three_e_4_idx_term) then - PROVIDE three_e_4_idx_direct_bi_ort three_e_4_idx_cycle_1_bi_ort three_e_4_idx_exch23_bi_ort three_e_4_idx_exch13_bi_ort + PROVIDE three_e_4_idx_direct_bi_ort three_e_4_idx_cycle_1_bi_ort three_e_4_idx_exch23_bi_ort three_e_4_idx_exch13_bi_ort + endif + if(pure_three_body_h_tc)then + provide three_body_ints_bi_ort endif if(.not. double_normal_ord .and. three_e_5_idx_term) then - PROVIDE three_e_5_idx_direct_bi_ort + PROVIDE three_e_5_idx_direct_bi_ort elseif(double_normal_ord .and. (.not. three_e_5_idx_term)) then PROVIDE normal_two_body_bi_orth endif @@ -34,14 +38,16 @@ end ! --- subroutine htilde_mu_mat_opt_bi_ortho_tot(key_j, key_i, Nint, htot) - implicit none + + implicit none + BEGIN_DOC ! ! where |key_j> is developed on the LEFT basis and |key_i> is developed on the RIGHT basis !! - ! Returns the total matrix element + ! Returns the total matrix element !! WARNING !! - ! + ! ! Non hermitian !! ! END_DOC @@ -50,7 +56,7 @@ subroutine htilde_mu_mat_opt_bi_ortho_tot(key_j, key_i, Nint, htot) integer, intent(in) :: Nint integer(bit_kind), intent(in) :: key_i(Nint,2), key_j(Nint,2) double precision, intent(out) :: htot - double precision :: hmono, htwoe, hthree + double precision :: hmono, htwoe, hthree call htilde_mu_mat_opt_bi_ortho(key_j, key_i, Nint, hmono, htwoe, hthree, htot) @@ -64,9 +70,9 @@ subroutine htilde_mu_mat_opt_bi_ortho(key_j, key_i, Nint, hmono, htwoe, hthree, ! ! where |key_j> is developed on the LEFT basis and |key_i> is developed on the RIGHT basis !! - ! Returns the detail of the matrix element in terms of single, two and three electron contribution. + ! Returns the detail of the matrix element in terms of single, two and three electron contribution. !! WARNING !! - ! + ! ! Non hermitian !! ! END_DOC @@ -77,28 +83,47 @@ subroutine htilde_mu_mat_opt_bi_ortho(key_j, key_i, Nint, hmono, htwoe, hthree, integer, intent(in) :: Nint integer(bit_kind), intent(in) :: key_i(Nint,2), key_j(Nint,2) double precision, intent(out) :: hmono, htwoe, hthree, htot - integer :: degree + integer :: degree hmono = 0.d0 htwoe = 0.d0 htot = 0.d0 - hthree = 0.D0 + hthree = 0.d0 call get_excitation_degree(key_i, key_j, degree, Nint) - if(degree.gt.2) return - if(degree == 0) then - call diag_htilde_mu_mat_fock_bi_ortho (Nint, key_i, hmono, htwoe, hthree, htot) - else if (degree == 1) then - call single_htilde_mu_mat_fock_bi_ortho(Nint, key_j, key_i , hmono, htwoe, hthree, htot) - else if(degree == 2) then - call double_htilde_mu_mat_fock_bi_ortho(Nint, key_j, key_i, hmono, htwoe, hthree, htot) + if(.not.pure_three_body_h_tc) then + + if(degree .gt. 2) return + + if(degree == 0) then + call diag_htilde_mu_mat_fock_bi_ortho (Nint, key_i, hmono, htwoe, hthree, htot) + else if (degree == 1) then + call single_htilde_mu_mat_fock_bi_ortho(Nint, key_j, key_i , hmono, htwoe, hthree, htot) + else if(degree == 2) then + call double_htilde_mu_mat_fock_bi_ortho(Nint, key_j, key_i, hmono, htwoe, hthree, htot) + endif + + else + + if(degree .gt. 3) return + + if(degree == 0) then + call diag_htilde_mu_mat_fock_bi_ortho (Nint, key_i, hmono, htwoe, hthree, htot) + else if (degree == 1) then + call single_htilde_mu_mat_fock_bi_ortho(Nint, key_j, key_i , hmono, htwoe, hthree, htot) + else if(degree == 2) then + call double_htilde_mu_mat_fock_bi_ortho(Nint, key_j, key_i, hmono, htwoe, hthree, htot) + else + call triple_htilde_mu_mat_fock_bi_ortho(Nint, key_j, key_i, hmono, htwoe, hthree, htot) + endif + endif if(degree==0) then htot += nuclear_repulsion endif - + end ! --- @@ -109,9 +134,9 @@ subroutine htilde_mu_mat_opt_bi_ortho_no_3e(key_j, key_i, Nint, htot) ! ! where |key_j> is developed on the LEFT basis and |key_i> is developed on the RIGHT basis !! - ! Returns the detail of the matrix element WITHOUT ANY CONTRIBUTION FROM THE THREE ELECTRON TERMS + ! Returns the detail of the matrix element WITHOUT ANY CONTRIBUTION FROM THE THREE ELECTRON TERMS !! WARNING !! - ! + ! ! Non hermitian !! ! END_DOC @@ -122,7 +147,7 @@ subroutine htilde_mu_mat_opt_bi_ortho_no_3e(key_j, key_i, Nint, htot) integer, intent(in) :: Nint integer(bit_kind), intent(in) :: key_i(Nint,2), key_j(Nint,2) double precision, intent(out) :: htot - integer :: degree + integer :: degree htot = 0.d0 @@ -140,7 +165,8 @@ subroutine htilde_mu_mat_opt_bi_ortho_no_3e(key_j, key_i, Nint, htot) if(degree==0) then htot += nuclear_repulsion endif - + end ! --- + diff --git a/src/tc_bi_ortho/slater_tc_opt_diag.irp.f b/plugins/local/tc_bi_ortho/slater_tc_opt_diag.irp.f similarity index 85% rename from src/tc_bi_ortho/slater_tc_opt_diag.irp.f rename to plugins/local/tc_bi_ortho/slater_tc_opt_diag.irp.f index d95c87b1..cc1a0603 100644 --- a/src/tc_bi_ortho/slater_tc_opt_diag.irp.f +++ b/plugins/local/tc_bi_ortho/slater_tc_opt_diag.irp.f @@ -7,7 +7,9 @@ &BEGIN_PROVIDER [ double precision, ref_tc_energy_3e] BEGIN_DOC + ! ! Various component of the TC energy for the reference "HF" Slater determinant + ! END_DOC implicit none @@ -29,6 +31,11 @@ ref_tc_energy_tot = ref_tc_energy_1e + ref_tc_energy_2e + ref_tc_energy_3e + nuclear_repulsion + if(noL_standard) then + PROVIDE noL_0e + ref_tc_energy_tot += noL_0e + endif + END_PROVIDER ! --- @@ -36,7 +43,9 @@ END_PROVIDER subroutine diag_htilde_mu_mat_fock_bi_ortho(Nint, det_in, hmono, htwoe, hthree, htot) BEGIN_DOC + ! ! Computes $\langle i|H|i \rangle$. + ! END_DOC implicit none @@ -58,7 +67,7 @@ subroutine diag_htilde_mu_mat_fock_bi_ortho(Nint, det_in, hmono, htwoe, hthree, nexc(1) = 0 nexc(2) = 0 - do i=1,Nint + do i = 1, Nint hole(i,1) = xor(det_in(i,1),ref_bitmask(i,1)) hole(i,2) = xor(det_in(i,2),ref_bitmask(i,2)) particle(i,1) = iand(hole(i,1),det_in(i,1)) @@ -107,6 +116,11 @@ subroutine diag_htilde_mu_mat_fock_bi_ortho(Nint, det_in, hmono, htwoe, hthree, htot = hmono + htwoe + hthree + nuclear_repulsion + if(noL_standard) then + PROVIDE noL_0e + htot += noL_0e + endif + end ! --- @@ -114,6 +128,7 @@ end subroutine ac_tc_operator(iorb, ispin, key, hmono, htwoe, hthree, Nint, na, nb) BEGIN_DOC + ! ! Routine that computes one- and two-body energy corresponding ! ! to the ADDITION of an electron in an orbital 'iorb' of spin 'ispin' @@ -123,6 +138,7 @@ subroutine ac_tc_operator(iorb, ispin, key, hmono, htwoe, hthree, Nint, na, nb) ! in output, the determinant key is changed by the ADDITION of that electron ! ! and the quantities hmono,htwoe,hthree are INCREMENTED + ! END_DOC use bitmasks @@ -178,8 +194,8 @@ subroutine ac_tc_operator(iorb, ispin, key, hmono, htwoe, hthree, Nint, na, nb) enddo if(three_body_h_tc .and. (elec_num.gt.2) .and. three_e_3_idx_term) then - !!!!! 3-e part + !! same-spin/same-spin do j = 1, na jj = occ(j,ispin) @@ -210,16 +226,19 @@ subroutine ac_tc_operator(iorb, ispin, key, hmono, htwoe, hthree, Nint, na, nb) enddo endif - na = na+1 + na = na + 1 end ! --- -subroutine a_tc_operator(iorb,ispin,key,hmono,htwoe,hthree,Nint,na,nb) +subroutine a_tc_operator(iorb, ispin, key, hmono, htwoe, hthree, Nint, na, nb) + use bitmasks implicit none + BEGIN_DOC + ! ! Routine that computes one- and two-body energy corresponding ! ! to the REMOVAL of an electron in an orbital 'iorb' of spin 'ispin' @@ -229,17 +248,19 @@ subroutine a_tc_operator(iorb,ispin,key,hmono,htwoe,hthree,Nint,na,nb) ! in output, the determinant key is changed by the REMOVAL of that electron ! ! and the quantities hmono,htwoe,hthree are INCREMENTED + ! END_DOC - integer, intent(in) :: iorb, ispin, Nint - integer, intent(inout) :: na, nb + + integer, intent(in) :: iorb, ispin, Nint + integer, intent(inout) :: na, nb integer(bit_kind), intent(inout) :: key(Nint,2) - double precision, intent(inout) :: hmono,htwoe,hthree + double precision, intent(inout) :: hmono,htwoe,hthree - double precision :: direct_int, exchange_int - integer :: occ(Nint*bit_kind_size,2) - integer :: other_spin - integer :: k,l,i,jj,mm,j,m - integer :: tmp(2) + double precision :: direct_int, exchange_int + integer :: occ(Nint*bit_kind_size,2) + integer :: other_spin + integer :: k, l, i, jj, mm, j, m + integer :: tmp(2) ASSERT (iorb > 0) ASSERT (ispin > 0) @@ -259,60 +280,63 @@ subroutine a_tc_operator(iorb,ispin,key,hmono,htwoe,hthree,Nint,na,nb) hmono = hmono - mo_bi_ortho_tc_one_e(iorb,iorb) ! Same spin - do i=1,na - htwoe= htwoe- mo_bi_ortho_tc_two_e_jj_anti(occ(i,ispin),iorb) + do i = 1, na + htwoe = htwoe - mo_bi_ortho_tc_two_e_jj_anti(occ(i,ispin),iorb) enddo ! Opposite spin - do i=1,nb - htwoe= htwoe- mo_bi_ortho_tc_two_e_jj(occ(i,other_spin),iorb) + do i = 1, nb + htwoe = htwoe - mo_bi_ortho_tc_two_e_jj(occ(i,other_spin),iorb) enddo - if(three_body_h_tc.and.elec_num.gt.2.and.three_e_3_idx_term)then - !!!!! 3-e part - !! same-spin/same-spin - do j = 1, na - jj = occ(j,ispin) - do m = j+1, na - mm = occ(m,ispin) - hthree -= three_e_diag_parrallel_spin_prov(mm,jj,iorb) + if(three_body_h_tc .and. elec_num.gt.2 .and. three_e_3_idx_term) then + !!!!! 3-e part + + !! same-spin/same-spin + do j = 1, na + jj = occ(j,ispin) + do m = j+1, na + mm = occ(m,ispin) + hthree -= three_e_diag_parrallel_spin_prov(mm,jj,iorb) + enddo enddo - enddo - !! same-spin/oposite-spin - do j = 1, na - jj = occ(j,ispin) - do m = 1, nb - mm = occ(m,other_spin) - direct_int = three_e_3_idx_direct_bi_ort(mm,jj,iorb) ! USES 3-IDX TENSOR - exchange_int = three_e_3_idx_exch12_bi_ort(mm,jj,iorb) ! USES 3-IDX TENSOR - hthree -= (direct_int - exchange_int) - enddo - enddo - !! oposite-spin/opposite-spin + !! same-spin/oposite-spin + do j = 1, na + jj = occ(j,ispin) + do m = 1, nb + mm = occ(m,other_spin) + direct_int = three_e_3_idx_direct_bi_ort(mm,jj,iorb) ! USES 3-IDX TENSOR + exchange_int = three_e_3_idx_exch12_bi_ort(mm,jj,iorb) ! USES 3-IDX TENSOR + hthree -= (direct_int - exchange_int) + enddo + enddo + !! oposite-spin/opposite-spin do j = 1, nb - jj = occ(j,other_spin) - do m = j+1, nb - mm = occ(m,other_spin) - direct_int = three_e_3_idx_direct_bi_ort(mm,jj,iorb) ! USES 3-IDX TENSOR - exchange_int = three_e_3_idx_exch23_bi_ort(mm,jj,iorb) ! USES 3-IDX TENSOR - hthree -= (direct_int - exchange_int) - enddo + jj = occ(j,other_spin) + do m = j+1, nb + mm = occ(m,other_spin) + direct_int = three_e_3_idx_direct_bi_ort(mm,jj,iorb) ! USES 3-IDX TENSOR + exchange_int = three_e_3_idx_exch23_bi_ort(mm,jj,iorb) ! USES 3-IDX TENSOR + hthree -= (direct_int - exchange_int) + enddo enddo endif end +! --- subroutine diag_htilde_mu_mat_fock_bi_ortho_no_3e(Nint, det_in,htot) - implicit none + BEGIN_DOC ! Computes $\langle i|H|i \rangle$. WITHOUT ANY CONTRIBUTIONS FROM 3E TERMS END_DOC - integer,intent(in) :: Nint - integer(bit_kind),intent(in) :: det_in(Nint,2) - double precision, intent(out) :: htot - double precision :: hmono,htwoe + implicit none + integer, intent(in) :: Nint + integer(bit_kind), intent(in) :: det_in(Nint,2) + double precision, intent(out) :: htot + double precision :: hmono, htwoe integer(bit_kind) :: hole(Nint,2) integer(bit_kind) :: particle(Nint,2) integer :: i, nexc(2), ispin @@ -339,15 +363,15 @@ subroutine diag_htilde_mu_mat_fock_bi_ortho_no_3e(Nint, det_in,htot) nexc(2) = nexc(2) + popcnt(hole(i,2)) enddo - if (nexc(1)+nexc(2) == 0) then + if(nexc(1)+nexc(2) == 0) then hmono = ref_tc_energy_1e htwoe = ref_tc_energy_2e - htot = ref_tc_energy_tot + htot = ref_tc_energy_tot return endif !call debug_det(det_in,Nint) - integer :: tmp(2) + integer :: tmp(2) !DIR$ FORCEINLINE call bitstring_to_list_ab(particle, occ_particle, tmp, Nint) ASSERT (tmp(1) == nexc(1)) ! Number of particles alpha @@ -357,8 +381,8 @@ subroutine diag_htilde_mu_mat_fock_bi_ortho_no_3e(Nint, det_in,htot) ASSERT (tmp(1) == nexc(1)) ! Number of holes alpha ASSERT (tmp(2) == nexc(2)) ! Number of holes beta - det_tmp = ref_bitmask + hmono = ref_tc_energy_1e htwoe = ref_tc_energy_2e do ispin=1,2 diff --git a/src/tc_bi_ortho/slater_tc_opt_double.irp.f b/plugins/local/tc_bi_ortho/slater_tc_opt_double.irp.f similarity index 91% rename from src/tc_bi_ortho/slater_tc_opt_double.irp.f rename to plugins/local/tc_bi_ortho/slater_tc_opt_double.irp.f index bd59583f..4067473c 100644 --- a/src/tc_bi_ortho/slater_tc_opt_double.irp.f +++ b/plugins/local/tc_bi_ortho/slater_tc_opt_double.irp.f @@ -1,4 +1,6 @@ +! --- + subroutine double_htilde_mu_mat_fock_bi_ortho(Nint, key_j, key_i, hmono, htwoe, hthree, htot) BEGIN_DOC @@ -29,55 +31,77 @@ subroutine double_htilde_mu_mat_fock_bi_ortho(Nint, key_j, key_i, hmono, htwoe, hthree = 0.d0 htot = 0.d0 - if(degree.ne.2)then - return + if(degree .ne. 2) then + return endif - integer :: degree_i,degree_j - call get_excitation_degree(ref_bitmask,key_i,degree_i,N_int) - call get_excitation_degree(ref_bitmask,key_j,degree_j,N_int) + + integer :: degree_i, degree_j + call get_excitation_degree(ref_bitmask, key_i, degree_i, N_int) + call get_excitation_degree(ref_bitmask, key_j, degree_j, N_int) call get_double_excitation(key_i, key_j, exc, phase, Nint) call decode_exc(exc, 2, h1, p1, h2, p2, s1, s2) - if(s1.ne.s2)then - ! opposite spin two-body - htwoe = mo_bi_ortho_tc_two_e(p2,p1,h2,h1) - if(three_body_h_tc.and.elec_num.gt.2)then - if(.not.double_normal_ord.and.three_e_5_idx_term)then - if(degree_i>degree_j)then - call three_comp_two_e_elem(key_j,h1,h2,p1,p2,s1,s2,hthree) - else - call three_comp_two_e_elem(key_i,h1,h2,p1,p2,s1,s2,hthree) + if(s1 .ne. s2) then + ! opposite spin two-body + + htwoe = mo_bi_ortho_tc_two_e(p2,p1,h2,h1) + + if(three_body_h_tc .and. (elec_num .gt. 2)) then + ! add 3-e term + + if(.not.double_normal_ord .and. three_e_5_idx_term) then + ! 5-idx approx + + if(degree_i > degree_j) then + call three_comp_two_e_elem(key_j,h1,h2,p1,p2,s1,s2,hthree) + else + call three_comp_two_e_elem(key_i,h1,h2,p1,p2,s1,s2,hthree) + endif + + elseif(double_normal_ord) then + ! noL a la Manu + + htwoe += normal_two_body_bi_orth(p2,h2,p1,h1) endif - elseif(double_normal_ord)then - htwoe += normal_two_body_bi_orth(p2,h2,p1,h1) - endif endif + else - ! same spin two-body - ! direct terms - htwoe = mo_bi_ortho_tc_two_e(p2,p1,h2,h1) - ! exchange terms - htwoe -= mo_bi_ortho_tc_two_e(p1,p2,h2,h1) - if(three_body_h_tc.and.elec_num.gt.2)then - if(.not.double_normal_ord.and.three_e_5_idx_term)then - if(degree_i>degree_j)then - call three_comp_two_e_elem(key_j,h1,h2,p1,p2,s1,s2,hthree) - else - call three_comp_two_e_elem(key_i,h1,h2,p1,p2,s1,s2,hthree) - endif - elseif(double_normal_ord)then - htwoe -= normal_two_body_bi_orth(h2,p1,h1,p2) - htwoe += normal_two_body_bi_orth(h1,p1,h2,p2) + ! same spin two-body + + ! direct terms + htwoe = mo_bi_ortho_tc_two_e(p2,p1,h2,h1) + + ! exchange terms + htwoe -= mo_bi_ortho_tc_two_e(p1,p2,h2,h1) + + if(three_body_h_tc .and. (elec_num .gt. 2)) then + ! add 3-e term + + if(.not.double_normal_ord.and.three_e_5_idx_term)then + ! 5-idx approx + + if(degree_i > degree_j) then + call three_comp_two_e_elem(key_j,h1,h2,p1,p2,s1,s2,hthree) + else + call three_comp_two_e_elem(key_i,h1,h2,p1,p2,s1,s2,hthree) + endif + + elseif(double_normal_ord) then + ! noL a la Manu + + htwoe -= normal_two_body_bi_orth(h2,p1,h1,p2) + htwoe += normal_two_body_bi_orth(h1,p1,h2,p2) + endif endif - endif endif + hthree *= phase htwoe *= phase - htot = htwoe + hthree + htot = htwoe + hthree end - +! --- subroutine three_comp_two_e_elem(key_i,h1,h2,p1,p2,s1,s2,hthree) implicit none diff --git a/src/tc_bi_ortho/slater_tc_opt_single.irp.f b/plugins/local/tc_bi_ortho/slater_tc_opt_single.irp.f similarity index 84% rename from src/tc_bi_ortho/slater_tc_opt_single.irp.f rename to plugins/local/tc_bi_ortho/slater_tc_opt_single.irp.f index ddcd1e66..81bf69f4 100644 --- a/src/tc_bi_ortho/slater_tc_opt_single.irp.f +++ b/plugins/local/tc_bi_ortho/slater_tc_opt_single.irp.f @@ -1,12 +1,16 @@ +! --- + +subroutine single_htilde_mu_mat_fock_bi_ortho(Nint, key_j, key_i, hmono, htwoe, hthree, htot) -subroutine single_htilde_mu_mat_fock_bi_ortho (Nint, key_j, key_i, hmono, htwoe, hthree, htot) BEGIN_DOC + ! ! for single excitation ONLY FOR ONE- AND TWO-BODY TERMS !! !! WARNING !! ! ! Non hermitian !! + ! END_DOC use bitmasks @@ -31,93 +35,105 @@ subroutine single_htilde_mu_mat_fock_bi_ortho (Nint, key_j, key_i, hmono, htwoe htwoe = 0.d0 hthree = 0.d0 htot = 0.d0 + call get_excitation_degree(key_i, key_j, degree, Nint) - if(degree.ne.1)then - return + if(degree .ne. 1) then + return endif + call bitstring_to_list_ab(key_i, occ, Ne, Nint) - call get_single_excitation(key_i, key_j, exc, phase, Nint) - call decode_exc(exc,1,h1,p1,h2,p2,s1,s2) - call get_single_excitation_from_fock_tc(key_i,key_j,h1,p1,s1,phase,hmono,htwoe,hthree,htot) -end - - -subroutine get_single_excitation_from_fock_tc(key_i,key_j,h,p,spin,phase,hmono,htwoe,hthree,htot) - use bitmasks - implicit none - integer,intent(in) :: h,p,spin - double precision, intent(in) :: phase - integer(bit_kind), intent(in) :: key_i(N_int,2), key_j(N_int,2) - double precision, intent(out) :: hmono,htwoe,hthree,htot - integer(bit_kind) :: differences(N_int,2) - integer(bit_kind) :: hole(N_int,2) - integer(bit_kind) :: partcl(N_int,2) - integer :: occ_hole(N_int*bit_kind_size,2) - integer :: occ_partcl(N_int*bit_kind_size,2) - integer :: n_occ_ab_hole(2),n_occ_ab_partcl(2) - integer :: i0,i - double precision :: buffer_c(mo_num),buffer_x(mo_num) - do i=1, mo_num - buffer_c(i) = tc_2e_3idx_coulomb_integrals(i,p,h) - buffer_x(i) = tc_2e_3idx_exchange_integrals(i,p,h) - enddo - do i = 1, N_int - differences(i,1) = xor(key_i(i,1),ref_closed_shell_bitmask(i,1)) - differences(i,2) = xor(key_i(i,2),ref_closed_shell_bitmask(i,2)) - hole(i,1) = iand(differences(i,1),ref_closed_shell_bitmask(i,1)) - hole(i,2) = iand(differences(i,2),ref_closed_shell_bitmask(i,2)) - partcl(i,1) = iand(differences(i,1),key_i(i,1)) - partcl(i,2) = iand(differences(i,2),key_i(i,2)) - enddo - call bitstring_to_list_ab(hole, occ_hole, n_occ_ab_hole, N_int) - call bitstring_to_list_ab(partcl, occ_partcl, n_occ_ab_partcl, N_int) - hmono = mo_bi_ortho_tc_one_e(p,h) - htwoe = fock_op_2_e_tc_closed_shell(p,h) - ! holes :: direct terms - do i0 = 1, n_occ_ab_hole(1) - i = occ_hole(i0,1) - htwoe -= buffer_c(i) - enddo - do i0 = 1, n_occ_ab_hole(2) - i = occ_hole(i0,2) - htwoe -= buffer_c(i) - enddo - - ! holes :: exchange terms - do i0 = 1, n_occ_ab_hole(spin) - i = occ_hole(i0,spin) - htwoe += buffer_x(i) - enddo - - ! particles :: direct terms - do i0 = 1, n_occ_ab_partcl(1) - i = occ_partcl(i0,1) - htwoe += buffer_c(i) - enddo - do i0 = 1, n_occ_ab_partcl(2) - i = occ_partcl(i0,2) - htwoe += buffer_c(i) - enddo - - ! particles :: exchange terms - do i0 = 1, n_occ_ab_partcl(spin) - i = occ_partcl(i0,spin) - htwoe -= buffer_x(i) - enddo - hthree = 0.d0 - if (three_body_h_tc.and.elec_num.gt.2.and.three_e_4_idx_term)then - call three_comp_fock_elem(key_i,h,p,spin,hthree) - endif - - - htwoe = htwoe * phase - hmono = hmono * phase - hthree = hthree * phase - htot = htwoe + hmono + hthree + call decode_exc(exc, 1, h1, p1, h2, p2, s1, s2) + call get_single_excitation_from_fock_tc(key_i, key_j, h1, p1, s1, phase, hmono, htwoe, hthree, htot) end +! --- + +subroutine get_single_excitation_from_fock_tc(key_i, key_j, h, p, spin, phase, hmono, htwoe, hthree, htot) + + use bitmasks + + implicit none + integer, intent(in) :: h, p, spin + double precision, intent(in) :: phase + integer(bit_kind), intent(in) :: key_i(N_int,2), key_j(N_int,2) + double precision, intent(out) :: hmono, htwoe, hthree, htot + + integer(bit_kind) :: differences(N_int,2) + integer(bit_kind) :: hole(N_int,2) + integer(bit_kind) :: partcl(N_int,2) + integer :: occ_hole(N_int*bit_kind_size,2) + integer :: occ_partcl(N_int*bit_kind_size,2) + integer :: n_occ_ab_hole(2),n_occ_ab_partcl(2) + integer :: i0,i + double precision :: buffer_c(mo_num),buffer_x(mo_num) + + do i = 1, mo_num + buffer_c(i) = tc_2e_3idx_coulomb_integrals (i,p,h) + buffer_x(i) = tc_2e_3idx_exchange_integrals(i,p,h) + enddo + + do i = 1, N_int + differences(i,1) = xor(key_i(i,1), ref_closed_shell_bitmask(i,1)) + differences(i,2) = xor(key_i(i,2), ref_closed_shell_bitmask(i,2)) + hole (i,1) = iand(differences(i,1), ref_closed_shell_bitmask(i,1)) + hole (i,2) = iand(differences(i,2), ref_closed_shell_bitmask(i,2)) + partcl (i,1) = iand(differences(i,1), key_i(i,1)) + partcl (i,2) = iand(differences(i,2), key_i(i,2)) + enddo + + call bitstring_to_list_ab(hole, occ_hole, n_occ_ab_hole, N_int) + call bitstring_to_list_ab(partcl, occ_partcl, n_occ_ab_partcl, N_int) + hmono = mo_bi_ortho_tc_one_e(p,h) + htwoe = fock_op_2_e_tc_closed_shell(p,h) + + ! holes :: direct terms + do i0 = 1, n_occ_ab_hole(1) + i = occ_hole(i0,1) + htwoe -= buffer_c(i) + enddo + do i0 = 1, n_occ_ab_hole(2) + i = occ_hole(i0,2) + htwoe -= buffer_c(i) + enddo + + ! holes :: exchange terms + do i0 = 1, n_occ_ab_hole(spin) + i = occ_hole(i0,spin) + htwoe += buffer_x(i) + enddo + + ! particles :: direct terms + do i0 = 1, n_occ_ab_partcl(1) + i = occ_partcl(i0,1) + htwoe += buffer_c(i) + enddo + do i0 = 1, n_occ_ab_partcl(2) + i = occ_partcl(i0,2) + htwoe += buffer_c(i) + enddo + + ! particles :: exchange terms + do i0 = 1, n_occ_ab_partcl(spin) + i = occ_partcl(i0,spin) + htwoe -= buffer_x(i) + enddo + + hthree = 0.d0 + if (three_body_h_tc .and. elec_num.gt.2 .and. three_e_4_idx_term) then + call three_comp_fock_elem(key_i, h, p, spin, hthree) + endif + + htwoe = htwoe * phase + hmono = hmono * phase + hthree = hthree * phase + htot = htwoe + hmono + hthree + +end + +! --- + subroutine three_comp_fock_elem(key_i,h_fock,p_fock,ispin_fock,hthree) implicit none integer,intent(in) :: h_fock,p_fock,ispin_fock diff --git a/src/tc_bi_ortho/slater_tc_slow.irp.f b/plugins/local/tc_bi_ortho/slater_tc_slow.irp.f similarity index 84% rename from src/tc_bi_ortho/slater_tc_slow.irp.f rename to plugins/local/tc_bi_ortho/slater_tc_slow.irp.f index 83a56d2d..b1751069 100644 --- a/src/tc_bi_ortho/slater_tc_slow.irp.f +++ b/plugins/local/tc_bi_ortho/slater_tc_slow.irp.f @@ -81,8 +81,14 @@ subroutine htilde_mu_mat_bi_ortho_slow(key_j, key_i, Nint, hmono, htwoe, hthree, endif htot = hmono + htwoe + hthree + if(degree==0) then htot += nuclear_repulsion + + if(noL_standard) then + PROVIDE noL_0e + htot += noL_0e + endif endif end @@ -92,7 +98,9 @@ end subroutine diag_htilde_mu_mat_bi_ortho_slow(Nint, key_i, hmono, htwoe, htot) BEGIN_DOC - ! diagonal element of htilde ONLY FOR ONE- AND TWO-BODY TERMS + ! + ! diagonal element of htilde ONLY FOR ONE- AND TWO-BODY TERMS + ! END_DOC use bitmasks @@ -108,78 +116,53 @@ subroutine diag_htilde_mu_mat_bi_ortho_slow(Nint, key_i, hmono, htwoe, htot) PROVIDE mo_bi_ortho_tc_two_e -! PROVIDE mo_two_e_integrals_tc_int_in_map mo_bi_ortho_tc_two_e -! -! PROVIDE mo_integrals_erf_map core_energy nuclear_repulsion core_bitmask -! PROVIDE core_fock_operator -! -! PROVIDE j1b_gauss + hmono = 0.d0 + htwoe = 0.d0 + htot = 0.d0 -! if(core_tc_op)then -! print*,'core_tc_op not already taken into account for bi ortho' -! print*,'stopping ...' -! stop -! do i = 1, Nint -! key_i_core(i,1) = xor(key_i(i,1),core_bitmask(i,1)) -! key_i_core(i,2) = xor(key_i(i,2),core_bitmask(i,2)) -! enddo -! call bitstring_to_list_ab(key_i_core, occ, Ne, Nint) -! hmono = core_energy - nuclear_repulsion -! else - call bitstring_to_list_ab(key_i, occ, Ne, Nint) - hmono = 0.d0 -! endif - htwoe= 0.d0 - htot = 0.d0 + call bitstring_to_list_ab(key_i, occ, Ne, Nint) do ispin = 1, 2 - do i = 1, Ne(ispin) ! - ii = occ(i,ispin) - hmono += mo_bi_ortho_tc_one_e(ii,ii) - -! if(core_tc_op)then -! print*,'core_tc_op not already taken into account for bi ortho' -! print*,'stopping ...' -! stop -! hmono += core_fock_operator(ii,ii) ! add the usual Coulomb - Exchange from the core -! endif - enddo + do i = 1, Ne(ispin) + ii = occ(i,ispin) + hmono += mo_bi_ortho_tc_one_e(ii,ii) + enddo enddo - - ! alpha/beta two-body - ispin = 1 - jspin = 2 - do i = 1, Ne(ispin) ! electron 1 (so it can be associated to mu(r1)) + ! alpha/beta two-body + ispin = 1 + jspin = 2 + do i = 1, Ne(ispin) ! electron 1 (so it can be associated to mu(r1)) ii = occ(i,ispin) do j = 1, Ne(jspin) ! electron 2 - jj = occ(j,jspin) - htwoe += mo_bi_ortho_tc_two_e(jj,ii,jj,ii) + jj = occ(j,jspin) + htwoe += mo_bi_ortho_tc_two_e(jj,ii,jj,ii) enddo - enddo + enddo - ! alpha/alpha two-body - do i = 1, Ne(ispin) + ! alpha/alpha two-body + do i = 1, Ne(ispin) ii = occ(i,ispin) do j = i+1, Ne(ispin) - jj = occ(j,ispin) - htwoe += mo_bi_ortho_tc_two_e(ii,jj,ii,jj) - mo_bi_ortho_tc_two_e(ii,jj,jj,ii) + jj = occ(j,ispin) + htwoe += mo_bi_ortho_tc_two_e(ii,jj,ii,jj) - mo_bi_ortho_tc_two_e(ii,jj,jj,ii) enddo - enddo + enddo - ! beta/beta two-body - do i = 1, Ne(jspin) + ! beta/beta two-body + do i = 1, Ne(jspin) ii = occ(i,jspin) do j = i+1, Ne(jspin) - jj = occ(j,jspin) - htwoe += mo_bi_ortho_tc_two_e(ii,jj,ii,jj) - mo_bi_ortho_tc_two_e(ii,jj,jj,ii) + jj = occ(j,jspin) + htwoe += mo_bi_ortho_tc_two_e(ii,jj,ii,jj) - mo_bi_ortho_tc_two_e(ii,jj,jj,ii) enddo - enddo + enddo + htot = hmono + htwoe end - +! --- subroutine double_htilde_mu_mat_bi_ortho_slow(Nint, key_j, key_i, hmono, htwoe, htot) diff --git a/src/tc_bi_ortho/spin_mulliken.irp.f b/plugins/local/tc_bi_ortho/spin_mulliken.irp.f similarity index 100% rename from src/tc_bi_ortho/spin_mulliken.irp.f rename to plugins/local/tc_bi_ortho/spin_mulliken.irp.f diff --git a/src/tc_bi_ortho/symmetrized_3_e_int.irp.f b/plugins/local/tc_bi_ortho/symmetrized_3_e_int.irp.f similarity index 100% rename from src/tc_bi_ortho/symmetrized_3_e_int.irp.f rename to plugins/local/tc_bi_ortho/symmetrized_3_e_int.irp.f diff --git a/src/tc_bi_ortho/symmetrized_3_e_int_prov.irp.f b/plugins/local/tc_bi_ortho/symmetrized_3_e_int_prov.irp.f similarity index 100% rename from src/tc_bi_ortho/symmetrized_3_e_int_prov.irp.f rename to plugins/local/tc_bi_ortho/symmetrized_3_e_int_prov.irp.f diff --git a/src/tc_bi_ortho/tc_bi_ortho.irp.f b/plugins/local/tc_bi_ortho/tc_bi_ortho.irp.f similarity index 87% rename from src/tc_bi_ortho/tc_bi_ortho.irp.f rename to plugins/local/tc_bi_ortho/tc_bi_ortho.irp.f index 2887c7be..e27672a2 100644 --- a/src/tc_bi_ortho/tc_bi_ortho.irp.f +++ b/plugins/local/tc_bi_ortho/tc_bi_ortho.irp.f @@ -13,6 +13,17 @@ program tc_bi_ortho my_n_pt_a_grid = tc_grid1_a touch my_grid_becke my_n_pt_r_grid my_n_pt_a_grid + if(j1b_type .ge. 100) then + my_extra_grid_becke = .True. + PROVIDE tc_grid2_a tc_grid2_r + my_n_pt_r_extra_grid = tc_grid2_r + my_n_pt_a_extra_grid = tc_grid2_a + touch my_extra_grid_becke my_n_pt_r_extra_grid my_n_pt_a_extra_grid + + call write_int(6, my_n_pt_r_extra_grid, 'radial internal grid over') + call write_int(6, my_n_pt_a_extra_grid, 'angular internal grid over') + endif + read_wf = .True. touch read_wf diff --git a/src/tc_bi_ortho/tc_bi_ortho_prop.irp.f b/plugins/local/tc_bi_ortho/tc_bi_ortho_prop.irp.f similarity index 57% rename from src/tc_bi_ortho/tc_bi_ortho_prop.irp.f rename to plugins/local/tc_bi_ortho/tc_bi_ortho_prop.irp.f index 9168fb3d..a5fe9249 100644 --- a/src/tc_bi_ortho/tc_bi_ortho_prop.irp.f +++ b/plugins/local/tc_bi_ortho/tc_bi_ortho_prop.irp.f @@ -34,4 +34,19 @@ subroutine test do i= 1, 3 print*,tc_bi_ortho_dipole(i,1) enddo + integer, allocatable :: occ(:,:) + integer :: n_occ_ab(2) + allocate(occ(N_int*bit_kind_size,2)) + call bitstring_to_list_ab(ref_bitmask, occ, n_occ_ab, N_int) + integer :: ispin,j,jorb + double precision :: accu + accu = 0.d0 + do ispin=1, 2 + do i = 1, n_occ_ab(ispin) + jorb = occ(i,ispin) + accu += mo_bi_orth_bipole_z(jorb,jorb) + enddo + enddo + print*,'accu = ',accu + end diff --git a/src/tc_bi_ortho/tc_cisd_sc2.irp.f b/plugins/local/tc_bi_ortho/tc_cisd_sc2.irp.f similarity index 100% rename from src/tc_bi_ortho/tc_cisd_sc2.irp.f rename to plugins/local/tc_bi_ortho/tc_cisd_sc2.irp.f diff --git a/src/tc_bi_ortho/tc_cisd_sc2_utils.irp.f b/plugins/local/tc_bi_ortho/tc_cisd_sc2_utils.irp.f similarity index 100% rename from src/tc_bi_ortho/tc_cisd_sc2_utils.irp.f rename to plugins/local/tc_bi_ortho/tc_cisd_sc2_utils.irp.f diff --git a/src/tc_bi_ortho/tc_h_eigvectors.irp.f b/plugins/local/tc_bi_ortho/tc_h_eigvectors.irp.f similarity index 93% rename from src/tc_bi_ortho/tc_h_eigvectors.irp.f rename to plugins/local/tc_bi_ortho/tc_h_eigvectors.irp.f index 48257943..a9e22e03 100644 --- a/src/tc_bi_ortho/tc_h_eigvectors.irp.f +++ b/plugins/local/tc_bi_ortho/tc_h_eigvectors.irp.f @@ -225,6 +225,8 @@ end external H_tc_dagger_u_0_opt external H_tc_s2_dagger_u_0_opt external H_tc_s2_u_0_opt + external H_tc_s2_dagger_u_0_with_pure_three_omp + external H_tc_s2_u_0_with_pure_three_omp allocate(H_jj(N_det),vec_tmp(N_det,n_states_diag)) @@ -250,7 +252,11 @@ end converged = .False. i_it = 0 do while (.not.converged) - call davidson_hs2_nonsym_b1space(vec_tmp, H_jj, s2_eigvec_tc_bi_orth, eigval_left_tc_bi_orth, N_det, n_states, n_states_diag, n_it_max, converged, H_tc_s2_dagger_u_0_opt) + if(.not.pure_three_body_h_tc)then + call davidson_hs2_nonsym_b1space(vec_tmp, H_jj, s2_eigvec_tc_bi_orth, eigval_left_tc_bi_orth, N_det, n_states, n_states_diag, n_it_max, converged, H_tc_s2_dagger_u_0_opt) + else + call davidson_hs2_nonsym_b1space(vec_tmp, H_jj, s2_eigvec_tc_bi_orth, eigval_left_tc_bi_orth, N_det, n_states, n_states_diag, n_it_max, converged, H_tc_s2_dagger_u_0_with_pure_three_omp) + endif i_it += 1 if(i_it .gt. 5) exit enddo @@ -275,7 +281,11 @@ end converged = .False. i_it = 0 do while (.not. converged) - call davidson_hs2_nonsym_b1space(vec_tmp, H_jj, s2_eigvec_tc_bi_orth, eigval_right_tc_bi_orth, N_det, n_states, n_states_diag, n_it_max, converged, H_tc_s2_u_0_opt) + if(.not.pure_three_body_h_tc)then + call davidson_hs2_nonsym_b1space(vec_tmp, H_jj, s2_eigvec_tc_bi_orth, eigval_right_tc_bi_orth, N_det, n_states, n_states_diag, n_it_max, converged, H_tc_s2_u_0_opt) + else + call davidson_hs2_nonsym_b1space(vec_tmp, H_jj, s2_eigvec_tc_bi_orth, eigval_right_tc_bi_orth, N_det, n_states, n_states_diag, n_it_max, converged, H_tc_s2_u_0_with_pure_three_omp) + endif i_it += 1 if(i_it .gt. 5) exit enddo diff --git a/src/tc_bi_ortho/tc_hmat.irp.f b/plugins/local/tc_bi_ortho/tc_hmat.irp.f similarity index 51% rename from src/tc_bi_ortho/tc_hmat.irp.f rename to plugins/local/tc_bi_ortho/tc_hmat.irp.f index ceabf853..88652caa 100644 --- a/src/tc_bi_ortho/tc_hmat.irp.f +++ b/plugins/local/tc_bi_ortho/tc_hmat.irp.f @@ -1,44 +1,53 @@ - BEGIN_PROVIDER [double precision, htilde_matrix_elmt_bi_ortho, (N_det,N_det)] +! --- + +BEGIN_PROVIDER [double precision, htilde_matrix_elmt_bi_ortho, (N_det,N_det)] BEGIN_DOC + ! ! htilde_matrix_elmt_bi_ortho(j,i) = ! ! WARNING !!!!!!!!! IT IS NOT HERMITIAN !!!!!!!!! + ! END_DOC implicit none integer :: i, j double precision :: htot - PROVIDE N_int + call provide_all_three_ints_bi_ortho i = 1 j = 1 call htilde_mu_mat_opt_bi_ortho_tot(psi_det(1,1,j), psi_det(1,1,i), N_int, htot) - !$OMP PARALLEL DO SCHEDULE(GUIDED) DEFAULT(NONE) PRIVATE(i,j, htot) & - !$OMP SHARED (N_det, psi_det, N_int,htilde_matrix_elmt_bi_ortho) - do i = 1, N_det - do j = 1, N_det - ! < J |Htilde | I > - call htilde_mu_mat_opt_bi_ortho_tot(psi_det(1,1,j), psi_det(1,1,i), N_int, htot) + !$OMP PARALLEL DO SCHEDULE(GUIDED) DEFAULT(NONE) PRIVATE(i,j, htot) & + !$OMP SHARED (N_det, psi_det, N_int, htilde_matrix_elmt_bi_ortho) + do i = 1, N_det + do j = 1, N_det + ! < J |Htilde | I > + call htilde_mu_mat_opt_bi_ortho_tot(psi_det(1,1,j), psi_det(1,1,i), N_int, htot) - htilde_matrix_elmt_bi_ortho(j,i) = htot - enddo + htilde_matrix_elmt_bi_ortho(j,i) = htot enddo - !$OMP END PARALLEL DO + enddo + !$OMP END PARALLEL DO END_PROVIDER ! --- BEGIN_PROVIDER [double precision, htilde_matrix_elmt_bi_ortho_tranp, (N_det,N_det)] - implicit none - integer ::i,j + + implicit none + integer ::i,j + do i = 1, N_det do j = 1, N_det htilde_matrix_elmt_bi_ortho_tranp(j,i) = htilde_matrix_elmt_bi_ortho(i,j) enddo enddo END_PROVIDER + +! --- + diff --git a/src/tc_bi_ortho/tc_natorb.irp.f b/plugins/local/tc_bi_ortho/tc_natorb.irp.f similarity index 87% rename from src/tc_bi_ortho/tc_natorb.irp.f rename to plugins/local/tc_bi_ortho/tc_natorb.irp.f index 1b5a66f3..b8cf5e81 100644 --- a/src/tc_bi_ortho/tc_natorb.irp.f +++ b/plugins/local/tc_bi_ortho/tc_natorb.irp.f @@ -29,22 +29,33 @@ write(*, '(100(F16.10,X))') -dm_tmp(:,i) enddo + print *, ' Transition density matrix AO' + do i = 1, ao_num + write(*, '(100(F16.10,X))') tc_transition_matrix_ao(:,i,1,1) + enddo + stop + thr_d = 1.d-6 thr_nd = 1.d-6 thr_deg = 1.d-3 - if(n_core_orb.ne.0)then -! print*,'core orbitals' -! pause - call diag_mat_per_fock_degen_core( fock_diag, dm_tmp, list_core, n_core_orb, mo_num, thr_d, thr_nd, thr_deg & - , natorb_tc_leigvec_mo, natorb_tc_reigvec_mo, natorb_tc_eigval) - else - call diag_mat_per_fock_degen( fock_diag, dm_tmp, mo_num, thr_d, thr_nd, thr_deg & - , natorb_tc_leigvec_mo, natorb_tc_reigvec_mo, natorb_tc_eigval) - endif -! call non_hrmt_bieig( mo_num, dm_tmp& -! , natorb_tc_leigvec_mo, natorb_tc_reigvec_mo& -! , mo_num, natorb_tc_eigval ) + do i = 1, mo_num + do j = 1, mo_num + if(dabs(dm_tmp(j,i)).lt.thr_d)then + dm_tmp(j,i) = 0.d0 + endif + enddo + enddo +! if(n_core_orb.ne.0)then +! call diag_mat_per_fock_degen_core( fock_diag, dm_tmp, list_core, n_core_orb, mo_num, thr_d, thr_nd, thr_deg & +! , natorb_tc_leigvec_mo, natorb_tc_reigvec_mo, natorb_tc_eigval) +! else +! call diag_mat_per_fock_degen( fock_diag, dm_tmp, mo_num, thr_d, thr_nd, thr_deg & +! , natorb_tc_leigvec_mo, natorb_tc_reigvec_mo, natorb_tc_eigval) +! endif + call non_hrmt_bieig(mo_num, dm_tmp, thresh_biorthog_diag, thresh_biorthog_nondiag & + , natorb_tc_leigvec_mo, natorb_tc_reigvec_mo & + , mo_num, natorb_tc_eigval ) accu = 0.d0 do i = 1, mo_num print*,'natorb_tc_eigval(i) = ',-natorb_tc_eigval(i) diff --git a/src/tc_bi_ortho/tc_prop.irp.f b/plugins/local/tc_bi_ortho/tc_prop.irp.f similarity index 98% rename from src/tc_bi_ortho/tc_prop.irp.f rename to plugins/local/tc_bi_ortho/tc_prop.irp.f index a13dc9a2..3375fed6 100644 --- a/src/tc_bi_ortho/tc_prop.irp.f +++ b/plugins/local/tc_bi_ortho/tc_prop.irp.f @@ -90,6 +90,7 @@ enddo enddo enddo + print*,'tc_bi_ortho_dipole(3) elec = ',tc_bi_ortho_dipole(3,1) nuclei_part = 0.d0 do m = 1, 3 diff --git a/src/tc_bi_ortho/tc_som.irp.f b/plugins/local/tc_bi_ortho/tc_som.irp.f similarity index 100% rename from src/tc_bi_ortho/tc_som.irp.f rename to plugins/local/tc_bi_ortho/tc_som.irp.f diff --git a/src/tc_bi_ortho/tc_utils.irp.f b/plugins/local/tc_bi_ortho/tc_utils.irp.f similarity index 100% rename from src/tc_bi_ortho/tc_utils.irp.f rename to plugins/local/tc_bi_ortho/tc_utils.irp.f diff --git a/src/tc_bi_ortho/test_natorb.irp.f b/plugins/local/tc_bi_ortho/test_natorb.irp.f similarity index 100% rename from src/tc_bi_ortho/test_natorb.irp.f rename to plugins/local/tc_bi_ortho/test_natorb.irp.f diff --git a/src/tc_bi_ortho/test_normal_order.irp.f b/plugins/local/tc_bi_ortho/test_normal_order.irp.f similarity index 100% rename from src/tc_bi_ortho/test_normal_order.irp.f rename to plugins/local/tc_bi_ortho/test_normal_order.irp.f diff --git a/src/tc_bi_ortho/test_s2_tc.irp.f b/plugins/local/tc_bi_ortho/test_s2_tc.irp.f similarity index 73% rename from src/tc_bi_ortho/test_s2_tc.irp.f rename to plugins/local/tc_bi_ortho/test_s2_tc.irp.f index b398507a..7c70b119 100644 --- a/src/tc_bi_ortho/test_s2_tc.irp.f +++ b/plugins/local/tc_bi_ortho/test_s2_tc.irp.f @@ -14,12 +14,14 @@ program test_tc read_wf = .True. touch read_wf - call routine_test_s2 - call routine_test_s2_davidson + call provide_all_three_ints_bi_ortho() + call routine_h_triple_left + call routine_h_triple_right +! call routine_test_s2_davidson end -subroutine routine_test_s2 +subroutine routine_h_triple_right implicit none logical :: do_right integer :: sze ,i, N_st, j @@ -29,67 +31,65 @@ subroutine routine_test_s2 sze = N_det N_st = 1 allocate(v_0_ref(N_det,1),u_0(N_det,1),s_0_ref(N_det,1),s_0_new(N_det,1),v_0_new(N_det,1)) - print*,'Checking first the Left ' - do_right = .False. - do i = 1, sze - u_0(i,1) = psi_l_coef_bi_ortho(i,1) - enddo - call H_tc_u_0_nstates_openmp(v_0_ref,u_0,N_st,sze, do_right) - s_0_ref = 0.d0 - do i = 1, sze - do j = 1, sze - call get_s2(psi_det(1,1,i),psi_det(1,1,j),N_int,sij) - s_0_ref(i,1) += u_0(j,1) * sij - enddo - enddo - call H_tc_s2_u_0_nstates_openmp(v_0_new,s_0_new,u_0,N_st,sze, do_right) - accu_e = 0.d0 - accu_s = 0.d0 - accu_e_0 = 0.d0 - accu_s_0 = 0.d0 - do i = 1, sze - accu_e_0 += v_0_ref(i,1) * psi_r_coef_bi_ortho(i,1) - accu_s_0 += s_0_ref(i,1) * psi_r_coef_bi_ortho(i,1) - accu_e += dabs(v_0_ref(i,1) - v_0_new(i,1)) - accu_s += dabs(s_0_ref(i,1) - s_0_new(i,1)) - enddo - print*,'accu_e = ',accu_e - print*,'accu_s = ',accu_s - print*,'accu_e_0 = ',accu_e_0 - print*,'accu_s_0 = ',accu_s_0 - - print*,'Checking then the right ' - do_right = .True. + print*,'Checking first the Right ' do i = 1, sze u_0(i,1) = psi_r_coef_bi_ortho(i,1) enddo - call H_tc_u_0_nstates_openmp(v_0_ref,u_0,N_st,sze, do_right) - s_0_ref = 0.d0 - do i = 1, sze - do j = 1, sze - call get_s2(psi_det(1,1,i),psi_det(1,1,j),N_int,sij) - s_0_ref(i,1) += u_0(j,1) * sij - enddo - enddo - call H_tc_s2_u_0_nstates_openmp(v_0_new,s_0_new,u_0,N_st,sze, do_right) + double precision :: wall0,wall1 + call wall_time(wall0) + call H_tc_s2_u_0_with_pure_three_omp(v_0_ref,s_0_ref, u_0,N_st,sze) + call wall_time(wall1) + print*,'time for omp',wall1 - wall0 + call wall_time(wall0) + call H_tc_s2_u_0_with_pure_three(v_0_new, s_0_new, u_0, N_st, sze) + call wall_time(wall1) + print*,'time serial ',wall1 - wall0 accu_e = 0.d0 accu_s = 0.d0 - accu_e_0 = 0.d0 - accu_s_0 = 0.d0 do i = 1, sze - accu_e_0 += v_0_ref(i,1) * psi_l_coef_bi_ortho(i,1) - accu_s_0 += s_0_ref(i,1) * psi_l_coef_bi_ortho(i,1) accu_e += dabs(v_0_ref(i,1) - v_0_new(i,1)) accu_s += dabs(s_0_ref(i,1) - s_0_new(i,1)) enddo print*,'accu_e = ',accu_e print*,'accu_s = ',accu_s - print*,'accu_e_0 = ',accu_e_0 - print*,'accu_s_0 = ',accu_s_0 - end +subroutine routine_h_triple_left + implicit none + logical :: do_right + integer :: sze ,i, N_st, j + double precision :: sij, accu_e, accu_s, accu_e_0, accu_s_0 + double precision, allocatable :: v_0_ref(:,:),u_0(:,:),s_0_ref(:,:) + double precision, allocatable :: v_0_new(:,:),s_0_new(:,:) + sze = N_det + N_st = 1 + allocate(v_0_ref(N_det,1),u_0(N_det,1),s_0_ref(N_det,1),s_0_new(N_det,1),v_0_new(N_det,1)) + print*,'Checking the Left ' + do i = 1, sze + u_0(i,1) = psi_l_coef_bi_ortho(i,1) + enddo + double precision :: wall0,wall1 + call wall_time(wall0) + call H_tc_s2_dagger_u_0_with_pure_three_omp(v_0_ref,s_0_ref, u_0,N_st,sze) + call wall_time(wall1) + print*,'time for omp',wall1 - wall0 + call wall_time(wall0) + call H_tc_s2_dagger_u_0_with_pure_three(v_0_new, s_0_new, u_0, N_st, sze) + call wall_time(wall1) + print*,'time serial ',wall1 - wall0 + accu_e = 0.d0 + accu_s = 0.d0 + do i = 1, sze + accu_e += dabs(v_0_ref(i,1) - v_0_new(i,1)) + accu_s += dabs(s_0_ref(i,1) - s_0_new(i,1)) + enddo + print*,'accu_e = ',accu_e + print*,'accu_s = ',accu_s + +end + + subroutine routine_test_s2_davidson implicit none double precision, allocatable :: H_jj(:),vec_tmp(:,:), energies(:) , s2(:) diff --git a/src/tc_bi_ortho/test_spin_dens.irp.f b/plugins/local/tc_bi_ortho/test_spin_dens.irp.f similarity index 100% rename from src/tc_bi_ortho/test_spin_dens.irp.f rename to plugins/local/tc_bi_ortho/test_spin_dens.irp.f diff --git a/src/tc_bi_ortho/test_tc_bi_ortho.irp.f b/plugins/local/tc_bi_ortho/test_tc_bi_ortho.irp.f similarity index 69% rename from src/tc_bi_ortho/test_tc_bi_ortho.irp.f rename to plugins/local/tc_bi_ortho/test_tc_bi_ortho.irp.f index b6beb65b..369efd15 100644 --- a/src/tc_bi_ortho/test_tc_bi_ortho.irp.f +++ b/plugins/local/tc_bi_ortho/test_tc_bi_ortho.irp.f @@ -11,14 +11,17 @@ program tc_bi_ortho print *, 'Hello world' - my_grid_becke = .True. + my_grid_becke = .True. PROVIDE tc_grid1_a tc_grid1_r my_n_pt_r_grid = tc_grid1_r my_n_pt_a_grid = tc_grid1_a touch my_grid_becke my_n_pt_r_grid my_n_pt_a_grid - read_wf = .True. - touch read_wf + call write_int(6, my_n_pt_r_grid, 'radial external grid over') + call write_int(6, my_n_pt_a_grid, 'angular external grid over') + +! read_wf = .True. +! touch read_wf ! call test_h_u0 ! call test_slater_tc_opt @@ -27,10 +30,18 @@ program tc_bi_ortho ! call timing_single ! call timing_double - call test_no() !call test_no_aba() !call test_no_aab() !call test_no_aaa() + + !call test_no() + !call test_no_v0() + + call test_noL_0e() + call test_noL_1e() + !call test_noL_2e_v0() + call test_noL_2e() + end subroutine test_h_u0 @@ -268,29 +279,30 @@ end ! --- -subroutine test_no() +subroutine test_no_v0() implicit none integer :: i, j, k, l - double precision :: accu, contrib, new, ref, thr + double precision :: accu, contrib, new, ref, thr, norm - print*, ' testing normal_two_body_bi_orth ...' + print*, ' test_no_v0 ...' thr = 1d-8 - PROVIDE normal_two_body_bi_orth_old + PROVIDE normal_two_body_bi_orth_v0 PROVIDE normal_two_body_bi_orth 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 = normal_two_body_bi_orth (l,k,j,i) - ref = normal_two_body_bi_orth_old(l,k,j,i) + new = normal_two_body_bi_orth (l,k,j,i) + ref = normal_two_body_bi_orth_v0(l,k,j,i) + contrib = dabs(new - ref) - accu += contrib if(contrib .gt. thr) then print*, ' problem on normal_two_body_bi_orth' print*, l, k, j, i @@ -298,13 +310,62 @@ subroutine test_no() stop endif + accu += contrib + norm += dabs(ref) enddo enddo enddo enddo - print*, ' accu on normal_two_body_bi_orth = ', accu / dble(mo_num)**4 - return + print*, ' accu (%) = ', 100.d0*accu/norm + + return +end + +! --- + + +subroutine test_no() + + implicit none + integer :: i, j, k, l + double precision :: accu, contrib, new, ref, thr, norm + + print*, ' test_no ...' + + thr = 1d-8 + + PROVIDE normal_two_body_bi_orth_old + PROVIDE normal_two_body_bi_orth + + 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 = normal_two_body_bi_orth (l,k,j,i) + ref = normal_two_body_bi_orth_old(l,k,j,i) + + contrib = dabs(new - ref) + if(contrib .gt. thr) then + print*, ' problem on normal_two_body_bi_orth' + print*, l, k, j, i + print*, ref, new, contrib + stop + endif + + accu += contrib + norm += dabs(ref) + enddo + enddo + enddo + enddo + + print*, ' accu (%) = ', 100.d0*accu/norm + + return end ! --- @@ -313,7 +374,7 @@ subroutine test_no_aba() implicit none integer :: i, j, k, l - double precision :: accu, contrib, new, ref, thr + double precision :: accu, contrib, new, ref, thr, norm print*, ' testing no_aba_contraction ...' @@ -323,6 +384,7 @@ subroutine test_no_aba() PROVIDE no_aba_contraction accu = 0.d0 + norm = 0.d0 do i = 1, mo_num do j = 1, mo_num do k = 1, mo_num @@ -331,7 +393,6 @@ subroutine test_no_aba() new = no_aba_contraction (l,k,j,i) ref = no_aba_contraction_v0(l,k,j,i) contrib = dabs(new - ref) - accu += contrib if(contrib .gt. thr) then print*, ' problem on no_aba_contraction' print*, l, k, j, i @@ -339,13 +400,16 @@ subroutine test_no_aba() stop endif + accu += contrib + norm += dabs(ref) enddo enddo enddo enddo - print*, ' accu on no_aba_contraction = ', accu / dble(mo_num)**4 - return + print*, ' accu (%) = ', 100.d0*accu/norm + + return end ! --- @@ -355,7 +419,7 @@ subroutine test_no_aab() implicit none integer :: i, j, k, l - double precision :: accu, contrib, new, ref, thr + double precision :: accu, contrib, new, ref, thr, norm print*, ' testing no_aab_contraction ...' @@ -365,6 +429,7 @@ subroutine test_no_aab() PROVIDE no_aab_contraction accu = 0.d0 + norm = 0.d0 do i = 1, mo_num do j = 1, mo_num do k = 1, mo_num @@ -373,7 +438,6 @@ subroutine test_no_aab() new = no_aab_contraction (l,k,j,i) ref = no_aab_contraction_v0(l,k,j,i) contrib = dabs(new - ref) - accu += contrib if(contrib .gt. thr) then print*, ' problem on no_aab_contraction' print*, l, k, j, i @@ -381,13 +445,16 @@ subroutine test_no_aab() stop endif + accu += contrib + norm += dabs(ref) enddo enddo enddo enddo - print*, ' accu on no_aab_contraction = ', accu / dble(mo_num)**4 - return + print*, ' accu (%) = ', 100.d0*accu/norm + + return end ! --- @@ -396,7 +463,7 @@ subroutine test_no_aaa() implicit none integer :: i, j, k, l - double precision :: accu, contrib, new, ref, thr + double precision :: accu, contrib, new, ref, thr, norm print*, ' testing no_aaa_contraction ...' @@ -406,6 +473,7 @@ subroutine test_no_aaa() PROVIDE no_aaa_contraction accu = 0.d0 + norm = 0.d0 do i = 1, mo_num do j = 1, mo_num do k = 1, mo_num @@ -414,7 +482,6 @@ subroutine test_no_aaa() new = no_aaa_contraction (l,k,j,i) ref = no_aaa_contraction_v0(l,k,j,i) contrib = dabs(new - ref) - accu += contrib if(contrib .gt. thr) then print*, ' problem on no_aaa_contraction' print*, l, k, j, i @@ -422,13 +489,179 @@ subroutine test_no_aaa() stop endif + accu += contrib + norm += dabs(ref) enddo enddo enddo enddo - print*, ' accu on no_aaa_contraction = ', accu / dble(mo_num)**4 - return + print*, ' accu (%) = ', 100.d0*accu/norm + + return end ! --- + +subroutine test_noL_0e() + + implicit none + double precision :: accu, norm, thr + + thr = 1d-8 + + print*, ' testing noL_0e ...' + + PROVIDE noL_0e_naive + PROVIDE noL_0e_v0 + PROVIDE noL_0e + + accu = dabs(noL_0e_naive - noL_0e) + norm = dabs(noL_0e_naive) + + if(accu .gt. thr) then + print*, ' problem on noL_0e' + print*, noL_0e_naive, noL_0e + stop + endif + + print*, ' accu (%) = ', 100.d0*accu/norm + + return +end + +! --- + +subroutine test_noL_1e() + + implicit none + integer :: i, j + double precision :: accu, contrib, new, ref, thr, norm + + print*, ' testing noL_1e ...' + + PROVIDE noL_1e_naive + PROVIDE noL_1e + PROVIDE energy_1e_noL_HF + + thr = 1d-8 + + accu = 0.d0 + norm = 0.d0 + do i = 1, mo_num + do j = 1, mo_num + + new = noL_1e (j,i) + ref = noL_1e_naive(j,i) + contrib = dabs(new - ref) + if(contrib .gt. thr) then + print*, ' problem on noL_1e' + print*, j, i + print*, ref, new, contrib + stop + endif + + accu += contrib + norm += dabs(ref) + enddo + enddo + + print*, ' accu (%) = ', 100.d0*accu/norm + + return +end + +! --- + +subroutine test_noL_2e_v0() + + implicit none + integer :: i, j, k, l + double precision :: accu, contrib, new, ref, thr, norm + + print*, ' testing noL_2e_v0 ...' + + PROVIDE noL_2e_naive + PROVIDE noL_2e_v0 + PROVIDE energy_2e_noL_HF + + thr = 1d-8 + + 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 = noL_2e_v0 (l,k,j,i) + ref = noL_2e_naive(l,k,j,i) + contrib = dabs(new - ref) + if(contrib .gt. thr) then + print*, ' problem on noL_2e_v0' + print*, l, k, j, i + print*, ref, new, contrib + stop + endif + + accu += contrib + norm += dabs(ref) + enddo + enddo + enddo + enddo + + print*, ' accu (%) = ', 100.d0*accu/norm + + return +end + +! --- + + +subroutine test_noL_2e() + + implicit none + integer :: i, j, k, l + double precision :: accu, contrib, new, ref, thr, norm + + print*, ' testing noL_2e ...' + + PROVIDE noL_2e_naive + PROVIDE noL_2e + PROVIDE energy_2e_noL_HF + + thr = 1d-8 + + 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 = noL_2e (l,k,j,i) + ref = noL_2e_naive(l,k,j,i) + contrib = dabs(new - ref) + if(contrib .gt. thr) then + print*, ' problem on noL_2e' + print*, l, k, j, i + print*, ref, new, contrib + stop + endif + + accu += contrib + norm += dabs(ref) + enddo + enddo + enddo + enddo + + print*, ' accu (%) = ', 100.d0*accu/norm + + return +end + +! --- + + diff --git a/src/tc_bi_ortho/test_tc_fock.irp.f b/plugins/local/tc_bi_ortho/test_tc_fock.irp.f similarity index 100% rename from src/tc_bi_ortho/test_tc_fock.irp.f rename to plugins/local/tc_bi_ortho/test_tc_fock.irp.f diff --git a/src/tc_bi_ortho/test_tc_two_rdm.irp.f b/plugins/local/tc_bi_ortho/test_tc_two_rdm.irp.f similarity index 58% rename from src/tc_bi_ortho/test_tc_two_rdm.irp.f rename to plugins/local/tc_bi_ortho/test_tc_two_rdm.irp.f index 3e556312..68b96f37 100644 --- a/src/tc_bi_ortho/test_tc_two_rdm.irp.f +++ b/plugins/local/tc_bi_ortho/test_tc_two_rdm.irp.f @@ -25,49 +25,43 @@ end subroutine test implicit none - integer :: h1,p1,h2,p2,i,j,istate - double precision :: rdm, integral, accu,ref + integer :: h1,p1,h2,p2,i,j,istate,s1,s2 + double precision :: rdm, integral, accu,ref, accu_new ,rdm_new double precision :: hmono, htwoe, hthree, htot accu = 0.d0 + accu_new = 0.d0 do h1 = 1, mo_num do p1 = 1, mo_num do h2 = 1, mo_num do p2 = 1, mo_num integral = mo_bi_ortho_tc_two_e(p2,p1,h2,h1) - rdm = tc_two_rdm(p1,h1,p2,h2) -! if(dabs(rdm).gt.1.d-10)then -! print*,h1,p1,h2,p2 -! print*,rdm,integral,rdm*integral -! endif + rdm = tc_two_rdm(p2,p1,h2,h1) accu += integral * rdm + rdm_new = 0.d0 + do s2 = 1, 2 + do s1 = 1, 2 + rdm_new += tc_two_rdm_s1s2(p2,p1,h2,h1,s1,s2) + enddo + enddo + accu_new += integral * rdm_new enddo enddo enddo enddo accu *= 0.5d0 - print*,'accu = ',accu -! print*,mo_bi_ortho_tc_two_e(2,15,2,1) -! print*,mo_bi_ortho_tc_two_e(15,2,2,1) -! print*,mo_bi_ortho_tc_two_e(2,1,2,15) -! print*,mo_bi_ortho_tc_two_e(2,1,15,2) + accu_new *= 0.5d0 + print*,'accu = ',accu + print*,'accu_new = ',accu_new ref = 0.d0 do i = 1, N_det do j = 1, N_det -! if(i.eq.j)cycle call htilde_mu_mat_opt_bi_ortho(psi_det(1,1,i), psi_det(1,1,j), N_int, hmono, htwoe, hthree, htot) do istate = 1,N_states -! print*,'i,j',i,j -! print*,psi_l_coef_bi_ortho(i,istate) , psi_r_coef_bi_ortho(j,istate) , htwoe -! print*,psi_l_coef_bi_ortho(i,istate) * psi_r_coef_bi_ortho(j,istate) * htwoe -! if(i.ne.j)then -! print*,psi_l_coef_bi_ortho(i,istate) * psi_r_coef_bi_ortho(j,istate) , htwoe -! print*,psi_l_coef_bi_ortho(i,istate) * psi_r_coef_bi_ortho(j,istate) * htwoe -! endif ref += psi_l_coef_bi_ortho(i,istate) * psi_r_coef_bi_ortho(j,istate) * state_average_weight(istate) * htwoe enddo enddo enddo - print*,' ref = ',ref + print*,' ref = ',ref print*,'delta= ',ref-accu end diff --git a/src/tc_bi_ortho/two_rdm_naive.irp.f b/plugins/local/tc_bi_ortho/two_rdm_naive.irp.f similarity index 70% rename from src/tc_bi_ortho/two_rdm_naive.irp.f rename to plugins/local/tc_bi_ortho/two_rdm_naive.irp.f index 3963d09e..90163de5 100644 --- a/src/tc_bi_ortho/two_rdm_naive.irp.f +++ b/plugins/local/tc_bi_ortho/two_rdm_naive.irp.f @@ -1,4 +1,5 @@ -BEGIN_PROVIDER [ double precision, tc_two_rdm_chemist, (mo_num, mo_num, mo_num, mo_num)] + BEGIN_PROVIDER [ double precision, tc_two_rdm_chemist, (mo_num, mo_num, mo_num, mo_num)] +&BEGIN_PROVIDER [ double precision, tc_two_rdm_chemist_s1s2, (mo_num, mo_num, mo_num, mo_num, 2,2)] implicit none BEGIN_DOC ! tc_two_rdm_chemist(p,s,q,r) = = CHEMIST NOTATION @@ -14,6 +15,7 @@ BEGIN_PROVIDER [ double precision, tc_two_rdm_chemist, (mo_num, mo_num, mo_num, other_spin(2) = 1 allocate(occ(N_int*bit_kind_size,2)) tc_two_rdm_chemist = 0.d0 + tc_two_rdm_chemist_s1s2 = 0.d0 do i = 1, N_det ! psi_left do j = 1, N_det ! psi_right @@ -21,14 +23,16 @@ BEGIN_PROVIDER [ double precision, tc_two_rdm_chemist, (mo_num, mo_num, mo_num, if(degree.gt.2)cycle if(degree.gt.0)then ! get excitation operators: from psi_det(j) --> psi_det(i) - call get_excitation(psi_det(1,1,j),psi_det(1,1,i),exc,degree,phase,N_int) - call decode_exc(exc,degree,h1,p1,h2,p2,s1,s2) - contrib = psi_l_coef_bi_ortho(i,1) * psi_r_coef_bi_ortho(j,1) * phase * state_average_weight(1) - do istate = 2, N_states - contrib += psi_l_coef_bi_ortho(i,istate) * psi_r_coef_bi_ortho(j,istate) * phase * state_average_weight(istate) - enddo + ! T_{j-->i} = a^p1_s1 a_h1_s1 + call get_excitation(psi_det(1,1,j),psi_det(1,1,i),exc,degree,phase,N_int) + call decode_exc(exc,degree,h1,p1,h2,p2,s1,s2) + contrib = psi_l_coef_bi_ortho(i,1) * psi_r_coef_bi_ortho(j,1) * phase * state_average_weight(1) + do istate = 2, N_states + contrib += psi_l_coef_bi_ortho(i,istate) * psi_r_coef_bi_ortho(j,istate) * phase * state_average_weight(istate) + enddo if(degree == 2)then call update_tc_rdm(h1,p1,h2,p2,s1,s2,tc_two_rdm_chemist,mo_num,contrib) + call update_tc_rdm(h1,p1,h2,p2,s1,s2,tc_two_rdm_chemist_s1s2(1,1,1,1,s1,s2) ,mo_num,contrib) else if(degree==1)then ! occupation of the determinant psi_det(j) call bitstring_to_list_ab(psi_det(1,1,j), occ, n_occ_ab, N_int) @@ -40,6 +44,7 @@ BEGIN_PROVIDER [ double precision, tc_two_rdm_chemist, (mo_num, mo_num, mo_num, h2 = m p2 = m call update_tc_rdm(h1,p1,h2,p2,s1,s2,tc_two_rdm_chemist,mo_num,contrib) + call update_tc_rdm(h1,p1,h2,p2,s1,s2,tc_two_rdm_chemist_s1s2(1,1,1,1,s1,s2) ,mo_num,contrib) enddo ! run over the electrons of same spin than the excitation s2 = s1 @@ -48,6 +53,7 @@ BEGIN_PROVIDER [ double precision, tc_two_rdm_chemist, (mo_num, mo_num, mo_num, h2 = m p2 = m call update_tc_rdm(h1,p1,h2,p2,s1,s2,tc_two_rdm_chemist,mo_num,contrib) + call update_tc_rdm(h1,p1,h2,p2,s1,s2,tc_two_rdm_chemist_s1s2(1,1,1,1,s1,s2) ,mo_num,contrib) enddo endif else if(degree == 0)then @@ -69,6 +75,7 @@ BEGIN_PROVIDER [ double precision, tc_two_rdm_chemist, (mo_num, mo_num, mo_num, h2 = m p2 = m call update_tc_rdm(h1,p1,h2,p2,s1,s2,tc_two_rdm_chemist,mo_num,contrib) + call update_tc_rdm(h1,p1,h2,p2,s1,s2,tc_two_rdm_chemist_s1s2(1,1,1,1,s1,s2) ,mo_num,contrib) enddo ! run over the couple of alpha-alpha electrons s2 = s1 @@ -78,6 +85,7 @@ BEGIN_PROVIDER [ double precision, tc_two_rdm_chemist, (mo_num, mo_num, mo_num, p2 = m if(h2.le.h1)cycle call update_tc_rdm(h1,p1,h2,p2,s1,s2,tc_two_rdm_chemist,mo_num,contrib) + call update_tc_rdm(h1,p1,h2,p2,s1,s2,tc_two_rdm_chemist_s1s2(1,1,1,1,s1,s2) ,mo_num,contrib) enddo enddo s1 = 2 @@ -92,6 +100,7 @@ BEGIN_PROVIDER [ double precision, tc_two_rdm_chemist, (mo_num, mo_num, mo_num, p2 = m if(h2.le.h1)cycle call update_tc_rdm(h1,p1,h2,p2,s1,s2,tc_two_rdm_chemist,mo_num,contrib) + call update_tc_rdm(h1,p1,h2,p2,s1,s2,tc_two_rdm_chemist_s1s2(1,1,1,1,s1,s2) ,mo_num,contrib) enddo enddo endif @@ -124,12 +133,13 @@ subroutine update_tc_rdm(h1,p1,h2,p2,s1,s2,array,sze,contrib) end -BEGIN_PROVIDER [ double precision, tc_two_rdm, (mo_num, mo_num, mo_num, mo_num)] + BEGIN_PROVIDER [ double precision, tc_two_rdm, (mo_num, mo_num, mo_num, mo_num)] +&BEGIN_PROVIDER [ double precision, tc_two_rdm_s1s2, (mo_num, mo_num, mo_num, mo_num,2,2)] implicit none BEGIN_DOC ! tc_two_rdm(p,q,s,r) = = PHYSICIST NOTATION END_DOC - integer :: p,q,r,s + integer :: p,q,r,s,s1,s2 do r = 1, mo_num do q = 1, mo_num do s = 1, mo_num @@ -139,5 +149,18 @@ BEGIN_PROVIDER [ double precision, tc_two_rdm, (mo_num, mo_num, mo_num, mo_num)] enddo enddo enddo + do s2 = 1, 2 + do s1 = 1, 2 + do r = 1, mo_num + do q = 1, mo_num + do s = 1, mo_num + do p = 1, mo_num + tc_two_rdm_s1s2(p,q,s,r,s1,s2) = tc_two_rdm_chemist_s1s2(p,s,q,r,s1,s2) + enddo + enddo + enddo + enddo + enddo + enddo END_PROVIDER diff --git a/src/tc_keywords/EZFIO.cfg b/plugins/local/tc_keywords/EZFIO.cfg similarity index 92% rename from src/tc_keywords/EZFIO.cfg rename to plugins/local/tc_keywords/EZFIO.cfg index c2f8be3b..ac2cfda2 100644 --- a/src/tc_keywords/EZFIO.cfg +++ b/plugins/local/tc_keywords/EZFIO.cfg @@ -46,6 +46,12 @@ doc: If |true|, contracted double excitation three-body terms are included interface: ezfio,provider,ocaml default: False +[noL_standard] +type: logical +doc: If |true|, standard normal-ordering for L (to be used with three_body_h_tc |false|) +interface: ezfio,provider,ocaml +default: False + [core_tc_op] type: logical doc: If |true|, takes the usual Hamiltonian for core orbitals (assumed to be doubly occupied) @@ -110,13 +116,13 @@ default: False type: Threshold doc: Threshold on the convergence of the Hartree Fock energy. interface: ezfio,provider,ocaml -default: 1.e-10 +default: 1.e-8 [n_it_tcscf_max] type: Strictly_positive_int doc: Maximum number of SCF iterations interface: ezfio,provider,ocaml -default: 100 +default: 50 [selection_tc] type: integer @@ -152,13 +158,19 @@ default: 0 type: double precision doc: a parameter used to define mu(r) interface: ezfio, provider, ocaml -default: 6.203504908994001e-1 +default: 1.5 [beta_rho_power] type: double precision doc: a parameter used to define mu(r) interface: ezfio, provider, ocaml -default: 0.5 +default: 0.33333 + +[zeta_erf_mu_of_r] +type: double precision +doc: a parameter used to define mu(r) +interface: ezfio, provider, ocaml +default: 1. [thr_degen_tc] type: Threshold @@ -280,4 +292,15 @@ doc: size of radial grid over r1 interface: ezfio,provider,ocaml default: 30 +[tc_grid2_a] +type: integer +doc: size of angular grid over r2 +interface: ezfio,provider,ocaml +default: 194 + +[tc_grid2_r] +type: integer +doc: size of radial grid over r2 +interface: ezfio,provider,ocaml +default: 50 diff --git a/src/tc_keywords/NEED b/plugins/local/tc_keywords/NEED similarity index 100% rename from src/tc_keywords/NEED rename to plugins/local/tc_keywords/NEED diff --git a/src/tc_keywords/j1b_pen.irp.f b/plugins/local/tc_keywords/j1b_pen.irp.f similarity index 97% rename from src/tc_keywords/j1b_pen.irp.f rename to plugins/local/tc_keywords/j1b_pen.irp.f index 2d5e59a9..d509fc7e 100644 --- a/src/tc_keywords/j1b_pen.irp.f +++ b/plugins/local/tc_keywords/j1b_pen.irp.f @@ -91,7 +91,7 @@ print *, ' parameters for nuclei jastrow' print *, ' i, Z, j1b_pen, j1b_pen_coef' do i = 1, nucl_num - write(*,"(I4, 2x, 3(E15.7, 2X))"), i, nucl_charge(i), j1b_pen(i), j1b_pen_coef(i) + write(*,'(I4, 2x, 3(E15.7, 2X))') i, nucl_charge(i), j1b_pen(i), j1b_pen_coef(i) enddo END_PROVIDER diff --git a/src/tc_keywords/tc_keywords.irp.f b/plugins/local/tc_keywords/tc_keywords.irp.f similarity index 100% rename from src/tc_keywords/tc_keywords.irp.f rename to plugins/local/tc_keywords/tc_keywords.irp.f diff --git a/src/tc_scf/11.tc_scf.bats b/plugins/local/tc_scf/11.tc_scf.bats similarity index 67% rename from src/tc_scf/11.tc_scf.bats rename to plugins/local/tc_scf/11.tc_scf.bats index 91b52540..b81c2f4b 100644 --- a/src/tc_scf/11.tc_scf.bats +++ b/plugins/local/tc_scf/11.tc_scf.bats @@ -8,15 +8,15 @@ function run_Ne() { rm -rf Ne_tc_scf echo Ne > Ne.xyz qp create_ezfio -b cc-pcvdz Ne.xyz -o Ne_tc_scf - qp run scf + qp run scf - qp set ao_two_e_erf_ints mu_erf 0.87 + qp set hamiltonian mu_erf 0.87 qp set tc_keywords j1b_type 3 - qp set tc_keywords j1b_pen [1.5] - qp set tc_keywords bi_ortho True + qp set tc_keywords j1b_pen [1.5] + qp set tc_keywords bi_ortho True qp set tc_keywords test_cycle_tc True - qp run tc_scf | tee ${EZFIO_FILE}.tc_scf.out + qp run tc_scf | tee ${EZFIO_FILE}.tc_scf.out eref=-128.552134 energy="$(qp get tc_scf bitc_energy)" eq $energy $eref 1e-6 @@ -24,22 +24,22 @@ function run_Ne() { @test "Ne" { - run_Ne + run_Ne } function run_C() { rm -rf C_tc_scf echo C > C.xyz qp create_ezfio -b cc-pcvdz C.xyz -o C_tc_scf -m 3 - qp run scf + qp run scf - qp set ao_two_e_erf_ints mu_erf 0.87 + qp set hamiltonian mu_erf 0.87 qp set tc_keywords j1b_type 3 - qp set tc_keywords j1b_pen [1.5] - qp set tc_keywords bi_ortho True + qp set tc_keywords j1b_pen [1.5] + qp set tc_keywords bi_ortho True qp set tc_keywords test_cycle_tc True - qp run tc_scf | tee ${EZFIO_FILE}.tc_scf.out + qp run tc_scf | tee ${EZFIO_FILE}.tc_scf.out eref=-37.691254356408791 energy="$(qp get tc_scf bitc_energy)" eq $energy $eref 1e-6 @@ -47,7 +47,7 @@ function run_C() { @test "C" { - run_C + run_C } @@ -55,15 +55,15 @@ function run_O() { rm -rf O_tc_scf echo O > O.xyz qp create_ezfio -b cc-pcvdz O.xyz -o O_tc_scf -m 3 - qp run scf + qp run scf - qp set ao_two_e_erf_ints mu_erf 0.87 + qp set hamiltonian mu_erf 0.87 qp set tc_keywords j1b_type 3 - qp set tc_keywords j1b_pen [1.5] - qp set tc_keywords bi_ortho True + qp set tc_keywords j1b_pen [1.5] + qp set tc_keywords bi_ortho True qp set tc_keywords test_cycle_tc True - qp run tc_scf | tee ${EZFIO_FILE}.tc_scf.out + qp run tc_scf | tee ${EZFIO_FILE}.tc_scf.out eref=-74.814687229354590 energy="$(qp get tc_scf bitc_energy)" eq $energy $eref 1e-6 @@ -71,7 +71,7 @@ function run_O() { @test "O" { - run_O + run_O } @@ -79,16 +79,16 @@ function run_O() { function run_ch2() { rm -rf ch2_tc_scf cp ${QP_ROOT}/tests/input/ch2.xyz . - qp create_ezfio -b "C:cc-pcvdz|H:cc-pvdz" ch2.xyz -o ch2_tc_scf - qp run scf + qp create_ezfio -b "C:cc-pcvdz|H:cc-pvdz" ch2.xyz -o ch2_tc_scf + qp run scf - qp set ao_two_e_erf_ints mu_erf 0.87 + qp set hamiltonian mu_erf 0.87 qp set tc_keywords j1b_type 3 qp set tc_keywords j1b_pen '[1.5,10000,10000]' qp set tc_keywords bi_ortho True qp set tc_keywords test_cycle_tc True - qp run tc_scf | tee ${EZFIO_FILE}.tc_scf.out + qp run tc_scf | tee ${EZFIO_FILE}.tc_scf.out eref=-38.903247818077737 energy="$(qp get tc_scf bitc_energy)" eq $energy $eref 1e-6 @@ -96,6 +96,6 @@ function run_ch2() { @test "ch2" { - run_ch2 + run_ch2 } diff --git a/src/tc_scf/EZFIO.cfg b/plugins/local/tc_scf/EZFIO.cfg similarity index 100% rename from src/tc_scf/EZFIO.cfg rename to plugins/local/tc_scf/EZFIO.cfg diff --git a/src/tc_scf/NEED b/plugins/local/tc_scf/NEED similarity index 100% rename from src/tc_scf/NEED rename to plugins/local/tc_scf/NEED diff --git a/src/tc_scf/combine_lr_tcscf.irp.f b/plugins/local/tc_scf/combine_lr_tcscf.irp.f similarity index 100% rename from src/tc_scf/combine_lr_tcscf.irp.f rename to plugins/local/tc_scf/combine_lr_tcscf.irp.f diff --git a/src/tc_scf/diago_bi_ort_tcfock.irp.f b/plugins/local/tc_scf/diago_bi_ort_tcfock.irp.f similarity index 100% rename from src/tc_scf/diago_bi_ort_tcfock.irp.f rename to plugins/local/tc_scf/diago_bi_ort_tcfock.irp.f diff --git a/src/tc_scf/diago_vartcfock.irp.f b/plugins/local/tc_scf/diago_vartcfock.irp.f similarity index 100% rename from src/tc_scf/diago_vartcfock.irp.f rename to plugins/local/tc_scf/diago_vartcfock.irp.f diff --git a/src/tc_scf/diis_tcscf.irp.f b/plugins/local/tc_scf/diis_tcscf.irp.f similarity index 100% rename from src/tc_scf/diis_tcscf.irp.f rename to plugins/local/tc_scf/diis_tcscf.irp.f diff --git a/plugins/local/tc_scf/fock_3e_bi_ortho_cs.irp.f b/plugins/local/tc_scf/fock_3e_bi_ortho_cs.irp.f new file mode 100644 index 00000000..0b883865 --- /dev/null +++ b/plugins/local/tc_scf/fock_3e_bi_ortho_cs.irp.f @@ -0,0 +1,280 @@ + +! --- + +BEGIN_PROVIDER [double precision, fock_3e_uhf_mo_cs, (mo_num, mo_num)] + + implicit none + integer :: a, b, i, j, ipoint + double precision :: ti, tf + double precision :: loc_1, loc_2, loc_3 + double precision, allocatable :: Okappa(:), Jkappa(:,:) + double precision, allocatable :: tmp_omp_d1(:), tmp_omp_d2(:,:) + double precision, allocatable :: tmp_1(:,:), tmp_2(:,:,:,:) + double precision, allocatable :: tmp_3(:,:,:), tmp_4(:,:,:) + + PROVIDE mo_l_coef mo_r_coef + + !print *, ' PROVIDING fock_3e_uhf_mo_cs ...' + !call wall_time(ti) + + ! --- + + allocate(Jkappa(n_points_final_grid,3), Okappa(n_points_final_grid)) + Jkappa = 0.d0 + Okappa = 0.d0 + + !$OMP PARALLEL & + !$OMP DEFAULT (NONE) & + !$OMP PRIVATE (ipoint, i, tmp_omp_d1, tmp_omp_d2) & + !$OMP SHARED (n_points_final_grid, elec_beta_num, & + !$OMP mos_l_in_r_array_transp, mos_r_in_r_array_transp, & + !$OMP int2_grad1_u12_bimo_t, Okappa, Jkappa) + + allocate(tmp_omp_d2(n_points_final_grid,3), tmp_omp_d1(n_points_final_grid)) + tmp_omp_d2 = 0.d0 + tmp_omp_d1 = 0.d0 + + !$OMP DO + do i = 1, elec_beta_num + do ipoint = 1, n_points_final_grid + tmp_omp_d2(ipoint,1) += int2_grad1_u12_bimo_t(ipoint,1,i,i) + tmp_omp_d2(ipoint,2) += int2_grad1_u12_bimo_t(ipoint,2,i,i) + tmp_omp_d2(ipoint,3) += int2_grad1_u12_bimo_t(ipoint,3,i,i) + tmp_omp_d1(ipoint) += mos_l_in_r_array_transp(ipoint,i) * mos_r_in_r_array_transp(ipoint,i) + enddo + enddo + !$OMP END DO NOWAIT + + !$OMP CRITICAL + do ipoint = 1, n_points_final_grid + Jkappa(ipoint,1) += tmp_omp_d2(ipoint,1) + Jkappa(ipoint,2) += tmp_omp_d2(ipoint,2) + Jkappa(ipoint,3) += tmp_omp_d2(ipoint,3) + Okappa(ipoint) += tmp_omp_d1(ipoint) + enddo + !$OMP END CRITICAL + + deallocate(tmp_omp_d2, tmp_omp_d1) + + !$OMP END PARALLEL + + ! --- + + allocate(tmp_1(n_points_final_grid,4)) + + do ipoint = 1, n_points_final_grid + + loc_1 = 2.d0 * Okappa(ipoint) + + tmp_1(ipoint,1) = loc_1 * Jkappa(ipoint,1) + tmp_1(ipoint,2) = loc_1 * Jkappa(ipoint,2) + tmp_1(ipoint,3) = loc_1 * Jkappa(ipoint,3) + + tmp_1(ipoint,4) = Okappa(ipoint) + enddo + + + !$OMP PARALLEL & + !$OMP DEFAULT (NONE) & + !$OMP PRIVATE (ipoint, i, j, loc_1, tmp_omp_d2) & + !$OMP SHARED (n_points_final_grid, elec_beta_num, & + !$OMP mos_l_in_r_array_transp, mos_r_in_r_array_transp, & + !$OMP int2_grad1_u12_bimo_t, tmp_1) + + allocate(tmp_omp_d2(n_points_final_grid,3)) + tmp_omp_d2 = 0.d0 + + !$OMP DO COLLAPSE(2) + do i = 1, elec_beta_num + do j = 1, elec_beta_num + do ipoint = 1, n_points_final_grid + + loc_1 = mos_l_in_r_array_transp(ipoint,j) * mos_r_in_r_array_transp(ipoint,i) + + tmp_omp_d2(ipoint,1) -= loc_1 * int2_grad1_u12_bimo_t(ipoint,1,i,j) + tmp_omp_d2(ipoint,2) -= loc_1 * int2_grad1_u12_bimo_t(ipoint,2,i,j) + tmp_omp_d2(ipoint,3) -= loc_1 * int2_grad1_u12_bimo_t(ipoint,3,i,j) + enddo + enddo + enddo + !$OMP END DO NOWAIT + + !$OMP CRITICAL + do ipoint = 1, n_points_final_grid + tmp_1(ipoint,1) += tmp_omp_d2(ipoint,1) + tmp_1(ipoint,2) += tmp_omp_d2(ipoint,2) + tmp_1(ipoint,3) += tmp_omp_d2(ipoint,3) + enddo + !$OMP END CRITICAL + + deallocate(tmp_omp_d2) + !$OMP END PARALLEL + + ! --- + + allocate(tmp_2(n_points_final_grid,4,mo_num,mo_num)) + + !$OMP PARALLEL & + !$OMP DEFAULT (NONE) & + !$OMP PRIVATE (ipoint, a, b) & + !$OMP SHARED (n_points_final_grid, mo_num, & + !$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_2) + !$OMP DO COLLAPSE(2) + do a = 1, mo_num + do b = 1, mo_num + do ipoint = 1, n_points_final_grid + tmp_2(ipoint,1,b,a) = final_weight_at_r_vector(ipoint) * int2_grad1_u12_bimo_t(ipoint,1,b,a) + tmp_2(ipoint,2,b,a) = final_weight_at_r_vector(ipoint) * int2_grad1_u12_bimo_t(ipoint,2,b,a) + tmp_2(ipoint,3,b,a) = final_weight_at_r_vector(ipoint) * int2_grad1_u12_bimo_t(ipoint,3,b,a) + enddo + enddo + enddo + !$OMP END DO + !$OMP END PARALLEL + + !$OMP PARALLEL & + !$OMP DEFAULT (NONE) & + !$OMP PRIVATE (ipoint, a, b, i) & + !$OMP SHARED (n_points_final_grid, mo_num, elec_beta_num, & + !$OMP final_weight_at_r_vector, int2_grad1_u12_bimo_t, & + !$OMP tmp_2) + !$OMP DO COLLAPSE(2) + do a = 1, mo_num + do b = 1, mo_num + tmp_2(:,4,b,a) = 0.d0 + do i = 1, elec_beta_num + do ipoint = 1, n_points_final_grid + tmp_2(ipoint,4,b,a) -= final_weight_at_r_vector(ipoint) * ( int2_grad1_u12_bimo_t(ipoint,1,b,i) * int2_grad1_u12_bimo_t(ipoint,1,i,a) & + + int2_grad1_u12_bimo_t(ipoint,2,b,i) * int2_grad1_u12_bimo_t(ipoint,2,i,a) & + + int2_grad1_u12_bimo_t(ipoint,3,b,i) * int2_grad1_u12_bimo_t(ipoint,3,i,a) ) + enddo + enddo + enddo + enddo + !$OMP END DO + !$OMP END PARALLEL + + ! --- + + call dgemv( 'T', 4*n_points_final_grid, mo_num*mo_num, -2.d0 & + , tmp_2(1,1,1,1), size(tmp_2, 1) * size(tmp_2, 2) & + , tmp_1(1,1), 1 & + , 0.d0, fock_3e_uhf_mo_cs(1,1), 1) + + deallocate(tmp_1, tmp_2) + + ! --- + + allocate(tmp_3(n_points_final_grid,5,mo_num), tmp_4(n_points_final_grid,5,mo_num)) + + !$OMP PARALLEL & + !$OMP DEFAULT (NONE) & + !$OMP PRIVATE (ipoint, b, loc_1, loc_2) & + !$OMP SHARED (n_points_final_grid, mo_num, & + !$OMP mos_l_in_r_array_transp, mos_r_in_r_array_transp, & + !$OMP final_weight_at_r_vector, Jkappa, tmp_3, tmp_4) + !$OMP DO + do b = 1, mo_num + tmp_3(:,:,b) = 0.d0 + tmp_4(:,:,b) = 0.d0 + do ipoint = 1, n_points_final_grid + tmp_3(ipoint,1,b) = final_weight_at_r_vector(ipoint) * mos_l_in_r_array_transp(ipoint,b) + + tmp_4(ipoint,1,b) = -2.d0 * mos_r_in_r_array_transp(ipoint,b) * ( Jkappa(ipoint,1) * Jkappa(ipoint,1) & + + Jkappa(ipoint,2) * Jkappa(ipoint,2) & + + Jkappa(ipoint,3) * Jkappa(ipoint,3) ) + tmp_4(ipoint,5,b) = mos_r_in_r_array_transp(ipoint,b) + enddo + enddo + !$OMP END DO + !$OMP END PARALLEL + + !$OMP PARALLEL & + !$OMP DEFAULT (NONE) & + !$OMP PRIVATE (ipoint, b, i, loc_1, loc_2) & + !$OMP SHARED (n_points_final_grid, mo_num, elec_beta_num, & + !$OMP final_weight_at_r_vector, int2_grad1_u12_bimo_t, & + !$OMP mos_l_in_r_array_transp, mos_r_in_r_array_transp, & + !$OMP Jkappa, tmp_3, tmp_4) + !$OMP DO + do b = 1, mo_num + do i = 1, elec_beta_num + do ipoint = 1, n_points_final_grid + + loc_1 = final_weight_at_r_vector(ipoint) * mos_l_in_r_array_transp(ipoint,i) + loc_2 = mos_r_in_r_array_transp(ipoint,i) + + tmp_3(ipoint,2,b) -= loc_1 * int2_grad1_u12_bimo_t(ipoint,1,b,i) + tmp_3(ipoint,3,b) -= loc_1 * int2_grad1_u12_bimo_t(ipoint,2,b,i) + tmp_3(ipoint,4,b) -= loc_1 * int2_grad1_u12_bimo_t(ipoint,3,b,i) + tmp_3(ipoint,5,b) += 2.d0 * loc_1 * ( Jkappa(ipoint,1) * int2_grad1_u12_bimo_t(ipoint,1,b,i) & + + Jkappa(ipoint,2) * int2_grad1_u12_bimo_t(ipoint,2,b,i) & + + Jkappa(ipoint,3) * int2_grad1_u12_bimo_t(ipoint,3,b,i) ) + + tmp_4(ipoint,2,b) += loc_2 * int2_grad1_u12_bimo_t(ipoint,1,i,b) + tmp_4(ipoint,3,b) += loc_2 * int2_grad1_u12_bimo_t(ipoint,2,i,b) + tmp_4(ipoint,4,b) += loc_2 * int2_grad1_u12_bimo_t(ipoint,3,i,b) + tmp_4(ipoint,1,b) += 2.d0 * loc_2 * ( Jkappa(ipoint,1) * int2_grad1_u12_bimo_t(ipoint,1,i,b) & + + Jkappa(ipoint,2) * int2_grad1_u12_bimo_t(ipoint,2,i,b) & + + Jkappa(ipoint,3) * int2_grad1_u12_bimo_t(ipoint,3,i,b) ) + enddo + enddo + enddo + !$OMP END DO + !$OMP END PARALLEL + + !$OMP PARALLEL & + !$OMP DEFAULT (NONE) & + !$OMP PRIVATE (ipoint, b, i, j, loc_1, loc_2, loc_3) & + !$OMP SHARED (n_points_final_grid, mo_num, elec_beta_num, & + !$OMP final_weight_at_r_vector, int2_grad1_u12_bimo_t, & + !$OMP mos_l_in_r_array_transp, mos_r_in_r_array_transp, & + !$OMP tmp_3, tmp_4) + !$OMP DO + do b = 1, mo_num + do i = 1, elec_beta_num + do j = 1, elec_beta_num + do ipoint = 1, n_points_final_grid + + loc_1 = final_weight_at_r_vector(ipoint) * mos_l_in_r_array_transp(ipoint,j) + loc_2 = mos_r_in_r_array_transp(ipoint,b) + loc_3 = mos_r_in_r_array_transp(ipoint,i) + + tmp_3(ipoint,5,b) -= loc_1 * ( int2_grad1_u12_bimo_t(ipoint,1,b,i) * int2_grad1_u12_bimo_t(ipoint,1,i,j) & + + int2_grad1_u12_bimo_t(ipoint,2,b,i) * int2_grad1_u12_bimo_t(ipoint,2,i,j) & + + int2_grad1_u12_bimo_t(ipoint,3,b,i) * int2_grad1_u12_bimo_t(ipoint,3,i,j) ) + + tmp_4(ipoint,1,b) += ( loc_2 * ( int2_grad1_u12_bimo_t(ipoint,1,i,j) * int2_grad1_u12_bimo_t(ipoint,1,j,i) & + + int2_grad1_u12_bimo_t(ipoint,2,i,j) * int2_grad1_u12_bimo_t(ipoint,2,j,i) & + + int2_grad1_u12_bimo_t(ipoint,3,i,j) * int2_grad1_u12_bimo_t(ipoint,3,j,i) ) & + - loc_3 * ( int2_grad1_u12_bimo_t(ipoint,1,i,j) * int2_grad1_u12_bimo_t(ipoint,1,j,b) & + + int2_grad1_u12_bimo_t(ipoint,2,i,j) * int2_grad1_u12_bimo_t(ipoint,2,j,b) & + + int2_grad1_u12_bimo_t(ipoint,3,i,j) * int2_grad1_u12_bimo_t(ipoint,3,j,b) ) ) + enddo + enddo + enddo + enddo + !$OMP END DO + !$OMP END PARALLEL + + ! --- + + call dgemm( 'T', 'N', mo_num, mo_num, 5*n_points_final_grid, 1.d0 & + , tmp_3(1,1,1), 5*n_points_final_grid & + , tmp_4(1,1,1), 5*n_points_final_grid & + , 1.d0, fock_3e_uhf_mo_cs(1,1), mo_num) + + deallocate(tmp_3, tmp_4) + deallocate(Jkappa, Okappa) + + ! --- + + !call wall_time(tf) + !print *, ' total Wall time for fock_3e_uhf_mo_cs =', tf - ti + +END_PROVIDER + +! --- + diff --git a/plugins/local/tc_scf/fock_3e_bi_ortho_os.irp.f b/plugins/local/tc_scf/fock_3e_bi_ortho_os.irp.f new file mode 100644 index 00000000..4bbce720 --- /dev/null +++ b/plugins/local/tc_scf/fock_3e_bi_ortho_os.irp.f @@ -0,0 +1,536 @@ + +! --- + + BEGIN_PROVIDER [double precision, fock_3e_uhf_mo_a_os, (mo_num, mo_num)] +&BEGIN_PROVIDER [double precision, fock_3e_uhf_mo_b_os, (mo_num, mo_num)] + + BEGIN_DOC + ! + ! Open Shell part of the Fock matrix from three-electron terms + ! + ! WARNING :: non hermitian if bi-ortho MOS used + ! + END_DOC + + implicit none + integer :: a, b, i, j, ipoint + double precision :: loc_1, loc_2, loc_3, loc_4 + double precision :: ti, tf + double precision, allocatable :: Okappa(:), Jkappa(:,:), Obarkappa(:), Jbarkappa(:,:) + double precision, allocatable :: tmp_omp_d1(:), tmp_omp_d2(:,:) + double precision, allocatable :: tmp_1(:,:), tmp_2(:,:,:,:) + double precision, allocatable :: tmp_3(:,:,:), tmp_4(:,:,:) + + PROVIDE mo_l_coef mo_r_coef + + !print *, ' Providing fock_3e_uhf_mo_a_os and fock_3e_uhf_mo_b_os ...' + !call wall_time(ti) + + ! --- + + allocate(Jkappa(n_points_final_grid,3), Okappa(n_points_final_grid)) + allocate(Jbarkappa(n_points_final_grid,3), Obarkappa(n_points_final_grid)) + Jkappa = 0.d0 + Okappa = 0.d0 + Jbarkappa = 0.d0 + Obarkappa = 0.d0 + + !$OMP PARALLEL & + !$OMP DEFAULT (NONE) & + !$OMP PRIVATE (ipoint, i, tmp_omp_d1, tmp_omp_d2) & + !$OMP SHARED (n_points_final_grid, elec_beta_num, elec_alpha_num, & + !$OMP mos_l_in_r_array_transp, mos_r_in_r_array_transp, & + !$OMP int2_grad1_u12_bimo_t, Okappa, Jkappa, Obarkappa, Jbarkappa) + + allocate(tmp_omp_d2(n_points_final_grid,3), tmp_omp_d1(n_points_final_grid)) + + tmp_omp_d2 = 0.d0 + tmp_omp_d1 = 0.d0 + !$OMP DO + do i = 1, elec_beta_num + do ipoint = 1, n_points_final_grid + tmp_omp_d2(ipoint,1) += int2_grad1_u12_bimo_t(ipoint,1,i,i) + tmp_omp_d2(ipoint,2) += int2_grad1_u12_bimo_t(ipoint,2,i,i) + tmp_omp_d2(ipoint,3) += int2_grad1_u12_bimo_t(ipoint,3,i,i) + tmp_omp_d1(ipoint) += mos_l_in_r_array_transp(ipoint,i) * mos_r_in_r_array_transp(ipoint,i) + enddo + enddo + !$OMP END DO NOWAIT + !$OMP CRITICAL + do ipoint = 1, n_points_final_grid + Jkappa(ipoint,1) += tmp_omp_d2(ipoint,1) + Jkappa(ipoint,2) += tmp_omp_d2(ipoint,2) + Jkappa(ipoint,3) += tmp_omp_d2(ipoint,3) + Okappa(ipoint) += tmp_omp_d1(ipoint) + enddo + !$OMP END CRITICAL + + tmp_omp_d2 = 0.d0 + tmp_omp_d1 = 0.d0 + !$OMP DO + do i = elec_beta_num+1, elec_alpha_num + do ipoint = 1, n_points_final_grid + tmp_omp_d2(ipoint,1) += int2_grad1_u12_bimo_t(ipoint,1,i,i) + tmp_omp_d2(ipoint,2) += int2_grad1_u12_bimo_t(ipoint,2,i,i) + tmp_omp_d2(ipoint,3) += int2_grad1_u12_bimo_t(ipoint,3,i,i) + tmp_omp_d1(ipoint) += mos_l_in_r_array_transp(ipoint,i) * mos_r_in_r_array_transp(ipoint,i) + enddo + enddo + !$OMP END DO NOWAIT + !$OMP CRITICAL + do ipoint = 1, n_points_final_grid + Jbarkappa(ipoint,1) += tmp_omp_d2(ipoint,1) + Jbarkappa(ipoint,2) += tmp_omp_d2(ipoint,2) + Jbarkappa(ipoint,3) += tmp_omp_d2(ipoint,3) + Obarkappa(ipoint) += tmp_omp_d1(ipoint) + enddo + !$OMP END CRITICAL + + deallocate(tmp_omp_d2, tmp_omp_d1) + !$OMP END PARALLEL + + ! --- + + allocate(tmp_1(n_points_final_grid,4)) + + do ipoint = 1, n_points_final_grid + + loc_1 = -2.d0 * Okappa (ipoint) + loc_2 = -2.d0 * Obarkappa(ipoint) + loc_3 = Obarkappa(ipoint) + + tmp_1(ipoint,1) = (loc_1 - loc_3) * Jbarkappa(ipoint,1) + loc_2 * Jkappa(ipoint,1) + tmp_1(ipoint,2) = (loc_1 - loc_3) * Jbarkappa(ipoint,2) + loc_2 * Jkappa(ipoint,2) + tmp_1(ipoint,3) = (loc_1 - loc_3) * Jbarkappa(ipoint,3) + loc_2 * Jkappa(ipoint,3) + + tmp_1(ipoint,4) = Obarkappa(ipoint) + enddo + + + !$OMP PARALLEL & + !$OMP DEFAULT (NONE) & + !$OMP PRIVATE (ipoint, i, j, loc_1, loc_2, tmp_omp_d2) & + !$OMP SHARED (n_points_final_grid, elec_beta_num, elec_alpha_num, & + !$OMP mos_l_in_r_array_transp, mos_r_in_r_array_transp, & + !$OMP int2_grad1_u12_bimo_t, tmp_1) + + allocate(tmp_omp_d2(n_points_final_grid,3)) + + tmp_omp_d2 = 0.d0 + !$OMP DO COLLAPSE(2) + do i = 1, elec_beta_num + do j = elec_beta_num+1, elec_alpha_num + do ipoint = 1, n_points_final_grid + + loc_1 = mos_l_in_r_array_transp(ipoint,j) * mos_r_in_r_array_transp(ipoint,i) + loc_2 = mos_l_in_r_array_transp(ipoint,i) * mos_r_in_r_array_transp(ipoint,j) + + tmp_omp_d2(ipoint,1) += loc_1 * int2_grad1_u12_bimo_t(ipoint,1,i,j) + loc_2 * int2_grad1_u12_bimo_t(ipoint,1,j,i) + tmp_omp_d2(ipoint,2) += loc_1 * int2_grad1_u12_bimo_t(ipoint,2,i,j) + loc_2 * int2_grad1_u12_bimo_t(ipoint,2,j,i) + tmp_omp_d2(ipoint,3) += loc_1 * int2_grad1_u12_bimo_t(ipoint,3,i,j) + loc_2 * int2_grad1_u12_bimo_t(ipoint,3,j,i) + enddo + enddo + enddo + !$OMP END DO NOWAIT + !$OMP CRITICAL + do ipoint = 1, n_points_final_grid + tmp_1(ipoint,1) += tmp_omp_d2(ipoint,1) + tmp_1(ipoint,2) += tmp_omp_d2(ipoint,2) + tmp_1(ipoint,3) += tmp_omp_d2(ipoint,3) + enddo + !$OMP END CRITICAL + + tmp_omp_d2 = 0.d0 + !$OMP DO COLLAPSE(2) + do i = elec_beta_num+1, elec_alpha_num + do j = elec_beta_num+1, elec_alpha_num + do ipoint = 1, n_points_final_grid + + loc_1 = mos_l_in_r_array_transp(ipoint,j) * mos_r_in_r_array_transp(ipoint,i) + + tmp_omp_d2(ipoint,1) += loc_1 * int2_grad1_u12_bimo_t(ipoint,1,i,j) + tmp_omp_d2(ipoint,2) += loc_1 * int2_grad1_u12_bimo_t(ipoint,2,i,j) + tmp_omp_d2(ipoint,3) += loc_1 * int2_grad1_u12_bimo_t(ipoint,3,i,j) + enddo + enddo + enddo + !$OMP END DO NOWAIT + !$OMP CRITICAL + do ipoint = 1, n_points_final_grid + tmp_1(ipoint,1) += tmp_omp_d2(ipoint,1) + tmp_1(ipoint,2) += tmp_omp_d2(ipoint,2) + tmp_1(ipoint,3) += tmp_omp_d2(ipoint,3) + enddo + !$OMP END CRITICAL + + deallocate(tmp_omp_d2) + !$OMP END PARALLEL + + ! --- + + allocate(tmp_2(n_points_final_grid,4,mo_num,mo_num)) + + !$OMP PARALLEL & + !$OMP DEFAULT (NONE) & + !$OMP PRIVATE (ipoint, a, b) & + !$OMP SHARED (n_points_final_grid, mo_num, & + !$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_2) + !$OMP DO COLLAPSE(2) + do a = 1, mo_num + do b = 1, mo_num + do ipoint = 1, n_points_final_grid + tmp_2(ipoint,1,b,a) = final_weight_at_r_vector(ipoint) * int2_grad1_u12_bimo_t(ipoint,1,b,a) + tmp_2(ipoint,2,b,a) = final_weight_at_r_vector(ipoint) * int2_grad1_u12_bimo_t(ipoint,2,b,a) + tmp_2(ipoint,3,b,a) = final_weight_at_r_vector(ipoint) * int2_grad1_u12_bimo_t(ipoint,3,b,a) + enddo + enddo + enddo + !$OMP END DO + !$OMP END PARALLEL + + !$OMP PARALLEL & + !$OMP DEFAULT (NONE) & + !$OMP PRIVATE (ipoint, a, b, i) & + !$OMP SHARED (n_points_final_grid, mo_num, elec_beta_num, elec_alpha_num, & + !$OMP final_weight_at_r_vector, int2_grad1_u12_bimo_t, & + !$OMP tmp_2) + !$OMP DO COLLAPSE(2) + do a = 1, mo_num + do b = 1, mo_num + + tmp_2(:,4,b,a) = 0.d0 + do i = 1, elec_beta_num + do ipoint = 1, n_points_final_grid + tmp_2(ipoint,4,b,a) += final_weight_at_r_vector(ipoint) * ( int2_grad1_u12_bimo_t(ipoint,1,b,i) * int2_grad1_u12_bimo_t(ipoint,1,i,a) & + + int2_grad1_u12_bimo_t(ipoint,2,b,i) * int2_grad1_u12_bimo_t(ipoint,2,i,a) & + + int2_grad1_u12_bimo_t(ipoint,3,b,i) * int2_grad1_u12_bimo_t(ipoint,3,i,a) ) + enddo + enddo + enddo + enddo + !$OMP END DO + !$OMP END PARALLEL + + ! --- + + call dgemv( 'T', 4*n_points_final_grid, mo_num*mo_num, 1.d0 & + , tmp_2(1,1,1,1), size(tmp_2, 1) * size(tmp_2, 2) & + , tmp_1(1,1), 1 & + , 0.d0, fock_3e_uhf_mo_b_os(1,1), 1) + + deallocate(tmp_1, tmp_2) + + ! --- + + allocate(tmp_3(n_points_final_grid,2,mo_num), tmp_4(n_points_final_grid,2,mo_num)) + + !$OMP PARALLEL & + !$OMP DEFAULT (NONE) & + !$OMP PRIVATE (ipoint, b, loc_1, loc_2) & + !$OMP SHARED (n_points_final_grid, mo_num, & + !$OMP mos_l_in_r_array_transp, mos_r_in_r_array_transp, & + !$OMP final_weight_at_r_vector, Jkappa, Jbarkappa, tmp_3, tmp_4) + !$OMP DO + do b = 1, mo_num + tmp_3(:,:,b) = 0.d0 + tmp_4(:,:,b) = 0.d0 + do ipoint = 1, n_points_final_grid + + tmp_3(ipoint,1,b) = final_weight_at_r_vector(ipoint) * mos_l_in_r_array_transp(ipoint,b) + + loc_1 = -2.0d0 * mos_r_in_r_array_transp(ipoint,b) + + tmp_4(ipoint,1,b) = loc_1 * ( Jbarkappa(ipoint,1) * (Jkappa(ipoint,1) + 0.25d0 * Jbarkappa(ipoint,1)) & + + Jbarkappa(ipoint,2) * (Jkappa(ipoint,2) + 0.25d0 * Jbarkappa(ipoint,2)) & + + Jbarkappa(ipoint,3) * (Jkappa(ipoint,3) + 0.25d0 * Jbarkappa(ipoint,3)) ) + + tmp_4(ipoint,2,b) = mos_r_in_r_array_transp(ipoint,b) + enddo + enddo + !$OMP END DO + !$OMP END PARALLEL + + !$OMP PARALLEL & + !$OMP DEFAULT (NONE) & + !$OMP PRIVATE (ipoint, b, i, loc_1, loc_2, loc_3, loc_4) & + !$OMP SHARED (n_points_final_grid, mo_num, elec_beta_num, elec_alpha_num, & + !$OMP final_weight_at_r_vector, int2_grad1_u12_bimo_t, & + !$OMP mos_l_in_r_array_transp, mos_r_in_r_array_transp, & + !$OMP Jkappa, Jbarkappa, tmp_3, tmp_4) + !$OMP DO + do b = 1, mo_num + + do i = 1, elec_beta_num + do ipoint = 1, n_points_final_grid + + loc_1 = final_weight_at_r_vector(ipoint) * mos_l_in_r_array_transp(ipoint,i) + loc_2 = mos_r_in_r_array_transp(ipoint,i) + + tmp_3(ipoint,2,b) += loc_1 * ( Jbarkappa(ipoint,1) * int2_grad1_u12_bimo_t(ipoint,1,b,i) & + + Jbarkappa(ipoint,2) * int2_grad1_u12_bimo_t(ipoint,2,b,i) & + + Jbarkappa(ipoint,3) * int2_grad1_u12_bimo_t(ipoint,3,b,i) ) + + tmp_4(ipoint,1,b) += loc_2 * ( Jbarkappa(ipoint,1) * int2_grad1_u12_bimo_t(ipoint,1,i,b) & + + Jbarkappa(ipoint,2) * int2_grad1_u12_bimo_t(ipoint,2,i,b) & + + Jbarkappa(ipoint,3) * int2_grad1_u12_bimo_t(ipoint,3,i,b) ) + enddo + enddo + enddo + !$OMP END DO + !$OMP END PARALLEL + + !$OMP PARALLEL & + !$OMP DEFAULT (NONE) & + !$OMP PRIVATE (ipoint, b, i, j, loc_1, loc_2, loc_3) & + !$OMP SHARED (n_points_final_grid, mo_num, elec_beta_num, elec_alpha_num, & + !$OMP final_weight_at_r_vector, int2_grad1_u12_bimo_t, & + !$OMP mos_l_in_r_array_transp, mos_r_in_r_array_transp, & + !$OMP tmp_3, tmp_4) + !$OMP DO + do b = 1, mo_num + do i = 1, elec_beta_num + do j = elec_beta_num+1, elec_alpha_num + do ipoint = 1, n_points_final_grid + + loc_2 = mos_r_in_r_array_transp(ipoint,b) + + tmp_4(ipoint,1,b) += loc_2 * ( int2_grad1_u12_bimo_t(ipoint,1,i,j) * int2_grad1_u12_bimo_t(ipoint,1,j,i) & + + int2_grad1_u12_bimo_t(ipoint,2,i,j) * int2_grad1_u12_bimo_t(ipoint,2,j,i) & + + int2_grad1_u12_bimo_t(ipoint,3,i,j) * int2_grad1_u12_bimo_t(ipoint,3,j,i) ) + enddo + enddo + enddo + + do i = elec_beta_num+1, elec_alpha_num + do j = elec_beta_num+1, elec_alpha_num + do ipoint = 1, n_points_final_grid + + loc_2 = 0.5d0 * mos_r_in_r_array_transp(ipoint,b) + + tmp_4(ipoint,1,b) += loc_2 * ( int2_grad1_u12_bimo_t(ipoint,1,i,j) * int2_grad1_u12_bimo_t(ipoint,1,j,i) & + + int2_grad1_u12_bimo_t(ipoint,2,i,j) * int2_grad1_u12_bimo_t(ipoint,2,j,i) & + + int2_grad1_u12_bimo_t(ipoint,3,i,j) * int2_grad1_u12_bimo_t(ipoint,3,j,i) ) + enddo + enddo + enddo + enddo + !$OMP END DO + !$OMP END PARALLEL + + ! --- + + call dgemm( 'T', 'N', mo_num, mo_num, 2*n_points_final_grid, 1.d0 & + , tmp_3(1,1,1), 2*n_points_final_grid & + , tmp_4(1,1,1), 2*n_points_final_grid & + , 1.d0, fock_3e_uhf_mo_b_os(1,1), mo_num) + + deallocate(tmp_3, tmp_4) + + + + + ! --- + + fock_3e_uhf_mo_a_os = fock_3e_uhf_mo_b_os + + allocate(tmp_1(n_points_final_grid,1)) + + do ipoint = 1, n_points_final_grid + tmp_1(ipoint,1) = Obarkappa(ipoint) + 2.d0 * Okappa(ipoint) + enddo + + allocate(tmp_2(n_points_final_grid,1,mo_num,mo_num)) + + !$OMP PARALLEL & + !$OMP DEFAULT (NONE) & + !$OMP PRIVATE (ipoint, a, b, i) & + !$OMP SHARED (n_points_final_grid, mo_num, elec_beta_num, elec_alpha_num, & + !$OMP final_weight_at_r_vector, int2_grad1_u12_bimo_t, & + !$OMP tmp_2) + !$OMP DO COLLAPSE(2) + do a = 1, mo_num + do b = 1, mo_num + + tmp_2(:,1,b,a) = 0.d0 + do i = elec_beta_num+1, elec_alpha_num + do ipoint = 1, n_points_final_grid + tmp_2(ipoint,1,b,a) += final_weight_at_r_vector(ipoint) * ( int2_grad1_u12_bimo_t(ipoint,1,b,i) * int2_grad1_u12_bimo_t(ipoint,1,i,a) & + + int2_grad1_u12_bimo_t(ipoint,2,b,i) * int2_grad1_u12_bimo_t(ipoint,2,i,a) & + + int2_grad1_u12_bimo_t(ipoint,3,b,i) * int2_grad1_u12_bimo_t(ipoint,3,i,a) ) + enddo + enddo + enddo + enddo + !$OMP END DO + !$OMP END PARALLEL + + call dgemv( 'T', n_points_final_grid, mo_num*mo_num, 1.d0 & + , tmp_2(1,1,1,1), size(tmp_2, 1) * size(tmp_2, 2) & + , tmp_1(1,1), 1 & + , 1.d0, fock_3e_uhf_mo_a_os(1,1), 1) + + deallocate(tmp_1, tmp_2) + + ! --- + + allocate(tmp_3(n_points_final_grid,8,mo_num), tmp_4(n_points_final_grid,8,mo_num)) + + !$OMP PARALLEL & + !$OMP DEFAULT (NONE) & + !$OMP PRIVATE (ipoint, b) & + !$OMP SHARED (n_points_final_grid, mo_num, & + !$OMP mos_l_in_r_array_transp, mos_r_in_r_array_transp, & + !$OMP final_weight_at_r_vector, Jkappa, Jbarkappa, tmp_3, tmp_4) + !$OMP DO + do b = 1, mo_num + tmp_3(:,:,b) = 0.d0 + tmp_4(:,:,b) = 0.d0 + do ipoint = 1, n_points_final_grid + + tmp_3(ipoint,1,b) = final_weight_at_r_vector(ipoint) * mos_l_in_r_array_transp(ipoint,b) + + tmp_4(ipoint,8,b) = mos_r_in_r_array_transp(ipoint,b) + enddo + enddo + !$OMP END DO + !$OMP END PARALLEL + + !$OMP PARALLEL & + !$OMP DEFAULT (NONE) & + !$OMP PRIVATE (ipoint, b, i, loc_1, loc_2, loc_3, loc_4) & + !$OMP SHARED (n_points_final_grid, mo_num, elec_beta_num, elec_alpha_num, & + !$OMP final_weight_at_r_vector, int2_grad1_u12_bimo_t, & + !$OMP mos_l_in_r_array_transp, mos_r_in_r_array_transp, & + !$OMP Jkappa, Jbarkappa, tmp_3, tmp_4) + !$OMP DO + do b = 1, mo_num + do i = 1, elec_beta_num + do ipoint = 1, n_points_final_grid + + loc_1 = final_weight_at_r_vector(ipoint) * mos_l_in_r_array_transp(ipoint,i) + loc_2 = mos_r_in_r_array_transp(ipoint,i) + + tmp_3(ipoint,2,b) -= loc_1 * int2_grad1_u12_bimo_t(ipoint,1,b,i) + tmp_3(ipoint,3,b) -= loc_1 * int2_grad1_u12_bimo_t(ipoint,2,b,i) + tmp_3(ipoint,4,b) -= loc_1 * int2_grad1_u12_bimo_t(ipoint,3,b,i) + + tmp_4(ipoint,5,b) += loc_2 * int2_grad1_u12_bimo_t(ipoint,1,i,b) + tmp_4(ipoint,6,b) += loc_2 * int2_grad1_u12_bimo_t(ipoint,2,i,b) + tmp_4(ipoint,7,b) += loc_2 * int2_grad1_u12_bimo_t(ipoint,3,i,b) + enddo + enddo + + do i = elec_beta_num+1, elec_alpha_num + do ipoint = 1, n_points_final_grid + + loc_1 = final_weight_at_r_vector(ipoint) * mos_l_in_r_array_transp(ipoint,i) + loc_3 = 2.d0 * loc_1 + loc_2 = mos_r_in_r_array_transp(ipoint,i) + loc_4 = 2.d0 * loc_2 + + tmp_3(ipoint,5,b) -= loc_1 * int2_grad1_u12_bimo_t(ipoint,1,b,i) + tmp_3(ipoint,6,b) -= loc_1 * int2_grad1_u12_bimo_t(ipoint,2,b,i) + tmp_3(ipoint,7,b) -= loc_1 * int2_grad1_u12_bimo_t(ipoint,3,b,i) + + tmp_3(ipoint,8,b) += loc_3 * ( (Jkappa(ipoint,1) + 0.5d0 * Jbarkappa(ipoint,1)) * int2_grad1_u12_bimo_t(ipoint,1,b,i) & + + (Jkappa(ipoint,2) + 0.5d0 * Jbarkappa(ipoint,2)) * int2_grad1_u12_bimo_t(ipoint,2,b,i) & + + (Jkappa(ipoint,3) + 0.5d0 * Jbarkappa(ipoint,3)) * int2_grad1_u12_bimo_t(ipoint,3,b,i) ) + + tmp_4(ipoint,1,b) += loc_4 * ( (Jkappa(ipoint,1) + 0.5d0 * Jbarkappa(ipoint,1)) * int2_grad1_u12_bimo_t(ipoint,1,i,b) & + + (Jkappa(ipoint,2) + 0.5d0 * Jbarkappa(ipoint,2)) * int2_grad1_u12_bimo_t(ipoint,2,i,b) & + + (Jkappa(ipoint,3) + 0.5d0 * Jbarkappa(ipoint,3)) * int2_grad1_u12_bimo_t(ipoint,3,i,b) ) + + tmp_4(ipoint,2,b) += loc_2 * int2_grad1_u12_bimo_t(ipoint,1,i,b) + tmp_4(ipoint,3,b) += loc_2 * int2_grad1_u12_bimo_t(ipoint,2,i,b) + tmp_4(ipoint,4,b) += loc_2 * int2_grad1_u12_bimo_t(ipoint,3,i,b) + + tmp_4(ipoint,5,b) += loc_2 * int2_grad1_u12_bimo_t(ipoint,1,i,b) + tmp_4(ipoint,6,b) += loc_2 * int2_grad1_u12_bimo_t(ipoint,2,i,b) + tmp_4(ipoint,7,b) += loc_2 * int2_grad1_u12_bimo_t(ipoint,3,i,b) + enddo + enddo + enddo + !$OMP END DO + !$OMP END PARALLEL + + !$OMP PARALLEL & + !$OMP DEFAULT (NONE) & + !$OMP PRIVATE (ipoint, b, i, j, loc_1, loc_2, loc_3) & + !$OMP SHARED (n_points_final_grid, mo_num, elec_beta_num, elec_alpha_num, & + !$OMP final_weight_at_r_vector, int2_grad1_u12_bimo_t, & + !$OMP mos_l_in_r_array_transp, mos_r_in_r_array_transp, & + !$OMP tmp_3, tmp_4) + !$OMP DO + do b = 1, mo_num + + do i = 1, elec_beta_num + do j = elec_beta_num+1, elec_alpha_num + do ipoint = 1, n_points_final_grid + + loc_1 = final_weight_at_r_vector(ipoint) * mos_l_in_r_array_transp(ipoint,j) + loc_2 = mos_r_in_r_array_transp(ipoint,b) + loc_3 = mos_r_in_r_array_transp(ipoint,i) + + tmp_3(ipoint,8,b) -= loc_1 * ( int2_grad1_u12_bimo_t(ipoint,1,b,i) * int2_grad1_u12_bimo_t(ipoint,1,i,j) & + + int2_grad1_u12_bimo_t(ipoint,2,b,i) * int2_grad1_u12_bimo_t(ipoint,2,i,j) & + + int2_grad1_u12_bimo_t(ipoint,3,b,i) * int2_grad1_u12_bimo_t(ipoint,3,i,j) ) + + tmp_4(ipoint,1,b) -= loc_3 * ( int2_grad1_u12_bimo_t(ipoint,1,i,j) * int2_grad1_u12_bimo_t(ipoint,1,j,b) & + + int2_grad1_u12_bimo_t(ipoint,2,i,j) * int2_grad1_u12_bimo_t(ipoint,2,j,b) & + + int2_grad1_u12_bimo_t(ipoint,3,i,j) * int2_grad1_u12_bimo_t(ipoint,3,j,b) ) + + loc_1 = final_weight_at_r_vector(ipoint) * mos_l_in_r_array_transp(ipoint,i) + loc_3 = mos_r_in_r_array_transp(ipoint,j) + + tmp_3(ipoint,8,b) -= loc_1 * ( int2_grad1_u12_bimo_t(ipoint,1,b,j) * int2_grad1_u12_bimo_t(ipoint,1,j,i) & + + int2_grad1_u12_bimo_t(ipoint,2,b,j) * int2_grad1_u12_bimo_t(ipoint,2,j,i) & + + int2_grad1_u12_bimo_t(ipoint,3,b,j) * int2_grad1_u12_bimo_t(ipoint,3,j,i) ) + + tmp_4(ipoint,1,b) -= loc_3 * ( int2_grad1_u12_bimo_t(ipoint,1,j,i) * int2_grad1_u12_bimo_t(ipoint,1,i,b) & + + int2_grad1_u12_bimo_t(ipoint,2,j,i) * int2_grad1_u12_bimo_t(ipoint,2,i,b) & + + int2_grad1_u12_bimo_t(ipoint,3,j,i) * int2_grad1_u12_bimo_t(ipoint,3,i,b) ) + enddo + enddo + enddo + + do i = elec_beta_num+1, elec_alpha_num + do j = elec_beta_num+1, elec_alpha_num + do ipoint = 1, n_points_final_grid + + loc_1 = final_weight_at_r_vector(ipoint) * mos_l_in_r_array_transp(ipoint,j) + loc_2 = 0.5d0 * mos_r_in_r_array_transp(ipoint,b) + loc_3 = mos_r_in_r_array_transp(ipoint,i) + + tmp_3(ipoint,8,b) -= loc_1 * ( int2_grad1_u12_bimo_t(ipoint,1,b,i) * int2_grad1_u12_bimo_t(ipoint,1,i,j) & + + int2_grad1_u12_bimo_t(ipoint,2,b,i) * int2_grad1_u12_bimo_t(ipoint,2,i,j) & + + int2_grad1_u12_bimo_t(ipoint,3,b,i) * int2_grad1_u12_bimo_t(ipoint,3,i,j) ) + + tmp_4(ipoint,1,b) -= loc_3 * ( int2_grad1_u12_bimo_t(ipoint,1,i,j) * int2_grad1_u12_bimo_t(ipoint,1,j,b) & + + int2_grad1_u12_bimo_t(ipoint,2,i,j) * int2_grad1_u12_bimo_t(ipoint,2,j,b) & + + int2_grad1_u12_bimo_t(ipoint,3,i,j) * int2_grad1_u12_bimo_t(ipoint,3,j,b) ) + enddo + enddo + enddo + enddo + !$OMP END DO + !$OMP END PARALLEL + + ! --- + + call dgemm( 'T', 'N', mo_num, mo_num, 8*n_points_final_grid, 1.d0 & + , tmp_3(1,1,1), 8*n_points_final_grid & + , tmp_4(1,1,1), 8*n_points_final_grid & + , 1.d0, fock_3e_uhf_mo_a_os(1,1), mo_num) + + deallocate(tmp_3, tmp_4) + deallocate(Jkappa, Okappa) + + !call wall_time(tf) + !print *, ' Wall time for fock_3e_uhf_mo_a_os and fock_3e_uhf_mo_b_os =', tf - ti + +END_PROVIDER + +! --- + diff --git a/plugins/local/tc_scf/fock_3e_bi_ortho_uhf.irp.f b/plugins/local/tc_scf/fock_3e_bi_ortho_uhf.irp.f new file mode 100644 index 00000000..63a1e162 --- /dev/null +++ b/plugins/local/tc_scf/fock_3e_bi_ortho_uhf.irp.f @@ -0,0 +1,77 @@ + +! --- + +BEGIN_PROVIDER [double precision, fock_3e_uhf_mo_a, (mo_num, mo_num)] + + BEGIN_DOC + ! + ! Fock matrix alpha from three-electron terms + ! + ! WARNING :: non hermitian if bi-ortho MOS used + ! + END_DOC + + implicit none + double precision :: ti, tf + + PROVIDE mo_l_coef mo_r_coef + + !print *, ' Providing fock_3e_uhf_mo_a ...' + !call wall_time(ti) + + ! CLOSED-SHELL PART + PROVIDE fock_3e_uhf_mo_cs + fock_3e_uhf_mo_a = fock_3e_uhf_mo_cs + + if(elec_alpha_num .ne. elec_beta_num) then + + ! OPEN-SHELL PART + PROVIDE fock_3e_uhf_mo_a_os + + fock_3e_uhf_mo_a += fock_3e_uhf_mo_a_os + endif + + !call wall_time(tf) + !print *, ' Wall time for fock_3e_uhf_mo_a =', tf - ti + +END_PROVIDER + +! --- + +BEGIN_PROVIDER [double precision, fock_3e_uhf_mo_b, (mo_num, mo_num)] + + BEGIN_DOC + ! + ! Fock matrix beta from three-electron terms + ! + ! WARNING :: non hermitian if bi-ortho MOS used + ! + END_DOC + + implicit none + double precision :: ti, tf + + PROVIDE mo_l_coef mo_r_coef + + !print *, ' Providing and fock_3e_uhf_mo_b ...' + !call wall_time(ti) + + ! CLOSED-SHELL PART + PROVIDE fock_3e_uhf_mo_cs + fock_3e_uhf_mo_b = fock_3e_uhf_mo_cs + + if(elec_alpha_num .ne. elec_beta_num) then + + ! OPEN-SHELL PART + PROVIDE fock_3e_uhf_mo_b_os + + fock_3e_uhf_mo_b += fock_3e_uhf_mo_b_os + endif + + !call wall_time(tf) + !print *, ' Wall time for fock_3e_uhf_mo_b =', tf - ti + +END_PROVIDER + +! --- + diff --git a/src/tc_scf/fock_3e_bi_ortho_uhf.irp.f b/plugins/local/tc_scf/fock_3e_bi_ortho_uhf_old.irp.f similarity index 91% rename from src/tc_scf/fock_3e_bi_ortho_uhf.irp.f rename to plugins/local/tc_scf/fock_3e_bi_ortho_uhf_old.irp.f index 3e624941..3bf6bd85 100644 --- a/src/tc_scf/fock_3e_bi_ortho_uhf.irp.f +++ b/plugins/local/tc_scf/fock_3e_bi_ortho_uhf_old.irp.f @@ -1,7 +1,7 @@ ! --- -BEGIN_PROVIDER [double precision, fock_3e_uhf_mo_cs, (mo_num, mo_num)] +BEGIN_PROVIDER [double precision, fock_3e_uhf_mo_cs_old, (mo_num, mo_num)] implicit none integer :: a, b, i, j @@ -12,14 +12,14 @@ BEGIN_PROVIDER [double precision, fock_3e_uhf_mo_cs, (mo_num, mo_num)] PROVIDE mo_l_coef mo_r_coef call give_integrals_3_body_bi_ort(1, 1, 1, 1, 1, 1, I_bij_aij) - !print *, ' PROVIDING fock_3e_uhf_mo_cs ...' + !print *, ' PROVIDING fock_3e_uhf_mo_cs_old ...' !call wall_time(ti) - fock_3e_uhf_mo_cs = 0.d0 + fock_3e_uhf_mo_cs_old = 0.d0 !$OMP PARALLEL DEFAULT (NONE) & !$OMP PRIVATE (a, b, i, j, I_bij_aij, I_bij_ija, I_bij_jai, I_bij_aji, I_bij_iaj, I_bij_jia, tmp) & - !$OMP SHARED (mo_num, elec_beta_num, fock_3e_uhf_mo_cs) + !$OMP SHARED (mo_num, elec_beta_num, fock_3e_uhf_mo_cs_old) allocate(tmp(mo_num,mo_num)) tmp = 0.d0 @@ -54,7 +54,7 @@ BEGIN_PROVIDER [double precision, fock_3e_uhf_mo_cs, (mo_num, mo_num)] !$OMP CRITICAL do a = 1, mo_num do b = 1, mo_num - fock_3e_uhf_mo_cs(b,a) += tmp(b,a) + fock_3e_uhf_mo_cs_old(b,a) += tmp(b,a) enddo enddo !$OMP END CRITICAL @@ -63,13 +63,13 @@ BEGIN_PROVIDER [double precision, fock_3e_uhf_mo_cs, (mo_num, mo_num)] !$OMP END PARALLEL !call wall_time(tf) - !print *, ' total Wall time for fock_3e_uhf_mo_cs =', tf - ti + !print *, ' total Wall time for fock_3e_uhf_mo_cs_old =', tf - ti END_PROVIDER ! --- -BEGIN_PROVIDER [double precision, fock_3e_uhf_mo_a, (mo_num, mo_num)] +BEGIN_PROVIDER [double precision, fock_3e_uhf_mo_a_old, (mo_num, mo_num)] BEGIN_DOC ! @@ -88,17 +88,18 @@ BEGIN_PROVIDER [double precision, fock_3e_uhf_mo_a, (mo_num, mo_num)] PROVIDE mo_l_coef mo_r_coef PROVIDE fock_3e_uhf_mo_cs - !print *, ' Providing fock_3e_uhf_mo_a ...' + !print *, ' Providing fock_3e_uhf_mo_a_old ...' !call wall_time(ti) o = elec_beta_num + 1 call give_integrals_3_body_bi_ort(1, 1, 1, 1, 1, 1, I_bij_aij) - fock_3e_uhf_mo_a = fock_3e_uhf_mo_cs + PROVIDE fock_3e_uhf_mo_cs_old + fock_3e_uhf_mo_a_old = fock_3e_uhf_mo_cs_old !$OMP PARALLEL DEFAULT (NONE) & !$OMP PRIVATE (a, b, i, j, I_bij_aij, I_bij_ija, I_bij_jai, I_bij_aji, I_bij_iaj, I_bij_jia, tmp) & - !$OMP SHARED (mo_num, o, elec_alpha_num, elec_beta_num, fock_3e_uhf_mo_a) + !$OMP SHARED (mo_num, o, elec_alpha_num, elec_beta_num, fock_3e_uhf_mo_a_old) allocate(tmp(mo_num,mo_num)) tmp = 0.d0 @@ -182,7 +183,7 @@ BEGIN_PROVIDER [double precision, fock_3e_uhf_mo_a, (mo_num, mo_num)] !$OMP CRITICAL do a = 1, mo_num do b = 1, mo_num - fock_3e_uhf_mo_a(b,a) += tmp(b,a) + fock_3e_uhf_mo_a_old(b,a) += tmp(b,a) enddo enddo !$OMP END CRITICAL @@ -191,18 +192,20 @@ BEGIN_PROVIDER [double precision, fock_3e_uhf_mo_a, (mo_num, mo_num)] !$OMP END PARALLEL !call wall_time(tf) - !print *, ' Wall time for fock_3e_uhf_mo_a =', tf - ti + !print *, ' Wall time for fock_3e_uhf_mo_a_old =', tf - ti END_PROVIDER ! --- -BEGIN_PROVIDER [double precision, fock_3e_uhf_mo_b, (mo_num, mo_num)] +BEGIN_PROVIDER [double precision, fock_3e_uhf_mo_b_old, (mo_num, mo_num)] BEGIN_DOC + ! ! BETA part of the Fock matrix from three-electron terms ! ! WARNING :: non hermitian if bi-ortho MOS used + ! END_DOC implicit none @@ -213,17 +216,18 @@ BEGIN_PROVIDER [double precision, fock_3e_uhf_mo_b, (mo_num, mo_num)] PROVIDE mo_l_coef mo_r_coef - !print *, ' PROVIDING fock_3e_uhf_mo_b ...' + !print *, ' PROVIDING fock_3e_uhf_mo_b_old ...' !call wall_time(ti) o = elec_beta_num + 1 call give_integrals_3_body_bi_ort(1, 1, 1, 1, 1, 1, I_bij_aij) - fock_3e_uhf_mo_b = fock_3e_uhf_mo_cs + PROVIDE fock_3e_uhf_mo_cs_old + fock_3e_uhf_mo_b_old = fock_3e_uhf_mo_cs_old !$OMP PARALLEL DEFAULT (NONE) & !$OMP PRIVATE (a, b, i, j, I_bij_aij, I_bij_ija, I_bij_jai, I_bij_aji, I_bij_iaj, I_bij_jia, tmp) & - !$OMP SHARED (mo_num, o, elec_alpha_num, elec_beta_num, fock_3e_uhf_mo_b) + !$OMP SHARED (mo_num, o, elec_alpha_num, elec_beta_num, fock_3e_uhf_mo_b_old) allocate(tmp(mo_num,mo_num)) tmp = 0.d0 @@ -297,7 +301,7 @@ BEGIN_PROVIDER [double precision, fock_3e_uhf_mo_b, (mo_num, mo_num)] !$OMP CRITICAL do a = 1, mo_num do b = 1, mo_num - fock_3e_uhf_mo_b(b,a) += tmp(b,a) + fock_3e_uhf_mo_b_old(b,a) += tmp(b,a) enddo enddo !$OMP END CRITICAL @@ -306,7 +310,7 @@ BEGIN_PROVIDER [double precision, fock_3e_uhf_mo_b, (mo_num, mo_num)] !$OMP END PARALLEL !call wall_time(tf) - !print *, ' total Wall time for fock_3e_uhf_mo_b =', tf - ti + !print *, ' total Wall time for fock_3e_uhf_mo_b_old =', tf - ti END_PROVIDER @@ -333,8 +337,8 @@ BEGIN_PROVIDER [double precision, fock_3e_uhf_ao_a, (ao_num, ao_num)] double precision :: ti, tf double precision, allocatable :: f_tmp(:,:) - print *, ' PROVIDING fock_3e_uhf_ao_a ...' - call wall_time(ti) + !print *, ' PROVIDING fock_3e_uhf_ao_a ...' + !call wall_time(ti) fock_3e_uhf_ao_a = 0.d0 @@ -391,8 +395,8 @@ BEGIN_PROVIDER [double precision, fock_3e_uhf_ao_a, (ao_num, ao_num)] deallocate(f_tmp) !$OMP END PARALLEL - call wall_time(tf) - print *, ' total Wall time for fock_3e_uhf_ao_a =', tf - ti + !call wall_time(tf) + !print *, ' total Wall time for fock_3e_uhf_ao_a =', tf - ti END_PROVIDER @@ -419,8 +423,8 @@ BEGIN_PROVIDER [double precision, fock_3e_uhf_ao_b, (ao_num, ao_num)] double precision :: ti, tf double precision, allocatable :: f_tmp(:,:) - print *, ' PROVIDING fock_3e_uhf_ao_b ...' - call wall_time(ti) + !print *, ' PROVIDING fock_3e_uhf_ao_b ...' + !call wall_time(ti) fock_3e_uhf_ao_b = 0.d0 @@ -477,8 +481,8 @@ BEGIN_PROVIDER [double precision, fock_3e_uhf_ao_b, (ao_num, ao_num)] deallocate(f_tmp) !$OMP END PARALLEL - call wall_time(tf) - print *, ' total Wall time for fock_3e_uhf_ao_b =', tf - ti + !call wall_time(tf) + !print *, ' total Wall time for fock_3e_uhf_ao_b =', tf - ti END_PROVIDER diff --git a/src/tc_scf/fock_hermit.irp.f b/plugins/local/tc_scf/fock_hermit.irp.f similarity index 100% rename from src/tc_scf/fock_hermit.irp.f rename to plugins/local/tc_scf/fock_hermit.irp.f diff --git a/src/tc_scf/fock_tc.irp.f b/plugins/local/tc_scf/fock_tc.irp.f similarity index 91% rename from src/tc_scf/fock_tc.irp.f rename to plugins/local/tc_scf/fock_tc.irp.f index f4553f3e..282f9873 100644 --- a/src/tc_scf/fock_tc.irp.f +++ b/plugins/local/tc_scf/fock_tc.irp.f @@ -190,30 +190,14 @@ BEGIN_PROVIDER [ double precision, Fock_matrix_tc_mo_alpha, (mo_num, mo_num) ] if(bi_ortho) then - !allocate(tmp(ao_num,ao_num)) - !tmp = Fock_matrix_tc_ao_alpha - !if(three_body_h_tc) then - ! tmp += fock_3e_uhf_ao_a - !endif - !call ao_to_mo_bi_ortho(tmp, size(tmp, 1), Fock_matrix_tc_mo_alpha, size(Fock_matrix_tc_mo_alpha, 1)) - !deallocate(tmp) - PROVIDE mo_l_coef mo_r_coef - !call wall_time(tt0) call ao_to_mo_bi_ortho( Fock_matrix_tc_ao_alpha, size(Fock_matrix_tc_ao_alpha, 1) & , Fock_matrix_tc_mo_alpha, size(Fock_matrix_tc_mo_alpha, 1) ) - !call wall_time(tt1) - !print*, ' 2-e term:', tt1-tt0 if(three_body_h_tc) then - !call wall_time(tt0) - PROVIDE fock_a_tot_3e_bi_orth - Fock_matrix_tc_mo_alpha += fock_a_tot_3e_bi_orth -! PROVIDE fock_3e_uhf_mo_a -! Fock_matrix_tc_mo_alpha += fock_3e_uhf_mo_a - !call wall_time(tt1) - !print*, ' 3-e term:', tt1-tt0 + PROVIDE fock_3e_uhf_mo_a + Fock_matrix_tc_mo_alpha += fock_3e_uhf_mo_a endif else @@ -243,11 +227,10 @@ BEGIN_PROVIDER [ double precision, Fock_matrix_tc_mo_beta, (mo_num,mo_num) ] call ao_to_mo_bi_ortho( Fock_matrix_tc_ao_beta, size(Fock_matrix_tc_ao_beta, 1) & , Fock_matrix_tc_mo_beta, size(Fock_matrix_tc_mo_beta, 1) ) + if(three_body_h_tc) then - PROVIDE fock_b_tot_3e_bi_orth - Fock_matrix_tc_mo_beta += fock_b_tot_3e_bi_orth -! PROVIDE fock_3e_uhf_mo_b -! Fock_matrix_tc_mo_beta += fock_3e_uhf_mo_b + PROVIDE fock_3e_uhf_mo_b + Fock_matrix_tc_mo_beta += fock_3e_uhf_mo_b endif else diff --git a/src/tc_scf/fock_tc_mo_tot.irp.f b/plugins/local/tc_scf/fock_tc_mo_tot.irp.f similarity index 100% rename from src/tc_scf/fock_tc_mo_tot.irp.f rename to plugins/local/tc_scf/fock_tc_mo_tot.irp.f diff --git a/src/tc_scf/fock_three_bi_ortho.irp.f b/plugins/local/tc_scf/fock_three_bi_ortho.irp.f similarity index 99% rename from src/tc_scf/fock_three_bi_ortho.irp.f rename to plugins/local/tc_scf/fock_three_bi_ortho.irp.f index 5d2f199c..8475c387 100644 --- a/src/tc_scf/fock_three_bi_ortho.irp.f +++ b/plugins/local/tc_scf/fock_three_bi_ortho.irp.f @@ -34,7 +34,7 @@ BEGIN_PROVIDER [double precision, fock_a_tot_3e_bi_orth, (mo_num, mo_num)] enddo !call wall_time(t1) - !print*, ' Wall time for fock_a_tot_3e_bi_orth =', t1-t0 + !print*, ' Wall time for fock_a_tot_3e_bi_orth =', t1 - t0 END_PROVIDER diff --git a/plugins/local/tc_scf/fock_three_hermit.irp.f b/plugins/local/tc_scf/fock_three_hermit.irp.f new file mode 100644 index 00000000..00d47fae --- /dev/null +++ b/plugins/local/tc_scf/fock_three_hermit.irp.f @@ -0,0 +1,771 @@ + +! --- + +BEGIN_PROVIDER [ double precision, fock_3_mat, (mo_num, mo_num)] + + implicit none + integer :: i,j + double precision :: contrib + + fock_3_mat = 0.d0 + if(.not.bi_ortho .and. three_body_h_tc) then + + call give_fock_ia_three_e_total(1, 1, contrib) + !! !$OMP PARALLEL & + !! !$OMP DEFAULT (NONE) & + !! !$OMP PRIVATE (i,j,m,integral) & + !! !$OMP SHARED (mo_num,three_body_3_index) + !! !$OMP DO SCHEDULE (guided) COLLAPSE(3) + do i = 1, mo_num + do j = 1, mo_num + call give_fock_ia_three_e_total(j,i,contrib) + fock_3_mat(j,i) = -contrib + enddo + enddo + !else if(bi_ortho.and.three_body_h_tc) then + !! !$OMP END DO + !! !$OMP END PARALLEL + !! do i = 1, mo_num + !! do j = 1, i-1 + !! mat_three(j,i) = mat_three(i,j) + !! enddo + !! enddo + endif + +END_PROVIDER + + +subroutine give_fock_ia_three_e_total(i,a,contrib) + implicit none + BEGIN_DOC +! contrib is the TOTAL (same spins / opposite spins) contribution from the three body term to the Fock operator +! + END_DOC + integer, intent(in) :: i,a + double precision, intent(out) :: contrib + double precision :: int_1, int_2, int_3 + double precision :: mos_i, mos_a, w_ia + double precision :: mos_ia, weight + + integer :: mm, ipoint,k,l + + int_1 = 0.d0 + int_2 = 0.d0 + int_3 = 0.d0 + do mm = 1, 3 + do ipoint = 1, n_points_final_grid + weight = final_weight_at_r_vector(ipoint) + mos_i = mos_in_r_array_transp(ipoint,i) + mos_a = mos_in_r_array_transp(ipoint,a) + mos_ia = mos_a * mos_i + w_ia = x_W_ij_erf_rk(ipoint,mm,i,a) + + int_1 += weight * fock_3_w_kk_sum(ipoint,mm) * (4.d0 * fock_3_rho_beta(ipoint) * w_ia & + + 2.0d0 * mos_ia * fock_3_w_kk_sum(ipoint,mm) & + - 2.0d0 * fock_3_w_ki_mos_k(ipoint,mm,i) * mos_a & + - 2.0d0 * fock_3_w_ki_mos_k(ipoint,mm,a) * mos_i ) + int_2 += weight * (-1.d0) * ( 2.0d0 * fock_3_w_kl_mo_k_mo_l(ipoint,mm) * w_ia & + + 2.0d0 * fock_3_rho_beta(ipoint) * fock_3_w_ki_wk_a(ipoint,mm,i,a) & + + 1.0d0 * mos_ia * fock_3_trace_w_tilde(ipoint,mm) ) + + int_3 += weight * 1.d0 * (fock_3_w_kl_wla_phi_k(ipoint,mm,i) * mos_a + fock_3_w_kl_wla_phi_k(ipoint,mm,a) * mos_i & + +fock_3_w_ki_mos_k(ipoint,mm,i) * fock_3_w_ki_mos_k(ipoint,mm,a) ) + enddo + enddo + contrib = int_1 + int_2 + int_3 + +end + +! --- + +BEGIN_PROVIDER [double precision, diag_three_elem_hf] + + implicit none + integer :: i, j, k, ipoint, mm + double precision :: contrib, weight, four_third, one_third, two_third, exchange_int_231 + double precision :: integral_aaa, hthree, integral_aab, integral_abb, integral_bbb + double precision, allocatable :: tmp(:) + double precision, allocatable :: tmp_L(:,:), tmp_R(:,:) + double precision, allocatable :: tmp_M(:,:), tmp_S(:), tmp_O(:), tmp_J(:,:) + double precision, allocatable :: tmp_M_priv(:,:), tmp_S_priv(:), tmp_O_priv(:), tmp_J_priv(:,:) + + PROVIDE mo_l_coef mo_r_coef + + !print *, ' providing diag_three_elem_hf' + + if(.not. three_body_h_tc) then + + if(noL_standard) then + PROVIDE noL_0e + diag_three_elem_hf = noL_0e + else + diag_three_elem_hf = 0.d0 + endif + + else + + if(.not. bi_ortho) then + + ! --- + + one_third = 1.d0/3.d0 + two_third = 2.d0/3.d0 + four_third = 4.d0/3.d0 + diag_three_elem_hf = 0.d0 + do i = 1, elec_beta_num + do j = 1, elec_beta_num + do k = 1, elec_beta_num + call give_integrals_3_body(k, j, i, j, i, k, exchange_int_231) + diag_three_elem_hf += two_third * exchange_int_231 + enddo + enddo + enddo + do mm = 1, 3 + do ipoint = 1, n_points_final_grid + weight = final_weight_at_r_vector(ipoint) + contrib = 3.d0 * fock_3_w_kk_sum(ipoint,mm) * fock_3_rho_beta(ipoint) * fock_3_w_kk_sum(ipoint,mm) & + - 2.d0 * fock_3_w_kl_mo_k_mo_l(ipoint,mm) * fock_3_w_kk_sum(ipoint,mm) & + - 1.d0 * fock_3_rho_beta(ipoint) * fock_3_w_kl_w_kl(ipoint,mm) + contrib *= four_third + contrib += -two_third * fock_3_rho_beta(ipoint) * fock_3_w_kl_w_kl(ipoint,mm) & + -four_third * fock_3_w_kk_sum(ipoint,mm) * fock_3_w_kl_mo_k_mo_l(ipoint,mm) + diag_three_elem_hf += weight * contrib + enddo + enddo + + diag_three_elem_hf = - diag_three_elem_hf + + ! --- + + else + + ! ------------ + ! SLOW VERSION + ! ------------ + + !call give_aaa_contrib(integral_aaa) + !call give_aab_contrib(integral_aab) + !call give_abb_contrib(integral_abb) + !call give_bbb_contrib(integral_bbb) + !diag_three_elem_hf = integral_aaa + integral_aab + integral_abb + integral_bbb + + ! ------------ + ! ------------ + + PROVIDE int2_grad1_u12_bimo_t + PROVIDE mos_l_in_r_array_transp + PROVIDE mos_r_in_r_array_transp + + if(elec_alpha_num .eq. elec_beta_num) then + + allocate(tmp(elec_beta_num)) + allocate(tmp_L(n_points_final_grid,3), tmp_R(n_points_final_grid,3)) + + !$OMP PARALLEL & + !$OMP DEFAULT(NONE) & + !$OMP PRIVATE(j, i, ipoint, tmp_L, tmp_R) & + !$OMP SHARED(elec_beta_num, n_points_final_grid, & + !$OMP mos_l_in_r_array_transp, mos_r_in_r_array_transp, & + !$OMP int2_grad1_u12_bimo_t, tmp, final_weight_at_r_vector) + + !$OMP DO + do j = 1, elec_beta_num + + tmp_L = 0.d0 + tmp_R = 0.d0 + do i = 1, elec_beta_num + do ipoint = 1, n_points_final_grid + + tmp_L(ipoint,1) = tmp_L(ipoint,1) + int2_grad1_u12_bimo_t(ipoint,1,j,i) * mos_l_in_r_array_transp(ipoint,i) + tmp_L(ipoint,2) = tmp_L(ipoint,2) + int2_grad1_u12_bimo_t(ipoint,2,j,i) * mos_l_in_r_array_transp(ipoint,i) + tmp_L(ipoint,3) = tmp_L(ipoint,3) + int2_grad1_u12_bimo_t(ipoint,3,j,i) * mos_l_in_r_array_transp(ipoint,i) + + tmp_R(ipoint,1) = tmp_R(ipoint,1) + int2_grad1_u12_bimo_t(ipoint,1,i,j) * mos_r_in_r_array_transp(ipoint,i) + tmp_R(ipoint,2) = tmp_R(ipoint,2) + int2_grad1_u12_bimo_t(ipoint,2,i,j) * mos_r_in_r_array_transp(ipoint,i) + tmp_R(ipoint,3) = tmp_R(ipoint,3) + int2_grad1_u12_bimo_t(ipoint,3,i,j) * mos_r_in_r_array_transp(ipoint,i) + enddo + enddo + + tmp(j) = 0.d0 + do ipoint = 1, n_points_final_grid + tmp(j) = tmp(j) + final_weight_at_r_vector(ipoint) * (tmp_L(ipoint,1)*tmp_R(ipoint,1) + tmp_L(ipoint,2)*tmp_R(ipoint,2) + tmp_L(ipoint,3)*tmp_R(ipoint,3)) + enddo + enddo ! j + !$OMP END DO + !$OMP END PARALLEL + + diag_three_elem_hf = -2.d0 * sum(tmp) + + deallocate(tmp) + deallocate(tmp_L, tmp_R) + + ! --- + + allocate(tmp_O(n_points_final_grid), tmp_J(n_points_final_grid,3)) + tmp_O = 0.d0 + tmp_J = 0.d0 + + !$OMP PARALLEL & + !$OMP DEFAULT(NONE) & + !$OMP PRIVATE(i, ipoint, tmp_O_priv, tmp_J_priv) & + !$OMP SHARED(elec_beta_num, n_points_final_grid, & + !$OMP mos_l_in_r_array_transp, mos_r_in_r_array_transp, & + !$OMP int2_grad1_u12_bimo_t, tmp_O, tmp_J) + + allocate(tmp_O_priv(n_points_final_grid), tmp_J_priv(n_points_final_grid,3)) + tmp_O_priv = 0.d0 + tmp_J_priv = 0.d0 + + !$OMP DO + do i = 1, elec_beta_num + do ipoint = 1, n_points_final_grid + tmp_O_priv(ipoint) = tmp_O_priv(ipoint) + mos_l_in_r_array_transp(ipoint,i) * mos_r_in_r_array_transp(ipoint,i) + tmp_J_priv(ipoint,1) = tmp_J_priv(ipoint,1) + int2_grad1_u12_bimo_t(ipoint,1,i,i) + tmp_J_priv(ipoint,2) = tmp_J_priv(ipoint,2) + int2_grad1_u12_bimo_t(ipoint,2,i,i) + tmp_J_priv(ipoint,3) = tmp_J_priv(ipoint,3) + int2_grad1_u12_bimo_t(ipoint,3,i,i) + enddo + enddo + !$OMP END DO NOWAIT + + !$OMP CRITICAL + tmp_O = tmp_O + tmp_O_priv + tmp_J = tmp_J + tmp_J_priv + !$OMP END CRITICAL + + deallocate(tmp_O_priv, tmp_J_priv) + !$OMP END PARALLEL + + allocate(tmp_M(n_points_final_grid,3), tmp_S(n_points_final_grid)) + tmp_M = 0.d0 + tmp_S = 0.d0 + + !$OMP PARALLEL & + !$OMP DEFAULT(NONE) & + !$OMP PRIVATE(i, j, ipoint, tmp_M_priv, tmp_S_priv) & + !$OMP SHARED(elec_beta_num, n_points_final_grid, & + !$OMP mos_l_in_r_array_transp, mos_r_in_r_array_transp, & + !$OMP int2_grad1_u12_bimo_t, tmp_M, tmp_S) + + allocate(tmp_M_priv(n_points_final_grid,3), tmp_S_priv(n_points_final_grid)) + tmp_M_priv = 0.d0 + tmp_S_priv = 0.d0 + + !$OMP DO COLLAPSE(2) + do i = 1, elec_beta_num + do j = 1, elec_beta_num + do ipoint = 1, n_points_final_grid + + tmp_M_priv(ipoint,1) = tmp_M_priv(ipoint,1) + int2_grad1_u12_bimo_t(ipoint,1,j,i) * mos_l_in_r_array_transp(ipoint,i) * mos_r_in_r_array_transp(ipoint,j) + tmp_M_priv(ipoint,2) = tmp_M_priv(ipoint,2) + int2_grad1_u12_bimo_t(ipoint,2,j,i) * mos_l_in_r_array_transp(ipoint,i) * mos_r_in_r_array_transp(ipoint,j) + tmp_M_priv(ipoint,3) = tmp_M_priv(ipoint,3) + int2_grad1_u12_bimo_t(ipoint,3,j,i) * mos_l_in_r_array_transp(ipoint,i) * mos_r_in_r_array_transp(ipoint,j) + + tmp_S_priv(ipoint) = tmp_S_priv(ipoint) + int2_grad1_u12_bimo_t(ipoint,1,i,j) * int2_grad1_u12_bimo_t(ipoint,1,j,i) & + + int2_grad1_u12_bimo_t(ipoint,2,i,j) * int2_grad1_u12_bimo_t(ipoint,2,j,i) & + + int2_grad1_u12_bimo_t(ipoint,3,i,j) * int2_grad1_u12_bimo_t(ipoint,3,j,i) + enddo + enddo + enddo + !$OMP END DO NOWAIT + + !$OMP CRITICAL + tmp_M = tmp_M + tmp_M_priv + tmp_S = tmp_S + tmp_S_priv + !$OMP END CRITICAL + + deallocate(tmp_M_priv, tmp_S_priv) + !$OMP END PARALLEL + + allocate(tmp(n_points_final_grid)) + + do ipoint = 1, n_points_final_grid + + tmp_S(ipoint) = 2.d0 * (tmp_J(ipoint,1)*tmp_J(ipoint,1) + tmp_J(ipoint,2)*tmp_J(ipoint,2) + tmp_J(ipoint,3)*tmp_J(ipoint,3)) - tmp_S(ipoint) + + tmp(ipoint) = final_weight_at_r_vector(ipoint) * ( tmp_O(ipoint) * tmp_S(ipoint) & + - 2.d0 * ( tmp_J(ipoint,1) * tmp_M(ipoint,1) & + + tmp_J(ipoint,2) * tmp_M(ipoint,2) & + + tmp_J(ipoint,3) * tmp_M(ipoint,3))) + enddo + + diag_three_elem_hf = diag_three_elem_hf -2.d0 * (sum(tmp)) + + deallocate(tmp) + + else + + allocate(tmp(elec_alpha_num)) + allocate(tmp_L(n_points_final_grid,3), tmp_R(n_points_final_grid,3)) + + !$OMP PARALLEL & + !$OMP DEFAULT(NONE) & + !$OMP PRIVATE(j, i, ipoint, tmp_L, tmp_R) & + !$OMP SHARED(elec_beta_num, elec_alpha_num, n_points_final_grid, & + !$OMP mos_l_in_r_array_transp, mos_r_in_r_array_transp, & + !$OMP int2_grad1_u12_bimo_t, tmp, final_weight_at_r_vector) + + !$OMP DO + do j = 1, elec_beta_num + + tmp_L = 0.d0 + tmp_R = 0.d0 + do i = elec_beta_num+1, elec_alpha_num + do ipoint = 1, n_points_final_grid + + tmp_L(ipoint,1) = tmp_L(ipoint,1) + 0.5d0 * int2_grad1_u12_bimo_t(ipoint,1,j,i) * mos_l_in_r_array_transp(ipoint,i) + tmp_L(ipoint,2) = tmp_L(ipoint,2) + 0.5d0 * int2_grad1_u12_bimo_t(ipoint,2,j,i) * mos_l_in_r_array_transp(ipoint,i) + tmp_L(ipoint,3) = tmp_L(ipoint,3) + 0.5d0 * int2_grad1_u12_bimo_t(ipoint,3,j,i) * mos_l_in_r_array_transp(ipoint,i) + + tmp_R(ipoint,1) = tmp_R(ipoint,1) + 0.5d0 * int2_grad1_u12_bimo_t(ipoint,1,i,j) * mos_r_in_r_array_transp(ipoint,i) + tmp_R(ipoint,2) = tmp_R(ipoint,2) + 0.5d0 * int2_grad1_u12_bimo_t(ipoint,2,i,j) * mos_r_in_r_array_transp(ipoint,i) + tmp_R(ipoint,3) = tmp_R(ipoint,3) + 0.5d0 * int2_grad1_u12_bimo_t(ipoint,3,i,j) * mos_r_in_r_array_transp(ipoint,i) + enddo + enddo + + tmp(j) = 0.d0 + do ipoint = 1, n_points_final_grid + tmp(j) = tmp(j) + final_weight_at_r_vector(ipoint) * (tmp_L(ipoint,1)*tmp_R(ipoint,1) + tmp_L(ipoint,2)*tmp_R(ipoint,2) + tmp_L(ipoint,3)*tmp_R(ipoint,3)) + enddo + + do i = 1, elec_beta_num + do ipoint = 1, n_points_final_grid + + tmp_L(ipoint,1) = tmp_L(ipoint,1) + int2_grad1_u12_bimo_t(ipoint,1,j,i) * mos_l_in_r_array_transp(ipoint,i) + tmp_L(ipoint,2) = tmp_L(ipoint,2) + int2_grad1_u12_bimo_t(ipoint,2,j,i) * mos_l_in_r_array_transp(ipoint,i) + tmp_L(ipoint,3) = tmp_L(ipoint,3) + int2_grad1_u12_bimo_t(ipoint,3,j,i) * mos_l_in_r_array_transp(ipoint,i) + + tmp_R(ipoint,1) = tmp_R(ipoint,1) + int2_grad1_u12_bimo_t(ipoint,1,i,j) * mos_r_in_r_array_transp(ipoint,i) + tmp_R(ipoint,2) = tmp_R(ipoint,2) + int2_grad1_u12_bimo_t(ipoint,2,i,j) * mos_r_in_r_array_transp(ipoint,i) + tmp_R(ipoint,3) = tmp_R(ipoint,3) + int2_grad1_u12_bimo_t(ipoint,3,i,j) * mos_r_in_r_array_transp(ipoint,i) + enddo + enddo + + do ipoint = 1, n_points_final_grid + tmp(j) = tmp(j) + final_weight_at_r_vector(ipoint) * (tmp_L(ipoint,1)*tmp_R(ipoint,1) + tmp_L(ipoint,2)*tmp_R(ipoint,2) + tmp_L(ipoint,3)*tmp_R(ipoint,3)) + enddo + enddo ! j + !$OMP END DO + !$OMP END PARALLEL + + ! --- + + !$OMP PARALLEL & + !$OMP DEFAULT(NONE) & + !$OMP PRIVATE(j, i, ipoint, tmp_L, tmp_R) & + !$OMP SHARED(elec_beta_num, elec_alpha_num, n_points_final_grid, & + !$OMP mos_l_in_r_array_transp, mos_r_in_r_array_transp, & + !$OMP int2_grad1_u12_bimo_t, tmp, final_weight_at_r_vector) + + !$OMP DO + do j = elec_beta_num+1, elec_alpha_num + + tmp_L = 0.d0 + tmp_R = 0.d0 + do i = 1, elec_alpha_num + do ipoint = 1, n_points_final_grid + tmp_L(ipoint,1) = tmp_L(ipoint,1) + int2_grad1_u12_bimo_t(ipoint,1,j,i) * mos_l_in_r_array_transp(ipoint,i) + tmp_L(ipoint,2) = tmp_L(ipoint,2) + int2_grad1_u12_bimo_t(ipoint,2,j,i) * mos_l_in_r_array_transp(ipoint,i) + tmp_L(ipoint,3) = tmp_L(ipoint,3) + int2_grad1_u12_bimo_t(ipoint,3,j,i) * mos_l_in_r_array_transp(ipoint,i) + + tmp_R(ipoint,1) = tmp_R(ipoint,1) + int2_grad1_u12_bimo_t(ipoint,1,i,j) * mos_r_in_r_array_transp(ipoint,i) + tmp_R(ipoint,2) = tmp_R(ipoint,2) + int2_grad1_u12_bimo_t(ipoint,2,i,j) * mos_r_in_r_array_transp(ipoint,i) + tmp_R(ipoint,3) = tmp_R(ipoint,3) + int2_grad1_u12_bimo_t(ipoint,3,i,j) * mos_r_in_r_array_transp(ipoint,i) + enddo + enddo + + tmp(j) = 0.d0 + do ipoint = 1, n_points_final_grid + tmp(j) = tmp(j) + 0.5d0 * final_weight_at_r_vector(ipoint) * (tmp_L(ipoint,1)*tmp_R(ipoint,1) + tmp_L(ipoint,2)*tmp_R(ipoint,2) + tmp_L(ipoint,3)*tmp_R(ipoint,3)) + enddo + enddo ! j + !$OMP END DO + !$OMP END PARALLEL + + diag_three_elem_hf = -2.d0 * sum(tmp) + + deallocate(tmp) + deallocate(tmp_L, tmp_R) + + ! --- + + allocate(tmp_O(n_points_final_grid), tmp_J(n_points_final_grid,3)) + tmp_O = 0.d0 + tmp_J = 0.d0 + + !$OMP PARALLEL & + !$OMP DEFAULT(NONE) & + !$OMP PRIVATE(i, ipoint, tmp_O_priv, tmp_J_priv) & + !$OMP SHARED(elec_beta_num, elec_alpha_num, n_points_final_grid, & + !$OMP mos_l_in_r_array_transp, mos_r_in_r_array_transp, & + !$OMP int2_grad1_u12_bimo_t, tmp_O, tmp_J) + + allocate(tmp_O_priv(n_points_final_grid), tmp_J_priv(n_points_final_grid,3)) + tmp_O_priv = 0.d0 + tmp_J_priv = 0.d0 + + !$OMP DO + do i = 1, elec_beta_num + do ipoint = 1, n_points_final_grid + tmp_O_priv(ipoint) = tmp_O_priv(ipoint) + mos_l_in_r_array_transp(ipoint,i) * mos_r_in_r_array_transp(ipoint,i) + tmp_J_priv(ipoint,1) = tmp_J_priv(ipoint,1) + int2_grad1_u12_bimo_t(ipoint,1,i,i) + tmp_J_priv(ipoint,2) = tmp_J_priv(ipoint,2) + int2_grad1_u12_bimo_t(ipoint,2,i,i) + tmp_J_priv(ipoint,3) = tmp_J_priv(ipoint,3) + int2_grad1_u12_bimo_t(ipoint,3,i,i) + enddo + enddo + !$OMP END DO NOWAIT + + !$OMP DO + do i = elec_beta_num+1, elec_alpha_num + do ipoint = 1, n_points_final_grid + tmp_O_priv(ipoint) = tmp_O_priv(ipoint) + 0.5d0 * mos_l_in_r_array_transp(ipoint,i) * mos_r_in_r_array_transp(ipoint,i) + tmp_J_priv(ipoint,1) = tmp_J_priv(ipoint,1) + 0.5d0 * int2_grad1_u12_bimo_t(ipoint,1,i,i) + tmp_J_priv(ipoint,2) = tmp_J_priv(ipoint,2) + 0.5d0 * int2_grad1_u12_bimo_t(ipoint,2,i,i) + tmp_J_priv(ipoint,3) = tmp_J_priv(ipoint,3) + 0.5d0 * int2_grad1_u12_bimo_t(ipoint,3,i,i) + enddo + enddo + !$OMP END DO NOWAIT + + !$OMP CRITICAL + tmp_O = tmp_O + tmp_O_priv + tmp_J = tmp_J + tmp_J_priv + !$OMP END CRITICAL + + deallocate(tmp_O_priv, tmp_J_priv) + !$OMP END PARALLEL + + ! --- + + allocate(tmp_M(n_points_final_grid,3), tmp_S(n_points_final_grid)) + tmp_M = 0.d0 + tmp_S = 0.d0 + + !$OMP PARALLEL & + !$OMP DEFAULT(NONE) & + !$OMP PRIVATE(i, j, ipoint, tmp_M_priv, tmp_S_priv) & + !$OMP SHARED(elec_beta_num, elec_alpha_num, n_points_final_grid, & + !$OMP mos_l_in_r_array_transp, mos_r_in_r_array_transp, & + !$OMP int2_grad1_u12_bimo_t, tmp_M, tmp_S) + + allocate(tmp_M_priv(n_points_final_grid,3), tmp_S_priv(n_points_final_grid)) + tmp_M_priv = 0.d0 + tmp_S_priv = 0.d0 + + !$OMP DO COLLAPSE(2) + do i = 1, elec_beta_num + do j = 1, elec_beta_num + do ipoint = 1, n_points_final_grid + + tmp_M_priv(ipoint,1) = tmp_M_priv(ipoint,1) + int2_grad1_u12_bimo_t(ipoint,1,j,i) * mos_l_in_r_array_transp(ipoint,i) * mos_r_in_r_array_transp(ipoint,j) + tmp_M_priv(ipoint,2) = tmp_M_priv(ipoint,2) + int2_grad1_u12_bimo_t(ipoint,2,j,i) * mos_l_in_r_array_transp(ipoint,i) * mos_r_in_r_array_transp(ipoint,j) + tmp_M_priv(ipoint,3) = tmp_M_priv(ipoint,3) + int2_grad1_u12_bimo_t(ipoint,3,j,i) * mos_l_in_r_array_transp(ipoint,i) * mos_r_in_r_array_transp(ipoint,j) + + tmp_S_priv(ipoint) = tmp_S_priv(ipoint) + int2_grad1_u12_bimo_t(ipoint,1,i,j) * int2_grad1_u12_bimo_t(ipoint,1,j,i) & + + int2_grad1_u12_bimo_t(ipoint,2,i,j) * int2_grad1_u12_bimo_t(ipoint,2,j,i) & + + int2_grad1_u12_bimo_t(ipoint,3,i,j) * int2_grad1_u12_bimo_t(ipoint,3,j,i) + enddo + enddo + enddo + !$OMP END DO NOWAIT + + !$OMP DO COLLAPSE(2) + do i = elec_beta_num+1, elec_alpha_num + do j = 1, elec_beta_num + do ipoint = 1, n_points_final_grid + + tmp_M_priv(ipoint,1) = tmp_M_priv(ipoint,1) + 0.5d0 * int2_grad1_u12_bimo_t(ipoint,1,j,i) * mos_l_in_r_array_transp(ipoint,i) * mos_r_in_r_array_transp(ipoint,j) + tmp_M_priv(ipoint,2) = tmp_M_priv(ipoint,2) + 0.5d0 * int2_grad1_u12_bimo_t(ipoint,2,j,i) * mos_l_in_r_array_transp(ipoint,i) * mos_r_in_r_array_transp(ipoint,j) + tmp_M_priv(ipoint,3) = tmp_M_priv(ipoint,3) + 0.5d0 * int2_grad1_u12_bimo_t(ipoint,3,j,i) * mos_l_in_r_array_transp(ipoint,i) * mos_r_in_r_array_transp(ipoint,j) + + tmp_M_priv(ipoint,1) = tmp_M_priv(ipoint,1) + 0.5d0 * int2_grad1_u12_bimo_t(ipoint,1,i,j) * mos_l_in_r_array_transp(ipoint,j) * mos_r_in_r_array_transp(ipoint,i) + tmp_M_priv(ipoint,2) = tmp_M_priv(ipoint,2) + 0.5d0 * int2_grad1_u12_bimo_t(ipoint,2,i,j) * mos_l_in_r_array_transp(ipoint,j) * mos_r_in_r_array_transp(ipoint,i) + tmp_M_priv(ipoint,3) = tmp_M_priv(ipoint,3) + 0.5d0 * int2_grad1_u12_bimo_t(ipoint,3,i,j) * mos_l_in_r_array_transp(ipoint,j) * mos_r_in_r_array_transp(ipoint,i) + + tmp_S_priv(ipoint) = tmp_S_priv(ipoint) + int2_grad1_u12_bimo_t(ipoint,1,i,j) * int2_grad1_u12_bimo_t(ipoint,1,j,i) & + + int2_grad1_u12_bimo_t(ipoint,2,i,j) * int2_grad1_u12_bimo_t(ipoint,2,j,i) & + + int2_grad1_u12_bimo_t(ipoint,3,i,j) * int2_grad1_u12_bimo_t(ipoint,3,j,i) + enddo + enddo + enddo + !$OMP END DO NOWAIT + + !$OMP DO COLLAPSE(2) + do i = elec_beta_num+1, elec_alpha_num + do j = elec_beta_num+1, elec_alpha_num + do ipoint = 1, n_points_final_grid + + tmp_M_priv(ipoint,1) = tmp_M_priv(ipoint,1) + 0.5d0 * int2_grad1_u12_bimo_t(ipoint,1,j,i) * mos_l_in_r_array_transp(ipoint,i) * mos_r_in_r_array_transp(ipoint,j) + tmp_M_priv(ipoint,2) = tmp_M_priv(ipoint,2) + 0.5d0 * int2_grad1_u12_bimo_t(ipoint,2,j,i) * mos_l_in_r_array_transp(ipoint,i) * mos_r_in_r_array_transp(ipoint,j) + tmp_M_priv(ipoint,3) = tmp_M_priv(ipoint,3) + 0.5d0 * int2_grad1_u12_bimo_t(ipoint,3,j,i) * mos_l_in_r_array_transp(ipoint,i) * mos_r_in_r_array_transp(ipoint,j) + + tmp_S_priv(ipoint) = tmp_S_priv(ipoint) + 0.5d0 * int2_grad1_u12_bimo_t(ipoint,1,i,j) * int2_grad1_u12_bimo_t(ipoint,1,j,i) & + + 0.5d0 * int2_grad1_u12_bimo_t(ipoint,2,i,j) * int2_grad1_u12_bimo_t(ipoint,2,j,i) & + + 0.5d0 * int2_grad1_u12_bimo_t(ipoint,3,i,j) * int2_grad1_u12_bimo_t(ipoint,3,j,i) + enddo + enddo + enddo + !$OMP END DO NOWAIT + + !$OMP CRITICAL + tmp_M = tmp_M + tmp_M_priv + tmp_S = tmp_S + tmp_S_priv + !$OMP END CRITICAL + + deallocate(tmp_M_priv, tmp_S_priv) + !$OMP END PARALLEL + + allocate(tmp(n_points_final_grid)) + + do ipoint = 1, n_points_final_grid + + tmp_S(ipoint) = 2.d0 * (tmp_J(ipoint,1)*tmp_J(ipoint,1) + tmp_J(ipoint,2)*tmp_J(ipoint,2) + tmp_J(ipoint,3)*tmp_J(ipoint,3)) - tmp_S(ipoint) + + tmp(ipoint) = final_weight_at_r_vector(ipoint) * ( tmp_O(ipoint) * tmp_S(ipoint) & + - 2.d0 * ( tmp_J(ipoint,1) * tmp_M(ipoint,1) & + + tmp_J(ipoint,2) * tmp_M(ipoint,2) & + + tmp_J(ipoint,3) * tmp_M(ipoint,3))) + enddo + + diag_three_elem_hf = diag_three_elem_hf - 2.d0 * (sum(tmp)) + + deallocate(tmp) + + endif + + + endif + + endif + +END_PROVIDER + +! --- + +BEGIN_PROVIDER [ double precision, fock_3_mat_a_op_sh, (mo_num, mo_num)] + implicit none + integer :: h,p,i,j + double precision :: direct_int, exch_int, exchange_int_231, exchange_int_312 + double precision :: exchange_int_23, exchange_int_12, exchange_int_13 + + fock_3_mat_a_op_sh = 0.d0 + do h = 1, mo_num + do p = 1, mo_num + !F_a^{ab}(h,p) + do i = 1, elec_beta_num ! beta + do j = elec_beta_num+1, elec_alpha_num ! alpha + call give_integrals_3_body(h,j,i,p,j,i,direct_int) ! + call give_integrals_3_body(h,j,i,j,p,i,exch_int) + fock_3_mat_a_op_sh(h,p) -= direct_int - exch_int + enddo + enddo + !F_a^{aa}(h,p) + do i = 1, elec_beta_num ! alpha + do j = elec_beta_num+1, elec_alpha_num ! alpha + call give_integrals_3_body(h,j,i,p,j,i,direct_int) + call give_integrals_3_body(h,j,i,i,p,j,exchange_int_231) + call give_integrals_3_body(h,j,i,j,i,p,exchange_int_312) + call give_integrals_3_body(h,j,i,p,i,j,exchange_int_23) + call give_integrals_3_body(h,j,i,i,j,p,exchange_int_12) + call give_integrals_3_body(h,j,i,j,p,i,exchange_int_13) + fock_3_mat_a_op_sh(h,p) -= ( direct_int + exchange_int_231 + exchange_int_312 & + - exchange_int_23 & ! i <-> j + - exchange_int_12 & ! p <-> j + - exchange_int_13 )! p <-> i + enddo + enddo + enddo + enddo +! symmetrized +! do p = 1, elec_beta_num +! do h = elec_alpha_num +1, mo_num +! fock_3_mat_a_op_sh(h,p) = fock_3_mat_a_op_sh(p,h) +! enddo +! enddo + +! do h = elec_beta_num+1, elec_alpha_num +! do p = elec_alpha_num +1, mo_num +! !F_a^{bb}(h,p) +! do i = 1, elec_beta_num +! do j = i+1, elec_beta_num +! call give_integrals_3_body(h,j,i,p,j,i,direct_int) +! call give_integrals_3_body(h,j,i,p,i,j,exch_int) +! fock_3_mat_a_op_sh(h,p) -= direct_int - exch_int +! enddo +! enddo +! enddo +! enddo + +END_PROVIDER + +BEGIN_PROVIDER [ double precision, fock_3_mat_b_op_sh, (mo_num, mo_num)] + implicit none + integer :: h,p,i,j + double precision :: direct_int, exch_int + fock_3_mat_b_op_sh = 0.d0 + do h = 1, elec_beta_num + do p = elec_alpha_num +1, mo_num + !F_b^{aa}(h,p) + do i = 1, elec_beta_num + do j = elec_beta_num+1, elec_alpha_num + call give_integrals_3_body(h,j,i,p,j,i,direct_int) + call give_integrals_3_body(h,j,i,p,i,j,exch_int) + fock_3_mat_b_op_sh(h,p) += direct_int - exch_int + enddo + enddo + + !F_b^{ab}(h,p) + do i = elec_beta_num+1, elec_beta_num + do j = 1, elec_beta_num + call give_integrals_3_body(h,j,i,p,j,i,direct_int) + call give_integrals_3_body(h,j,i,j,p,i,exch_int) + fock_3_mat_b_op_sh(h,p) += direct_int - exch_int + enddo + enddo + + enddo + enddo + +END_PROVIDER + + +BEGIN_PROVIDER [ double precision, fock_3_w_kk_sum, (n_points_final_grid,3)] + implicit none + integer :: mm, ipoint,k + double precision :: w_kk + fock_3_w_kk_sum = 0.d0 + do k = 1, elec_beta_num + do mm = 1, 3 + do ipoint = 1, n_points_final_grid + w_kk = x_W_ij_erf_rk(ipoint,mm,k,k) + fock_3_w_kk_sum(ipoint,mm) += w_kk + enddo + enddo + enddo +END_PROVIDER + +BEGIN_PROVIDER [ double precision, fock_3_w_ki_mos_k, (n_points_final_grid,3,mo_num)] + implicit none + integer :: mm, ipoint,k,i + double precision :: w_ki, mo_k + fock_3_w_ki_mos_k = 0.d0 + do i = 1, mo_num + do k = 1, elec_beta_num + do mm = 1, 3 + do ipoint = 1, n_points_final_grid + w_ki = x_W_ij_erf_rk(ipoint,mm,k,i) + mo_k = mos_in_r_array(k,ipoint) + fock_3_w_ki_mos_k(ipoint,mm,i) += w_ki * mo_k + enddo + enddo + enddo + enddo + +END_PROVIDER + +BEGIN_PROVIDER [ double precision, fock_3_w_kl_w_kl, (n_points_final_grid,3)] + implicit none + integer :: k,j,ipoint,mm + double precision :: w_kj + fock_3_w_kl_w_kl = 0.d0 + do j = 1, elec_beta_num + do k = 1, elec_beta_num + do mm = 1, 3 + do ipoint = 1, n_points_final_grid + w_kj = x_W_ij_erf_rk(ipoint,mm,k,j) + fock_3_w_kl_w_kl(ipoint,mm) += w_kj * w_kj + enddo + enddo + enddo + enddo + + +END_PROVIDER + +BEGIN_PROVIDER [ double precision, fock_3_rho_beta, (n_points_final_grid)] + implicit none + integer :: ipoint,k + fock_3_rho_beta = 0.d0 + do ipoint = 1, n_points_final_grid + do k = 1, elec_beta_num + fock_3_rho_beta(ipoint) += mos_in_r_array(k,ipoint) * mos_in_r_array(k,ipoint) + enddo + enddo +END_PROVIDER + +BEGIN_PROVIDER [ double precision, fock_3_w_kl_mo_k_mo_l, (n_points_final_grid,3)] + implicit none + integer :: ipoint,k,l,mm + double precision :: mos_k, mos_l, w_kl + fock_3_w_kl_mo_k_mo_l = 0.d0 + do k = 1, elec_beta_num + do l = 1, elec_beta_num + do mm = 1, 3 + do ipoint = 1, n_points_final_grid + mos_k = mos_in_r_array_transp(ipoint,k) + mos_l = mos_in_r_array_transp(ipoint,l) + w_kl = x_W_ij_erf_rk(ipoint,mm,l,k) + fock_3_w_kl_mo_k_mo_l(ipoint,mm) += w_kl * mos_k * mos_l + enddo + enddo + enddo + enddo + +END_PROVIDER + +BEGIN_PROVIDER [ double precision, fock_3_w_ki_wk_a, (n_points_final_grid,3,mo_num, mo_num)] + implicit none + integer :: ipoint,i,a,k,mm + double precision :: w_ki,w_ka + fock_3_w_ki_wk_a = 0.d0 + do i = 1, mo_num + do a = 1, mo_num + do mm = 1, 3 + do ipoint = 1, n_points_final_grid + do k = 1, elec_beta_num + w_ki = x_W_ij_erf_rk(ipoint,mm,k,i) + w_ka = x_W_ij_erf_rk(ipoint,mm,k,a) + fock_3_w_ki_wk_a(ipoint,mm,a,i) += w_ki * w_ka + enddo + enddo + enddo + enddo + enddo +END_PROVIDER + +BEGIN_PROVIDER [ double precision, fock_3_trace_w_tilde, (n_points_final_grid,3)] + implicit none + integer :: ipoint,k,mm + fock_3_trace_w_tilde = 0.d0 + do k = 1, elec_beta_num + do mm = 1, 3 + do ipoint = 1, n_points_final_grid + fock_3_trace_w_tilde(ipoint,mm) += fock_3_w_ki_wk_a(ipoint,mm,k,k) + enddo + enddo + enddo + +END_PROVIDER + +BEGIN_PROVIDER [ double precision, fock_3_w_kl_wla_phi_k, (n_points_final_grid,3,mo_num)] + implicit none + integer :: ipoint,a,k,mm,l + double precision :: w_kl,w_la, mo_k + fock_3_w_kl_wla_phi_k = 0.d0 + do a = 1, mo_num + do k = 1, elec_beta_num + do l = 1, elec_beta_num + do mm = 1, 3 + do ipoint = 1, n_points_final_grid + w_kl = x_W_ij_erf_rk(ipoint,mm,l,k) + w_la = x_W_ij_erf_rk(ipoint,mm,l,a) + mo_k = mos_in_r_array_transp(ipoint,k) + fock_3_w_kl_wla_phi_k(ipoint,mm,a) += w_kl * w_la * mo_k + enddo + enddo + enddo + enddo + enddo +END_PROVIDER + + + + + diff --git a/src/tc_scf/fock_vartc.irp.f b/plugins/local/tc_scf/fock_vartc.irp.f similarity index 100% rename from src/tc_scf/fock_vartc.irp.f rename to plugins/local/tc_scf/fock_vartc.irp.f diff --git a/src/tc_scf/integrals_in_r_stuff.irp.f b/plugins/local/tc_scf/integrals_in_r_stuff.irp.f similarity index 100% rename from src/tc_scf/integrals_in_r_stuff.irp.f rename to plugins/local/tc_scf/integrals_in_r_stuff.irp.f diff --git a/src/tc_scf/minimize_tc_angles.irp.f b/plugins/local/tc_scf/minimize_tc_angles.irp.f similarity index 100% rename from src/tc_scf/minimize_tc_angles.irp.f rename to plugins/local/tc_scf/minimize_tc_angles.irp.f diff --git a/src/tc_scf/molden_lr_mos.irp.f b/plugins/local/tc_scf/molden_lr_mos.irp.f similarity index 100% rename from src/tc_scf/molden_lr_mos.irp.f rename to plugins/local/tc_scf/molden_lr_mos.irp.f diff --git a/src/tc_scf/print_fit_param.irp.f b/plugins/local/tc_scf/print_fit_param.irp.f similarity index 100% rename from src/tc_scf/print_fit_param.irp.f rename to plugins/local/tc_scf/print_fit_param.irp.f diff --git a/src/tc_scf/print_tcscf_energy.irp.f b/plugins/local/tc_scf/print_tcscf_energy.irp.f similarity index 100% rename from src/tc_scf/print_tcscf_energy.irp.f rename to plugins/local/tc_scf/print_tcscf_energy.irp.f diff --git a/src/tc_scf/rh_tcscf_diis.irp.f b/plugins/local/tc_scf/rh_tcscf_diis.irp.f similarity index 98% rename from src/tc_scf/rh_tcscf_diis.irp.f rename to plugins/local/tc_scf/rh_tcscf_diis.irp.f index 0504373c..12678500 100644 --- a/src/tc_scf/rh_tcscf_diis.irp.f +++ b/plugins/local/tc_scf/rh_tcscf_diis.irp.f @@ -71,10 +71,7 @@ subroutine rh_tcscf_diis() etc_tot = TC_HF_energy etc_1e = TC_HF_one_e_energy etc_2e = TC_HF_two_e_energy - etc_3e = 0.d0 - if(three_body_h_tc) then - etc_3e = diag_three_elem_hf - endif + etc_3e = diag_three_elem_hf !tc_grad = grad_non_hermit er_DIIS = maxval(abs(FQS_SQF_mo)) e_delta = dabs(etc_tot - e_save) @@ -202,10 +199,7 @@ subroutine rh_tcscf_diis() etc_tot = TC_HF_energy etc_1e = TC_HF_one_e_energy etc_2e = TC_HF_two_e_energy - etc_3e = 0.d0 - if(three_body_h_tc) then - etc_3e = diag_three_elem_hf - endif + etc_3e = diag_three_elem_hf !tc_grad = grad_non_hermit er_DIIS = maxval(abs(FQS_SQF_mo)) e_delta = dabs(etc_tot - e_save) @@ -245,7 +239,7 @@ subroutine rh_tcscf_diis() write(json_unit, json_real_fmt) ' delta Energy ', e_delta write(json_unit, json_real_fmt) ' DIIS error ', er_DIIS write(json_unit, json_real_fmt) ' level_shift ', level_shift_tcscf - write(json_unit, json_real_fmt) ' DIIS ', dim_DIIS + write(json_unit, json_int_fmtx) ' DIIS ', dim_DIIS write(json_unit, json_real_fmt) ' Wall time (min)', (t1-t0)/60.d0 call unlock_io diff --git a/src/tc_scf/rh_tcscf_simple.irp.f b/plugins/local/tc_scf/rh_tcscf_simple.irp.f similarity index 100% rename from src/tc_scf/rh_tcscf_simple.irp.f rename to plugins/local/tc_scf/rh_tcscf_simple.irp.f diff --git a/src/tc_scf/rh_vartcscf_simple.irp.f b/plugins/local/tc_scf/rh_vartcscf_simple.irp.f similarity index 100% rename from src/tc_scf/rh_vartcscf_simple.irp.f rename to plugins/local/tc_scf/rh_vartcscf_simple.irp.f diff --git a/src/tc_scf/rotate_tcscf_orbitals.irp.f b/plugins/local/tc_scf/rotate_tcscf_orbitals.irp.f similarity index 100% rename from src/tc_scf/rotate_tcscf_orbitals.irp.f rename to plugins/local/tc_scf/rotate_tcscf_orbitals.irp.f diff --git a/src/tc_scf/routines_rotates.irp.f b/plugins/local/tc_scf/routines_rotates.irp.f similarity index 99% rename from src/tc_scf/routines_rotates.irp.f rename to plugins/local/tc_scf/routines_rotates.irp.f index 588382b5..cc825429 100644 --- a/src/tc_scf/routines_rotates.irp.f +++ b/plugins/local/tc_scf/routines_rotates.irp.f @@ -402,6 +402,7 @@ subroutine print_energy_and_mos(good_angles) print *, ' TC energy = ', TC_HF_energy print *, ' TC SCF energy gradient = ', grad_non_hermit print *, ' Max angle Left/right = ', max_angle_left_right + call print_angles_tc() if(max_angle_left_right .lt. thresh_lr_angle) then print *, ' Maximum angle BELOW 45 degrees, everthing is OK !' diff --git a/src/tc_scf/tc_petermann_factor.irp.f b/plugins/local/tc_scf/tc_petermann_factor.irp.f similarity index 57% rename from src/tc_scf/tc_petermann_factor.irp.f rename to plugins/local/tc_scf/tc_petermann_factor.irp.f index 2e9c67e2..14fff898 100644 --- a/src/tc_scf/tc_petermann_factor.irp.f +++ b/plugins/local/tc_scf/tc_petermann_factor.irp.f @@ -30,9 +30,22 @@ subroutine main() allocate(Sl(mo_num,mo_num), Sr(mo_num,mo_num), Pf(mo_num,mo_num)) - call dgemm( "T", "N", mo_num, mo_num, ao_num, 1.d0 & - , mo_l_coef, size(mo_l_coef, 1), mo_l_coef, size(mo_l_coef, 1) & - , 0.d0, Sl, size(Sl, 1) ) + + call LTxSxR(ao_num, mo_num, mo_l_coef, ao_overlap, mo_r_coef, Sl) + !call dgemm( "T", "N", mo_num, mo_num, ao_num, 1.d0 & + ! , mo_l_coef, size(mo_l_coef, 1), mo_l_coef, size(mo_l_coef, 1) & + ! , 0.d0, Sl, size(Sl, 1) ) + + print *, '' + print *, ' left-right orthog matrix:' + do i = 1, mo_num + write(*,'(100(F8.4,X))') Sl(:,i) + enddo + + call LTxSxR(ao_num, mo_num, mo_l_coef, ao_overlap, mo_l_coef, Sl) + !call dgemm( "T", "N", mo_num, mo_num, ao_num, 1.d0 & + ! , mo_l_coef, size(mo_l_coef, 1), mo_l_coef, size(mo_l_coef, 1) & + ! , 0.d0, Sl, size(Sl, 1) ) print *, '' print *, ' left-orthog matrix:' @@ -40,9 +53,10 @@ subroutine main() write(*,'(100(F8.4,X))') Sl(:,i) enddo - call dgemm( "T", "N", mo_num, mo_num, ao_num, 1.d0 & - , mo_r_coef, size(mo_r_coef, 1), mo_r_coef, size(mo_r_coef, 1) & - , 0.d0, Sr, size(Sr, 1) ) + call LTxSxR(ao_num, mo_num, mo_r_coef, ao_overlap, mo_r_coef, Sr) +! call dgemm( "T", "N", mo_num, mo_num, ao_num, 1.d0 & +! , mo_r_coef, size(mo_r_coef, 1), mo_r_coef, size(mo_r_coef, 1) & +! , 0.d0, Sr, size(Sr, 1) ) print *, '' print *, ' right-orthog matrix:' diff --git a/src/tc_scf/tc_scf.irp.f b/plugins/local/tc_scf/tc_scf.irp.f similarity index 79% rename from src/tc_scf/tc_scf.irp.f rename to plugins/local/tc_scf/tc_scf.irp.f index e4c38741..22f66484 100644 --- a/src/tc_scf/tc_scf.irp.f +++ b/plugins/local/tc_scf/tc_scf.irp.f @@ -13,19 +13,32 @@ program tc_scf print *, ' starting ...' my_grid_becke = .True. - PROVIDE tc_grid1_a tc_grid1_r my_n_pt_r_grid = tc_grid1_r my_n_pt_a_grid = tc_grid1_a - touch my_grid_becke my_n_pt_r_grid my_n_pt_a_grid + call write_int(6, my_n_pt_r_grid, 'radial external grid over') + call write_int(6, my_n_pt_a_grid, 'angular external grid over') + + PROVIDE mu_erf print *, ' mu = ', mu_erf PROVIDE j1b_type print *, ' j1b_type = ', j1b_type print *, j1b_pen + if(j1b_type .ge. 100) then + my_extra_grid_becke = .True. + PROVIDE tc_grid2_a tc_grid2_r + my_n_pt_r_extra_grid = tc_grid2_r + my_n_pt_a_extra_grid = tc_grid2_a + touch my_extra_grid_becke my_n_pt_r_extra_grid my_n_pt_a_extra_grid + + call write_int(6, my_n_pt_r_extra_grid, 'radial internal grid over') + call write_int(6, my_n_pt_a_extra_grid, 'angular internal grid over') + endif + !call create_guess() !call orthonormalize_mos() diff --git a/src/tc_scf/tc_scf_dm.irp.f b/plugins/local/tc_scf/tc_scf_dm.irp.f similarity index 75% rename from src/tc_scf/tc_scf_dm.irp.f rename to plugins/local/tc_scf/tc_scf_dm.irp.f index 07da8a58..bf31a4a1 100644 --- a/src/tc_scf/tc_scf_dm.irp.f +++ b/plugins/local/tc_scf/tc_scf_dm.irp.f @@ -1,46 +1,68 @@ ! --- -BEGIN_PROVIDER [ double precision, TCSCF_density_matrix_ao_beta, (ao_num, ao_num) ] +BEGIN_PROVIDER [double precision, TCSCF_density_matrix_ao_beta, (ao_num, ao_num)] BEGIN_DOC + ! ! TC-SCF transition density matrix on the AO basis for BETA electrons + ! END_DOC + implicit none if(bi_ortho) then + PROVIDE mo_l_coef mo_r_coef TCSCF_density_matrix_ao_beta = TCSCF_bi_ort_dm_ao_beta + else + TCSCF_density_matrix_ao_beta = SCF_density_matrix_ao_beta + endif + END_PROVIDER ! --- -BEGIN_PROVIDER [ double precision, TCSCF_density_matrix_ao_alpha, (ao_num, ao_num) ] +BEGIN_PROVIDER [double precision, TCSCF_density_matrix_ao_alpha, (ao_num, ao_num)] BEGIN_DOC + ! ! TC-SCF transition density matrix on the AO basis for ALPHA electrons + ! END_DOC + implicit none if(bi_ortho) then + PROVIDE mo_l_coef mo_r_coef TCSCF_density_matrix_ao_alpha = TCSCF_bi_ort_dm_ao_alpha + else + TCSCF_density_matrix_ao_alpha = SCF_density_matrix_ao_alpha + endif + END_PROVIDER ! --- -BEGIN_PROVIDER [ double precision, TCSCF_density_matrix_ao_tot, (ao_num, ao_num) ] - implicit none +BEGIN_PROVIDER [double precision, TCSCF_density_matrix_ao_tot, (ao_num, ao_num)] + BEGIN_DOC + ! ! TC-SCF transition density matrix on the AO basis for ALPHA+BETA electrons + ! END_DOC + + implicit none + TCSCF_density_matrix_ao_tot = TCSCF_density_matrix_ao_beta + TCSCF_density_matrix_ao_alpha + END_PROVIDER diff --git a/src/tc_scf/tc_scf_energy.irp.f b/plugins/local/tc_scf/tc_scf_energy.irp.f similarity index 100% rename from src/tc_scf/tc_scf_energy.irp.f rename to plugins/local/tc_scf/tc_scf_energy.irp.f diff --git a/src/tc_scf/tcscf_energy_naive.irp.f b/plugins/local/tc_scf/tcscf_energy_naive.irp.f similarity index 100% rename from src/tc_scf/tcscf_energy_naive.irp.f rename to plugins/local/tc_scf/tcscf_energy_naive.irp.f diff --git a/src/tc_scf/test_int.irp.f b/plugins/local/tc_scf/test_int.irp.f similarity index 91% rename from src/tc_scf/test_int.irp.f rename to plugins/local/tc_scf/test_int.irp.f index 649d0f3e..4aa67d04 100644 --- a/src/tc_scf/test_int.irp.f +++ b/plugins/local/tc_scf/test_int.irp.f @@ -54,7 +54,12 @@ program test_ints !!PROVIDE TC_HF_energy VARTC_HF_energy !!print *, ' TC_HF_energy = ', TC_HF_energy !!print *, ' VARTC_HF_energy = ', VARTC_HF_energy - call test_old_ints +! call test_old_ints + + call test_fock_3e_uhf_mo_cs() + call test_fock_3e_uhf_mo_a() + call test_fock_3e_uhf_mo_b() + end ! --- @@ -1096,3 +1101,130 @@ subroutine test_int2_grad1_u12_ao_test print*,'accu_abs = ',accu_abs/dble(ao_num)**4 print*,'accu_relat = ',accu_relat/dble(ao_num)**4 end + +! --- + +subroutine test_fock_3e_uhf_mo_cs() + + implicit none + integer :: i, j + double precision :: I_old, I_new + double precision :: diff_tot, diff, thr_ih, norm + +! double precision :: t0, t1 +! print*, ' Providing fock_a_tot_3e_bi_orth ...' +! call wall_time(t0) +! PROVIDE fock_a_tot_3e_bi_orth +! call wall_time(t1) +! print*, ' Wall time for fock_a_tot_3e_bi_orth =', t1 - t0 + + PROVIDE fock_3e_uhf_mo_cs fock_3e_uhf_mo_cs_old + + thr_ih = 1d-8 + norm = 0.d0 + diff_tot = 0.d0 + + do i = 1, mo_num + do j = 1, mo_num + + I_old = fock_3e_uhf_mo_cs_old(j,i) + I_new = fock_3e_uhf_mo_cs (j,i) + + diff = dabs(I_old - I_new) + if(diff .gt. thr_ih) then + print *, ' problem in fock_3e_uhf_mo_cs on ', j, i + print *, ' old value = ', I_old + print *, ' new value = ', I_new + !stop + endif + + norm += dabs(I_old) + diff_tot += diff + enddo + enddo + + print *, ' diff tot (%) = ', 100.d0 * diff_tot / norm + + return +end subroutine test_fock_3e_uhf_mo_cs + +! --- + +subroutine test_fock_3e_uhf_mo_a() + + implicit none + integer :: i, j + double precision :: I_old, I_new + double precision :: diff_tot, diff, thr_ih, norm + + PROVIDE fock_3e_uhf_mo_a fock_3e_uhf_mo_a_old + + thr_ih = 1d-8 + norm = 0.d0 + diff_tot = 0.d0 + + do i = 1, mo_num + do j = 1, mo_num + + I_old = fock_3e_uhf_mo_a_old(j,i) + I_new = fock_3e_uhf_mo_a (j,i) + + diff = dabs(I_old - I_new) + if(diff .gt. thr_ih) then + print *, ' problem in fock_3e_uhf_mo_a on ', j, i + print *, ' old value = ', I_old + print *, ' new value = ', I_new + !stop + endif + + norm += dabs(I_old) + diff_tot += diff + enddo + enddo + + print *, ' diff tot (%) = ', 100.d0 * diff_tot / norm + + return +end subroutine test_fock_3e_uhf_mo_a + +! --- + +subroutine test_fock_3e_uhf_mo_b() + + implicit none + integer :: i, j + double precision :: I_old, I_new + double precision :: diff_tot, diff, thr_ih, norm + + PROVIDE fock_3e_uhf_mo_b fock_3e_uhf_mo_b_old + + thr_ih = 1d-8 + norm = 0.d0 + diff_tot = 0.d0 + + do i = 1, mo_num + do j = 1, mo_num + + I_old = fock_3e_uhf_mo_b_old(j,i) + I_new = fock_3e_uhf_mo_b (j,i) + + diff = dabs(I_old - I_new) + if(diff .gt. thr_ih) then + print *, ' problem in fock_3e_uhf_mo_b on ', j, i + print *, ' old value = ', I_old + print *, ' new value = ', I_new + !stop + endif + + norm += dabs(I_old) + diff_tot += diff + enddo + enddo + + print *, ' diff tot (%) = ', 100.d0 * diff_tot / norm + + return +end subroutine test_fock_3e_uhf_mo_b + +! --- + diff --git a/src/tc_scf/three_e_energy_bi_ortho.irp.f b/plugins/local/tc_scf/three_e_energy_bi_ortho.irp.f similarity index 100% rename from src/tc_scf/three_e_energy_bi_ortho.irp.f rename to plugins/local/tc_scf/three_e_energy_bi_ortho.irp.f diff --git a/scripts/Hn.py b/scripts/Hn.py index 0f938510..55a958f7 100644 --- a/scripts/Hn.py +++ b/scripts/Hn.py @@ -1,4 +1,5 @@ -#!/usr/bin/env python +#!/usr/bin/env python3 + import sys from math import * arg = sys.argv diff --git a/scripts/compilation/qp_create_ninja b/scripts/compilation/qp_create_ninja index 606fd0f6..e67d896b 100755 --- a/scripts/compilation/qp_create_ninja +++ b/scripts/compilation/qp_create_ninja @@ -38,9 +38,8 @@ def comp_path(path): from qp_path import QP_ROOT, QP_SRC, QP_EZFIO -LIB = " -lz -ltrexio" +LIB = " -lz" 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_EXP = join(QP_ROOT, "config", "build.ninja") 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_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 for directory in [real_join(QP_SRC, m) for m in sorted(os.listdir(QP_SRC))]: diff --git a/scripts/ezfio_interface/ei_handler.py b/scripts/ezfio_interface/ei_handler.py index fd514ace..3af43883 100755 --- a/scripts/ezfio_interface/ei_handler.py +++ b/scripts/ezfio_interface/ei_handler.py @@ -829,4 +829,8 @@ if __name__ == "__main__": # _| 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) + diff --git a/scripts/import_champ_jastrow.py b/scripts/import_champ_jastrow.py new file mode 100755 index 00000000..489309b7 --- /dev/null +++ b/scripts/import_champ_jastrow.py @@ -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']) + diff --git a/scripts/module/create_executables_list.sh b/scripts/module/create_executables_list.sh index 67e1aba2..41d8853d 100755 --- a/scripts/module/create_executables_list.sh +++ b/scripts/module/create_executables_list.sh @@ -11,7 +11,11 @@ fi cd ${QP_ROOT}/data rm -f executables +if [[ "$(uname -s)" = "Darwin" ]] ; then +EXES=$(find -L ${QP_ROOT}/src -maxdepth 2 -depth -perm +111 -type f | grep -e "${QP_ROOT}/src/[^/]*/[^/]*$" |sort ) +else EXES=$(find -L ${QP_ROOT}/src -maxdepth 2 -depth -executable -type f | grep -e "${QP_ROOT}/src/[^/]*/[^/]*$" |sort ) +fi for EXE in $EXES do diff --git a/scripts/module/module_handler.py b/scripts/module/module_handler.py index fbdee171..43030fc8 100755 --- a/scripts/module/module_handler.py +++ b/scripts/module/module_handler.py @@ -115,9 +115,7 @@ def get_l_module_descendant(d_child, l_module): except KeyError: print("Error: ", file=sys.stderr) print("`{0}` is not a submodule".format(module), file=sys.stderr) - print("Check the typo (spelling, case, '/', etc.) ", file=sys.stderr) -# pass - sys.exit(1) + raise return list(set(l)) diff --git a/scripts/qp_exc_energy.py b/scripts/qp_exc_energy.py index 7e7f1d67..44136311 100755 --- a/scripts/qp_exc_energy.py +++ b/scripts/qp_exc_energy.py @@ -1,4 +1,5 @@ -#!/usr/bin/env python +#!/usr/bin/env python3 + # Computes the error on the excitation energy of a CIPSI run. def student(p,df): diff --git a/scripts/qp_import_trexio.py b/scripts/qp_import_trexio.py index 2c829f5c..9251a1b0 100755 --- a/scripts/qp_import_trexio.py +++ b/scripts/qp_import_trexio.py @@ -38,6 +38,15 @@ else: QP_ROOT + "/install", 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): @@ -133,6 +142,7 @@ def write_ezfio(trexio_filename, filename): try: basis_type = trexio.read_basis_type(trexio_file) + print ("BASIS TYPE: ", basis_type.lower()) if basis_type.lower() in ["gaussian", "slater"]: shell_num = trexio.read_basis_shell_num(trexio_file) prim_num = trexio.read_basis_prim_num(trexio_file) @@ -454,18 +464,40 @@ def write_ezfio(trexio_filename, filename): else: print("None") - print("Determinant\t\t...\t", end=' ') + 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) - beta = [ i for i in range(mo_num) if spin[i] == 1 ] - beta = [ beta[i] for i in range(num_beta) ] + 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 = qp_bitmasks.BitMask(alpha) - beta = qp_bitmasks.BitMask(beta ) - print(alpha) - print(beta) + 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") diff --git a/scripts/utility/qp_json.py b/scripts/utility/qp_json.py index 09ffe1be..5cba9ff2 100644 --- a/scripts/utility/qp_json.py +++ b/scripts/utility/qp_json.py @@ -1,4 +1,5 @@ -#!/usr/bin/env python +#!/usr/bin/env python3 + import os import json diff --git a/src/ao_one_e_ints/kin_ao_ints.irp.f b/src/ao_one_e_ints/kin_ao_ints.irp.f index a5ee0670..3a97d095 100644 --- a/src/ao_one_e_ints/kin_ao_ints.irp.f +++ b/src/ao_one_e_ints/kin_ao_ints.irp.f @@ -52,7 +52,7 @@ !$OMP DEFAULT(NONE) & !$OMP PRIVATE(A_center,B_center,power_A,power_B,& !$OMP overlap_y, overlap_z, overlap, & - !$OMP alpha, beta,i,j,c,d_a_2,d_2,deriv_tmp, & + !$OMP alpha, beta, n, l, i,j,c,d_a_2,d_2,deriv_tmp, & !$OMP overlap_x0,overlap_y0,overlap_z0) & !$OMP SHARED(nucl_coord,ao_power,ao_prim_num, & !$OMP ao_deriv2_x,ao_deriv2_y,ao_deriv2_z,ao_num,ao_coef_normalized_ordered_transp,ao_nucl, & diff --git a/src/ao_two_e_erf_ints/EZFIO.cfg b/src/ao_two_e_erf_ints/EZFIO.cfg deleted file mode 100644 index 0af0e1d8..00000000 --- a/src/ao_two_e_erf_ints/EZFIO.cfg +++ /dev/null @@ -1,13 +0,0 @@ -[io_ao_two_e_integrals_erf] -type: Disk_access -doc: Read/Write |AO| integrals with the long range interaction from/to disk [ Write | Read | None ] -interface: ezfio,provider,ocaml -default: None - -[mu_erf] -type: double precision -doc: cutting of the interaction in the range separated model -interface: ezfio,provider,ocaml -default: 0.5 -ezfio_name: mu_erf - diff --git a/src/ao_two_e_erf_ints/NEED b/src/ao_two_e_erf_ints/NEED deleted file mode 100644 index b30cc39d..00000000 --- a/src/ao_two_e_erf_ints/NEED +++ /dev/null @@ -1 +0,0 @@ -ao_two_e_ints diff --git a/src/ao_two_e_erf_ints/README.rst b/src/ao_two_e_erf_ints/README.rst deleted file mode 100644 index 45c72b84..00000000 --- a/src/ao_two_e_erf_ints/README.rst +++ /dev/null @@ -1,19 +0,0 @@ -====================== -ao_two_e_erf_ints -====================== - -Here, all two-electron integrals (:math:`erf(\mu r_{12})/r_{12}`) are computed. -As they have 4 indices and many are zero, they are stored in a map, as defined -in :file:`utils/map_module.f90`. - -The main parameter of this module is :option:`ao_two_e_erf_ints mu_erf` which is the range-separation parameter. - -To fetch an |AO| integral, use the -`get_ao_two_e_integral_erf(i,j,k,l,ao_integrals_erf_map)` function. - - -The conventions are: -* For |AO| integrals : (ij|kl) = (11|22) = = <12|12> - - - diff --git a/src/ao_two_e_ints/EZFIO.cfg b/src/ao_two_e_ints/EZFIO.cfg index 9c017813..ff932b0c 100644 --- a/src/ao_two_e_ints/EZFIO.cfg +++ b/src/ao_two_e_ints/EZFIO.cfg @@ -35,3 +35,15 @@ type: logical doc: Perform Cholesky decomposition of AO integrals interface: ezfio,provider,ocaml default: False + +[io_ao_two_e_integrals_erf] +type: Disk_access +doc: Read/Write |AO| erf integrals from/to disk [ Write | Read | None ] +interface: ezfio,provider,ocaml +default: None + +[use_only_lr] +type: logical +doc: If true, use only the long range part of the two-electron integrals instead of 1/r12 +interface: ezfio, provider, ocaml +default: False diff --git a/src/ao_two_e_ints/NEED b/src/ao_two_e_ints/NEED index ffc5e8be..542962ec 100644 --- a/src/ao_two_e_ints/NEED +++ b/src/ao_two_e_ints/NEED @@ -1,3 +1,4 @@ +hamiltonian ao_one_e_ints pseudo bitmask diff --git a/src/ao_two_e_erf_ints/integrals_erf_in_map_slave.irp.f b/src/ao_two_e_ints/integrals_erf_in_map_slave.irp.f similarity index 100% rename from src/ao_two_e_erf_ints/integrals_erf_in_map_slave.irp.f rename to src/ao_two_e_ints/integrals_erf_in_map_slave.irp.f diff --git a/src/ao_two_e_erf_ints/map_integrals_erf.irp.f b/src/ao_two_e_ints/map_integrals_erf.irp.f similarity index 100% rename from src/ao_two_e_erf_ints/map_integrals_erf.irp.f rename to src/ao_two_e_ints/map_integrals_erf.irp.f diff --git a/src/ao_two_e_erf_ints/providers_ao_erf.irp.f b/src/ao_two_e_ints/providers_ao_erf.irp.f similarity index 98% rename from src/ao_two_e_erf_ints/providers_ao_erf.irp.f rename to src/ao_two_e_ints/providers_ao_erf.irp.f index 293df29f..ff8c31a2 100644 --- a/src/ao_two_e_erf_ints/providers_ao_erf.irp.f +++ b/src/ao_two_e_ints/providers_ao_erf.irp.f @@ -90,7 +90,7 @@ BEGIN_PROVIDER [ logical, ao_two_e_integrals_erf_in_map ] if (write_ao_two_e_integrals_erf) then call ezfio_set_work_empty(.False.) call map_save_to_disk(trim(ezfio_filename)//'/work/ao_ints_erf',ao_integrals_erf_map) - call ezfio_set_ao_two_e_erf_ints_io_ao_two_e_integrals_erf("Read") + call ezfio_set_ao_two_e_ints_io_ao_two_e_integrals_erf('Read') endif END_PROVIDER diff --git a/src/ao_two_e_erf_ints/routines_save_integrals_erf.irp.f b/src/ao_two_e_ints/routines_save_integrals_erf.irp.f similarity index 88% rename from src/ao_two_e_erf_ints/routines_save_integrals_erf.irp.f rename to src/ao_two_e_ints/routines_save_integrals_erf.irp.f index 4b0cfad0..d980bc05 100644 --- a/src/ao_two_e_erf_ints/routines_save_integrals_erf.irp.f +++ b/src/ao_two_e_ints/routines_save_integrals_erf.irp.f @@ -4,7 +4,7 @@ subroutine save_erf_two_e_integrals_ao PROVIDE ao_two_e_integrals_erf_in_map call ezfio_set_work_empty(.False.) call map_save_to_disk(trim(ezfio_filename)//'/work/ao_ints_erf',ao_integrals_erf_map) - call ezfio_set_ao_two_e_erf_ints_io_ao_two_e_integrals_erf('Read') + call ezfio_set_ao_two_e_ints_io_ao_two_e_integrals_erf('Read') end subroutine save_erf_two_e_ints_ao_into_ints_ao diff --git a/src/ao_two_e_ints/two_e_integrals.irp.f b/src/ao_two_e_ints/two_e_integrals.irp.f index 148ebb62..b55b5f0d 100644 --- a/src/ao_two_e_ints/two_e_integrals.irp.f +++ b/src/ao_two_e_ints/two_e_integrals.irp.f @@ -21,9 +21,9 @@ double precision function ao_two_e_integral(i, j, k, l) double precision :: P_new(0:max_dim,3),P_center(3),fact_p,pp double precision :: Q_new(0:max_dim,3),Q_center(3),fact_q,qq - double precision :: ao_two_e_integral_schwartz_accel - - double precision :: ao_two_e_integral_cosgtos + double precision, external :: ao_two_e_integral_erf + double precision, external :: ao_two_e_integral_cosgtos + double precision, external :: ao_two_e_integral_schwartz_accel if(use_cosgtos) then @@ -31,13 +31,15 @@ double precision function ao_two_e_integral(i, j, k, l) ao_two_e_integral = ao_two_e_integral_cosgtos(i, j, k, l) - else + else if (use_only_lr) then - if (ao_prim_num(i) * ao_prim_num(j) * ao_prim_num(k) * ao_prim_num(l) > 1024 ) then + ao_two_e_integral = ao_two_e_integral_erf(i, j, k, l) + + else if (ao_prim_num(i) * ao_prim_num(j) * ao_prim_num(k) * ao_prim_num(l) > 1024 ) then ao_two_e_integral = ao_two_e_integral_schwartz_accel(i,j,k,l) - else + else dim1 = n_pt_max_integrals @@ -117,8 +119,6 @@ double precision function ao_two_e_integral(i, j, k, l) enddo ! q enddo ! p - endif - endif endif diff --git a/src/ao_two_e_erf_ints/two_e_integrals_erf.irp.f b/src/ao_two_e_ints/two_e_integrals_erf.irp.f similarity index 100% rename from src/ao_two_e_erf_ints/two_e_integrals_erf.irp.f rename to src/ao_two_e_ints/two_e_integrals_erf.irp.f diff --git a/src/becke_numerical_grid/EZFIO.cfg b/src/becke_numerical_grid/EZFIO.cfg index 7861f074..e660fd6d 100644 --- a/src/becke_numerical_grid/EZFIO.cfg +++ b/src/becke_numerical_grid/EZFIO.cfg @@ -33,6 +33,10 @@ doc: Number of angular grid points given from input. Warning, this number cannot interface: ezfio,provider,ocaml default: 1202 +[n_points_extra_final_grid] +type: integer +doc: Total number of extra_grid points +interface: ezfio [extra_grid_type_sgn] type: integer diff --git a/src/becke_numerical_grid/extra_grid.irp.f b/src/becke_numerical_grid/extra_grid.irp.f index 9bd24f22..7df4dd6d 100644 --- a/src/becke_numerical_grid/extra_grid.irp.f +++ b/src/becke_numerical_grid/extra_grid.irp.f @@ -14,7 +14,7 @@ implicit none - if(.not.my_extra_grid_becke)then + if(.not. my_extra_grid_becke) then select case (extra_grid_type_sgn) case(0) n_points_extra_radial_grid = 23 @@ -33,7 +33,7 @@ stop end select else - n_points_extra_radial_grid = my_n_pt_r_extra_grid + n_points_extra_radial_grid = my_n_pt_r_extra_grid n_points_extra_integration_angular = my_n_pt_a_extra_grid endif diff --git a/src/becke_numerical_grid/extra_grid_vector.irp.f b/src/becke_numerical_grid/extra_grid_vector.irp.f index e4fc03b5..ae167282 100644 --- a/src/becke_numerical_grid/extra_grid_vector.irp.f +++ b/src/becke_numerical_grid/extra_grid_vector.irp.f @@ -23,29 +23,33 @@ BEGIN_PROVIDER [integer, n_points_extra_final_grid] 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) -! call ezfio_set_becke_numerical_grid_n_points_extra_final_grid(n_points_extra_final_grid) + 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) + call ezfio_set_becke_numerical_grid_n_points_extra_final_grid(n_points_extra_final_grid) + END_PROVIDER ! --- 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 [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) ] - implicit none +&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_reverse, (n_points_extra_integration_angular,n_points_extra_radial_grid,nucl_num)] + BEGIN_DOC -! 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 -! -! 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 + ! 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 + ! + ! 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 END_DOC + + implicit none integer :: i,j,k,l,i_count double precision :: r(3) + i_count = 0 do j = 1, nucl_num do i = 1, n_points_extra_radial_grid -1 @@ -67,3 +71,5 @@ END_PROVIDER enddo END_PROVIDER + + diff --git a/src/becke_numerical_grid/grid_becke.irp.f b/src/becke_numerical_grid/grid_becke.irp.f index 21b9f98d..f72d452d 100644 --- a/src/becke_numerical_grid/grid_becke.irp.f +++ b/src/becke_numerical_grid/grid_becke.irp.f @@ -14,7 +14,7 @@ implicit none - if(.not.my_grid_becke)then + if(.not. my_grid_becke) then select case (grid_type_sgn) case(0) n_points_radial_grid = 23 @@ -37,6 +37,9 @@ 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 ! --- diff --git a/src/casscf_cipsi/50.casscf.bats b/src/casscf_cipsi/50.casscf.bats index a0db725d..9f63dfe2 100644 --- a/src/casscf_cipsi/50.casscf.bats +++ b/src/casscf_cipsi/50.casscf.bats @@ -9,8 +9,8 @@ function run_stoch() { test_exe casscf || skip qp set perturbation do_pt2 True qp set determinants n_det_max $3 - qp set davidson threshold_davidson 1.e-10 - qp set davidson n_states_diag 4 + qp set davidson_keywords threshold_davidson 1.e-10 + qp set davidson_keywords n_states_diag 4 qp run casscf | tee casscf.out energy1="$(ezfio get casscf energy_pt2 | tr '[]' ' ' | cut -d ',' -f 1)" eq $energy1 $1 $thresh diff --git a/src/casscf_cipsi/EZFIO.cfg b/src/casscf_cipsi/EZFIO.cfg index 2a1f1926..18e0b6b1 100644 --- a/src/casscf_cipsi/EZFIO.cfg +++ b/src/casscf_cipsi/EZFIO.cfg @@ -73,3 +73,9 @@ type: logical doc: If |true|, the pt2_max value in the CIPSI iterations will automatically adapt, otherwise it is fixed at the value given in the EZFIO folder interface: ezfio,provider,ocaml default: True + +[small_active_space] +type: logical +doc: If |true|, the pt2_max value in the CIPSI is set to 10-10 and will not change +interface: ezfio,provider,ocaml +default: False diff --git a/src/casscf_cipsi/README.rst b/src/casscf_cipsi/README.rst index 08bfd95b..f84cde75 100644 --- a/src/casscf_cipsi/README.rst +++ b/src/casscf_cipsi/README.rst @@ -3,3 +3,45 @@ casscf ====== |CASSCF| program with the CIPSI algorithm. + +Example of inputs +----------------- + +a) Small active space : standard CASSCF +--------------------------------------- +Let's do O2 (triplet) in aug-cc-pvdz with the following geometry (xyz format, Bohr units) +3 + + O 0.0000000000 0.0000000000 -1.1408000000 + O 0.0000000000 0.0000000000 1.1408000000 + +# Create the ezfio folder +qp create_ezfio -b aug-cc-pvdz O2.xyz -m 3 -a -o O2_avdz + +# Start with an ROHF guess +qp run scf | tee ${EZFIO_FILE}.rohf.out + +# Get the ROHF energy for check +qp get hartree_fock energy # should be -149.4684509 + +# Define the full valence active space: the two 1s are doubly occupied, the other 8 valence orbitals are active +# CASSCF(12e,10orb) +qp set_mo_class -c "[1-2]" -a "[3-10]" -v "[11-46]" + +# Specify that you want an near exact CASSCF, i.e. the CIPSI selection will stop at pt2_max = 10^-10 +qp set casscf_cipsi small_active_space True +# RUN THE CASSCF +qp run casscf | tee ${EZFIO_FILE}.casscf.out +# you should find around -149.7243542 + + +b) Large active space : Exploit the selected CI in the active space +------------------------------------------------------------------- +#Let us start from the small active space calculation orbitals and add another 10 virtuals: CASSCF(12e,20orb) +qp set_mo_class -c "[1-2]" -a "[3-20]" -v "[21-46]" +# As this active space is larger, you unset the small_active_space feature +qp set casscf_cipsi small_active_space False +# As it is a large active space, the energy convergence thereshold is set to be 0.0001 +qp run casscf | tee ${EZFIO_FILE}.casscf_large.out +# you should find around -149.9046 + diff --git a/src/casscf_cipsi/casscf.irp.f b/src/casscf_cipsi/casscf.irp.f index 02954ebf..addca236 100644 --- a/src/casscf_cipsi/casscf.irp.f +++ b/src/casscf_cipsi/casscf.irp.f @@ -8,17 +8,23 @@ program casscf ! touch no_vvvv_integrals n_det_max_full = 500 touch n_det_max_full - pt2_relative_error = 0.04 + if(small_active_space)then + pt2_relative_error = 0.00001 + else + thresh_scf = 1.d-4 + pt2_relative_error = 0.04 + endif touch pt2_relative_error -! call run_stochastic_cipsi call run end subroutine run implicit none - double precision :: energy_old, energy, pt2_max_before, ept2_before,delta_E + double precision :: energy_old, energy, pt2_max_before,delta_E logical :: converged,state_following_casscf_cipsi_save - integer :: iteration + integer :: iteration,istate + double precision, allocatable :: E_PT2(:), PT2(:), Ev(:), ept2_before(:) + allocate(E_PT2(N_states), PT2(N_states), Ev(N_states), ept2_before(N_states)) converged = .False. energy = 0.d0 @@ -28,13 +34,20 @@ subroutine run state_following_casscf = .True. touch state_following_casscf ept2_before = 0.d0 - if(adaptive_pt2_max)then - pt2_max = 0.005 + if(small_active_space)then + pt2_max = 1.d-10 SOFT_TOUCH pt2_max + else + if(adaptive_pt2_max)then + pt2_max = 0.005 + SOFT_TOUCH pt2_max + endif endif do while (.not.converged) print*,'pt2_max = ',pt2_max - call run_stochastic_cipsi + call run_stochastic_cipsi(Ev,PT2) + print*,'Ev,PT2',Ev(1),PT2(1) + E_PT2(1:N_states) = Ev(1:N_states) + PT2(1:N_states) energy_old = energy energy = eone+etwo+ecore pt2_max_before = pt2_max @@ -42,15 +55,15 @@ subroutine run call write_time(6) call write_int(6,iteration,'CAS-SCF iteration = ') call write_double(6,energy,'CAS-SCF energy = ') - if(n_states == 1)then - double precision :: E_PT2, PT2 - call ezfio_get_casscf_cipsi_energy_pt2(E_PT2) - call ezfio_get_casscf_cipsi_energy(PT2) - PT2 -= E_PT2 - call write_double(6,E_PT2,'E + PT2 energy = ') - call write_double(6,PT2,' PT2 = ') +! if(n_states == 1)then +! call ezfio_get_casscf_cipsi_energy_pt2(E_PT2) +! call ezfio_get_casscf_cipsi_energy(PT2) + do istate=1,N_states + call write_double(6,E_PT2(istate),'E + PT2 energy = ') + call write_double(6,PT2(istate),' PT2 = ') + enddo call write_double(6,pt2_max,' PT2_MAX = ') - endif +! endif print*,'' call write_double(6,norm_grad_vec2,'Norm of gradients = ') @@ -65,15 +78,20 @@ subroutine run else if (criterion_casscf == "gradients")then converged = norm_grad_vec2 < thresh_scf else if (criterion_casscf == "e_pt2")then - delta_E = dabs(E_PT2 - ept2_before) + delta_E = 0.d0 + do istate = 1, N_states + delta_E += dabs(E_PT2(istate) - ept2_before(istate)) + enddo converged = dabs(delta_E) < thresh_casscf endif ept2_before = E_PT2 - if(adaptive_pt2_max)then - pt2_max = dabs(energy_improvement / (pt2_relative_error)) - pt2_max = min(pt2_max, pt2_max_before) - if(n_act_orb.ge.n_big_act_orb)then - pt2_max = max(pt2_max,pt2_min_casscf) + if(.not.small_active_space)then + if(adaptive_pt2_max)then + pt2_max = dabs(energy_improvement / (pt2_relative_error)) + pt2_max = min(pt2_max, pt2_max_before) + if(n_act_orb.ge.n_big_act_orb)then + pt2_max = max(pt2_max,pt2_min_casscf) + endif endif endif print*,'' @@ -94,8 +112,10 @@ subroutine run read_wf = .True. call clear_mo_map SOFT_TOUCH mo_coef N_det psi_det psi_coef - if(adaptive_pt2_max)then - SOFT_TOUCH pt2_max + if(.not.small_active_space)then + if(adaptive_pt2_max)then + SOFT_TOUCH pt2_max + endif endif if(iteration .gt. 3)then state_following_casscf = state_following_casscf_cipsi_save @@ -104,6 +124,25 @@ subroutine run endif enddo + integer :: i + print*,'Converged CASSCF ' + print*,'--------------------------' + write(6,*) ' occupation numbers of orbitals ' + do i=1,mo_num + write(6,*) i,occnum(i) + end do + print*,'--------------' +! +! write(6,*) +! write(6,*) ' the diagonal of the inactive effective Fock matrix ' +! write(6,'(5(i3,F12.5))') (i,Fipq(i,i),i=1,mo_num) +! write(6,*) + print*,'Fock MCSCF' + do i = 1, mo_num + write(*,*)i,mcscf_fock_diag_mo(i) +! write(*,*)mcscf_fock_alpha_mo(i,i) + enddo + end diff --git a/src/casscf_cipsi/densities.irp.f b/src/casscf_cipsi/densities.irp.f index bebcf5d7..54ff86e1 100644 --- a/src/casscf_cipsi/densities.irp.f +++ b/src/casscf_cipsi/densities.irp.f @@ -17,6 +17,35 @@ BEGIN_PROVIDER [real*8, D0tu, (n_act_orb,n_act_orb) ] END_PROVIDER + BEGIN_PROVIDER [double precision, D0tu_alpha_ao, (ao_num, ao_num)] +&BEGIN_PROVIDER [double precision, D0tu_beta_ao, (ao_num, ao_num)] + implicit none + integer :: i,ii,j,u,t,uu,tt + double precision, allocatable :: D0_tmp_alpha(:,:),D0_tmp_beta(:,:) + allocate(D0_tmp_alpha(mo_num, mo_num),D0_tmp_beta(mo_num, mo_num)) + D0_tmp_beta = 0.d0 + D0_tmp_alpha = 0.d0 + do i = 1, n_core_inact_orb + ii = list_core_inact(i) + D0_tmp_alpha(ii,ii) = 1.d0 + D0_tmp_beta(ii,ii) = 1.d0 + enddo + print*,'Diagonal elements of the 1RDM in the active space' + do u=1,n_act_orb + uu = list_act(u) + print*,uu,one_e_dm_mo_alpha_average(uu,uu),one_e_dm_mo_beta_average(uu,uu) + do t=1,n_act_orb + tt = list_act(t) + D0_tmp_alpha(tt,uu) = one_e_dm_mo_alpha_average(tt,uu) + D0_tmp_beta(tt,uu) = one_e_dm_mo_beta_average(tt,uu) + enddo + enddo + + call mo_to_ao_no_overlap(D0_tmp_alpha,mo_num,D0tu_alpha_ao,ao_num) + call mo_to_ao_no_overlap(D0_tmp_beta,mo_num,D0tu_beta_ao,ao_num) + +END_PROVIDER + BEGIN_PROVIDER [real*8, P0tuvx, (n_act_orb,n_act_orb,n_act_orb,n_act_orb) ] BEGIN_DOC ! The second-order density matrix in the basis of the starting MOs ONLY IN THE RANGE OF ACTIVE MOS diff --git a/src/casscf_cipsi/mcscf_fock.irp.f b/src/casscf_cipsi/mcscf_fock.irp.f index e4568405..0f4b7a99 100644 --- a/src/casscf_cipsi/mcscf_fock.irp.f +++ b/src/casscf_cipsi/mcscf_fock.irp.f @@ -77,4 +77,119 @@ BEGIN_PROVIDER [real*8, Fapq, (mo_num,mo_num) ] END_PROVIDER - + BEGIN_PROVIDER [ double precision, mcscf_fock_alpha_ao, (ao_num, ao_num)] +&BEGIN_PROVIDER [ double precision, mcscf_fock_beta_ao, (ao_num, ao_num)] + implicit none + BEGIN_DOC + ! mcscf_fock_alpha_ao are set to usual Fock like operator but computed with the MCSCF densities on the AO basis + END_DOC + SCF_density_matrix_ao_alpha = D0tu_alpha_ao + SCF_density_matrix_ao_beta = D0tu_beta_ao + soft_touch SCF_density_matrix_ao_alpha SCF_density_matrix_ao_beta + mcscf_fock_beta_ao = fock_matrix_ao_beta + mcscf_fock_alpha_ao = fock_matrix_ao_alpha +END_PROVIDER + + + BEGIN_PROVIDER [ double precision, mcscf_fock_alpha_mo, (mo_num, mo_num)] +&BEGIN_PROVIDER [ double precision, mcscf_fock_beta_mo, (mo_num, mo_num)] + implicit none + BEGIN_DOC + ! Mo_mcscf_fock_alpha are set to usual Fock like operator but computed with the MCSCF densities on the MO basis + END_DOC + + call ao_to_mo(mcscf_fock_alpha_ao,ao_num,mcscf_fock_alpha_mo,mo_num) + call ao_to_mo(mcscf_fock_beta_ao,ao_num,mcscf_fock_beta_mo,mo_num) + +END_PROVIDER + + BEGIN_PROVIDER [ double precision, mcscf_fock_mo, (mo_num,mo_num) ] +&BEGIN_PROVIDER [ double precision, mcscf_fock_diag_mo, (mo_num)] + implicit none + BEGIN_DOC + ! MCSF Fock matrix on the MO basis. + ! For open shells, the ROHF Fock Matrix is :: + ! + ! | Rcc | F^b | Fcv | + ! |-----------------------| + ! | F^b | Roo | F^a | + ! |-----------------------| + ! | Fcv | F^a | Rvv | + ! + ! C: Core, O: Open, V: Virtual + ! + ! Rcc = Acc Fcc^a + Bcc Fcc^b + ! Roo = Aoo Foo^a + Boo Foo^b + ! Rvv = Avv Fvv^a + Bvv Fvv^b + ! Fcv = (F^a + F^b)/2 + ! + ! F^a: Fock matrix alpha (MO), F^b: Fock matrix beta (MO) + ! A,B: Coupling parameters + ! + ! J. Chem. Phys. 133, 141102 (2010), https://doi.org/10.1063/1.3503173 + ! Coupling parameters from J. Chem. Phys. 125, 204110 (2006); https://doi.org/10.1063/1.2393223. + ! cc oo vv + ! A -0.5 0.5 1.5 + ! B 1.5 0.5 -0.5 + ! + END_DOC + integer :: i,j,n + if (elec_alpha_num == elec_beta_num) then + mcscf_fock_mo = mcscf_fock_alpha_mo + else + ! Core + do j = 1, elec_beta_num + ! Core + do i = 1, elec_beta_num + mcscf_fock_mo(i,j) = - 0.5d0 * mcscf_fock_alpha_mo(i,j) & + + 1.5d0 * mcscf_fock_beta_mo(i,j) + enddo + ! Open + do i = elec_beta_num+1, elec_alpha_num + mcscf_fock_mo(i,j) = mcscf_fock_beta_mo(i,j) + enddo + ! Virtual + do i = elec_alpha_num+1, mo_num + mcscf_fock_mo(i,j) = 0.5d0 * mcscf_fock_alpha_mo(i,j) & + + 0.5d0 * mcscf_fock_beta_mo(i,j) + enddo + enddo + ! Open + do j = elec_beta_num+1, elec_alpha_num + ! Core + do i = 1, elec_beta_num + mcscf_fock_mo(i,j) = mcscf_fock_beta_mo(i,j) + enddo + ! Open + do i = elec_beta_num+1, elec_alpha_num + mcscf_fock_mo(i,j) = 0.5d0 * mcscf_fock_alpha_mo(i,j) & + + 0.5d0 * mcscf_fock_beta_mo(i,j) + enddo + ! Virtual + do i = elec_alpha_num+1, mo_num + mcscf_fock_mo(i,j) = mcscf_fock_alpha_mo(i,j) + enddo + enddo + ! Virtual + do j = elec_alpha_num+1, mo_num + ! Core + do i = 1, elec_beta_num + mcscf_fock_mo(i,j) = 0.5d0 * mcscf_fock_alpha_mo(i,j) & + + 0.5d0 * mcscf_fock_beta_mo(i,j) + enddo + ! Open + do i = elec_beta_num+1, elec_alpha_num + mcscf_fock_mo(i,j) = mcscf_fock_alpha_mo(i,j) + enddo + ! Virtual + do i = elec_alpha_num+1, mo_num + mcscf_fock_mo(i,j) = 1.5d0 * mcscf_fock_alpha_mo(i,j) & + - 0.5d0 * mcscf_fock_beta_mo(i,j) + enddo + enddo + endif + + do i = 1, mo_num + mcscf_fock_diag_mo(i) = mcscf_fock_mo(i,i) + enddo +END_PROVIDER diff --git a/src/cipsi/stochastic_cipsi.irp.f b/src/cipsi/stochastic_cipsi.irp.f index 339f7084..289040f0 100644 --- a/src/cipsi/stochastic_cipsi.irp.f +++ b/src/cipsi/stochastic_cipsi.irp.f @@ -1,10 +1,11 @@ -subroutine run_stochastic_cipsi +subroutine run_stochastic_cipsi(Ev,PT2) use selection_types implicit none BEGIN_DOC ! Selected Full Configuration Interaction with Stochastic selection and PT2. END_DOC integer :: i,j,k + double precision, intent(out) :: Ev(N_states), PT2(N_states) double precision, allocatable :: zeros(:) integer :: to_select type(pt2_type) :: pt2_data, pt2_data_err @@ -79,12 +80,14 @@ subroutine run_stochastic_cipsi to_select = max(N_states_diag, to_select) + Ev(1:N_states) = psi_energy_with_nucl_rep(1:N_states) call pt2_dealloc(pt2_data) call pt2_dealloc(pt2_data_err) call pt2_alloc(pt2_data, N_states) call pt2_alloc(pt2_data_err, N_states) call ZMQ_pt2(psi_energy_with_nucl_rep,pt2_data,pt2_data_err,relative_error,to_select) ! Stochastic PT2 and selection + PT2(1:N_states) = pt2_data % pt2(1:N_states) correlation_energy_ratio = (psi_energy_with_nucl_rep(1) - hf_energy_ref) / & (psi_energy_with_nucl_rep(1) + pt2_data % rpt2(1) - hf_energy_ref) correlation_energy_ratio = min(1.d0,correlation_energy_ratio) diff --git a/src/cis/20.cis.bats b/src/cis/20.cis.bats index 4f255c7b..4a5c6e45 100644 --- a/src/cis/20.cis.bats +++ b/src/cis/20.cis.bats @@ -9,7 +9,7 @@ function run() { qp set_file $1 qp edit --check qp set determinants n_states 3 - qp set davidson threshold_davidson 1.e-12 + qp set davidson_keywords threshold_davidson 1.e-12 qp set mo_two_e_ints io_mo_two_e_integrals Write qp set_frozen_core qp run cis @@ -59,7 +59,7 @@ function run() { @test "ClO" { # 1.65582s 2.06465s [[ -n $TRAVIS ]] && skip - run clo.ezfio -534.263560525680 -534.256601571199 -534.062020844428 + run clo.ezfio -534.2635737789097 -534.2566081298855 -534.0620070783308 } @test "SO" { # 1.9667s 2.91234s @@ -69,7 +69,7 @@ function run() { @test "OH" { # 2.201s 2.65573s [[ -n $TRAVIS ]] && skip - run oh.ezfio -75.4314648243896 -75.4254639668256 -75.2707675632313 + run oh.ezfio -75.4314822573358 -75.4254733392003 -75.2707586997333 } @test "H2O2" { # 2.27079s 3.07875s @@ -109,7 +109,7 @@ function run() { @test "DHNO" { # 6.42976s 12.9899s [[ -n $TRAVIS ]] && skip - run dhno.ezfio -130.4472288472718 -130.3571808164850 -130.2196257046987 + run dhno.ezfio -130.447238897118 -130.357186843611 -130.219626716369 } @test "CH4" { # 6.4969s 10.9157s @@ -129,7 +129,7 @@ function run() { @test "[Cu(NH3)4]2+" { # 29.7711s 3.45478m [[ -n ${TRAVIS} ]] && skip - run cu_nh3_4_2plus.ezfio -1862.97958885180 -1862.92457657404 -1862.91134959451 + run cu_nh3_4_2plus.ezfio -1862.97958844302 -1862.92454785007 -1862.91130869967 } diff --git a/src/cisd/30.cisd.bats b/src/cisd/30.cisd.bats index 6b8fddb6..5ec11e4b 100644 --- a/src/cisd/30.cisd.bats +++ b/src/cisd/30.cisd.bats @@ -8,10 +8,9 @@ function run() { test_exe cisd || skip qp edit --check qp set determinants n_states 2 - qp set davidson threshold_davidson 1.e-12 - qp set davidson n_states_diag 24 - qp run cis - qp run cisd + qp set davidson_keywords threshold_davidson 1.e-12 + qp set davidson_keywords n_states_diag 24 + qp run cisd energy1="$(qp get cisd energy | tr '[]' ' ' | cut -d ',' -f 1)" energy2="$(qp get cisd energy | tr '[]' ' ' | cut -d ',' -f 2)" eq $energy1 $1 $thresh @@ -19,7 +18,7 @@ function run() { } -@test "B-B" { # +@test "B-B" { # qp set_file b2_stretched.ezfio qp set_frozen_core run -49.120607088648597 -49.055152453388231 @@ -34,7 +33,7 @@ function run() { @test "HBO" { # 4.42968s 19.6099s qp set_file hbo.ezfio qp set_frozen_core - run -100.2019254455993 -99.79484127741013 + run -100.2019254455993 -99.79484127741013 } @test "HCO" { # 6.6077s 28.6801s @@ -46,7 +45,7 @@ function run() { @test "H2O" { # 7.0651s 30.6642s qp set_file h2o.ezfio qp set_frozen_core - run -76.22975602077072 -75.80609108747208 + run -76.22975602077072 -75.80609108747208 } @@ -78,7 +77,7 @@ function run() { [[ -n $TRAVIS ]] && skip qp set_file oh.ezfio qp set_frozen_core - run -75.6087472926588 -75.5370393736601 + run -75.6088105201621 -75.5370802925698 } @test "CH4" { # 19.821s 1.38648m @@ -105,8 +104,9 @@ function run() { @test "DHNO" { # 24.7077s 1.46487m [[ -n $TRAVIS ]] && skip qp set_file dhno.ezfio - qp set_mo_class --core="[1-7]" --act="[8-64]" - run -130.458814562403 -130.356308303681 + qp set_mo_class --core="[1-7]" --act="[8-64]" + run -130.4659881027444 -130.2692384198501 +# run -130.458814562403 -130.356308303681 } @test "H3COH" { # 24.7248s 1.85043m @@ -120,7 +120,7 @@ function run() { [[ -n $TRAVIS ]] && skip qp set_file cu_nh3_4_2plus.ezfio qp set_mo_class --core="[1-24]" --act="[25-45]" --del="[46-87]" - run -1862.98689579931 -1862.6883044626563 + run -1862.98310702274 -1862.88506319755 } @@ -135,14 +135,14 @@ function run() { [[ -n $TRAVIS ]] && skip qp set_file c2h2.ezfio qp set_mo_class --act="[1-30]" --del="[31-36]" - run -12.3566731164213 -11.9495394759914 + run -12.3566731164213 -11.9495394759914 } @test "ClO" { # 37.6949s [[ -n $TRAVIS ]] && skip qp set_file clo.ezfio qp set_frozen_core - run -534.5404021326773 -534.3818725793897 + run -534.540464615019 -534.381904487587 } @test "F2" { # 45.2078s @@ -155,7 +155,7 @@ function run() { @test "SO2" { # 47.6922s [[ -n $TRAVIS ]] && skip qp set_file so2.ezfio - qp set_mo_class --core="[1-8]" --act="[9-87]" + qp set_mo_class --core="[1-8]" --act="[9-87]" run -41.5746738710350 -41.3800467740750 } @@ -177,7 +177,7 @@ function run() { [[ -n $TRAVIS ]] && skip qp set_file n2.ezfio qp set_mo_class --core="[1,2]" --act="[3-40]" --del="[41-60]" - run -109.275693633982 -108.757794570948 + run -109.275693633982 -108.757794570948 } @test "HCN" { # 133.8696s diff --git a/src/davidson/diagonalization_hs2_dressed.irp.f b/src/davidson/diagonalization_hs2_dressed.irp.f index 7b559925..1ead9d78 100644 --- a/src/davidson/diagonalization_hs2_dressed.irp.f +++ b/src/davidson/diagonalization_hs2_dressed.irp.f @@ -286,7 +286,7 @@ subroutine davidson_diag_hjj_sjj(dets_in,u_in,H_jj,s2_out,energies,dim_in,sze,N_ ! Small h(N_st_diag*itermax,N_st_diag*itermax), & - h_p(N_st_diag*itermax,N_st_diag*itermax), & +! h_p(N_st_diag*itermax,N_st_diag*itermax), & y(N_st_diag*itermax,N_st_diag*itermax), & s_(N_st_diag*itermax,N_st_diag*itermax), & s_tmp(N_st_diag*itermax,N_st_diag*itermax), & @@ -340,7 +340,10 @@ subroutine davidson_diag_hjj_sjj(dets_in,u_in,H_jj,s2_out,energies,dim_in,sze,N_ exit endif - do iter=1,itermax-1 + iter = 0 + do while (iter < itermax-1) + iter += 1 +! do iter=1,itermax-1 shift = N_st_diag*(iter-1) shift2 = N_st_diag*iter @@ -430,30 +433,30 @@ subroutine davidson_diag_hjj_sjj(dets_in,u_in,H_jj,s2_out,energies,dim_in,sze,N_ call dgemm('T','N', shift2, shift2, sze, & 1.d0, U, size(U,1), W, size(W,1), & - 0.d0, h, size(h_p,1)) + 0.d0, h, size(h,1)) call dgemm('T','N', shift2, shift2, sze, & 1.d0, U, size(U,1), U, size(U,1), & 0.d0, s_tmp, size(s_tmp,1)) - ! Penalty method - ! -------------- - - if (s2_eig) then - h_p = s_ - do k=1,shift2 - h_p(k,k) = h_p(k,k) - expected_s2 - enddo - if (only_expected_s2) then - alpha = 0.1d0 - h_p = h + alpha*h_p - else - alpha = 0.0001d0 - h_p = h + alpha*h_p - endif - else - h_p = h - alpha = 0.d0 - endif +! ! Penalty method +! ! -------------- +! +! if (s2_eig) then +! h_p = s_ +! do k=1,shift2 +! h_p(k,k) = h_p(k,k) - expected_s2 +! enddo +! if (only_expected_s2) then +! alpha = 0.1d0 +! h_p = h + alpha*h_p +! else +! alpha = 0.0001d0 +! h_p = h + alpha*h_p +! endif +! else +! h_p = h +! alpha = 0.d0 +! endif ! Diagonalize h_p ! --------------- @@ -473,8 +476,10 @@ subroutine davidson_diag_hjj_sjj(dets_in,u_in,H_jj,s2_out,energies,dim_in,sze,N_ call dsygv(1,'V','U',shift2,y,size(y,1), & s_tmp,size(s_tmp,1), lambda, work,lwork,info) deallocate(work) - if (info /= 0) then - stop 'DSYGV Diagonalization failed' + if (info > 0) then + ! Numerical errors propagate. We need to reduce the number of iterations + itermax = iter-1 + exit endif ! Compute Energy for each eigenvector diff --git a/src/determinants/density_matrix.irp.f b/src/determinants/density_matrix.irp.f index af035a2a..6ea6b051 100644 --- a/src/determinants/density_matrix.irp.f +++ b/src/determinants/density_matrix.irp.f @@ -523,3 +523,101 @@ subroutine get_occupation_from_dets(istate,occupation) enddo end +BEGIN_PROVIDER [double precision, difference_dm, (mo_num, mo_num, N_states)] + implicit none + BEGIN_DOC +! difference_dm(i,j,istate) = dm(i,j,1) - dm(i,j,istate) + END_DOC + integer :: istate + do istate = 1, N_states + difference_dm(:,:,istate) = one_e_dm_mo_alpha(:,:,1) + one_e_dm_mo_beta(:,:,1) & + - (one_e_dm_mo_alpha(:,:,istate) + one_e_dm_mo_beta(:,:,istate)) + enddo +END_PROVIDER + + BEGIN_PROVIDER [double precision, difference_dm_eigvect, (mo_num, mo_num, N_states) ] +&BEGIN_PROVIDER [double precision, difference_dm_eigval, (mo_num, N_states) ] + implicit none + BEGIN_DOC +! eigenvalues and eigevenctors of the difference_dm + END_DOC + integer :: istate,i + do istate = 2, N_states + call lapack_diag(difference_dm_eigval(1,istate),difference_dm_eigvect(1,1,istate)& + ,difference_dm(1,1,istate),mo_num,mo_num) + print*,'Eigenvalues of difference_dm for state ',istate + do i = 1, mo_num + print*,i,difference_dm_eigval(i,istate) + enddo + enddo +END_PROVIDER + + BEGIN_PROVIDER [ integer , n_attachment, (N_states)] +&BEGIN_PROVIDER [ integer , n_dettachment, (N_states)] +&BEGIN_PROVIDER [ integer , list_attachment, (mo_num,N_states)] +&BEGIN_PROVIDER [ integer , list_dettachment, (mo_num,N_states)] + implicit none + integer :: i,istate + integer :: list_attachment_tmp(mo_num) + n_attachment = 0 + n_dettachment = 0 + do istate = 2, N_states + do i = 1, mo_num + if(difference_dm_eigval(i,istate).lt.0.d0)then ! dettachment_orbitals + n_dettachment(istate) += 1 + list_dettachment(n_dettachment(istate),istate) = i ! they are already sorted + else + n_attachment(istate) += 1 + list_attachment_tmp(n_attachment(istate)) = i ! they are not sorted + endif + enddo + ! sorting the attachment + do i = 0, n_attachment(istate) - 1 + list_attachment(i+1,istate) = list_attachment_tmp(n_attachment(istate) - i) + enddo + enddo + +END_PROVIDER + + BEGIN_PROVIDER [ double precision, attachment_numbers_sorted, (mo_num, N_states)] +&BEGIN_PROVIDER [ double precision, dettachment_numbers_sorted, (mo_num, N_states)] + implicit none + integer :: i,istate + do istate = 2, N_states + print*,'dettachment' + do i = 1, n_dettachment(istate) + dettachment_numbers_sorted(i,istate) = difference_dm_eigval(list_dettachment(i,istate),istate) + print*,i,list_dettachment(i,istate),dettachment_numbers_sorted(i,istate) + enddo + print*,'attachment' + do i = 1, n_attachment(istate) + attachment_numbers_sorted(i,istate) = difference_dm_eigval(list_attachment(i,istate),istate) + print*,i,list_attachment(i,istate),attachment_numbers_sorted(i,istate) + enddo + enddo + END_PROVIDER + + BEGIN_PROVIDER [ double precision, attachment_orbitals, (ao_num, mo_num, N_states)] +&BEGIN_PROVIDER [ double precision, dettachment_orbitals, (ao_num, mo_num, N_states)] + implicit none + integer :: i,j,k,istate + attachment_orbitals = 0.d0 + dettachment_orbitals = 0.d0 + do istate = 2, N_states + do i = 1, n_dettachment(istate) + do j = 1, mo_num + do k = 1, ao_num + dettachment_orbitals(k,list_dettachment(i,istate),istate) += mo_coef(k,j) * difference_dm_eigvect(j,list_dettachment(i,istate),istate) + enddo + enddo + enddo + do i = 1, n_attachment(istate) + do j = 1, mo_num + do k = 1, ao_num + attachment_orbitals(k,i,istate) += mo_coef(k,j) * difference_dm_eigvect(j,list_attachment(i,istate),istate) + enddo + enddo + enddo + enddo + +END_PROVIDER diff --git a/src/determinants/dipole_moments.irp.f b/src/determinants/dipole_moments.irp.f index e445c56b..dae04369 100644 --- a/src/determinants/dipole_moments.irp.f +++ b/src/determinants/dipole_moments.irp.f @@ -26,10 +26,10 @@ enddo enddo -! print*,'electron part for z_dipole = ',z_dipole_moment -! print*,'electron part for y_dipole = ',y_dipole_moment -! print*,'electron part for x_dipole = ',x_dipole_moment -! + print*,'electron part for z_dipole = ',z_dipole_moment + print*,'electron part for y_dipole = ',y_dipole_moment + print*,'electron part for x_dipole = ',x_dipole_moment + nuclei_part_z = 0.d0 nuclei_part_y = 0.d0 nuclei_part_x = 0.d0 @@ -38,10 +38,10 @@ nuclei_part_y += nucl_charge(i) * nucl_coord(i,2) nuclei_part_x += nucl_charge(i) * nucl_coord(i,1) enddo -! print*,'nuclei part for z_dipole = ',nuclei_part_z -! print*,'nuclei part for y_dipole = ',nuclei_part_y -! print*,'nuclei part for x_dipole = ',nuclei_part_x -! + print*,'nuclei part for z_dipole = ',nuclei_part_z + print*,'nuclei part for y_dipole = ',nuclei_part_y + print*,'nuclei part for x_dipole = ',nuclei_part_x + do istate = 1, N_states z_dipole_moment(istate) += nuclei_part_z y_dipole_moment(istate) += nuclei_part_y diff --git a/src/dft_one_e/NEED b/src/dft_one_e/NEED index 615ee97e..667859a5 100644 --- a/src/dft_one_e/NEED +++ b/src/dft_one_e/NEED @@ -4,6 +4,4 @@ mo_one_e_ints mo_two_e_ints ao_one_e_ints ao_two_e_ints -mo_two_e_erf_ints -ao_two_e_erf_ints mu_of_r diff --git a/src/dft_one_e/mu_erf_dft.irp.f b/src/dft_one_e/mu_erf_dft.irp.f index 0b870564..08779f0e 100644 --- a/src/dft_one_e/mu_erf_dft.irp.f +++ b/src/dft_one_e/mu_erf_dft.irp.f @@ -3,7 +3,7 @@ BEGIN_PROVIDER [double precision, mu_erf_dft] BEGIN_DOC ! range separation parameter used in RS-DFT. ! -! It is set to mu_erf in order to be consistent with the module "ao_two_e_erf_ints" +! It is set to mu_erf in order to be consistent with the module "hamiltonian" END_DOC mu_erf_dft = mu_erf diff --git a/src/dft_utils_func/on_top_from_ueg.irp.f b/src/dft_utils_func/on_top_from_ueg.irp.f index 5b964a03..4e28ad89 100644 --- a/src/dft_utils_func/on_top_from_ueg.irp.f +++ b/src/dft_utils_func/on_top_from_ueg.irp.f @@ -146,3 +146,51 @@ end end subroutine g0_dg0 + subroutine g0_dg0_d2g0(rho, rho_a, rho_b, g0, dg0drho, d2g0drho2) + + implicit none + BEGIN_DOC + ! Give the on-top pair distribution function g0 second derivative according to rho d2g0drho2 + END_DOC + + double precision, intent (in) :: rho, rho_a, rho_b + double precision, intent (out) :: g0, dg0drho, d2g0drho2 + double precision :: pi + double precision :: g0_UEG_mu_inf, dg0drs, d2g0drs2, d2rsdrho2 + double precision :: C1, F1, D1, E1, B1, rs + + pi = dacos(-1.d0) + C1 = 0.0819306d0 + F1 = 0.752411d0 + D1 = -0.0127713d0 + E1 = 0.00185898d0 + B1 = 0.7317d0 - F1 + if(dabs(rho).gt.1.d-20)then + rs = (3.d0 / (4.d0*pi*rho))**(1.d0/3.d0) + else + rs = (3.d0 / (4.d0*pi*1.d-20))**(1.d0/3.d0) + endif + + g0 = g0_UEG_mu_inf(rho_a, rho_b) + if(dabs(F1*rs).lt.50.d0)then + dg0drs = 0.5d0*((-B1 + 2.d0*C1*rs + 3.d0*D1*rs**2 + 4.d0*E1*rs**3)-F1*(1.d0 - B1*rs + C1*rs**2 + D1*rs**3 + E1*rs**4))*dexp(-F1*rs) + d2g0drs2 = 0.5d0*((2.d0*C1 + 6.d0*D1*rs + 12*E1*rs**2) - 2.d0*F1*(-B1 + 2.d0*C1*rs + 3.d0*D1*rs**2 + 4.d0*E1*rs**3)& + &+ (F1**2)*(1.d0 - B1*rs + C1*rs**2 + D1*rs**3 + E1*rs**4))*dexp(-F1*rs) + else + dg0drs = 0.d0 + d2g0drs2 = 0.d0 + endif + + if(dabs(rho).gt.1.d-20)then + dg0drho = -((6.d0*dsqrt(pi)*rho**2)**(-2.d0/3.d0))*dg0drs + d2rsdrho2 = -8.d0*dsqrt(pi)*rho*(6.d0*dsqrt(pi)*rho**2)**(-5.d0/3.d0) + d2g0drho2 = dg0drho*d2rsdrho2 -((6.d0*dsqrt(pi)*rho**2)**(-4.d0/3.d0))*d2g0drs2 + else + dg0drho = -((6.d0*dsqrt(pi)*1.d-40)**(-2.d0/3.d0))*dg0drs + d2rsdrho2 = -8.d0*dsqrt(pi)*(1.d-20)*(6.d0*dsqrt(pi)*1.d-40)**(-5.d0/3.d0) + d2g0drho2 = dg0drho*d2rsdrho2 - ((6.d0*dsqrt(pi)*1.d-40)**(-4.d0/3.d0))*d2g0drs2 + endif + + end subroutine g0_dg0 + + diff --git a/src/dummy/NEED b/src/dummy/NEED index 3d5eb1f7..1dcb7a25 100644 --- a/src/dummy/NEED +++ b/src/dummy/NEED @@ -1,6 +1,5 @@ ao_basis ao_one_e_ints -ao_two_e_erf_ints ao_two_e_ints aux_quantities becke_numerical_grid @@ -24,13 +23,13 @@ functionals generators_cas generators_full hartree_fock +hamiltonian iterations kohn_sham kohn_sham_rs mo_basis mo_guess mo_one_e_ints -mo_two_e_erf_ints mo_two_e_ints mpi nuclei diff --git a/src/ezfio_files/00.create.bats b/src/ezfio_files/00.create.bats index 49430a0b..f1751c6e 100644 --- a/src/ezfio_files/00.create.bats +++ b/src/ezfio_files/00.create.bats @@ -53,7 +53,6 @@ function run { @test "B-B" { - qp set_file b2_stretched.ezfio run b2_stretched.zmt 1 0 6-31g } diff --git a/src/ezfio_files/ezfio.irp.f b/src/ezfio_files/ezfio.irp.f index 7e414a04..02f45571 100644 --- a/src/ezfio_files/ezfio.irp.f +++ b/src/ezfio_files/ezfio.irp.f @@ -33,6 +33,8 @@ BEGIN_PROVIDER [ character*(1024), ezfio_filename ] call ezfio_set_file(ezfio_filename) +IRP_IF MACOS +IRP_ELSE ! Adjust out-of-memory killer flag such that the current process will be ! killed first by the OOM killer, allowing compute nodes to survive integer :: getpid @@ -40,6 +42,7 @@ BEGIN_PROVIDER [ character*(1024), ezfio_filename ] write(pidc,*) getpid() write(command,*) 'echo 15 > /proc//'//trim(adjustl(pidc))//'/oom_adj' call system(command) +IRP_ENDIF PROVIDE file_lock diff --git a/src/fci/fci.irp.f b/src/fci/fci.irp.f index bb2a93f8..2059a53b 100644 --- a/src/fci/fci.irp.f +++ b/src/fci/fci.irp.f @@ -41,8 +41,10 @@ program fci write(json_unit,json_array_open_fmt) 'fci' + double precision, allocatable :: Ev(:),PT2(:) + allocate(Ev(N_states), PT2(N_states)) if (do_pt2) then - call run_stochastic_cipsi + call run_stochastic_cipsi(Ev,PT2) else call run_cipsi endif diff --git a/src/hamiltonian/EZFIO.cfg b/src/hamiltonian/EZFIO.cfg new file mode 100644 index 00000000..672bfdfa --- /dev/null +++ b/src/hamiltonian/EZFIO.cfg @@ -0,0 +1,8 @@ +[mu_erf] +type: double precision +doc: cutting of the interaction in the range separated model +interface: ezfio,provider,ocaml +default: 0.5 +ezfio_name: mu_erf + + diff --git a/src/hamiltonian/NEED b/src/hamiltonian/NEED new file mode 100644 index 00000000..e69de29b diff --git a/src/hamiltonian/README.rst b/src/hamiltonian/README.rst new file mode 100644 index 00000000..c237f8d2 --- /dev/null +++ b/src/hamiltonian/README.rst @@ -0,0 +1,5 @@ +=========== +hamiltonian +=========== + +Parameters of the Hamiltonian. diff --git a/src/hartree_fock/10.hf.bats b/src/hartree_fock/10.hf.bats index 6e7d0233..b496a089 100644 --- a/src/hartree_fock/10.hf.bats +++ b/src/hartree_fock/10.hf.bats @@ -39,7 +39,7 @@ rm -rf $EZFIO qp create_ezfio -b def2-svp hcn.xyz -o $EZFIO qp run scf mv hcn_charges.xyz ${EZFIO}_point_charges.xyz -python write_pt_charges.py ${EZFIO} +python3 write_pt_charges.py ${EZFIO} qp set nuclei point_charges True qp run scf | tee ${EZFIO}.pt_charges.out energy="$(ezfio get hartree_fock energy)" diff --git a/src/hartree_fock/fock_matrix_hf.irp.f b/src/hartree_fock/fock_matrix_hf.irp.f index a5ab6a60..65b3d63c 100644 --- a/src/hartree_fock/fock_matrix_hf.irp.f +++ b/src/hartree_fock/fock_matrix_hf.irp.f @@ -174,7 +174,6 @@ END_PROVIDER allocate (X(cholesky_ao_num)) - ! X(j) = \sum_{mn} SCF_density_matrix_ao(m,n) * cholesky_ao(m,n,j) call dgemm('T','N',cholesky_ao_num,1,ao_num*ao_num,1.d0, & cholesky_ao, ao_num*ao_num, & diff --git a/src/iterations/print_extrapolation.irp.f b/src/iterations/print_extrapolation.irp.f index a7f85693..24c9845f 100644 --- a/src/iterations/print_extrapolation.irp.f +++ b/src/iterations/print_extrapolation.irp.f @@ -37,7 +37,7 @@ subroutine print_extrapolated_energy write(*,*) 'minimum PT2 ', 'Extrapolated energy ', ' Excitation (a.u) ', ' Excitation (eV) ' write(*,*) '=========== ', '=================== ', '=================== ', '===================' do k=2,N_iter_p - write(*,'(F11.4,X,3(X,F18.8))') pt2_iterations(i,k), extrapolated_energy(k,i), & + write(*,'(F11.4,X,3(X,F18.8))') pt2_iterations(i,N_iter_p+1-k), extrapolated_energy(k,i), & extrapolated_energy(k,i) - extrapolated_energy(k,1), & (extrapolated_energy(k,i) - extrapolated_energy(k,1) ) * 27.211396641308d0 enddo diff --git a/src/kohn_sham_rs/61.rsks.bats b/src/kohn_sham_rs/61.rsks.bats index 90b82142..29d43c3b 100644 --- a/src/kohn_sham_rs/61.rsks.bats +++ b/src/kohn_sham_rs/61.rsks.bats @@ -13,7 +13,7 @@ function run() { qp set scf_utils thresh_scf 1.e-10 qp set dft_keywords exchange_functional $functional qp set dft_keywords correlation_functional $functional - qp set ao_two_e_erf_ints mu_erf 0.5 + qp set hamiltonian mu_erf 0.5 qp set becke_numerical_grid grid_type_sgn 1 qp_reset --mos $1 qp run rs_ks_scf diff --git a/src/mo_optimization/cipsi_orb_opt.irp.f b/src/mo_optimization/cipsi_orb_opt.irp.f index ae3aa1bf..7e3a79eb 100644 --- a/src/mo_optimization/cipsi_orb_opt.irp.f +++ b/src/mo_optimization/cipsi_orb_opt.irp.f @@ -11,11 +11,13 @@ subroutine run_optimization implicit none double precision :: e_cipsi, e_opt, delta_e + double precision, allocatable :: Ev(:),PT2(:) integer :: nb_iter,i logical :: not_converged character (len=100) :: filename PROVIDE psi_det psi_coef mo_two_e_integrals_in_map ao_pseudo_integrals + allocate(Ev(N_states),PT2(N_states)) not_converged = .True. nb_iter = 0 @@ -38,7 +40,7 @@ subroutine run_optimization print*,'' print*,'********** cipsi step **********' ! cispi calculation - call run_stochastic_cipsi + call run_stochastic_cipsi(Ev,PT2) ! State average energy after the cipsi step call state_average_energy(e_cipsi) diff --git a/src/mo_two_e_erf_ints/EZFIO.cfg b/src/mo_two_e_erf_ints/EZFIO.cfg deleted file mode 100644 index 57137e65..00000000 --- a/src/mo_two_e_erf_ints/EZFIO.cfg +++ /dev/null @@ -1,6 +0,0 @@ -[io_mo_two_e_integrals_erf] -type: Disk_access -doc: Read/Write MO integrals with the long range interaction from/to disk [ Write | Read | None ] -interface: ezfio,provider,ocaml -default: None - diff --git a/src/mo_two_e_erf_ints/NEED b/src/mo_two_e_erf_ints/NEED deleted file mode 100644 index 7adb17a1..00000000 --- a/src/mo_two_e_erf_ints/NEED +++ /dev/null @@ -1,3 +0,0 @@ -ao_two_e_erf_ints -mo_two_e_ints -mo_basis diff --git a/src/mo_two_e_erf_ints/README.rst b/src/mo_two_e_erf_ints/README.rst deleted file mode 100644 index b118e0c7..00000000 --- a/src/mo_two_e_erf_ints/README.rst +++ /dev/null @@ -1,20 +0,0 @@ -====================== -mo_two_e_erf_ints -====================== - -Here, all two-electron integrals (:math:`erf({\mu}_{erf} * r_{12})/r_{12}`) are computed. -As they have 4 indices and many are zero, they are stored in a map, as defined -in :file:`Utils/map_module.f90`. - -The range separation parameter :math:`{\mu}_{erf}` is the variable :option:`ao_two_e_erf_ints mu_erf`. - -To fetch an |MO| integral, use -`get_mo_two_e_integral_erf(i,j,k,l,mo_integrals_map_erf)` - -The conventions are: - -* For |MO| integrals : = <12|12> - -Be aware that it might not be the same conventions for |MO| and |AO| integrals. - - diff --git a/src/mo_two_e_ints/EZFIO.cfg b/src/mo_two_e_ints/EZFIO.cfg index ea47c51c..088a2416 100644 --- a/src/mo_two_e_ints/EZFIO.cfg +++ b/src/mo_two_e_ints/EZFIO.cfg @@ -17,3 +17,10 @@ doc: If `True`, computes all integrals except for the integrals having 3 or 4 vi interface: ezfio,provider,ocaml default: false +[io_mo_two_e_integrals_erf] +type: Disk_access +doc: Read/Write MO integrals with the long range interaction from/to disk [ Write | Read | None ] +interface: ezfio,provider,ocaml +default: None + + diff --git a/src/mo_two_e_erf_ints/core_quantities_erf.irp.f b/src/mo_two_e_ints/core_quantities_erf.irp.f similarity index 100% rename from src/mo_two_e_erf_ints/core_quantities_erf.irp.f rename to src/mo_two_e_ints/core_quantities_erf.irp.f diff --git a/src/mo_two_e_erf_ints/ints_erf_3_index.irp.f b/src/mo_two_e_ints/ints_erf_3_index.irp.f similarity index 100% rename from src/mo_two_e_erf_ints/ints_erf_3_index.irp.f rename to src/mo_two_e_ints/ints_erf_3_index.irp.f diff --git a/src/mo_two_e_erf_ints/map_integrals_erf.irp.f b/src/mo_two_e_ints/map_integrals_erf.irp.f similarity index 100% rename from src/mo_two_e_erf_ints/map_integrals_erf.irp.f rename to src/mo_two_e_ints/map_integrals_erf.irp.f diff --git a/src/mo_two_e_erf_ints/mo_bi_integrals_erf.irp.f b/src/mo_two_e_ints/mo_bi_integrals_erf.irp.f similarity index 80% rename from src/mo_two_e_erf_ints/mo_bi_integrals_erf.irp.f rename to src/mo_two_e_ints/mo_bi_integrals_erf.irp.f index e009b7d9..a1910fd4 100644 --- a/src/mo_two_e_erf_ints/mo_bi_integrals_erf.irp.f +++ b/src/mo_two_e_ints/mo_bi_integrals_erf.irp.f @@ -9,27 +9,27 @@ subroutine mo_two_e_integrals_erf_index(i,j,k,l,i1) integer(key_kind) :: p,q,r,s,i2 p = min(i,k) r = max(i,k) - p = p+ishft(r*r-r,-1) + p = p+shiftr(r*r-r,1) q = min(j,l) s = max(j,l) - q = q+ishft(s*s-s,-1) + q = q+shiftr(s*s-s,1) i1 = min(p,q) i2 = max(p,q) - i1 = i1+ishft(i2*i2-i2,-1) + i1 = i1+shiftr(i2*i2-i2,1) end BEGIN_PROVIDER [ logical, mo_two_e_integrals_erf_in_map ] use map_module implicit none - integer(bit_kind) :: mask_ijkl(N_int,4) - integer(bit_kind) :: mask_ijk(N_int,3) - BEGIN_DOC ! If True, the map of MO two-electron integrals is provided END_DOC + integer(bit_kind) :: mask_ijkl(N_int,4) + integer(bit_kind) :: mask_ijk(N_int,3) + double precision :: cpu_1, cpu_2, wall_1, wall_2 - real :: map_mb + PROVIDE mo_class mo_two_e_integrals_erf_in_map = .True. if (read_mo_two_e_integrals_erf) then @@ -37,29 +37,138 @@ BEGIN_PROVIDER [ logical, mo_two_e_integrals_erf_in_map ] call map_load_from_disk(trim(ezfio_filename)//'/work/mo_ints_erf',mo_integrals_erf_map) print*, 'MO integrals_erf provided' return - else - PROVIDE ao_two_e_integrals_erf_in_map endif - ! call four_index_transform_block(ao_integrals_erf_map,mo_integrals_erf_map, & - ! mo_coef, size(mo_coef,1), & - ! 1, 1, 1, 1, ao_num, ao_num, ao_num, ao_num, & - ! 1, 1, 1, 1, mo_num, mo_num, mo_num, mo_num) - call add_integrals_to_map_erf(full_ijkl_bitmask_4) - integer*8 :: get_mo_erf_map_size, mo_erf_map_size - mo_erf_map_size = get_mo_erf_map_size() + PROVIDE ao_two_e_integrals_erf_in_map -! print*,'Molecular integrals ERF provided:' -! print*,' Size of MO ERF map ', map_mb(mo_integrals_erf_map) ,'MB' -! print*,' Number of MO ERF integrals: ', mo_erf_map_size - if (write_mo_two_e_integrals_erf) then + print *, '' + print *, 'AO -> MO ERF integrals transformation' + print *, '-------------------------------------' + print *, '' + + call wall_time(wall_1) + call cpu_time(cpu_1) + + if (dble(ao_num)**4 * 32.d-9 < dble(qp_max_mem)) then + call four_idx_dgemm_erf + else + call add_integrals_to_map_erf(full_ijkl_bitmask_4) + endif + + call wall_time(wall_2) + call cpu_time(cpu_2) + + integer*8 :: get_mo_erf_map_size, mo_erf_map_size + mo_erf_map_size = get_mo_erf_map_size() + + double precision, external :: map_mb + print*,'Molecular integrals provided:' + print*,' Size of MO map ', map_mb(mo_integrals_erf_map) ,'MB' + print*,' Number of MO integrals: ', mo_erf_map_size + print*,' cpu time :',cpu_2 - cpu_1, 's' + print*,' wall time :',wall_2 - wall_1, 's ( x ', (cpu_2-cpu_1)/(wall_2-wall_1), ')' + + if (write_mo_two_e_integrals_erf.and.mpi_master) then call ezfio_set_work_empty(.False.) call map_save_to_disk(trim(ezfio_filename)//'/work/mo_ints_erf',mo_integrals_erf_map) - call ezfio_set_mo_two_e_erf_ints_io_mo_two_e_integrals_erf("Read") + call ezfio_set_mo_two_e_ints_io_mo_two_e_integrals_erf('Read') endif END_PROVIDER +subroutine four_idx_dgemm_erf + implicit none + integer :: p,q,r,s,i,j,k,l + double precision, allocatable :: a1(:,:,:,:) + double precision, allocatable :: a2(:,:,:,:) + + if (ao_num > 1289) then + print *, irp_here, ': Integer overflow in ao_num**3' + endif + + allocate (a1(ao_num,ao_num,ao_num,ao_num)) + + print *, 'Getting AOs' + !$OMP PARALLEL DO DEFAULT(SHARED) PRIVATE(q,r,s) + do s=1,ao_num + do r=1,ao_num + do q=1,ao_num + call get_ao_two_e_integrals_erf(q,r,s,ao_num,a1(1,q,r,s)) + enddo + enddo + enddo + !$OMP END PARALLEL DO + + + print *, '1st transformation' + ! 1st transformation + allocate (a2(ao_num,ao_num,ao_num,mo_num)) + call dgemm('T','N', (ao_num*ao_num*ao_num), mo_num, ao_num, 1.d0, a1, ao_num, mo_coef, ao_num, 0.d0, a2, (ao_num*ao_num*ao_num)) + + ! 2nd transformation + print *, '2nd transformation' + deallocate (a1) + allocate (a1(ao_num,ao_num,mo_num,mo_num)) + call dgemm('T','N', (ao_num*ao_num*mo_num), mo_num, ao_num, 1.d0, a2, ao_num, mo_coef, ao_num, 0.d0, a1, (ao_num*ao_num*mo_num)) + + ! 3rd transformation + print *, '3rd transformation' + deallocate (a2) + allocate (a2(ao_num,mo_num,mo_num,mo_num)) + call dgemm('T','N', (ao_num*mo_num*mo_num), mo_num, ao_num, 1.d0, a1, ao_num, mo_coef, ao_num, 0.d0, a2, (ao_num*mo_num*mo_num)) + + ! 4th transformation + print *, '4th transformation' + deallocate (a1) + allocate (a1(mo_num,mo_num,mo_num,mo_num)) + call dgemm('T','N', (mo_num*mo_num*mo_num), mo_num, ao_num, 1.d0, a2, ao_num, mo_coef, ao_num, 0.d0, a1, (mo_num*mo_num*mo_num)) + + deallocate (a2) + + integer :: n_integrals, size_buffer + integer(key_kind) , allocatable :: buffer_i(:) + real(integral_kind), allocatable :: buffer_value(:) + size_buffer = min(ao_num*ao_num*ao_num,16000000) + + !$OMP PARALLEL DEFAULT(SHARED) PRIVATE(i,j,k,l,buffer_value,buffer_i,n_integrals) + allocate ( buffer_i(size_buffer), buffer_value(size_buffer) ) + + n_integrals = 0 + !$OMP DO + do l=1,mo_num + do k=1,mo_num + do j=1,l + do i=1,k + if (abs(a1(i,j,k,l)) < mo_integrals_threshold) then + cycle + endif + n_integrals += 1 + buffer_value(n_integrals) = a1(i,j,k,l) + !DIR$ FORCEINLINE + call mo_two_e_integrals_index(i,j,k,l,buffer_i(n_integrals)) + if (n_integrals == size_buffer) then + call map_append(mo_integrals_erf_map, buffer_i, buffer_value, n_integrals) + n_integrals = 0 + endif + enddo + enddo + enddo + enddo + !$OMP END DO + + call map_append(mo_integrals_erf_map, buffer_i, buffer_value, n_integrals) + + deallocate(buffer_i, buffer_value) + !$OMP END PARALLEL + + deallocate (a1) + + call map_sort(mo_integrals_erf_map) + call map_unique(mo_integrals_erf_map) + +end subroutine + + BEGIN_PROVIDER [ double precision, mo_two_e_int_erf_jj_from_ao, (mo_num,mo_num) ] &BEGIN_PROVIDER [ double precision, mo_two_e_int_erf_jj_exchange_from_ao, (mo_num,mo_num) ] diff --git a/src/mo_two_e_erf_ints/routines_save_integrals_erf.irp.f b/src/mo_two_e_ints/routines_save_integrals_erf.irp.f similarity index 88% rename from src/mo_two_e_erf_ints/routines_save_integrals_erf.irp.f rename to src/mo_two_e_ints/routines_save_integrals_erf.irp.f index 52fb8f63..9915b206 100644 --- a/src/mo_two_e_erf_ints/routines_save_integrals_erf.irp.f +++ b/src/mo_two_e_ints/routines_save_integrals_erf.irp.f @@ -4,7 +4,7 @@ subroutine save_erf_two_e_integrals_mo PROVIDE mo_two_e_integrals_erf_in_map call ezfio_set_work_empty(.False.) call map_save_to_disk(trim(ezfio_filename)//'/work/mo_ints_erf',mo_integrals_erf_map) - call ezfio_set_mo_two_e_erf_ints_io_mo_two_e_integrals_erf('Read') + call ezfio_set_mo_two_e_ints_io_mo_two_e_integrals_erf('Read') end diff --git a/src/mu_of_r/EZFIO.cfg b/src/mu_of_r/EZFIO.cfg index c774ec82..a66b00ef 100644 --- a/src/mu_of_r/EZFIO.cfg +++ b/src/mu_of_r/EZFIO.cfg @@ -6,7 +6,7 @@ size: (becke_numerical_grid.n_points_final_grid,determinants.n_states) [mu_of_r_potential] type: character*(32) -doc: type of potential for the mu(r) interaction: can be [ hf| cas_ful | cas_truncated | pure_act] +doc: type of potential for the mu(r) interaction: can be [ hf| cas_full | cas_truncated | pure_act] interface: ezfio, provider, ocaml default: hf diff --git a/src/mu_of_r/mu_of_r_conditions.irp.f b/src/mu_of_r/mu_of_r_conditions.irp.f index f9c3b3b3..6b49b9df 100644 --- a/src/mu_of_r/mu_of_r_conditions.irp.f +++ b/src/mu_of_r/mu_of_r_conditions.irp.f @@ -26,7 +26,7 @@ do ipoint = 1, n_points_final_grid if(mu_of_r_potential.EQ."hf")then mu_of_r_prov(ipoint,istate) = mu_of_r_hf(ipoint) - else if(mu_of_r_potential.EQ."cas_ful".or.mu_of_r_potential.EQ."cas_truncated".or.mu_of_r_potential.EQ."pure_act")then + else if(mu_of_r_potential.EQ."cas_full".or.mu_of_r_potential.EQ."cas_truncated".or.mu_of_r_potential.EQ."pure_act")then mu_of_r_prov(ipoint,istate) = mu_of_r_psi_cas(ipoint,istate) else print*,'you requested the following mu_of_r_potential' @@ -128,7 +128,7 @@ BEGIN_PROVIDER [double precision, mu_average_prov, (N_states)] implicit none BEGIN_DOC - ! average value of mu(r) weighted with the total one-e density and divised by the number of electrons + ! average value of mu(r) weighted with the total one-e density and divided by the number of electrons ! ! !!!!!! WARNING !!!!!! if no_core_density == .True. then all contributions from the core orbitals ! diff --git a/src/mu_of_r/test_proj_op.irp.f b/src/mu_of_r/test_proj_op.irp.f index 1d46da5e..f9aba094 100644 --- a/src/mu_of_r/test_proj_op.irp.f +++ b/src/mu_of_r/test_proj_op.irp.f @@ -9,7 +9,7 @@ program projected_operators ! orbitals coming from core no_core_density = .True. touch no_core_density - mu_of_r_potential = "cas_ful" + mu_of_r_potential = "cas_full" touch mu_of_r_potential print*,'Using Valence Only functions' ! call test_f_HF_valence_ab diff --git a/src/nuclei/EZFIO.cfg b/src/nuclei/EZFIO.cfg index 060eede6..20c63932 100644 --- a/src/nuclei/EZFIO.cfg +++ b/src/nuclei/EZFIO.cfg @@ -5,7 +5,7 @@ interface: ezfio, provider [nucl_label] doc: Nuclear labels -type: character*(32) +type: character*(32) size: (nuclei.nucl_num) interface: ezfio, provider @@ -17,7 +17,7 @@ interface: ezfio, provider [nucl_coord] doc: Nuclear coordinates in the format (:, {x,y,z}) -type: double precision +type: double precision size: (nuclei.nucl_num,3) interface: ezfio @@ -37,11 +37,12 @@ type: logical doc: If true, the calculation uses periodic boundary conditions interface: ezfio, provider, ocaml default: false + [n_pts_charge] type: integer doc: Number of point charges to be added to the potential interface: ezfio -default: 0 +default: 0 [pts_charge_z] type: double precision diff --git a/src/nuclei/write_pt_charges.py b/src/nuclei/write_pt_charges.py index f5007090..910f03aa 100644 --- a/src/nuclei/write_pt_charges.py +++ b/src/nuclei/write_pt_charges.py @@ -1,4 +1,4 @@ -#!/usr/bin/env python +#!/usr/bin/env python3 import os import sys @@ -52,7 +52,7 @@ fncharges.write(" "+str(n_charges)+'\n') fncharges.close() mv_in_ezfio(EZFIO,tmp) -# Write the file containing the charges and set in EZFIO folder +# Write the file containing the charges and set in EZFIO folder tmp="pts_charge_z" fcharges = open(tmp,'w') fcharges.write(" 1\n") diff --git a/src/scf_utils/roothaan_hall_scf.irp.f b/src/scf_utils/roothaan_hall_scf.irp.f index cf006035..730cb496 100644 --- a/src/scf_utils/roothaan_hall_scf.irp.f +++ b/src/scf_utils/roothaan_hall_scf.irp.f @@ -199,6 +199,7 @@ END_DOC write(6,*) if (converged) then write(6,*) 'SCF converged' + call sleep(1) ! When too fast, the MOs aren't saved. endif diff --git a/src/tc_bi_ortho/normal_ordered.irp.f b/src/tc_bi_ortho/normal_ordered.irp.f deleted file mode 100644 index ca5875c9..00000000 --- a/src/tc_bi_ortho/normal_ordered.irp.f +++ /dev/null @@ -1,1971 +0,0 @@ - -! --- - -BEGIN_PROVIDER [ double precision, normal_two_body_bi_orth_v0, (mo_num, mo_num, mo_num, mo_num)] - - BEGIN_DOC - ! Normal ordering of the three body interaction on the HF density - END_DOC - - use bitmasks ! you need to include the bitmasks_module.f90 features - - implicit none - - integer :: i, ii, h1, p1, h2, p2, ipoint - integer :: hh1, hh2, pp1, pp2 - integer :: Ne(2) - double precision :: wall0, wall1, walli, wallf - integer, allocatable :: occ(:,:) - integer(bit_kind), allocatable :: key_i_core(:,:) - - print*,' Providing normal_two_body_bi_orth_v0 ...' - call wall_time(walli) - - if(read_tc_norm_ord) then - - open(unit=11, form="unformatted", file=trim(ezfio_filename)//'/work/normal_two_body_bi_orth_v0', action="read") - read(11) normal_two_body_bi_orth_v0 - close(11) - - else - - double precision, allocatable :: tmp_2d(:,:), tmp_3d(:,:,:) - double precision, allocatable :: tmp1(:,:,:), tmp2(:,:), tmp3(:,:,:) - double precision, allocatable :: tmpval_1(:), tmpval_2(:), tmpvec_1(:,:), tmpvec_2(:,:), tmpvec_3(:,:) - double precision, allocatable :: tmp(:,:,:,:) - - PROVIDE N_int - - allocate( occ(N_int*bit_kind_size,2) ) - allocate( key_i_core(N_int,2) ) - - if(core_tc_op) then - do i = 1, N_int - key_i_core(i,1) = xor(ref_bitmask(i,1), core_bitmask(i,1)) - key_i_core(i,2) = xor(ref_bitmask(i,2), core_bitmask(i,2)) - enddo - call bitstring_to_list_ab(key_i_core, occ, Ne, N_int) - else - call bitstring_to_list_ab(ref_bitmask, occ, Ne, N_int) - endif - - allocate(tmp(mo_num,mo_num,mo_num,mo_num)) - - ! --- - ! aba contraction - - print*,' Providing aba_contraction ...' - call wall_time(wall0) - - tmp = 0.d0 - - allocate(tmp_3d(mo_num,mo_num,mo_num)) - allocate(tmp1(n_points_final_grid,3,mo_num)) - allocate(tmp2(n_points_final_grid,mo_num)) - allocate(tmpval_1(n_points_final_grid)) - allocate(tmpval_2(n_points_final_grid)) - allocate(tmpvec_1(n_points_final_grid,3)) - allocate(tmpvec_2(n_points_final_grid,3)) - allocate(tmp_2d(mo_num,mo_num)) - - ! purely closed shell part - do ii = 1, Ne(2) - i = occ(ii,2) - - ! to avoid tmp(N^4) - do h1 = 1, mo_num - - ! to minimize the number of operations - !$OMP PARALLEL & - !$OMP DEFAULT (NONE) & - !$OMP PRIVATE (ipoint) & - !$OMP SHARED (n_points_final_grid, i, h1, & - !$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 tmpval_1, tmpval_2, tmpvec_1, tmpvec_2) - !$OMP DO - do ipoint = 1, n_points_final_grid - tmpval_1(ipoint) = final_weight_at_r_vector(ipoint) * mos_l_in_r_array_transp(ipoint,i) * mos_r_in_r_array_transp(ipoint, i) - tmpval_2(ipoint) = final_weight_at_r_vector(ipoint) * mos_l_in_r_array_transp(ipoint,i) * mos_r_in_r_array_transp(ipoint,h1) - tmpvec_1(ipoint,1) = final_weight_at_r_vector(ipoint) * int2_grad1_u12_bimo_t(ipoint,1,i, i) * mos_r_in_r_array_transp(ipoint,h1) - tmpvec_1(ipoint,2) = final_weight_at_r_vector(ipoint) * int2_grad1_u12_bimo_t(ipoint,2,i, i) * mos_r_in_r_array_transp(ipoint,h1) - tmpvec_1(ipoint,3) = final_weight_at_r_vector(ipoint) * int2_grad1_u12_bimo_t(ipoint,3,i, i) * mos_r_in_r_array_transp(ipoint,h1) - tmpvec_2(ipoint,1) = final_weight_at_r_vector(ipoint) * int2_grad1_u12_bimo_t(ipoint,1,i,h1) * mos_r_in_r_array_transp(ipoint, i) - tmpvec_2(ipoint,2) = final_weight_at_r_vector(ipoint) * int2_grad1_u12_bimo_t(ipoint,2,i,h1) * mos_r_in_r_array_transp(ipoint, i) - tmpvec_2(ipoint,3) = final_weight_at_r_vector(ipoint) * int2_grad1_u12_bimo_t(ipoint,3,i,h1) * mos_r_in_r_array_transp(ipoint, i) - enddo - !$OMP END DO - !$OMP END PARALLEL - - !$OMP PARALLEL & - !$OMP DEFAULT (NONE) & - !$OMP PRIVATE (p1, ipoint) & - !$OMP SHARED (mo_num, n_points_final_grid, h1, i, & - !$OMP mos_l_in_r_array_transp, int2_grad1_u12_bimo_t, & - !$OMP tmpval_1, tmpval_2, tmpvec_1, tmpvec_2, tmp1) - !$OMP DO - do p1 = 1, mo_num - do ipoint = 1, n_points_final_grid - tmp1(ipoint,1,p1) = mos_l_in_r_array_transp(ipoint,p1) * (tmpvec_1(ipoint,1) - tmpvec_2(ipoint,1)) & - + tmpval_1(ipoint) * int2_grad1_u12_bimo_t(ipoint,1,p1,h1) - tmpval_2(ipoint) * int2_grad1_u12_bimo_t(ipoint,1,p1,i) - tmp1(ipoint,2,p1) = mos_l_in_r_array_transp(ipoint,p1) * (tmpvec_1(ipoint,2) - tmpvec_2(ipoint,2)) & - + tmpval_1(ipoint) * int2_grad1_u12_bimo_t(ipoint,2,p1,h1) - tmpval_2(ipoint) * int2_grad1_u12_bimo_t(ipoint,2,p1,i) - tmp1(ipoint,3,p1) = mos_l_in_r_array_transp(ipoint,p1) * (tmpvec_1(ipoint,3) - tmpvec_2(ipoint,3)) & - + tmpval_1(ipoint) * int2_grad1_u12_bimo_t(ipoint,3,p1,h1) - tmpval_2(ipoint) * int2_grad1_u12_bimo_t(ipoint,3,p1,i) - enddo - enddo - !$OMP END DO - !$OMP END PARALLEL - - call dgemm( 'T', 'N', mo_num*mo_num, mo_num, 3*n_points_final_grid, 1.d0 & - , int2_grad1_u12_bimo_t(1,1,1,1), 3*n_points_final_grid & - , tmp1(1,1,1), 3*n_points_final_grid & - , 0.d0, tmp_3d(1,1,1), mo_num*mo_num) - - !$OMP PARALLEL DO PRIVATE(p1,h2,p2) - do p1 = 1, mo_num - do h2 = 1, mo_num - do p2 = 1, mo_num - tmp(p2,h2,p1,h1) = tmp(p2,h2,p1,h1) + tmp_3d(p2,h2,p1) - enddo - enddo - enddo - !$OMP END PARALLEL DO - - ! to avoid tmp(N^4) - do p1 = 1, mo_num - - ! to minimize the number of operations - !$OMP PARALLEL & - !$OMP DEFAULT (NONE) & - !$OMP PRIVATE (ipoint) & - !$OMP SHARED (n_points_final_grid, i, h1, p1, & - !$OMP int2_grad1_u12_bimo_t, final_weight_at_r_vector, & - !$OMP tmpval_1) - !$OMP DO - do ipoint = 1, n_points_final_grid - tmpval_1(ipoint) = final_weight_at_r_vector(ipoint) * ( int2_grad1_u12_bimo_t(ipoint,1, i,i) * int2_grad1_u12_bimo_t(ipoint,1,p1,h1) & - + int2_grad1_u12_bimo_t(ipoint,2, i,i) * int2_grad1_u12_bimo_t(ipoint,2,p1,h1) & - + int2_grad1_u12_bimo_t(ipoint,3, i,i) * int2_grad1_u12_bimo_t(ipoint,3,p1,h1) & - - int2_grad1_u12_bimo_t(ipoint,1,p1,i) * int2_grad1_u12_bimo_t(ipoint,1, i,h1) & - - int2_grad1_u12_bimo_t(ipoint,2,p1,i) * int2_grad1_u12_bimo_t(ipoint,2, i,h1) & - - int2_grad1_u12_bimo_t(ipoint,3,p1,i) * int2_grad1_u12_bimo_t(ipoint,3, i,h1) ) - enddo - !$OMP END DO - !$OMP END PARALLEL - - !$OMP PARALLEL & - !$OMP DEFAULT (NONE) & - !$OMP PRIVATE (h2, ipoint) & - !$OMP SHARED (mo_num, n_points_final_grid, & - !$OMP mos_r_in_r_array_transp, & - !$OMP tmpval_1, tmp2) - !$OMP DO - do h2 = 1, mo_num - do ipoint = 1, n_points_final_grid - tmp2(ipoint,h2) = mos_r_in_r_array_transp(ipoint,h2) * tmpval_1(ipoint) - enddo - enddo - !$OMP END DO - !$OMP END PARALLEL - - call dgemm( 'T', 'N', mo_num, mo_num, n_points_final_grid, 1.d0 & - , mos_l_in_r_array_transp(1,1), n_points_final_grid & - , tmp2(1,1), n_points_final_grid & - , 0.d0, tmp_2d(1,1), mo_num) - - !$OMP PARALLEL DO PRIVATE(h2,p2) - do h2 = 1, mo_num - do p2 = 1, mo_num - tmp(p2,h2,p1,h1) = tmp(p2,h2,p1,h1) + tmp_2d(p2,h2) - enddo - enddo - !$OMP END PARALLEL DO - - enddo ! p1 - enddo ! h1 - enddo ! i - - ! purely open-shell part - if(Ne(2) < Ne(1)) then - do ii = Ne(2) + 1, Ne(1) - i = occ(ii,1) - - do h1 = 1, mo_num - - !$OMP PARALLEL & - !$OMP DEFAULT (NONE) & - !$OMP PRIVATE (ipoint) & - !$OMP SHARED (n_points_final_grid, i, h1, & - !$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 tmpval_1, tmpval_2, tmpvec_1, tmpvec_2) - !$OMP DO - do ipoint = 1, n_points_final_grid - tmpval_1(ipoint) = final_weight_at_r_vector(ipoint) * mos_l_in_r_array_transp(ipoint,i) * mos_r_in_r_array_transp(ipoint, i) - tmpval_2(ipoint) = final_weight_at_r_vector(ipoint) * mos_l_in_r_array_transp(ipoint,i) * mos_r_in_r_array_transp(ipoint,h1) - tmpvec_1(ipoint,1) = final_weight_at_r_vector(ipoint) * int2_grad1_u12_bimo_t(ipoint,1,i, i) * mos_r_in_r_array_transp(ipoint,h1) - tmpvec_1(ipoint,2) = final_weight_at_r_vector(ipoint) * int2_grad1_u12_bimo_t(ipoint,2,i, i) * mos_r_in_r_array_transp(ipoint,h1) - tmpvec_1(ipoint,3) = final_weight_at_r_vector(ipoint) * int2_grad1_u12_bimo_t(ipoint,3,i, i) * mos_r_in_r_array_transp(ipoint,h1) - tmpvec_2(ipoint,1) = final_weight_at_r_vector(ipoint) * int2_grad1_u12_bimo_t(ipoint,1,i,h1) * mos_r_in_r_array_transp(ipoint, i) - tmpvec_2(ipoint,2) = final_weight_at_r_vector(ipoint) * int2_grad1_u12_bimo_t(ipoint,2,i,h1) * mos_r_in_r_array_transp(ipoint, i) - tmpvec_2(ipoint,3) = final_weight_at_r_vector(ipoint) * int2_grad1_u12_bimo_t(ipoint,3,i,h1) * mos_r_in_r_array_transp(ipoint, i) - enddo - !$OMP END DO - !$OMP END PARALLEL - - !$OMP PARALLEL & - !$OMP DEFAULT (NONE) & - !$OMP PRIVATE (p1, ipoint) & - !$OMP SHARED (mo_num, n_points_final_grid, h1, i, & - !$OMP mos_l_in_r_array_transp, int2_grad1_u12_bimo_t, & - !$OMP tmpval_1, tmpval_2, tmpvec_1, tmpvec_2, tmp1) - !$OMP DO - do p1 = 1, mo_num - do ipoint = 1, n_points_final_grid - tmp1(ipoint,1,p1) = mos_l_in_r_array_transp(ipoint,p1) * (tmpvec_1(ipoint,1) - tmpvec_2(ipoint,1)) & - + tmpval_1(ipoint) * int2_grad1_u12_bimo_t(ipoint,1,p1,h1) - tmpval_2(ipoint) * int2_grad1_u12_bimo_t(ipoint,1,p1,i) - tmp1(ipoint,2,p1) = mos_l_in_r_array_transp(ipoint,p1) * (tmpvec_1(ipoint,2) - tmpvec_2(ipoint,2)) & - + tmpval_1(ipoint) * int2_grad1_u12_bimo_t(ipoint,2,p1,h1) - tmpval_2(ipoint) * int2_grad1_u12_bimo_t(ipoint,2,p1,i) - tmp1(ipoint,3,p1) = mos_l_in_r_array_transp(ipoint,p1) * (tmpvec_1(ipoint,3) - tmpvec_2(ipoint,3)) & - + tmpval_1(ipoint) * int2_grad1_u12_bimo_t(ipoint,3,p1,h1) - tmpval_2(ipoint) * int2_grad1_u12_bimo_t(ipoint,3,p1,i) - enddo - enddo - !$OMP END DO - !$OMP END PARALLEL - - call dgemm( 'T', 'N', mo_num*mo_num, mo_num, 3*n_points_final_grid, 0.5d0 & - , int2_grad1_u12_bimo_t(1,1,1,1), 3*n_points_final_grid & - , tmp1(1,1,1), 3*n_points_final_grid & - , 0.d0, tmp_3d(1,1,1), mo_num*mo_num) - - !$OMP PARALLEL DO PRIVATE(p1,h2,p2) - do p1 = 1, mo_num - do h2 = 1, mo_num - do p2 = 1, mo_num - tmp(p2,h2,p1,h1) = tmp(p2,h2,p1,h1) + tmp_3d(p2,h2,p1) - enddo - enddo - enddo - !$OMP END PARALLEL DO - - do p1 = 1, mo_num - - ! to minimize the number of operations - !$OMP PARALLEL & - !$OMP DEFAULT (NONE) & - !$OMP PRIVATE (ipoint) & - !$OMP SHARED (n_points_final_grid, i, h1, p1, & - !$OMP int2_grad1_u12_bimo_t, final_weight_at_r_vector, & - !$OMP tmpval_1) - !$OMP DO - do ipoint = 1, n_points_final_grid - tmpval_1(ipoint) = final_weight_at_r_vector(ipoint) * ( int2_grad1_u12_bimo_t(ipoint,1, i,i) * int2_grad1_u12_bimo_t(ipoint,1,p1,h1) & - + int2_grad1_u12_bimo_t(ipoint,2, i,i) * int2_grad1_u12_bimo_t(ipoint,2,p1,h1) & - + int2_grad1_u12_bimo_t(ipoint,3, i,i) * int2_grad1_u12_bimo_t(ipoint,3,p1,h1) & - - int2_grad1_u12_bimo_t(ipoint,1,p1,i) * int2_grad1_u12_bimo_t(ipoint,1, i,h1) & - - int2_grad1_u12_bimo_t(ipoint,2,p1,i) * int2_grad1_u12_bimo_t(ipoint,2, i,h1) & - - int2_grad1_u12_bimo_t(ipoint,3,p1,i) * int2_grad1_u12_bimo_t(ipoint,3, i,h1) ) - enddo - !$OMP END DO - !$OMP END PARALLEL - - !$OMP PARALLEL & - !$OMP DEFAULT (NONE) & - !$OMP PRIVATE (h2, ipoint) & - !$OMP SHARED (mo_num, n_points_final_grid, & - !$OMP mos_r_in_r_array_transp, & - !$OMP tmpval_1, tmp2) - !$OMP DO - do h2 = 1, mo_num - do ipoint = 1, n_points_final_grid - tmp2(ipoint,h2) = mos_r_in_r_array_transp(ipoint,h2) * tmpval_1(ipoint) - enddo - enddo - !$OMP END DO - !$OMP END PARALLEL - - call dgemm( 'T', 'N', mo_num, mo_num, n_points_final_grid, 0.5d0 & - , mos_l_in_r_array_transp(1,1), n_points_final_grid & - , tmp2(1,1), n_points_final_grid & - , 0.d0, tmp_2d(1,1), mo_num) - - !$OMP PARALLEL DO PRIVATE(h2,p2) - do h2 = 1, mo_num - do p2 = 1, mo_num - tmp(p2,h2,p1,h1) = tmp(p2,h2,p1,h1) + tmp_2d(p2,h2) - enddo - enddo - !$OMP END PARALLEL DO - - enddo ! p1 - enddo ! h1 - enddo !i - endif - - deallocate(tmp_3d) - deallocate(tmp1) - deallocate(tmp2) - deallocate(tmpval_1) - deallocate(tmpval_2) - deallocate(tmpvec_1) - deallocate(tmpvec_2) - deallocate(tmp_2d) - - tmp = -0.5d0 * tmp - call sum_A_At(tmp(1,1,1,1), mo_num*mo_num) - - call wall_time(wall1) - print*,' Wall time for aba_contraction', wall1-wall0 - - normal_two_body_bi_orth_v0 = tmp - - ! --- - ! aab contraction - - print*,' Providing aab_contraction ...' - call wall_time(wall0) - - tmp = 0.d0 - - allocate(tmp_2d(mo_num,mo_num)) - allocate(tmp_3d(mo_num,mo_num,mo_num)) - allocate(tmp1(n_points_final_grid,3,mo_num)) - allocate(tmp2(n_points_final_grid,mo_num)) - allocate(tmpval_1(n_points_final_grid)) - allocate(tmpvec_1(n_points_final_grid,3)) - - ! purely closed shell part - do ii = 1, Ne(2) - i = occ(ii,2) - - ! to avoid tmp(N^4) - do h1 = 1, mo_num - - ! to minimize the number of operations - !$OMP PARALLEL & - !$OMP DEFAULT (NONE) & - !$OMP PRIVATE (ipoint) & - !$OMP SHARED (n_points_final_grid, i, h1, & - !$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 tmpval_1, tmpvec_1) - !$OMP DO - do ipoint = 1, n_points_final_grid - tmpval_1(ipoint) = final_weight_at_r_vector(ipoint) * mos_l_in_r_array_transp(ipoint,i) * mos_r_in_r_array_transp(ipoint,i) - tmpvec_1(ipoint,1) = final_weight_at_r_vector(ipoint) * int2_grad1_u12_bimo_t(ipoint,1,i,i) * mos_r_in_r_array_transp(ipoint,h1) - tmpvec_1(ipoint,2) = final_weight_at_r_vector(ipoint) * int2_grad1_u12_bimo_t(ipoint,2,i,i) * mos_r_in_r_array_transp(ipoint,h1) - tmpvec_1(ipoint,3) = final_weight_at_r_vector(ipoint) * int2_grad1_u12_bimo_t(ipoint,3,i,i) * mos_r_in_r_array_transp(ipoint,h1) - enddo - !$OMP END DO - !$OMP END PARALLEL - - !$OMP PARALLEL & - !$OMP DEFAULT (NONE) & - !$OMP PRIVATE (p1, ipoint) & - !$OMP SHARED (mo_num, n_points_final_grid, h1, i, & - !$OMP mos_l_in_r_array_transp, int2_grad1_u12_bimo_t, & - !$OMP tmpval_1, tmpvec_1, tmp1) - !$OMP DO - do p1 = 1, mo_num - do ipoint = 1, n_points_final_grid - tmp1(ipoint,1,p1) = mos_l_in_r_array_transp(ipoint,p1) * tmpvec_1(ipoint,1) + tmpval_1(ipoint) * int2_grad1_u12_bimo_t(ipoint,1,p1,h1) - tmp1(ipoint,2,p1) = mos_l_in_r_array_transp(ipoint,p1) * tmpvec_1(ipoint,2) + tmpval_1(ipoint) * int2_grad1_u12_bimo_t(ipoint,2,p1,h1) - tmp1(ipoint,3,p1) = mos_l_in_r_array_transp(ipoint,p1) * tmpvec_1(ipoint,3) + tmpval_1(ipoint) * int2_grad1_u12_bimo_t(ipoint,3,p1,h1) - enddo - enddo - !$OMP END DO - !$OMP END PARALLEL - - call dgemm( 'T', 'N', mo_num*mo_num, mo_num, 3*n_points_final_grid, 1.d0 & - , int2_grad1_u12_bimo_t(1,1,1,1), 3*n_points_final_grid & - , tmp1(1,1,1), 3*n_points_final_grid & - , 0.d0, tmp_3d(1,1,1), mo_num*mo_num) - - !$OMP PARALLEL DO PRIVATE(p1,h2,p2) - do p1 = 1, mo_num - do h2 = 1, mo_num - do p2 = 1, mo_num - tmp(p2,h2,p1,h1) = tmp(p2,h2,p1,h1) + tmp_3d(p2,h2,p1) - enddo - enddo - enddo - !$OMP END PARALLEL DO - - ! to avoid tmp(N^4) - do p1 = 1, mo_num - - ! to minimize the number of operations - !$OMP PARALLEL & - !$OMP DEFAULT (NONE) & - !$OMP PRIVATE (ipoint) & - !$OMP SHARED (n_points_final_grid, i, h1, p1, & - !$OMP int2_grad1_u12_bimo_t, final_weight_at_r_vector, & - !$OMP tmpval_1) - !$OMP DO - do ipoint = 1, n_points_final_grid - tmpval_1(ipoint) = final_weight_at_r_vector(ipoint) * ( int2_grad1_u12_bimo_t(ipoint,1,i,i) * int2_grad1_u12_bimo_t(ipoint,1,p1,h1) & - + int2_grad1_u12_bimo_t(ipoint,2,i,i) * int2_grad1_u12_bimo_t(ipoint,2,p1,h1) & - + int2_grad1_u12_bimo_t(ipoint,3,i,i) * int2_grad1_u12_bimo_t(ipoint,3,p1,h1) ) - enddo - !$OMP END DO - !$OMP END PARALLEL - - !$OMP PARALLEL & - !$OMP DEFAULT (NONE) & - !$OMP PRIVATE (h2, ipoint) & - !$OMP SHARED (mo_num, n_points_final_grid, & - !$OMP mos_r_in_r_array_transp, & - !$OMP tmpval_1, tmp2) - !$OMP DO - do h2 = 1, mo_num - do ipoint = 1, n_points_final_grid - tmp2(ipoint,h2) = mos_r_in_r_array_transp(ipoint,h2) * tmpval_1(ipoint) - enddo - enddo - !$OMP END DO - !$OMP END PARALLEL - - call dgemm( 'T', 'N', mo_num, mo_num, n_points_final_grid, 1.d0 & - , mos_l_in_r_array_transp(1,1), n_points_final_grid & - , tmp2(1,1), n_points_final_grid & - , 0.d0, tmp_2d(1,1), mo_num) - - !$OMP PARALLEL DO PRIVATE(h2,p2) - do h2 = 1, mo_num - do p2 = 1, mo_num - tmp(p2,h2,p1,h1) = tmp(p2,h2,p1,h1) + tmp_2d(p2,h2) - enddo - enddo - !$OMP END PARALLEL DO - - enddo ! p1 - enddo ! h1 - enddo ! i - - deallocate(tmp_2d) - deallocate(tmp_3d) - deallocate(tmp1) - deallocate(tmp2) - deallocate(tmpval_1) - deallocate(tmpvec_1) - - tmp = -0.5d0 * tmp - - !$OMP PARALLEL & - !$OMP DEFAULT (NONE) & - !$OMP PRIVATE (h1, h2, p1, p2) & - !$OMP SHARED (tmp, mo_num) - - !$OMP DO - do h1 = 1, mo_num - do h2 = 1, mo_num - do p1 = 1, mo_num - do p2 = p1, mo_num - tmp(p2,h2,p1,h1) -= tmp(p1,h2,p2,h1) - enddo - enddo - enddo - enddo - !$OMP END DO - - !$OMP DO - do h1 = 1, mo_num - do h2 = 1, mo_num - do p1 = 2, mo_num - do p2 = 1, p1-1 - tmp(p2,h2,p1,h1) = -tmp(p1,h2,p2,h1) - enddo - enddo - enddo - enddo - !$OMP END DO - - !$OMP DO - do h1 = 1, mo_num-1 - do h2 = h1+1, mo_num - do p1 = 2, mo_num - do p2 = 1, p1-1 - tmp(p2,h2,p1,h1) *= -1.d0 - enddo - enddo - enddo - enddo - !$OMP END DO - !$OMP END PARALLEL - - call wall_time(wall1) - print*,' Wall time for aab_contraction', wall1-wall0 - - normal_two_body_bi_orth_v0 += tmp - - ! --- - ! aaa contraction - - if(Ne(2) .ge. 3) then - - print*,' Providing aaa_contraction ...' - call wall_time(wall0) - - tmp = 0.d0 - - allocate(tmp_2d(mo_num,mo_num)) - allocate(tmp_3d(mo_num,mo_num,mo_num)) - allocate(tmp1(n_points_final_grid,3,mo_num)) - allocate(tmp2(n_points_final_grid,mo_num)) - allocate(tmp3(n_points_final_grid,3,mo_num)) - allocate(tmpval_1(n_points_final_grid)) - allocate(tmpval_2(n_points_final_grid)) - allocate(tmpvec_1(n_points_final_grid,3)) - allocate(tmpvec_2(n_points_final_grid,3)) - allocate(tmpvec_3(n_points_final_grid,3)) - - ! purely closed shell part - do ii = 1, Ne(2) - i = occ(ii,2) - - ! to avoid tmp(N^4) - do h1 = 1, mo_num - - ! to minimize the number of operations - !$OMP PARALLEL & - !$OMP DEFAULT (NONE) & - !$OMP PRIVATE (ipoint) & - !$OMP SHARED (n_points_final_grid, i, h1, & - !$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 tmpval_1, tmpval_2, tmpvec_1, tmpvec_2 ) - !$OMP DO - do ipoint = 1, n_points_final_grid - - tmpval_1(ipoint) = final_weight_at_r_vector(ipoint) * mos_l_in_r_array_transp(ipoint,i) * mos_r_in_r_array_transp(ipoint,i) - - tmpval_2(ipoint) = final_weight_at_r_vector(ipoint) * mos_l_in_r_array_transp(ipoint,i) * mos_r_in_r_array_transp(ipoint,h1) - - tmpvec_1(ipoint,1) = final_weight_at_r_vector(ipoint) * int2_grad1_u12_bimo_t(ipoint,1,i,i) * mos_r_in_r_array_transp(ipoint,h1) - tmpvec_1(ipoint,2) = final_weight_at_r_vector(ipoint) * int2_grad1_u12_bimo_t(ipoint,2,i,i) * mos_r_in_r_array_transp(ipoint,h1) - tmpvec_1(ipoint,3) = final_weight_at_r_vector(ipoint) * int2_grad1_u12_bimo_t(ipoint,3,i,i) * mos_r_in_r_array_transp(ipoint,h1) - - tmpvec_2(ipoint,1) = final_weight_at_r_vector(ipoint) * int2_grad1_u12_bimo_t(ipoint,1,i,h1) * mos_r_in_r_array_transp(ipoint,i) - tmpvec_2(ipoint,2) = final_weight_at_r_vector(ipoint) * int2_grad1_u12_bimo_t(ipoint,2,i,h1) * mos_r_in_r_array_transp(ipoint,i) - tmpvec_2(ipoint,3) = final_weight_at_r_vector(ipoint) * int2_grad1_u12_bimo_t(ipoint,3,i,h1) * mos_r_in_r_array_transp(ipoint,i) - enddo - !$OMP END DO - !$OMP END PARALLEL - - !$OMP PARALLEL & - !$OMP DEFAULT (NONE) & - !$OMP PRIVATE (p1, ipoint) & - !$OMP SHARED (mo_num, n_points_final_grid, h1, i, & - !$OMP mos_l_in_r_array_transp, int2_grad1_u12_bimo_t, & - !$OMP tmpval_1, tmpvec_1, tmp1) - !$OMP DO - do p1 = 1, mo_num - do ipoint = 1, n_points_final_grid - tmp1(ipoint,1,p1) = mos_l_in_r_array_transp(ipoint,p1) * tmpvec_1(ipoint,1) + tmpval_1(ipoint) * int2_grad1_u12_bimo_t(ipoint,1,p1,h1) - tmp1(ipoint,2,p1) = mos_l_in_r_array_transp(ipoint,p1) * tmpvec_1(ipoint,2) + tmpval_1(ipoint) * int2_grad1_u12_bimo_t(ipoint,2,p1,h1) - tmp1(ipoint,3,p1) = mos_l_in_r_array_transp(ipoint,p1) * tmpvec_1(ipoint,3) + tmpval_1(ipoint) * int2_grad1_u12_bimo_t(ipoint,3,p1,h1) - enddo - enddo - !$OMP END DO - !$OMP END PARALLEL - - call dgemm( 'T', 'N', mo_num*mo_num, mo_num, 3*n_points_final_grid, 1.d0 & - , int2_grad1_u12_bimo_t(1,1,1,1), 3*n_points_final_grid & - , tmp1(1,1,1), 3*n_points_final_grid & - , 0.d0, tmp_3d(1,1,1), mo_num*mo_num) - - !$OMP PARALLEL DO PRIVATE(p1,h2,p2) - do p1 = 1, mo_num - do h2 = 1, mo_num - do p2 = 1, mo_num - tmp(p2,h2,p1,h1) = tmp(p2,h2,p1,h1) + tmp_3d(p2,h2,p1) - enddo - enddo - enddo - !$OMP END PARALLEL DO - - !$OMP PARALLEL & - !$OMP DEFAULT (NONE) & - !$OMP PRIVATE (p2, ipoint) & - !$OMP SHARED (mo_num, n_points_final_grid, h1, i, & - !$OMP mos_l_in_r_array_transp, int2_grad1_u12_bimo_t, & - !$OMP tmpval_2, tmpvec_2, tmp1) - !$OMP DO - do p2 = 1, mo_num - do ipoint = 1, n_points_final_grid - tmp1(ipoint,1,p2) = tmpval_2(ipoint) * int2_grad1_u12_bimo_t(ipoint,1,p2,i) + mos_l_in_r_array_transp(ipoint,p2) * tmpvec_2(ipoint,1) - tmp1(ipoint,2,p2) = tmpval_2(ipoint) * int2_grad1_u12_bimo_t(ipoint,2,p2,i) + mos_l_in_r_array_transp(ipoint,p2) * tmpvec_2(ipoint,2) - tmp1(ipoint,3,p2) = tmpval_2(ipoint) * int2_grad1_u12_bimo_t(ipoint,3,p2,i) + mos_l_in_r_array_transp(ipoint,p2) * tmpvec_2(ipoint,3) - enddo - enddo - !$OMP END DO - !$OMP END PARALLEL - - call dgemm( 'T', 'N', mo_num, mo_num*mo_num, 3*n_points_final_grid, 1.d0 & - , tmp1(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_3d(1,1,1), mo_num) - - !$OMP PARALLEL DO PRIVATE(p1,h2,p2) - do p1 = 1, mo_num - do h2 = 1, mo_num - do p2 = 1, mo_num - tmp(p2,h2,p1,h1) = tmp(p2,h2,p1,h1) + tmp_3d(p2,p1,h2) - enddo - enddo - enddo - !$OMP END PARALLEL DO - - ! to avoid tmp(N^4) - do p1 = 1, mo_num - - !$OMP PARALLEL & - !$OMP DEFAULT (NONE) & - !$OMP PRIVATE (ipoint) & - !$OMP SHARED (n_points_final_grid, i, h1, p1, & - !$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 tmpval_1, tmpval_2, tmpvec_1, tmpvec_2, tmpvec_3) - !$OMP DO - do ipoint = 1, n_points_final_grid - - tmpval_1(ipoint) = final_weight_at_r_vector(ipoint) * & - ( int2_grad1_u12_bimo_t(ipoint,1,i,i) * int2_grad1_u12_bimo_t(ipoint,1,p1,h1) & - + int2_grad1_u12_bimo_t(ipoint,2,i,i) * int2_grad1_u12_bimo_t(ipoint,2,p1,h1) & - + int2_grad1_u12_bimo_t(ipoint,3,i,i) * int2_grad1_u12_bimo_t(ipoint,3,p1,h1) ) - - tmpval_2(ipoint) = final_weight_at_r_vector(ipoint) * mos_l_in_r_array_transp(ipoint,p1) * mos_r_in_r_array_transp(ipoint,i) - - tmpvec_1(ipoint,1) = final_weight_at_r_vector(ipoint) * int2_grad1_u12_bimo_t(ipoint,1,p1,i) * mos_r_in_r_array_transp(ipoint,h1) - tmpvec_1(ipoint,2) = final_weight_at_r_vector(ipoint) * int2_grad1_u12_bimo_t(ipoint,2,p1,i) * mos_r_in_r_array_transp(ipoint,h1) - tmpvec_1(ipoint,3) = final_weight_at_r_vector(ipoint) * int2_grad1_u12_bimo_t(ipoint,3,p1,i) * mos_r_in_r_array_transp(ipoint,h1) - - tmpvec_2(ipoint,1) = final_weight_at_r_vector(ipoint) * int2_grad1_u12_bimo_t(ipoint,1,i,h1) * mos_l_in_r_array_transp(ipoint,p1) - tmpvec_2(ipoint,2) = final_weight_at_r_vector(ipoint) * int2_grad1_u12_bimo_t(ipoint,2,i,h1) * mos_l_in_r_array_transp(ipoint,p1) - tmpvec_2(ipoint,3) = final_weight_at_r_vector(ipoint) * int2_grad1_u12_bimo_t(ipoint,3,i,h1) * mos_l_in_r_array_transp(ipoint,p1) - - tmpvec_3(ipoint,1) = final_weight_at_r_vector(ipoint) * int2_grad1_u12_bimo_t(ipoint,1,p1,i) * mos_l_in_r_array_transp(ipoint,i) - tmpvec_3(ipoint,2) = final_weight_at_r_vector(ipoint) * int2_grad1_u12_bimo_t(ipoint,2,p1,i) * mos_l_in_r_array_transp(ipoint,i) - tmpvec_3(ipoint,3) = final_weight_at_r_vector(ipoint) * int2_grad1_u12_bimo_t(ipoint,3,p1,i) * mos_l_in_r_array_transp(ipoint,i) - enddo - !$OMP END DO - !$OMP END PARALLEL - - !$OMP PARALLEL & - !$OMP DEFAULT (NONE) & - !$OMP PRIVATE (h2, ipoint) & - !$OMP SHARED (mo_num, n_points_final_grid, i, & - !$OMP mos_r_in_r_array_transp, & - !$OMP int2_grad1_u12_bimo_t, & - !$OMP tmp1, tmp2, tmpval_1, tmpval_2, tmpvec_1) - !$OMP DO - do h2 = 1, mo_num - do ipoint = 1, n_points_final_grid - - tmp2(ipoint,h2) = mos_r_in_r_array_transp(ipoint,h2) * tmpval_1(ipoint) & - + int2_grad1_u12_bimo_t(ipoint,1,i,h2) * tmpvec_1(ipoint,1) & - + int2_grad1_u12_bimo_t(ipoint,2,i,h2) * tmpvec_1(ipoint,2) & - + int2_grad1_u12_bimo_t(ipoint,3,i,h2) * tmpvec_1(ipoint,3) - - tmp1(ipoint,1,h2) = tmpval_2(ipoint) * int2_grad1_u12_bimo_t(ipoint,1,i,h2) - tmp1(ipoint,2,h2) = tmpval_2(ipoint) * int2_grad1_u12_bimo_t(ipoint,2,i,h2) - tmp1(ipoint,3,h2) = tmpval_2(ipoint) * int2_grad1_u12_bimo_t(ipoint,3,i,h2) - - enddo - enddo - !$OMP END DO - !$OMP END PARALLEL - - call dgemm( 'T', 'N', mo_num, mo_num, n_points_final_grid, 1.d0 & - , mos_l_in_r_array_transp(1,1), n_points_final_grid & - , tmp2(1,1), n_points_final_grid & - , 0.d0, tmp_2d(1,1), mo_num) - - !$OMP PARALLEL DO PRIVATE(h2,p2) - do h2 = 1, mo_num - do p2 = 1, mo_num - tmp(p2,h2,p1,h1) = tmp(p2,h2,p1,h1) + tmp_2d(p2,h2) - enddo - enddo - !$OMP END PARALLEL DO - - !$OMP PARALLEL & - !$OMP DEFAULT (NONE) & - !$OMP PRIVATE (p2, ipoint) & - !$OMP SHARED (mo_num, n_points_final_grid, i, h1, & - !$OMP int2_grad1_u12_bimo_t, & - !$OMP tmpvec_2, tmpvec_3, tmp2, tmp3) - !$OMP DO - do p2 = 1, mo_num - do ipoint = 1, n_points_final_grid - - tmp2(ipoint,p2) = int2_grad1_u12_bimo_t(ipoint,1,p2,i) * tmpvec_2(ipoint,1) + int2_grad1_u12_bimo_t(ipoint,1,p2,h1) * tmpvec_3(ipoint,1) & - + int2_grad1_u12_bimo_t(ipoint,2,p2,i) * tmpvec_2(ipoint,2) + int2_grad1_u12_bimo_t(ipoint,2,p2,h1) * tmpvec_3(ipoint,2) & - + int2_grad1_u12_bimo_t(ipoint,3,p2,i) * tmpvec_2(ipoint,3) + int2_grad1_u12_bimo_t(ipoint,3,p2,h1) * tmpvec_3(ipoint,3) - - tmp3(ipoint,1,p2) = int2_grad1_u12_bimo_t(ipoint,1,p2,h1) - tmp3(ipoint,2,p2) = int2_grad1_u12_bimo_t(ipoint,2,p2,h1) - tmp3(ipoint,3,p2) = int2_grad1_u12_bimo_t(ipoint,3,p2,h1) - enddo - enddo - !$OMP END DO - !$OMP END PARALLEL - - call dgemm( 'T', 'N', mo_num, mo_num, n_points_final_grid, 1.d0 & - , tmp2(1,1), n_points_final_grid & - , mos_r_in_r_array_transp(1,1), n_points_final_grid & - , 0.d0, tmp_2d(1,1), mo_num) - - call dgemm( 'T', 'N', mo_num, mo_num, 3*n_points_final_grid, 1.d0 & - , tmp3(1,1,1), 3*n_points_final_grid & - , tmp1(1,1,1), 3*n_points_final_grid & - , 1.d0, tmp_2d(1,1), mo_num) - - !$OMP PARALLEL DO PRIVATE(h2,p2) - do h2 = 1, mo_num - do p2 = 1, mo_num - tmp(p2,h2,p1,h1) = tmp(p2,h2,p1,h1) + tmp_2d(p2,h2) - enddo - enddo - !$OMP END PARALLEL DO - - enddo ! p1 - enddo ! h1 - enddo ! i - - ! purely open-shell part - if(Ne(2) < Ne(1)) then - - do ii = Ne(2) + 1, Ne(1) - i = occ(ii,1) - - ! to avoid tmp(N^4) - do h1 = 1, mo_num - - ! to minimize the number of operations - !$OMP PARALLEL & - !$OMP DEFAULT (NONE) & - !$OMP PRIVATE (ipoint) & - !$OMP SHARED (n_points_final_grid, i, h1, & - !$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 tmpval_1, tmpval_2, tmpvec_1, tmpvec_2 ) - !$OMP DO - do ipoint = 1, n_points_final_grid - - tmpval_1(ipoint) = final_weight_at_r_vector(ipoint) * mos_l_in_r_array_transp(ipoint,i) * mos_r_in_r_array_transp(ipoint,i) - - tmpval_2(ipoint) = final_weight_at_r_vector(ipoint) * mos_l_in_r_array_transp(ipoint,i) * mos_r_in_r_array_transp(ipoint,h1) - - tmpvec_1(ipoint,1) = final_weight_at_r_vector(ipoint) * int2_grad1_u12_bimo_t(ipoint,1,i,i) * mos_r_in_r_array_transp(ipoint,h1) - tmpvec_1(ipoint,2) = final_weight_at_r_vector(ipoint) * int2_grad1_u12_bimo_t(ipoint,2,i,i) * mos_r_in_r_array_transp(ipoint,h1) - tmpvec_1(ipoint,3) = final_weight_at_r_vector(ipoint) * int2_grad1_u12_bimo_t(ipoint,3,i,i) * mos_r_in_r_array_transp(ipoint,h1) - - tmpvec_2(ipoint,1) = final_weight_at_r_vector(ipoint) * int2_grad1_u12_bimo_t(ipoint,1,i,h1) * mos_r_in_r_array_transp(ipoint,i) - tmpvec_2(ipoint,2) = final_weight_at_r_vector(ipoint) * int2_grad1_u12_bimo_t(ipoint,2,i,h1) * mos_r_in_r_array_transp(ipoint,i) - tmpvec_2(ipoint,3) = final_weight_at_r_vector(ipoint) * int2_grad1_u12_bimo_t(ipoint,3,i,h1) * mos_r_in_r_array_transp(ipoint,i) - enddo - !$OMP END DO - !$OMP END PARALLEL - - !$OMP PARALLEL & - !$OMP DEFAULT (NONE) & - !$OMP PRIVATE (p1, ipoint) & - !$OMP SHARED (mo_num, n_points_final_grid, h1, i, & - !$OMP mos_l_in_r_array_transp, int2_grad1_u12_bimo_t, & - !$OMP tmpval_1, tmpvec_1, tmp1) - !$OMP DO - do p1 = 1, mo_num - do ipoint = 1, n_points_final_grid - tmp1(ipoint,1,p1) = mos_l_in_r_array_transp(ipoint,p1) * tmpvec_1(ipoint,1) + tmpval_1(ipoint) * int2_grad1_u12_bimo_t(ipoint,1,p1,h1) - tmp1(ipoint,2,p1) = mos_l_in_r_array_transp(ipoint,p1) * tmpvec_1(ipoint,2) + tmpval_1(ipoint) * int2_grad1_u12_bimo_t(ipoint,2,p1,h1) - tmp1(ipoint,3,p1) = mos_l_in_r_array_transp(ipoint,p1) * tmpvec_1(ipoint,3) + tmpval_1(ipoint) * int2_grad1_u12_bimo_t(ipoint,3,p1,h1) - enddo - enddo - !$OMP END DO - !$OMP END PARALLEL - - call dgemm( 'T', 'N', mo_num*mo_num, mo_num, 3*n_points_final_grid, 0.5d0 & - , int2_grad1_u12_bimo_t(1,1,1,1), 3*n_points_final_grid & - , tmp1(1,1,1), 3*n_points_final_grid & - , 0.d0, tmp_3d(1,1,1), mo_num*mo_num) - - !$OMP PARALLEL DO PRIVATE(p1,h2,p2) - do p1 = 1, mo_num - do h2 = 1, mo_num - do p2 = 1, mo_num - tmp(p2,h2,p1,h1) = tmp(p2,h2,p1,h1) + tmp_3d(p2,h2,p1) - enddo - enddo - enddo - !$OMP END PARALLEL DO - - !$OMP PARALLEL & - !$OMP DEFAULT (NONE) & - !$OMP PRIVATE (p2, ipoint) & - !$OMP SHARED (mo_num, n_points_final_grid, h1, i, & - !$OMP mos_l_in_r_array_transp, int2_grad1_u12_bimo_t, & - !$OMP tmpval_2, tmpvec_2, tmp1) - !$OMP DO - do p2 = 1, mo_num - do ipoint = 1, n_points_final_grid - tmp1(ipoint,1,p2) = tmpval_2(ipoint) * int2_grad1_u12_bimo_t(ipoint,1,p2,i) + mos_l_in_r_array_transp(ipoint,p2) * tmpvec_2(ipoint,1) - tmp1(ipoint,2,p2) = tmpval_2(ipoint) * int2_grad1_u12_bimo_t(ipoint,2,p2,i) + mos_l_in_r_array_transp(ipoint,p2) * tmpvec_2(ipoint,2) - tmp1(ipoint,3,p2) = tmpval_2(ipoint) * int2_grad1_u12_bimo_t(ipoint,3,p2,i) + mos_l_in_r_array_transp(ipoint,p2) * tmpvec_2(ipoint,3) - enddo - enddo - !$OMP END DO - !$OMP END PARALLEL - - call dgemm( 'T', 'N', mo_num, mo_num*mo_num, 3*n_points_final_grid, 0.5d0 & - , tmp1(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_3d(1,1,1), mo_num) - - !$OMP PARALLEL DO PRIVATE(p1,h2,p2) - do p1 = 1, mo_num - do h2 = 1, mo_num - do p2 = 1, mo_num - tmp(p2,h2,p1,h1) = tmp(p2,h2,p1,h1) + tmp_3d(p2,p1,h2) - enddo - enddo - enddo - !$OMP END PARALLEL DO - - ! to avoid tmp(N^4) - do p1 = 1, mo_num - - !$OMP PARALLEL & - !$OMP DEFAULT (NONE) & - !$OMP PRIVATE (ipoint) & - !$OMP SHARED (n_points_final_grid, i, h1, p1, & - !$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 tmpval_1, tmpval_2, tmpvec_1, tmpvec_2, tmpvec_3) - !$OMP DO - do ipoint = 1, n_points_final_grid - - tmpval_1(ipoint) = final_weight_at_r_vector(ipoint) * & - ( int2_grad1_u12_bimo_t(ipoint,1,i,i) * int2_grad1_u12_bimo_t(ipoint,1,p1,h1) & - + int2_grad1_u12_bimo_t(ipoint,2,i,i) * int2_grad1_u12_bimo_t(ipoint,2,p1,h1) & - + int2_grad1_u12_bimo_t(ipoint,3,i,i) * int2_grad1_u12_bimo_t(ipoint,3,p1,h1) ) - - tmpval_2(ipoint) = final_weight_at_r_vector(ipoint) * mos_l_in_r_array_transp(ipoint,p1) * mos_r_in_r_array_transp(ipoint,i) - - tmpvec_1(ipoint,1) = final_weight_at_r_vector(ipoint) * int2_grad1_u12_bimo_t(ipoint,1,p1,i) * mos_r_in_r_array_transp(ipoint,h1) - tmpvec_1(ipoint,2) = final_weight_at_r_vector(ipoint) * int2_grad1_u12_bimo_t(ipoint,2,p1,i) * mos_r_in_r_array_transp(ipoint,h1) - tmpvec_1(ipoint,3) = final_weight_at_r_vector(ipoint) * int2_grad1_u12_bimo_t(ipoint,3,p1,i) * mos_r_in_r_array_transp(ipoint,h1) - - tmpvec_2(ipoint,1) = final_weight_at_r_vector(ipoint) * int2_grad1_u12_bimo_t(ipoint,1,i,h1) * mos_l_in_r_array_transp(ipoint,p1) - tmpvec_2(ipoint,2) = final_weight_at_r_vector(ipoint) * int2_grad1_u12_bimo_t(ipoint,2,i,h1) * mos_l_in_r_array_transp(ipoint,p1) - tmpvec_2(ipoint,3) = final_weight_at_r_vector(ipoint) * int2_grad1_u12_bimo_t(ipoint,3,i,h1) * mos_l_in_r_array_transp(ipoint,p1) - - tmpvec_3(ipoint,1) = final_weight_at_r_vector(ipoint) * int2_grad1_u12_bimo_t(ipoint,1,p1,i) * mos_l_in_r_array_transp(ipoint,i) - tmpvec_3(ipoint,2) = final_weight_at_r_vector(ipoint) * int2_grad1_u12_bimo_t(ipoint,2,p1,i) * mos_l_in_r_array_transp(ipoint,i) - tmpvec_3(ipoint,3) = final_weight_at_r_vector(ipoint) * int2_grad1_u12_bimo_t(ipoint,3,p1,i) * mos_l_in_r_array_transp(ipoint,i) - enddo - !$OMP END DO - !$OMP END PARALLEL - - !$OMP PARALLEL & - !$OMP DEFAULT (NONE) & - !$OMP PRIVATE (h2, ipoint) & - !$OMP SHARED (mo_num, n_points_final_grid, i, & - !$OMP mos_r_in_r_array_transp, & - !$OMP int2_grad1_u12_bimo_t, & - !$OMP tmp1, tmp2, tmpval_1, tmpval_2, tmpvec_1) - !$OMP DO - do h2 = 1, mo_num - do ipoint = 1, n_points_final_grid - - tmp2(ipoint,h2) = mos_r_in_r_array_transp(ipoint,h2) * tmpval_1(ipoint) & - + int2_grad1_u12_bimo_t(ipoint,1,i,h2) * tmpvec_1(ipoint,1) & - + int2_grad1_u12_bimo_t(ipoint,2,i,h2) * tmpvec_1(ipoint,2) & - + int2_grad1_u12_bimo_t(ipoint,3,i,h2) * tmpvec_1(ipoint,3) - - tmp1(ipoint,1,h2) = tmpval_2(ipoint) * int2_grad1_u12_bimo_t(ipoint,1,i,h2) - tmp1(ipoint,2,h2) = tmpval_2(ipoint) * int2_grad1_u12_bimo_t(ipoint,2,i,h2) - tmp1(ipoint,3,h2) = tmpval_2(ipoint) * int2_grad1_u12_bimo_t(ipoint,3,i,h2) - - enddo - enddo - !$OMP END DO - !$OMP END PARALLEL - - call dgemm( 'T', 'N', mo_num, mo_num, n_points_final_grid, 0.5d0 & - , mos_l_in_r_array_transp(1,1), n_points_final_grid & - , tmp2(1,1), n_points_final_grid & - , 0.d0, tmp_2d(1,1), mo_num) - - !$OMP PARALLEL DO PRIVATE(h2,p2) - do h2 = 1, mo_num - do p2 = 1, mo_num - tmp(p2,h2,p1,h1) = tmp(p2,h2,p1,h1) + tmp_2d(p2,h2) - enddo - enddo - !$OMP END PARALLEL DO - - !$OMP PARALLEL & - !$OMP DEFAULT (NONE) & - !$OMP PRIVATE (p2, ipoint) & - !$OMP SHARED (mo_num, n_points_final_grid, i, h1, & - !$OMP int2_grad1_u12_bimo_t, & - !$OMP tmpvec_2, tmpvec_3, tmp2, tmp3) - !$OMP DO - do p2 = 1, mo_num - do ipoint = 1, n_points_final_grid - - tmp2(ipoint,p2) = int2_grad1_u12_bimo_t(ipoint,1,p2,i) * tmpvec_2(ipoint,1) + int2_grad1_u12_bimo_t(ipoint,1,p2,h1) * tmpvec_3(ipoint,1) & - + int2_grad1_u12_bimo_t(ipoint,2,p2,i) * tmpvec_2(ipoint,2) + int2_grad1_u12_bimo_t(ipoint,2,p2,h1) * tmpvec_3(ipoint,2) & - + int2_grad1_u12_bimo_t(ipoint,3,p2,i) * tmpvec_2(ipoint,3) + int2_grad1_u12_bimo_t(ipoint,3,p2,h1) * tmpvec_3(ipoint,3) - - tmp3(ipoint,1,p2) = int2_grad1_u12_bimo_t(ipoint,1,p2,h1) - tmp3(ipoint,2,p2) = int2_grad1_u12_bimo_t(ipoint,2,p2,h1) - tmp3(ipoint,3,p2) = int2_grad1_u12_bimo_t(ipoint,3,p2,h1) - enddo - enddo - !$OMP END DO - !$OMP END PARALLEL - - call dgemm( 'T', 'N', mo_num, mo_num, n_points_final_grid, 0.5d0 & - , tmp2(1,1), n_points_final_grid & - , mos_r_in_r_array_transp(1,1), n_points_final_grid & - , 0.d0, tmp_2d(1,1), mo_num) - - call dgemm( 'T', 'N', mo_num, mo_num, 3*n_points_final_grid, 0.5d0 & - , tmp3(1,1,1), 3*n_points_final_grid & - , tmp1(1,1,1), 3*n_points_final_grid & - , 1.d0, tmp_2d(1,1), mo_num) - - !$OMP PARALLEL DO PRIVATE(h2,p2) - do h2 = 1, mo_num - do p2 = 1, mo_num - tmp(p2,h2,p1,h1) = tmp(p2,h2,p1,h1) + tmp_2d(p2,h2) - enddo - enddo - !$OMP END PARALLEL DO - - enddo ! p1 - enddo ! h1 - enddo !i - endif - - deallocate(tmp_2d) - deallocate(tmp_3d) - deallocate(tmp1) - deallocate(tmp2) - deallocate(tmp3) - deallocate(tmpval_1) - deallocate(tmpval_2) - deallocate(tmpvec_1) - deallocate(tmpvec_2) - deallocate(tmpvec_3) - - tmp = -0.5d0 * tmp - - !$OMP PARALLEL & - !$OMP DEFAULT (NONE) & - !$OMP PRIVATE (h1, h2, p1, p2) & - !$OMP SHARED (tmp, mo_num) - - !$OMP DO - do h1 = 1, mo_num - do h2 = 1, mo_num - do p1 = 1, mo_num - do p2 = p1, mo_num - tmp(p2,h2,p1,h1) -= tmp(p1,h2,p2,h1) - enddo - enddo - enddo - enddo - !$OMP END DO - - !$OMP DO - do h1 = 1, mo_num - do h2 = 1, mo_num - do p1 = 2, mo_num - do p2 = 1, p1-1 - tmp(p2,h2,p1,h1) = -tmp(p1,h2,p2,h1) - enddo - enddo - enddo - enddo - !$OMP END DO - - !$OMP DO - do h1 = 1, mo_num-1 - do h2 = h1+1, mo_num - do p1 = 2, mo_num - do p2 = 1, p1-1 - tmp(p2,h2,p1,h1) *= -1.d0 - enddo - enddo - enddo - enddo - !$OMP END DO - !$OMP END PARALLEL - - call wall_time(wall1) - print*,' Wall time for aaa_contraction', wall1-wall0 - - normal_two_body_bi_orth_v0 += tmp - endif ! Ne(2) .ge. 3 - - deallocate(tmp) - - endif ! read_tc_norm_ord - - if(write_tc_norm_ord.and.mpi_master) then - open(unit=11, form="unformatted", file=trim(ezfio_filename)//'/work/normal_two_body_bi_orth_v0', action="write") - call ezfio_set_work_empty(.False.) - write(11) normal_two_body_bi_orth_v0 - close(11) - call ezfio_set_tc_keywords_io_tc_integ('Read') - endif - - call wall_time(wallf) - print*,' Wall time for normal_two_body_bi_orth_v0 ', wallf-walli - -END_PROVIDER - -! --- - -BEGIN_PROVIDER [ double precision, normal_two_body_bi_orth, (mo_num, mo_num, mo_num, mo_num)] - - BEGIN_DOC - ! Normal ordering of the three body interaction on the HF density - END_DOC - - use bitmasks ! you need to include the bitmasks_module.f90 features - - implicit none - - integer :: i, ii, h1, p1, h2, p2, ipoint - integer :: hh1, hh2, pp1, pp2 - integer :: Ne(2) - double precision :: wall0, wall1, walli, wallf - integer, allocatable :: occ(:,:) - integer(bit_kind), allocatable :: key_i_core(:,:) - - print*,' Providing normal_two_body_bi_orth ...' - call wall_time(walli) - - if(read_tc_norm_ord) then - - open(unit=11, form="unformatted", file=trim(ezfio_filename)//'/work/normal_two_body_bi_orth', action="read") - read(11) normal_two_body_bi_orth - close(11) - - else - - double precision, allocatable :: tmp_2d(:,:), tmp_3d(:,:,:) - double precision, allocatable :: tmp1(:,:,:), tmp2(:,:), tmp3(:,:,:) - double precision, allocatable :: tmpval_1(:), tmpval_2(:), tmpvec_1(:,:), tmpvec_2(:,:), tmpvec_3(:,:) - double precision, allocatable :: tmp(:,:,:,:) - - PROVIDE N_int - - allocate( occ(N_int*bit_kind_size,2) ) - allocate( key_i_core(N_int,2) ) - - if(core_tc_op) then - do i = 1, N_int - key_i_core(i,1) = xor(ref_bitmask(i,1), core_bitmask(i,1)) - key_i_core(i,2) = xor(ref_bitmask(i,2), core_bitmask(i,2)) - enddo - call bitstring_to_list_ab(key_i_core, occ, Ne, N_int) - else - call bitstring_to_list_ab(ref_bitmask, occ, Ne, N_int) - endif - - allocate(tmp(mo_num,mo_num,mo_num,mo_num)) - - ! --- - ! aba contraction - - print*,' Providing aba_contraction ...' - call wall_time(wall0) - - tmp = 0.d0 - - !$OMP PARALLEL & - !$OMP DEFAULT (NONE) & - !$OMP PRIVATE (ipoint, h1, p1, h2, p2, i, ii, & - !$OMP tmp_3d, tmp_2d, tmp1, tmp2, & - !$OMP tmpval_1, tmpval_2, tmpvec_1, tmpvec_2) & - !$OMP SHARED (n_points_final_grid, Ne, occ, mo_num, & - !$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) - - allocate(tmp_3d(mo_num,mo_num,mo_num), tmp_2d(mo_num,mo_num)) - allocate(tmp1(n_points_final_grid,3,mo_num), tmp2(n_points_final_grid,mo_num)) - allocate(tmpval_1(n_points_final_grid), tmpval_2(n_points_final_grid)) - allocate(tmpvec_1(n_points_final_grid,3), tmpvec_2(n_points_final_grid,3)) - - tmp_3d = 0.d0 - tmp_2d = 0.d0 - tmp1 = 0.d0 - tmp2 = 0.d0 - tmpval_1 = 0.d0 - tmpval_2 = 0.d0 - tmpvec_1 = 0.d0 - tmpvec_2 = 0.d0 - - !$OMP DO - - do ii = 1, Ne(2) - i = occ(ii,2) - - do h1 = 1, mo_num - - do ipoint = 1, n_points_final_grid - tmpval_1(ipoint) = final_weight_at_r_vector(ipoint) * mos_l_in_r_array_transp(ipoint,i) * mos_r_in_r_array_transp(ipoint, i) - tmpval_2(ipoint) = final_weight_at_r_vector(ipoint) * mos_l_in_r_array_transp(ipoint,i) * mos_r_in_r_array_transp(ipoint,h1) - tmpvec_1(ipoint,1) = final_weight_at_r_vector(ipoint) * int2_grad1_u12_bimo_t(ipoint,1,i, i) * mos_r_in_r_array_transp(ipoint,h1) - tmpvec_1(ipoint,2) = final_weight_at_r_vector(ipoint) * int2_grad1_u12_bimo_t(ipoint,2,i, i) * mos_r_in_r_array_transp(ipoint,h1) - tmpvec_1(ipoint,3) = final_weight_at_r_vector(ipoint) * int2_grad1_u12_bimo_t(ipoint,3,i, i) * mos_r_in_r_array_transp(ipoint,h1) - tmpvec_2(ipoint,1) = final_weight_at_r_vector(ipoint) * int2_grad1_u12_bimo_t(ipoint,1,i,h1) * mos_r_in_r_array_transp(ipoint, i) - tmpvec_2(ipoint,2) = final_weight_at_r_vector(ipoint) * int2_grad1_u12_bimo_t(ipoint,2,i,h1) * mos_r_in_r_array_transp(ipoint, i) - tmpvec_2(ipoint,3) = final_weight_at_r_vector(ipoint) * int2_grad1_u12_bimo_t(ipoint,3,i,h1) * mos_r_in_r_array_transp(ipoint, i) - enddo - - do p1 = 1, mo_num - do ipoint = 1, n_points_final_grid - tmp1(ipoint,1,p1) = mos_l_in_r_array_transp(ipoint,p1) * (tmpvec_1(ipoint,1) - tmpvec_2(ipoint,1)) & - + tmpval_1(ipoint) * int2_grad1_u12_bimo_t(ipoint,1,p1,h1) - tmpval_2(ipoint) * int2_grad1_u12_bimo_t(ipoint,1,p1,i) - tmp1(ipoint,2,p1) = mos_l_in_r_array_transp(ipoint,p1) * (tmpvec_1(ipoint,2) - tmpvec_2(ipoint,2)) & - + tmpval_1(ipoint) * int2_grad1_u12_bimo_t(ipoint,2,p1,h1) - tmpval_2(ipoint) * int2_grad1_u12_bimo_t(ipoint,2,p1,i) - tmp1(ipoint,3,p1) = mos_l_in_r_array_transp(ipoint,p1) * (tmpvec_1(ipoint,3) - tmpvec_2(ipoint,3)) & - + tmpval_1(ipoint) * int2_grad1_u12_bimo_t(ipoint,3,p1,h1) - tmpval_2(ipoint) * int2_grad1_u12_bimo_t(ipoint,3,p1,i) - enddo - enddo - - call dgemm( 'T', 'N', mo_num*mo_num, mo_num, 3*n_points_final_grid, 1.d0 & - , int2_grad1_u12_bimo_t(1,1,1,1), 3*n_points_final_grid & - , tmp1(1,1,1), 3*n_points_final_grid & - , 0.d0, tmp_3d(1,1,1), mo_num*mo_num) - - do p1 = 1, mo_num - do h2 = 1, mo_num - do p2 = 1, mo_num - !$OMP CRITICAL - tmp(p2,h2,p1,h1) = tmp(p2,h2,p1,h1) + tmp_3d(p2,h2,p1) - !$OMP END CRITICAL - enddo - enddo - enddo - - do p1 = 1, mo_num - - do ipoint = 1, n_points_final_grid - tmpval_1(ipoint) = final_weight_at_r_vector(ipoint) * & - ( int2_grad1_u12_bimo_t(ipoint,1, i,i) * int2_grad1_u12_bimo_t(ipoint,1,p1,h1) & - + int2_grad1_u12_bimo_t(ipoint,2, i,i) * int2_grad1_u12_bimo_t(ipoint,2,p1,h1) & - + int2_grad1_u12_bimo_t(ipoint,3, i,i) * int2_grad1_u12_bimo_t(ipoint,3,p1,h1) & - - int2_grad1_u12_bimo_t(ipoint,1,p1,i) * int2_grad1_u12_bimo_t(ipoint,1, i,h1) & - - int2_grad1_u12_bimo_t(ipoint,2,p1,i) * int2_grad1_u12_bimo_t(ipoint,2, i,h1) & - - int2_grad1_u12_bimo_t(ipoint,3,p1,i) * int2_grad1_u12_bimo_t(ipoint,3, i,h1) ) - enddo - - do h2 = 1, mo_num - do ipoint = 1, n_points_final_grid - tmp2(ipoint,h2) = mos_r_in_r_array_transp(ipoint,h2) * tmpval_1(ipoint) - enddo - enddo - - call dgemm( 'T', 'N', mo_num, mo_num, n_points_final_grid, 1.d0 & - , mos_l_in_r_array_transp(1,1), n_points_final_grid & - , tmp2(1,1), n_points_final_grid & - , 0.d0, tmp_2d(1,1), mo_num) - - do h2 = 1, mo_num - do p2 = 1, mo_num - !$OMP CRITICAL - tmp(p2,h2,p1,h1) = tmp(p2,h2,p1,h1) + tmp_2d(p2,h2) - !$OMP END CRITICAL - enddo - enddo - - enddo ! p1 - enddo ! h1 - enddo ! i - - !$OMP END DO - - deallocate(tmp_3d, tmp_2d) - deallocate(tmp1, tmp2) - deallocate(tmpval_1, tmpval_2) - deallocate(tmpvec_1, tmpvec_2) - - !$OMP END PARALLEL - - - ! purely open-shell part - if(Ne(2) < Ne(1)) then - - !$OMP PARALLEL & - !$OMP DEFAULT (NONE) & - !$OMP PRIVATE (ipoint, h1, p1, h2, p2, i, ii, & - !$OMP tmp_3d, tmp_2d, tmp1, tmp2, & - !$OMP tmpval_1, tmpval_2, tmpvec_1, tmpvec_2) & - !$OMP SHARED (n_points_final_grid, Ne, occ, mo_num, & - !$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) - - Allocate(tmp_3d(mo_num,mo_num,mo_num), tmp_2d(mo_num,mo_num)) - Allocate(tmp1(n_points_final_grid,3,mo_num), tmp2(n_points_final_grid,mo_num)) - Allocate(tmpval_1(n_points_final_grid), tmpval_2(n_points_final_grid)) - Allocate(tmpvec_1(n_points_final_grid,3), tmpvec_2(n_points_final_grid,3)) - - Tmp_3d = 0.d0 - Tmp_2d = 0.d0 - Tmp1 = 0.d0 - Tmp2 = 0.d0 - Tmpval_1 = 0.d0 - Tmpval_2 = 0.d0 - Tmpvec_1 = 0.d0 - Tmpvec_2 = 0.d0 - - !$OMP DO - - do ii = Ne(2) + 1, Ne(1) - i = occ(ii,1) - - do h1 = 1, mo_num - - do ipoint = 1, n_points_final_grid - tmpval_1(ipoint) = final_weight_at_r_vector(ipoint) * mos_l_in_r_array_transp(ipoint,i) * mos_r_in_r_array_transp(ipoint, i) - tmpval_2(ipoint) = final_weight_at_r_vector(ipoint) * mos_l_in_r_array_transp(ipoint,i) * mos_r_in_r_array_transp(ipoint,h1) - tmpvec_1(ipoint,1) = final_weight_at_r_vector(ipoint) * int2_grad1_u12_bimo_t(ipoint,1,i, i) * mos_r_in_r_array_transp(ipoint,h1) - tmpvec_1(ipoint,2) = final_weight_at_r_vector(ipoint) * int2_grad1_u12_bimo_t(ipoint,2,i, i) * mos_r_in_r_array_transp(ipoint,h1) - tmpvec_1(ipoint,3) = final_weight_at_r_vector(ipoint) * int2_grad1_u12_bimo_t(ipoint,3,i, i) * mos_r_in_r_array_transp(ipoint,h1) - tmpvec_2(ipoint,1) = final_weight_at_r_vector(ipoint) * int2_grad1_u12_bimo_t(ipoint,1,i,h1) * mos_r_in_r_array_transp(ipoint, i) - tmpvec_2(ipoint,2) = final_weight_at_r_vector(ipoint) * int2_grad1_u12_bimo_t(ipoint,2,i,h1) * mos_r_in_r_array_transp(ipoint, i) - tmpvec_2(ipoint,3) = final_weight_at_r_vector(ipoint) * int2_grad1_u12_bimo_t(ipoint,3,i,h1) * mos_r_in_r_array_transp(ipoint, i) - enddo - - do p1 = 1, mo_num - do ipoint = 1, n_points_final_grid - tmp1(ipoint,1,p1) = mos_l_in_r_array_transp(ipoint,p1) * (tmpvec_1(ipoint,1) - tmpvec_2(ipoint,1)) & - + tmpval_1(ipoint) * int2_grad1_u12_bimo_t(ipoint,1,p1,h1) - tmpval_2(ipoint) * int2_grad1_u12_bimo_t(ipoint,1,p1,i) - tmp1(ipoint,2,p1) = mos_l_in_r_array_transp(ipoint,p1) * (tmpvec_1(ipoint,2) - tmpvec_2(ipoint,2)) & - + tmpval_1(ipoint) * int2_grad1_u12_bimo_t(ipoint,2,p1,h1) - tmpval_2(ipoint) * int2_grad1_u12_bimo_t(ipoint,2,p1,i) - tmp1(ipoint,3,p1) = mos_l_in_r_array_transp(ipoint,p1) * (tmpvec_1(ipoint,3) - tmpvec_2(ipoint,3)) & - + tmpval_1(ipoint) * int2_grad1_u12_bimo_t(ipoint,3,p1,h1) - tmpval_2(ipoint) * int2_grad1_u12_bimo_t(ipoint,3,p1,i) - enddo - enddo - - call dgemm( 'T', 'N', mo_num*mo_num, mo_num, 3*n_points_final_grid, 0.5d0 & - , int2_grad1_u12_bimo_t(1,1,1,1), 3*n_points_final_grid & - , tmp1(1,1,1), 3*n_points_final_grid & - , 0.d0, tmp_3d(1,1,1), mo_num*mo_num) - - do p1 = 1, mo_num - do h2 = 1, mo_num - do p2 = 1, mo_num - !$OMP CRITICAL - tmp(p2,h2,p1,h1) = tmp(p2,h2,p1,h1) + tmp_3d(p2,h2,p1) - !$OMP END CRITICAL - enddo - enddo - enddo - - do p1 = 1, mo_num - - do ipoint = 1, n_points_final_grid - tmpval_1(ipoint) = final_weight_at_r_vector(ipoint) * & - ( int2_grad1_u12_bimo_t(ipoint,1, i,i) * int2_grad1_u12_bimo_t(ipoint,1,p1,h1) & - + int2_grad1_u12_bimo_t(ipoint,2, i,i) * int2_grad1_u12_bimo_t(ipoint,2,p1,h1) & - + int2_grad1_u12_bimo_t(ipoint,3, i,i) * int2_grad1_u12_bimo_t(ipoint,3,p1,h1) & - - int2_grad1_u12_bimo_t(ipoint,1,p1,i) * int2_grad1_u12_bimo_t(ipoint,1, i,h1) & - - int2_grad1_u12_bimo_t(ipoint,2,p1,i) * int2_grad1_u12_bimo_t(ipoint,2, i,h1) & - - int2_grad1_u12_bimo_t(ipoint,3,p1,i) * int2_grad1_u12_bimo_t(ipoint,3, i,h1) ) - enddo - - do h2 = 1, mo_num - do ipoint = 1, n_points_final_grid - tmp2(ipoint,h2) = mos_r_in_r_array_transp(ipoint,h2) * tmpval_1(ipoint) - enddo - enddo - - call dgemm( 'T', 'N', mo_num, mo_num, n_points_final_grid, 0.5d0 & - , mos_l_in_r_array_transp(1,1), n_points_final_grid & - , tmp2(1,1), n_points_final_grid & - , 0.d0, tmp_2d(1,1), mo_num) - - do h2 = 1, mo_num - do p2 = 1, mo_num - !$OMP CRITICAL - tmp(p2,h2,p1,h1) = tmp(p2,h2,p1,h1) + tmp_2d(p2,h2) - !$OMP END CRITICAL - enddo - enddo - - enddo ! p1 - enddo ! h1 - enddo !i - !$OMP END DO - - deallocate(tmp_3d, tmp_2d) - deallocate(tmp1, tmp2) - deallocate(tmpval_1, tmpval_2) - deallocate(tmpvec_1, tmpvec_2) - - !$OMP END PARALLEL - endif - - tmp = -0.5d0 * tmp - call sum_A_At(tmp(1,1,1,1), mo_num*mo_num) - - call wall_time(wall1) - print*,' Wall time for aba_contraction', wall1-wall0 - - normal_two_body_bi_orth = tmp - - ! --- - ! aab contraction - - print*,' Providing aab_contraction ...' - call wall_time(wall0) - - tmp = 0.d0 - - !$OMP PARALLEL & - !$OMP DEFAULT (NONE) & - !$OMP PRIVATE (ipoint, ii, i, h1, p1, h2, p2, & - !$OMP tmp_2d, tmp_3d, tmp1, tmp2, & - !$OMP tmpval_1, tmpvec_1) & - !$OMP SHARED (n_points_final_grid, mo_num, Ne, occ, & - !$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) - - allocate(tmp_2d(mo_num,mo_num)) - allocate(tmp_3d(mo_num,mo_num,mo_num)) - allocate(tmp1(n_points_final_grid,3,mo_num)) - allocate(tmp2(n_points_final_grid,mo_num)) - allocate(tmpval_1(n_points_final_grid)) - allocate(tmpvec_1(n_points_final_grid,3)) - - tmp_2d = 0.d0 - tmp_3d = 0.d0 - tmp1 = 0.d0 - tmp2 = 0.d0 - tmpval_1 = 0.d0 - tmpvec_1 = 0.d0 - - !$OMP DO - - do ii = 1, Ne(2) - i = occ(ii,2) - - do h1 = 1, mo_num - - do ipoint = 1, n_points_final_grid - tmpval_1(ipoint) = final_weight_at_r_vector(ipoint) * mos_l_in_r_array_transp(ipoint,i) * mos_r_in_r_array_transp(ipoint,i) - tmpvec_1(ipoint,1) = final_weight_at_r_vector(ipoint) * int2_grad1_u12_bimo_t(ipoint,1,i,i) * mos_r_in_r_array_transp(ipoint,h1) - tmpvec_1(ipoint,2) = final_weight_at_r_vector(ipoint) * int2_grad1_u12_bimo_t(ipoint,2,i,i) * mos_r_in_r_array_transp(ipoint,h1) - tmpvec_1(ipoint,3) = final_weight_at_r_vector(ipoint) * int2_grad1_u12_bimo_t(ipoint,3,i,i) * mos_r_in_r_array_transp(ipoint,h1) - enddo - - do p1 = 1, mo_num - do ipoint = 1, n_points_final_grid - tmp1(ipoint,1,p1) = mos_l_in_r_array_transp(ipoint,p1) * tmpvec_1(ipoint,1) + tmpval_1(ipoint) * int2_grad1_u12_bimo_t(ipoint,1,p1,h1) - tmp1(ipoint,2,p1) = mos_l_in_r_array_transp(ipoint,p1) * tmpvec_1(ipoint,2) + tmpval_1(ipoint) * int2_grad1_u12_bimo_t(ipoint,2,p1,h1) - tmp1(ipoint,3,p1) = mos_l_in_r_array_transp(ipoint,p1) * tmpvec_1(ipoint,3) + tmpval_1(ipoint) * int2_grad1_u12_bimo_t(ipoint,3,p1,h1) - enddo - enddo - - call dgemm( 'T', 'N', mo_num*mo_num, mo_num, 3*n_points_final_grid, 1.d0 & - , int2_grad1_u12_bimo_t(1,1,1,1), 3*n_points_final_grid & - , tmp1(1,1,1), 3*n_points_final_grid & - , 0.d0, tmp_3d(1,1,1), mo_num*mo_num) - - do p1 = 1, mo_num - do h2 = 1, mo_num - do p2 = 1, mo_num - !$OMP CRITICAL - tmp(p2,h2,p1,h1) = tmp(p2,h2,p1,h1) + tmp_3d(p2,h2,p1) - !$OMP END CRITICAL - enddo - enddo - enddo - - do p1 = 1, mo_num - - do ipoint = 1, n_points_final_grid - tmpval_1(ipoint) = final_weight_at_r_vector(ipoint) * ( int2_grad1_u12_bimo_t(ipoint,1,i,i) * int2_grad1_u12_bimo_t(ipoint,1,p1,h1) & - + int2_grad1_u12_bimo_t(ipoint,2,i,i) * int2_grad1_u12_bimo_t(ipoint,2,p1,h1) & - + int2_grad1_u12_bimo_t(ipoint,3,i,i) * int2_grad1_u12_bimo_t(ipoint,3,p1,h1) ) - enddo - - do h2 = 1, mo_num - do ipoint = 1, n_points_final_grid - tmp2(ipoint,h2) = mos_r_in_r_array_transp(ipoint,h2) * tmpval_1(ipoint) - enddo - enddo - - call dgemm( 'T', 'N', mo_num, mo_num, n_points_final_grid, 1.d0 & - , mos_l_in_r_array_transp(1,1), n_points_final_grid & - , tmp2(1,1), n_points_final_grid & - , 0.d0, tmp_2d(1,1), mo_num) - - do h2 = 1, mo_num - do p2 = 1, mo_num - !$OMP CRITICAL - tmp(p2,h2,p1,h1) = tmp(p2,h2,p1,h1) + tmp_2d(p2,h2) - !$OMP END CRITICAL - enddo - enddo - - enddo ! p1 - enddo ! h1 - enddo ! i - - !$OMP END DO - - deallocate(tmp_3d) - deallocate(tmp1, tmp2) - deallocate(tmpval_1) - deallocate(tmpvec_1) - - !$OMP END PARALLEL - - tmp = -0.5d0 * tmp - - !$OMP PARALLEL & - !$OMP DEFAULT (NONE) & - !$OMP PRIVATE (h1, h2, p1, p2) & - !$OMP SHARED (tmp, mo_num) - - !$OMP DO - do h1 = 1, mo_num - do h2 = 1, mo_num - do p1 = 1, mo_num - do p2 = p1, mo_num - tmp(p2,h2,p1,h1) -= tmp(p1,h2,p2,h1) - enddo - enddo - enddo - enddo - !$OMP END DO - - !$OMP DO - do h1 = 1, mo_num - do h2 = 1, mo_num - do p1 = 2, mo_num - do p2 = 1, p1-1 - tmp(p2,h2,p1,h1) = -tmp(p1,h2,p2,h1) - enddo - enddo - enddo - enddo - !$OMP END DO - - !$OMP DO - do h1 = 1, mo_num-1 - do h2 = h1+1, mo_num - do p1 = 2, mo_num - do p2 = 1, p1-1 - tmp(p2,h2,p1,h1) *= -1.d0 - enddo - enddo - enddo - enddo - !$OMP END DO - !$OMP END PARALLEL - - call wall_time(wall1) - print*,' Wall time for aab_contraction', wall1-wall0 - - normal_two_body_bi_orth += tmp - - ! --- - ! aaa contraction - - if(Ne(2) .ge. 3) then - - print*,' Providing aaa_contraction ...' - call wall_time(wall0) - - tmp = 0.d0 - - !$OMP PARALLEL & - !$OMP DEFAULT (NONE) & - !$OMP PRIVATE (ipoint, i, ii, h1, h2, p1, p2, & - !$OMP tmp_2d, tmp_3d, tmp1, tmp2, tmp3, & - !$OMP tmpval_1, tmpval_2, & - !$OMP tmpvec_1, tmpvec_2, tmpvec_3) & - !$OMP SHARED (n_points_final_grid, Ne, occ, mo_num, & - !$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) - - allocate(tmp_2d(mo_num,mo_num)) - allocate(tmp_3d(mo_num,mo_num,mo_num)) - allocate(tmp1(n_points_final_grid,3,mo_num)) - allocate(tmp2(n_points_final_grid,mo_num)) - allocate(tmp3(n_points_final_grid,3,mo_num)) - allocate(tmpval_1(n_points_final_grid)) - allocate(tmpval_2(n_points_final_grid)) - allocate(tmpvec_1(n_points_final_grid,3)) - allocate(tmpvec_2(n_points_final_grid,3)) - allocate(tmpvec_3(n_points_final_grid,3)) - - tmp_2d = 0.d0 - tmp_3d = 0.d0 - tmp1 = 0.d0 - tmp2 = 0.d0 - tmp3 = 0.d0 - tmpval_1 = 0.d0 - tmpval_2 = 0.d0 - tmpvec_1 = 0.d0 - tmpvec_2 = 0.d0 - tmpvec_3 = 0.d0 - - !$OMP DO - do ii = 1, Ne(2) - i = occ(ii,2) - - do h1 = 1, mo_num - - do ipoint = 1, n_points_final_grid - - tmpval_1(ipoint) = final_weight_at_r_vector(ipoint) * mos_l_in_r_array_transp(ipoint,i) * mos_r_in_r_array_transp(ipoint,i) - - tmpval_2(ipoint) = final_weight_at_r_vector(ipoint) * mos_l_in_r_array_transp(ipoint,i) * mos_r_in_r_array_transp(ipoint,h1) - - tmpvec_1(ipoint,1) = final_weight_at_r_vector(ipoint) * int2_grad1_u12_bimo_t(ipoint,1,i,i) * mos_r_in_r_array_transp(ipoint,h1) - tmpvec_1(ipoint,2) = final_weight_at_r_vector(ipoint) * int2_grad1_u12_bimo_t(ipoint,2,i,i) * mos_r_in_r_array_transp(ipoint,h1) - tmpvec_1(ipoint,3) = final_weight_at_r_vector(ipoint) * int2_grad1_u12_bimo_t(ipoint,3,i,i) * mos_r_in_r_array_transp(ipoint,h1) - - tmpvec_2(ipoint,1) = final_weight_at_r_vector(ipoint) * int2_grad1_u12_bimo_t(ipoint,1,i,h1) * mos_r_in_r_array_transp(ipoint,i) - tmpvec_2(ipoint,2) = final_weight_at_r_vector(ipoint) * int2_grad1_u12_bimo_t(ipoint,2,i,h1) * mos_r_in_r_array_transp(ipoint,i) - tmpvec_2(ipoint,3) = final_weight_at_r_vector(ipoint) * int2_grad1_u12_bimo_t(ipoint,3,i,h1) * mos_r_in_r_array_transp(ipoint,i) - enddo - - do p1 = 1, mo_num - do ipoint = 1, n_points_final_grid - tmp1(ipoint,1,p1) = mos_l_in_r_array_transp(ipoint,p1) * tmpvec_1(ipoint,1) + tmpval_1(ipoint) * int2_grad1_u12_bimo_t(ipoint,1,p1,h1) - tmp1(ipoint,2,p1) = mos_l_in_r_array_transp(ipoint,p1) * tmpvec_1(ipoint,2) + tmpval_1(ipoint) * int2_grad1_u12_bimo_t(ipoint,2,p1,h1) - tmp1(ipoint,3,p1) = mos_l_in_r_array_transp(ipoint,p1) * tmpvec_1(ipoint,3) + tmpval_1(ipoint) * int2_grad1_u12_bimo_t(ipoint,3,p1,h1) - enddo - enddo - - call dgemm( 'T', 'N', mo_num*mo_num, mo_num, 3*n_points_final_grid, 1.d0 & - , int2_grad1_u12_bimo_t(1,1,1,1), 3*n_points_final_grid & - , tmp1(1,1,1), 3*n_points_final_grid & - , 0.d0, tmp_3d(1,1,1), mo_num*mo_num) - - do p1 = 1, mo_num - do h2 = 1, mo_num - do p2 = 1, mo_num - !$OMP CRITICAL - tmp(p2,h2,p1,h1) = tmp(p2,h2,p1,h1) + tmp_3d(p2,h2,p1) - !$OMP END CRITICAL - enddo - enddo - enddo - - do p2 = 1, mo_num - do ipoint = 1, n_points_final_grid - tmp1(ipoint,1,p2) = tmpval_2(ipoint) * int2_grad1_u12_bimo_t(ipoint,1,p2,i) + mos_l_in_r_array_transp(ipoint,p2) * tmpvec_2(ipoint,1) - tmp1(ipoint,2,p2) = tmpval_2(ipoint) * int2_grad1_u12_bimo_t(ipoint,2,p2,i) + mos_l_in_r_array_transp(ipoint,p2) * tmpvec_2(ipoint,2) - tmp1(ipoint,3,p2) = tmpval_2(ipoint) * int2_grad1_u12_bimo_t(ipoint,3,p2,i) + mos_l_in_r_array_transp(ipoint,p2) * tmpvec_2(ipoint,3) - enddo - enddo - - call dgemm( 'T', 'N', mo_num, mo_num*mo_num, 3*n_points_final_grid, 1.d0 & - , tmp1(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_3d(1,1,1), mo_num) - - do p1 = 1, mo_num - do h2 = 1, mo_num - do p2 = 1, mo_num - !$OMP CRITICAL - tmp(p2,h2,p1,h1) = tmp(p2,h2,p1,h1) + tmp_3d(p2,p1,h2) - !$OMP END CRITICAL - enddo - enddo - enddo - - do p1 = 1, mo_num - - do ipoint = 1, n_points_final_grid - - tmpval_1(ipoint) = final_weight_at_r_vector(ipoint) * & - ( int2_grad1_u12_bimo_t(ipoint,1,i,i) * int2_grad1_u12_bimo_t(ipoint,1,p1,h1) & - + int2_grad1_u12_bimo_t(ipoint,2,i,i) * int2_grad1_u12_bimo_t(ipoint,2,p1,h1) & - + int2_grad1_u12_bimo_t(ipoint,3,i,i) * int2_grad1_u12_bimo_t(ipoint,3,p1,h1) ) - - tmpval_2(ipoint) = final_weight_at_r_vector(ipoint) * mos_l_in_r_array_transp(ipoint,p1) * mos_r_in_r_array_transp(ipoint,i) - - tmpvec_1(ipoint,1) = final_weight_at_r_vector(ipoint) * int2_grad1_u12_bimo_t(ipoint,1,p1,i) * mos_r_in_r_array_transp(ipoint,h1) - tmpvec_1(ipoint,2) = final_weight_at_r_vector(ipoint) * int2_grad1_u12_bimo_t(ipoint,2,p1,i) * mos_r_in_r_array_transp(ipoint,h1) - tmpvec_1(ipoint,3) = final_weight_at_r_vector(ipoint) * int2_grad1_u12_bimo_t(ipoint,3,p1,i) * mos_r_in_r_array_transp(ipoint,h1) - - tmpvec_2(ipoint,1) = final_weight_at_r_vector(ipoint) * int2_grad1_u12_bimo_t(ipoint,1,i,h1) * mos_l_in_r_array_transp(ipoint,p1) - tmpvec_2(ipoint,2) = final_weight_at_r_vector(ipoint) * int2_grad1_u12_bimo_t(ipoint,2,i,h1) * mos_l_in_r_array_transp(ipoint,p1) - tmpvec_2(ipoint,3) = final_weight_at_r_vector(ipoint) * int2_grad1_u12_bimo_t(ipoint,3,i,h1) * mos_l_in_r_array_transp(ipoint,p1) - - tmpvec_3(ipoint,1) = final_weight_at_r_vector(ipoint) * int2_grad1_u12_bimo_t(ipoint,1,p1,i) * mos_l_in_r_array_transp(ipoint,i) - tmpvec_3(ipoint,2) = final_weight_at_r_vector(ipoint) * int2_grad1_u12_bimo_t(ipoint,2,p1,i) * mos_l_in_r_array_transp(ipoint,i) - tmpvec_3(ipoint,3) = final_weight_at_r_vector(ipoint) * int2_grad1_u12_bimo_t(ipoint,3,p1,i) * mos_l_in_r_array_transp(ipoint,i) - enddo - - do h2 = 1, mo_num - do ipoint = 1, n_points_final_grid - - tmp2(ipoint,h2) = mos_r_in_r_array_transp(ipoint,h2) * tmpval_1(ipoint) & - + int2_grad1_u12_bimo_t(ipoint,1,i,h2) * tmpvec_1(ipoint,1) & - + int2_grad1_u12_bimo_t(ipoint,2,i,h2) * tmpvec_1(ipoint,2) & - + int2_grad1_u12_bimo_t(ipoint,3,i,h2) * tmpvec_1(ipoint,3) - - tmp1(ipoint,1,h2) = tmpval_2(ipoint) * int2_grad1_u12_bimo_t(ipoint,1,i,h2) - tmp1(ipoint,2,h2) = tmpval_2(ipoint) * int2_grad1_u12_bimo_t(ipoint,2,i,h2) - tmp1(ipoint,3,h2) = tmpval_2(ipoint) * int2_grad1_u12_bimo_t(ipoint,3,i,h2) - - enddo - enddo - - call dgemm( 'T', 'N', mo_num, mo_num, n_points_final_grid, 1.d0 & - , mos_l_in_r_array_transp(1,1), n_points_final_grid & - , tmp2(1,1), n_points_final_grid & - , 0.d0, tmp_2d(1,1), mo_num) - - do h2 = 1, mo_num - do p2 = 1, mo_num - !$OMP CRITICAL - tmp(p2,h2,p1,h1) = tmp(p2,h2,p1,h1) + tmp_2d(p2,h2) - !$OMP END CRITICAL - enddo - enddo - - do p2 = 1, mo_num - do ipoint = 1, n_points_final_grid - - tmp2(ipoint,p2) = int2_grad1_u12_bimo_t(ipoint,1,p2,i) * tmpvec_2(ipoint,1) + int2_grad1_u12_bimo_t(ipoint,1,p2,h1) * tmpvec_3(ipoint,1) & - + int2_grad1_u12_bimo_t(ipoint,2,p2,i) * tmpvec_2(ipoint,2) + int2_grad1_u12_bimo_t(ipoint,2,p2,h1) * tmpvec_3(ipoint,2) & - + int2_grad1_u12_bimo_t(ipoint,3,p2,i) * tmpvec_2(ipoint,3) + int2_grad1_u12_bimo_t(ipoint,3,p2,h1) * tmpvec_3(ipoint,3) - - tmp3(ipoint,1,p2) = int2_grad1_u12_bimo_t(ipoint,1,p2,h1) - tmp3(ipoint,2,p2) = int2_grad1_u12_bimo_t(ipoint,2,p2,h1) - tmp3(ipoint,3,p2) = int2_grad1_u12_bimo_t(ipoint,3,p2,h1) - enddo - enddo - - call dgemm( 'T', 'N', mo_num, mo_num, n_points_final_grid, 1.d0 & - , tmp2(1,1), n_points_final_grid & - , mos_r_in_r_array_transp(1,1), n_points_final_grid & - , 0.d0, tmp_2d(1,1), mo_num) - - call dgemm( 'T', 'N', mo_num, mo_num, 3*n_points_final_grid, 1.d0 & - , tmp3(1,1,1), 3*n_points_final_grid & - , tmp1(1,1,1), 3*n_points_final_grid & - , 1.d0, tmp_2d(1,1), mo_num) - - do h2 = 1, mo_num - do p2 = 1, mo_num - !$OMP CRITICAL - tmp(p2,h2,p1,h1) = tmp(p2,h2,p1,h1) + tmp_2d(p2,h2) - !$OMP END CRITICAL - enddo - enddo - - enddo ! p1 - enddo ! h1 - enddo ! i - !$OMP END DO - - deallocate(tmp_2d) - deallocate(tmp_3d) - deallocate(tmp1) - deallocate(tmp2) - deallocate(tmp3) - deallocate(tmpval_1) - deallocate(tmpval_2) - deallocate(tmpvec_1) - deallocate(tmpvec_2) - deallocate(tmpvec_3) - - !$OMP END PARALLEL - - ! purely open-shell part - if(Ne(2) < Ne(1)) then - - !$OMP PARALLEL & - !$OMP DEFAULT (NONE) & - !$OMP PRIVATE (ipoint, i, ii, h1, h2, p1, p2, & - !$OMP tmp_2d, tmp_3d, tmp1, tmp2, tmp3, & - !$OMP tmpval_1, tmpval_2, & - !$OMP tmpvec_1, tmpvec_2, tmpvec_3) & - !$OMP SHARED (n_points_final_grid, Ne, occ, mo_num, & - !$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) - - allocate(tmp_2d(mo_num,mo_num)) - allocate(tmp_3d(mo_num,mo_num,mo_num)) - allocate(tmp1(n_points_final_grid,3,mo_num)) - allocate(tmp2(n_points_final_grid,mo_num)) - allocate(tmp3(n_points_final_grid,3,mo_num)) - allocate(tmpval_1(n_points_final_grid)) - allocate(tmpval_2(n_points_final_grid)) - allocate(tmpvec_1(n_points_final_grid,3)) - allocate(tmpvec_2(n_points_final_grid,3)) - allocate(tmpvec_3(n_points_final_grid,3)) - - tmp_2d = 0.d0 - tmp_3d = 0.d0 - tmp1 = 0.d0 - tmp2 = 0.d0 - tmp3 = 0.d0 - tmpval_1 = 0.d0 - tmpval_2 = 0.d0 - tmpvec_1 = 0.d0 - tmpvec_2 = 0.d0 - tmpvec_3 = 0.d0 - - !$OMP DO - - do ii = Ne(2) + 1, Ne(1) - i = occ(ii,1) - - do h1 = 1, mo_num - - do ipoint = 1, n_points_final_grid - - tmpval_1(ipoint) = final_weight_at_r_vector(ipoint) * mos_l_in_r_array_transp(ipoint,i) * mos_r_in_r_array_transp(ipoint,i) - - tmpval_2(ipoint) = final_weight_at_r_vector(ipoint) * mos_l_in_r_array_transp(ipoint,i) * mos_r_in_r_array_transp(ipoint,h1) - - tmpvec_1(ipoint,1) = final_weight_at_r_vector(ipoint) * int2_grad1_u12_bimo_t(ipoint,1,i,i) * mos_r_in_r_array_transp(ipoint,h1) - tmpvec_1(ipoint,2) = final_weight_at_r_vector(ipoint) * int2_grad1_u12_bimo_t(ipoint,2,i,i) * mos_r_in_r_array_transp(ipoint,h1) - tmpvec_1(ipoint,3) = final_weight_at_r_vector(ipoint) * int2_grad1_u12_bimo_t(ipoint,3,i,i) * mos_r_in_r_array_transp(ipoint,h1) - - tmpvec_2(ipoint,1) = final_weight_at_r_vector(ipoint) * int2_grad1_u12_bimo_t(ipoint,1,i,h1) * mos_r_in_r_array_transp(ipoint,i) - tmpvec_2(ipoint,2) = final_weight_at_r_vector(ipoint) * int2_grad1_u12_bimo_t(ipoint,2,i,h1) * mos_r_in_r_array_transp(ipoint,i) - tmpvec_2(ipoint,3) = final_weight_at_r_vector(ipoint) * int2_grad1_u12_bimo_t(ipoint,3,i,h1) * mos_r_in_r_array_transp(ipoint,i) - enddo - - do p1 = 1, mo_num - do ipoint = 1, n_points_final_grid - tmp1(ipoint,1,p1) = mos_l_in_r_array_transp(ipoint,p1) * tmpvec_1(ipoint,1) + tmpval_1(ipoint) * int2_grad1_u12_bimo_t(ipoint,1,p1,h1) - tmp1(ipoint,2,p1) = mos_l_in_r_array_transp(ipoint,p1) * tmpvec_1(ipoint,2) + tmpval_1(ipoint) * int2_grad1_u12_bimo_t(ipoint,2,p1,h1) - tmp1(ipoint,3,p1) = mos_l_in_r_array_transp(ipoint,p1) * tmpvec_1(ipoint,3) + tmpval_1(ipoint) * int2_grad1_u12_bimo_t(ipoint,3,p1,h1) - enddo - enddo - - call dgemm( 'T', 'N', mo_num*mo_num, mo_num, 3*n_points_final_grid, 0.5d0 & - , int2_grad1_u12_bimo_t(1,1,1,1), 3*n_points_final_grid & - , tmp1(1,1,1), 3*n_points_final_grid & - , 0.d0, tmp_3d(1,1,1), mo_num*mo_num) - - do p1 = 1, mo_num - do h2 = 1, mo_num - do p2 = 1, mo_num - !$OMP CRITICAL - tmp(p2,h2,p1,h1) = tmp(p2,h2,p1,h1) + tmp_3d(p2,h2,p1) - !$OMP END CRITICAL - enddo - enddo - enddo - - do p2 = 1, mo_num - do ipoint = 1, n_points_final_grid - tmp1(ipoint,1,p2) = tmpval_2(ipoint) * int2_grad1_u12_bimo_t(ipoint,1,p2,i) + mos_l_in_r_array_transp(ipoint,p2) * tmpvec_2(ipoint,1) - tmp1(ipoint,2,p2) = tmpval_2(ipoint) * int2_grad1_u12_bimo_t(ipoint,2,p2,i) + mos_l_in_r_array_transp(ipoint,p2) * tmpvec_2(ipoint,2) - tmp1(ipoint,3,p2) = tmpval_2(ipoint) * int2_grad1_u12_bimo_t(ipoint,3,p2,i) + mos_l_in_r_array_transp(ipoint,p2) * tmpvec_2(ipoint,3) - enddo - enddo - - call dgemm( 'T', 'N', mo_num, mo_num*mo_num, 3*n_points_final_grid, 0.5d0 & - , tmp1(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_3d(1,1,1), mo_num) - - do p1 = 1, mo_num - do h2 = 1, mo_num - do p2 = 1, mo_num - !$OMP CRITICAL - tmp(p2,h2,p1,h1) = tmp(p2,h2,p1,h1) + tmp_3d(p2,p1,h2) - !$OMP END CRITICAL - enddo - enddo - enddo - - do p1 = 1, mo_num - - do ipoint = 1, n_points_final_grid - - tmpval_1(ipoint) = final_weight_at_r_vector(ipoint) * & - ( int2_grad1_u12_bimo_t(ipoint,1,i,i) * int2_grad1_u12_bimo_t(ipoint,1,p1,h1) & - + int2_grad1_u12_bimo_t(ipoint,2,i,i) * int2_grad1_u12_bimo_t(ipoint,2,p1,h1) & - + int2_grad1_u12_bimo_t(ipoint,3,i,i) * int2_grad1_u12_bimo_t(ipoint,3,p1,h1) ) - - tmpval_2(ipoint) = final_weight_at_r_vector(ipoint) * mos_l_in_r_array_transp(ipoint,p1) * mos_r_in_r_array_transp(ipoint,i) - - tmpvec_1(ipoint,1) = final_weight_at_r_vector(ipoint) * int2_grad1_u12_bimo_t(ipoint,1,p1,i) * mos_r_in_r_array_transp(ipoint,h1) - tmpvec_1(ipoint,2) = final_weight_at_r_vector(ipoint) * int2_grad1_u12_bimo_t(ipoint,2,p1,i) * mos_r_in_r_array_transp(ipoint,h1) - tmpvec_1(ipoint,3) = final_weight_at_r_vector(ipoint) * int2_grad1_u12_bimo_t(ipoint,3,p1,i) * mos_r_in_r_array_transp(ipoint,h1) - - tmpvec_2(ipoint,1) = final_weight_at_r_vector(ipoint) * int2_grad1_u12_bimo_t(ipoint,1,i,h1) * mos_l_in_r_array_transp(ipoint,p1) - tmpvec_2(ipoint,2) = final_weight_at_r_vector(ipoint) * int2_grad1_u12_bimo_t(ipoint,2,i,h1) * mos_l_in_r_array_transp(ipoint,p1) - tmpvec_2(ipoint,3) = final_weight_at_r_vector(ipoint) * int2_grad1_u12_bimo_t(ipoint,3,i,h1) * mos_l_in_r_array_transp(ipoint,p1) - - tmpvec_3(ipoint,1) = final_weight_at_r_vector(ipoint) * int2_grad1_u12_bimo_t(ipoint,1,p1,i) * mos_l_in_r_array_transp(ipoint,i) - tmpvec_3(ipoint,2) = final_weight_at_r_vector(ipoint) * int2_grad1_u12_bimo_t(ipoint,2,p1,i) * mos_l_in_r_array_transp(ipoint,i) - tmpvec_3(ipoint,3) = final_weight_at_r_vector(ipoint) * int2_grad1_u12_bimo_t(ipoint,3,p1,i) * mos_l_in_r_array_transp(ipoint,i) - enddo - - do h2 = 1, mo_num - do ipoint = 1, n_points_final_grid - - tmp2(ipoint,h2) = mos_r_in_r_array_transp(ipoint,h2) * tmpval_1(ipoint) & - + int2_grad1_u12_bimo_t(ipoint,1,i,h2) * tmpvec_1(ipoint,1) & - + int2_grad1_u12_bimo_t(ipoint,2,i,h2) * tmpvec_1(ipoint,2) & - + int2_grad1_u12_bimo_t(ipoint,3,i,h2) * tmpvec_1(ipoint,3) - - tmp1(ipoint,1,h2) = tmpval_2(ipoint) * int2_grad1_u12_bimo_t(ipoint,1,i,h2) - tmp1(ipoint,2,h2) = tmpval_2(ipoint) * int2_grad1_u12_bimo_t(ipoint,2,i,h2) - tmp1(ipoint,3,h2) = tmpval_2(ipoint) * int2_grad1_u12_bimo_t(ipoint,3,i,h2) - - enddo - enddo - - call dgemm( 'T', 'N', mo_num, mo_num, n_points_final_grid, 0.5d0 & - , mos_l_in_r_array_transp(1,1), n_points_final_grid & - , tmp2(1,1), n_points_final_grid & - , 0.d0, tmp_2d(1,1), mo_num) - - do h2 = 1, mo_num - do p2 = 1, mo_num - !$OMP CRITICAL - tmp(p2,h2,p1,h1) = tmp(p2,h2,p1,h1) + tmp_2d(p2,h2) - !$OMP END CRITICAL - enddo - enddo - - do p2 = 1, mo_num - do ipoint = 1, n_points_final_grid - - tmp2(ipoint,p2) = int2_grad1_u12_bimo_t(ipoint,1,p2,i) * tmpvec_2(ipoint,1) + int2_grad1_u12_bimo_t(ipoint,1,p2,h1) * tmpvec_3(ipoint,1) & - + int2_grad1_u12_bimo_t(ipoint,2,p2,i) * tmpvec_2(ipoint,2) + int2_grad1_u12_bimo_t(ipoint,2,p2,h1) * tmpvec_3(ipoint,2) & - + int2_grad1_u12_bimo_t(ipoint,3,p2,i) * tmpvec_2(ipoint,3) + int2_grad1_u12_bimo_t(ipoint,3,p2,h1) * tmpvec_3(ipoint,3) - - tmp3(ipoint,1,p2) = int2_grad1_u12_bimo_t(ipoint,1,p2,h1) - tmp3(ipoint,2,p2) = int2_grad1_u12_bimo_t(ipoint,2,p2,h1) - tmp3(ipoint,3,p2) = int2_grad1_u12_bimo_t(ipoint,3,p2,h1) - enddo - enddo - - call dgemm( 'T', 'N', mo_num, mo_num, n_points_final_grid, 0.5d0 & - , tmp2(1,1), n_points_final_grid & - , mos_r_in_r_array_transp(1,1), n_points_final_grid & - , 0.d0, tmp_2d(1,1), mo_num) - - call dgemm( 'T', 'N', mo_num, mo_num, 3*n_points_final_grid, 0.5d0 & - , tmp3(1,1,1), 3*n_points_final_grid & - , tmp1(1,1,1), 3*n_points_final_grid & - , 1.d0, tmp_2d(1,1), mo_num) - - do h2 = 1, mo_num - do p2 = 1, mo_num - !$OMP CRITICAL - tmp(p2,h2,p1,h1) = tmp(p2,h2,p1,h1) + tmp_2d(p2,h2) - !$OMP END CRITICAL - enddo - enddo - - enddo ! p1 - enddo ! h1 - enddo !i - !$OMP END DO - - deallocate(tmp_2d) - deallocate(tmp_3d) - deallocate(tmp1) - deallocate(tmp2) - deallocate(tmp3) - deallocate(tmpval_1) - deallocate(tmpval_2) - deallocate(tmpvec_1) - deallocate(tmpvec_2) - deallocate(tmpvec_3) - - !$OMP END PARALLEL - endif - - tmp = -0.5d0 * tmp - - !$OMP PARALLEL & - !$OMP DEFAULT (NONE) & - !$OMP PRIVATE (h1, h2, p1, p2) & - !$OMP SHARED (tmp, mo_num) - - !$OMP DO - do h1 = 1, mo_num - do h2 = 1, mo_num - do p1 = 1, mo_num - do p2 = p1, mo_num - tmp(p2,h2,p1,h1) -= tmp(p1,h2,p2,h1) - enddo - enddo - enddo - enddo - !$OMP END DO - - !$OMP DO - do h1 = 1, mo_num - do h2 = 1, mo_num - do p1 = 2, mo_num - do p2 = 1, p1-1 - tmp(p2,h2,p1,h1) = -tmp(p1,h2,p2,h1) - enddo - enddo - enddo - enddo - !$OMP END DO - - !$OMP DO - do h1 = 1, mo_num-1 - do h2 = h1+1, mo_num - do p1 = 2, mo_num - do p2 = 1, p1-1 - tmp(p2,h2,p1,h1) *= -1.d0 - enddo - enddo - enddo - enddo - !$OMP END DO - !$OMP END PARALLEL - - call wall_time(wall1) - print*,' Wall time for aaa_contraction', wall1-wall0 - - normal_two_body_bi_orth += tmp - endif ! Ne(2) .ge. 3 - - deallocate(tmp) - - endif ! read_tc_norm_ord - - if(write_tc_norm_ord.and.mpi_master) then - open(unit=11, form="unformatted", file=trim(ezfio_filename)//'/work/normal_two_body_bi_orth', action="write") - call ezfio_set_work_empty(.False.) - write(11) normal_two_body_bi_orth - close(11) - call ezfio_set_tc_keywords_io_tc_integ('Read') - endif - - call wall_time(wallf) - print*,' Wall time for normal_two_body_bi_orth ', wallf-walli - -END_PROVIDER - -! --- - diff --git a/src/tc_scf/fock_three_hermit.irp.f b/src/tc_scf/fock_three_hermit.irp.f deleted file mode 100644 index a936da9b..00000000 --- a/src/tc_scf/fock_three_hermit.irp.f +++ /dev/null @@ -1,376 +0,0 @@ - -! --- - -BEGIN_PROVIDER [ double precision, fock_3_mat, (mo_num, mo_num)] - - implicit none - integer :: i,j - double precision :: contrib - - fock_3_mat = 0.d0 - if(.not.bi_ortho .and. three_body_h_tc) then - - call give_fock_ia_three_e_total(1, 1, contrib) - !! !$OMP PARALLEL & - !! !$OMP DEFAULT (NONE) & - !! !$OMP PRIVATE (i,j,m,integral) & - !! !$OMP SHARED (mo_num,three_body_3_index) - !! !$OMP DO SCHEDULE (guided) COLLAPSE(3) - do i = 1, mo_num - do j = 1, mo_num - call give_fock_ia_three_e_total(j,i,contrib) - fock_3_mat(j,i) = -contrib - enddo - enddo - !else if(bi_ortho.and.three_body_h_tc) then - !! !$OMP END DO - !! !$OMP END PARALLEL - !! do i = 1, mo_num - !! do j = 1, i-1 - !! mat_three(j,i) = mat_three(i,j) - !! enddo - !! enddo - endif - -END_PROVIDER - - -subroutine give_fock_ia_three_e_total(i,a,contrib) - implicit none - BEGIN_DOC -! contrib is the TOTAL (same spins / opposite spins) contribution from the three body term to the Fock operator -! - END_DOC - integer, intent(in) :: i,a - double precision, intent(out) :: contrib - double precision :: int_1, int_2, int_3 - double precision :: mos_i, mos_a, w_ia - double precision :: mos_ia, weight - - integer :: mm, ipoint,k,l - - int_1 = 0.d0 - int_2 = 0.d0 - int_3 = 0.d0 - do mm = 1, 3 - do ipoint = 1, n_points_final_grid - weight = final_weight_at_r_vector(ipoint) - mos_i = mos_in_r_array_transp(ipoint,i) - mos_a = mos_in_r_array_transp(ipoint,a) - mos_ia = mos_a * mos_i - w_ia = x_W_ij_erf_rk(ipoint,mm,i,a) - - int_1 += weight * fock_3_w_kk_sum(ipoint,mm) * (4.d0 * fock_3_rho_beta(ipoint) * w_ia & - + 2.0d0 * mos_ia * fock_3_w_kk_sum(ipoint,mm) & - - 2.0d0 * fock_3_w_ki_mos_k(ipoint,mm,i) * mos_a & - - 2.0d0 * fock_3_w_ki_mos_k(ipoint,mm,a) * mos_i ) - int_2 += weight * (-1.d0) * ( 2.0d0 * fock_3_w_kl_mo_k_mo_l(ipoint,mm) * w_ia & - + 2.0d0 * fock_3_rho_beta(ipoint) * fock_3_w_ki_wk_a(ipoint,mm,i,a) & - + 1.0d0 * mos_ia * fock_3_trace_w_tilde(ipoint,mm) ) - - int_3 += weight * 1.d0 * (fock_3_w_kl_wla_phi_k(ipoint,mm,i) * mos_a + fock_3_w_kl_wla_phi_k(ipoint,mm,a) * mos_i & - +fock_3_w_ki_mos_k(ipoint,mm,i) * fock_3_w_ki_mos_k(ipoint,mm,a) ) - enddo - enddo - contrib = int_1 + int_2 + int_3 - -end - -! --- - -! TODO DGEMM -BEGIN_PROVIDER [double precision, diag_three_elem_hf] - - implicit none - integer :: i, j, k, ipoint, mm - double precision :: contrib, weight, four_third, one_third, two_third, exchange_int_231 - double precision :: integral_aaa, hthree, integral_aab, integral_abb, integral_bbb - - PROVIDE mo_l_coef mo_r_coef - - !print *, ' providing diag_three_elem_hf' - - if(.not. three_body_h_tc) then - - diag_three_elem_hf = 0.d0 - - else - - if(.not. bi_ortho) then - - ! --- - - one_third = 1.d0/3.d0 - two_third = 2.d0/3.d0 - four_third = 4.d0/3.d0 - diag_three_elem_hf = 0.d0 - do i = 1, elec_beta_num - do j = 1, elec_beta_num - do k = 1, elec_beta_num - call give_integrals_3_body(k, j, i, j, i, k, exchange_int_231) - diag_three_elem_hf += two_third * exchange_int_231 - enddo - enddo - enddo - do mm = 1, 3 - do ipoint = 1, n_points_final_grid - weight = final_weight_at_r_vector(ipoint) - contrib = 3.d0 * fock_3_w_kk_sum(ipoint,mm) * fock_3_rho_beta(ipoint) * fock_3_w_kk_sum(ipoint,mm) & - - 2.d0 * fock_3_w_kl_mo_k_mo_l(ipoint,mm) * fock_3_w_kk_sum(ipoint,mm) & - - 1.d0 * fock_3_rho_beta(ipoint) * fock_3_w_kl_w_kl(ipoint,mm) - contrib *= four_third - contrib += -two_third * fock_3_rho_beta(ipoint) * fock_3_w_kl_w_kl(ipoint,mm) & - -four_third * fock_3_w_kk_sum(ipoint,mm) * fock_3_w_kl_mo_k_mo_l(ipoint,mm) - diag_three_elem_hf += weight * contrib - enddo - enddo - - diag_three_elem_hf = - diag_three_elem_hf - - ! --- - - else - - provide mo_l_coef mo_r_coef - call give_aaa_contrib(integral_aaa) - call give_aab_contrib(integral_aab) - call give_abb_contrib(integral_abb) - call give_bbb_contrib(integral_bbb) - diag_three_elem_hf = integral_aaa + integral_aab + integral_abb + integral_bbb -! print*,'integral_aaa + integral_aab + integral_abb + integral_bbb' -! print*,integral_aaa , integral_aab , integral_abb , integral_bbb - - endif - - endif - -END_PROVIDER - -! --- - -BEGIN_PROVIDER [ double precision, fock_3_mat_a_op_sh, (mo_num, mo_num)] - implicit none - integer :: h,p,i,j - double precision :: direct_int, exch_int, exchange_int_231, exchange_int_312 - double precision :: exchange_int_23, exchange_int_12, exchange_int_13 - - fock_3_mat_a_op_sh = 0.d0 - do h = 1, mo_num - do p = 1, mo_num - !F_a^{ab}(h,p) - do i = 1, elec_beta_num ! beta - do j = elec_beta_num+1, elec_alpha_num ! alpha - call give_integrals_3_body(h,j,i,p,j,i,direct_int) ! - call give_integrals_3_body(h,j,i,j,p,i,exch_int) - fock_3_mat_a_op_sh(h,p) -= direct_int - exch_int - enddo - enddo - !F_a^{aa}(h,p) - do i = 1, elec_beta_num ! alpha - do j = elec_beta_num+1, elec_alpha_num ! alpha - call give_integrals_3_body(h,j,i,p,j,i,direct_int) - call give_integrals_3_body(h,j,i,i,p,j,exchange_int_231) - call give_integrals_3_body(h,j,i,j,i,p,exchange_int_312) - call give_integrals_3_body(h,j,i,p,i,j,exchange_int_23) - call give_integrals_3_body(h,j,i,i,j,p,exchange_int_12) - call give_integrals_3_body(h,j,i,j,p,i,exchange_int_13) - fock_3_mat_a_op_sh(h,p) -= ( direct_int + exchange_int_231 + exchange_int_312 & - - exchange_int_23 & ! i <-> j - - exchange_int_12 & ! p <-> j - - exchange_int_13 )! p <-> i - enddo - enddo - enddo - enddo -! symmetrized -! do p = 1, elec_beta_num -! do h = elec_alpha_num +1, mo_num -! fock_3_mat_a_op_sh(h,p) = fock_3_mat_a_op_sh(p,h) -! enddo -! enddo - -! do h = elec_beta_num+1, elec_alpha_num -! do p = elec_alpha_num +1, mo_num -! !F_a^{bb}(h,p) -! do i = 1, elec_beta_num -! do j = i+1, elec_beta_num -! call give_integrals_3_body(h,j,i,p,j,i,direct_int) -! call give_integrals_3_body(h,j,i,p,i,j,exch_int) -! fock_3_mat_a_op_sh(h,p) -= direct_int - exch_int -! enddo -! enddo -! enddo -! enddo - -END_PROVIDER - -BEGIN_PROVIDER [ double precision, fock_3_mat_b_op_sh, (mo_num, mo_num)] - implicit none - integer :: h,p,i,j - double precision :: direct_int, exch_int - fock_3_mat_b_op_sh = 0.d0 - do h = 1, elec_beta_num - do p = elec_alpha_num +1, mo_num - !F_b^{aa}(h,p) - do i = 1, elec_beta_num - do j = elec_beta_num+1, elec_alpha_num - call give_integrals_3_body(h,j,i,p,j,i,direct_int) - call give_integrals_3_body(h,j,i,p,i,j,exch_int) - fock_3_mat_b_op_sh(h,p) += direct_int - exch_int - enddo - enddo - - !F_b^{ab}(h,p) - do i = elec_beta_num+1, elec_beta_num - do j = 1, elec_beta_num - call give_integrals_3_body(h,j,i,p,j,i,direct_int) - call give_integrals_3_body(h,j,i,j,p,i,exch_int) - fock_3_mat_b_op_sh(h,p) += direct_int - exch_int - enddo - enddo - - enddo - enddo - -END_PROVIDER - - -BEGIN_PROVIDER [ double precision, fock_3_w_kk_sum, (n_points_final_grid,3)] - implicit none - integer :: mm, ipoint,k - double precision :: w_kk - fock_3_w_kk_sum = 0.d0 - do k = 1, elec_beta_num - do mm = 1, 3 - do ipoint = 1, n_points_final_grid - w_kk = x_W_ij_erf_rk(ipoint,mm,k,k) - fock_3_w_kk_sum(ipoint,mm) += w_kk - enddo - enddo - enddo -END_PROVIDER - -BEGIN_PROVIDER [ double precision, fock_3_w_ki_mos_k, (n_points_final_grid,3,mo_num)] - implicit none - integer :: mm, ipoint,k,i - double precision :: w_ki, mo_k - fock_3_w_ki_mos_k = 0.d0 - do i = 1, mo_num - do k = 1, elec_beta_num - do mm = 1, 3 - do ipoint = 1, n_points_final_grid - w_ki = x_W_ij_erf_rk(ipoint,mm,k,i) - mo_k = mos_in_r_array(k,ipoint) - fock_3_w_ki_mos_k(ipoint,mm,i) += w_ki * mo_k - enddo - enddo - enddo - enddo - -END_PROVIDER - -BEGIN_PROVIDER [ double precision, fock_3_w_kl_w_kl, (n_points_final_grid,3)] - implicit none - integer :: k,j,ipoint,mm - double precision :: w_kj - fock_3_w_kl_w_kl = 0.d0 - do j = 1, elec_beta_num - do k = 1, elec_beta_num - do mm = 1, 3 - do ipoint = 1, n_points_final_grid - w_kj = x_W_ij_erf_rk(ipoint,mm,k,j) - fock_3_w_kl_w_kl(ipoint,mm) += w_kj * w_kj - enddo - enddo - enddo - enddo - - -END_PROVIDER - -BEGIN_PROVIDER [ double precision, fock_3_rho_beta, (n_points_final_grid)] - implicit none - integer :: ipoint,k - fock_3_rho_beta = 0.d0 - do ipoint = 1, n_points_final_grid - do k = 1, elec_beta_num - fock_3_rho_beta(ipoint) += mos_in_r_array(k,ipoint) * mos_in_r_array(k,ipoint) - enddo - enddo -END_PROVIDER - -BEGIN_PROVIDER [ double precision, fock_3_w_kl_mo_k_mo_l, (n_points_final_grid,3)] - implicit none - integer :: ipoint,k,l,mm - double precision :: mos_k, mos_l, w_kl - fock_3_w_kl_mo_k_mo_l = 0.d0 - do k = 1, elec_beta_num - do l = 1, elec_beta_num - do mm = 1, 3 - do ipoint = 1, n_points_final_grid - mos_k = mos_in_r_array_transp(ipoint,k) - mos_l = mos_in_r_array_transp(ipoint,l) - w_kl = x_W_ij_erf_rk(ipoint,mm,l,k) - fock_3_w_kl_mo_k_mo_l(ipoint,mm) += w_kl * mos_k * mos_l - enddo - enddo - enddo - enddo - -END_PROVIDER - -BEGIN_PROVIDER [ double precision, fock_3_w_ki_wk_a, (n_points_final_grid,3,mo_num, mo_num)] - implicit none - integer :: ipoint,i,a,k,mm - double precision :: w_ki,w_ka - fock_3_w_ki_wk_a = 0.d0 - do i = 1, mo_num - do a = 1, mo_num - do mm = 1, 3 - do ipoint = 1, n_points_final_grid - do k = 1, elec_beta_num - w_ki = x_W_ij_erf_rk(ipoint,mm,k,i) - w_ka = x_W_ij_erf_rk(ipoint,mm,k,a) - fock_3_w_ki_wk_a(ipoint,mm,a,i) += w_ki * w_ka - enddo - enddo - enddo - enddo - enddo -END_PROVIDER - -BEGIN_PROVIDER [ double precision, fock_3_trace_w_tilde, (n_points_final_grid,3)] - implicit none - integer :: ipoint,k,mm - fock_3_trace_w_tilde = 0.d0 - do k = 1, elec_beta_num - do mm = 1, 3 - do ipoint = 1, n_points_final_grid - fock_3_trace_w_tilde(ipoint,mm) += fock_3_w_ki_wk_a(ipoint,mm,k,k) - enddo - enddo - enddo - -END_PROVIDER - -BEGIN_PROVIDER [ double precision, fock_3_w_kl_wla_phi_k, (n_points_final_grid,3,mo_num)] - implicit none - integer :: ipoint,a,k,mm,l - double precision :: w_kl,w_la, mo_k - fock_3_w_kl_wla_phi_k = 0.d0 - do a = 1, mo_num - do k = 1, elec_beta_num - do l = 1, elec_beta_num - do mm = 1, 3 - do ipoint = 1, n_points_final_grid - w_kl = x_W_ij_erf_rk(ipoint,mm,l,k) - w_la = x_W_ij_erf_rk(ipoint,mm,l,a) - mo_k = mos_in_r_array_transp(ipoint,k) - fock_3_w_kl_wla_phi_k(ipoint,mm,a) += w_kl * w_la * mo_k - enddo - enddo - enddo - enddo - enddo -END_PROVIDER - diff --git a/src/tools/NEED b/src/tools/NEED index 0f4e17b0..ea465e92 100644 --- a/src/tools/NEED +++ b/src/tools/NEED @@ -1,5 +1,4 @@ fci -mo_two_e_erf_ints aux_quantities hartree_fock two_body_rdm diff --git a/src/tools/attachement_orb.irp.f b/src/tools/attachement_orb.irp.f new file mode 100644 index 00000000..92a51ca8 --- /dev/null +++ b/src/tools/attachement_orb.irp.f @@ -0,0 +1,168 @@ +program molden_detachment_attachment + implicit none + read_wf=.True. + touch read_wf + call molden_attachment +end + +subroutine molden_attachment + implicit none + BEGIN_DOC + ! Produces a Molden file + END_DOC + character*(128) :: output + integer :: i_unit_output,getUnitAndOpen + integer :: i,j,k,l + double precision, parameter :: a0 = 0.529177249d0 + + PROVIDE ezfio_filename + + output=trim(ezfio_filename)//'.attachement.mol' + print*,'output = ',trim(output) + + i_unit_output = getUnitAndOpen(output,'w') + + write(i_unit_output,'(A)') '[Molden Format]' + + write(i_unit_output,'(A)') '[Atoms] Angs' + do i = 1, nucl_num + write(i_unit_output,'(A2,2X,I4,2X,I4,3(2X,F15.10))') & + trim(element_name(int(nucl_charge(i)))), & + i, & + int(nucl_charge(i)), & + nucl_coord(i,1)*a0, nucl_coord(i,2)*a0, nucl_coord(i,3)*a0 + enddo + + write(i_unit_output,'(A)') '[GTO]' + + character*(1) :: character_shell + integer :: i_shell,i_prim,i_ao + integer :: iorder(ao_num) + integer :: nsort(ao_num) + + i_shell = 0 + i_prim = 0 + do i=1,nucl_num + write(i_unit_output,*) i, 0 + do j=1,nucl_num_shell_aos(i) + i_shell +=1 + i_ao = nucl_list_shell_aos(i,j) + character_shell = trim(ao_l_char(i_ao)) + write(i_unit_output,*) character_shell, ao_prim_num(i_ao), '1.00' + do k = 1, ao_prim_num(i_ao) + i_prim +=1 + write(i_unit_output,'(ES20.10,2X,ES20.10)') ao_expo(i_ao,k), ao_coef(i_ao,k) + enddo + l = i_ao + do while ( ao_l(l) == ao_l(i_ao) ) + nsort(l) = i*10000 + j*100 + l += 1 + if (l > ao_num) exit + enddo + enddo + write(i_unit_output,*)'' + enddo + + + do i=1,ao_num + iorder(i) = i + ! p + if ((ao_power(i,1) == 1 ).and.(ao_power(i,2) == 0 ).and.(ao_power(i,3) == 0 )) then + nsort(i) += 1 + else if ((ao_power(i,1) == 0 ).and.(ao_power(i,2) == 1 ).and.(ao_power(i,3) == 0 )) then + nsort(i) += 2 + else if ((ao_power(i,1) == 0 ).and.(ao_power(i,2) == 0 ).and.(ao_power(i,3) == 1 )) then + nsort(i) += 3 + ! d + else if ((ao_power(i,1) == 2 ).and.(ao_power(i,2) == 0 ).and.(ao_power(i,3) == 0 )) then + nsort(i) += 1 + else if ((ao_power(i,1) == 0 ).and.(ao_power(i,2) == 2 ).and.(ao_power(i,3) == 0 )) then + nsort(i) += 2 + else if ((ao_power(i,1) == 0 ).and.(ao_power(i,2) == 0 ).and.(ao_power(i,3) == 2 )) then + nsort(i) += 3 + else if ((ao_power(i,1) == 1 ).and.(ao_power(i,2) == 1 ).and.(ao_power(i,3) == 0 )) then + nsort(i) += 4 + else if ((ao_power(i,1) == 1 ).and.(ao_power(i,2) == 0 ).and.(ao_power(i,3) == 1 )) then + nsort(i) += 5 + else if ((ao_power(i,1) == 0 ).and.(ao_power(i,2) == 1 ).and.(ao_power(i,3) == 1 )) then + nsort(i) += 6 + ! f + else if ((ao_power(i,1) == 3 ).and.(ao_power(i,2) == 0 ).and.(ao_power(i,3) == 0 )) then + nsort(i) += 1 + else if ((ao_power(i,1) == 0 ).and.(ao_power(i,2) == 3 ).and.(ao_power(i,3) == 0 )) then + nsort(i) += 2 + else if ((ao_power(i,1) == 0 ).and.(ao_power(i,2) == 0 ).and.(ao_power(i,3) == 3 )) then + nsort(i) += 3 + else if ((ao_power(i,1) == 1 ).and.(ao_power(i,2) == 2 ).and.(ao_power(i,3) == 0 )) then + nsort(i) += 4 + else if ((ao_power(i,1) == 2 ).and.(ao_power(i,2) == 1 ).and.(ao_power(i,3) == 0 )) then + nsort(i) += 5 + else if ((ao_power(i,1) == 2 ).and.(ao_power(i,2) == 0 ).and.(ao_power(i,3) == 1 )) then + nsort(i) += 6 + else if ((ao_power(i,1) == 1 ).and.(ao_power(i,2) == 0 ).and.(ao_power(i,3) == 2 )) then + nsort(i) += 7 + else if ((ao_power(i,1) == 0 ).and.(ao_power(i,2) == 1 ).and.(ao_power(i,3) == 2 )) then + nsort(i) += 8 + else if ((ao_power(i,1) == 0 ).and.(ao_power(i,2) == 2 ).and.(ao_power(i,3) == 1 )) then + nsort(i) += 9 + else if ((ao_power(i,1) == 1 ).and.(ao_power(i,2) == 1 ).and.(ao_power(i,3) == 1 )) then + nsort(i) += 10 + ! g + else if ((ao_power(i,1) == 4 ).and.(ao_power(i,2) == 0 ).and.(ao_power(i,3) == 0 )) then + nsort(i) += 1 + else if ((ao_power(i,1) == 0 ).and.(ao_power(i,2) == 4 ).and.(ao_power(i,3) == 0 )) then + nsort(i) += 2 + else if ((ao_power(i,1) == 0 ).and.(ao_power(i,2) == 0 ).and.(ao_power(i,3) == 4 )) then + nsort(i) += 3 + else if ((ao_power(i,1) == 3 ).and.(ao_power(i,2) == 1 ).and.(ao_power(i,3) == 0 )) then + nsort(i) += 4 + else if ((ao_power(i,1) == 3 ).and.(ao_power(i,2) == 0 ).and.(ao_power(i,3) == 1 )) then + nsort(i) += 5 + else if ((ao_power(i,1) == 1 ).and.(ao_power(i,2) == 3 ).and.(ao_power(i,3) == 0 )) then + nsort(i) += 6 + else if ((ao_power(i,1) == 0 ).and.(ao_power(i,2) == 3 ).and.(ao_power(i,3) == 1 )) then + nsort(i) += 7 + else if ((ao_power(i,1) == 1 ).and.(ao_power(i,2) == 0 ).and.(ao_power(i,3) == 3 )) then + nsort(i) += 8 + else if ((ao_power(i,1) == 0 ).and.(ao_power(i,2) == 1 ).and.(ao_power(i,3) == 3 )) then + nsort(i) += 9 + else if ((ao_power(i,1) == 2 ).and.(ao_power(i,2) == 2 ).and.(ao_power(i,3) == 0 )) then + nsort(i) += 10 + else if ((ao_power(i,1) == 2 ).and.(ao_power(i,2) == 0 ).and.(ao_power(i,3) == 2 )) then + nsort(i) += 11 + else if ((ao_power(i,1) == 0 ).and.(ao_power(i,2) == 2 ).and.(ao_power(i,3) == 2 )) then + nsort(i) += 12 + else if ((ao_power(i,1) == 2 ).and.(ao_power(i,2) == 1 ).and.(ao_power(i,3) == 1 )) then + nsort(i) += 13 + else if ((ao_power(i,1) == 1 ).and.(ao_power(i,2) == 2 ).and.(ao_power(i,3) == 1 )) then + nsort(i) += 14 + else if ((ao_power(i,1) == 1 ).and.(ao_power(i,2) == 1 ).and.(ao_power(i,3) == 2 )) then + nsort(i) += 15 + endif + enddo + + call isort(nsort,iorder,ao_num) + write(i_unit_output,'(A)') '[MO]' + integer :: istate + istate = 2 + do i=1,n_dettachment(istate) + write (i_unit_output,*) 'Sym= 1' + write (i_unit_output,*) 'Ene=', dettachment_numbers_sorted(i,istate) + write (i_unit_output,*) 'Spin= Alpha' + write (i_unit_output,*) 'Occup=', dettachment_numbers_sorted(i,istate) + do j=1,ao_num + write(i_unit_output, '(I6,2X,ES20.10)') j, dettachment_orbitals(iorder(j),i,istate) + enddo + enddo + do i=1,n_attachment(istate) + write (i_unit_output,*) 'Sym= 1' + write (i_unit_output,*) 'Ene=', attachment_numbers_sorted(i,istate) + write (i_unit_output,*) 'Spin= Alpha' + write (i_unit_output,*) 'Occup=', attachment_numbers_sorted(i,istate) + do j=1,ao_num + write(i_unit_output, '(I6,2X,ES20.10)') j, attachment_orbitals(iorder(j),i,istate) + enddo + enddo + close(i_unit_output) +end + diff --git a/src/tools/print_sorted_wf_coef.irp.f b/src/tools/print_sorted_wf_coef.irp.f index fa0f1eab..b3c0cb34 100644 --- a/src/tools/print_sorted_wf_coef.irp.f +++ b/src/tools/print_sorted_wf_coef.irp.f @@ -13,7 +13,7 @@ subroutine routine output=trim(ezfio_filename)//'.wf_sorted' i_unit_output = getUnitAndOpen(output,'w') do i= 1, N_det - write(i_unit_output,*)i,dabs(psi_coef_sorted(i,1)) + write(i_unit_output,*)i,dabs(psi_coef_sorted(i,1)),dabs(psi_coef_sorted(i,1)/psi_coef_sorted(1,1)) enddo end diff --git a/src/trexio/LIB b/src/trexio/LIB new file mode 100644 index 00000000..ccff168e --- /dev/null +++ b/src/trexio/LIB @@ -0,0 +1 @@ +-ltrexio diff --git a/src/two_body_rdm/state_av_act_2rdm.irp.f b/src/two_body_rdm/state_av_act_2rdm.irp.f index ea636212..e1bd6439 100644 --- a/src/two_body_rdm/state_av_act_2rdm.irp.f +++ b/src/two_body_rdm/state_av_act_2rdm.irp.f @@ -123,7 +123,7 @@ state_av_act_2_rdm_spin_trace_mo = state_av_act_2_rdm_ab_mo & + state_av_act_2_rdm_aa_mo & + state_av_act_2_rdm_bb_mo - +! ! call orb_range_2_rdm_state_av_openmp(state_av_act_2_rdm_spin_trace_mo,n_act_orb,n_act_orb,list_act,state_weights,ispin,psi_coef,size(psi_coef,2),size(psi_coef,1)) call wall_time(wall_2) diff --git a/src/two_body_rdm/state_av_full_orb_2_rdm.irp.f b/src/two_body_rdm/state_av_full_orb_2_rdm.irp.f index 5fb9e475..851e6b24 100644 --- a/src/two_body_rdm/state_av_full_orb_2_rdm.irp.f +++ b/src/two_body_rdm/state_av_full_orb_2_rdm.irp.f @@ -8,7 +8,7 @@ ! ! = \sum_{istate} w(istate) * ! -! WHERE ALL ORBITALS (i,j,k,l) BELONGS TO ALL OCCUPIED ORBITALS : core, inactive and active +! WHERE ALL ORBITALS (i,j,k,l) BELONG TO ALL OCCUPIED ORBITALS : core, inactive and active ! ! THE NORMALIZATION (i.e. sum of diagonal elements) IS SET TO N_{\alpha} * N_{\beta} * 2 ! @@ -149,7 +149,7 @@ ! ! = \sum_{istate} w(istate) * ! -! WHERE ALL ORBITALS (i,j,k,l) BELONGS TO ALL OCCUPIED ORBITALS : core, inactive and active +! WHERE ALL ORBITALS (i,j,k,l) BELONG TO ALL OCCUPIED ORBITALS : core, inactive and active ! ! THE NORMALIZATION (i.e. sum of diagonal elements) IS SET TO N_{\alpha} * (N_{\alpha} - 1) ! @@ -262,7 +262,7 @@ ! ! = \sum_{istate} w(istate) * ! -! WHERE ALL ORBITALS (i,j,k,l) BELONGS TO ALL OCCUPIED ORBITALS : core, inactive and active +! WHERE ALL ORBITALS (i,j,k,l) BELONG TO ALL OCCUPIED ORBITALS : core, inactive and active ! ! THE NORMALIZATION (i.e. sum of diagonal elements) IS SET TO N_{\beta} * (N_{\beta} - 1) ! @@ -376,7 +376,7 @@ ! = \sum_{istate} w(istate) * \sum_{sigma,sigma'} ! ! -! WHERE ALL ORBITALS (i,j,k,l) BELONGS TO ALL OCCUPIED ORBITALS : core, inactive and active +! WHERE ALL ORBITALS (i,j,k,l) BELONG TO ALL OCCUPIED ORBITALS : core, inactive and active ! ! THE NORMALIZATION (i.e. sum of diagonal elements) IS SET TO N_{elec} * (N_{elec} - 1) ! @@ -619,3 +619,4 @@ !$OMP END PARALLEL END_PROVIDER + diff --git a/src/two_body_rdm/test_2_rdm.irp.f b/src/two_body_rdm/test_2_rdm.irp.f index 4eb8f9f0..123261d8 100644 --- a/src/two_body_rdm/test_2_rdm.irp.f +++ b/src/two_body_rdm/test_2_rdm.irp.f @@ -2,7 +2,7 @@ program test_2_rdm implicit none read_wf = .True. touch read_wf -! call routine_active_only + call routine_active_only call routine_full_mos end diff --git a/src/utils/constants.include.F b/src/utils/constants.include.F index d1727701..422eff95 100644 --- a/src/utils/constants.include.F +++ b/src/utils/constants.include.F @@ -1,6 +1,6 @@ integer, parameter :: max_dim = 511 integer, parameter :: SIMD_vector = 32 -integer, parameter :: N_int_max = 32 +integer, parameter :: N_int_max = 128 double precision, parameter :: pi = dacos(-1.d0) double precision, parameter :: inv_pi = 1.d0/dacos(-1.d0) diff --git a/src/utils/memory.irp.f b/src/utils/memory.irp.f index 41ec0428..ab85c21b 100644 --- a/src/utils/memory.irp.f +++ b/src/utils/memory.irp.f @@ -33,6 +33,8 @@ subroutine resident_memory(value) call usleep(10) value = 0.d0 +IRP_IF MACOS +IRP_ELSE iunit = getUnitAndOpen('/proc/self/status','r') do read(iunit,*,err=10,end=20) key, value @@ -43,6 +45,7 @@ subroutine resident_memory(value) end do 20 continue close(iunit) +IRP_ENDIF value = value / (1024.d0*1024.d0) call unlock_io() end function @@ -58,6 +61,9 @@ subroutine total_memory(value) double precision, intent(out) :: value call lock_io() + value = 0.d0 +IRP_IF MACOS +IRP_ELSE iunit = getUnitAndOpen('/proc/self/status','r') do read(iunit,*,err=10,end=20) key, value @@ -68,6 +74,7 @@ subroutine total_memory(value) end do 20 continue close(iunit) +IRP_ENDIF value = value / (1024.d0*1024.d0) call unlock_io() end function diff --git a/src/utils/util.irp.f b/src/utils/util.irp.f index a9f1a438..ebb13781 100644 --- a/src/utils/util.irp.f +++ b/src/utils/util.irp.f @@ -556,3 +556,28 @@ subroutine sub_A_At(A, N) !$OMP END PARALLEL end + +! --- + +logical function is_same_spin(sigma_1, sigma_2) + + BEGIN_DOC + ! + ! true if sgn(sigma_1) = sgn(sigma_2) + ! + END_DOC + + implicit none + double precision, intent(in) :: sigma_1, sigma_2 + + if((sigma_1 * sigma_2) .gt. 0.d0) then + is_same_spin = .true. + else + is_same_spin = .false. + endif + +end function is_same_spin + +! --- + + diff --git a/src/zmq/LIB b/src/zmq/LIB new file mode 100644 index 00000000..ad8f4d2c --- /dev/null +++ b/src/zmq/LIB @@ -0,0 +1 @@ +-lf77zmq -lzmq