PTEROSOR/QuantumPackage
10
0
Fork 0
mirror of https://github.com/QuantumPackage/qp2.git synced 2024-06-21 20:52:28 +02:00
Code Releases Activity

Merge pull request #1 from QuantumPackage/dev-tc

Browse Source 
Dev tc
This commit is contained in:
AbdAmmar 2022-10-11 10:05:45 +02:00 committed by GitHub
commit 2989703835
No known key found for this signature in database
GPG Key ID: 4AEE18F83AFDEB23
303 changed files with 27295 additions and 2176 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

74
.drone.yml
View File

@ -7,46 +7,46 @@ clone:
depth: 10
steps:
- name: configure debug
image: scemama666/qp2_env
commands:
- ./configure -i all -c ./config/gfortran_debug.cfg
- bash -c "source quantum_package.rc ; exec qp_plugins download https://gitlab.com/scemama/qp_plugins_scemama"
- bash -c "source quantum_package.rc ; exec qp_plugins install champ"
- name: configure
image: scemama666/qp2_env
commands:
- ./configure -i all -c ./config/gfortran_debug.cfg
- bash -c "source quantum_package.rc ; exec qp_plugins download https://gitlab.com/scemama/qp_plugins_scemama"
- bash -c "source quantum_package.rc ; exec qp_plugins install champ"
- name: compile debug
image: scemama666/qp2_env
commands:
- bash -c "source quantum_package.rc ; exec ninja"
- name: compile
image: scemama666/qp2_env
commands:
- bash -c "source quantum_package.rc ; exec ninja"
- name: testing debug
image: scemama666/qp2_env
commands:
- bash -c "source quantum_package.rc ; TRAVIS=1 exec qp_test -a"
- name: testing
image: scemama666/qp2_env
commands:
- bash -c "source quantum_package.rc ; TRAVIS=1 exec qp_test -a"
- name: configure fast
image: scemama666/qp2_env
commands:
- ./configure -c ./config/gfortran_avx.cfg
---
kind: pipeline
type: docker
name: gfortran-avx
- name: compile fast
image: scemama666/qp2_env
commands:
- bash -c "source quantum_package.rc ; exec ninja"
clone:
depth: 10
steps:
- name: configure
image: scemama666/qp2_env
commands:
- ./configure -i all -c ./config/gfortran_avx.cfg
- name: compile
image: scemama666/qp2_env
commands:
- bash -c "source quantum_package.rc ; exec ninja"
- name: testing
image: scemama666/qp2_env
commands:
- bash -c "source quantum_package.rc ; exec qp_test -a"
- name: testing fast
image: scemama666/qp2_env
commands:
- bash -c "source quantum_package.rc ; exec qp_test -a"
- name: notify
image: drillster/drone-email
settings:
host:
from_secret: hostname # irsamc.ups-tlse.fr
from:
from_secret: from # drone@irssv7.ups-tlse.fr
recipients:
from_secret: recipients # scemama@irsamc.ups-tlse.fr
when:
status: [changed, failure]

6
README.md
View File

@ -35,6 +35,12 @@ https://arxiv.org/abs/1902.08154
* [Download the latest release](http://github.com/QuantumPackage/qp2/releases)
* [Read the documentation](https://quantum-package.readthedocs.io)
# Discussion list
For any questions or announcements regarding QuantumPackage, you can join our discussion list by registering [here](https://groupes.renater.fr/sympa/subscribe/quantum_package) or by sending an email to `quantum_package-request@groupes.renater.fr` .
You can also look over its [archives](https://groupes.renater.fr/sympa/arc/quantum_package).
# Build status
* Master [![master build status](https://travis-ci.com/QuantumPackage/qp2.svg?branch=master)](https://travis-ci.org/QuantumPackage/qp2)

13
bin/qp_convert_output_to_ezfio
View File

@ -146,6 +146,17 @@ def write_ezfio(res, filename):
ezfio.set_ao_basis_ao_nucl(at)
ezfio.set_ao_basis_ao_prim_num(num_prim)
ezfio.set_ao_basis_ao_power(power_x + power_y + power_z)
try:
normf = res.normf
if normf == 0:
ezfio.set_ao_basis_ao_normalized(True)
elif normf == 1:
ezfio.set_ao_basis_ao_normalized(False)
else:
print("BUG in NORMF")
sys.exit(0)
except AttributeError:
ezfio.set_ao_basis_ao_normalized(True)
# ~#~#~#~#~#~#~ #
# P a r s i n g #
@ -224,7 +235,7 @@ def write_ezfio(res, filename):
exponent += [p.expo for p in b.prim]
ang_mom.append(str.count(s, "z"))
shell_prim_num.append(len(b.prim))
shell_index += [nshell_tot+1] * len(b.prim)
shell_index += [nshell_tot] * len(b.prim)
# ~#~#~#~#~ #
# W r i t e #

4
bin/qp_set_frozen_core
View File

@ -11,8 +11,8 @@ Usage:
Options:
-q --query Prints in the standard output the number of frozen MOs
-l --large Use a small core
-s --small Use a large core
-l --large Use a large core
-s --small Use a small core
-u --unset Unset frozen core

9
bin/qp_test
View File

@ -60,19 +60,14 @@ def main(arguments):
print("Running tests for %s"%(bats_file))
print("")
if arguments["-v"]:
p = None
if arguments["TEST"]:
test = "export TEST=%s ; "%arguments["TEST"]
else:
test = ""
try:
os.system(test+" python3 bats_to_sh.py "+bats_file+
os.system(test+" python3 bats_to_sh.py "+bats_file+
"| bash")
except:
if p:
p.terminate()
else:
subprocess.check_call(["bats", bats_file], env=os.environ)
subprocess.check_call(["bats", "--verbose-run", "--trace", bats_file], env=os.environ)

2
config/ifort_2019_avx.cfg
View File

@ -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 -DINTEL -DSET_NESTED

2
config/ifort_2019_avx_mpi.cfg
View File

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

2
config/ifort_2019_mpi_rome.cfg
View File

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

2
config/ifort_2019_rome.cfg
View File

@ -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 -DINTEL -DSET_NESTED

2
config/ifort_2019_sse4.cfg
View File

@ -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 -DINTEL -DSET_NESTED

2
config/ifort_2019_sse4_mpi.cfg
View File

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

2
config/ifort_2019_xHost.cfg
View File

@ -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=64 -DINTEL -DSET_NESTED

2
config/ifort_2021_avx.cfg
View File

@ -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 -DINTEL

2
config/ifort_2021_avx_mpi.cfg
View File

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

2
config/ifort_2021_mpi_rome.cfg
View File

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

2
config/ifort_2021_rome.cfg
View File

@ -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 -DINTEL

2
config/ifort_2021_sse4.cfg
View File

@ -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 -DINTEL

2
config/ifort_2021_sse4_mpi.cfg
View File

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

2
config/ifort_2021_xHost.cfg
View File

@ -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=64 -DINTEL

12
configure vendored
View File

@ -180,7 +180,7 @@ if [[ "${PACKAGES}.x" != ".x" ]] ; then
fi
if [[ ${PACKAGES} = all ]] ; then
PACKAGES="zlib ninja zeromq f77zmq gmp ocaml docopt resultsFile bats"
PACKAGES="zlib ninja zeromq f77zmq gmp ocaml docopt resultsFile bats bse"
fi
@ -281,8 +281,8 @@ EOF
execute << EOF
cd "\${QP_ROOT}"/external
tar -zxf qp2-dependencies/bats-v1.1.0.tar.gz
( cd bats-core-1.1.0/ ; ./install.sh \${QP_ROOT})
tar -zxf qp2-dependencies/bats-v1.7.0.tar.gz
( cd bats-core-1.7.0/ ; ./install.sh \${QP_ROOT})
EOF
else
@ -354,12 +354,6 @@ echo " ||----w | "
echo " || || "
echo "~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~"
echo ""
echo "If you have PIP, you can install the Basis Set Exchange command-line tool:"
echo ""
echo " ./configure -i bse"
echo ""
echo "This will enable the usage of qp_basis to install extra basis sets."
echo ""
echo ""
printf "\e[m\n"

2
data/basis/cc-pv5z_ecp_bfd
View File

@ -555,7 +555,7 @@ g 1 1.00
g 1 1.00
1 0.457496 1.000000
MAGNESIUM
MAGNESIUM
s 9 1.00
1 0.030975 0.165290
2 0.062959 0.506272

8
drone/Docker/README.md
View File

@ -1,8 +0,0 @@
Docker files to build the containers used with DroneCI.
Example:
```
docker build -t ubuntu/qp2_env .
```

27
drone/Docker/Ubuntu/Dockerfile
View File

@ -1,27 +0,0 @@
ARG UBUNTU_VERSION=20.04
FROM ubuntu:${UBUNTU_VERSION} AS builder
# Timezone for tzdata
ARG tz=Etc/UTC
RUN echo $tz > /etc/timezone && rm -rf /etc/localtime
# Install
RUN apt-get update && DEBIAN_FRONTEND=noninteractive apt-get install -y \
git \
curl \
wget \
python3 \
gfortran \
gcc \
g++ \
make \
build-essential \
rsync \
unzip \
libopenblas-dev \
pkg-config \
m4
RUN ln -s /usr/bin/python3 /usr/bin/python

16
drone/compilation.sh
View File

@ -1,16 +0,0 @@
#!/bin/bash
# Stage 2
# Extract cache from config stage
cd ../
tar -zxf $HOME/cache/config.tgz
# Configure QP2
cd qp2
source ./quantum_package.rc
ninja -j 1 -v || exit -1
# Create cache
cd ..
tar -zcf $HOME/cache/compil.tgz qp2 && rm $HOME/cache/config.tgz

10
drone/configuration.sh
View File

@ -1,10 +0,0 @@
#!/bin/bash
# Stage 1
# Configure QP2
./configure --download all --install all --config ./config/travis.cfg || exit -1
# Create cache
cd ../
tar -zcf $HOME/cache/config.tgz qp2

30
drone/drone_docker.yml
View File

@ -1,30 +0,0 @@
---
kind: pipeline
type: docker
name: default
clone:
depth: 10
steps:
- name: configure
pull: never
image: ubuntu/qp2_env
commands:
- ./configure -i all -c ./config/gfortran_debug.cfg
- source quantum_package.rc ; qp plugins download https://gitlab.com/scemama/qp_plugins_scemama
- source quantum_package.rc ; qp plugins install champ
- name: compile
pull: never
image: ubuntu/qp2_env
commands:
- ninja
- name: testing
pull: never
image: ubuntu/qp2_env
commands:
- qp test

29
drone/drone_ssh.yml
View File

@ -1,29 +0,0 @@
kind: pipeline
type: ssh
name: default
clone:
depth: 10
server:
host: 130.120.229.139
user: test
password:
from_secret: ssh_pass
steps:
- name: configure
commands:
- ./configure -i all -c ./config/gfortran_debug.cfg
- source quantum_package.rc ; qp plugins download https://gitlab.com/scemama/qp_plugins_scemama
- source quantum_package.rc ; qp plugins install champ
- name: compile
commands:
- ninja
- name: testing
commands:
- qp test

16
drone/testing.sh
View File

@ -1,16 +0,0 @@
#!/bin/bash
# Stage 3
# Extract cache from compile stage
cd ../
tar -zxf $HOME/cache/compil.tgz
# Configure QP2
cd qp2
source ./quantum_package.rc
exec qp_test -a && rm $HOME/cache/compil.tgz

2
etc/qp.rc
View File

@ -80,8 +80,6 @@ function qp()
if [[ -d $NAME ]] ; then
[[ -d $EZFIO_FILE ]] && ezfio unset_file
ezfio set_file $NAME
else
qp_create_ezfio -h | more
fi
unset _ARGS
;;

579
external/Python/docopt.py vendored Normal file
View File

@ -0,0 +1,579 @@
"""Pythonic command-line interface parser that will make you smile.
* http://docopt.org
* Repository and issue-tracker: https://github.com/docopt/docopt
* Licensed under terms of MIT license (see LICENSE-MIT)
* Copyright (c) 2013 Vladimir Keleshev, vladimir@keleshev.com
"""
import sys
import re
__all__ = ['docopt']
__version__ = '0.6.2'
class DocoptLanguageError(Exception):
"""Error in construction of usage-message by developer."""
class DocoptExit(SystemExit):
"""Exit in case user invoked program with incorrect arguments."""
usage = ''
def __init__(self, message=''):
SystemExit.__init__(self, (message + '\n' + self.usage).strip())
class Pattern(object):
def __eq__(self, other):
return repr(self) == repr(other)
def __hash__(self):
return hash(repr(self))
def fix(self):
self.fix_identities()
self.fix_repeating_arguments()
return self
def fix_identities(self, uniq=None):
"""Make pattern-tree tips point to same object if they are equal."""
if not hasattr(self, 'children'):
return self
uniq = list(set(self.flat())) if uniq is None else uniq
for i, c in enumerate(self.children):
if not hasattr(c, 'children'):
assert c in uniq
self.children[i] = uniq[uniq.index(c)]
else:
c.fix_identities(uniq)
def fix_repeating_arguments(self):
"""Fix elements that should accumulate/increment values."""
either = [list(c.children) for c in self.either.children]
for case in either:
for e in [c for c in case if case.count(c) > 1]:
if type(e) is Argument or type(e) is Option and e.argcount:
if e.value is None:
e.value = []
elif type(e.value) is not list:
e.value = e.value.split()
if type(e) is Command or type(e) is Option and e.argcount == 0:
e.value = 0
return self
@property
def either(self):
"""Transform pattern into an equivalent, with only top-level Either."""
# Currently the pattern will not be equivalent, but more "narrow",
# although good enough to reason about list arguments.
ret = []
groups = [[self]]
while groups:
children = groups.pop(0)
types = [type(c) for c in children]
if Either in types:
either = [c for c in children if type(c) is Either][0]
children.pop(children.index(either))
for c in either.children:
groups.append([c] + children)
elif Required in types:
required = [c for c in children if type(c) is Required][0]
children.pop(children.index(required))
groups.append(list(required.children) + children)
elif Optional in types:
optional = [c for c in children if type(c) is Optional][0]
children.pop(children.index(optional))
groups.append(list(optional.children) + children)
elif AnyOptions in types:
optional = [c for c in children if type(c) is AnyOptions][0]
children.pop(children.index(optional))
groups.append(list(optional.children) + children)
elif OneOrMore in types:
oneormore = [c for c in children if type(c) is OneOrMore][0]
children.pop(children.index(oneormore))
groups.append(list(oneormore.children) * 2 + children)
else:
ret.append(children)
return Either(*[Required(*e) for e in ret])
class ChildPattern(Pattern):
def __init__(self, name, value=None):
self.name = name
self.value = value
def __repr__(self):
return '%s(%r, %r)' % (self.__class__.__name__, self.name, self.value)
def flat(self, *types):
return [self] if not types or type(self) in types else []
def match(self, left, collected=None):
collected = [] if collected is None else collected
pos, match = self.single_match(left)
if match is None:
return False, left, collected
left_ = left[:pos] + left[pos + 1:]
same_name = [a for a in collected if a.name == self.name]
if type(self.value) in (int, list):
if type(self.value) is int:
increment = 1
else:
increment = ([match.value] if type(match.value) is str
else match.value)
if not same_name:
match.value = increment
return True, left_, collected + [match]
same_name[0].value += increment
return True, left_, collected
return True, left_, collected + [match]
class ParentPattern(Pattern):
def __init__(self, *children):
self.children = list(children)
def __repr__(self):
return '%s(%s)' % (self.__class__.__name__,
', '.join(repr(a) for a in self.children))
def flat(self, *types):
if type(self) in types:
return [self]
return sum([c.flat(*types) for c in self.children], [])
class Argument(ChildPattern):
def single_match(self, left):
for n, p in enumerate(left):
if type(p) is Argument:
return n, Argument(self.name, p.value)
return None, None
@classmethod
def parse(class_, source):
name = re.findall('(<\S*?>)', source)[0]
value = re.findall('\[default: (.*)\]', source, flags=re.I)
return class_(name, value[0] if value else None)
class Command(Argument):
def __init__(self, name, value=False):
self.name = name
self.value = value
def single_match(self, left):
for n, p in enumerate(left):
if type(p) is Argument:
if p.value == self.name:
return n, Command(self.name, True)
else:
break
return None, None
class Option(ChildPattern):
def __init__(self, short=None, long=None, argcount=0, value=False):
assert argcount in (0, 1)
self.short, self.long = short, long
self.argcount, self.value = argcount, value
self.value = None if value is False and argcount else value
@classmethod
def parse(class_, option_description):
short, long, argcount, value = None, None, 0, False
options, _, description = option_description.strip().partition(' ')
options = options.replace(',', ' ').replace('=', ' ')
for s in options.split():
if s.startswith('--'):
long = s
elif s.startswith('-'):
short = s
else:
argcount = 1
if argcount:
matched = re.findall('\[default: (.*)\]', description, flags=re.I)
value = matched[0] if matched else None
return class_(short, long, argcount, value)
def single_match(self, left):
for n, p in enumerate(left):
if self.name == p.name:
return n, p
return None, None
@property
def name(self):
return self.long or self.short
def __repr__(self):
return 'Option(%r, %r, %r, %r)' % (self.short, self.long,
self.argcount, self.value)
class Required(ParentPattern):
def match(self, left, collected=None):
collected = [] if collected is None else collected
l = left
c = collected
for p in self.children:
matched, l, c = p.match(l, c)
if not matched:
return False, left, collected
return True, l, c
class Optional(ParentPattern):
def match(self, left, collected=None):
collected = [] if collected is None else collected
for p in self.children:
m, left, collected = p.match(left, collected)
return True, left, collected
class AnyOptions(Optional):
"""Marker/placeholder for [options] shortcut."""
class OneOrMore(ParentPattern):
def match(self, left, collected=None):
assert len(self.children) == 1
collected = [] if collected is None else collected
l = left
c = collected
l_ = None
matched = True
times = 0
while matched:
# could it be that something didn't match but changed l or c?
matched, l, c = self.children[0].match(l, c)
times += 1 if matched else 0
if l_ == l:
break
l_ = l
if times >= 1:
return True, l, c
return False, left, collected
class Either(ParentPattern):
def match(self, left, collected=None):
collected = [] if collected is None else collected
outcomes = []
for p in self.children:
matched, _, _ = outcome = p.match(left, collected)
if matched:
outcomes.append(outcome)
if outcomes:
return min(outcomes, key=lambda outcome: len(outcome[1]))
return False, left, collected
class TokenStream(list):
def __init__(self, source, error):
self += source.split() if hasattr(source, 'split') else source
self.error = error
def move(self):
return self.pop(0) if len(self) else None
def current(self):
return self[0] if len(self) else None
def parse_long(tokens, options):
"""long ::= '--' chars [ ( ' ' | '=' ) chars ] ;"""
long, eq, value = tokens.move().partition('=')
assert long.startswith('--')
value = None if eq == value == '' else value
similar = [o for o in options if o.long == long]
if tokens.error is DocoptExit and similar == []: # if no exact match
similar = [o for o in options if o.long and o.long.startswith(long)]
if len(similar) > 1: # might be simply specified ambiguously 2+ times?
raise tokens.error('%s is not a unique prefix: %s?' %
(long, ', '.join(o.long for o in similar)))
elif len(similar) < 1:
argcount = 1 if eq == '=' else 0
o = Option(None, long, argcount)
options.append(o)
if tokens.error is DocoptExit:
o = Option(None, long, argcount, value if argcount else True)
else:
o = Option(similar[0].short, similar[0].long,
similar[0].argcount, similar[0].value)
if o.argcount == 0:
if value is not None:
raise tokens.error('%s must not have an argument' % o.long)
else:
if value is None:
if tokens.current() is None:
raise tokens.error('%s requires argument' % o.long)
value = tokens.move()
if tokens.error is DocoptExit:
o.value = value if value is not None else True
return [o]
def parse_shorts(tokens, options):
"""shorts ::= '-' ( chars )* [ [ ' ' ] chars ] ;"""
token = tokens.move()
assert token.startswith('-') and not token.startswith('--')
left = token.lstrip('-')
parsed = []
while left != '':
short, left = '-' + left[0], left[1:]
similar = [o for o in options if o.short == short]
if len(similar) > 1:
raise tokens.error('%s is specified ambiguously %d times' %
(short, len(similar)))
elif len(similar) < 1:
o = Option(short, None, 0)
options.append(o)
if tokens.error is DocoptExit:
o = Option(short, None, 0, True)
else: # why copying is necessary here?
o = Option(short, similar[0].long,
similar[0].argcount, similar[0].value)
value = None
if o.argcount != 0:
if left == '':
if tokens.current() is None:
raise tokens.error('%s requires argument' % short)
value = tokens.move()
else:
value = left
left = ''
if tokens.error is DocoptExit:
o.value = value if value is not None else True
parsed.append(o)
return parsed
def parse_pattern(source, options):
tokens = TokenStream(re.sub(r'([\[\]\(\)\|]|\.\.\.)', r' \1 ', source),
DocoptLanguageError)
result = parse_expr(tokens, options)
if tokens.current() is not None:
raise tokens.error('unexpected ending: %r' % ' '.join(tokens))
return Required(*result)
def parse_expr(tokens, options):
"""expr ::= seq ( '|' seq )* ;"""
seq = parse_seq(tokens, options)
if tokens.current() != '|':
return seq
result = [Required(*seq)] if len(seq) > 1 else seq
while tokens.current() == '|':
tokens.move()
seq = parse_seq(tokens, options)
result += [Required(*seq)] if len(seq) > 1 else seq
return [Either(*result)] if len(result) > 1 else result
def parse_seq(tokens, options):
"""seq ::= ( atom [ '...' ] )* ;"""
result = []
while tokens.current() not in [None, ']', ')', '|']:
atom = parse_atom(tokens, options)
if tokens.current() == '...':
atom = [OneOrMore(*atom)]
tokens.move()
result += atom
return result
def parse_atom(tokens, options):
"""atom ::= '(' expr ')' | '[' expr ']' | 'options'
| long | shorts | argument | command ;
"""
token = tokens.current()
result = []
if token in '([':
tokens.move()
matching, pattern = {'(': [')', Required], '[': [']', Optional]}[token]
result = pattern(*parse_expr(tokens, options))
if tokens.move() != matching:
raise tokens.error("unmatched '%s'" % token)
return [result]
elif token == 'options':
tokens.move()
return [AnyOptions()]
elif token.startswith('--') and token != '--':
return parse_long(tokens, options)
elif token.startswith('-') and token not in ('-', '--'):
return parse_shorts(tokens, options)
elif token.startswith('<') and token.endswith('>') or token.isupper():
return [Argument(tokens.move())]
else:
return [Command(tokens.move())]
def parse_argv(tokens, options, options_first=False):
"""Parse command-line argument vector.
If options_first:
argv ::= [ long | shorts ]* [ argument ]* [ '--' [ argument ]* ] ;
else:
argv ::= [ long | shorts | argument ]* [ '--' [ argument ]* ] ;
"""
parsed = []
while tokens.current() is not None:
if tokens.current() == '--':
return parsed + [Argument(None, v) for v in tokens]
elif tokens.current().startswith('--'):
parsed += parse_long(tokens, options)
elif tokens.current().startswith('-') and tokens.current() != '-':
parsed += parse_shorts(tokens, options)
elif options_first:
return parsed + [Argument(None, v) for v in tokens]
else:
parsed.append(Argument(None, tokens.move()))
return parsed
def parse_defaults(doc):
# in python < 2.7 you can't pass flags=re.MULTILINE
split = re.split('\n *(<\S+?>|-\S+?)', doc)[1:]
split = [s1 + s2 for s1, s2 in zip(split[::2], split[1::2])]
options = [Option.parse(s) for s in split if s.startswith('-')]
#arguments = [Argument.parse(s) for s in split if s.startswith('<')]
#return options, arguments
return options
def printable_usage(doc):
# in python < 2.7 you can't pass flags=re.IGNORECASE
usage_split = re.split(r'([Uu][Ss][Aa][Gg][Ee]:)', doc)
if len(usage_split) < 3:
raise DocoptLanguageError('"usage:" (case-insensitive) not found.')
if len(usage_split) > 3:
raise DocoptLanguageError('More than one "usage:" (case-insensitive).')
return re.split(r'\n\s*\n', ''.join(usage_split[1:]))[0].strip()
def formal_usage(printable_usage):
pu = printable_usage.split()[1:] # split and drop "usage:"
return '( ' + ' '.join(') | (' if s == pu[0] else s for s in pu[1:]) + ' )'
def extras(help, version, options, doc):
if help and any((o.name in ('-h', '--help')) and o.value for o in options):
print(doc.strip("\n"))
sys.exit()
if version and any(o.name == '--version' and o.value for o in options):
print(version)
sys.exit()
class Dict(dict):
def __repr__(self):
return '{%s}' % ',\n '.join('%r: %r' % i for i in sorted(self.items()))
def docopt(doc, argv=None, help=True, version=None, options_first=False):
"""Parse `argv` based on command-line interface described in `doc`.
`docopt` creates your command-line interface based on its
description that you pass as `doc`. Such description can contain
--options, <positional-argument>, commands, which could be
[optional], (required), (mutually | exclusive) or repeated...
Parameters
----------
doc : str
Description of your command-line interface.
argv : list of str, optional
Argument vector to be parsed. sys.argv[1:] is used if not
provided.
help : bool (default: True)
Set to False to disable automatic help on -h or --help
options.
version : any object
If passed, the object will be printed if --version is in
`argv`.
options_first : bool (default: False)
Set to True to require options preceed positional arguments,
i.e. to forbid options and positional arguments intermix.
Returns
-------
args : dict
A dictionary, where keys are names of command-line elements
such as e.g. "--verbose" and "<path>", and values are the
parsed values of those elements.
Example
-------
>>> from docopt import docopt
>>> doc = '''
Usage:
my_program tcp <host> <port> [--timeout=<seconds>]
my_program serial <port> [--baud=<n>] [--timeout=<seconds>]
my_program (-h | --help | --version)
Options:
-h, --help Show this screen and exit.
--baud=<n> Baudrate [default: 9600]
'''
>>> argv = ['tcp', '127.0.0.1', '80', '--timeout', '30']
>>> docopt(doc, argv)
{'--baud': '9600',
'--help': False,
'--timeout': '30',
'--version': False,
'<host>': '127.0.0.1',
'<port>': '80',
'serial': False,
'tcp': True}
See also
--------
* For video introduction see http://docopt.org
* Full documentation is available in README.rst as well as online
at https://github.com/docopt/docopt#readme
"""
if argv is None:
argv = sys.argv[1:]
DocoptExit.usage = printable_usage(doc)
options = parse_defaults(doc)
pattern = parse_pattern(formal_usage(DocoptExit.usage), options)
# [default] syntax for argument is disabled
#for a in pattern.flat(Argument):
# same_name = [d for d in arguments if d.name == a.name]
# if same_name:
# a.value = same_name[0].value
argv = parse_argv(TokenStream(argv, DocoptExit), list(options),
options_first)
pattern_options = set(pattern.flat(Option))
for ao in pattern.flat(AnyOptions):
doc_options = parse_defaults(doc)
ao.children = list(set(doc_options) - pattern_options)
#if any_options:
# ao.children += [Option(o.short, o.long, o.argcount)
# for o in argv if type(o) is Option]
extras(help, version, argv, doc)
matched, left, collected = pattern.fix().match(argv)
if matched and left == []: # better error message if left?
return Dict((a.name, a.value) for a in (pattern.flat() + collected))
raise DocoptExit()

2
external/qp2-dependencies vendored

@ -1 +1 @@
Subproject commit 90ee61f5041c7c94a0c605625a264860292813a0
Subproject commit 242151e03d1d6bf042387226431d82d35845686a

617
include/f77_zmq.h Normal file
View File

@ -0,0 +1,617 @@
integer EADDRINUSE
integer EADDRNOTAVAIL
integer EAFNOSUPPORT
integer ECONNABORTED
integer ECONNREFUSED
integer ECONNRESET
integer EFSM
integer EHOSTUNREACH
integer EINPROGRESS
integer EMSGSIZE
integer EMTHREAD
integer ENETDOWN
integer ENETRESET
integer ENETUNREACH
integer ENOBUFS
integer ENOCOMPATPROTO
integer ENOTCONN
integer ENOTSOCK
integer ENOTSUP
integer EPROTONOSUPPORT
integer ETERM
integer ETIMEDOUT
integer ZMQ_AFFINITY
integer ZMQ_BACKLOG
integer ZMQ_BINDTODEVICE
integer ZMQ_BLOCKY
integer ZMQ_CHANNEL
integer ZMQ_CLIENT
integer ZMQ_CONFLATE
integer ZMQ_CONNECT_RID
integer ZMQ_CONNECT_ROUTING_ID
integer ZMQ_CONNECT_TIMEOUT
integer ZMQ_CURRENT_EVENT_VERSION
integer ZMQ_CURRENT_EVENT_VERSION_DRAFT
integer ZMQ_CURVE
integer ZMQ_CURVE_PUBLICKEY
integer ZMQ_CURVE_SECRETKEY
integer ZMQ_CURVE_SERVER
integer ZMQ_CURVE_SERVERKEY
integer ZMQ_DEALER
integer ZMQ_DEFINED_STDINT
integer ZMQ_DELAY_ATTACH_ON_CONNECT
integer ZMQ_DGRAM
integer ZMQ_DISCONNECT_MSG
integer ZMQ_DISH
integer ZMQ_DONTWAIT
integer ZMQ_EVENTS
integer ZMQ_EVENT_ACCEPTED
integer ZMQ_EVENT_ACCEPT_FAILED
integer ZMQ_EVENT_ALL
integer ZMQ_EVENT_ALL_V1
integer ZMQ_EVENT_ALL_V2
integer ZMQ_EVENT_BIND_FAILED
integer ZMQ_EVENT_CLOSED
integer ZMQ_EVENT_CLOSE_FAILED
integer ZMQ_EVENT_CONNECTED
integer ZMQ_EVENT_CONNECT_DELAYED
integer ZMQ_EVENT_CONNECT_RETRIED
integer ZMQ_EVENT_DISCONNECTED
integer ZMQ_EVENT_HANDSHAKE_FAILED_AUTH
integer ZMQ_EVENT_HANDSHAKE_FAILED_NO_DETAIL
integer ZMQ_EVENT_HANDSHAKE_FAILED_PROTOCOL
integer ZMQ_EVENT_HANDSHAKE_SUCCEEDED
integer ZMQ_EVENT_LISTENING
integer ZMQ_EVENT_MONITOR_STOPPED
integer ZMQ_EVENT_PIPES_STATS
integer ZMQ_FAIL_UNROUTABLE
integer ZMQ_FD
integer ZMQ_FORWARDER
integer ZMQ_GATHER
integer ZMQ_GROUP_MAX_LENGTH
integer ZMQ_GSSAPI
integer ZMQ_GSSAPI_NT_HOSTBASED
integer ZMQ_GSSAPI_NT_KRB5_PRINCIPAL
integer ZMQ_GSSAPI_NT_USER_NAME
integer ZMQ_GSSAPI_PLAINTEXT
integer ZMQ_GSSAPI_PRINCIPAL
integer ZMQ_GSSAPI_PRINCIPAL_NAMETYPE
integer ZMQ_GSSAPI_SERVER
integer ZMQ_GSSAPI_SERVICE_PRINCIPAL
integer ZMQ_GSSAPI_SERVICE_PRINCIPAL_NAMETYPE
integer ZMQ_HANDSHAKE_IVL
integer ZMQ_HAS_CAPABILITIES
integer ZMQ_HAUSNUMERO
integer ZMQ_HEARTBEAT_IVL
integer ZMQ_HEARTBEAT_TIMEOUT
integer ZMQ_HEARTBEAT_TTL
integer ZMQ_HELLO_MSG
integer ZMQ_IDENTITY
integer ZMQ_IMMEDIATE
integer ZMQ_INVERT_MATCHING
integer ZMQ_IN_BATCH_SIZE
integer ZMQ_IO_THREADS
integer ZMQ_IO_THREADS_DFLT
integer ZMQ_IPC_FILTER_GID
integer ZMQ_IPC_FILTER_PID
integer ZMQ_IPC_FILTER_UID
integer ZMQ_IPV4ONLY
integer ZMQ_IPV6
integer ZMQ_LAST_ENDPOINT
integer ZMQ_LINGER
integer ZMQ_LOOPBACK_FASTPATH
integer ZMQ_MAXMSGSIZE
integer ZMQ_MAX_MSGSZ
integer ZMQ_MAX_SOCKETS
integer ZMQ_MAX_SOCKETS_DFLT
integer ZMQ_MECHANISM
integer ZMQ_METADATA
integer ZMQ_MORE
integer ZMQ_MSG_T_SIZE
integer ZMQ_MULTICAST_HOPS
integer ZMQ_MULTICAST_LOOP
integer ZMQ_MULTICAST_MAXTPDU
integer ZMQ_NOBLOCK
integer ZMQ_NOTIFY_CONNECT
integer ZMQ_NOTIFY_DISCONNECT
integer ZMQ_NULL
integer ZMQ_ONLY_FIRST_SUBSCRIBE
integer ZMQ_OUT_BATCH_SIZE
integer ZMQ_PAIR
integer ZMQ_PEER
integer ZMQ_PLAIN
integer ZMQ_PLAIN_PASSWORD
integer ZMQ_PLAIN_SERVER
integer ZMQ_PLAIN_USERNAME
integer ZMQ_POLLERR
integer ZMQ_POLLIN
integer ZMQ_POLLITEMS_DFLT
integer ZMQ_POLLOUT
integer ZMQ_POLLPRI
integer ZMQ_PRIORITY
integer ZMQ_PROBE_ROUTER
integer ZMQ_PROTOCOL_ERROR_WS_UNSPECIFIED
integer ZMQ_PROTOCOL_ERROR_ZAP_BAD_REQUEST_ID
integer ZMQ_PROTOCOL_ERROR_ZAP_BAD_VERSION
integer ZMQ_PROTOCOL_ERROR_ZAP_INVALID_METADATA
integer ZMQ_PROTOCOL_ERROR_ZAP_INVALID_STATUS_CODE
integer ZMQ_PROTOCOL_ERROR_ZAP_MALFORMED_REPLY
integer ZMQ_PROTOCOL_ERROR_ZAP_UNSPECIFIED
integer ZMQ_PROTOCOL_ERROR_ZMTP_CRYPTOGRAPHIC
integer ZMQ_PROTOCOL_ERROR_ZMTP_INVALID_METADATA
integer ZMQ_PROTOCOL_ERROR_ZMTP_INVALID_SEQUENCE
integer ZMQ_PROTOCOL_ERROR_ZMTP_KEY_EXCHANGE
integer ZMQ_PROTOCOL_ERROR_ZMTP_MALFORMED_COMMAND_ERROR
integer ZMQ_PROTOCOL_ERROR_ZMTP_MALFORMED_COMMAND_HELLO
integer ZMQ_PROTOCOL_ERROR_ZMTP_MALFORMED_COMMAND_INITIATE
integer ZMQ_PROTOCOL_ERROR_ZMTP_MALFORMED_COMMAND_MESSAGE
integer ZMQ_PROTOCOL_ERROR_ZMTP_MALFORMED_COMMAND_READY
integer ZMQ_PROTOCOL_ERROR_ZMTP_MALFORMED_COMMAND_UNSPECIFIED
integer ZMQ_PROTOCOL_ERROR_ZMTP_MALFORMED_COMMAND_WELCOME
integer ZMQ_PROTOCOL_ERROR_ZMTP_MECHANISM_MISMATCH
integer ZMQ_PROTOCOL_ERROR_ZMTP_UNEXPECTED_COMMAND
integer ZMQ_PROTOCOL_ERROR_ZMTP_UNSPECIFIED
integer ZMQ_PTR
integer ZMQ_PUB
integer ZMQ_PULL
integer ZMQ_PUSH
integer ZMQ_QUEUE
integer ZMQ_RADIO
integer ZMQ_RATE
integer ZMQ_RCVBUF
integer ZMQ_RCVHWM
integer ZMQ_RCVMORE
integer ZMQ_RCVTIMEO
integer ZMQ_RECONNECT_IVL
integer ZMQ_RECONNECT_IVL_MAX
integer ZMQ_RECONNECT_STOP
integer ZMQ_RECONNECT_STOP_AFTER_DISCONNECT
integer ZMQ_RECONNECT_STOP_CONN_REFUSED
integer ZMQ_RECONNECT_STOP_HANDSHAKE_FAILED
integer ZMQ_RECOVERY_IVL
integer ZMQ_REP
integer ZMQ_REQ
integer ZMQ_REQ_CORRELATE
integer ZMQ_REQ_RELAXED
integer ZMQ_ROUTER
integer ZMQ_ROUTER_BEHAVIOR
integer ZMQ_ROUTER_HANDOVER
integer ZMQ_ROUTER_MANDATORY
integer ZMQ_ROUTER_NOTIFY
integer ZMQ_ROUTER_RAW
integer ZMQ_ROUTING_ID
integer ZMQ_SCATTER
integer ZMQ_SERVER
integer ZMQ_SHARED
integer ZMQ_SNDBUF
integer ZMQ_SNDHWM
integer ZMQ_SNDMORE
integer ZMQ_SNDTIMEO
integer ZMQ_SOCKET_LIMIT
integer ZMQ_SOCKS_PASSWORD
integer ZMQ_SOCKS_PROXY
integer ZMQ_SOCKS_USERNAME
integer ZMQ_SRCFD
integer ZMQ_STREAM
integer ZMQ_STREAMER
integer ZMQ_STREAM_NOTIFY
integer ZMQ_SUB
integer ZMQ_SUBSCRIBE
integer ZMQ_TCP_ACCEPT_FILTER
integer ZMQ_TCP_KEEPALIVE
integer ZMQ_TCP_KEEPALIVE_CNT
integer ZMQ_TCP_KEEPALIVE_IDLE
integer ZMQ_TCP_KEEPALIVE_INTVL
integer ZMQ_TCP_MAXRT
integer ZMQ_THREAD_AFFINITY_CPU_ADD
integer ZMQ_THREAD_AFFINITY_CPU_REMOVE
integer ZMQ_THREAD_NAME_PREFIX
integer ZMQ_THREAD_PRIORITY
integer ZMQ_THREAD_PRIORITY_DFLT
integer ZMQ_THREAD_SAFE
integer ZMQ_THREAD_SCHED_POLICY
integer ZMQ_THREAD_SCHED_POLICY_DFLT
integer ZMQ_TOS
integer ZMQ_TYPE
integer ZMQ_UNSUBSCRIBE
integer ZMQ_USE_FD
integer ZMQ_VERSION
integer ZMQ_VERSION_MAJOR
integer ZMQ_VERSION_MINOR
integer ZMQ_VERSION_PATCH
integer ZMQ_VMCI_BUFFER_MAX_SIZE
integer ZMQ_VMCI_BUFFER_MIN_SIZE
integer ZMQ_VMCI_BUFFER_SIZE
integer ZMQ_VMCI_CONNECT_TIMEOUT
integer ZMQ_WSS_CERT_PEM
integer ZMQ_WSS_HOSTNAME
integer ZMQ_WSS_KEY_PEM
integer ZMQ_WSS_TRUST_PEM
integer ZMQ_WSS_TRUST_SYSTEM
integer ZMQ_XPUB
integer ZMQ_XPUB_MANUAL
integer ZMQ_XPUB_MANUAL_LAST_VALUE
integer ZMQ_XPUB_NODROP
integer ZMQ_XPUB_VERBOSE
integer ZMQ_XPUB_VERBOSER
integer ZMQ_XPUB_WELCOME_MSG
integer ZMQ_XREP
integer ZMQ_XREQ
integer ZMQ_XSUB
integer ZMQ_ZAP_DOMAIN
integer ZMQ_ZAP_ENFORCE_DOMAIN
integer ZMQ_ZERO_COPY_RECV
parameter(EADDRINUSE=156384717)
parameter(EADDRNOTAVAIL=156384718)
parameter(EAFNOSUPPORT=156384723)
parameter(ECONNABORTED=156384725)
parameter(ECONNREFUSED=156384719)
parameter(ECONNRESET=156384726)
parameter(EFSM=156384763)
parameter(EHOSTUNREACH=156384729)
parameter(EINPROGRESS=156384720)
parameter(EMSGSIZE=156384722)
parameter(EMTHREAD=156384766)
parameter(ENETDOWN=156384716)
parameter(ENETRESET=156384730)
parameter(ENETUNREACH=156384724)
parameter(ENOBUFS=156384715)
parameter(ENOCOMPATPROTO=156384764)
parameter(ENOTCONN=156384727)
parameter(ENOTSOCK=156384721)
parameter(ENOTSUP=156384713)
parameter(EPROTONOSUPPORT=156384714)
parameter(ETERM=156384765)
parameter(ETIMEDOUT=156384728)
parameter(ZMQ_AFFINITY=4)
parameter(ZMQ_BACKLOG=19)
parameter(ZMQ_BINDTODEVICE=92)
parameter(ZMQ_BLOCKY=70)
parameter(ZMQ_CHANNEL=20)
parameter(ZMQ_CLIENT=13)
parameter(ZMQ_CONFLATE=54)
parameter(ZMQ_CONNECT_RID=61)
parameter(ZMQ_CONNECT_ROUTING_ID=61)
parameter(ZMQ_CONNECT_TIMEOUT=79)
parameter(ZMQ_CURRENT_EVENT_VERSION=1)
parameter(ZMQ_CURRENT_EVENT_VERSION_DRAFT=2)
parameter(ZMQ_CURVE=2)
parameter(ZMQ_CURVE_PUBLICKEY=48)
parameter(ZMQ_CURVE_SECRETKEY=49)
parameter(ZMQ_CURVE_SERVER=47)
parameter(ZMQ_CURVE_SERVERKEY=50)
parameter(ZMQ_DEALER=5)
parameter(ZMQ_DEFINED_STDINT=1)
parameter(ZMQ_DELAY_ATTACH_ON_CONNECT=39)
parameter(ZMQ_DGRAM=18)
parameter(ZMQ_DISCONNECT_MSG=111)
parameter(ZMQ_DISH=15)
parameter(ZMQ_DONTWAIT=1)
parameter(ZMQ_EVENTS=15)
parameter(ZMQ_EVENT_ACCEPTED=32)
parameter(ZMQ_EVENT_ACCEPT_FAILED=64)
parameter(ZMQ_EVENT_ALL=65535)
parameter(ZMQ_EVENT_ALL_V1=65535)
parameter(ZMQ_EVENT_ALL_V2=131071)
parameter(ZMQ_EVENT_BIND_FAILED=16)
parameter(ZMQ_EVENT_CLOSED=128)
parameter(ZMQ_EVENT_CLOSE_FAILED=256)
parameter(ZMQ_EVENT_CONNECTED=1)
parameter(ZMQ_EVENT_CONNECT_DELAYED=2)
parameter(ZMQ_EVENT_CONNECT_RETRIED=4)
parameter(ZMQ_EVENT_DISCONNECTED=512)
parameter(ZMQ_EVENT_HANDSHAKE_FAILED_AUTH=16384)
parameter(ZMQ_EVENT_HANDSHAKE_FAILED_NO_DETAIL=2048)
parameter(ZMQ_EVENT_HANDSHAKE_FAILED_PROTOCOL=8192)
parameter(ZMQ_EVENT_HANDSHAKE_SUCCEEDED=4096)
parameter(ZMQ_EVENT_LISTENING=8)
parameter(ZMQ_EVENT_MONITOR_STOPPED=1024)
parameter(ZMQ_EVENT_PIPES_STATS=65536)
parameter(ZMQ_FAIL_UNROUTABLE=33)
parameter(ZMQ_FD=14)
parameter(ZMQ_FORWARDER=2)
parameter(ZMQ_GATHER=16)
parameter(ZMQ_GROUP_MAX_LENGTH=255)
parameter(ZMQ_GSSAPI=3)
parameter(ZMQ_GSSAPI_NT_HOSTBASED=0)
parameter(ZMQ_GSSAPI_NT_KRB5_PRINCIPAL=2)
parameter(ZMQ_GSSAPI_NT_USER_NAME=1)
parameter(ZMQ_GSSAPI_PLAINTEXT=65)
parameter(ZMQ_GSSAPI_PRINCIPAL=63)
parameter(ZMQ_GSSAPI_PRINCIPAL_NAMETYPE=90)
parameter(ZMQ_GSSAPI_SERVER=62)
parameter(ZMQ_GSSAPI_SERVICE_PRINCIPAL=64)
parameter(ZMQ_GSSAPI_SERVICE_PRINCIPAL_NAMETYPE=91)
parameter(ZMQ_HANDSHAKE_IVL=66)
parameter(ZMQ_HAS_CAPABILITIES=1)
parameter(ZMQ_HAUSNUMERO=156384712)
parameter(ZMQ_HEARTBEAT_IVL=75)
parameter(ZMQ_HEARTBEAT_TIMEOUT=77)
parameter(ZMQ_HEARTBEAT_TTL=76)
parameter(ZMQ_HELLO_MSG=110)
parameter(ZMQ_IDENTITY=5)
parameter(ZMQ_IMMEDIATE=39)
parameter(ZMQ_INVERT_MATCHING=74)
parameter(ZMQ_IN_BATCH_SIZE=101)
parameter(ZMQ_IO_THREADS=1)
parameter(ZMQ_IO_THREADS_DFLT=1)
parameter(ZMQ_IPC_FILTER_GID=60)
parameter(ZMQ_IPC_FILTER_PID=58)
parameter(ZMQ_IPC_FILTER_UID=59)
parameter(ZMQ_IPV4ONLY=31)
parameter(ZMQ_IPV6=42)
parameter(ZMQ_LAST_ENDPOINT=32)
parameter(ZMQ_LINGER=17)
parameter(ZMQ_LOOPBACK_FASTPATH=94)
parameter(ZMQ_MAXMSGSIZE=22)
parameter(ZMQ_MAX_MSGSZ=5)
parameter(ZMQ_MAX_SOCKETS=2)
parameter(ZMQ_MAX_SOCKETS_DFLT=1023)
parameter(ZMQ_MECHANISM=43)
parameter(ZMQ_METADATA=95)
parameter(ZMQ_MORE=1)
parameter(ZMQ_MSG_T_SIZE=6)
parameter(ZMQ_MULTICAST_HOPS=25)
parameter(ZMQ_MULTICAST_LOOP=96)
parameter(ZMQ_MULTICAST_MAXTPDU=84)
parameter(ZMQ_NOBLOCK=1)
parameter(ZMQ_NOTIFY_CONNECT=1)
parameter(ZMQ_NOTIFY_DISCONNECT=2)
parameter(ZMQ_NULL=0)
parameter(ZMQ_ONLY_FIRST_SUBSCRIBE=108)
parameter(ZMQ_OUT_BATCH_SIZE=102)
parameter(ZMQ_PAIR=0)
parameter(ZMQ_PEER=19)
parameter(ZMQ_PLAIN=1)
parameter(ZMQ_PLAIN_PASSWORD=46)
parameter(ZMQ_PLAIN_SERVER=44)
parameter(ZMQ_PLAIN_USERNAME=45)
parameter(ZMQ_POLLERR=4)
parameter(ZMQ_POLLIN=1)
parameter(ZMQ_POLLITEMS_DFLT=16)
parameter(ZMQ_POLLOUT=2)
parameter(ZMQ_POLLPRI=8)
parameter(ZMQ_PRIORITY=112)
parameter(ZMQ_PROBE_ROUTER=51)
parameter(ZMQ_PROTOCOL_ERROR_WS_UNSPECIFIED=805306368)
parameter(ZMQ_PROTOCOL_ERROR_ZAP_BAD_REQUEST_ID=536870914)
parameter(ZMQ_PROTOCOL_ERROR_ZAP_BAD_VERSION=536870915)
parameter(ZMQ_PROTOCOL_ERROR_ZAP_INVALID_METADATA=536870917)
parameter(ZMQ_PROTOCOL_ERROR_ZAP_INVALID_STATUS_CODE=536870916)
parameter(ZMQ_PROTOCOL_ERROR_ZAP_MALFORMED_REPLY=536870913)
parameter(ZMQ_PROTOCOL_ERROR_ZAP_UNSPECIFIED=536870912)
parameter(ZMQ_PROTOCOL_ERROR_ZMTP_CRYPTOGRAPHIC=285212673)
parameter(ZMQ_PROTOCOL_ERROR_ZMTP_INVALID_METADATA=268435480)
parameter(ZMQ_PROTOCOL_ERROR_ZMTP_INVALID_SEQUENCE=268435458)
parameter(ZMQ_PROTOCOL_ERROR_ZMTP_KEY_EXCHANGE=268435459)
parameter(
& ZMQ_PROTOCOL_ERROR_ZMTP_MALFORMED_COMMAND_ERROR=268435477)
parameter(
& ZMQ_PROTOCOL_ERROR_ZMTP_MALFORMED_COMMAND_HELLO=268435475)
parameter(
& ZMQ_PROTOCOL_ERROR_ZMTP_MALFORMED_COMMAND_INITIATE=268435476)
parameter(
& ZMQ_PROTOCOL_ERROR_ZMTP_MALFORMED_COMMAND_MESSAGE=268435474)
parameter(
& ZMQ_PROTOCOL_ERROR_ZMTP_MALFORMED_COMMAND_READY=268435478)
parameter(
& ZMQ_PROTOCOL_ERROR_ZMTP_MALFORMED_COMMAND_UNSPECIFIED=268435473)
parameter(
& ZMQ_PROTOCOL_ERROR_ZMTP_MALFORMED_COMMAND_WELCOME=268435479)
parameter(ZMQ_PROTOCOL_ERROR_ZMTP_MECHANISM_MISMATCH=285212674)
parameter(ZMQ_PROTOCOL_ERROR_ZMTP_UNEXPECTED_COMMAND=268435457)
parameter(ZMQ_PROTOCOL_ERROR_ZMTP_UNSPECIFIED=268435456)
parameter(ZMQ_PTR=8)
parameter(ZMQ_PUB=1)
parameter(ZMQ_PULL=7)
parameter(ZMQ_PUSH=8)
parameter(ZMQ_QUEUE=3)
parameter(ZMQ_RADIO=14)
parameter(ZMQ_RATE=8)
parameter(ZMQ_RCVBUF=12)
parameter(ZMQ_RCVHWM=24)
parameter(ZMQ_RCVMORE=13)
parameter(ZMQ_RCVTIMEO=27)
parameter(ZMQ_RECONNECT_IVL=18)
parameter(ZMQ_RECONNECT_IVL_MAX=21)
parameter(ZMQ_RECONNECT_STOP=109)
parameter(ZMQ_RECONNECT_STOP_AFTER_DISCONNECT=3)
parameter(ZMQ_RECONNECT_STOP_CONN_REFUSED=1)
parameter(ZMQ_RECONNECT_STOP_HANDSHAKE_FAILED=2)
parameter(ZMQ_RECOVERY_IVL=9)
parameter(ZMQ_REP=4)
parameter(ZMQ_REQ=3)
parameter(ZMQ_REQ_CORRELATE=52)
parameter(ZMQ_REQ_RELAXED=53)
parameter(ZMQ_ROUTER=6)
parameter(ZMQ_ROUTER_BEHAVIOR=33)
parameter(ZMQ_ROUTER_HANDOVER=56)
parameter(ZMQ_ROUTER_MANDATORY=33)
parameter(ZMQ_ROUTER_NOTIFY=97)
parameter(ZMQ_ROUTER_RAW=41)
parameter(ZMQ_ROUTING_ID=5)
parameter(ZMQ_SCATTER=17)
parameter(ZMQ_SERVER=12)
parameter(ZMQ_SHARED=3)
parameter(ZMQ_SNDBUF=11)
parameter(ZMQ_SNDHWM=23)
parameter(ZMQ_SNDMORE=2)
parameter(ZMQ_SNDTIMEO=28)
parameter(ZMQ_SOCKET_LIMIT=3)
parameter(ZMQ_SOCKS_PASSWORD=100)
parameter(ZMQ_SOCKS_PROXY=68)
parameter(ZMQ_SOCKS_USERNAME=99)
parameter(ZMQ_SRCFD=2)
parameter(ZMQ_STREAM=11)
parameter(ZMQ_STREAMER=1)
parameter(ZMQ_STREAM_NOTIFY=73)
parameter(ZMQ_SUB=2)
parameter(ZMQ_SUBSCRIBE=6)
parameter(ZMQ_TCP_ACCEPT_FILTER=38)
parameter(ZMQ_TCP_KEEPALIVE=34)
parameter(ZMQ_TCP_KEEPALIVE_CNT=35)
parameter(ZMQ_TCP_KEEPALIVE_IDLE=36)
parameter(ZMQ_TCP_KEEPALIVE_INTVL=37)
parameter(ZMQ_TCP_MAXRT=80)
parameter(ZMQ_THREAD_AFFINITY_CPU_ADD=7)
parameter(ZMQ_THREAD_AFFINITY_CPU_REMOVE=8)
parameter(ZMQ_THREAD_NAME_PREFIX=9)
parameter(ZMQ_THREAD_PRIORITY=3)
parameter(ZMQ_THREAD_PRIORITY_DFLT=-1)
parameter(ZMQ_THREAD_SAFE=81)
parameter(ZMQ_THREAD_SCHED_POLICY=4)
parameter(ZMQ_THREAD_SCHED_POLICY_DFLT=-1)
parameter(ZMQ_TOS=57)
parameter(ZMQ_TYPE=16)
parameter(ZMQ_UNSUBSCRIBE=7)
parameter(ZMQ_USE_FD=89)
parameter(ZMQ_VERSION=40304)
parameter(ZMQ_VERSION_MAJOR=4)
parameter(ZMQ_VERSION_MINOR=3)
parameter(ZMQ_VERSION_PATCH=4)
parameter(ZMQ_VMCI_BUFFER_MAX_SIZE=87)
parameter(ZMQ_VMCI_BUFFER_MIN_SIZE=86)
parameter(ZMQ_VMCI_BUFFER_SIZE=85)
parameter(ZMQ_VMCI_CONNECT_TIMEOUT=88)
parameter(ZMQ_WSS_CERT_PEM=104)
parameter(ZMQ_WSS_HOSTNAME=106)
parameter(ZMQ_WSS_KEY_PEM=103)
parameter(ZMQ_WSS_TRUST_PEM=105)
parameter(ZMQ_WSS_TRUST_SYSTEM=107)
parameter(ZMQ_XPUB=9)
parameter(ZMQ_XPUB_MANUAL=71)
parameter(ZMQ_XPUB_MANUAL_LAST_VALUE=98)
parameter(ZMQ_XPUB_NODROP=69)
parameter(ZMQ_XPUB_VERBOSE=40)
parameter(ZMQ_XPUB_VERBOSER=78)
parameter(ZMQ_XPUB_WELCOME_MSG=72)
parameter(ZMQ_XREP=6)
parameter(ZMQ_XREQ=5)
parameter(ZMQ_XSUB=10)
parameter(ZMQ_ZAP_DOMAIN=55)
parameter(ZMQ_ZAP_ENFORCE_DOMAIN=93)
parameter(ZMQ_ZERO_COPY_RECV=10)
integer f77_zmq_bind
external f77_zmq_bind
integer f77_zmq_close
external f77_zmq_close
integer f77_zmq_connect
external f77_zmq_connect
integer f77_zmq_ctx_destroy
external f77_zmq_ctx_destroy
integer f77_zmq_ctx_get
external f77_zmq_ctx_get
integer*8 f77_zmq_ctx_new
external f77_zmq_ctx_new
integer f77_zmq_ctx_set
external f77_zmq_ctx_set
integer f77_zmq_ctx_shutdown
external f77_zmq_ctx_shutdown
integer f77_zmq_ctx_term
external f77_zmq_ctx_term
integer f77_zmq_disconnect
external f77_zmq_disconnect
integer f77_zmq_errno
external f77_zmq_errno
integer f77_zmq_getsockopt
external f77_zmq_getsockopt
integer f77_zmq_microsleep
external f77_zmq_microsleep
integer f77_zmq_msg_close
external f77_zmq_msg_close
integer f77_zmq_msg_copy
external f77_zmq_msg_copy
integer f77_zmq_msg_copy_from_data
external f77_zmq_msg_copy_from_data
integer f77_zmq_msg_copy_to_data
external f77_zmq_msg_copy_to_data
integer f77_zmq_msg_copy_to_data8
external f77_zmq_msg_copy_to_data8
integer*8 f77_zmq_msg_data
external f77_zmq_msg_data
integer*8 f77_zmq_msg_data_new
external f77_zmq_msg_data_new
integer f77_zmq_msg_destroy
external f77_zmq_msg_destroy
integer f77_zmq_msg_destroy_data
external f77_zmq_msg_destroy_data
integer f77_zmq_msg_get
external f77_zmq_msg_get
character*(64) f77_zmq_msg_gets
external f77_zmq_msg_gets
integer f77_zmq_msg_init
external f77_zmq_msg_init
integer f77_zmq_msg_init_data
external f77_zmq_msg_init_data
integer f77_zmq_msg_init_size
external f77_zmq_msg_init_size
integer f77_zmq_msg_more
external f77_zmq_msg_more
integer f77_zmq_msg_move
external f77_zmq_msg_move
integer*8 f77_zmq_msg_new
external f77_zmq_msg_new
integer f77_zmq_msg_recv
external f77_zmq_msg_recv
integer*8 f77_zmq_msg_recv8
external f77_zmq_msg_recv8
integer f77_zmq_msg_send
external f77_zmq_msg_send
integer*8 f77_zmq_msg_send8
external f77_zmq_msg_send8
integer f77_zmq_msg_set
external f77_zmq_msg_set
integer f77_zmq_msg_size
external f77_zmq_msg_size
integer*8 f77_zmq_msg_size8
external f77_zmq_msg_size8
integer f77_zmq_poll
external f77_zmq_poll
integer f77_zmq_pollitem_destroy
external f77_zmq_pollitem_destroy
integer*8 f77_zmq_pollitem_new
external f77_zmq_pollitem_new
integer f77_zmq_pollitem_revents
external f77_zmq_pollitem_revents
integer f77_zmq_pollitem_set_events
external f77_zmq_pollitem_set_events
integer f77_zmq_pollitem_set_socket
external f77_zmq_pollitem_set_socket
integer f77_zmq_proxy
external f77_zmq_proxy
integer f77_zmq_proxy_steerable
external f77_zmq_proxy_steerable
integer f77_zmq_recv
external f77_zmq_recv
integer*8 f77_zmq_recv8
external f77_zmq_recv8
integer f77_zmq_send
external f77_zmq_send
integer*8 f77_zmq_send8
external f77_zmq_send8
integer f77_zmq_send_const
external f77_zmq_send_const
integer*8 f77_zmq_send_const8
external f77_zmq_send_const8
integer f77_zmq_setsockopt
external f77_zmq_setsockopt
integer*8 f77_zmq_socket
external f77_zmq_socket
integer f77_zmq_socket_monitor
external f77_zmq_socket_monitor
character*(64) f77_zmq_strerror
external f77_zmq_strerror
integer f77_zmq_term
external f77_zmq_term
integer f77_zmq_unbind
external f77_zmq_unbind
integer f77_zmq_version
external f77_zmq_version
integer pthread_create
external pthread_create
integer pthread_create_arg
external pthread_create_arg
integer pthread_detach
external pthread_detach
integer pthread_join
external pthread_join

113
ocaml/Input_ao_two_e_eff_pot.ml Normal file
View File

@ -0,0 +1,113 @@
(* =~=~ *)
(* Init *)
(* =~=~ *)
open Qptypes;;
open Qputils;;
open Sexplib.Std;;
module Ao_two_e_eff_pot : sig
(* Generate type *)
type t =
{
adjoint_tc_h : bool;
grad_squared : bool;
} [@@deriving sexp]
;;
val read : unit -> t option
val write : t-> unit
val to_string : t -> string
val to_rst : t -> Rst_string.t
val of_rst : Rst_string.t -> t option
end = struct
(* Generate type *)
type t =
{
adjoint_tc_h : bool;
grad_squared : bool;
} [@@deriving sexp]
;;
let get_default = Qpackage.get_ezfio_default "ao_two_e_eff_pot";;
(* =~=~=~=~=~=~==~=~=~=~=~=~ *)
(* Generate Special Function *)
(* =~=~=~==~=~~=~=~=~=~=~=~=~ *)
(* Read snippet for adjoint_tc_h *)
let read_adjoint_tc_h () =
if not (Ezfio.has_ao_two_e_eff_pot_adjoint_tc_h ()) then
get_default "adjoint_tc_h"
|> bool_of_string
|> Ezfio.set_ao_two_e_eff_pot_adjoint_tc_h
;
Ezfio.get_ao_two_e_eff_pot_adjoint_tc_h ()
;;
(* Write snippet for adjoint_tc_h *)
let write_adjoint_tc_h =
Ezfio.set_ao_two_e_eff_pot_adjoint_tc_h
;;
(* Read snippet for grad_squared *)
let read_grad_squared () =
if not (Ezfio.has_ao_two_e_eff_pot_grad_squared ()) then
get_default "grad_squared"
|> bool_of_string
|> Ezfio.set_ao_two_e_eff_pot_grad_squared
;
Ezfio.get_ao_two_e_eff_pot_grad_squared ()
;;
(* Write snippet for grad_squared *)
let write_grad_squared =
Ezfio.set_ao_two_e_eff_pot_grad_squared
;;
(* =~=~=~=~=~=~=~=~=~=~=~=~ *)
(* Generate Global Function *)
(* =~=~=~=~=~=~=~=~=~=~=~=~ *)
(* Read all *)
let read() =
Some
{
adjoint_tc_h = read_adjoint_tc_h ();
grad_squared = read_grad_squared ();
}
;;
(* Write all *)
let write{
adjoint_tc_h;
grad_squared;
} =
write_adjoint_tc_h adjoint_tc_h;
write_grad_squared grad_squared;
;;
(* to_string*)
let to_string b =
Printf.sprintf "
adjoint_tc_h = %s
grad_squared = %s
"
(string_of_bool b.adjoint_tc_h)
(string_of_bool b.grad_squared)
;;
(* to_rst*)
let to_rst b =
Printf.sprintf "
If |true|, you compute the adjoint of the transcorrelated Hamiltonian ::
adjoint_tc_h = %s
If |true|, you compute also the square of the gradient of the correlation factor ::
grad_squared = %s
"
(string_of_bool b.adjoint_tc_h)
(string_of_bool b.grad_squared)
|> Rst_string.of_string
;;
include Generic_input_of_rst;;
let of_rst = of_rst t_of_sexp;;
end

87
ocaml/Input_bi_ortho_mos.ml Normal file
View File

@ -0,0 +1,87 @@
(* =~=~ *)
(* Init *)
(* =~=~ *)
open Qptypes;;
open Qputils;;
open Sexplib.Std;;
module Bi_ortho_mos : sig
(* Generate type *)
type t =
{
bi_ortho : bool;
} [@@deriving sexp]
;;
val read : unit -> t option
val write : t-> unit
val to_string : t -> string
val to_rst : t -> Rst_string.t
val of_rst : Rst_string.t -> t option
end = struct
(* Generate type *)
type t =
{
bi_ortho : bool;
} [@@deriving sexp]
;;
let get_default = Qpackage.get_ezfio_default "bi_ortho_mos";;
(* =~=~=~=~=~=~==~=~=~=~=~=~ *)
(* Generate Special Function *)
(* =~=~=~==~=~~=~=~=~=~=~=~=~ *)
(* Read snippet for bi_ortho *)
let read_bi_ortho () =
if not (Ezfio.has_bi_ortho_mos_bi_ortho ()) then
get_default "bi_ortho"
|> bool_of_string
|> Ezfio.set_bi_ortho_mos_bi_ortho
;
Ezfio.get_bi_ortho_mos_bi_ortho ()
;;
(* Write snippet for bi_ortho *)
let write_bi_ortho =
Ezfio.set_bi_ortho_mos_bi_ortho
;;
(* =~=~=~=~=~=~=~=~=~=~=~=~ *)
(* Generate Global Function *)
(* =~=~=~=~=~=~=~=~=~=~=~=~ *)
(* Read all *)
let read() =
Some
{
bi_ortho = read_bi_ortho ();
}
;;
(* Write all *)
let write{
bi_ortho;
} =
write_bi_ortho bi_ortho;
;;
(* to_string*)
let to_string b =
Printf.sprintf "
bi_ortho = %s
"
(string_of_bool b.bi_ortho)
;;
(* to_rst*)
let to_rst b =
Printf.sprintf "
If |true|, the MO basis is assumed to be bi-orthonormal ::
bi_ortho = %s
"
(string_of_bool b.bi_ortho)
|> Rst_string.of_string
;;
include Generic_input_of_rst;;
let of_rst = of_rst t_of_sexp;;
end

113
ocaml/Input_cassd.ml Normal file
View File

@ -0,0 +1,113 @@
(* =~=~ *)
(* Init *)
(* =~=~ *)
open Qptypes;;
open Qputils;;
open Sexplib.Std;;
module Cassd : sig
(* Generate type *)
type t =
{
do_ddci : bool;
do_only_1h1p : bool;
} [@@deriving sexp]
;;
val read : unit -> t option
val write : t-> unit
val to_string : t -> string
val to_rst : t -> Rst_string.t
val of_rst : Rst_string.t -> t option
end = struct
(* Generate type *)
type t =
{
do_ddci : bool;
do_only_1h1p : bool;
} [@@deriving sexp]
;;
let get_default = Qpackage.get_ezfio_default "cassd";;
(* =~=~=~=~=~=~==~=~=~=~=~=~ *)
(* Generate Special Function *)
(* =~=~=~==~=~~=~=~=~=~=~=~=~ *)
(* Read snippet for do_ddci *)
let read_do_ddci () =
if not (Ezfio.has_cassd_do_ddci ()) then
get_default "do_ddci"
|> bool_of_string
|> Ezfio.set_cassd_do_ddci
;
Ezfio.get_cassd_do_ddci ()
;;
(* Write snippet for do_ddci *)
let write_do_ddci =
Ezfio.set_cassd_do_ddci
;;
(* Read snippet for do_only_1h1p *)
let read_do_only_1h1p () =
if not (Ezfio.has_cassd_do_only_1h1p ()) then
get_default "do_only_1h1p"
|> bool_of_string
|> Ezfio.set_cassd_do_only_1h1p
;
Ezfio.get_cassd_do_only_1h1p ()
;;
(* Write snippet for do_only_1h1p *)
let write_do_only_1h1p =
Ezfio.set_cassd_do_only_1h1p
;;
(* =~=~=~=~=~=~=~=~=~=~=~=~ *)
(* Generate Global Function *)
(* =~=~=~=~=~=~=~=~=~=~=~=~ *)
(* Read all *)
let read() =
Some
{
do_ddci = read_do_ddci ();
do_only_1h1p = read_do_only_1h1p ();
}
;;
(* Write all *)
let write{
do_ddci;
do_only_1h1p;
} =
write_do_ddci do_ddci;
write_do_only_1h1p do_only_1h1p;
;;
(* to_string*)
let to_string b =
Printf.sprintf "
do_ddci = %s
do_only_1h1p = %s
"
(string_of_bool b.do_ddci)
(string_of_bool b.do_only_1h1p)
;;
(* to_rst*)
let to_rst b =
Printf.sprintf "
If true, remove purely inactive double excitations ::
do_ddci = %s
If true, do only one hole/one particle excitations ::
do_only_1h1p = %s
"
(string_of_bool b.do_ddci)
(string_of_bool b.do_only_1h1p)
|> Rst_string.of_string
;;
include Generic_input_of_rst;;
let of_rst = of_rst t_of_sexp;;
end

243
ocaml/Input_cipsi_deb.ml Normal file
View File

@ -0,0 +1,243 @@
(* =~=~ *)
(* Init *)
(* =~=~ *)
open Qptypes;;
open Qputils;;
open Sexplib.Std;;
module Cipsi_deb : sig
(* Generate type *)
type t =
{
pert_2rdm : bool;
save_wf_after_selection : bool;
seniority_max : int;
excitation_ref : int;
excitation_max : int;
excitation_alpha_max : int;
excitation_beta_max : int;
} [@@deriving sexp]
;;
val read : unit -> t option
val write : t-> unit
val to_string : t -> string
val to_rst : t -> Rst_string.t
val of_rst : Rst_string.t -> t option
end = struct
(* Generate type *)
type t =
{
pert_2rdm : bool;
save_wf_after_selection : bool;
seniority_max : int;
excitation_ref : int;
excitation_max : int;
excitation_alpha_max : int;
excitation_beta_max : int;
} [@@deriving sexp]
;;
let get_default = Qpackage.get_ezfio_default "cipsi_deb";;
(* =~=~=~=~=~=~==~=~=~=~=~=~ *)
(* Generate Special Function *)
(* =~=~=~==~=~~=~=~=~=~=~=~=~ *)
(* Read snippet for excitation_alpha_max *)
let read_excitation_alpha_max () =
if not (Ezfio.has_cipsi_deb_excitation_alpha_max ()) then
get_default "excitation_alpha_max"
|> int_of_string
|> Ezfio.set_cipsi_deb_excitation_alpha_max
;
Ezfio.get_cipsi_deb_excitation_alpha_max ()
;;
(* Write snippet for excitation_alpha_max *)
let write_excitation_alpha_max =
Ezfio.set_cipsi_deb_excitation_alpha_max
;;
(* Read snippet for excitation_beta_max *)
let read_excitation_beta_max () =
if not (Ezfio.has_cipsi_deb_excitation_beta_max ()) then
get_default "excitation_beta_max"
|> int_of_string
|> Ezfio.set_cipsi_deb_excitation_beta_max
;
Ezfio.get_cipsi_deb_excitation_beta_max ()
;;
(* Write snippet for excitation_beta_max *)
let write_excitation_beta_max =
Ezfio.set_cipsi_deb_excitation_beta_max
;;
(* Read snippet for excitation_max *)
let read_excitation_max () =
if not (Ezfio.has_cipsi_deb_excitation_max ()) then
get_default "excitation_max"
|> int_of_string
|> Ezfio.set_cipsi_deb_excitation_max
;
Ezfio.get_cipsi_deb_excitation_max ()
;;
(* Write snippet for excitation_max *)
let write_excitation_max =
Ezfio.set_cipsi_deb_excitation_max
;;
(* Read snippet for excitation_ref *)
let read_excitation_ref () =
if not (Ezfio.has_cipsi_deb_excitation_ref ()) then
get_default "excitation_ref"
|> int_of_string
|> Ezfio.set_cipsi_deb_excitation_ref
;
Ezfio.get_cipsi_deb_excitation_ref ()
;;
(* Write snippet for excitation_ref *)
let write_excitation_ref =
Ezfio.set_cipsi_deb_excitation_ref
;;
(* Read snippet for pert_2rdm *)
let read_pert_2rdm () =
if not (Ezfio.has_cipsi_deb_pert_2rdm ()) then
get_default "pert_2rdm"
|> bool_of_string
|> Ezfio.set_cipsi_deb_pert_2rdm
;
Ezfio.get_cipsi_deb_pert_2rdm ()
;;
(* Write snippet for pert_2rdm *)
let write_pert_2rdm =
Ezfio.set_cipsi_deb_pert_2rdm
;;
(* Read snippet for save_wf_after_selection *)
let read_save_wf_after_selection () =
if not (Ezfio.has_cipsi_deb_save_wf_after_selection ()) then
get_default "save_wf_after_selection"
|> bool_of_string
|> Ezfio.set_cipsi_deb_save_wf_after_selection
;
Ezfio.get_cipsi_deb_save_wf_after_selection ()
;;
(* Write snippet for save_wf_after_selection *)
let write_save_wf_after_selection =
Ezfio.set_cipsi_deb_save_wf_after_selection
;;
(* Read snippet for seniority_max *)
let read_seniority_max () =
if not (Ezfio.has_cipsi_deb_seniority_max ()) then
get_default "seniority_max"
|> int_of_string
|> Ezfio.set_cipsi_deb_seniority_max
;
Ezfio.get_cipsi_deb_seniority_max ()
;;
(* Write snippet for seniority_max *)
let write_seniority_max =
Ezfio.set_cipsi_deb_seniority_max
;;
(* =~=~=~=~=~=~=~=~=~=~=~=~ *)
(* Generate Global Function *)
(* =~=~=~=~=~=~=~=~=~=~=~=~ *)
(* Read all *)
let read() =
Some
{
pert_2rdm = read_pert_2rdm ();
save_wf_after_selection = read_save_wf_after_selection ();
seniority_max = read_seniority_max ();
excitation_ref = read_excitation_ref ();
excitation_max = read_excitation_max ();
excitation_alpha_max = read_excitation_alpha_max ();
excitation_beta_max = read_excitation_beta_max ();
}
;;
(* Write all *)
let write{
pert_2rdm;
save_wf_after_selection;
seniority_max;
excitation_ref;
excitation_max;
excitation_alpha_max;
excitation_beta_max;
} =
write_pert_2rdm pert_2rdm;
write_save_wf_after_selection save_wf_after_selection;
write_seniority_max seniority_max;
write_excitation_ref excitation_ref;
write_excitation_max excitation_max;
write_excitation_alpha_max excitation_alpha_max;
write_excitation_beta_max excitation_beta_max;
;;
(* to_string*)
let to_string b =
Printf.sprintf "
pert_2rdm = %s
save_wf_after_selection = %s
seniority_max = %s
excitation_ref = %s
excitation_max = %s
excitation_alpha_max = %s
excitation_beta_max = %s
"
(string_of_bool b.pert_2rdm)
(string_of_bool b.save_wf_after_selection)
(string_of_int b.seniority_max)
(string_of_int b.excitation_ref)
(string_of_int b.excitation_max)
(string_of_int b.excitation_alpha_max)
(string_of_int b.excitation_beta_max)
;;
(* to_rst*)
let to_rst b =
Printf.sprintf "
If true, computes the one- and two-body rdms with perturbation theory ::
pert_2rdm = %s
If true, saves the wave function after the selection, before the diagonalization ::
save_wf_after_selection = %s
Maximum number of allowed open shells. Using -1 selects all determinants ::
seniority_max = %s
1: Hartree-Fock determinant, 2:All determinants of the dominant configuration ::
excitation_ref = %s
Maximum number of excitation with respect to the Hartree-Fock determinant. Using -1 selects all determinants ::
excitation_max = %s
Maximum number of excitation for alpha determinants with respect to the Hartree-Fock determinant. Using -1 selects all determinants ::
excitation_alpha_max = %s
Maximum number of excitation for beta determinants with respect to the Hartree-Fock determinant. Using -1 selects all determinants ::
excitation_beta_max = %s
"
(string_of_bool b.pert_2rdm)
(string_of_bool b.save_wf_after_selection)
(string_of_int b.seniority_max)
(string_of_int b.excitation_ref)
(string_of_int b.excitation_max)
(string_of_int b.excitation_alpha_max)
(string_of_int b.excitation_beta_max)
|> Rst_string.of_string
;;
include Generic_input_of_rst;;
let of_rst = of_rst t_of_sexp;;
end

351
ocaml/Input_tc_h_clean.ml Normal file
View File

@ -0,0 +1,351 @@
(* =~=~ *)
(* Init *)
(* =~=~ *)
open Qptypes;;
open Qputils;;
open Sexplib.Std;;
module Tc_h_clean : sig
(* Generate type *)
type t =
{
read_rl_eigv : bool;
comp_left_eigv : bool;
three_body_h_tc : bool;
pure_three_body_h_tc : bool;
double_normal_ord : bool;
core_tc_op : bool;
full_tc_h_solver : bool;
thresh_it_dav : Threshold.t;
max_it_dav : int;
thresh_psi_r : Threshold.t;
thresh_psi_r_norm : bool;
} [@@deriving sexp]
;;
val read : unit -> t option
val write : t-> unit
val to_string : t -> string
val to_rst : t -> Rst_string.t
val of_rst : Rst_string.t -> t option
end = struct
(* Generate type *)
type t =
{
read_rl_eigv : bool;
comp_left_eigv : bool;
three_body_h_tc : bool;
pure_three_body_h_tc : bool;
double_normal_ord : bool;
core_tc_op : bool;
full_tc_h_solver : bool;
thresh_it_dav : Threshold.t;
max_it_dav : int;
thresh_psi_r : Threshold.t;
thresh_psi_r_norm : bool;
} [@@deriving sexp]
;;
let get_default = Qpackage.get_ezfio_default "tc_h_clean";;
(* =~=~=~=~=~=~==~=~=~=~=~=~ *)
(* Generate Special Function *)
(* =~=~=~==~=~~=~=~=~=~=~=~=~ *)
(* Read snippet for comp_left_eigv *)
let read_comp_left_eigv () =
if not (Ezfio.has_tc_h_clean_comp_left_eigv ()) then
get_default "comp_left_eigv"
|> bool_of_string
|> Ezfio.set_tc_h_clean_comp_left_eigv
;
Ezfio.get_tc_h_clean_comp_left_eigv ()
;;
(* Write snippet for comp_left_eigv *)
let write_comp_left_eigv =
Ezfio.set_tc_h_clean_comp_left_eigv
;;
(* Read snippet for core_tc_op *)
let read_core_tc_op () =
if not (Ezfio.has_tc_h_clean_core_tc_op ()) then
get_default "core_tc_op"
|> bool_of_string
|> Ezfio.set_tc_h_clean_core_tc_op
;
Ezfio.get_tc_h_clean_core_tc_op ()
;;
(* Write snippet for core_tc_op *)
let write_core_tc_op =
Ezfio.set_tc_h_clean_core_tc_op
;;
(* Read snippet for double_normal_ord *)
let read_double_normal_ord () =
if not (Ezfio.has_tc_h_clean_double_normal_ord ()) then
get_default "double_normal_ord"
|> bool_of_string
|> Ezfio.set_tc_h_clean_double_normal_ord
;
Ezfio.get_tc_h_clean_double_normal_ord ()
;;
(* Write snippet for double_normal_ord *)
let write_double_normal_ord =
Ezfio.set_tc_h_clean_double_normal_ord
;;
(* Read snippet for full_tc_h_solver *)
let read_full_tc_h_solver () =
if not (Ezfio.has_tc_h_clean_full_tc_h_solver ()) then
get_default "full_tc_h_solver"
|> bool_of_string
|> Ezfio.set_tc_h_clean_full_tc_h_solver
;
Ezfio.get_tc_h_clean_full_tc_h_solver ()
;;
(* Write snippet for full_tc_h_solver *)
let write_full_tc_h_solver =
Ezfio.set_tc_h_clean_full_tc_h_solver
;;
(* Read snippet for max_it_dav *)
let read_max_it_dav () =
if not (Ezfio.has_tc_h_clean_max_it_dav ()) then
get_default "max_it_dav"
|> int_of_string
|> Ezfio.set_tc_h_clean_max_it_dav
;
Ezfio.get_tc_h_clean_max_it_dav ()
;;
(* Write snippet for max_it_dav *)
let write_max_it_dav =
Ezfio.set_tc_h_clean_max_it_dav
;;
(* Read snippet for pure_three_body_h_tc *)
let read_pure_three_body_h_tc () =
if not (Ezfio.has_tc_h_clean_pure_three_body_h_tc ()) then
get_default "pure_three_body_h_tc"
|> bool_of_string
|> Ezfio.set_tc_h_clean_pure_three_body_h_tc
;
Ezfio.get_tc_h_clean_pure_three_body_h_tc ()
;;
(* Write snippet for pure_three_body_h_tc *)
let write_pure_three_body_h_tc =
Ezfio.set_tc_h_clean_pure_three_body_h_tc
;;
(* Read snippet for read_rl_eigv *)
let read_read_rl_eigv () =
if not (Ezfio.has_tc_h_clean_read_rl_eigv ()) then
get_default "read_rl_eigv"
|> bool_of_string
|> Ezfio.set_tc_h_clean_read_rl_eigv
;
Ezfio.get_tc_h_clean_read_rl_eigv ()
;;
(* Write snippet for read_rl_eigv *)
let write_read_rl_eigv =
Ezfio.set_tc_h_clean_read_rl_eigv
;;
(* Read snippet for three_body_h_tc *)
let read_three_body_h_tc () =
if not (Ezfio.has_tc_h_clean_three_body_h_tc ()) then
get_default "three_body_h_tc"
|> bool_of_string
|> Ezfio.set_tc_h_clean_three_body_h_tc
;
Ezfio.get_tc_h_clean_three_body_h_tc ()
;;
(* Write snippet for three_body_h_tc *)
let write_three_body_h_tc =
Ezfio.set_tc_h_clean_three_body_h_tc
;;
(* Read snippet for thresh_it_dav *)
let read_thresh_it_dav () =
if not (Ezfio.has_tc_h_clean_thresh_it_dav ()) then
get_default "thresh_it_dav"
|> float_of_string
|> Ezfio.set_tc_h_clean_thresh_it_dav
;
Ezfio.get_tc_h_clean_thresh_it_dav ()
|> Threshold.of_float
;;
(* Write snippet for thresh_it_dav *)
let write_thresh_it_dav var =
Threshold.to_float var
|> Ezfio.set_tc_h_clean_thresh_it_dav
;;
(* Read snippet for thresh_psi_r *)
let read_thresh_psi_r () =
if not (Ezfio.has_tc_h_clean_thresh_psi_r ()) then
get_default "thresh_psi_r"
|> float_of_string
|> Ezfio.set_tc_h_clean_thresh_psi_r
;
Ezfio.get_tc_h_clean_thresh_psi_r ()
|> Threshold.of_float
;;
(* Write snippet for thresh_psi_r *)
let write_thresh_psi_r var =
Threshold.to_float var
|> Ezfio.set_tc_h_clean_thresh_psi_r
;;
(* Read snippet for thresh_psi_r_norm *)
let read_thresh_psi_r_norm () =
if not (Ezfio.has_tc_h_clean_thresh_psi_r_norm ()) then
get_default "thresh_psi_r_norm"
|> bool_of_string
|> Ezfio.set_tc_h_clean_thresh_psi_r_norm
;
Ezfio.get_tc_h_clean_thresh_psi_r_norm ()
;;
(* Write snippet for thresh_psi_r_norm *)
let write_thresh_psi_r_norm =
Ezfio.set_tc_h_clean_thresh_psi_r_norm
;;
(* =~=~=~=~=~=~=~=~=~=~=~=~ *)
(* Generate Global Function *)
(* =~=~=~=~=~=~=~=~=~=~=~=~ *)
(* Read all *)
let read() =
Some
{
read_rl_eigv = read_read_rl_eigv ();
comp_left_eigv = read_comp_left_eigv ();
three_body_h_tc = read_three_body_h_tc ();
pure_three_body_h_tc = read_pure_three_body_h_tc ();
double_normal_ord = read_double_normal_ord ();
core_tc_op = read_core_tc_op ();
full_tc_h_solver = read_full_tc_h_solver ();
thresh_it_dav = read_thresh_it_dav ();
max_it_dav = read_max_it_dav ();
thresh_psi_r = read_thresh_psi_r ();
thresh_psi_r_norm = read_thresh_psi_r_norm ();
}
;;
(* Write all *)
let write{
read_rl_eigv;
comp_left_eigv;
three_body_h_tc;
pure_three_body_h_tc;
double_normal_ord;
core_tc_op;
full_tc_h_solver;
thresh_it_dav;
max_it_dav;
thresh_psi_r;
thresh_psi_r_norm;
} =
write_read_rl_eigv read_rl_eigv;
write_comp_left_eigv comp_left_eigv;
write_three_body_h_tc three_body_h_tc;
write_pure_three_body_h_tc pure_three_body_h_tc;
write_double_normal_ord double_normal_ord;
write_core_tc_op core_tc_op;
write_full_tc_h_solver full_tc_h_solver;
write_thresh_it_dav thresh_it_dav;
write_max_it_dav max_it_dav;
write_thresh_psi_r thresh_psi_r;
write_thresh_psi_r_norm thresh_psi_r_norm;
;;
(* to_string*)
let to_string b =
Printf.sprintf "
read_rl_eigv = %s
comp_left_eigv = %s
three_body_h_tc = %s
pure_three_body_h_tc = %s
double_normal_ord = %s
core_tc_op = %s
full_tc_h_solver = %s
thresh_it_dav = %s
max_it_dav = %s
thresh_psi_r = %s
thresh_psi_r_norm = %s
"
(string_of_bool b.read_rl_eigv)
(string_of_bool b.comp_left_eigv)
(string_of_bool b.three_body_h_tc)
(string_of_bool b.pure_three_body_h_tc)
(string_of_bool b.double_normal_ord)
(string_of_bool b.core_tc_op)
(string_of_bool b.full_tc_h_solver)
(Threshold.to_string b.thresh_it_dav)
(string_of_int b.max_it_dav)
(Threshold.to_string b.thresh_psi_r)
(string_of_bool b.thresh_psi_r_norm)
;;
(* to_rst*)
let to_rst b =
Printf.sprintf "
If |true|, read the right/left eigenvectors from ezfio ::
read_rl_eigv = %s
If |true|, computes also the left-eigenvector ::
comp_left_eigv = %s
If |true|, three-body terms are included ::
three_body_h_tc = %s
If |true|, pure triple excitation three-body terms are included ::
pure_three_body_h_tc = %s
If |true|, contracted double excitation three-body terms are included ::
double_normal_ord = %s
If |true|, takes the usual Hamiltonian for core orbitals (assumed to be doubly occupied) ::
core_tc_op = %s
If |true|, you diagonalize the full TC H matrix ::
full_tc_h_solver = %s
Thresholds on the energy for iterative Davidson used in TC ::
thresh_it_dav = %s
nb max of iteration in Davidson used in TC ::
max_it_dav = %s
Thresholds on the coefficients of the right-eigenvector. Used for PT2 computation. ::
thresh_psi_r = %s
If |true|, you prune the WF to compute the PT1 coef based on the norm. If False, the pruning is done through the amplitude on the right-coefficient. ::
thresh_psi_r_norm = %s
"
(string_of_bool b.read_rl_eigv)
(string_of_bool b.comp_left_eigv)
(string_of_bool b.three_body_h_tc)
(string_of_bool b.pure_three_body_h_tc)
(string_of_bool b.double_normal_ord)
(string_of_bool b.core_tc_op)
(string_of_bool b.full_tc_h_solver)
(Threshold.to_string b.thresh_it_dav)
(string_of_int b.max_it_dav)
(Threshold.to_string b.thresh_psi_r)
(string_of_bool b.thresh_psi_r_norm)
|> Rst_string.of_string
;;
include Generic_input_of_rst;;
let of_rst = of_rst t_of_sexp;;
end

143
ocaml/Input_tc_scf.ml Normal file
View File

@ -0,0 +1,143 @@
(* =~=~ *)
(* Init *)
(* =~=~ *)
open Qptypes;;
open Qputils;;
open Sexplib.Std;;
module Tc_scf : sig
(* Generate type *)
type t =
{
bi_ortho : bool;
thresh_tcscf : Threshold.t;
n_it_tcscf_max : Strictly_positive_int.t;
} [@@deriving sexp]
;;
val read : unit -> t option
val write : t-> unit
val to_string : t -> string
val to_rst : t -> Rst_string.t
val of_rst : Rst_string.t -> t option
end = struct
(* Generate type *)
type t =
{
bi_ortho : bool;
thresh_tcscf : Threshold.t;
n_it_tcscf_max : Strictly_positive_int.t;
} [@@deriving sexp]
;;
let get_default = Qpackage.get_ezfio_default "tc_scf";;
(* =~=~=~=~=~=~==~=~=~=~=~=~ *)
(* Generate Special Function *)
(* =~=~=~==~=~~=~=~=~=~=~=~=~ *)
(* Read snippet for bi_ortho *)
let read_bi_ortho () =
if not (Ezfio.has_tc_scf_bi_ortho ()) then
get_default "bi_ortho"
|> bool_of_string
|> Ezfio.set_tc_scf_bi_ortho
;
Ezfio.get_tc_scf_bi_ortho ()
;;
(* Write snippet for bi_ortho *)
let write_bi_ortho =
Ezfio.set_tc_scf_bi_ortho
;;
(* Read snippet for n_it_tcscf_max *)
let read_n_it_tcscf_max () =
if not (Ezfio.has_tc_scf_n_it_tcscf_max ()) then
get_default "n_it_tcscf_max"
|> int_of_string
|> Ezfio.set_tc_scf_n_it_tcscf_max
;
Ezfio.get_tc_scf_n_it_tcscf_max ()
|> Strictly_positive_int.of_int
;;
(* Write snippet for n_it_tcscf_max *)
let write_n_it_tcscf_max var =
Strictly_positive_int.to_int var
|> Ezfio.set_tc_scf_n_it_tcscf_max
;;
(* Read snippet for thresh_tcscf *)
let read_thresh_tcscf () =
if not (Ezfio.has_tc_scf_thresh_tcscf ()) then
get_default "thresh_tcscf"
|> float_of_string
|> Ezfio.set_tc_scf_thresh_tcscf
;
Ezfio.get_tc_scf_thresh_tcscf ()
|> Threshold.of_float
;;
(* Write snippet for thresh_tcscf *)
let write_thresh_tcscf var =
Threshold.to_float var
|> Ezfio.set_tc_scf_thresh_tcscf
;;
(* =~=~=~=~=~=~=~=~=~=~=~=~ *)
(* Generate Global Function *)
(* =~=~=~=~=~=~=~=~=~=~=~=~ *)
(* Read all *)
let read() =
Some
{
bi_ortho = read_bi_ortho ();
thresh_tcscf = read_thresh_tcscf ();
n_it_tcscf_max = read_n_it_tcscf_max ();
}
;;
(* Write all *)
let write{
bi_ortho;
thresh_tcscf;
n_it_tcscf_max;
} =
write_bi_ortho bi_ortho;
write_thresh_tcscf thresh_tcscf;
write_n_it_tcscf_max n_it_tcscf_max;
;;
(* to_string*)
let to_string b =
Printf.sprintf "
bi_ortho = %s
thresh_tcscf = %s
n_it_tcscf_max = %s
"
(string_of_bool b.bi_ortho)
(Threshold.to_string b.thresh_tcscf)
(Strictly_positive_int.to_string b.n_it_tcscf_max)
;;
(* to_rst*)
let to_rst b =
Printf.sprintf "
If |true|, the MO basis is assumed to be bi-orthonormal ::
bi_ortho = %s
Threshold on the convergence of the Hartree Fock energy. ::
thresh_tcscf = %s
Maximum number of SCF iterations ::
n_it_tcscf_max = %s
"
(string_of_bool b.bi_ortho)
(Threshold.to_string b.thresh_tcscf)
(Strictly_positive_int.to_string b.n_it_tcscf_max)
|> Rst_string.of_string
;;
include Generic_input_of_rst;;
let of_rst = of_rst t_of_sexp;;
end

2
ocaml/qp_create_ezfio.ml
View File

@ -681,10 +681,8 @@ let () =
let open Command_line in
begin
"Creates an EZFIO directory from a standard xyz file or from a z-matrix file in Gaussian format. The basis set is defined as a single string if all the atoms are taken from the same basis set, otherwise specific elements can be defined as follows:
-b \"cc-pcvdz | H:cc-pvdz | C:6-31g\"
-b \"cc-pvtz | 1,H:sto-3g | 3,H:6-31g\"
If a file with the same name as the basis set exists, this file will be read. Otherwise, the basis set is obtained from the database.
" |> set_description_doc ;
set_header_doc (Sys.argv.(0) ^ " - Quantum Package command");

7
src/ao_basis/EZFIO.cfg
View File

@ -17,7 +17,7 @@ interface: ezfio, provider
[ao_prim_num_max]
type: integer
doc: Maximum number of primitives
default: =maxval(ao_basis.ao_prim_num)
#default: =maxval(ao_basis.ao_prim_num)
interface: ezfio
[ao_nucl]
@ -36,13 +36,13 @@ interface: ezfio, provider
type: double precision
doc: Primitive coefficients, read from input. Those should not be used directly, as the MOs are expressed on the basis of **normalized** AOs.
size: (ao_basis.ao_num,ao_basis.ao_prim_num_max)
interface: ezfio, provider
interface: ezfio
[ao_expo]
type: double precision
doc: Exponents for each primitive of each |AO|
size: (ao_basis.ao_num,ao_basis.ao_prim_num_max)
interface: ezfio, provider
interface: ezfio
[ao_md5]
type: character*(32)
@ -67,3 +67,4 @@ doc: Use normalized primitive functions
interface: ezfio, provider
default: true

59
src/ao_basis/aos.irp.f
View File

@ -1,11 +1,3 @@
BEGIN_PROVIDER [ integer, ao_prim_num_max ]
implicit none
BEGIN_DOC
! Max number of primitives.
END_DOC
ao_prim_num_max = maxval(ao_prim_num)
END_PROVIDER
BEGIN_PROVIDER [ integer, ao_shell, (ao_num) ]
implicit none
BEGIN_DOC
@ -23,6 +15,32 @@ BEGIN_PROVIDER [ integer, ao_shell, (ao_num) ]
END_PROVIDER
BEGIN_PROVIDER [ double precision, ao_coef , (ao_num,ao_prim_num_max) ]
&BEGIN_PROVIDER [ double precision, ao_expo , (ao_num,ao_prim_num_max) ]
implicit none
BEGIN_DOC
! Primitive coefficients and exponents for each atomic orbital. Copied from shell info.
END_DOC
integer :: i, l
do i=1,ao_num
l = ao_shell(i)
ao_coef(i,:) = shell_coef(l,:)
ao_expo(i,:) = shell_expo(l,:)
end do
END_PROVIDER
BEGIN_PROVIDER [ integer, ao_prim_num_max ]
implicit none
BEGIN_DOC
! Max number of primitives.
END_DOC
ao_prim_num_max = shell_prim_num_max
END_PROVIDER
BEGIN_PROVIDER [ integer, ao_first_of_shell, (shell_num) ]
implicit none
BEGIN_DOC
@ -44,20 +62,20 @@ END_PROVIDER
BEGIN_DOC
! Coefficients including the |AO| normalization
END_DOC
do i=1,ao_num
l = ao_shell(i)
ao_coef_normalized(i,:) = shell_coef(l,:) * shell_normalization_factor(l)
end do
double precision :: norm,overlap_x,overlap_y,overlap_z,C_A(3), c
integer :: l, powA(3), nz
integer :: i,j,k
nz=100
C_A(1) = 0.d0
C_A(2) = 0.d0
C_A(3) = 0.d0
ao_coef_normalized = 0.d0
C_A = 0.d0
do i=1,ao_num
! powA(1) = ao_power(i,1) + ao_power(i,2) + ao_power(i,3)
! powA(2) = 0
! powA(3) = 0
powA(1) = ao_power(i,1)
powA(2) = ao_power(i,2)
powA(3) = ao_power(i,3)
@ -67,18 +85,9 @@ END_PROVIDER
do j=1,ao_prim_num(i)
call overlap_gaussian_xyz(C_A,C_A,ao_expo(i,j),ao_expo(i,j), &
powA,powA,overlap_x,overlap_y,overlap_z,norm,nz)
ao_coef_normalized(i,j) = ao_coef(i,j)/dsqrt(norm)
enddo
else
do j=1,ao_prim_num(i)
ao_coef_normalized(i,j) = ao_coef(i,j)
ao_coef_normalized(i,j) = ao_coef_normalized(i,j)/dsqrt(norm)
enddo
endif
powA(1) = ao_power(i,1)
powA(2) = ao_power(i,2)
powA(3) = ao_power(i,3)
! Normalization of the contracted basis functions
if (ao_normalized) then
norm = 0.d0

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

@ -12,21 +12,21 @@ double precision function ao_value(i,r)
integer :: power_ao(3)
double precision :: accu,dx,dy,dz,r2
num_ao = ao_nucl(i)
! power_ao(1:3)= ao_power(i,1:3)
! center_ao(1:3) = nucl_coord(num_ao,1:3)
! dx = (r(1) - center_ao(1))
! dy = (r(2) - center_ao(2))
! dz = (r(3) - center_ao(3))
! r2 = dx*dx + dy*dy + dz*dz
! dx = dx**power_ao(1)
! dy = dy**power_ao(2)
! dz = dz**power_ao(3)
power_ao(1:3)= ao_power(i,1:3)
center_ao(1:3) = nucl_coord(num_ao,1:3)
dx = (r(1) - center_ao(1))
dy = (r(2) - center_ao(2))
dz = (r(3) - center_ao(3))
r2 = dx*dx + dy*dy + dz*dz
dx = dx**power_ao(1)
dy = dy**power_ao(2)
dz = dz**power_ao(3)
accu = 0.d0
! do m=1,ao_prim_num(i)
! beta = ao_expo_ordered_transp(m,i)
! accu += ao_coef_normalized_ordered_transp(m,i) * dexp(-beta*r2)
! enddo
do m=1,ao_prim_num(i)
beta = ao_expo_ordered_transp(m,i)
accu += ao_coef_normalized_ordered_transp(m,i) * dexp(-beta*r2)
enddo
ao_value = accu * dx * dy * dz
end

2
src/ao_basis/spherical_to_cartesian.irp.f
View File

@ -1,7 +1,7 @@
! Spherical to cartesian transformation matrix obtained with
! Horton (http://theochem.github.com/horton/, 2015)
! First index is the index of the cartesian AO, obtained by ao_power_index
! First index is the index of the carteisan AO, obtained by ao_power_index
! Second index is the index of the spherical AO
BEGIN_PROVIDER [ double precision, cart_to_sphe_0, (1,1) ]

5
src/ao_many_one_e_ints/NEED Normal file
View File

@ -0,0 +1,5 @@
ao_one_e_ints
ao_two_e_ints
becke_numerical_grid
mo_one_e_ints
dft_utils_in_r

25
src/ao_many_one_e_ints/README.rst Normal file
View File

@ -0,0 +1,25 @@
==================
ao_many_one_e_ints
==================
This module contains A LOT of one-electron integrals of the type
A_ij( r ) = \int dr' phi_i(r') w(r,r') phi_j(r')
where r is a point in real space.
+) ao_gaus_gauss.irp.f: w(r,r') is a exp(-(r-r')^2) , and can be multiplied by x/y/z
+) ao_erf_gauss.irp.f : w(r,r') is a exp(-(r-r')^2) erf(mu * |r-r'|)/|r-r'| , and can be multiplied by x/y/z
+) ao_erf_gauss_grad.irp.f: w(r,r') is a exp(-(r-r')^2) erf(mu * |r-r'|)/|r-r'| , and can be multiplied by x/y/z, but evaluated with also one gradient of an AO function.
Fit of a Slater function and corresponding integrals
----------------------------------------------------
The file fit_slat_gauss.irp.f contains many useful providers/routines to fit a Slater function with 20 gaussian.
+) coef_fit_slat_gauss : coefficients of the gaussians to fit e^(-x)
+) expo_fit_slat_gauss : exponents of the gaussians to fit e^(-x)
Integrals involving Slater functions : stg_gauss_int.irp.f
Taylor expansion of full correlation factor
-------------------------------------------
In taylor_exp.irp.f you might find interesting integrals of the type
\int dr' exp( e^{-alpha |r-r|' - beta |r-r'|^2}) phi_i(r') phi_j(r')
evaluated as a Taylor expansion of the exponential.

269
src/ao_many_one_e_ints/ao_erf_gauss.irp.f Normal file
View File

@ -0,0 +1,269 @@
subroutine phi_j_erf_mu_r_xyz_phi(i,j,mu_in, C_center, xyz_ints)
implicit none
BEGIN_DOC
! xyz_ints(1/2/3) = int dr phi_j(r) [erf(mu |r - C|)/|r-C|] x/y/z phi_i(r)
!
! where phi_i and phi_j are AOs
END_DOC
integer, intent(in) :: i,j
double precision, intent(in) :: mu_in, C_center(3)
double precision, intent(out):: xyz_ints(3)
integer :: num_A,power_A(3), num_b, power_B(3),power_B_tmp(3)
double precision :: alpha, beta, A_center(3), B_center(3),contrib,NAI_pol_mult_erf
integer :: n_pt_in,l,m,mm
xyz_ints = 0.d0
if(ao_overlap_abs(j,i).lt.1.d-12)then
return
endif
n_pt_in = n_pt_max_integrals
! j
num_A = ao_nucl(j)
power_A(1:3)= ao_power(j,1:3)
A_center(1:3) = nucl_coord(num_A,1:3)
! i
num_B = ao_nucl(i)
power_B(1:3)= ao_power(i,1:3)
B_center(1:3) = nucl_coord(num_B,1:3)
do l=1,ao_prim_num(j)
alpha = ao_expo_ordered_transp(l,j)
do m=1,ao_prim_num(i)
beta = ao_expo_ordered_transp(m,i)
do mm = 1, 3
! (x phi_i ) * phi_j
! x * (x - B_x)^b_x = b_x (x - B_x)^b_x + 1 * (x - B_x)^{b_x+1}
!
! first contribution :: B_x (x - B_x)^b_x :: usual integral multiplied by B_x
power_B_tmp = power_B
contrib = NAI_pol_mult_erf(A_center,B_center,power_A,power_B_tmp,alpha,beta,C_center,n_pt_in,mu_in)
xyz_ints(mm) += contrib * B_center(mm) * ao_coef_normalized_ordered_transp(l,j) &
* ao_coef_normalized_ordered_transp(m,i)
! second contribution :: 1 * (x - B_x)^(b_x+1) :: integral with b_x=>b_x+1
power_B_tmp(mm) += 1
contrib = NAI_pol_mult_erf(A_center,B_center,power_A,power_B_tmp,alpha,beta,C_center,n_pt_in,mu_in)
xyz_ints(mm) += contrib * 1.d0 * ao_coef_normalized_ordered_transp(l,j) &
* ao_coef_normalized_ordered_transp(m,i)
enddo
enddo
enddo
end
double precision function phi_j_erf_mu_r_phi(i,j,mu_in, C_center)
implicit none
BEGIN_DOC
! phi_j_erf_mu_r_phi = int dr phi_j(r) [erf(mu |r - C|)/|r-C|] phi_i(r)
END_DOC
integer, intent(in) :: i,j
double precision, intent(in) :: mu_in, C_center(3)
integer :: num_A,power_A(3), num_b, power_B(3)
double precision :: alpha, beta, A_center(3), B_center(3),contrib,NAI_pol_mult_erf
integer :: n_pt_in,l,m
phi_j_erf_mu_r_phi = 0.d0
if(ao_overlap_abs(j,i).lt.1.d-12)then
return
endif
n_pt_in = n_pt_max_integrals
! j
num_A = ao_nucl(j)
power_A(1:3)= ao_power(j,1:3)
A_center(1:3) = nucl_coord(num_A,1:3)
! i
num_B = ao_nucl(i)
power_B(1:3)= ao_power(i,1:3)
B_center(1:3) = nucl_coord(num_B,1:3)
do l=1,ao_prim_num(j)
alpha = ao_expo_ordered_transp(l,j)
do m=1,ao_prim_num(i)
beta = ao_expo_ordered_transp(m,i)
contrib = NAI_pol_mult_erf(A_center,B_center,power_A,power_B,alpha,beta,C_center,n_pt_in,mu_in)
phi_j_erf_mu_r_phi += contrib * ao_coef_normalized_ordered_transp(l,j) &
* ao_coef_normalized_ordered_transp(m,i)
enddo
enddo
end
subroutine erfc_mu_gauss_xyz_ij_ao(i,j,mu, C_center, delta,gauss_ints)
implicit none
BEGIN_DOC
! gauss_ints(m) = \int dr exp(-delta (r - C)^2 ) x/y/z * ( 1 - erf(mu |r-r'|))/ |r-r'| * AO_i(r') * AO_j(r')
!
! with m = 1 ==> x, m = 2, m = 3 ==> z
!
! m = 4 ==> no x/y/z
END_DOC
integer, intent(in) :: i,j
double precision, intent(in) :: mu, C_center(3),delta
double precision, intent(out):: gauss_ints(4)
integer :: num_A,power_A(3), num_b, power_B(3)
double precision :: alpha, beta, A_center(3), B_center(3),contrib,NAI_pol_mult_erf
double precision :: xyz_ints(4)
integer :: n_pt_in,l,m,mm
gauss_ints = 0.d0
if(ao_overlap_abs(j,i).lt.1.d-12)then
return
endif
n_pt_in = n_pt_max_integrals
! j
num_A = ao_nucl(j)
power_A(1:3)= ao_power(j,1:3)
A_center(1:3) = nucl_coord(num_A,1:3)
! i
num_B = ao_nucl(i)
power_B(1:3)= ao_power(i,1:3)
B_center(1:3) = nucl_coord(num_B,1:3)
gauss_ints = 0.d0
do l=1,ao_prim_num(j)
alpha = ao_expo_ordered_transp(l,j)
do m=1,ao_prim_num(i)
beta = ao_expo_ordered_transp(m,i)
call erfc_mu_gauss_xyz(C_center,delta,mu,A_center,B_center,power_A,power_B,alpha,beta,n_pt_in,xyz_ints)
do mm = 1, 4
gauss_ints(mm) += xyz_ints(mm) * ao_coef_normalized_ordered_transp(l,j) &
* ao_coef_normalized_ordered_transp(m,i)
enddo
enddo
enddo
end
subroutine erf_mu_gauss_ij_ao(i,j,mu, C_center, delta,gauss_ints)
implicit none
BEGIN_DOC
! gauss_ints(m) = \int dr exp(-delta (r - C)^2 ) * erf(mu |r-r'|)/ |r-r'| * AO_i(r') * AO_j(r')
!
END_DOC
integer, intent(in) :: i,j
double precision, intent(in) :: mu, C_center(3),delta
double precision, intent(out):: gauss_ints
integer :: num_A,power_A(3), num_b, power_B(3)
double precision :: alpha, beta, A_center(3), B_center(3),contrib,NAI_pol_mult_erf
double precision :: integral , erf_mu_gauss
integer :: n_pt_in,l,m,mm
gauss_ints = 0.d0
if(ao_overlap_abs(j,i).lt.1.d-12)then
return
endif
n_pt_in = n_pt_max_integrals
! j
num_A = ao_nucl(j)
power_A(1:3)= ao_power(j,1:3)
A_center(1:3) = nucl_coord(num_A,1:3)
! i
num_B = ao_nucl(i)
power_B(1:3)= ao_power(i,1:3)
B_center(1:3) = nucl_coord(num_B,1:3)
do l=1,ao_prim_num(j)
alpha = ao_expo_ordered_transp(l,j)
do m=1,ao_prim_num(i)
beta = ao_expo_ordered_transp(m,i)
if(dabs(ao_coef_normalized_ordered_transp(l,j) * ao_coef_normalized_ordered_transp(m,i)).lt.1.d-12)cycle
integral = erf_mu_gauss(C_center,delta,mu,A_center,B_center,power_A,power_B,alpha,beta,n_pt_in)
gauss_ints += integral * ao_coef_normalized_ordered_transp(l,j) &
* ao_coef_normalized_ordered_transp(m,i)
enddo
enddo
end
subroutine NAI_pol_x_mult_erf_ao(i_ao,j_ao,mu_in,C_center,ints)
implicit none
BEGIN_DOC
! Computes the following integral :
! $\int_{-\infty}^{infty} dr x * \chi_i(r) \chi_j(r) \frac{\erf(\mu | r - R_C | )}{ | r - R_C | }$.
!
! $\int_{-\infty}^{infty} dr y * \chi_i(r) \chi_j(r) \frac{\erf(\mu | r - R_C | )}{ | r - R_C | }$.
!
! $\int_{-\infty}^{infty} dr z * \chi_i(r) \chi_j(r) \frac{\erf(\mu | r - R_C | )}{ | r - R_C | }$.
END_DOC
include 'utils/constants.include.F'
integer, intent(in) :: i_ao,j_ao
double precision, intent(in) :: mu_in, C_center(3)
double precision, intent(out):: ints(3)
double precision :: A_center(3), B_center(3),integral, alpha,beta
double precision :: NAI_pol_mult_erf
integer :: i,j,num_A,num_B, power_A(3), power_B(3), n_pt_in, power_xA(3),m
ints = 0.d0
if(ao_overlap_abs(j_ao,i_ao).lt.1.d-12)then
return
endif
num_A = ao_nucl(i_ao)
power_A(1:3)= ao_power(i_ao,1:3)
A_center(1:3) = nucl_coord(num_A,1:3)
num_B = ao_nucl(j_ao)
power_B(1:3)= ao_power(j_ao,1:3)
B_center(1:3) = nucl_coord(num_B,1:3)
n_pt_in = n_pt_max_integrals
do i = 1, ao_prim_num(i_ao)
alpha = ao_expo_ordered_transp(i,i_ao)
do m = 1, 3
power_xA = power_A
! x * phi_i(r) = x * (x-Ax)**ax = (x-Ax)**(ax+1) + Ax * (x-Ax)**ax
power_xA(m) += 1
do j = 1, ao_prim_num(j_ao)
beta = ao_expo_ordered_transp(j,j_ao)
! First term = (x-Ax)**(ax+1)
integral = NAI_pol_mult_erf(A_center,B_center,power_xA,power_B,alpha,beta,C_center,n_pt_in,mu_in)
ints(m) += integral * ao_coef_normalized_ordered_transp(j,j_ao)*ao_coef_normalized_ordered_transp(i,i_ao)
! Second term = Ax * (x-Ax)**(ax)
integral = NAI_pol_mult_erf(A_center,B_center,power_A,power_B,alpha,beta,C_center,n_pt_in,mu_in)
ints(m) += A_center(m) * integral * ao_coef_normalized_ordered_transp(j,j_ao)*ao_coef_normalized_ordered_transp(i,i_ao)
enddo
enddo
enddo
end
subroutine NAI_pol_x_specify_mult_erf_ao(i_ao,j_ao,mu_in,C_center,m,ints)
implicit none
BEGIN_DOC
! Computes the following integral :
! $\int_{-\infty}^{infty} dr X(m) * \chi_i(r) \chi_j(r) \frac{\erf(\mu | r - R_C | )}{ | r - R_C | }$.
!
! if m == 1 X(m) = x, m == 1 X(m) = y, m == 1 X(m) = z
END_DOC
include 'utils/constants.include.F'
integer, intent(in) :: i_ao,j_ao,m
double precision, intent(in) :: mu_in, C_center(3)
double precision, intent(out):: ints
double precision :: A_center(3), B_center(3),integral, alpha,beta
double precision :: NAI_pol_mult_erf
integer :: i,j,num_A,num_B, power_A(3), power_B(3), n_pt_in, power_xA(3)
ints = 0.d0
if(ao_overlap_abs(j_ao,i_ao).lt.1.d-12)then
return
endif
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)
power_xA = power_A
! x * phi_i(r) = x * (x-Ax)**ax = (x-Ax)**(ax+1) + Ax * (x-Ax)**ax
power_xA(m) += 1
do j = 1, ao_prim_num(j_ao)
beta = ao_expo_ordered_transp(j,j_ao)
! First term = (x-Ax)**(ax+1)
integral = NAI_pol_mult_erf(A_center,B_center,power_xA,power_B,alpha,beta,C_center,n_pt_in,mu_in)
ints += integral * ao_coef_normalized_ordered_transp(j,j_ao)*ao_coef_normalized_ordered_transp(i,i_ao)
! Second term = Ax * (x-Ax)**(ax)
integral = NAI_pol_mult_erf(A_center,B_center,power_A,power_B,alpha,beta,C_center,n_pt_in,mu_in)
ints += A_center(m) * integral * ao_coef_normalized_ordered_transp(j,j_ao)*ao_coef_normalized_ordered_transp(i,i_ao)
enddo
enddo
end

150
src/ao_many_one_e_ints/ao_erf_gauss_grad.irp.f Normal file
View File

@ -0,0 +1,150 @@
subroutine phi_j_erf_mu_r_dxyz_phi(i,j,mu_in, C_center, dxyz_ints)
implicit none
BEGIN_DOC
! dxyz_ints(1/2/3) = int dr phi_i(r) [erf(mu |r - C|)/|r-C|] d/d(x/y/z) phi_i(r)
END_DOC
integer, intent(in) :: i,j
double precision, intent(in) :: mu_in, C_center(3)
double precision, intent(out):: dxyz_ints(3)
integer :: num_A,power_A(3), num_b, power_B(3),power_B_tmp(3)
double precision :: alpha, beta, A_center(3), B_center(3),contrib,NAI_pol_mult_erf,coef,thr
integer :: n_pt_in,l,m,mm
thr = 1.d-12
dxyz_ints = 0.d0
if(ao_overlap_abs(j,i).lt.thr)then
return
endif
n_pt_in = n_pt_max_integrals
! j
num_A = ao_nucl(j)
power_A(1:3)= ao_power(j,1:3)
A_center(1:3) = nucl_coord(num_A,1:3)
! i
num_B = ao_nucl(i)
power_B(1:3)= ao_power(i,1:3)
B_center(1:3) = nucl_coord(num_B,1:3)
do l=1,ao_prim_num(j)
alpha = ao_expo_ordered_transp(l,j)
do m=1,ao_prim_num(i)
beta = ao_expo_ordered_transp(m,i)
coef = ao_coef_normalized_ordered_transp(l,j) * ao_coef_normalized_ordered_transp(m,i)
if(dabs(coef).lt.thr)cycle
do mm = 1, 3
! (d/dx phi_i ) * phi_j
! d/dx * (x - B_x)^b_x exp(-beta * (x -B_x)^2)= [b_x * (x - B_x)^(b_x - 1) - 2 beta * (x - B_x)^(b_x + 1)] exp(-beta * (x -B_x)^2)
!
! first contribution :: b_x (x - B_x)^(b_x-1) :: integral with b_x=>b_x-1 multiplied by b_x
power_B_tmp = power_B
power_B_tmp(mm) += -1
contrib = NAI_pol_mult_erf(A_center,B_center,power_A,power_B_tmp,alpha,beta,C_center,n_pt_in,mu_in)
dxyz_ints(mm) += contrib * dble(power_B(mm)) * coef
! second contribution :: - 2 beta * (x - B_x)^(b_x + 1) :: integral with b_x=> b_x+1 multiplied by -2 * beta
power_B_tmp = power_B
power_B_tmp(mm) += 1
contrib = NAI_pol_mult_erf(A_center,B_center,power_A,power_B_tmp,alpha,beta,C_center,n_pt_in,mu_in)
dxyz_ints(mm) += contrib * (-2.d0 * beta ) * coef
enddo
enddo
enddo
end
subroutine phi_j_erf_mu_r_dxyz_phi_bis(i,j,mu_in, C_center, dxyz_ints)
implicit none
BEGIN_DOC
! dxyz_ints(1/2/3) = int dr phi_j(r) [erf(mu |r - C|)/|r-C|] d/d(x/y/z) phi_i(r)
END_DOC
integer, intent(in) :: i,j
double precision, intent(in) :: mu_in, C_center(3)
double precision, intent(out):: dxyz_ints(3)
integer :: num_A,power_A(3), num_b, power_B(3),power_B_tmp(3)
double precision :: alpha, beta, A_center(3), B_center(3),contrib,NAI_pol_mult_erf
double precision :: thr, coef
integer :: n_pt_in,l,m,mm,kk
thr = 1.d-12
dxyz_ints = 0.d0
if(ao_overlap_abs(j,i).lt.thr)then
return
endif
n_pt_in = n_pt_max_integrals
! j == A
num_A = ao_nucl(j)
power_A(1:3)= ao_power(j,1:3)
A_center(1:3) = nucl_coord(num_A,1:3)
! i == B
num_B = ao_nucl(i)
power_B(1:3)= ao_power(i,1:3)
B_center(1:3) = nucl_coord(num_B,1:3)
dxyz_ints = 0.d0
do l=1,ao_prim_num(j)
alpha = ao_expo_ordered_transp(l,j)
do m=1,ao_prim_num(i)
beta = ao_expo_ordered_transp(m,i)
do kk = 1, 2 ! loop over the extra terms induced by the d/dx/y/z * AO(i)
do mm = 1, 3
power_B_tmp = power_B
power_B_tmp(mm) = power_ord_grad_transp(kk,mm,i)
coef = ao_coef_normalized_ordered_transp(l,j) * ao_coef_ord_grad_transp(kk,mm,m,i)
if(dabs(coef).lt.thr)cycle
contrib = NAI_pol_mult_erf(A_center,B_center,power_A,power_B_tmp,alpha,beta,C_center,n_pt_in,mu_in)
dxyz_ints(mm) += contrib * coef
enddo
enddo
enddo
enddo
end
subroutine phi_j_erf_mu_r_xyz_dxyz_phi(i,j,mu_in, C_center, dxyz_ints)
implicit none
BEGIN_DOC
! dxyz_ints(1/2/3) = int dr phi_j(r) x/y/z [erf(mu |r - C|)/|r-C|] d/d(x/y/z) phi_i(r)
END_DOC
integer, intent(in) :: i,j
double precision, intent(in) :: mu_in, C_center(3)
double precision, intent(out):: dxyz_ints(3)
integer :: num_A,power_A(3), num_b, power_B(3),power_B_tmp(3)
double precision :: alpha, beta, A_center(3), B_center(3),contrib,NAI_pol_mult_erf
double precision :: thr, coef
integer :: n_pt_in,l,m,mm,kk
thr = 1.d-12
dxyz_ints = 0.d0
if(ao_overlap_abs(j,i).lt.thr)then
return
endif
n_pt_in = n_pt_max_integrals
! j == A
num_A = ao_nucl(j)
power_A(1:3)= ao_power(j,1:3)
A_center(1:3) = nucl_coord(num_A,1:3)
! i == B
num_B = ao_nucl(i)
power_B(1:3)= ao_power(i,1:3)
B_center(1:3) = nucl_coord(num_B,1:3)
dxyz_ints = 0.d0
do l=1,ao_prim_num(j)
alpha = ao_expo_ordered_transp(l,j)
do m=1,ao_prim_num(i)
beta = ao_expo_ordered_transp(m,i)
do kk = 1, 4 ! loop over the extra terms induced by the x/y/z * d dx/y/z AO(i)
do mm = 1, 3
power_B_tmp = power_B
power_B_tmp(mm) = power_ord_xyz_grad_transp(kk,mm,i)
coef = ao_coef_normalized_ordered_transp(l,j) * ao_coef_ord_xyz_grad_transp(kk,mm,m,i)
if(dabs(coef).lt.thr)cycle
contrib = NAI_pol_mult_erf(A_center,B_center,power_A,power_B_tmp,alpha,beta,C_center,n_pt_in,mu_in)
dxyz_ints(mm) += contrib * coef
enddo
enddo
enddo
enddo
end

137
src/ao_many_one_e_ints/ao_gaus_gauss.irp.f Normal file
View File

@ -0,0 +1,137 @@
subroutine overlap_gauss_xyz_r12_ao(D_center,delta,i,j,gauss_ints)
implicit none
BEGIN_DOC
! gauss_ints(m) = \int dr AO_i(r) AO_j(r) x/y/z e^{-delta |r-D_center|^2}
!
! with m == 1 ==> x, m == 2 ==> y, m == 3 ==> z
END_DOC
integer, intent(in) :: i,j
double precision, intent(in) :: D_center(3), delta
double precision, intent(out) :: gauss_ints(3)
integer :: num_a,num_b,power_A(3), power_B(3),l,k,m
double precision :: A_center(3), B_center(3),overlap_gauss_r12,alpha,beta,gauss_ints_tmp(3)
gauss_ints = 0.d0
if(ao_overlap_abs(j,i).lt.1.d-12)then
return
endif
num_A = ao_nucl(i)
power_A(1:3)= ao_power(i,1:3)
A_center(1:3) = nucl_coord(num_A,1:3)
num_B = ao_nucl(j)
power_B(1:3)= ao_power(j,1:3)
B_center(1:3) = nucl_coord(num_B,1:3)
do l=1,ao_prim_num(i)
alpha = ao_expo_ordered_transp(l,i)
do k=1,ao_prim_num(j)
beta = ao_expo_ordered_transp(k,j)
call overlap_gauss_xyz_r12(D_center,delta,A_center,B_center,power_A,power_B,alpha,beta,gauss_ints_tmp)
do m = 1, 3
gauss_ints(m) += gauss_ints_tmp(m) * ao_coef_normalized_ordered_transp(l,i) &
* ao_coef_normalized_ordered_transp(k,j)
enddo
enddo
enddo
end
double precision function overlap_gauss_xyz_r12_ao_specific(D_center,delta,i,j,mx)
implicit none
BEGIN_DOC
! \int dr AO_i(r) AO_j(r) x/y/z e^{-delta |r-D_center|^2}
!
! with mx == 1 ==> x, mx == 2 ==> y, mx == 3 ==> z
END_DOC
integer, intent(in) :: i,j,mx
double precision, intent(in) :: D_center(3), delta
integer :: num_a,num_b,power_A(3), power_B(3),l,k
double precision :: gauss_int
double precision :: A_center(3), B_center(3),overlap_gauss_r12,alpha,beta
double precision :: overlap_gauss_xyz_r12_specific
overlap_gauss_xyz_r12_ao_specific = 0.d0
if(ao_overlap_abs(j,i).lt.1.d-12)then
return
endif
num_A = ao_nucl(i)
power_A(1:3)= ao_power(i,1:3)
A_center(1:3) = nucl_coord(num_A,1:3)
num_B = ao_nucl(j)
power_B(1:3)= ao_power(j,1:3)
B_center(1:3) = nucl_coord(num_B,1:3)
do l=1,ao_prim_num(i)
alpha = ao_expo_ordered_transp(l,i)
do k=1,ao_prim_num(j)
beta = ao_expo_ordered_transp(k,j)
gauss_int = overlap_gauss_xyz_r12_specific(D_center,delta,A_center,B_center,power_A,power_B,alpha,beta,mx)
overlap_gauss_xyz_r12_ao_specific = gauss_int * ao_coef_normalized_ordered_transp(l,i) &
* ao_coef_normalized_ordered_transp(k,j)
enddo
enddo
end
subroutine overlap_gauss_r12_all_ao(D_center,delta,aos_ints)
implicit none
double precision, intent(in) :: D_center(3), delta
double precision, intent(out):: aos_ints(ao_num,ao_num)
integer :: num_a,num_b,power_A(3), power_B(3),l,k,i,j
double precision :: A_center(3), B_center(3),overlap_gauss_r12,alpha,beta,analytical_j
aos_ints = 0.d0
do i = 1, ao_num
do j = 1, ao_num
if(ao_overlap_abs(j,i).lt.1.d-12)cycle
num_A = ao_nucl(i)
power_A(1:3)= ao_power(i,1:3)
A_center(1:3) = nucl_coord(num_A,1:3)
num_B = ao_nucl(j)
power_B(1:3)= ao_power(j,1:3)
B_center(1:3) = nucl_coord(num_B,1:3)
do l=1,ao_prim_num(i)
alpha = ao_expo_ordered_transp(l,i)
do k=1,ao_prim_num(j)
beta = ao_expo_ordered_transp(k,j)
analytical_j = overlap_gauss_r12(D_center,delta,A_center,B_center,power_A,power_B,alpha,beta)
aos_ints(j,i) += analytical_j * ao_coef_normalized_ordered_transp(l,i) &
* ao_coef_normalized_ordered_transp(k,j)
enddo
enddo
enddo
enddo
end
double precision function overlap_gauss_r12_ao(D_center,delta,i,j)
implicit none
BEGIN_DOC
! \int dr AO_i(r) AO_j(r) e^{-delta |r-D_center|^2}
END_DOC
integer, intent(in) :: i,j
double precision, intent(in) :: D_center(3), delta
integer :: num_a,num_b,power_A(3), power_B(3),l,k
double precision :: A_center(3), B_center(3),overlap_gauss_r12,alpha,beta,analytical_j
overlap_gauss_r12_ao = 0.d0
if(ao_overlap_abs(j,i).lt.1.d-12)then
return
endif
! TODO :: PUT CYCLES IN LOOPS
num_A = ao_nucl(i)
power_A(1:3)= ao_power(i,1:3)
A_center(1:3) = nucl_coord(num_A,1:3)
num_B = ao_nucl(j)
power_B(1:3)= ao_power(j,1:3)
B_center(1:3) = nucl_coord(num_B,1:3)
do l=1,ao_prim_num(i)
alpha = ao_expo_ordered_transp(l,i)
do k=1,ao_prim_num(j)
beta = ao_expo_ordered_transp(k,j)
analytical_j = overlap_gauss_r12(D_center,delta,A_center,B_center,power_A,power_B,alpha,beta)
overlap_gauss_r12_ao += analytical_j * ao_coef_normalized_ordered_transp(l,i) &
* ao_coef_normalized_ordered_transp(k,j)
enddo
enddo
end

94
src/ao_many_one_e_ints/fit_slat_gauss.irp.f Normal file
View File

@ -0,0 +1,94 @@
BEGIN_PROVIDER [integer, n_max_fit_slat]
implicit none
BEGIN_DOC
! number of gaussian to fit exp(-x)
!
! I took 20 gaussians from the program bassto.f
END_DOC
n_max_fit_slat = 20
END_PROVIDER
BEGIN_PROVIDER [double precision, coef_fit_slat_gauss, (n_max_fit_slat)]
&BEGIN_PROVIDER [double precision, expo_fit_slat_gauss, (n_max_fit_slat)]
implicit none
include 'constants.include.F'
BEGIN_DOC
! fit the exp(-x) as
!
! \sum_{i = 1, n_max_fit_slat} coef_fit_slat_gauss(i) * exp(-expo_fit_slat_gauss(i) * x**2)
!
! The coefficient are taken from the program bassto.f
END_DOC
expo_fit_slat_gauss(01)=30573.77073000000
coef_fit_slat_gauss(01)=0.00338925525
expo_fit_slat_gauss(02)=5608.45238100000
coef_fit_slat_gauss(02)=0.00536433869
expo_fit_slat_gauss(03)=1570.95673400000
coef_fit_slat_gauss(03)=0.00818702846
expo_fit_slat_gauss(04)=541.39785110000
coef_fit_slat_gauss(04)=0.01202047655
expo_fit_slat_gauss(05)=212.43469630000
coef_fit_slat_gauss(05)=0.01711289568
expo_fit_slat_gauss(06)=91.31444574000
coef_fit_slat_gauss(06)=0.02376001022
expo_fit_slat_gauss(07)=42.04087246000
coef_fit_slat_gauss(07)=0.03229121736
expo_fit_slat_gauss(08)=20.43200443000
coef_fit_slat_gauss(08)=0.04303646818
expo_fit_slat_gauss(09)=10.37775161000
coef_fit_slat_gauss(09)=0.05624657578
expo_fit_slat_gauss(10)=5.46880754500
coef_fit_slat_gauss(10)=0.07192311571
expo_fit_slat_gauss(11)=2.97373529200
coef_fit_slat_gauss(11)=0.08949389001
expo_fit_slat_gauss(12)=1.66144190200
coef_fit_slat_gauss(12)=0.10727599240
expo_fit_slat_gauss(13)=0.95052560820
coef_fit_slat_gauss(13)=0.12178961750
expo_fit_slat_gauss(14)=0.55528683970
coef_fit_slat_gauss(14)=0.12740141870
expo_fit_slat_gauss(15)=0.33043360020
coef_fit_slat_gauss(15)=0.11759168160
expo_fit_slat_gauss(16)=0.19982303230
coef_fit_slat_gauss(16)=0.08953504394
expo_fit_slat_gauss(17)=0.12246840760
coef_fit_slat_gauss(17)=0.05066721317
expo_fit_slat_gauss(18)=0.07575825322
coef_fit_slat_gauss(18)=0.01806363869
expo_fit_slat_gauss(19)=0.04690146243
coef_fit_slat_gauss(19)=0.00305632563
expo_fit_slat_gauss(20)=0.02834749861
coef_fit_slat_gauss(20)=0.00013317513
END_PROVIDER
double precision function slater_fit_gam(x,gam)
implicit none
double precision, intent(in) :: x,gam
BEGIN_DOC
! fit of the function exp(-gam * x) with gaussian functions
END_DOC
integer :: i
slater_fit_gam = 0.d0
do i = 1, n_max_fit_slat
slater_fit_gam += coef_fit_slat_gauss(i) * dexp(-expo_fit_slat_gauss(i) * gam * gam * x * x)
enddo
end
subroutine expo_fit_slater_gam(gam,expos)
implicit none
BEGIN_DOC
! returns the array of the exponents of the gaussians to fit exp(-gam*x)
END_DOC
double precision, intent(in) :: gam
double precision, intent(out) :: expos(n_max_fit_slat)
integer :: i
do i = 1, n_max_fit_slat
expos(i) = expo_fit_slat_gauss(i) * gam * gam
enddo
end

342
src/ao_many_one_e_ints/grad_related_ints.irp.f Normal file
View File

@ -0,0 +1,342 @@
BEGIN_PROVIDER [ double precision, v_ij_erf_rk_cst_mu, ( ao_num, ao_num,n_points_final_grid)]
implicit none
BEGIN_DOC
! int dr phi_i(r) phi_j(r) (erf(mu(R) |r - R| - 1)/|r - R|
END_DOC
integer :: i,j,ipoint
double precision :: mu,r(3),NAI_pol_mult_erf_ao
double precision :: int_mu, int_coulomb
provide mu_erf final_grid_points
double precision :: wall0, wall1
call wall_time(wall0)
!$OMP PARALLEL &
!$OMP DEFAULT (NONE) &
!$OMP PRIVATE (i,j,ipoint,mu,r,int_mu,int_coulomb) &
!$OMP SHARED (ao_num,n_points_final_grid,v_ij_erf_rk_cst_mu,final_grid_points,mu_erf)
!$OMP DO SCHEDULE (dynamic)
do ipoint = 1, n_points_final_grid
do i = 1, ao_num
do j = i, ao_num
mu = mu_erf
r(1) = final_grid_points(1,ipoint)
r(2) = final_grid_points(2,ipoint)
r(3) = final_grid_points(3,ipoint)
int_mu = NAI_pol_mult_erf_ao(i,j,mu,r)
int_coulomb = NAI_pol_mult_erf_ao(i,j,1.d+9,r)
v_ij_erf_rk_cst_mu(j,i,ipoint)= (int_mu - int_coulomb )
enddo
enddo
enddo
!$OMP END DO
!$OMP END PARALLEL
do ipoint = 1, n_points_final_grid
do i = 1, ao_num
do j = 1, i-1
v_ij_erf_rk_cst_mu(j,i,ipoint)= v_ij_erf_rk_cst_mu(i,j,ipoint)
enddo
enddo
enddo
call wall_time(wall1)
print*,'wall time for v_ij_erf_rk_cst_mu ',wall1 - wall0
END_PROVIDER
BEGIN_PROVIDER [ double precision, v_ij_erf_rk_cst_mu_transp, (n_points_final_grid, ao_num, ao_num)]
implicit none
BEGIN_DOC
! int dr phi_i(r) phi_j(r) (erf(mu(R) |r - R| - 1)/|r - R|
END_DOC
integer :: i,j,ipoint
double precision :: mu,r(3),NAI_pol_mult_erf_ao
double precision :: int_mu, int_coulomb
provide mu_erf final_grid_points
double precision :: wall0, wall1
call wall_time(wall0)
!$OMP PARALLEL &
!$OMP DEFAULT (NONE) &
!$OMP PRIVATE (i,j,ipoint,mu,r,int_mu,int_coulomb) &
!$OMP SHARED (ao_num,n_points_final_grid,v_ij_erf_rk_cst_mu_transp,final_grid_points,mu_erf)
!$OMP DO SCHEDULE (dynamic)
do i = 1, ao_num
do j = i, ao_num
do ipoint = 1, n_points_final_grid
mu = mu_erf
r(1) = final_grid_points(1,ipoint)
r(2) = final_grid_points(2,ipoint)
r(3) = final_grid_points(3,ipoint)
int_mu = NAI_pol_mult_erf_ao(i,j,mu,r)
int_coulomb = NAI_pol_mult_erf_ao(i,j,1.d+9,r)
v_ij_erf_rk_cst_mu_transp(ipoint,j,i)= (int_mu - int_coulomb )
enddo
enddo
enddo
!$OMP END DO
!$OMP END PARALLEL
do i = 1, ao_num
do j = 1, i-1
do ipoint = 1, n_points_final_grid
v_ij_erf_rk_cst_mu_transp(ipoint,j,i)= v_ij_erf_rk_cst_mu_transp(ipoint,i,j)
enddo
enddo
enddo
call wall_time(wall1)
print*,'wall time for v_ij_erf_rk_cst_mu_transp ',wall1 - wall0
END_PROVIDER
BEGIN_PROVIDER [ double precision, x_v_ij_erf_rk_cst_mu_tmp, (3,ao_num, ao_num,n_points_final_grid)]
implicit none
BEGIN_DOC
! int dr x * phi_i(r) phi_j(r) (erf(mu(R) |r - R|) - 1)/|r - R|
END_DOC
integer :: i,j,ipoint,m
double precision :: mu,r(3),ints(3),ints_coulomb(3)
double precision :: wall0, wall1
call wall_time(wall0)
!$OMP PARALLEL &
!$OMP DEFAULT (NONE) &
!$OMP PRIVATE (i,j,ipoint,mu,r,ints,m,ints_coulomb) &
!$OMP SHARED (ao_num,n_points_final_grid,x_v_ij_erf_rk_cst_mu_tmp,final_grid_points,mu_erf)
!$OMP DO SCHEDULE (dynamic)
do ipoint = 1, n_points_final_grid
do i = 1, ao_num
do j = i, ao_num
mu = mu_erf
r(1) = final_grid_points(1,ipoint)
r(2) = final_grid_points(2,ipoint)
r(3) = final_grid_points(3,ipoint)
call NAI_pol_x_mult_erf_ao(i,j,mu,r,ints)
call NAI_pol_x_mult_erf_ao(i,j,1.d+9,r,ints_coulomb)
do m = 1, 3
x_v_ij_erf_rk_cst_mu_tmp(m,j,i,ipoint) = ( ints(m) - ints_coulomb(m))
enddo
enddo
enddo
enddo
!$OMP END DO
!$OMP END PARALLEL
do ipoint = 1, n_points_final_grid
do i = 1, ao_num
do j = 1, i-1
do m = 1, 3
x_v_ij_erf_rk_cst_mu_tmp(m,j,i,ipoint)= x_v_ij_erf_rk_cst_mu_tmp(m,i,j,ipoint)
enddo
enddo
enddo
enddo
call wall_time(wall1)
print*,'wall time for x_v_ij_erf_rk_cst_mu_tmp',wall1 - wall0
END_PROVIDER
BEGIN_PROVIDER [ double precision, x_v_ij_erf_rk_cst_mu, (ao_num, ao_num,n_points_final_grid,3)]
implicit none
BEGIN_DOC
! int dr x * phi_i(r) phi_j(r) (erf(mu(R) |r - R|) - 1)/|r - R|
END_DOC
integer :: i,j,ipoint,m
double precision :: mu,r(3),ints,ints_coulomb
double precision :: wall0, wall1
call wall_time(wall0)
do ipoint = 1, n_points_final_grid
do i = 1, ao_num
do j = 1, ao_num
do m = 1, 3
x_v_ij_erf_rk_cst_mu(j,i,ipoint,m)= x_v_ij_erf_rk_cst_mu_tmp(m,j,i,ipoint)
enddo
enddo
enddo
enddo
call wall_time(wall1)
print*,'wall time for x_v_ij_erf_rk_cst_mu',wall1 - wall0
END_PROVIDER
BEGIN_PROVIDER [ double precision, x_v_ij_erf_rk_cst_mu_transp, (ao_num, ao_num,3,n_points_final_grid)]
implicit none
BEGIN_DOC
! int dr x * phi_i(r) phi_j(r) (erf(mu(R) |r - R|) - 1)/|r - R|
END_DOC
integer :: i,j,ipoint,m
double precision :: mu,r(3),ints,ints_coulomb
double precision :: wall0, wall1
call wall_time(wall0)
do ipoint = 1, n_points_final_grid
do m = 1, 3
do i = 1, ao_num
do j = 1, ao_num
x_v_ij_erf_rk_cst_mu_transp(j,i,m,ipoint)= x_v_ij_erf_rk_cst_mu_tmp(m,j,i,ipoint)
enddo
enddo
enddo
enddo
call wall_time(wall1)
print*,'wall time for x_v_ij_erf_rk_cst_mu_transp',wall1 - wall0
END_PROVIDER
BEGIN_PROVIDER [ double precision, x_v_ij_erf_rk_cst_mu_transp_bis, (n_points_final_grid,ao_num, ao_num,3)]
implicit none
BEGIN_DOC
! int dr x * phi_i(r) phi_j(r) (erf(mu(R) |r - R|) - 1)/|r - R|
END_DOC
integer :: i,j,ipoint,m
double precision :: mu,r(3),ints,ints_coulomb
double precision :: wall0, wall1
call wall_time(wall0)
do m = 1, 3
do i = 1, ao_num
do j = 1, ao_num
do ipoint = 1, n_points_final_grid
x_v_ij_erf_rk_cst_mu_transp_bis(ipoint,j,i,m)= x_v_ij_erf_rk_cst_mu_tmp(m,j,i,ipoint)
enddo
enddo
enddo
enddo
call wall_time(wall1)
print*,'wall time for x_v_ij_erf_rk_cst_mu_transp',wall1 - wall0
END_PROVIDER
BEGIN_PROVIDER [ double precision, d_dx_v_ij_erf_rk_cst_mu_tmp, (3,n_points_final_grid,ao_num, ao_num)]
implicit none
BEGIN_DOC
! d_dx_v_ij_erf_rk_cst_mu_tmp(m,R,j,i) = int dr phi_j(r)) (erf(mu(R) |r - R|) - 1)/|r - R| d/dx (phi_i(r)
!
! with m == 1 -> d/dx , m == 2 -> d/dy , m == 3 -> d/dz
END_DOC
integer :: i,j,ipoint,m
double precision :: mu,r(3),ints(3),ints_coulomb(3)
double precision :: wall0, wall1
call wall_time(wall0)
!$OMP PARALLEL &
!$OMP DEFAULT (NONE) &
!$OMP PRIVATE (i,j,ipoint,mu,r,ints,m,ints_coulomb) &
!$OMP SHARED (ao_num,n_points_final_grid,d_dx_v_ij_erf_rk_cst_mu_tmp,final_grid_points,mu_erf)
!$OMP DO SCHEDULE (dynamic)
do i = 1, ao_num
do j = 1, ao_num
do ipoint = 1, n_points_final_grid
mu = mu_erf
r(1) = final_grid_points(1,ipoint)
r(2) = final_grid_points(2,ipoint)
r(3) = final_grid_points(3,ipoint)
call phi_j_erf_mu_r_dxyz_phi(j,i,mu, r, ints)
call phi_j_erf_mu_r_dxyz_phi(j,i,1.d+9, r, ints_coulomb)
do m = 1, 3
d_dx_v_ij_erf_rk_cst_mu_tmp(m,ipoint,j,i) = ( ints(m) - ints_coulomb(m))
enddo
enddo
enddo
enddo
!$OMP END DO
!$OMP END PARALLEL
call wall_time(wall1)
print*,'wall time for d_dx_v_ij_erf_rk_cst_mu_tmp',wall1 - wall0
END_PROVIDER
BEGIN_PROVIDER [ double precision, d_dx_v_ij_erf_rk_cst_mu, (n_points_final_grid,ao_num, ao_num,3)]
implicit none
BEGIN_DOC
! d_dx_v_ij_erf_rk_cst_mu_tmp(j,i,R,m) = int dr phi_j(r)) (erf(mu(R) |r - R|) - 1)/|r - R| d/dx (phi_i(r)
!
! with m == 1 -> d/dx , m == 2 -> d/dy , m == 3 -> d/dz
END_DOC
integer :: i,j,ipoint,m
double precision :: mu,r(3),ints,ints_coulomb
double precision :: wall0, wall1
call wall_time(wall0)
do i = 1, ao_num
do j = 1, ao_num
do m = 1, 3
do ipoint = 1, n_points_final_grid
d_dx_v_ij_erf_rk_cst_mu(ipoint,j,i,m)= d_dx_v_ij_erf_rk_cst_mu_tmp(m,ipoint,j,i)
enddo
enddo
enddo
enddo
call wall_time(wall1)
print*,'wall time for d_dx_v_ij_erf_rk_cst_mu',wall1 - wall0
END_PROVIDER
BEGIN_PROVIDER [ double precision, x_d_dx_v_ij_erf_rk_cst_mu_tmp, (3,n_points_final_grid,ao_num, ao_num)]
implicit none
BEGIN_DOC
! x_d_dx_v_ij_erf_rk_cst_mu_tmp(m,j,i,R) = int dr x phi_j(r)) (erf(mu(R) |r - R|) - 1)/|r - R| d/dx (phi_i(r)
!
! with m == 1 -> d/dx , m == 2 -> d/dy , m == 3 -> d/dz
END_DOC
integer :: i,j,ipoint,m
double precision :: mu,r(3),ints(3),ints_coulomb(3)
double precision :: wall0, wall1
call wall_time(wall0)
!$OMP PARALLEL &
!$OMP DEFAULT (NONE) &
!$OMP PRIVATE (i,j,ipoint,mu,r,ints,m,ints_coulomb) &
!$OMP SHARED (ao_num,n_points_final_grid,x_d_dx_v_ij_erf_rk_cst_mu_tmp,final_grid_points,mu_erf)
!$OMP DO SCHEDULE (dynamic)
do i = 1, ao_num
do j = 1, ao_num
do ipoint = 1, n_points_final_grid
mu = mu_erf
r(1) = final_grid_points(1,ipoint)
r(2) = final_grid_points(2,ipoint)
r(3) = final_grid_points(3,ipoint)
call phi_j_erf_mu_r_xyz_dxyz_phi(j,i,mu, r, ints)
call phi_j_erf_mu_r_xyz_dxyz_phi(j,i,1.d+9, r, ints_coulomb)
do m = 1, 3
x_d_dx_v_ij_erf_rk_cst_mu_tmp(m,ipoint,j,i) = ( ints(m) - ints_coulomb(m))
enddo
enddo
enddo
enddo
!$OMP END DO
!$OMP END PARALLEL
call wall_time(wall1)
print*,'wall time for x_d_dx_v_ij_erf_rk_cst_mu_tmp',wall1 - wall0
END_PROVIDER
BEGIN_PROVIDER [ double precision, x_d_dx_v_ij_erf_rk_cst_mu, (n_points_final_grid,ao_num, ao_num,3)]
implicit none
BEGIN_DOC
! x_d_dx_v_ij_erf_rk_cst_mu_tmp(j,i,R,m) = int dr x phi_j(r)) (erf(mu(R) |r - R|) - 1)/|r - R| d/dx (phi_i(r)
!
! with m == 1 -> d/dx , m == 2 -> d/dy , m == 3 -> d/dz
END_DOC
integer :: i,j,ipoint,m
double precision :: mu,r(3),ints,ints_coulomb
double precision :: wall0, wall1
call wall_time(wall0)
do i = 1, ao_num
do j = 1, ao_num
do ipoint = 1, n_points_final_grid
do m = 1, 3
x_d_dx_v_ij_erf_rk_cst_mu(ipoint,j,i,m)= x_d_dx_v_ij_erf_rk_cst_mu_tmp(m,ipoint,j,i)
enddo
enddo
enddo
enddo
call wall_time(wall1)
print*,'wall time for x_d_dx_v_ij_erf_rk_cst_mu',wall1 - wall0
END_PROVIDER

195
src/ao_many_one_e_ints/prim_int_erf_gauss.irp.f Normal file
View File

@ -0,0 +1,195 @@
double precision function NAI_pol_mult_erf_gauss_r12(D_center,delta,A_center,B_center,power_A,power_B,alpha,beta,C_center,mu)
BEGIN_DOC
! Computes the following integral R^3 :
!
! .. math::
!
! \int dr (x-A_x)^a (x-B_x)^b \exp(-\alpha (x-A_x)^2 - \beta (x-B_x)^2 )
! \frac{\erf(\mu | r - R_C | )}{ | r - R_C | }$ exp(-delta (r - D)^2 ).
!
END_DOC
implicit none
include 'constants.include.F'
double precision, intent(in) :: D_center(3), delta ! pure gaussian "D"
double precision, intent(in) :: C_center(3),mu ! coulomb center "C" and "mu" in the erf(mu*x)/x function
double precision, intent(in) :: A_center(3),B_center(3),alpha,beta ! gaussian/polynoms "A" and "B"
integer, intent(in) :: power_A(3),power_B(3)
double precision :: NAI_pol_mult_erf
! First you multiply the usual gaussian "A" with the gaussian exp(-delta (r - D)^2 )
double precision :: A_new(0:max_dim,3)! new polynom
double precision :: A_center_new(3) ! new center
integer :: iorder_a_new(3) ! i_order(i) = order of the new polynom ==> should be equal to power_A
double precision :: alpha_new ! new exponent
double precision :: fact_a_new ! constant factor
double precision :: accu,coefx,coefy,coefz,coefxy,coefxyz,thr
integer :: d(3),i,lx,ly,lz,iorder_tmp(3)
thr = 1.d-10
d = 0 ! order of the polynom for the gaussian exp(-delta (r - D)^2 ) == 0
! New gaussian/polynom defined by :: new pol new center new expo cst fact new order
call give_explicit_poly_and_gaussian(A_new , A_center_new , alpha_new, fact_a_new , iorder_a_new , &
delta,alpha,d,power_A,D_center,A_center,n_pt_max_integrals)
! The new gaussian exp(-delta (r - D)^2 ) (x-A_x)^a \exp(-\alpha (x-A_x)^2
accu = 0.d0
do lx = 0, iorder_a_new(1)
coefx = A_new(lx,1)
if(dabs(coefx).lt.thr)cycle
iorder_tmp(1) = lx
do ly = 0, iorder_a_new(2)
coefy = A_new(ly,2)
coefxy = coefx * coefy
if(dabs(coefxy).lt.thr)cycle
iorder_tmp(2) = ly
do lz = 0, iorder_a_new(3)
coefz = A_new(lz,3)
coefxyz = coefxy * coefz
if(dabs(coefxyz).lt.thr)cycle
iorder_tmp(3) = lz
accu += coefxyz * NAI_pol_mult_erf(A_center_new,B_center,iorder_tmp,power_B,alpha_new,beta,C_center,n_pt_max_integrals,mu)
enddo
enddo
enddo
NAI_pol_mult_erf_gauss_r12 = fact_a_new * accu
end
subroutine erfc_mu_gauss_xyz(D_center,delta,mu,A_center,B_center,power_A,power_B,alpha,beta,n_pt_in,xyz_ints)
BEGIN_DOC
! Computes the following integral :
!
! .. math::
!
! \int dr exp(-delta (r - D)^2 ) x/y/z * (1 - erf(mu |r-r'|))/ |r-r'| * (x-A_x)^a (x-B_x)^b \exp(-\alpha (x-A_x)^2 - \beta (x-B_x)^2 )
!
! xyz_ints(1) = x , xyz_ints(2) = y, xyz_ints(3) = z, xyz_ints(4) = x^0
END_DOC
implicit none
include 'constants.include.F'
double precision, intent(in) :: D_center(3), delta,mu ! pure gaussian "D" and mu parameter
double precision, intent(in) :: A_center(3),B_center(3),alpha,beta ! gaussian/polynoms "A" and "B"
integer, intent(in) :: power_A(3),power_B(3),n_pt_in
double precision, intent(out) :: xyz_ints(4)
double precision :: NAI_pol_mult_erf
! First you multiply the usual gaussian "A" with the gaussian exp(-delta (r - D)^2 )
double precision :: A_new(0:max_dim,3)! new polynom
double precision :: A_center_new(3) ! new center
integer :: iorder_a_new(3) ! i_order(i) = order of the new polynom ==> should be equal to power_A
double precision :: alpha_new ! new exponent
double precision :: fact_a_new ! constant factor
double precision :: accu,coefx,coefy,coefz,coefxy,coefxyz,thr,contrib,contrib_inf,mu_inf
integer :: d(3),i,lx,ly,lz,iorder_tmp(3),dim1,mm
integer :: power_B_tmp(3)
dim1=100
mu_inf = 1.d+10
thr = 1.d-10
d = 0 ! order of the polynom for the gaussian exp(-delta (r - D)^2 ) == 0
! New gaussian/polynom defined by :: new pol new center new expo cst fact new order
call give_explicit_poly_and_gaussian(A_new , A_center_new , alpha_new, fact_a_new , iorder_a_new , &
delta,alpha,d,power_A,D_center,A_center,n_pt_max_integrals)
! The new gaussian exp(-delta (r - D)^2 ) (x-A_x)^a \exp(-\alpha (x-A_x)^2
xyz_ints = 0.d0
do lx = 0, iorder_a_new(1)
coefx = A_new(lx,1)
if(dabs(coefx).lt.thr)cycle
iorder_tmp(1) = lx
do ly = 0, iorder_a_new(2)
coefy = A_new(ly,2)
coefxy = coefx * coefy
if(dabs(coefxy).lt.thr)cycle
iorder_tmp(2) = ly
do lz = 0, iorder_a_new(3)
coefz = A_new(lz,3)
coefxyz = coefxy * coefz
if(dabs(coefxyz).lt.thr)cycle
iorder_tmp(3) = lz
power_B_tmp = power_B
contrib = NAI_pol_mult_erf(A_center_new,B_center,iorder_tmp,power_B_tmp,alpha_new,beta,D_center,n_pt_in,mu)
contrib_inf = NAI_pol_mult_erf(A_center_new,B_center,iorder_tmp,power_B_tmp,alpha_new,beta,D_center,n_pt_in,mu_inf)
xyz_ints(4) += (contrib_inf - contrib) * coefxyz ! usual term with no x/y/z
do mm = 1, 3
! (x phi_i ) * phi_j
! x * (x - B_x)^b_x = B_x (x - B_x)^b_x + 1 * (x - B_x)^{b_x+1}
!
! first contribution :: B_x (x - B_x)^b_x :: usual integral multiplied by B_x
power_B_tmp = power_B
contrib_inf = NAI_pol_mult_erf(A_center_new,B_center,iorder_tmp,power_B_tmp,alpha_new,beta,D_center,n_pt_in,mu_inf)
contrib = NAI_pol_mult_erf(A_center_new,B_center,iorder_tmp,power_B_tmp,alpha_new,beta,D_center,n_pt_in,mu)
xyz_ints(mm) += (contrib_inf - contrib) * B_center(mm) * coefxyz
!
! second contribution :: (x - B_x)^(b_x+1) :: integral with b_x=>b_x+1
power_B_tmp(mm) += 1
contrib = NAI_pol_mult_erf(A_center_new,B_center,iorder_tmp,power_B_tmp,alpha_new,beta,D_center,n_pt_in,mu)
contrib_inf = NAI_pol_mult_erf(A_center_new,B_center,iorder_tmp,power_B_tmp,alpha_new,beta,D_center,n_pt_in,mu_inf)
xyz_ints(mm) += (contrib_inf - contrib) * coefxyz
enddo
enddo
enddo
enddo
xyz_ints *= fact_a_new
end
double precision function erf_mu_gauss(D_center,delta,mu,A_center,B_center,power_A,power_B,alpha,beta,n_pt_in)
BEGIN_DOC
! Computes the following integral :
!
! .. math::
!
! \int dr exp(-delta (r - D)^2 ) erf(mu*|r-r'|)/ |r-r'| * (x-A_x)^a (x-B_x)^b \exp(-\alpha (x-A_x)^2 - \beta (x-B_x)^2 )
!
END_DOC
implicit none
include 'constants.include.F'
double precision, intent(in) :: D_center(3), delta,mu ! pure gaussian "D" and mu parameter
double precision, intent(in) :: A_center(3),B_center(3),alpha,beta ! gaussian/polynoms "A" and "B"
integer, intent(in) :: power_A(3),power_B(3),n_pt_in
double precision :: NAI_pol_mult_erf
! First you multiply the usual gaussian "A" with the gaussian exp(-delta (r - D)^2 )
double precision :: A_new(0:max_dim,3)! new polynom
double precision :: A_center_new(3) ! new center
integer :: iorder_a_new(3) ! i_order(i) = order of the new polynom ==> should be equal to power_A
double precision :: alpha_new ! new exponent
double precision :: fact_a_new ! constant factor
double precision :: accu,coefx,coefy,coefz,coefxy,coefxyz,thr,contrib,contrib_inf,mu_inf
integer :: d(3),i,lx,ly,lz,iorder_tmp(3),dim1,mm
dim1=100
mu_inf = 1.d+10
thr = 1.d-10
d = 0 ! order of the polynom for the gaussian exp(-delta (r - D)^2 ) == 0
! New gaussian/polynom defined by :: new pol new center new expo cst fact new order
call give_explicit_poly_and_gaussian(A_new , A_center_new , alpha_new, fact_a_new , iorder_a_new , &
delta,alpha,d,power_A,D_center,A_center,n_pt_max_integrals)
! The new gaussian exp(-delta (r - D)^2 ) (x-A_x)^a \exp(-\alpha (x-A_x)^2
erf_mu_gauss = 0.d0
do lx = 0, iorder_a_new(1)
coefx = A_new(lx,1)
if(dabs(coefx).lt.thr)cycle
iorder_tmp(1) = lx
do ly = 0, iorder_a_new(2)
coefy = A_new(ly,2)
coefxy = coefx * coefy
if(dabs(coefxy).lt.thr)cycle
iorder_tmp(2) = ly
do lz = 0, iorder_a_new(3)
coefz = A_new(lz,3)
coefxyz = coefxy * coefz
if(dabs(coefxyz).lt.thr)cycle
iorder_tmp(3) = lz
contrib = NAI_pol_mult_erf(A_center_new,B_center,iorder_tmp,power_B,alpha_new,beta,D_center,n_pt_in,mu)
erf_mu_gauss += contrib * coefxyz
enddo
enddo
enddo
erf_mu_gauss *= fact_a_new
end

191
src/ao_many_one_e_ints/prim_int_gauss_gauss.irp.f Normal file
View File

@ -0,0 +1,191 @@
double precision function overlap_gauss_r12(D_center,delta,A_center,B_center,power_A,power_B,alpha,beta)
BEGIN_DOC
! Computes the following integral :
!
! .. math::
!
! \int dr exp(-delta (r - D)^2 ) (x-A_x)^a (x-B_x)^b \exp(-\alpha (x-A_x)^2 - \beta (x-B_x)^2 )
!
END_DOC
implicit none
include 'constants.include.F'
double precision, intent(in) :: D_center(3), delta ! pure gaussian "D"
double precision, intent(in) :: A_center(3),B_center(3),alpha,beta ! gaussian/polynoms "A" and "B"
integer, intent(in) :: power_A(3),power_B(3)
double precision :: overlap_x,overlap_y,overlap_z,overlap
! First you multiply the usual gaussian "A" with the gaussian exp(-delta (r - D)^2 )
double precision :: A_new(0:max_dim,3)! new polynom
double precision :: A_center_new(3) ! new center
integer :: iorder_a_new(3) ! i_order(i) = order of the new polynom ==> should be equal to power_A
double precision :: alpha_new ! new exponent
double precision :: fact_a_new ! constant factor
double precision :: accu,coefx,coefy,coefz,coefxy,coefxyz,thr
integer :: d(3),i,lx,ly,lz,iorder_tmp(3),dim1
dim1=100
thr = 1.d-10
d = 0 ! order of the polynom for the gaussian exp(-delta (r - D)^2 ) == 0
! New gaussian/polynom defined by :: new pol new center new expo cst fact new order
call give_explicit_poly_and_gaussian(A_new , A_center_new , alpha_new, fact_a_new , iorder_a_new , &
delta,alpha,d,power_A,D_center,A_center,n_pt_max_integrals)
! The new gaussian exp(-delta (r - D)^2 ) (x-A_x)^a \exp(-\alpha (x-A_x)^2
accu = 0.d0
do lx = 0, iorder_a_new(1)
coefx = A_new(lx,1)
if(dabs(coefx).lt.thr)cycle
iorder_tmp(1) = lx
do ly = 0, iorder_a_new(2)
coefy = A_new(ly,2)
coefxy = coefx * coefy
if(dabs(coefxy).lt.thr)cycle
iorder_tmp(2) = ly
do lz = 0, iorder_a_new(3)
coefz = A_new(lz,3)
coefxyz = coefxy * coefz
if(dabs(coefxyz).lt.thr)cycle
iorder_tmp(3) = lz
call overlap_gaussian_xyz(A_center_new,B_center,alpha_new,beta,iorder_tmp,power_B,overlap_x,overlap_y,overlap_z,overlap,dim1)
accu += coefxyz * overlap
enddo
enddo
enddo
overlap_gauss_r12 = fact_a_new * accu
end
subroutine overlap_gauss_xyz_r12(D_center,delta,A_center,B_center,power_A,power_B,alpha,beta,gauss_ints)
BEGIN_DOC
! Computes the following integral :
!
! .. math::
!
! gauss_ints(m) = \int dr exp(-delta (r - D)^2 ) * x/y/z (x-A_x)^a (x-B_x)^b \exp(-\alpha (x-A_x)^2 - \beta (x-B_x)^2 )
!
! with m == 1 ==> x, m == 2 ==> y, m == 3 ==> z
END_DOC
implicit none
include 'constants.include.F'
double precision, intent(in) :: D_center(3), delta ! pure gaussian "D"
double precision, intent(in) :: A_center(3),B_center(3),alpha,beta ! gaussian/polynoms "A" and "B"
integer, intent(in) :: power_A(3),power_B(3)
double precision, intent(out) :: gauss_ints(3)
double precision :: overlap_x,overlap_y,overlap_z,overlap
! First you multiply the usual gaussian "A" with the gaussian exp(-delta (r - D)^2 )
double precision :: A_new(0:max_dim,3)! new polynom
double precision :: A_center_new(3) ! new center
integer :: iorder_a_new(3) ! i_order(i) = order of the new polynom ==> should be equal to power_A
integer :: power_B_new(3)
double precision :: alpha_new ! new exponent
double precision :: fact_a_new ! constant factor
double precision :: coefx,coefy,coefz,coefxy,coefxyz,thr
integer :: d(3),i,lx,ly,lz,iorder_tmp(3),dim1,m
dim1=100
thr = 1.d-10
d = 0 ! order of the polynom for the gaussian exp(-delta (r - D)^2 ) == 0
! New gaussian/polynom defined by :: new pol new center new expo cst fact new order
call give_explicit_poly_and_gaussian(A_new , A_center_new , alpha_new, fact_a_new , iorder_a_new , &
delta,alpha,d,power_A,D_center,A_center,n_pt_max_integrals)
! The new gaussian exp(-delta (r - D)^2 ) (x-A_x)^a \exp(-\alpha (x-A_x)^2
gauss_ints = 0.d0
do lx = 0, iorder_a_new(1)
coefx = A_new(lx,1)
if(dabs(coefx).lt.thr)cycle
iorder_tmp(1) = lx
do ly = 0, iorder_a_new(2)
coefy = A_new(ly,2)
coefxy = coefx * coefy
if(dabs(coefxy).lt.thr)cycle
iorder_tmp(2) = ly
do lz = 0, iorder_a_new(3)
coefz = A_new(lz,3)
coefxyz = coefxy * coefz
if(dabs(coefxyz).lt.thr)cycle
iorder_tmp(3) = lz
do m = 1, 3
! change (x-Bx)^bx --> (x-Bx)^(bx+1) + Bx(x-Bx)^bx
power_B_new = power_B
power_B_new(m) += 1 ! (x-Bx)^(bx+1)
call overlap_gaussian_xyz(A_center_new,B_center,alpha_new,beta,iorder_tmp,power_B_new,overlap_x,overlap_y,overlap_z,overlap,dim1)
gauss_ints(m) += coefxyz * overlap
power_B_new = power_B
call overlap_gaussian_xyz(A_center_new,B_center,alpha_new,beta,iorder_tmp,power_B_new,overlap_x,overlap_y,overlap_z,overlap,dim1)
gauss_ints(m) += coefxyz * overlap * B_center(m) ! Bx (x-Bx)^(bx)
enddo
enddo
enddo
enddo
gauss_ints *= fact_a_new
end
double precision function overlap_gauss_xyz_r12_specific(D_center,delta,A_center,B_center,power_A,power_B,alpha,beta,mx)
BEGIN_DOC
! Computes the following integral :
!
! .. math::
!
! \int dr exp(-delta (r - D)^2 ) * x/y/z (x-A_x)^a (x-B_x)^b \exp(-\alpha (x-A_x)^2 - \beta (x-B_x)^2 )
!
! with mx == 1 ==> x, mx == 2 ==> y, mx == 3 ==> z
END_DOC
implicit none
include 'constants.include.F'
double precision, intent(in) :: D_center(3), delta ! pure gaussian "D"
double precision, intent(in) :: A_center(3),B_center(3),alpha,beta ! gaussian/polynoms "A" and "B"
integer, intent(in) :: power_A(3),power_B(3),mx
double precision :: overlap_x,overlap_y,overlap_z,overlap
! First you multiply the usual gaussian "A" with the gaussian exp(-delta (r - D)^2 )
double precision :: A_new(0:max_dim,3)! new polynom
double precision :: A_center_new(3) ! new center
integer :: iorder_a_new(3) ! i_order(i) = order of the new polynom ==> should be equal to power_A
integer :: power_B_new(3)
double precision :: alpha_new ! new exponent
double precision :: fact_a_new ! constant factor
double precision :: coefx,coefy,coefz,coefxy,coefxyz,thr
integer :: d(3),i,lx,ly,lz,iorder_tmp(3),dim1,m
dim1=100
thr = 1.d-10
d = 0 ! order of the polynom for the gaussian exp(-delta (r - D)^2 ) == 0
! New gaussian/polynom defined by :: new pol new center new expo cst fact new order
call give_explicit_poly_and_gaussian(A_new , A_center_new , alpha_new, fact_a_new , iorder_a_new , &
delta,alpha,d,power_A,D_center,A_center,n_pt_max_integrals)
! The new gaussian exp(-delta (r - D)^2 ) (x-A_x)^a \exp(-\alpha (x-A_x)^2
overlap_gauss_xyz_r12_specific = 0.d0
do lx = 0, iorder_a_new(1)
coefx = A_new(lx,1)
if(dabs(coefx).lt.thr)cycle
iorder_tmp(1) = lx
do ly = 0, iorder_a_new(2)
coefy = A_new(ly,2)
coefxy = coefx * coefy
if(dabs(coefxy).lt.thr)cycle
iorder_tmp(2) = ly
do lz = 0, iorder_a_new(3)
coefz = A_new(lz,3)
coefxyz = coefxy * coefz
if(dabs(coefxyz).lt.thr)cycle
iorder_tmp(3) = lz
m = mx
! change (x-Bx)^bx --> (x-Bx)^(bx+1) + Bx(x-Bx)^bx
power_B_new = power_B
power_B_new(m) += 1 ! (x-Bx)^(bx+1)
call overlap_gaussian_xyz(A_center_new,B_center,alpha_new,beta,iorder_tmp,power_B_new,overlap_x,overlap_y,overlap_z,overlap,dim1)
overlap_gauss_xyz_r12_specific += coefxyz * overlap
power_B_new = power_B
call overlap_gaussian_xyz(A_center_new,B_center,alpha_new,beta,iorder_tmp,power_B_new,overlap_x,overlap_y,overlap_z,overlap,dim1)
overlap_gauss_xyz_r12_specific += coefxyz * overlap * B_center(m) ! Bx (x-Bx)^(bx)
enddo
enddo
enddo
overlap_gauss_xyz_r12_specific *= fact_a_new
end

121
src/ao_many_one_e_ints/stg_gauss_int.irp.f Normal file
View File

@ -0,0 +1,121 @@
double precision function ovlp_stg_gauss_int_phi_ij(D_center,gam,delta,A_center,B_center,power_A,power_B,alpha,beta)
BEGIN_DOC
! Computes the following integral :
!
! .. math::
!
! \int dr exp(-gam (r - D)) exp(-delta * (r -D)^2) (x-A_x)^a (x-B_x)^b \exp(-\alpha (x-A_x)^2 - \beta (x-B_x)^2 )
!
END_DOC
implicit none
double precision, intent(in) :: D_center(3), gam ! pure Slater "D" in r-r_D
double precision, intent(in) :: delta ! gaussian in r-r_D
double precision, intent(in) :: A_center(3),B_center(3),alpha,beta ! gaussian/polynoms "A" and "B"
integer, intent(in) :: power_A(3),power_B(3)
integer :: i
double precision :: integral,gama_gauss
double precision, allocatable :: expos_slat(:)
allocate(expos_slat(n_max_fit_slat))
double precision :: overlap_gauss_r12
ovlp_stg_gauss_int_phi_ij = 0.d0
call expo_fit_slater_gam(gam,expos_slat)
do i = 1, n_max_fit_slat
gama_gauss = expos_slat(i)+delta
integral = overlap_gauss_r12(D_center,gama_gauss,A_center,B_center,power_A,power_B,alpha,beta)
ovlp_stg_gauss_int_phi_ij += coef_fit_slat_gauss(i) * integral
enddo
end
double precision function erf_mu_stg_gauss_int_phi_ij(D_center,gam,delta,A_center,B_center,power_A,power_B,alpha,beta,C_center,mu)
BEGIN_DOC
! Computes the following integral :
!
! .. math::
!
! \int dr exp(-gam(r - D)-delta(r - D)^2) (x-A_x)^a (x-B_x)^b \exp(-\alpha (x-A_x)^2 - \beta (x-B_x)^2 )
! \frac{\erf(\mu | r - R_C | )}{ | r - R_C | }$.
!
END_DOC
implicit none
include 'constants.include.F'
double precision, intent(in) :: D_center(3), gam ! pure Slater "D" in r-r_D
double precision, intent(in) :: delta ! gaussian in r-r_D
double precision, intent(in) :: C_center(3),mu ! coulomb center "C" and "mu" in the erf(mu*x)/x function
double precision, intent(in) :: A_center(3),B_center(3),alpha,beta ! gaussian/polynoms "A" and "B"
integer, intent(in) :: power_A(3),power_B(3)
integer :: i
double precision :: NAI_pol_mult_erf_gauss_r12
double precision :: integral,gama_gauss
double precision, allocatable :: expos_slat(:)
allocate(expos_slat(n_max_fit_slat))
erf_mu_stg_gauss_int_phi_ij = 0.d0
call expo_fit_slater_gam(gam,expos_slat)
do i = 1, n_max_fit_slat
gama_gauss = expos_slat(i) + delta
integral = NAI_pol_mult_erf_gauss_r12(D_center,gama_gauss,A_center,B_center,power_A,power_B,alpha,beta,C_center,mu)
erf_mu_stg_gauss_int_phi_ij += coef_fit_slat_gauss(i) * integral
enddo
end
double precision function overlap_stg_gauss(D_center,gam,A_center,B_center,power_A,power_B,alpha,beta)
BEGIN_DOC
! Computes the following integral :
!
! .. math::
!
! \int dr exp(-gam (r - D)) (x-A_x)^a (x-B_x)^b \exp(-\alpha (x-A_x)^2 - \beta (x-B_x)^2 )
!
END_DOC
implicit none
double precision, intent(in) :: D_center(3), gam ! pure Slater "D"
double precision, intent(in) :: A_center(3),B_center(3),alpha,beta ! gaussian/polynoms "A" and "B"
integer, intent(in) :: power_A(3),power_B(3)
integer :: i
double precision :: expos_slat(n_max_fit_slat),integral,delta
double precision :: overlap_gauss_r12
overlap_stg_gauss = 0.d0
call expo_fit_slater_gam(gam,expos_slat)
do i = 1, n_max_fit_slat
delta = expos_slat(i)
integral = overlap_gauss_r12(D_center,delta,A_center,B_center,power_A,power_B,alpha,beta)
overlap_stg_gauss += coef_fit_slat_gauss(i) * integral
enddo
end
double precision function erf_mu_stg_gauss(D_center,gam,A_center,B_center,power_A,power_B,alpha,beta,C_center,mu)
BEGIN_DOC
! Computes the following integral :
!
! .. math::
!
! \int dr exp(-gam(r - D)) (x-A_x)^a (x-B_x)^b \exp(-\alpha (x-A_x)^2 - \beta (x-B_x)^2 )
! \frac{\erf(\mu | r - R_C | )}{ | r - R_C | }$.
!
END_DOC
implicit none
include 'constants.include.F'
double precision, intent(in) :: D_center(3), gam ! pure Slater "D"
double precision, intent(in) :: C_center(3),mu ! coulomb center "C" and "mu" in the erf(mu*x)/x function
double precision, intent(in) :: A_center(3),B_center(3),alpha,beta ! gaussian/polynoms "A" and "B"
integer, intent(in) :: power_A(3),power_B(3)
integer :: i
double precision :: expos_slat(n_max_fit_slat),integral,delta
double precision :: NAI_pol_mult_erf_gauss_r12
erf_mu_stg_gauss = 0.d0
call expo_fit_slater_gam(gam,expos_slat)
do i = 1, n_max_fit_slat
delta = expos_slat(i)
integral = NAI_pol_mult_erf_gauss_r12(D_center,delta,A_center,B_center,power_A,power_B,alpha,beta,C_center,mu)
erf_mu_stg_gauss += coef_fit_slat_gauss(i) * integral
enddo
end

101
src/ao_many_one_e_ints/taylor_exp.irp.f Normal file
View File

@ -0,0 +1,101 @@
double precision function exp_dl(x,n)
implicit none
double precision, intent(in) :: x
integer , intent(in) :: n
integer :: i
exp_dl = 1.d0
do i = 1, n
exp_dl += fact_inv(i) * x**dble(i)
enddo
end
subroutine exp_dl_rout(x,n, array)
implicit none
double precision, intent(in) :: x
integer , intent(in) :: n
double precision, intent(out):: array(0:n)
integer :: i
double precision :: accu
accu = 1.d0
array(0) = 1.d0
do i = 1, n
accu += fact_inv(i) * x**dble(i)
array(i) = accu
enddo
end
subroutine exp_dl_ovlp_stg_phi_ij(zeta,D_center,gam,delta,A_center,B_center,power_A,power_B,alpha,beta,n_taylor,array_ints,integral_taylor,exponent_exp)
BEGIN_DOC
! Computes the following integrals :
!
! .. math::
!
! array(i) = \int dr EXP{exponent_exp * [exp(-gam*i (r - D)) exp(-delta*i * (r -D)^2)] (x-A_x)^a (x-B_x)^b \exp(-\alpha (x-A_x)^2 - \beta (x-B_x)^2 )
!
!
! and gives back the Taylor expansion of the exponential in integral_taylor
END_DOC
implicit none
double precision, intent(in) :: zeta ! prefactor of the argument of the exp(-zeta*x)
integer, intent(in) :: n_taylor ! order of the Taylor expansion of the exponential
double precision, intent(in) :: D_center(3), gam ! pure Slater "D" in r-r_D
double precision, intent(in) :: delta ! gaussian in r-r_D
double precision, intent(in) :: A_center(3),B_center(3),alpha,beta ! gaussian/polynoms "A" and "B"
double precision, intent(in) :: exponent_exp
integer, intent(in) :: power_A(3),power_B(3)
double precision, intent(out) :: array_ints(0:n_taylor),integral_taylor
integer :: i,dim1
double precision :: delta_exp,gam_exp,ovlp_stg_gauss_int_phi_ij
double precision :: overlap_x,overlap_y,overlap_z,overlap
dim1=100
call overlap_gaussian_xyz(A_center,B_center,alpha,beta,power_A,power_B,overlap_x,overlap_y,overlap_z,overlap,dim1)
array_ints(0) = overlap
integral_taylor = array_ints(0)
do i = 1, n_taylor
delta_exp = dble(i) * delta
gam_exp = dble(i) * gam
array_ints(i) = ovlp_stg_gauss_int_phi_ij(D_center,gam_exp,delta_exp,A_center,B_center,power_A,power_B,alpha,beta)
integral_taylor += (-zeta*exponent_exp)**dble(i) * fact_inv(i) * array_ints(i)
enddo
end
subroutine exp_dl_erf_stg_phi_ij(zeta,D_center,gam,delta,A_center,B_center,power_A,power_B,alpha,beta,C_center,mu,n_taylor,array_ints,integral_taylor)
BEGIN_DOC
! Computes the following integrals :
!
! .. math::
!
! array(i) = \int dr exp(-gam*i (r - D)) exp(-delta*i * (r -D)^2) (x-A_x)^a (x-B_x)^b \exp(-\alpha (x-A_x)^2 - \beta (x-B_x)^2 )
! \frac{\erf(\mu | r - R_C | )}{ | r - R_C | }$.
!
!
! and gives back the Taylor expansion of the exponential in integral_taylor
END_DOC
implicit none
integer, intent(in) :: n_taylor ! order of the Taylor expansion of the exponential
double precision, intent(in) :: zeta ! prefactor of the argument of the exp(-zeta*x)
double precision, intent(in) :: D_center(3), gam ! pure Slater "D" in r-r_D
double precision, intent(in) :: delta ! gaussian in r-r_D
double precision, intent(in) :: C_center(3),mu ! coulomb center "C" and "mu" in the erf(mu*x)/x function
double precision, intent(in) :: A_center(3),B_center(3),alpha,beta ! gaussian/polynoms "A" and "B"
integer, intent(in) :: power_A(3),power_B(3)
double precision, intent(out) :: array_ints(0:n_taylor),integral_taylor
integer :: i,dim1
double precision :: delta_exp,gam_exp,NAI_pol_mult_erf,erf_mu_stg_gauss_int_phi_ij
dim1=100
array_ints(0) = NAI_pol_mult_erf(A_center,B_center,power_A,power_B,alpha,beta,C_center,n_pt_max_integrals,mu)
integral_taylor = array_ints(0)
do i = 1, n_taylor
delta_exp = dble(i) * delta
gam_exp = dble(i) * gam
array_ints(i) = erf_mu_stg_gauss_int_phi_ij(D_center,gam_exp,delta_exp,A_center,B_center,power_A,power_B,alpha,beta,C_center,mu)
integral_taylor += (-zeta)**dble(i) * fact_inv(i) * array_ints(i)
enddo
end

343
src/ao_many_one_e_ints/xyz_grad_xyz_ao_pol.irp.f Normal file
View File

@ -0,0 +1,343 @@
BEGIN_PROVIDER [double precision, coef_xyz_ao, (2,3,ao_num)]
&BEGIN_PROVIDER [integer, power_xyz_ao, (2,3,ao_num)]
implicit none
BEGIN_DOC
! coefficient for the basis function :: (x * phi_i(r), y * phi_i(r), * z_phi(r))
!
! x * (x - A_x)^a_x = A_x (x - A_x)^a_x + 1 * (x - A_x)^{a_x+1}
END_DOC
integer :: i,j,k,num_ao,power_ao(1:3)
double precision :: center_ao(1:3)
do i = 1, ao_num
power_ao(1:3)= ao_power(i,1:3)
num_ao = ao_nucl(i)
center_ao(1:3) = nucl_coord(num_ao,1:3)
do j = 1, 3
coef_xyz_ao(1,j,i) = center_ao(j) ! A_x (x - A_x)^a_x
power_xyz_ao(1,j,i)= power_ao(j)
coef_xyz_ao(2,j,i) = 1.d0 ! 1 * (x - A_x)^a_{x+1}
power_xyz_ao(2,j,i)= power_ao(j) + 1
enddo
enddo
END_PROVIDER
BEGIN_PROVIDER [ double precision, ao_coef_ord_grad_transp, (2,3,ao_prim_num_max,ao_num) ]
&BEGIN_PROVIDER [ integer, power_ord_grad_transp, (2,3,ao_num) ]
implicit none
BEGIN_DOC
! grad AO in terms of polynoms and coefficients
!
! WARNING !!!! SOME polynoms might be negative !!!!!
!
! WHEN IT IS THE CASE, coefficients are ZERO
END_DOC
integer :: i,j,power_ao(3), m,kk
do j=1, ao_num
power_ao(1:3)= ao_power(j,1:3)
do m = 1, 3
power_ord_grad_transp(1,m,j) = power_ao(m) - 1
power_ord_grad_transp(2,m,j) = power_ao(m) + 1
enddo
do i=1, ao_prim_num_max
do m = 1, 3
ao_coef_ord_grad_transp(1,m,i,j) = ao_coef_normalized_ordered(j,i) * dble(power_ao(m)) ! a_x * c_i
ao_coef_ord_grad_transp(2,m,i,j) = -2.d0 * ao_coef_normalized_ordered(j,i) * ao_expo_ordered_transp(i,j) ! -2 * c_i * alpha_i
do kk = 1, 2
if(power_ord_grad_transp(kk,m,j).lt.0)then
ao_coef_ord_grad_transp(kk,m,i,j) = 0.d0
endif
enddo
enddo
enddo
enddo
END_PROVIDER
BEGIN_PROVIDER [ double precision, ao_coef_ord_xyz_grad_transp, (4,3,ao_prim_num_max,ao_num) ]
&BEGIN_PROVIDER [ integer, power_ord_xyz_grad_transp, (4,3,ao_num) ]
implicit none
BEGIN_DOC
! x * d/dx of an AO in terms of polynoms and coefficients
!
! WARNING !!!! SOME polynoms might be negative !!!!!
!
! WHEN IT IS THE CASE, coefficients are ZERO
END_DOC
integer :: i,j,power_ao(3), m,num_ao,kk
double precision :: center_ao(1:3)
do j=1, ao_num
power_ao(1:3)= ao_power(j,1:3)
num_ao = ao_nucl(j)
center_ao(1:3) = nucl_coord(num_ao,1:3)
do m = 1, 3
power_ord_xyz_grad_transp(1,m,j) = power_ao(m) - 1
power_ord_xyz_grad_transp(2,m,j) = power_ao(m)
power_ord_xyz_grad_transp(3,m,j) = power_ao(m) + 1
power_ord_xyz_grad_transp(4,m,j) = power_ao(m) + 2
do kk = 1, 4
if(power_ord_xyz_grad_transp(kk,m,j).lt.0)then
power_ord_xyz_grad_transp(kk,m,j) = -1
endif
enddo
enddo
do i=1, ao_prim_num_max
do m = 1, 3
ao_coef_ord_xyz_grad_transp(1,m,i,j) = dble(power_ao(m)) * ao_coef_normalized_ordered(j,i) * center_ao(m)
ao_coef_ord_xyz_grad_transp(2,m,i,j) = dble(power_ao(m)) * ao_coef_normalized_ordered(j,i)
ao_coef_ord_xyz_grad_transp(3,m,i,j) = -2.d0 * ao_coef_normalized_ordered(j,i) * ao_expo_ordered_transp(i,j) * center_ao(m)
ao_coef_ord_xyz_grad_transp(4,m,i,j) = -2.d0 * ao_coef_normalized_ordered(j,i) * ao_expo_ordered_transp(i,j)
do kk = 1, 4
if(power_ord_xyz_grad_transp(kk,m,j).lt.0)then
ao_coef_ord_xyz_grad_transp(kk,m,i,j) = 0.d0
endif
enddo
enddo
enddo
enddo
END_PROVIDER
subroutine xyz_grad_phi_ao(r,i_ao,xyz_grad_phi)
implicit none
integer, intent(in) :: i_ao
double precision, intent(in) :: r(3)
double precision, intent(out):: xyz_grad_phi(3) ! x * d/dx phi i, y * d/dy phi_i, z * d/dz phi_
double precision :: center_ao(3),beta
double precision :: accu(3,4),dr(3),r2,pol_usual(3)
integer :: m,power_ao(3),num_ao,j_prim
power_ao(1:3)= ao_power(i_ao,1:3)
num_ao = ao_nucl(i_ao)
center_ao(1:3) = nucl_coord(num_ao,1:3)
dr(1) = (r(1) - center_ao(1))
dr(2) = (r(2) - center_ao(2))
dr(3) = (r(3) - center_ao(3))
r2 = 0.d0
do m = 1, 3
r2 += dr(m)*dr(m)
enddo
! computes the gaussian part
accu = 0.d0
do j_prim =1,ao_prim_num(i_ao)
beta = ao_expo_ordered_transp(j_prim,i_ao)
if(dabs(beta*r2).gt.50.d0)cycle
do m = 1, 3
accu(m,1) += ao_coef_ord_xyz_grad_transp(1,m,j_prim,i_ao) * dexp(-beta*r2)
accu(m,2) += ao_coef_ord_xyz_grad_transp(2,m,j_prim,i_ao) * dexp(-beta*r2)
accu(m,3) += ao_coef_ord_xyz_grad_transp(3,m,j_prim,i_ao) * dexp(-beta*r2)
accu(m,4) += ao_coef_ord_xyz_grad_transp(4,m,j_prim,i_ao) * dexp(-beta*r2)
enddo
enddo
! computes the polynom part
pol_usual = 0.d0
pol_usual(1) = dr(2)**dble(power_ao(2)) * dr(3)**dble(power_ao(3))
pol_usual(2) = dr(1)**dble(power_ao(1)) * dr(3)**dble(power_ao(3))
pol_usual(3) = dr(1)**dble(power_ao(1)) * dr(2)**dble(power_ao(2))
xyz_grad_phi = 0.d0
do m = 1, 3
xyz_grad_phi(m) += accu(m,2) * pol_usual(m) * dr(m)**dble(power_ord_xyz_grad_transp(2,m,i_ao))
xyz_grad_phi(m) += accu(m,3) * pol_usual(m) * dr(m)**dble(power_ord_xyz_grad_transp(3,m,i_ao))
xyz_grad_phi(m) += accu(m,4) * pol_usual(m) * dr(m)**dble(power_ord_xyz_grad_transp(4,m,i_ao))
if(power_ord_xyz_grad_transp(1,m,i_ao).lt.0)cycle
xyz_grad_phi(m) += accu(m,1) * pol_usual(m) * dr(m)**dble(power_ord_xyz_grad_transp(1,m,i_ao))
enddo
end
subroutine grad_phi_ao(r,i_ao,grad_xyz_phi)
implicit none
integer, intent(in) :: i_ao
double precision, intent(in) :: r(3)
double precision, intent(out):: grad_xyz_phi(3) ! x * phi i, y * phi_i, z * phi_
double precision :: center_ao(3),beta
double precision :: accu(3,2),dr(3),r2,pol_usual(3)
integer :: m,power_ao(3),num_ao,j_prim
power_ao(1:3)= ao_power(i_ao,1:3)
num_ao = ao_nucl(i_ao)
center_ao(1:3) = nucl_coord(num_ao,1:3)
dr(1) = (r(1) - center_ao(1))
dr(2) = (r(2) - center_ao(2))
dr(3) = (r(3) - center_ao(3))
r2 = 0.d0
do m = 1, 3
r2 += dr(m)*dr(m)
enddo
! computes the gaussian part
accu = 0.d0
do j_prim =1,ao_prim_num(i_ao)
beta = ao_expo_ordered_transp(j_prim,i_ao)
if(dabs(beta*r2).gt.50.d0)cycle
do m = 1, 3
accu(m,1) += ao_coef_ord_grad_transp(1,m,j_prim,i_ao) * dexp(-beta*r2)
accu(m,2) += ao_coef_ord_grad_transp(2,m,j_prim,i_ao) * dexp(-beta*r2)
enddo
enddo
! computes the polynom part
pol_usual = 0.d0
pol_usual(1) = dr(2)**dble(power_ao(2)) * dr(3)**dble(power_ao(3))
pol_usual(2) = dr(1)**dble(power_ao(1)) * dr(3)**dble(power_ao(3))
pol_usual(3) = dr(1)**dble(power_ao(1)) * dr(2)**dble(power_ao(2))
do m = 1, 3
grad_xyz_phi(m) = accu(m,2) * pol_usual(m) * dr(m)**dble(power_ord_grad_transp(2,m,i_ao))
if(power_ao(m)==0)cycle
grad_xyz_phi(m) += accu(m,1) * pol_usual(m) * dr(m)**dble(power_ord_grad_transp(1,m,i_ao))
enddo
end
subroutine xyz_phi_ao(r,i_ao,xyz_phi)
implicit none
integer, intent(in) :: i_ao
double precision, intent(in) :: r(3)
double precision, intent(out):: xyz_phi(3) ! x * phi i, y * phi_i, z * phi_i
double precision :: center_ao(3),beta
double precision :: accu,dr(3),r2,pol_usual(3)
integer :: m,power_ao(3),num_ao
power_ao(1:3)= ao_power(i_ao,1:3)
num_ao = ao_nucl(i_ao)
center_ao(1:3) = nucl_coord(num_ao,1:3)
dr(1) = (r(1) - center_ao(1))
dr(2) = (r(2) - center_ao(2))
dr(3) = (r(3) - center_ao(3))
r2 = 0.d0
do m = 1, 3
r2 += dr(m)*dr(m)
enddo
! computes the gaussian part
accu = 0.d0
do m=1,ao_prim_num(i_ao)
beta = ao_expo_ordered_transp(m,i_ao)
if(dabs(beta*r2).gt.50.d0)cycle
accu += ao_coef_normalized_ordered_transp(m,i_ao) * dexp(-beta*r2)
enddo
! computes the polynom part
pol_usual = 0.d0
pol_usual(1) = dr(2)**dble(power_ao(2)) * dr(3)**dble(power_ao(3))
pol_usual(2) = dr(1)**dble(power_ao(1)) * dr(3)**dble(power_ao(3))
pol_usual(3) = dr(1)**dble(power_ao(1)) * dr(2)**dble(power_ao(2))
do m = 1, 3
xyz_phi(m) = accu * pol_usual(m) * dr(m)**(dble(power_ao(m))) * ( coef_xyz_ao(1,m,i_ao) + coef_xyz_ao(2,m,i_ao) * dr(m) )
enddo
end
subroutine test_pol_xyz
implicit none
integer :: ipoint,i,j,m,jpoint
double precision :: r1(3),derf_mu_x
double precision :: weight1,r12,xyz_phi(3),grad_phi(3),xyz_grad_phi(3)
double precision, allocatable :: aos_array(:),aos_grad_array(:,:)
double precision :: num_xyz_phi(3),num_grad_phi(3),num_xyz_grad_phi(3)
double precision :: accu_xyz_phi(3),accu_grad_phi(3),accu_xyz_grad_phi(3)
double precision :: meta_accu_xyz_phi(3),meta_accu_grad_phi(3),meta_accu_xyz_grad_phi(3)
allocate(aos_array(ao_num),aos_grad_array(3,ao_num))
meta_accu_xyz_phi = 0.d0
meta_accu_grad_phi = 0.d0
meta_accu_xyz_grad_phi= 0.d0
do i = 1, ao_num
accu_xyz_phi = 0.d0
accu_grad_phi = 0.d0
accu_xyz_grad_phi= 0.d0
do ipoint = 1, n_points_final_grid
r1(:) = final_grid_points(:,ipoint)
weight1 = final_weight_at_r_vector(ipoint)
call give_all_aos_and_grad_at_r(r1,aos_array,aos_grad_array)
do m = 1, 3
num_xyz_phi(m) = r1(m) * aos_array(i)
num_grad_phi(m) = aos_grad_array(m,i)
num_xyz_grad_phi(m) = r1(m) * aos_grad_array(m,i)
enddo
call xyz_phi_ao(r1,i,xyz_phi)
call grad_phi_ao(r1,i,grad_phi)
call xyz_grad_phi_ao(r1,i,xyz_grad_phi)
do m = 1, 3
accu_xyz_phi(m) += weight1 * dabs(num_xyz_phi(m) - xyz_phi(m) )
accu_grad_phi(m) += weight1 * dabs(num_grad_phi(m) - grad_phi(m) )
accu_xyz_grad_phi(m) += weight1 * dabs(num_xyz_grad_phi(m) - xyz_grad_phi(m))
enddo
enddo
print*,''
print*,''
print*,'i,',i
print*,''
do m = 1, 3
! print*, 'm, accu_xyz_phi(m) ' ,m, accu_xyz_phi(m)
! print*, 'm, accu_grad_phi(m) ' ,m, accu_grad_phi(m)
print*, 'm, accu_xyz_grad_phi' ,m, accu_xyz_grad_phi(m)
enddo
do m = 1, 3
meta_accu_xyz_phi(m) += dabs(accu_xyz_phi(m))
meta_accu_grad_phi(m) += dabs(accu_grad_phi(m))
meta_accu_xyz_grad_phi(m) += dabs(accu_xyz_grad_phi(m))
enddo
enddo
do m = 1, 3
! print*, 'm, meta_accu_xyz_phi(m) ' ,m, meta_accu_xyz_phi(m)
! print*, 'm, meta_accu_grad_phi(m) ' ,m, meta_accu_grad_phi(m)
print*, 'm, meta_accu_xyz_grad_phi' ,m, meta_accu_xyz_grad_phi(m)
enddo
end
subroutine test_ints_semi_bis
implicit none
integer :: ipoint,i,j,m
double precision :: r1(3), aos_grad_array_r1(3, ao_num), aos_array_r1(ao_num)
double precision :: C_center(3), weight1,mu_in,r12,derf_mu_x,dxyz_ints(3),NAI_pol_mult_erf_ao
double precision :: ao_mat(ao_num,ao_num),ao_xmat(3,ao_num,ao_num),accu1, accu2(3)
mu_in = 0.5d0
C_center = 0.d0
C_center(1) = 0.25d0
C_center(3) = 1.12d0
C_center(2) = -1.d0
ao_mat = 0.d0
ao_xmat = 0.d0
do ipoint = 1, n_points_final_grid
r1(1) = final_grid_points(1,ipoint)
r1(2) = final_grid_points(2,ipoint)
r1(3) = final_grid_points(3,ipoint)
call give_all_aos_and_grad_at_r(r1,aos_array_r1,aos_grad_array_r1)
weight1 = final_weight_at_r_vector(ipoint)
r12 = (r1(1) - C_center(1))**2.d0 + (r1(2) - C_center(2))**2.d0 + (r1(3) - C_center(3))**2.d0
r12 = dsqrt(r12)
do i = 1, ao_num
do j = 1, ao_num
ao_mat(j,i) += aos_array_r1(i) * aos_array_r1(j) * weight1 * derf_mu_x(mu_in,r12)
do m = 1, 3
ao_xmat(m,j,i) += r1(m) * aos_array_r1(j) * aos_grad_array_r1(m,i) * weight1 * derf_mu_x(mu_in,r12)
enddo
enddo
enddo
enddo
accu1 = 0.d0
accu2 = 0.d0
accu1relat = 0.d0
accu2relat = 0.d0
double precision :: accu1relat, accu2relat(3)
double precision :: contrib(3)
do i = 1, ao_num
do j = 1, ao_num
call phi_j_erf_mu_r_xyz_dxyz_phi(i,j,mu_in, C_center, dxyz_ints)
print*,''
print*,'i,j',i,j
print*,dxyz_ints(:)
print*,ao_xmat(:,j,i)
do m = 1, 3
contrib(m) = dabs(ao_xmat(m,j,i) - dxyz_ints(m))
accu2(m) += contrib(m)
if(dabs(ao_xmat(m,j,i)).gt.1.d-10)then
accu2relat(m) += dabs(ao_xmat(m,j,i) - dxyz_ints(m))/dabs(ao_xmat(m,j,i))
endif
enddo
print*,contrib
enddo
print*,''
enddo
print*,'accu2relat = '
print*, accu2relat /dble(ao_num * ao_num)
end

1
src/ao_one_e_ints/NEED
View File

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

184
src/ao_one_e_ints/ao_overlap.irp.f
View File

@ -1,75 +1,99 @@
BEGIN_PROVIDER [ double precision, ao_overlap,(ao_num,ao_num) ]
&BEGIN_PROVIDER [ double precision, ao_overlap_x,(ao_num,ao_num) ]
&BEGIN_PROVIDER [ double precision, ao_overlap_y,(ao_num,ao_num) ]
&BEGIN_PROVIDER [ double precision, ao_overlap_z,(ao_num,ao_num) ]
implicit none
! ---
BEGIN_PROVIDER [ double precision, ao_overlap , (ao_num, ao_num) ]
&BEGIN_PROVIDER [ double precision, ao_overlap_x, (ao_num, ao_num) ]
&BEGIN_PROVIDER [ double precision, ao_overlap_y, (ao_num, ao_num) ]
&BEGIN_PROVIDER [ double precision, ao_overlap_z, (ao_num, ao_num) ]
BEGIN_DOC
! Overlap between atomic basis functions:
!
! :math:`\int \chi_i(r) \chi_j(r) dr`
! Overlap between atomic basis functions:
!
! :math:`\int \chi_i(r) \chi_j(r) dr`
END_DOC
integer :: i,j,n,l
double precision :: f
integer :: dim1
implicit none
integer :: i, j, n, l, dim1, power_A(3), power_B(3)
double precision :: overlap, overlap_x, overlap_y, overlap_z
double precision :: alpha, beta, c
double precision :: A_center(3), B_center(3)
integer :: power_A(3), power_B(3)
ao_overlap = 0.d0
ao_overlap = 0.d0
ao_overlap_x = 0.d0
ao_overlap_y = 0.d0
ao_overlap_z = 0.d0
if (read_ao_integrals_overlap) then
call ezfio_get_ao_one_e_ints_ao_integrals_overlap(ao_overlap(1:ao_num, 1:ao_num))
print *, 'AO overlap integrals read from disk'
if(read_ao_integrals_overlap) then
call ezfio_get_ao_one_e_ints_ao_integrals_overlap(ao_overlap(1:ao_num, 1:ao_num))
print *, 'AO overlap integrals read from disk'
else
dim1=100
!$OMP PARALLEL DO SCHEDULE(GUIDED) &
!$OMP DEFAULT(NONE) &
!$OMP PRIVATE(A_center,B_center,power_A,power_B,&
!$OMP overlap_x,overlap_y, overlap_z, overlap, &
!$OMP alpha, beta,i,j,c) &
!$OMP SHARED(nucl_coord,ao_power,ao_prim_num, &
!$OMP ao_overlap_x,ao_overlap_y,ao_overlap_z,ao_overlap,ao_num,ao_coef_normalized_ordered_transp,ao_nucl, &
!$OMP ao_expo_ordered_transp,dim1)
do j=1,ao_num
A_center(1) = nucl_coord( ao_nucl(j), 1 )
A_center(2) = nucl_coord( ao_nucl(j), 2 )
A_center(3) = nucl_coord( ao_nucl(j), 3 )
power_A(1) = ao_power( j, 1 )
power_A(2) = ao_power( j, 2 )
power_A(3) = ao_power( j, 3 )
do i= 1,ao_num
B_center(1) = nucl_coord( ao_nucl(i), 1 )
B_center(2) = nucl_coord( ao_nucl(i), 2 )
B_center(3) = nucl_coord( ao_nucl(i), 3 )
power_B(1) = ao_power( i, 1 )
power_B(2) = ao_power( i, 2 )
power_B(3) = ao_power( i, 3 )
do n = 1,ao_prim_num(j)
alpha = ao_expo_ordered_transp(n,j)
do l = 1, ao_prim_num(i)
beta = ao_expo_ordered_transp(l,i)
call overlap_gaussian_xyz(A_center,B_center,alpha,beta,power_A,power_B,overlap_x,overlap_y,overlap_z,overlap,dim1)
c = ao_coef_normalized_ordered_transp(n,j) * ao_coef_normalized_ordered_transp(l,i)
ao_overlap(i,j) += c * overlap
if(isnan(ao_overlap(i,j)))then
print*,'i,j',i,j
print*,'l,n',l,n
print*,'c,overlap',c,overlap
print*,overlap_x,overlap_y,overlap_z
stop
endif
ao_overlap_x(i,j) += c * overlap_x
ao_overlap_y(i,j) += c * overlap_y
ao_overlap_z(i,j) += c * overlap_z
if(use_cosgtos) then
!print*, ' use_cosgtos for ao_overlap ?', use_cosgtos
do j = 1, ao_num
do i = 1, ao_num
ao_overlap (i,j) = ao_overlap_cosgtos (i,j)
ao_overlap_x(i,j) = ao_overlap_cosgtos_x(i,j)
ao_overlap_y(i,j) = ao_overlap_cosgtos_y(i,j)
ao_overlap_z(i,j) = ao_overlap_cosgtos_z(i,j)
enddo
enddo
else
dim1=100
!$OMP PARALLEL DO SCHEDULE(GUIDED) &
!$OMP DEFAULT(NONE) &
!$OMP PRIVATE(A_center,B_center,power_A,power_B,&
!$OMP overlap_x,overlap_y, overlap_z, overlap, &
!$OMP alpha, beta,i,j,c) &
!$OMP SHARED(nucl_coord,ao_power,ao_prim_num, &
!$OMP ao_overlap_x,ao_overlap_y,ao_overlap_z,ao_overlap,ao_num,ao_coef_normalized_ordered_transp,ao_nucl, &
!$OMP ao_expo_ordered_transp,dim1)
do j=1,ao_num
A_center(1) = nucl_coord( ao_nucl(j), 1 )
A_center(2) = nucl_coord( ao_nucl(j), 2 )
A_center(3) = nucl_coord( ao_nucl(j), 3 )
power_A(1) = ao_power( j, 1 )
power_A(2) = ao_power( j, 2 )
power_A(3) = ao_power( j, 3 )
do i= 1,ao_num
B_center(1) = nucl_coord( ao_nucl(i), 1 )
B_center(2) = nucl_coord( ao_nucl(i), 2 )
B_center(3) = nucl_coord( ao_nucl(i), 3 )
power_B(1) = ao_power( i, 1 )
power_B(2) = ao_power( i, 2 )
power_B(3) = ao_power( i, 3 )
do n = 1,ao_prim_num(j)
alpha = ao_expo_ordered_transp(n,j)
do l = 1, ao_prim_num(i)
beta = ao_expo_ordered_transp(l,i)
call overlap_gaussian_xyz(A_center,B_center,alpha,beta,power_A,power_B,overlap_x,overlap_y,overlap_z,overlap,dim1)
c = ao_coef_normalized_ordered_transp(n,j) * ao_coef_normalized_ordered_transp(l,i)
ao_overlap(i,j) += c * overlap
if(isnan(ao_overlap(i,j)))then
print*,'i,j',i,j
print*,'l,n',l,n
print*,'c,overlap',c,overlap
print*,overlap_x,overlap_y,overlap_z
stop
endif
ao_overlap_x(i,j) += c * overlap_x
ao_overlap_y(i,j) += c * overlap_y
ao_overlap_z(i,j) += c * overlap_z
enddo
enddo
enddo
enddo
enddo
enddo
!$OMP END PARALLEL DO
!$OMP END PARALLEL DO
endif
endif
if (write_ao_integrals_overlap) then
call ezfio_set_ao_one_e_ints_ao_integrals_overlap(ao_overlap(1:ao_num, 1:ao_num))
print *, 'AO overlap integrals written to disk'
@ -77,6 +101,8 @@
END_PROVIDER
! ---
BEGIN_PROVIDER [ double precision, ao_overlap_imag, (ao_num, ao_num) ]
implicit none
BEGIN_DOC
@ -85,6 +111,8 @@ BEGIN_PROVIDER [ double precision, ao_overlap_imag, (ao_num, ao_num) ]
ao_overlap_imag = 0.d0
END_PROVIDER
! ---
BEGIN_PROVIDER [ complex*16, ao_overlap_complex, (ao_num, ao_num) ]
implicit none
BEGIN_DOC
@ -98,37 +126,39 @@ BEGIN_PROVIDER [ complex*16, ao_overlap_complex, (ao_num, ao_num) ]
enddo
END_PROVIDER
! ---
BEGIN_PROVIDER [ double precision, ao_overlap_abs, (ao_num, ao_num) ]
BEGIN_PROVIDER [ double precision, ao_overlap_abs,(ao_num,ao_num) ]
implicit none
BEGIN_DOC
! Overlap between absolute values of atomic basis functions:
!
! :math:`\int |\chi_i(r)| |\chi_j(r)| dr`
! Overlap between absolute values of atomic basis functions:
!
! :math:`\int |\chi_i(r)| |\chi_j(r)| dr`
END_DOC
integer :: i,j,n,l
double precision :: f
integer :: dim1
double precision :: overlap, overlap_x, overlap_y, overlap_z
implicit none
integer :: i, j, n, l, dim1, power_A(3), power_B(3)
double precision :: overlap_x, overlap_y, overlap_z
double precision :: alpha, beta
double precision :: A_center(3), B_center(3)
integer :: power_A(3), power_B(3)
double precision :: lower_exp_val, dx
if (is_periodic) then
do j=1,ao_num
do i= 1,ao_num
ao_overlap_abs(i,j)= cdabs(ao_overlap_complex(i,j))
if(is_periodic) then
do j = 1, ao_num
do i = 1, ao_num
ao_overlap_abs(i,j) = cdabs(ao_overlap_complex(i,j))
enddo
enddo
else
dim1=100
lower_exp_val = 40.d0
!$OMP PARALLEL DO SCHEDULE(GUIDED) &
!$OMP DEFAULT(NONE) &
!$OMP PRIVATE(A_center,B_center,power_A,power_B, &
!$OMP overlap_x,overlap_y, overlap_z, overlap, &
!$OMP overlap_x,overlap_y, overlap_z, &
!$OMP alpha, beta,i,j,dx) &
!$OMP SHARED(nucl_coord,ao_power,ao_prim_num, &
!$OMP ao_overlap_abs,ao_num,ao_coef_normalized_ordered_transp,ao_nucl,&
@ -161,9 +191,13 @@ BEGIN_PROVIDER [ double precision, ao_overlap_abs,(ao_num,ao_num) ]
enddo
enddo
!$OMP END PARALLEL DO
endif
END_PROVIDER
! ---
BEGIN_PROVIDER [ double precision, S_inv,(ao_num,ao_num) ]
implicit none
BEGIN_DOC

206
src/ao_one_e_ints/kin_ao_ints.irp.f
View File

@ -1,7 +1,10 @@
BEGIN_PROVIDER [ double precision, ao_deriv2_x,(ao_num,ao_num) ]
&BEGIN_PROVIDER [ double precision, ao_deriv2_y,(ao_num,ao_num) ]
&BEGIN_PROVIDER [ double precision, ao_deriv2_z,(ao_num,ao_num) ]
implicit none
! ---
BEGIN_PROVIDER [ double precision, ao_deriv2_x, (ao_num, ao_num) ]
&BEGIN_PROVIDER [ double precision, ao_deriv2_y, (ao_num, ao_num) ]
&BEGIN_PROVIDER [ double precision, ao_deriv2_z, (ao_num, ao_num) ]
BEGIN_DOC
! Second derivative matrix elements in the |AO| basis.
!
@ -11,114 +14,131 @@
! \langle \chi_i(x,y,z) | \frac{\partial^2}{\partial x^2} |\chi_j (x,y,z) \rangle
!
END_DOC
integer :: i,j,n,l
double precision :: f
integer :: dim1
implicit none
integer :: i, j, n, l, dim1, power_A(3), power_B(3)
double precision :: overlap, overlap_y, overlap_z
double precision :: overlap_x0, overlap_y0, overlap_z0
double precision :: alpha, beta, c
double precision :: A_center(3), B_center(3)
integer :: power_A(3), power_B(3)
double precision :: d_a_2,d_2
dim1=100
! -- Dummy call to provide everything
A_center(:) = 0.d0
B_center(:) = 1.d0
alpha = 1.d0
beta = .1d0
power_A = 1
power_B = 0
call overlap_gaussian_xyz(A_center,B_center,alpha,beta,power_A,power_B,overlap_y,d_a_2,overlap_z,overlap,dim1)
! --
if(use_cosgtos) then
!print*, 'use_cosgtos for ao_kinetic_integrals ?', use_cosgtos
!$OMP PARALLEL DO SCHEDULE(GUIDED) &
!$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 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, &
!$OMP ao_expo_ordered_transp,dim1)
do j=1,ao_num
A_center(1) = nucl_coord( ao_nucl(j), 1 )
A_center(2) = nucl_coord( ao_nucl(j), 2 )
A_center(3) = nucl_coord( ao_nucl(j), 3 )
power_A(1) = ao_power( j, 1 )
power_A(2) = ao_power( j, 2 )
power_A(3) = ao_power( j, 3 )
do i= 1,ao_num
ao_deriv2_x(i,j)= 0.d0
ao_deriv2_y(i,j)= 0.d0
ao_deriv2_z(i,j)= 0.d0
B_center(1) = nucl_coord( ao_nucl(i), 1 )
B_center(2) = nucl_coord( ao_nucl(i), 2 )
B_center(3) = nucl_coord( ao_nucl(i), 3 )
power_B(1) = ao_power( i, 1 )
power_B(2) = ao_power( i, 2 )
power_B(3) = ao_power( i, 3 )
do n = 1,ao_prim_num(j)
alpha = ao_expo_ordered_transp(n,j)
do l = 1, ao_prim_num(i)
beta = ao_expo_ordered_transp(l,i)
call overlap_gaussian_xyz(A_center,B_center,alpha,beta,power_A,power_B,overlap_x0,overlap_y0,overlap_z0,overlap,dim1)
c = ao_coef_normalized_ordered_transp(n,j) * ao_coef_normalized_ordered_transp(l,i)
do j = 1, ao_num
do i = 1, ao_num
ao_deriv2_x(i,j) = ao_deriv2_cosgtos_x(i,j)
ao_deriv2_y(i,j) = ao_deriv2_cosgtos_y(i,j)
ao_deriv2_z(i,j) = ao_deriv2_cosgtos_z(i,j)
enddo
enddo
power_A(1) = power_A(1)-2
if (power_A(1)>-1) then
call overlap_gaussian_xyz(A_center,B_center,alpha,beta,power_A,power_B,d_a_2,overlap_y,overlap_z,overlap,dim1)
else
d_a_2 = 0.d0
endif
power_A(1) = power_A(1)+4
call overlap_gaussian_xyz(A_center,B_center,alpha,beta,power_A,power_B,d_2,overlap_y,overlap_z,overlap,dim1)
power_A(1) = power_A(1)-2
else
double precision :: deriv_tmp
deriv_tmp = (-2.d0 * alpha * (2.d0 * power_A(1) +1.d0) * overlap_x0 &
+power_A(1) * (power_A(1)-1.d0) * d_a_2 &
+4.d0 * alpha * alpha * d_2 )*overlap_y0*overlap_z0
dim1=100
ao_deriv2_x(i,j) += c*deriv_tmp
power_A(2) = power_A(2)-2
if (power_A(2)>-1) then
call overlap_gaussian_xyz(A_center,B_center,alpha,beta,power_A,power_B,overlap_y,d_a_2,overlap_z,overlap,dim1)
else
d_a_2 = 0.d0
endif
power_A(2) = power_A(2)+4
call overlap_gaussian_xyz(A_center,B_center,alpha,beta,power_A,power_B,overlap_y,d_2,overlap_z,overlap,dim1)
power_A(2) = power_A(2)-2
! -- Dummy call to provide everything
A_center(:) = 0.d0
B_center(:) = 1.d0
alpha = 1.d0
beta = .1d0
power_A = 1
power_B = 0
call overlap_gaussian_xyz(A_center,B_center,alpha,beta,power_A,power_B,overlap_y,d_a_2,overlap_z,overlap,dim1)
! --
deriv_tmp = (-2.d0 * alpha * (2.d0 * power_A(2) +1.d0 ) * overlap_y0 &
+power_A(2) * (power_A(2)-1.d0) * d_a_2 &
+4.d0 * alpha * alpha * d_2 )*overlap_x0*overlap_z0
ao_deriv2_y(i,j) += c*deriv_tmp
!$OMP PARALLEL DO SCHEDULE(GUIDED) &
!$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 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, &
!$OMP ao_expo_ordered_transp,dim1)
do j=1,ao_num
A_center(1) = nucl_coord( ao_nucl(j), 1 )
A_center(2) = nucl_coord( ao_nucl(j), 2 )
A_center(3) = nucl_coord( ao_nucl(j), 3 )
power_A(1) = ao_power( j, 1 )
power_A(2) = ao_power( j, 2 )
power_A(3) = ao_power( j, 3 )
do i= 1,ao_num
ao_deriv2_x(i,j)= 0.d0
ao_deriv2_y(i,j)= 0.d0
ao_deriv2_z(i,j)= 0.d0
B_center(1) = nucl_coord( ao_nucl(i), 1 )
B_center(2) = nucl_coord( ao_nucl(i), 2 )
B_center(3) = nucl_coord( ao_nucl(i), 3 )
power_B(1) = ao_power( i, 1 )
power_B(2) = ao_power( i, 2 )
power_B(3) = ao_power( i, 3 )
do n = 1,ao_prim_num(j)
alpha = ao_expo_ordered_transp(n,j)
do l = 1, ao_prim_num(i)
beta = ao_expo_ordered_transp(l,i)
call overlap_gaussian_xyz(A_center,B_center,alpha,beta,power_A,power_B,overlap_x0,overlap_y0,overlap_z0,overlap,dim1)
c = ao_coef_normalized_ordered_transp(n,j) * ao_coef_normalized_ordered_transp(l,i)
power_A(3) = power_A(3)-2
if (power_A(3)>-1) then
call overlap_gaussian_xyz(A_center,B_center,alpha,beta,power_A,power_B,overlap_y,overlap_z,d_a_2,overlap,dim1)
else
d_a_2 = 0.d0
endif
power_A(3) = power_A(3)+4
call overlap_gaussian_xyz(A_center,B_center,alpha,beta,power_A,power_B,overlap_y,overlap_z,d_2,overlap,dim1)
power_A(3) = power_A(3)-2
power_A(1) = power_A(1)-2
if (power_A(1)>-1) then
call overlap_gaussian_xyz(A_center,B_center,alpha,beta,power_A,power_B,d_a_2,overlap_y,overlap_z,overlap,dim1)
else
d_a_2 = 0.d0
endif
power_A(1) = power_A(1)+4
call overlap_gaussian_xyz(A_center,B_center,alpha,beta,power_A,power_B,d_2,overlap_y,overlap_z,overlap,dim1)
power_A(1) = power_A(1)-2
deriv_tmp = (-2.d0 * alpha * (2.d0 * power_A(3) +1.d0 ) * overlap_z0 &
+power_A(3) * (power_A(3)-1.d0) * d_a_2 &
+4.d0 * alpha * alpha * d_2 )*overlap_x0*overlap_y0
ao_deriv2_z(i,j) += c*deriv_tmp
double precision :: deriv_tmp
deriv_tmp = (-2.d0 * alpha * (2.d0 * power_A(1) +1.d0) * overlap_x0 &
+power_A(1) * (power_A(1)-1.d0) * d_a_2 &
+4.d0 * alpha * alpha * d_2 )*overlap_y0*overlap_z0
ao_deriv2_x(i,j) += c*deriv_tmp
power_A(2) = power_A(2)-2
if (power_A(2)>-1) then
call overlap_gaussian_xyz(A_center,B_center,alpha,beta,power_A,power_B,overlap_y,d_a_2,overlap_z,overlap,dim1)
else
d_a_2 = 0.d0
endif
power_A(2) = power_A(2)+4
call overlap_gaussian_xyz(A_center,B_center,alpha,beta,power_A,power_B,overlap_y,d_2,overlap_z,overlap,dim1)
power_A(2) = power_A(2)-2
deriv_tmp = (-2.d0 * alpha * (2.d0 * power_A(2) +1.d0 ) * overlap_y0 &
+power_A(2) * (power_A(2)-1.d0) * d_a_2 &
+4.d0 * alpha * alpha * d_2 )*overlap_x0*overlap_z0
ao_deriv2_y(i,j) += c*deriv_tmp
power_A(3) = power_A(3)-2
if (power_A(3)>-1) then
call overlap_gaussian_xyz(A_center,B_center,alpha,beta,power_A,power_B,overlap_y,overlap_z,d_a_2,overlap,dim1)
else
d_a_2 = 0.d0
endif
power_A(3) = power_A(3)+4
call overlap_gaussian_xyz(A_center,B_center,alpha,beta,power_A,power_B,overlap_y,overlap_z,d_2,overlap,dim1)
power_A(3) = power_A(3)-2
deriv_tmp = (-2.d0 * alpha * (2.d0 * power_A(3) +1.d0 ) * overlap_z0 &
+power_A(3) * (power_A(3)-1.d0) * d_a_2 &
+4.d0 * alpha * alpha * d_2 )*overlap_x0*overlap_y0
ao_deriv2_z(i,j) += c*deriv_tmp
enddo
enddo
enddo
enddo
enddo
enddo
!$OMP END PARALLEL DO
!$OMP END PARALLEL DO
endif
END_PROVIDER
! ---
BEGIN_PROVIDER [double precision, ao_kinetic_integrals, (ao_num,ao_num)]
implicit none
BEGIN_DOC

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

@ -1,4 +1,8 @@
! ---
BEGIN_PROVIDER [ double precision, ao_integrals_n_e, (ao_num,ao_num)]
BEGIN_DOC
! Nucleus-electron interaction, in the |AO| basis set.
!
@ -6,78 +10,103 @@ BEGIN_PROVIDER [ double precision, ao_integrals_n_e, (ao_num,ao_num)]
!
! These integrals also contain the pseudopotential integrals.
END_DOC
implicit none
double precision :: alpha, beta, gama, delta
integer :: num_A,num_B
double precision :: A_center(3),B_center(3),C_center(3)
integer :: power_A(3),power_B(3)
integer :: i,j,k,l,n_pt_in,m
double precision :: overlap_x,overlap_y,overlap_z,overlap,dx,NAI_pol_mult
integer :: num_A, num_B, power_A(3), power_B(3)
integer :: i, j, k, l, n_pt_in, m
double precision :: alpha, beta
double precision :: A_center(3),B_center(3),C_center(3)
double precision :: overlap_x,overlap_y,overlap_z,overlap,dx,NAI_pol_mult
if (read_ao_integrals_n_e) then
call ezfio_get_ao_one_e_ints_ao_integrals_n_e(ao_integrals_n_e)
print *, 'AO N-e integrals read from disk'
else
ao_integrals_n_e = 0.d0
if(use_cosgtos) then
!print *, " use_cosgtos for ao_integrals_n_e ?", use_cosgtos
! _
! /| / |_)
! | / | \
!
do j = 1, ao_num
do i = 1, ao_num
ao_integrals_n_e(i,j) = ao_integrals_n_e_cosgtos(i,j)
enddo
enddo
!$OMP PARALLEL &
!$OMP DEFAULT (NONE) &
!$OMP PRIVATE (i,j,k,l,m,alpha,beta,A_center,B_center,C_center,power_A,power_B,&
!$OMP num_A,num_B,Z,c,n_pt_in) &
!$OMP SHARED (ao_num,ao_prim_num,ao_expo_ordered_transp,ao_power,ao_nucl,nucl_coord,ao_coef_normalized_ordered_transp,&
!$OMP n_pt_max_integrals,ao_integrals_n_e,nucl_num,nucl_charge)
else
n_pt_in = n_pt_max_integrals
ao_integrals_n_e = 0.d0
!$OMP DO SCHEDULE (dynamic)
! _
! /| / |_)
! | / | \
!
do j = 1, ao_num
num_A = ao_nucl(j)
power_A(1:3)= ao_power(j,1:3)
A_center(1:3) = nucl_coord(num_A,1:3)
!$OMP PARALLEL &
!$OMP DEFAULT (NONE) &
!$OMP PRIVATE (i,j,k,l,m,alpha,beta,A_center,B_center,C_center,power_A,power_B,&
!$OMP num_A,num_B,Z,c,c1,n_pt_in) &
!$OMP SHARED (ao_num,ao_prim_num,ao_expo_ordered_transp,ao_power,ao_nucl,nucl_coord,ao_coef_normalized_ordered_transp,&
!$OMP n_pt_max_integrals,ao_integrals_n_e,nucl_num,nucl_charge)
do i = 1, ao_num
n_pt_in = n_pt_max_integrals
num_B = ao_nucl(i)
power_B(1:3)= ao_power(i,1:3)
B_center(1:3) = nucl_coord(num_B,1:3)
!$OMP DO SCHEDULE (dynamic)
do l=1,ao_prim_num(j)
alpha = ao_expo_ordered_transp(l,j)
do j = 1, ao_num
num_A = ao_nucl(j)
power_A(1:3)= ao_power(j,1:3)
A_center(1:3) = nucl_coord(num_A,1:3)
do m=1,ao_prim_num(i)
beta = ao_expo_ordered_transp(m,i)
do i = 1, ao_num
double precision :: c
c = 0.d0
num_B = ao_nucl(i)
power_B(1:3)= ao_power(i,1:3)
B_center(1:3) = nucl_coord(num_B,1:3)
do k = 1, nucl_num
double precision :: Z
Z = nucl_charge(k)
do l=1,ao_prim_num(j)
alpha = ao_expo_ordered_transp(l,j)
C_center(1:3) = nucl_coord(k,1:3)
do m=1,ao_prim_num(i)
beta = ao_expo_ordered_transp(m,i)
c = c - Z * NAI_pol_mult(A_center,B_center, &
power_A,power_B,alpha,beta,C_center,n_pt_in)
double precision :: c, c1
c = 0.d0
do k = 1, nucl_num
double precision :: Z
Z = nucl_charge(k)
C_center(1:3) = nucl_coord(k,1:3)
!print *, ' '
!print *, A_center, B_center, C_center, power_A, power_B
!print *, alpha, beta
c1 = NAI_pol_mult( A_center, B_center, power_A, power_B &
, alpha, beta, C_center, n_pt_in )
!print *, ' c1 = ', c1
c = c - Z * c1
enddo
ao_integrals_n_e(i,j) = ao_integrals_n_e(i,j) &
+ ao_coef_normalized_ordered_transp(l,j) &
* ao_coef_normalized_ordered_transp(m,i) * c
enddo
ao_integrals_n_e(i,j) = ao_integrals_n_e(i,j) &
+ ao_coef_normalized_ordered_transp(l,j) &
* ao_coef_normalized_ordered_transp(m,i) * c
enddo
enddo
enddo
enddo
!$OMP END DO
!$OMP END PARALLEL
IF (DO_PSEUDO) THEN
endif
IF(DO_PSEUDO) THEN
ao_integrals_n_e += ao_pseudo_integrals
ENDIF
@ -98,7 +127,7 @@ BEGIN_PROVIDER [ double precision, ao_integrals_n_e_imag, (ao_num,ao_num)]
! :math:`\langle \chi_i | -\sum_A \frac{1}{|r-R_A|} | \chi_j \rangle`
END_DOC
implicit none
double precision :: alpha, beta, gama, delta
double precision :: alpha, beta
integer :: num_A,num_B
double precision :: A_center(3),B_center(3),C_center(3)
integer :: power_A(3),power_B(3)
@ -121,7 +150,7 @@ BEGIN_PROVIDER [ double precision, ao_integrals_n_e_per_atom, (ao_num,ao_num,nuc
! :math:`\langle \chi_i | -\frac{1}{|r-R_A|} | \chi_j \rangle`
END_DOC
implicit none
double precision :: alpha, beta, gama, delta
double precision :: alpha, beta
integer :: i_c,num_A,num_B
double precision :: A_center(3),B_center(3),C_center(3)
integer :: power_A(3),power_B(3)
@ -259,11 +288,14 @@ double precision function NAI_pol_mult(A_center,B_center,power_A,power_B,alpha,b
! sum of integrals of type : int {t,[0,1]} exp-(rho.(P-Q)^2 * t^2) * t^i
do i =0 ,n_pt_out,2
accu += d(i) * rint(i/2,const)
! print *, i/2, const, d(i), rint(shiftr(i, 1), const)
enddo
NAI_pol_mult = accu * coeff
end
! ---
subroutine give_polynomial_mult_center_one_e(A_center,B_center,alpha,beta,power_A,power_B,C_center,n_pt_in,d,n_pt_out)
implicit none
@ -575,61 +607,3 @@ double precision function V_r(n,alpha)
end
double precision function V_phi(n,m)
implicit none
BEGIN_DOC
! Computes the angular $\phi$ part of the nuclear attraction integral:
!
! $\int_{0}^{2 \pi} \cos(\phi)^n \sin(\phi)^m d\phi$.
END_DOC
integer :: n,m, i
double precision :: prod, Wallis
prod = 1.d0
do i = 0,shiftr(n,1)-1
prod = prod/ (1.d0 + dfloat(m+1)/dfloat(n-i-i-1))
enddo
V_phi = 4.d0 * prod * Wallis(m)
end
double precision function V_theta(n,m)
implicit none
BEGIN_DOC
! Computes the angular $\theta$ part of the nuclear attraction integral:
!
! $\int_{0}^{\pi} \cos(\theta)^n \sin(\theta)^m d\theta$
END_DOC
integer :: n,m,i
double precision :: Wallis, prod
include 'utils/constants.include.F'
V_theta = 0.d0
prod = 1.d0
do i = 0,shiftr(n,1)-1
prod = prod / (1.d0 + dfloat(m+1)/dfloat(n-i-i-1))
enddo
V_theta = (prod+prod) * Wallis(m)
end
double precision function Wallis(n)
implicit none
BEGIN_DOC
! Wallis integral:
!
! $\int_{0}^{\pi} \cos(\theta)^n d\theta$.
END_DOC
double precision :: fact
integer :: n,p
include 'utils/constants.include.F'
if(iand(n,1).eq.0)then
Wallis = fact(shiftr(n,1))
Wallis = pi * fact(n) / (dble(ibset(0_8,n)) * (Wallis+Wallis)*Wallis)
else
p = shiftr(n,1)
Wallis = fact(p)
Wallis = dble(ibset(0_8,p+p)) * Wallis*Wallis / fact(p+p+1)
endif
end

4
src/ao_one_e_ints/pot_ao_pseudo_ints.irp.f
View File

@ -28,7 +28,6 @@ BEGIN_PROVIDER [ double precision, ao_pseudo_integrals, (ao_num,ao_num)]
END_PROVIDER
BEGIN_PROVIDER [ double precision, ao_pseudo_integrals_local, (ao_num,ao_num)]
use omp_lib
implicit none
BEGIN_DOC
! Local pseudo-potential
@ -43,6 +42,7 @@ BEGIN_PROVIDER [ double precision, ao_pseudo_integrals_local, (ao_num,ao_num)]
double precision :: wall_1, wall_2, wall_0
integer :: thread_num
integer :: omp_get_thread_num
double precision :: c
double precision :: Z
@ -158,7 +158,6 @@ BEGIN_PROVIDER [ double precision, ao_pseudo_integrals_local, (ao_num,ao_num)]
BEGIN_PROVIDER [ double precision, ao_pseudo_integrals_non_local, (ao_num,ao_num)]
use omp_lib
implicit none
BEGIN_DOC
! Non-local pseudo-potential
@ -170,6 +169,7 @@ BEGIN_PROVIDER [ double precision, ao_pseudo_integrals_local, (ao_num,ao_num)]
integer :: power_A(3),power_B(3)
integer :: i,j,k,l,m
double precision :: Vloc, Vpseudo
integer :: omp_get_thread_num
double precision :: wall_1, wall_2, wall_0
integer :: thread_num

12
src/ao_tc_eff_map/EZFIO.cfg Normal file
View File

@ -0,0 +1,12 @@
[j1b_gauss_pen]
type: double precision
doc: exponents of the 1-body Jastrow
interface: ezfio
size: (nuclei.nucl_num)
[j1b_gauss]
type: integer
doc: Use 1-body Gaussian Jastrow
interface: ezfio, provider, ocaml
default: 0

4
src/ao_tc_eff_map/NEED Normal file
View File

@ -0,0 +1,4 @@
ao_two_e_erf_ints
mo_one_e_ints
ao_many_one_e_ints
dft_utils_in_r

12
src/ao_tc_eff_map/README.rst Normal file
View File

@ -0,0 +1,12 @@
ao_tc_eff_map
=============
This is a module to obtain the integrals on the AO basis of the SCALAR HERMITIAN
effective potential defined in Eq. 32 of JCP 154, 084119 (2021)
It also contains the modification by a one-body Jastrow factor.
The main routine/providers are
+) ao_tc_sym_two_e_pot_map : map of the SCALAR PART of total effective two-electron on the AO basis in PHYSICIST notations. It might contain the two-electron term coming from the one-e correlation factor.
+) get_ao_tc_sym_two_e_pot(i,j,k,l,ao_tc_sym_two_e_pot_map) : routine to get the integrals from ao_tc_sym_two_e_pot_map.
+) ao_tc_sym_two_e_pot(i,j,k,l) : FUNCTION that returns the scalar part of TC-potential EXCLUDING the erf(mu r12)/r12. See two_e_ints_gauss.irp.f for more details.

75
src/ao_tc_eff_map/compute_ints_eff_pot.irp.f Normal file
View File

@ -0,0 +1,75 @@
subroutine compute_ao_tc_sym_two_e_pot_jl(j, l, n_integrals, buffer_i, buffer_value)
use map_module
BEGIN_DOC
! Parallel client for AO integrals of the TC integrals involving purely hermitian operators
END_DOC
implicit none
integer, intent(in) :: j, l
integer,intent(out) :: n_integrals
integer(key_kind),intent(out) :: buffer_i(ao_num*ao_num)
real(integral_kind),intent(out) :: buffer_value(ao_num*ao_num)
integer :: i, k
integer :: kk, m, j1, i1
double precision :: cpu_1, cpu_2, wall_1, wall_2
double precision :: integral, wall_0, integral_pot, integral_erf
double precision :: thr
logical, external :: ao_two_e_integral_zero
double precision :: ao_tc_sym_two_e_pot, ao_two_e_integral_erf
double precision :: j1b_gauss_erf, j1b_gauss_coul
double precision :: j1b_gauss_coul_debug
double precision :: j1b_gauss_coul_modifdebug
double precision :: j1b_gauss_coulerf
PROVIDE j1b_gauss
thr = ao_integrals_threshold
n_integrals = 0
j1 = j+ishft(l*l-l,-1)
do k = 1, ao_num ! r1
i1 = ishft(k*k-k,-1)
if (i1 > j1) then
exit
endif
do i = 1, k
i1 += 1
if (i1 > j1) then
exit
endif
if (ao_two_e_integral_erf_schwartz(i,k)*ao_two_e_integral_erf_schwartz(j,l) < thr ) then
cycle
endif
!DIR$ FORCEINLINE
integral_pot = ao_tc_sym_two_e_pot (i, k, j, l) ! i,k : r1 j,l : r2
integral_erf = ao_two_e_integral_erf(i, k, j, l)
integral = integral_erf + integral_pot
if( j1b_gauss .eq. 1 ) then
integral = integral &
+ j1b_gauss_coulerf(i, k, j, l)
endif
if(abs(integral) < thr) then
cycle
endif
n_integrals += 1
!DIR$ FORCEINLINE
call two_e_integrals_index(i, j, k, l, buffer_i(n_integrals))
buffer_value(n_integrals) = integral
enddo
enddo
end subroutine compute_ao_tc_sym_two_e_pot_jl

194
src/ao_tc_eff_map/integrals_eff_pot_in_map_slave.irp.f Normal file
View File

@ -0,0 +1,194 @@
subroutine ao_tc_sym_two_e_pot_in_map_slave_tcp(i)
implicit none
integer, intent(in) :: i
BEGIN_DOC
! Computes a buffer of integrals. i is the ID of the current thread.
END_DOC
call ao_tc_sym_two_e_pot_in_map_slave(0,i)
end
subroutine ao_tc_sym_two_e_pot_in_map_slave_inproc(i)
implicit none
integer, intent(in) :: i
BEGIN_DOC
! Computes a buffer of integrals. i is the ID of the current thread.
END_DOC
call ao_tc_sym_two_e_pot_in_map_slave(1,i)
end
subroutine ao_tc_sym_two_e_pot_in_map_slave(thread,iproc)
use map_module
use f77_zmq
implicit none
BEGIN_DOC
! Computes a buffer of integrals
END_DOC
integer, intent(in) :: thread, iproc
integer :: j,l,n_integrals
integer :: rc
real(integral_kind), allocatable :: buffer_value(:)
integer(key_kind), allocatable :: buffer_i(:)
integer :: worker_id, task_id
character*(512) :: task
integer(ZMQ_PTR),external :: new_zmq_to_qp_run_socket
integer(ZMQ_PTR) :: zmq_to_qp_run_socket
integer(ZMQ_PTR), external :: new_zmq_push_socket
integer(ZMQ_PTR) :: zmq_socket_push
character*(64) :: state
zmq_to_qp_run_socket = new_zmq_to_qp_run_socket()
integer, external :: connect_to_taskserver
if (connect_to_taskserver(zmq_to_qp_run_socket,worker_id,thread) == -1) then
call end_zmq_to_qp_run_socket(zmq_to_qp_run_socket)
return
endif
zmq_socket_push = new_zmq_push_socket(thread)
allocate ( buffer_i(ao_num*ao_num), buffer_value(ao_num*ao_num) )
do
integer, external :: get_task_from_taskserver
if (get_task_from_taskserver(zmq_to_qp_run_socket,worker_id, task_id, task) == -1) then
exit
endif
if (task_id == 0) exit
read(task,*) j, l
integer, external :: task_done_to_taskserver
call compute_ao_tc_sym_two_e_pot_jl(j,l,n_integrals,buffer_i,buffer_value)
if (task_done_to_taskserver(zmq_to_qp_run_socket,worker_id,task_id) == -1) then
stop 'Unable to send task_done'
endif
call push_integrals(zmq_socket_push, n_integrals, buffer_i, buffer_value, task_id)
enddo
integer, external :: disconnect_from_taskserver
if (disconnect_from_taskserver(zmq_to_qp_run_socket,worker_id) == -1) then
continue
endif
deallocate( buffer_i, buffer_value )
call end_zmq_to_qp_run_socket(zmq_to_qp_run_socket)
call end_zmq_push_socket(zmq_socket_push,thread)
end
subroutine ao_tc_sym_two_e_pot_in_map_collector(zmq_socket_pull)
use map_module
use f77_zmq
implicit none
BEGIN_DOC
! Collects results from the AO integral calculation
END_DOC
integer(ZMQ_PTR), intent(in) :: zmq_socket_pull
integer :: j,l,n_integrals
integer :: rc
real(integral_kind), allocatable :: buffer_value(:)
integer(key_kind), allocatable :: buffer_i(:)
integer(ZMQ_PTR),external :: new_zmq_to_qp_run_socket
integer(ZMQ_PTR) :: zmq_to_qp_run_socket
integer(ZMQ_PTR), external :: new_zmq_pull_socket
integer*8 :: control, accu, sze
integer :: task_id, more
zmq_to_qp_run_socket = new_zmq_to_qp_run_socket()
sze = ao_num*ao_num
allocate ( buffer_i(sze), buffer_value(sze) )
accu = 0_8
more = 1
do while (more == 1)
rc = f77_zmq_recv( zmq_socket_pull, n_integrals, 4, 0)
if (rc == -1) then
n_integrals = 0
return
endif
if (rc /= 4) then
print *, irp_here, ': f77_zmq_recv( zmq_socket_pull, n_integrals, 4, 0)'
stop 'error'
endif
if (n_integrals >= 0) then
if (n_integrals > sze) then
deallocate (buffer_value, buffer_i)
sze = n_integrals
allocate (buffer_value(sze), buffer_i(sze))
endif
rc = f77_zmq_recv( zmq_socket_pull, buffer_i, key_kind*n_integrals, 0)
if (rc /= key_kind*n_integrals) then
print *, rc, key_kind, n_integrals
print *, irp_here, ': f77_zmq_recv( zmq_socket_pull, buffer_i, key_kind*n_integrals, 0)'
stop 'error'
endif
rc = f77_zmq_recv( zmq_socket_pull, buffer_value, integral_kind*n_integrals, 0)
if (rc /= integral_kind*n_integrals) then
print *, irp_here, ': f77_zmq_recv( zmq_socket_pull, buffer_value, integral_kind*n_integrals, 0)'
stop 'error'
endif
rc = f77_zmq_recv( zmq_socket_pull, task_id, 4, 0)
IRP_IF ZMQ_PUSH
IRP_ELSE
rc = f77_zmq_send( zmq_socket_pull, 0, 4, 0)
if (rc /= 4) then
print *, irp_here, ' : f77_zmq_send (zmq_socket_pull,...'
stop 'error'
endif
IRP_ENDIF
call insert_into_ao_tc_sym_two_e_pot_map(n_integrals,buffer_i,buffer_value)
accu += n_integrals
if (task_id /= 0) then
integer, external :: zmq_delete_task
if (zmq_delete_task(zmq_to_qp_run_socket,zmq_socket_pull,task_id,more) == -1) then
stop 'Unable to delete task'
endif
endif
endif
enddo
deallocate( buffer_i, buffer_value )
integer (map_size_kind) :: get_ao_tc_sym_two_e_pot_map_size
control = get_ao_tc_sym_two_e_pot_map_size(ao_tc_sym_two_e_pot_map)
if (control /= accu) then
print *, ''
print *, irp_here
print *, 'Control : ', control
print *, 'Accu : ', accu
print *, 'Some integrals were lost during the parallel computation.'
print *, 'Try to reduce the number of threads.'
stop
endif
call end_zmq_to_qp_run_socket(zmq_to_qp_run_socket)
end

299
src/ao_tc_eff_map/j1b_1eInteg.py Normal file
View File

@ -0,0 +1,299 @@
import sys, os
QP_PATH=os.environ["QP_EZFIO"]
sys.path.insert(0,QP_PATH+"/Python/")
from ezfio import ezfio
from datetime import datetime
import time
from math import exp, sqrt, pi
import numpy as np
import subprocess
from scipy.integrate import tplquad
import multiprocessing
from multiprocessing import Pool
# _____________________________________________________________________________
#
def read_ao():
with open('ao_data') as f:
lines = f.readlines()
ao_prim_num = np.zeros((ao_num), dtype=int)
ao_nucl = np.zeros((ao_num), dtype=int)
ao_power = np.zeros((ao_num, 3))
nucl_coord = np.zeros((ao_num, 3))
ao_expo = np.zeros((ao_num, ao_num))
ao_coef = np.zeros((ao_num, ao_num))
iline = 0
for j in range(ao_num):
line = lines[iline]
iline += 1
ao_nucl[j] = int(line) - 1
line = lines[iline].split()
iline += 1
ao_power[j, 0] = float(line[0])
ao_power[j, 1] = float(line[1])
ao_power[j, 2] = float(line[2])
line = lines[iline].split()
iline += 1
nucl_coord[ao_nucl[j], 0] = float(line[0])
nucl_coord[ao_nucl[j], 1] = float(line[1])
nucl_coord[ao_nucl[j], 2] = float(line[2])
line = lines[iline]
iline += 1
ao_prim_num[j] = int(line)
for l in range(ao_prim_num[j]):
line = lines[iline].split()
iline += 1
ao_expo[l, j] = float(line[0])
ao_coef[l, j] = float(line[1])
return( ao_prim_num
, ao_nucl
, ao_power
, nucl_coord
, ao_expo
, ao_coef )
# _____________________________________________________________________________
# _____________________________________________________________________________
#
def Gao(X, i_ao):
ii = ao_nucl[i_ao]
C = np.array([nucl_coord[ii,0], nucl_coord[ii,1], nucl_coord[ii,2]])
Y = X - C
dis = np.dot(Y,Y)
ip = np.array([ao_power[i_ao,0], ao_power[i_ao,1], ao_power[i_ao,2]])
pol = np.prod(Y**ip)
xi = np.sum( ao_coef[:,i_ao] * np.exp(-dis*ao_expo[:,i_ao]) )
return(xi*pol)
# _____________________________________________________________________________
# _____________________________________________________________________________
#
def grad_Gao(X, i_ao):
ii = ao_nucl[i_ao]
C = np.array([nucl_coord[ii,0], nucl_coord[ii,1], nucl_coord[ii,2]])
ix = ao_power[i_ao,0]
iy = ao_power[i_ao,1]
iz = ao_power[i_ao,2]
Y = X - C
dis = np.dot(Y,Y)
xm = np.sum( ao_coef[:,i_ao]*np.exp(-dis*ao_expo[:,i_ao]))
xp = np.sum(ao_expo[:,i_ao]*ao_coef[:,i_ao]*np.exp(-dis*ao_expo[:,i_ao]))
ip = np.array([ix+1, iy, iz])
dx = -2. * np.prod(Y**ip) * xp
if(ix > 0):
ip = np.array([ix-1, iy, iz])
dx += ix * np.prod(Y**ip) * xm
ip = np.array([ix, iy+1, iz])
dy = -2. * np.prod(Y**ip) * xp
if(iy > 0):
ip = np.array([ix, iy-1, iz])
dy += iy * np.prod(Y**ip) * xm
ip = np.array([ix, iy, iz+1])
dz = -2. * np.prod(Y**ip) * xp
if(iz > 0):
ip = np.array([ix, iy, iz-1])
dz += iz * np.prod(Y**ip) * xm
return(np.array([dx, dy, dz]))
# _____________________________________________________________________________
# _____________________________________________________________________________
#
# 3 x < XA | exp[-gama r_C^2] | XB >
# - 2 x < XA | r_A^2 exp[-gama r_C^2] | XB >
#
def integ_lap(z, y, x, i_ao, j_ao):
X = np.array([x, y, z])
Gi = Gao(X, i_ao)
Gj = Gao(X, j_ao)
c = 0.
for k in range(nucl_num):
gama = j1b_gauss_pen[k]
C = nucl_coord[k,:]
Y = X - C
dis = np.dot(Y, Y)
arg = exp(-gama*dis)
arg = exp(-gama*dis)
c += ( 3. - 2. * dis * gama ) * arg * gama * Gi * Gj
return(c)
# _____________________________________________________________________________
# _____________________________________________________________________________
#
#
def integ_grad2(z, y, x, i_ao, j_ao):
X = np.array([x, y, z])
Gi = Gao(X, i_ao)
Gj = Gao(X, j_ao)
c = np.zeros((3))
for k in range(nucl_num):
gama = j1b_gauss_pen[k]
C = nucl_coord[k,:]
Y = X - C
c += gama * exp(-gama*np.dot(Y, Y)) * Y
return(-2*np.dot(c,c)*Gi*Gj)
# _____________________________________________________________________________
# _____________________________________________________________________________
#
#
def integ_nonh(z, y, x, i_ao, j_ao):
X = np.array([x, y, z])
Gi = Gao(X, i_ao)
c = 0.
for k in range(nucl_num):
gama = j1b_gauss_pen[k]
C = nucl_coord[k,:]
Y = X - C
grad = grad_Gao(X, j_ao)
c += gama * exp(-gama*np.dot(Y,Y)) * np.dot(Y,grad)
return(2*c*Gi)
# _____________________________________________________________________________
# _____________________________________________________________________________
#
def perform_integ( ind_ao ):
i_ao = ind_ao[0]
j_ao = ind_ao[1]
a = -15. #-np.Inf
b = +15. #+np.Inf
epsrel = 1e-5
res_lap, err_lap = tplquad( integ_lap
, a, b
, lambda x : a, lambda x : b
, lambda x,y: a, lambda x,y: b
, (i_ao, j_ao)
, epsrel=epsrel )
res_grd, err_grd = tplquad( integ_grad2
, a, b
, lambda x : a, lambda x : b
, lambda x,y: a, lambda x,y: b
, (i_ao, j_ao)
, epsrel=epsrel )
res_nnh, err_nnh = tplquad( integ_nonh
, a, b
, lambda x : a, lambda x : b
, lambda x,y: a, lambda x,y: b
, (i_ao, j_ao)
, epsrel=epsrel )
return( [ res_lap, err_lap
, res_grd, err_grd
, res_nnh, err_nnh ])
# _____________________________________________________________________________
# _____________________________________________________________________________
#
def integ_eval():
list_ind = []
for i_ao in range(ao_num):
for j_ao in range(ao_num):
list_ind.append( [i_ao, j_ao] )
nb_proc = multiprocessing.cpu_count()
print(" --- Excexution with {} processors ---\n".format(nb_proc))
p = Pool(nb_proc)
res = np.array( p.map( perform_integ, list_ind ) )
ii = 0
for i_ao in range(ao_num):
for j_ao in range(ao_num):
print(" {} {} {:+e} {:+e} {:+e} {:+e}".format( i_ao, j_ao
, res[ii][0], res[ii][1], res[ii][2], res[ii][3]) )
ii += 1
p.close()
# _____________________________________________________________________________
# _____________________________________________________________________________
#
if __name__=="__main__":
t0 = time.time()
EZFIO_file = sys.argv[1]
ezfio.set_file(EZFIO_file)
print(" Today's date:", datetime.now() )
print(" EZFIO file = {}".format(EZFIO_file))
nucl_num = ezfio.get_nuclei_nucl_num()
ao_num = ezfio.get_ao_basis_ao_num()
j1b_gauss_pen = ezfio.get_ao_tc_eff_map_j1b_gauss_pen()
ao_prim_num, ao_nucl, ao_power, nucl_coord, ao_expo, ao_coef = read_ao()
#integ_eval()
i_ao = 0
j_ao = 0
a = -5.
b = +5.
epsrel = 1e-1
res_grd, err_grd = tplquad( integ_nonh
, a, b
, lambda x : a, lambda x : b
, lambda x,y: a, lambda x,y: b
, (i_ao, j_ao)
, epsrel=epsrel )
print(res_grd, err_grd)
tf = time.time() - t0
print(' end after {} min'.format(tf/60.))
# _____________________________________________________________________________

59
src/ao_tc_eff_map/j1b_pen.irp.f Normal file
View File

@ -0,0 +1,59 @@
! ---
BEGIN_PROVIDER [ double precision, j1b_gauss_pen, (nucl_num) ]
BEGIN_DOC
! exponents of the 1-body Jastrow
END_DOC
implicit none
logical :: exists
PROVIDE ezfio_filename
if (mpi_master) then
call ezfio_has_ao_tc_eff_map_j1b_gauss_pen(exists)
endif
IRP_IF MPI_DEBUG
print *, irp_here, mpi_rank
call MPI_BARRIER(MPI_COMM_WORLD, ierr)
IRP_ENDIF
IRP_IF MPI
include 'mpif.h'
integer :: ierr
call MPI_BCAST(j1b_gauss_pen, (nucl_num), MPI_DOUBLE_PRECISION, 0, MPI_COMM_WORLD, ierr)
if (ierr /= MPI_SUCCESS) then
stop 'Unable to read j1b_gauss_pen with MPI'
endif
IRP_ENDIF
if (exists) then
if (mpi_master) then
write(6,'(A)') '.. >>>>> [ IO READ: j1b_gauss_pen ] <<<<< ..'
call ezfio_get_ao_tc_eff_map_j1b_gauss_pen(j1b_gauss_pen)
IRP_IF MPI
call MPI_BCAST(j1b_gauss_pen, (nucl_num), MPI_DOUBLE_PRECISION, 0, MPI_COMM_WORLD, ierr)
if (ierr /= MPI_SUCCESS) then
stop 'Unable to read j1b_gauss_pen with MPI'
endif
IRP_ENDIF
endif
else
integer :: i
do i = 1, nucl_num
j1b_gauss_pen(i) = 1d5
enddo
endif
END_PROVIDER
! ---

291
src/ao_tc_eff_map/map_integrals_eff_pot.irp.f Normal file
View File

@ -0,0 +1,291 @@
use map_module
!! AO Map
!! ======
BEGIN_PROVIDER [ type(map_type), ao_tc_sym_two_e_pot_map ]
implicit none
BEGIN_DOC
! |AO| integrals
END_DOC
integer(key_kind) :: key_max
integer(map_size_kind) :: sze
call two_e_integrals_index(ao_num,ao_num,ao_num,ao_num,key_max)
sze = key_max
call map_init(ao_tc_sym_two_e_pot_map,sze)
print*, 'ao_tc_sym_two_e_pot_map map initialized : ', sze
END_PROVIDER
BEGIN_PROVIDER [ integer, ao_tc_sym_two_e_pot_cache_min ]
&BEGIN_PROVIDER [ integer, ao_tc_sym_two_e_pot_cache_max ]
implicit none
BEGIN_DOC
! Min and max values of the AOs for which the integrals are in the cache
END_DOC
ao_tc_sym_two_e_pot_cache_min = max(1,ao_num - 63)
ao_tc_sym_two_e_pot_cache_max = ao_num
END_PROVIDER
BEGIN_PROVIDER [ double precision, ao_tc_sym_two_e_pot_cache, (0:64*64*64*64) ]
use map_module
implicit none
BEGIN_DOC
! Cache of |AO| integrals for fast access
END_DOC
PROVIDE ao_tc_sym_two_e_pot_in_map
integer :: i,j,k,l,ii
integer(key_kind) :: idx
real(integral_kind) :: integral
!$OMP PARALLEL DO PRIVATE (i,j,k,l,idx,ii,integral)
do l=ao_tc_sym_two_e_pot_cache_min,ao_tc_sym_two_e_pot_cache_max
do k=ao_tc_sym_two_e_pot_cache_min,ao_tc_sym_two_e_pot_cache_max
do j=ao_tc_sym_two_e_pot_cache_min,ao_tc_sym_two_e_pot_cache_max
do i=ao_tc_sym_two_e_pot_cache_min,ao_tc_sym_two_e_pot_cache_max
!DIR$ FORCEINLINE
call two_e_integrals_index(i,j,k,l,idx)
!DIR$ FORCEINLINE
call map_get(ao_tc_sym_two_e_pot_map,idx,integral)
ii = l-ao_tc_sym_two_e_pot_cache_min
ii = ior( ishft(ii,6), k-ao_tc_sym_two_e_pot_cache_min)
ii = ior( ishft(ii,6), j-ao_tc_sym_two_e_pot_cache_min)
ii = ior( ishft(ii,6), i-ao_tc_sym_two_e_pot_cache_min)
ao_tc_sym_two_e_pot_cache(ii) = integral
enddo
enddo
enddo
enddo
!$OMP END PARALLEL DO
END_PROVIDER
subroutine insert_into_ao_tc_sym_two_e_pot_map(n_integrals,buffer_i, buffer_values)
use map_module
implicit none
BEGIN_DOC
! Create new entry into |AO| map
END_DOC
integer, intent(in) :: n_integrals
integer(key_kind), intent(inout) :: buffer_i(n_integrals)
real(integral_kind), intent(inout) :: buffer_values(n_integrals)
call map_append(ao_tc_sym_two_e_pot_map, buffer_i, buffer_values, n_integrals)
end
double precision function get_ao_tc_sym_two_e_pot(i,j,k,l,map) result(result)
use map_module
implicit none
BEGIN_DOC
! Gets one |AO| two-electron integral from the |AO| map in PHYSICIST NOTATION
END_DOC
integer, intent(in) :: i,j,k,l
integer(key_kind) :: idx
type(map_type), intent(inout) :: map
integer :: ii
real(integral_kind) :: tmp
logical, external :: ao_two_e_integral_zero
PROVIDE ao_tc_sym_two_e_pot_in_map ao_tc_sym_two_e_pot_cache ao_tc_sym_two_e_pot_cache_min
!DIR$ FORCEINLINE
! if (ao_two_e_integral_zero(i,j,k,l)) then
if (.False.) then
tmp = 0.d0
!else if (ao_two_e_integral_erf_schwartz(i,k)*ao_two_e_integral_erf_schwartz(j,l) < ao_integrals_threshold) then
! tmp = 0.d0
else
ii = l-ao_tc_sym_two_e_pot_cache_min
ii = ior(ii, k-ao_tc_sym_two_e_pot_cache_min)
ii = ior(ii, j-ao_tc_sym_two_e_pot_cache_min)
ii = ior(ii, i-ao_tc_sym_two_e_pot_cache_min)
if (iand(ii, -64) /= 0) then
!DIR$ FORCEINLINE
call two_e_integrals_index(i,j,k,l,idx)
!DIR$ FORCEINLINE
call map_get(map,idx,tmp)
tmp = tmp
else
ii = l-ao_tc_sym_two_e_pot_cache_min
ii = ior( ishft(ii,6), k-ao_tc_sym_two_e_pot_cache_min)
ii = ior( ishft(ii,6), j-ao_tc_sym_two_e_pot_cache_min)
ii = ior( ishft(ii,6), i-ao_tc_sym_two_e_pot_cache_min)
tmp = ao_tc_sym_two_e_pot_cache(ii)
endif
endif
result = tmp
end
subroutine get_many_ao_tc_sym_two_e_pot(j,k,l,sze,out_val)
use map_module
BEGIN_DOC
! Gets multiple |AO| two-electron integral from the |AO| map .
! All i are retrieved for j,k,l fixed.
END_DOC
implicit none
integer, intent(in) :: j,k,l, sze
real(integral_kind), intent(out) :: out_val(sze)
integer :: i
integer(key_kind) :: hash
double precision :: thresh
! logical, external :: ao_one_e_integral_zero
PROVIDE ao_tc_sym_two_e_pot_in_map ao_tc_sym_two_e_pot_map
thresh = ao_integrals_threshold
! if (ao_one_e_integral_zero(j,l)) then
if (.False.) then
out_val = 0.d0
return
endif
double precision :: get_ao_tc_sym_two_e_pot
do i=1,sze
out_val(i) = get_ao_tc_sym_two_e_pot(i,j,k,l,ao_tc_sym_two_e_pot_map)
enddo
end
subroutine get_many_ao_tc_sym_two_e_pot_non_zero(j,k,l,sze,out_val,out_val_index,non_zero_int)
use map_module
implicit none
BEGIN_DOC
! Gets multiple |AO| two-electron integrals from the |AO| map .
! All non-zero i are retrieved for j,k,l fixed.
END_DOC
integer, intent(in) :: j,k,l, sze
real(integral_kind), intent(out) :: out_val(sze)
integer, intent(out) :: out_val_index(sze),non_zero_int
integer :: i
integer(key_kind) :: hash
double precision :: thresh,tmp
! logical, external :: ao_one_e_integral_zero
PROVIDE ao_tc_sym_two_e_pot_in_map
thresh = ao_integrals_threshold
non_zero_int = 0
! if (ao_one_e_integral_zero(j,l)) then
if (.False.) then
out_val = 0.d0
return
endif
non_zero_int = 0
do i=1,sze
integer, external :: ao_l4
double precision, external :: ao_two_e_integral_eff_pot
!DIR$ FORCEINLINE
!if (ao_two_e_integral_erf_schwartz(i,k)*ao_two_e_integral_erf_schwartz(j,l) < thresh) then
! cycle
!endif
call two_e_integrals_index(i,j,k,l,hash)
call map_get(ao_tc_sym_two_e_pot_map, hash,tmp)
if (dabs(tmp) < thresh ) cycle
non_zero_int = non_zero_int+1
out_val_index(non_zero_int) = i
out_val(non_zero_int) = tmp
enddo
end
function get_ao_tc_sym_two_e_pot_map_size()
implicit none
integer (map_size_kind) :: get_ao_tc_sym_two_e_pot_map_size
BEGIN_DOC
! Returns the number of elements in the |AO| map
END_DOC
get_ao_tc_sym_two_e_pot_map_size = ao_tc_sym_two_e_pot_map % n_elements
end
subroutine clear_ao_tc_sym_two_e_pot_map
implicit none
BEGIN_DOC
! Frees the memory of the |AO| map
END_DOC
call map_deinit(ao_tc_sym_two_e_pot_map)
FREE ao_tc_sym_two_e_pot_map
end
subroutine dump_ao_tc_sym_two_e_pot(filename)
use map_module
implicit none
BEGIN_DOC
! Save to disk the |AO| eff_pot integrals
END_DOC
character*(*), intent(in) :: filename
integer(cache_key_kind), pointer :: key(:)
real(integral_kind), pointer :: val(:)
integer*8 :: i,j, n
call ezfio_set_work_empty(.False.)
open(unit=66,file=filename,FORM='unformatted')
write(66) integral_kind, key_kind
write(66) ao_tc_sym_two_e_pot_map%sorted, ao_tc_sym_two_e_pot_map%map_size, &
ao_tc_sym_two_e_pot_map%n_elements
do i=0_8,ao_tc_sym_two_e_pot_map%map_size
write(66) ao_tc_sym_two_e_pot_map%map(i)%sorted, ao_tc_sym_two_e_pot_map%map(i)%map_size,&
ao_tc_sym_two_e_pot_map%map(i)%n_elements
enddo
do i=0_8,ao_tc_sym_two_e_pot_map%map_size
key => ao_tc_sym_two_e_pot_map%map(i)%key
val => ao_tc_sym_two_e_pot_map%map(i)%value
n = ao_tc_sym_two_e_pot_map%map(i)%n_elements
write(66) (key(j), j=1,n), (val(j), j=1,n)
enddo
close(66)
end
integer function load_ao_tc_sym_two_e_pot(filename)
implicit none
BEGIN_DOC
! Read from disk the |AO| eff_pot integrals
END_DOC
character*(*), intent(in) :: filename
integer*8 :: i
integer(cache_key_kind), pointer :: key(:)
real(integral_kind), pointer :: val(:)
integer :: iknd, kknd
integer*8 :: n, j
load_ao_tc_sym_two_e_pot = 1
open(unit=66,file=filename,FORM='unformatted',STATUS='UNKNOWN')
read(66,err=98,end=98) iknd, kknd
if (iknd /= integral_kind) then
print *, 'Wrong integrals kind in file :', iknd
stop 1
endif
if (kknd /= key_kind) then
print *, 'Wrong key kind in file :', kknd
stop 1
endif
read(66,err=98,end=98) ao_tc_sym_two_e_pot_map%sorted, ao_tc_sym_two_e_pot_map%map_size,&
ao_tc_sym_two_e_pot_map%n_elements
do i=0_8, ao_tc_sym_two_e_pot_map%map_size
read(66,err=99,end=99) ao_tc_sym_two_e_pot_map%map(i)%sorted, &
ao_tc_sym_two_e_pot_map%map(i)%map_size, ao_tc_sym_two_e_pot_map%map(i)%n_elements
call cache_map_reallocate(ao_tc_sym_two_e_pot_map%map(i),ao_tc_sym_two_e_pot_map%map(i)%map_size)
enddo
do i=0_8, ao_tc_sym_two_e_pot_map%map_size
key => ao_tc_sym_two_e_pot_map%map(i)%key
val => ao_tc_sym_two_e_pot_map%map(i)%value
n = ao_tc_sym_two_e_pot_map%map(i)%n_elements
read(66,err=99,end=99) (key(j), j=1,n), (val(j), j=1,n)
enddo
call map_sort(ao_tc_sym_two_e_pot_map)
load_ao_tc_sym_two_e_pot = 0
return
99 continue
call map_deinit(ao_tc_sym_two_e_pot_map)
98 continue
stop 'Problem reading ao_tc_sym_two_e_pot_map file in work/'
end

519
src/ao_tc_eff_map/one_e_1bgauss_hermit.irp.f Normal file
View File

@ -0,0 +1,519 @@
BEGIN_PROVIDER [ double precision, j1b_gauss_hermII, (ao_num,ao_num)]
BEGIN_DOC
!
! Hermitian part of 1-body Jastrow factow in the |AO| basis set.
!
! :math:`\langle \chi_A | -0.5 \grad \tau_{1b} \cdot \grad \tau_{1b} | \chi_B \rangle`
!
END_DOC
implicit none
integer :: num_A, num_B
integer :: power_A(3), power_B(3)
integer :: i, j, k1, k2, l, m
double precision :: alpha, beta, gama1, gama2
double precision :: A_center(3), B_center(3), C_center1(3), C_center2(3)
double precision :: c1, c
integer :: dim1
double precision :: overlap_y, d_a_2, overlap_z, overlap
double precision :: int_gauss_4G
PROVIDE j1b_gauss_pen
! --------------------------------------------------------------------------------
! -- Dummy call to provide everything
dim1 = 100
A_center(:) = 0.d0
B_center(:) = 1.d0
alpha = 1.d0
beta = 0.1d0
power_A(:) = 1
power_B(:) = 0
call overlap_gaussian_xyz( A_center, B_center, alpha, beta, power_A, power_B &
, overlap_y, d_a_2, overlap_z, overlap, dim1 )
! --------------------------------------------------------------------------------
j1b_gauss_hermII(1:ao_num,1:ao_num) = 0.d0
!$OMP PARALLEL &
!$OMP DEFAULT (NONE) &
!$OMP PRIVATE (i, j, k1, k2, l, m, alpha, beta, gama1, gama2, &
!$OMP A_center, B_center, C_center1, C_center2, &
!$OMP power_A, power_B, num_A, num_B, c1, c) &
!$OMP SHARED (ao_num, ao_prim_num, ao_expo_ordered_transp, &
!$OMP ao_power, ao_nucl, nucl_coord, &
!$OMP ao_coef_normalized_ordered_transp, &
!$OMP nucl_num, j1b_gauss_pen, j1b_gauss_hermII)
!$OMP DO SCHEDULE (dynamic)
do j = 1, ao_num
num_A = ao_nucl(j)
power_A(1:3) = ao_power(j,1:3)
A_center(1:3) = nucl_coord(num_A,1:3)
do i = 1, ao_num
num_B = ao_nucl(i)
power_B(1:3) = ao_power(i,1:3)
B_center(1:3) = nucl_coord(num_B,1:3)
do l = 1, ao_prim_num(j)
alpha = ao_expo_ordered_transp(l,j)
do m = 1, ao_prim_num(i)
beta = ao_expo_ordered_transp(m,i)
c = 0.d0
do k1 = 1, nucl_num
gama1 = j1b_gauss_pen(k1)
C_center1(1:3) = nucl_coord(k1,1:3)
do k2 = 1, nucl_num
gama2 = j1b_gauss_pen(k2)
C_center2(1:3) = nucl_coord(k2,1:3)
! < XA | exp[-gama1 r_C1^2 -gama2 r_C2^2] r_C1 \cdot r_C2 | XB >
c1 = int_gauss_4G( A_center, B_center, C_center1, C_center2 &
, power_A, power_B, alpha, beta, gama1, gama2 )
c = c - 2.d0 * gama1 * gama2 * c1
enddo
enddo
j1b_gauss_hermII(i,j) = j1b_gauss_hermII(i,j) &
+ ao_coef_normalized_ordered_transp(l,j) &
* ao_coef_normalized_ordered_transp(m,i) * c
enddo
enddo
enddo
enddo
!$OMP END DO
!$OMP END PARALLEL
END_PROVIDER
!_____________________________________________________________________________________________________________
!
! < XA | exp[-gama1 r_C1^2 -gama2 r_C2^2] r_C1 \cdot r_C2 | XB >
!
double precision function int_gauss_4G( A_center, B_center, C_center1, C_center2, power_A, power_B &
, alpha, beta, gama1, gama2 )
! for max_dim
include 'constants.include.F'
implicit none
integer , intent(in) :: power_A(3), power_B(3)
double precision, intent(in) :: A_center(3), B_center(3), C_center1(3), C_center2(3)
double precision, intent(in) :: alpha, beta, gama1, gama2
integer :: i, dim1, power_C
integer :: iorder(3)
double precision :: AB_expo, fact_AB, AB_center(3), P_AB(0:max_dim,3)
double precision :: gama, fact_C, C_center(3)
double precision :: cx0, cy0, cz0, c_tmp1, c_tmp2, cx, cy, cz
double precision :: int_tmp
double precision :: overlap_gaussian_x
dim1 = 100
! P_AB(0:max_dim,3) polynomial
! AB_center(3) new center
! AB_expo new exponent
! fact_AB constant factor
! iorder(3) i_order(i) = order of the polynomials
call give_explicit_poly_and_gaussian( P_AB, AB_center, AB_expo, fact_AB &
, iorder, alpha, beta, power_A, power_B, A_center, B_center, dim1)
call gaussian_product(gama1, C_center1, gama2, C_center2, fact_C, gama, C_center)
! <<<
! to avoid multi-evaluation
power_C = 0
cx0 = 0.d0
do i = 0, iorder(1)
cx0 = cx0 + P_AB(i,1) * overlap_gaussian_x( AB_center(1), C_center(1), AB_expo, gama, i, power_C, dim1)
enddo
cy0 = 0.d0
do i = 0, iorder(2)
cy0 = cy0 + P_AB(i,2) * overlap_gaussian_x( AB_center(2), C_center(2), AB_expo, gama, i, power_C, dim1)
enddo
cz0 = 0.d0
do i = 0, iorder(3)
cz0 = cz0 + P_AB(i,3) * overlap_gaussian_x( AB_center(3), C_center(3), AB_expo, gama, i, power_C, dim1)
enddo
! >>>
int_tmp = 0.d0
! -----------------------------------------------------------------------------------------------
!
! x term:
! < XA | exp[-gama1 r_C1^2 -gama2 r_C2^2] (x - x_C1) (x - x_C2) | XB >
!
c_tmp1 = 2.d0 * C_center(1) - C_center1(1) - C_center2(1)
c_tmp2 = ( C_center(1) - C_center1(1) ) * ( C_center(1) - C_center2(1) )
cx = 0.d0
do i = 0, iorder(1)
! < XA | exp[-gama r_C^2] (x - x_C)^2 | XB >
power_C = 2
cx = cx + P_AB(i,1) &
* overlap_gaussian_x( AB_center(1), C_center(1), AB_expo, gama, i, power_C, dim1)
! < XA | exp[-gama r_C^2] (x - x_C) | XB >
power_C = 1
cx = cx + P_AB(i,1) * c_tmp1 &
* overlap_gaussian_x( AB_center(1), C_center(1), AB_expo, gama, i, power_C, dim1)
! < XA | exp[-gama r_C^2] | XB >
power_C = 0
cx = cx + P_AB(i,1) * c_tmp2 &
* overlap_gaussian_x( AB_center(1), C_center(1), AB_expo, gama, i, power_C, dim1)
enddo
int_tmp += cx * cy0 * cz0
! -----------------------------------------------------------------------------------------------
! -----------------------------------------------------------------------------------------------
!
! y term:
! < XA | exp[-gama1 r_C1^2 -gama2 r_C2^2] (y - y_C1) (y - y_C2) | XB >
!
c_tmp1 = 2.d0 * C_center(2) - C_center1(2) - C_center2(2)
c_tmp2 = ( C_center(2) - C_center1(2) ) * ( C_center(2) - C_center2(2) )
cy = 0.d0
do i = 0, iorder(2)
! < XA | exp[-gama r_C^2] (y - y_C)^2 | XB >
power_C = 2
cy = cy + P_AB(i,2) &
* overlap_gaussian_x( AB_center(2), C_center(2), AB_expo, gama, i, power_C, dim1)
! < XA | exp[-gama r_C^2] (y - y_C) | XB >
power_C = 1
cy = cy + P_AB(i,2) * c_tmp1 &
* overlap_gaussian_x( AB_center(2), C_center(2), AB_expo, gama, i, power_C, dim1)
! < XA | exp[-gama r_C^2] | XB >
power_C = 0
cy = cy + P_AB(i,2) * c_tmp2 &
* overlap_gaussian_x( AB_center(2), C_center(2), AB_expo, gama, i, power_C, dim1)
enddo
int_tmp += cx0 * cy * cz0
! -----------------------------------------------------------------------------------------------
! -----------------------------------------------------------------------------------------------
!
! z term:
! < XA | exp[-gama1 r_C1^2 -gama2 r_C2^2] (z - z_C1) (z - z_C2) | XB >
!
c_tmp1 = 2.d0 * C_center(3) - C_center1(3) - C_center2(3)
c_tmp2 = ( C_center(3) - C_center1(3) ) * ( C_center(3) - C_center2(3) )
cz = 0.d0
do i = 0, iorder(3)
! < XA | exp[-gama r_C^2] (z - z_C)^2 | XB >
power_C = 2
cz = cz + P_AB(i,3) &
* overlap_gaussian_x( AB_center(3), C_center(3), AB_expo, gama, i, power_C, dim1)
! < XA | exp[-gama r_C^2] (z - z_C) | XB >
power_C = 1
cz = cz + P_AB(i,3) * c_tmp1 &
* overlap_gaussian_x( AB_center(3), C_center(3), AB_expo, gama, i, power_C, dim1)
! < XA | exp[-gama r_C^2] | XB >
power_C = 0
cz = cz + P_AB(i,3) * c_tmp2 &
* overlap_gaussian_x( AB_center(3), C_center(3), AB_expo, gama, i, power_C, dim1)
enddo
int_tmp += cx0 * cy0 * cz
! -----------------------------------------------------------------------------------------------
int_gauss_4G = fact_AB * fact_C * int_tmp
return
end function int_gauss_4G
!_____________________________________________________________________________________________________________
!_____________________________________________________________________________________________________________
BEGIN_PROVIDER [ double precision, j1b_gauss_hermI, (ao_num,ao_num)]
BEGIN_DOC
!
! Hermitian part of 1-body Jastrow factow in the |AO| basis set.
!
! :math:`\langle \chi_A | -0.5 \Delta \tau_{1b} | \chi_B \rangle`
!
END_DOC
implicit none
integer :: num_A, num_B
integer :: power_A(3), power_B(3)
integer :: i, j, k, l, m
double precision :: alpha, beta, gama
double precision :: A_center(3), B_center(3), C_center(3)
double precision :: c1, c2, c
integer :: dim1
double precision :: overlap_y, d_a_2, overlap_z, overlap
double precision :: int_gauss_r0, int_gauss_r2
PROVIDE j1b_gauss_pen
! --------------------------------------------------------------------------------
! -- Dummy call to provide everything
dim1 = 100
A_center(:) = 0.d0
B_center(:) = 1.d0
alpha = 1.d0
beta = 0.1d0
power_A(:) = 1
power_B(:) = 0
call overlap_gaussian_xyz( A_center, B_center, alpha, beta, power_A, power_B &
, overlap_y, d_a_2, overlap_z, overlap, dim1 )
! --------------------------------------------------------------------------------
j1b_gauss_hermI(1:ao_num,1:ao_num) = 0.d0
!$OMP PARALLEL &
!$OMP DEFAULT (NONE) &
!$OMP PRIVATE (i, j, k, l, m, alpha, beta, gama, &
!$OMP A_center, B_center, C_center, power_A, power_B, &
!$OMP num_A, num_B, c1, c2, c) &
!$OMP SHARED (ao_num, ao_prim_num, ao_expo_ordered_transp, &
!$OMP ao_power, ao_nucl, nucl_coord, &
!$OMP ao_coef_normalized_ordered_transp, &
!$OMP nucl_num, j1b_gauss_pen, j1b_gauss_hermI)
!$OMP DO SCHEDULE (dynamic)
do j = 1, ao_num
num_A = ao_nucl(j)
power_A(1:3) = ao_power(j,1:3)
A_center(1:3) = nucl_coord(num_A,1:3)
do i = 1, ao_num
num_B = ao_nucl(i)
power_B(1:3) = ao_power(i,1:3)
B_center(1:3) = nucl_coord(num_B,1:3)
do l = 1, ao_prim_num(j)
alpha = ao_expo_ordered_transp(l,j)
do m = 1, ao_prim_num(i)
beta = ao_expo_ordered_transp(m,i)
c = 0.d0
do k = 1, nucl_num
gama = j1b_gauss_pen(k)
C_center(1:3) = nucl_coord(k,1:3)
! < XA | exp[-gama r_C^2] | XB >
c1 = int_gauss_r0( A_center, B_center, C_center &
, power_A, power_B, alpha, beta, gama )
! < XA | r_A^2 exp[-gama r_C^2] | XB >
c2 = int_gauss_r2( A_center, B_center, C_center &
, power_A, power_B, alpha, beta, gama )
c = c + 3.d0 * gama * c1 - 2.d0 * gama * gama * c2
enddo
j1b_gauss_hermI(i,j) = j1b_gauss_hermI(i,j) &
+ ao_coef_normalized_ordered_transp(l,j) &
* ao_coef_normalized_ordered_transp(m,i) * c
enddo
enddo
enddo
enddo
!$OMP END DO
!$OMP END PARALLEL
END_PROVIDER
!_____________________________________________________________________________________________________________
!
! < XA | exp[-gama r_C^2] | XB >
!
double precision function int_gauss_r0(A_center, B_center, C_center, power_A, power_B, alpha, beta, gama)
! for max_dim
include 'constants.include.F'
implicit none
integer , intent(in) :: power_A(3), power_B(3)
double precision, intent(in) :: A_center(3), B_center(3), C_center(3)
double precision, intent(in) :: alpha, beta, gama
integer :: i, power_C, dim1
integer :: iorder(3)
integer :: nmax
double precision :: AB_expo, fact_AB, AB_center(3), P_AB(0:max_dim,3)
double precision :: cx, cy, cz
double precision :: overlap_gaussian_x
dim1 = 100
! P_AB(0:max_dim,3) polynomial
! AB_center(3) new center
! AB_expo new exponent
! fact_AB constant factor
! iorder(3) i_order(i) = order of the polynomials
call give_explicit_poly_and_gaussian( P_AB, AB_center, AB_expo, fact_AB &
, iorder, alpha, beta, power_A, power_B, A_center, B_center, dim1)
if( fact_AB .lt. 1d-20 ) then
int_gauss_r0 = 0.d0
return
endif
power_C = 0
cx = 0.d0
do i = 0, iorder(1)
cx = cx + P_AB(i,1) * overlap_gaussian_x(AB_center(1), C_center(1), AB_expo, gama, i, power_C, dim1)
enddo
cy = 0.d0
do i = 0, iorder(2)
cy = cy + P_AB(i,2) * overlap_gaussian_x(AB_center(2), C_center(2), AB_expo, gama, i, power_C, dim1)
enddo
cz = 0.d0
do i = 0, iorder(3)
cz = cz + P_AB(i,3) * overlap_gaussian_x(AB_center(3), C_center(3), AB_expo, gama, i, power_C, dim1)
enddo
int_gauss_r0 = fact_AB * cx * cy * cz
return
end function int_gauss_r0
!_____________________________________________________________________________________________________________
!_____________________________________________________________________________________________________________
!_____________________________________________________________________________________________________________
!
! < XA | r_C^2 exp[-gama r_C^2] | XB >
!
double precision function int_gauss_r2(A_center, B_center, C_center, power_A, power_B, alpha, beta, gama)
! for max_dim
include 'constants.include.F'
implicit none
integer, intent(in) :: power_A(3), power_B(3)
double precision, intent(in) :: A_center(3), B_center(3), C_center(3)
double precision, intent(in) :: alpha, beta, gama
integer :: i, power_C, dim1
integer :: iorder(3)
double precision :: AB_expo, fact_AB, AB_center(3), P_AB(0:max_dim,3)
double precision :: cx0, cy0, cz0, cx, cy, cz
double precision :: int_tmp
double precision :: overlap_gaussian_x
dim1 = 100
! P_AB(0:max_dim,3) polynomial centered on AB_center
! AB_center(3) new center
! AB_expo new exponent
! fact_AB constant factor
! iorder(3) i_order(i) = order of the polynomials
call give_explicit_poly_and_gaussian( P_AB, AB_center, AB_expo, fact_AB &
, iorder, alpha, beta, power_A, power_B, A_center, B_center, dim1)
! <<<
! to avoid multi-evaluation
power_C = 0
cx0 = 0.d0
do i = 0, iorder(1)
cx0 = cx0 + P_AB(i,1) * overlap_gaussian_x(AB_center(1), C_center(1), AB_expo, gama, i, power_C, dim1)
enddo
cy0 = 0.d0
do i = 0, iorder(2)
cy0 = cy0 + P_AB(i,2) * overlap_gaussian_x(AB_center(2), C_center(2), AB_expo, gama, i, power_C, dim1)
enddo
cz0 = 0.d0
do i = 0, iorder(3)
cz0 = cz0 + P_AB(i,3) * overlap_gaussian_x(AB_center(3), C_center(3), AB_expo, gama, i, power_C, dim1)
enddo
! >>>
int_tmp = 0.d0
power_C = 2
! ( x - XC)^2
cx = 0.d0
do i = 0, iorder(1)
cx = cx + P_AB(i,1) * overlap_gaussian_x(AB_center(1), C_center(1), AB_expo, gama, i, power_C, dim1)
enddo
int_tmp += cx * cy0 * cz0
! ( y - YC)^2
cy = 0.d0
do i = 0, iorder(2)
cy = cy + P_AB(i,2) * overlap_gaussian_x(AB_center(2), C_center(2), AB_expo, gama, i, power_C, dim1)
enddo
int_tmp += cx0 * cy * cz0
! ( z - ZC)^2
cz = 0.d0
do i = 0, iorder(3)
cz = cz + P_AB(i,3) * overlap_gaussian_x(AB_center(3), C_center(3), AB_expo, gama, i, power_C, dim1)
enddo
int_tmp += cx0 * cy0 * cz
int_gauss_r2 = fact_AB * int_tmp
return
end function int_gauss_r2
!_____________________________________________________________________________________________________________
!_____________________________________________________________________________________________________________

319
src/ao_tc_eff_map/one_e_1bgauss_nonherm.irp.f Normal file
View File

@ -0,0 +1,319 @@
BEGIN_PROVIDER [ double precision, j1b_gauss_nonherm, (ao_num,ao_num)]
BEGIN_DOC
!
! Hermitian part of 1-body Jastrow factow in the |AO| basis set.
!
! \langle \chi_i | - grad \tau_{1b} \cdot grad | \chi_j \rangle =
! 2 \sum_A aA \langle \chi_i | exp[-aA riA^2] (ri-rA) \cdot grad | \chi_j \rangle
!
END_DOC
implicit none
integer :: num_A, num_B
integer :: power_A(3), power_B(3)
integer :: i, j, k, l, m
double precision :: alpha, beta, gama
double precision :: A_center(3), B_center(3), C_center(3)
double precision :: c1, c
integer :: dim1
double precision :: overlap_y, d_a_2, overlap_z, overlap
double precision :: int_gauss_deriv
PROVIDE j1b_gauss_pen
! --------------------------------------------------------------------------------
! -- Dummy call to provide everything
dim1 = 100
A_center(:) = 0.d0
B_center(:) = 1.d0
alpha = 1.d0
beta = 0.1d0
power_A(:) = 1
power_B(:) = 0
call overlap_gaussian_xyz( A_center, B_center, alpha, beta, power_A, power_B &
, overlap_y, d_a_2, overlap_z, overlap, dim1 )
! --------------------------------------------------------------------------------
j1b_gauss_nonherm(1:ao_num,1:ao_num) = 0.d0
!$OMP PARALLEL &
!$OMP DEFAULT (NONE) &
!$OMP PRIVATE (i, j, k, l, m, alpha, beta, gama, &
!$OMP A_center, B_center, C_center, power_A, power_B, &
!$OMP num_A, num_B, c1, c) &
!$OMP SHARED (ao_num, ao_prim_num, ao_expo_ordered_transp, &
!$OMP ao_power, ao_nucl, nucl_coord, &
!$OMP ao_coef_normalized_ordered_transp, &
!$OMP nucl_num, j1b_gauss_pen, j1b_gauss_nonherm)
!$OMP DO SCHEDULE (dynamic)
do j = 1, ao_num
num_A = ao_nucl(j)
power_A(1:3) = ao_power(j,1:3)
A_center(1:3) = nucl_coord(num_A,1:3)
do i = 1, ao_num
num_B = ao_nucl(i)
power_B(1:3) = ao_power(i,1:3)
B_center(1:3) = nucl_coord(num_B,1:3)
do l = 1, ao_prim_num(j)
alpha = ao_expo_ordered_transp(l,j)
do m = 1, ao_prim_num(i)
beta = ao_expo_ordered_transp(m,i)
c = 0.d0
do k = 1, nucl_num
gama = j1b_gauss_pen(k)
C_center(1:3) = nucl_coord(k,1:3)
! \langle \chi_A | exp[-gama r_C^2] r_C \cdot grad | \chi_B \rangle
c1 = int_gauss_deriv( A_center, B_center, C_center &
, power_A, power_B, alpha, beta, gama )
c = c + 2.d0 * gama * c1
enddo
j1b_gauss_nonherm(i,j) = j1b_gauss_nonherm(i,j) &
+ ao_coef_normalized_ordered_transp(l,j) &
* ao_coef_normalized_ordered_transp(m,i) * c
enddo
enddo
enddo
enddo
!$OMP END DO
!$OMP END PARALLEL
END_PROVIDER
!_____________________________________________________________________________________________________________
!
! < XA | exp[-gama r_C^2] r_C \cdot grad | XB >
!
double precision function int_gauss_deriv(A_center, B_center, C_center, power_A, power_B, alpha, beta, gama)
! for max_dim
include 'constants.include.F'
implicit none
double precision, intent(in) :: A_center(3), B_center(3), C_center(3)
integer , intent(in) :: power_A(3), power_B(3)
double precision, intent(in) :: alpha, beta, gama
integer :: i, power_C, dim1
integer :: iorder(3), power_D(3)
double precision :: AB_expo
double precision :: fact_AB, center_AB(3), pol_AB(0:max_dim,3)
double precision :: cx, cy, cz
double precision :: overlap_gaussian_x
dim1 = 100
int_gauss_deriv = 0.d0
! ===============
! term I:
! \partial_x
! ===============
if( power_B(1) .ge. 1 ) then
power_D(1) = power_B(1) - 1
power_D(2) = power_B(2)
power_D(3) = power_B(3)
call give_explicit_poly_and_gaussian( pol_AB, center_AB, AB_expo, fact_AB &
, iorder, alpha, beta, power_A, power_D, A_center, B_center, dim1)
power_C = 1
cx = 0.d0
do i = 0, iorder(1)
cx = cx + pol_AB(i,1) * overlap_gaussian_x( center_AB(1), C_center(1), AB_expo, gama, i, power_C, dim1)
enddo
power_C = 0
cy = 0.d0
do i = 0, iorder(2)
cy = cy + pol_AB(i,2) * overlap_gaussian_x( center_AB(2), C_center(2), AB_expo, gama, i, power_C, dim1)
enddo
power_C = 0
cz = 0.d0
do i = 0, iorder(3)
cz = cz + pol_AB(i,3) * overlap_gaussian_x( center_AB(3), C_center(3), AB_expo, gama, i, power_C, dim1)
enddo
int_gauss_deriv = int_gauss_deriv + fact_AB * dble(power_B(1)) * cx * cy * cz
endif
! ===============
power_D(1) = power_B(1) + 1
power_D(2) = power_B(2)
power_D(3) = power_B(3)
call give_explicit_poly_and_gaussian( pol_AB, center_AB, AB_expo, fact_AB &
, iorder, alpha, beta, power_A, power_D, A_center, B_center, dim1)
power_C = 1
cx = 0.d0
do i = 0, iorder(1)
cx = cx + pol_AB(i,1) * overlap_gaussian_x( center_AB(1), C_center(1), AB_expo, gama, i, power_C, dim1)
enddo
power_C = 0
cy = 0.d0
do i = 0, iorder(2)
cy = cy + pol_AB(i,2) * overlap_gaussian_x( center_AB(2), C_center(2), AB_expo, gama, i, power_C, dim1)
enddo
power_C = 0
cz = 0.d0
do i = 0, iorder(3)
cz = cz + pol_AB(i,3) * overlap_gaussian_x( center_AB(3), C_center(3), AB_expo, gama, i, power_C, dim1)
enddo
int_gauss_deriv = int_gauss_deriv - 2.d0 * beta * fact_AB * cx * cy * cz
! ===============
! ===============
! ===============
! term II:
! \partial_y
! ===============
if( power_B(2) .ge. 1 ) then
power_D(1) = power_B(1)
power_D(2) = power_B(2) - 1
power_D(3) = power_B(3)
call give_explicit_poly_and_gaussian( pol_AB, center_AB, AB_expo, fact_AB &
, iorder, alpha, beta, power_A, power_D, A_center, B_center, dim1)
power_C = 0
cx = 0.d0
do i = 0, iorder(1)
cx = cx + pol_AB(i,1) * overlap_gaussian_x( center_AB(1), C_center(1), AB_expo, gama, i, power_C, dim1)
enddo
power_C = 1
cy = 0.d0
do i = 0, iorder(2)
cy = cy + pol_AB(i,2) * overlap_gaussian_x( center_AB(2), C_center(2), AB_expo, gama, i, power_C, dim1)
enddo
power_C = 0
cz = 0.d0
do i = 0, iorder(3)
cz = cz + pol_AB(i,3) * overlap_gaussian_x( center_AB(3), C_center(3), AB_expo, gama, i, power_C, dim1)
enddo
int_gauss_deriv = int_gauss_deriv + fact_AB * dble(power_B(2)) * cx * cy * cz
endif
! ===============
power_D(1) = power_B(1)
power_D(2) = power_B(2) + 1
power_D(3) = power_B(3)
call give_explicit_poly_and_gaussian( pol_AB, center_AB, AB_expo, fact_AB &
, iorder, alpha, beta, power_A, power_D, A_center, B_center, dim1)
power_C = 0
cx = 0.d0
do i = 0, iorder(1)
cx = cx + pol_AB(i,1) * overlap_gaussian_x( center_AB(1), C_center(1), AB_expo, gama, i, power_C, dim1)
enddo
power_C = 1
cy = 0.d0
do i = 0, iorder(2)
cy = cy + pol_AB(i,2) * overlap_gaussian_x( center_AB(2), C_center(2), AB_expo, gama, i, power_C, dim1)
enddo
power_C = 0
cz = 0.d0
do i = 0, iorder(3)
cz = cz + pol_AB(i,3) * overlap_gaussian_x( center_AB(3), C_center(3), AB_expo, gama, i, power_C, dim1)
enddo
int_gauss_deriv = int_gauss_deriv - 2.d0 * beta * fact_AB * cx * cy * cz
! ===============
! ===============
! ===============
! term III:
! \partial_z
! ===============
if( power_B(3) .ge. 1 ) then
power_D(1) = power_B(1)
power_D(2) = power_B(2)
power_D(3) = power_B(3) - 1
call give_explicit_poly_and_gaussian( pol_AB, center_AB, AB_expo, fact_AB &
, iorder, alpha, beta, power_A, power_D, A_center, B_center, dim1)
power_C = 0
cx = 0.d0
do i = 0, iorder(1)
cx = cx + pol_AB(i,1) * overlap_gaussian_x( center_AB(1), C_center(1), AB_expo, gama, i, power_C, dim1)
enddo
power_C = 0
cy = 0.d0
do i = 0, iorder(2)
cy = cy + pol_AB(i,2) * overlap_gaussian_x( center_AB(2), C_center(2), AB_expo, gama, i, power_C, dim1)
enddo
power_C = 1
cz = 0.d0
do i = 0, iorder(3)
cz = cz + pol_AB(i,3) * overlap_gaussian_x( center_AB(3), C_center(3), AB_expo, gama, i, power_C, dim1)
enddo
int_gauss_deriv = int_gauss_deriv + fact_AB * dble(power_B(3)) * cx * cy * cz
endif
! ===============
power_D(1) = power_B(1)
power_D(2) = power_B(2)
power_D(3) = power_B(3) + 1
call give_explicit_poly_and_gaussian( pol_AB, center_AB, AB_expo, fact_AB &
, iorder, alpha, beta, power_A, power_D, A_center, B_center, dim1)
power_C = 0
cx = 0.d0
do i = 0, iorder(1)
cx = cx + pol_AB(i,1) * overlap_gaussian_x( center_AB(1), C_center(1), AB_expo, gama, i, power_C, dim1)
enddo
power_C = 0
cy = 0.d0
do i = 0, iorder(2)
cy = cy + pol_AB(i,2) * overlap_gaussian_x( center_AB(2), C_center(2), AB_expo, gama, i, power_C, dim1)
enddo
power_C = 1
cz = 0.d0
do i = 0, iorder(3)
cz = cz + pol_AB(i,3) * overlap_gaussian_x( center_AB(3), C_center(3), AB_expo, gama, i, power_C, dim1)
enddo
int_gauss_deriv = int_gauss_deriv - 2.d0 * beta * fact_AB * cx * cy * cz
! ===============
! ===============
return
end function int_gauss_deriv
!_____________________________________________________________________________________________________________
!_____________________________________________________________________________________________________________

203
src/ao_tc_eff_map/potential.irp.f Normal file
View File

@ -0,0 +1,203 @@
BEGIN_PROVIDER [integer, n_gauss_eff_pot]
implicit none
BEGIN_DOC
! number of gaussians to represent the effective potential :
!
! V(mu,r12) = -0.25 * (1 - erf(mu*r12))^2 + 1/(\sqrt(pi)mu) * exp(-(mu*r12)^2)
!
! Here (1 - erf(mu*r12))^2 is expanded in Gaussians as Eqs A11-A20 in JCP 154, 084119 (2021)
END_DOC
n_gauss_eff_pot = n_max_fit_slat + 1
END_PROVIDER
BEGIN_PROVIDER [integer, n_gauss_eff_pot_deriv]
implicit none
BEGIN_DOC
! V(r12) = -(1 - erf(mu*r12))^2 is expanded in Gaussians as Eqs A11-A20 in JCP 154, 084119 (2021)
END_DOC
n_gauss_eff_pot_deriv = n_max_fit_slat
END_PROVIDER
BEGIN_PROVIDER [double precision, expo_gauss_eff_pot, (n_gauss_eff_pot)]
&BEGIN_PROVIDER [double precision, coef_gauss_eff_pot, (n_gauss_eff_pot)]
implicit none
BEGIN_DOC
! Coefficients and exponents of the Fit on Gaussians of V(X) = -(1 - erf(mu*X))^2 + 1/(\sqrt(pi)mu) * exp(-(mu*X)^2)
!
! V(X) = \sum_{i=1,n_gauss_eff_pot} coef_gauss_eff_pot(i) * exp(-expo_gauss_eff_pot(i) * X^2)
!
! Relies on the fit proposed in Eqs A11-A20 in JCP 154, 084119 (2021)
END_DOC
include 'constants.include.F'
integer :: i
! fit of the -0.25 * (1 - erf(mu*x))^2 with n_max_fit_slat gaussians
do i = 1, n_max_fit_slat
expo_gauss_eff_pot(i) = expo_gauss_1_erf_x_2(i)
coef_gauss_eff_pot(i) = -0.25d0 * coef_gauss_1_erf_x_2(i) ! -1/4 * (1 - erf(mu*x))^2
enddo
! Analytical Gaussian part of the potential: + 1/(\sqrt(pi)mu) * exp(-(mu*x)^2)
expo_gauss_eff_pot(n_max_fit_slat+1) = mu_erf * mu_erf
coef_gauss_eff_pot(n_max_fit_slat+1) = 1.d0 * mu_erf * inv_sq_pi
END_PROVIDER
double precision function eff_pot_gauss(x,mu)
implicit none
BEGIN_DOC
! V(mu,r12) = -0.25 * (1 - erf(mu*r12))^2 + 1/(\sqrt(pi)mu) * exp(-(mu*r12)^2)
END_DOC
double precision, intent(in) :: x,mu
eff_pot_gauss = mu/dsqrt(dacos(-1.d0)) * dexp(-mu*mu*x*x) - 0.25d0 * (1.d0 - derf(mu*x))**2.d0
end
! -------------------------------------------------------------------------------------------------
! ---
double precision function eff_pot_fit_gauss(x)
implicit none
BEGIN_DOC
! V(mu,r12) = -0.25 * (1 - erf(mu*r12))^2 + 1/(\sqrt(pi)mu) * exp(-(mu*r12)^2)
!
! but fitted with gaussians
END_DOC
double precision, intent(in) :: x
integer :: i
double precision :: alpha
eff_pot_fit_gauss = derf(mu_erf*x)/x
do i = 1, n_gauss_eff_pot
alpha = expo_gauss_eff_pot(i)
eff_pot_fit_gauss += coef_gauss_eff_pot(i) * dexp(-alpha*x*x)
enddo
end
BEGIN_PROVIDER [integer, n_fit_1_erf_x]
implicit none
BEGIN_DOC
!
END_DOC
n_fit_1_erf_x = 2
END_PROVIDER
BEGIN_PROVIDER [double precision, expos_slat_gauss_1_erf_x, (n_fit_1_erf_x)]
implicit none
BEGIN_DOC
! 1 - erf(mu*x) is fitted with a Slater and gaussian as in Eq.A15 of JCP 154, 084119 (2021)
!
! 1 - erf(mu*x) = e^{-expos_slat_gauss_1_erf_x(1) * mu *x} * e^{-expos_slat_gauss_1_erf_x(2) * mu^2 * x^2}
END_DOC
expos_slat_gauss_1_erf_x(1) = 1.09529d0
expos_slat_gauss_1_erf_x(2) = 0.756023d0
END_PROVIDER
BEGIN_PROVIDER [double precision, expo_gauss_1_erf_x, (n_max_fit_slat)]
&BEGIN_PROVIDER [double precision, coef_gauss_1_erf_x, (n_max_fit_slat)]
implicit none
BEGIN_DOC
! (1 - erf(mu*x)) = \sum_i coef_gauss_1_erf_x(i) * exp(-expo_gauss_1_erf_x(i) * x^2)
!
! This is based on a fit of (1 - erf(mu*x)) by exp(-alpha * x) exp(-beta*mu^2x^2)
!
! and the slater function exp(-alpha * x) is fitted with n_max_fit_slat gaussians
!
! See Appendix 2 of JCP 154, 084119 (2021)
END_DOC
integer :: i
double precision :: expos(n_max_fit_slat),alpha,beta
alpha = expos_slat_gauss_1_erf_x(1) * mu_erf
call expo_fit_slater_gam(alpha,expos)
beta = expos_slat_gauss_1_erf_x(2) * mu_erf**2.d0
do i = 1, n_max_fit_slat
expo_gauss_1_erf_x(i) = expos(i) + beta
coef_gauss_1_erf_x(i) = coef_fit_slat_gauss(i)
enddo
END_PROVIDER
double precision function fit_1_erf_x(x)
implicit none
double precision, intent(in) :: x
BEGIN_DOC
! fit_1_erf_x(x) = \sum_i c_i exp (-alpha_i x^2) \approx (1 - erf(mu*x))
END_DOC
integer :: i
fit_1_erf_x = 0.d0
do i = 1, n_max_fit_slat
fit_1_erf_x += dexp(-expo_gauss_1_erf_x(i) *x*x) * coef_gauss_1_erf_x(i)
enddo
end
BEGIN_PROVIDER [double precision, expo_gauss_1_erf_x_2, (n_max_fit_slat)]
&BEGIN_PROVIDER [double precision, coef_gauss_1_erf_x_2, (n_max_fit_slat)]
implicit none
BEGIN_DOC
! (1 - erf(mu*x))^2 = \sum_i coef_gauss_1_erf_x_2(i) * exp(-expo_gauss_1_erf_x_2(i) * x^2)
!
! This is based on a fit of (1 - erf(mu*x)) by exp(-alpha * x) exp(-beta*mu^2x^2)
!
! and the slater function exp(-alpha * x) is fitted with n_max_fit_slat gaussians
END_DOC
integer :: i
double precision :: expos(n_max_fit_slat),alpha,beta
alpha = 2.d0 * expos_slat_gauss_1_erf_x(1) * mu_erf
call expo_fit_slater_gam(alpha,expos)
beta = 2.d0 * expos_slat_gauss_1_erf_x(2) * mu_erf**2.d0
do i = 1, n_max_fit_slat
expo_gauss_1_erf_x_2(i) = expos(i) + beta
coef_gauss_1_erf_x_2(i) = coef_fit_slat_gauss(i)
enddo
END_PROVIDER
double precision function fit_1_erf_x_2(x)
implicit none
double precision, intent(in) :: x
BEGIN_DOC
! fit_1_erf_x_2(x) = \sum_i c_i exp (-alpha_i x^2) \approx (1 - erf(mu*x))^2
END_DOC
integer :: i
fit_1_erf_x_2 = 0.d0
do i = 1, n_max_fit_slat
fit_1_erf_x_2 += dexp(-expo_gauss_1_erf_x_2(i) *x*x) * coef_gauss_1_erf_x_2(i)
enddo
end
subroutine inv_r_times_poly(r, dist_r, dist_vec, poly)
implicit none
BEGIN_DOC
! returns
!
! poly(1) = x / sqrt(x^2+y^2+z^2), poly(2) = y / sqrt(x^2+y^2+z^2), poly(3) = z / sqrt(x^2+y^2+z^2)
!
! with the arguments
!
! r(1) = x, r(2) = y, r(3) = z, dist_r = sqrt(x^2+y^2+z^2)
!
! dist_vec(1) = sqrt(y^2+z^2), dist_vec(2) = sqrt(x^2+z^2), dist_vec(3) = sqrt(x^2+y^2)
END_DOC
double precision, intent(in) :: r(3), dist_r, dist_vec(3)
double precision, intent(out):: poly(3)
double precision :: inv_dist
integer :: i
if (dist_r.gt. 1.d-8)then
inv_dist = 1.d0/dist_r
do i = 1, 3
poly(i) = r(i) * inv_dist
enddo
else
do i = 1, 3
if(dabs(r(i)).lt.dist_vec(i))then
inv_dist = 1.d0/dist_r
poly(i) = r(i) * inv_dist
else !if(dabs(r(i)))then
poly(i) = 1.d0
! poly(i) = 0.d0
endif
enddo
endif
end

86
src/ao_tc_eff_map/providers_ao_eff_pot.irp.f Normal file
View File

@ -0,0 +1,86 @@
BEGIN_PROVIDER [ logical, ao_tc_sym_two_e_pot_in_map ]
implicit none
use f77_zmq
use map_module
BEGIN_DOC
! Map of Atomic integrals
! i(r1) j(r2) 1/r12 k(r1) l(r2)
END_DOC
integer :: i,j,k,l
double precision :: ao_tc_sym_two_e_pot,cpu_1,cpu_2, wall_1, wall_2
double precision :: integral, wall_0
include 'utils/constants.include.F'
! For integrals file
integer(key_kind),allocatable :: buffer_i(:)
integer,parameter :: size_buffer = 1024*64
real(integral_kind),allocatable :: buffer_value(:)
integer :: n_integrals, rc
integer :: kk, m, j1, i1, lmax
character*(64) :: fmt
!double precision :: j1b_gauss_coul_debug
!integral = j1b_gauss_coul_debug(1,1,1,1)
integral = ao_tc_sym_two_e_pot(1,1,1,1)
double precision :: map_mb
print*, 'Providing the ao_tc_sym_two_e_pot_map integrals'
call wall_time(wall_0)
call wall_time(wall_1)
call cpu_time(cpu_1)
integer(ZMQ_PTR) :: zmq_to_qp_run_socket, zmq_socket_pull
call new_parallel_job(zmq_to_qp_run_socket,zmq_socket_pull,'ao_tc_sym_two_e_pot')
character(len=:), allocatable :: task
allocate(character(len=ao_num*12) :: task)
write(fmt,*) '(', ao_num, '(I5,X,I5,''|''))'
do l=1,ao_num
write(task,fmt) (i,l, i=1,l)
integer, external :: add_task_to_taskserver
if (add_task_to_taskserver(zmq_to_qp_run_socket,trim(task)) == -1) then
stop 'Unable to add task to server'
endif
enddo
deallocate(task)
integer, external :: zmq_set_running
if (zmq_set_running(zmq_to_qp_run_socket) == -1) then
print *, irp_here, ': Failed in zmq_set_running'
endif
PROVIDE nproc
!$OMP PARALLEL DEFAULT(shared) private(i) num_threads(nproc+1)
i = omp_get_thread_num()
if (i==0) then
call ao_tc_sym_two_e_pot_in_map_collector(zmq_socket_pull)
else
call ao_tc_sym_two_e_pot_in_map_slave_inproc(i)
endif
!$OMP END PARALLEL
call end_parallel_job(zmq_to_qp_run_socket, zmq_socket_pull, 'ao_tc_sym_two_e_pot')
print*, 'Sorting the map'
call map_sort(ao_tc_sym_two_e_pot_map)
call cpu_time(cpu_2)
call wall_time(wall_2)
integer(map_size_kind) :: get_ao_tc_sym_two_e_pot_map_size, ao_eff_pot_map_size
ao_eff_pot_map_size = get_ao_tc_sym_two_e_pot_map_size()
print*, 'AO eff_pot integrals provided:'
print*, ' Size of AO eff_pot map : ', map_mb(ao_tc_sym_two_e_pot_map) ,'MB'
print*, ' Number of AO eff_pot integrals :', ao_eff_pot_map_size
print*, ' cpu time :',cpu_2 - cpu_1, 's'
print*, ' wall time :',wall_2 - wall_1, 's ( x ', (cpu_2-cpu_1)/(wall_2-wall_1+tiny(1.d0)), ' )'
ao_tc_sym_two_e_pot_in_map = .True.
END_PROVIDER

800
src/ao_tc_eff_map/two_e_1bgauss_coul.irp.f Normal file
View File

@ -0,0 +1,800 @@
double precision function j1b_gauss_coul(i, j, k, l)
BEGIN_DOC
!
! integral in the AO basis:
! i(r1) j(r1) f(r12) k(r2) l(r2)
!
! with:
! f(r12) = - [ 0.5 / r12 ] (r1-r2) \cdot \sum_A (-2 a_A) [ r1A exp(-aA r1A^2) - r2A exp(-aA r2A^2) ]
! = [ 1 / r12 ] \sum_A a_A [ (r1-RA)^2 exp(-aA r1A^2)
! + (r2-RA)^2 exp(-aA r2A^2)
! - (r1-RA) \cdot (r2-RA) exp(-aA r1A^2)
! - (r1-RA) \cdot (r2-RA) exp(-aA r2A^2) ]
!
END_DOC
include 'utils/constants.include.F'
implicit none
integer, intent(in) :: i, j, k, l
integer :: p, q, r, s, ii
integer :: num_i, num_j, num_k, num_l, num_ii
integer :: I_power(3), J_power(3), K_power(3), L_power(3)
integer :: iorder_p(3), iorder_q(3)
integer :: shift_P(3), shift_Q(3)
integer :: dim1
double precision :: coef1, coef2, coef3, coef4
double precision :: expo1, expo2, expo3, expo4
double precision :: p_inv, q_inv
double precision :: P_new_tmp(0:max_dim,3), P_center_tmp(3), fact_p_tmp, pp_tmp
double precision :: Q_new_tmp(0:max_dim,3), Q_center_tmp(3), fact_q_tmp, qq_tmp
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 :: I_center(3), J_center(3), K_center(3), L_center(3)
double precision :: expoii, factii, Centerii(3)
double precision :: ff, gg, cx, cy, cz
double precision :: general_primitive_integral_coul_shifted
PROVIDE j1b_gauss_pen
dim1 = n_pt_max_integrals
num_i = ao_nucl(i)
num_j = ao_nucl(j)
num_k = ao_nucl(k)
num_l = ao_nucl(l)
do p = 1, 3
I_power(p) = ao_power(i,p)
J_power(p) = ao_power(j,p)
K_power(p) = ao_power(k,p)
L_power(p) = ao_power(l,p)
I_center(p) = nucl_coord(num_i,p)
J_center(p) = nucl_coord(num_j,p)
K_center(p) = nucl_coord(num_k,p)
L_center(p) = nucl_coord(num_l,p)
enddo
j1b_gauss_coul = 0.d0
! -------------------------------------------------------------------------------------------------------------------
!
! [ 1 / r12 ] \sum_A a_A [ (r1-RA)^2 exp(-aA r1A^2)
!
! -------------------------------------------------------------------------------------------------------------------
shift_Q = (/ 0, 0, 0 /)
do p = 1, ao_prim_num(i)
coef1 = ao_coef_normalized_ordered_transp(p, i)
expo1 = ao_expo_ordered_transp(p, i)
do q = 1, ao_prim_num(j)
coef2 = coef1 * ao_coef_normalized_ordered_transp(q, j)
expo2 = ao_expo_ordered_transp(q, j)
call give_explicit_poly_and_gaussian( P_new_tmp, P_center_tmp, pp_tmp, fact_p_tmp, iorder_p, expo1, expo2 &
, I_power, J_power, I_center, J_center, dim1 )
do r = 1, ao_prim_num(k)
coef3 = coef2 * ao_coef_normalized_ordered_transp(r, k)
expo3 = ao_expo_ordered_transp(r, k)
do s = 1, ao_prim_num(l)
coef4 = coef3 * ao_coef_normalized_ordered_transp(s, l)
expo4 = ao_expo_ordered_transp(s, l)
call give_explicit_poly_and_gaussian( Q_new, Q_center, qq, fact_q, iorder_q, expo3, expo4 &
, K_power, L_power, K_center, L_center, dim1 )
q_inv = 1.d0 / qq
cx = 0.d0
cy = 0.d0
cz = 0.d0
do ii = 1, nucl_num
expoii = j1b_gauss_pen(ii)
Centerii(1:3) = nucl_coord(ii, 1:3)
call gaussian_product(pp_tmp, P_center_tmp, expoii, Centerii, factii, pp, P_center)
fact_p = fact_p_tmp * factii
p_inv = 1.d0 / pp
! pol centerd on P_center_tmp ==> centerd on P_center
call pol_modif_center( P_center_tmp, P_center, iorder_p, P_new_tmp, P_new)
! ----------------------------------------------------------------------------------------------------
! x term:
ff = P_center(1) - Centerii(1)
shift_P = (/ 2, 0, 0 /)
cx = cx + expoii * general_primitive_integral_coul_shifted( dim1 &
, P_new, P_center, fact_p, pp, p_inv, iorder_p, shift_P &
, Q_new, Q_center, fact_q, qq, q_inv, iorder_q, shift_Q )
shift_P = (/ 1, 0, 0 /)
cx = cx + expoii * 2.d0 * ff * general_primitive_integral_coul_shifted( dim1 &
, P_new, P_center, fact_p, pp, p_inv, iorder_p, shift_P &
, Q_new, Q_center, fact_q, qq, q_inv, iorder_q, shift_Q )
shift_P = (/ 0, 0, 0 /)
cx = cx + expoii * ff * ff * general_primitive_integral_coul_shifted( dim1 &
, P_new, P_center, fact_p, pp, p_inv, iorder_p, shift_P &
, Q_new, Q_center, fact_q, qq, q_inv, iorder_q, shift_Q )
! ----------------------------------------------------------------------------------------------------
! ----------------------------------------------------------------------------------------------------
! y term:
ff = P_center(2) - Centerii(2)
shift_P = (/ 0, 2, 0 /)
cy = cy + expoii * general_primitive_integral_coul_shifted( dim1 &
, P_new, P_center, fact_p, pp, p_inv, iorder_p, shift_P &
, Q_new, Q_center, fact_q, qq, q_inv, iorder_q, shift_Q )
shift_P = (/ 0, 1, 0 /)
cy = cy + expoii * 2.d0 * ff * general_primitive_integral_coul_shifted( dim1 &
, P_new, P_center, fact_p, pp, p_inv, iorder_p, shift_P &
, Q_new, Q_center, fact_q, qq, q_inv, iorder_q, shift_Q )
shift_P = (/ 0, 0, 0 /)
cy = cy + expoii * ff * ff * general_primitive_integral_coul_shifted( dim1 &
, P_new, P_center, fact_p, pp, p_inv, iorder_p, shift_P &
, Q_new, Q_center, fact_q, qq, q_inv, iorder_q, shift_Q )
! ----------------------------------------------------------------------------------------------------
! ----------------------------------------------------------------------------------------------------
! z term:
ff = P_center(3) - Centerii(3)
shift_P = (/ 0, 0, 2 /)
cz = cz + expoii * general_primitive_integral_coul_shifted( dim1 &
, P_new, P_center, fact_p, pp, p_inv, iorder_p, shift_P &
, Q_new, Q_center, fact_q, qq, q_inv, iorder_q, shift_Q )
shift_P = (/ 0, 0, 1 /)
cz = cz + expoii * 2.d0 * ff * general_primitive_integral_coul_shifted( dim1 &
, P_new, P_center, fact_p, pp, p_inv, iorder_p, shift_P &
, Q_new, Q_center, fact_q, qq, q_inv, iorder_q, shift_Q )
shift_P = (/ 0, 0, 0 /)
cz = cz + expoii * ff * ff * general_primitive_integral_coul_shifted( dim1 &
, P_new, P_center, fact_p, pp, p_inv, iorder_p, shift_P &
, Q_new, Q_center, fact_q, qq, q_inv, iorder_q, shift_Q )
! ----------------------------------------------------------------------------------------------------
enddo
j1b_gauss_coul = j1b_gauss_coul + coef4 * ( cx + cy + cz )
enddo ! s
enddo ! r
enddo ! q
enddo ! p
! -------------------------------------------------------------------------------------------------------------------
! -------------------------------------------------------------------------------------------------------------------
! -------------------------------------------------------------------------------------------------------------------
!
! [ 1 / r12 ] \sum_A a_A [ (r2-RA)^2 exp(-aA r2A^2)
!
! -------------------------------------------------------------------------------------------------------------------
shift_P = (/ 0, 0, 0 /)
do p = 1, ao_prim_num(i)
coef1 = ao_coef_normalized_ordered_transp(p, i)
expo1 = ao_expo_ordered_transp(p, i)
do q = 1, ao_prim_num(j)
coef2 = coef1 * ao_coef_normalized_ordered_transp(q, j)
expo2 = ao_expo_ordered_transp(q, j)
call give_explicit_poly_and_gaussian( P_new, P_center, pp, fact_p, iorder_p, expo1, expo2 &
, I_power, J_power, I_center, J_center, dim1 )
p_inv = 1.d0 / pp
do r = 1, ao_prim_num(k)
coef3 = coef2 * ao_coef_normalized_ordered_transp(r, k)
expo3 = ao_expo_ordered_transp(r, k)
do s = 1, ao_prim_num(l)
coef4 = coef3 * ao_coef_normalized_ordered_transp(s, l)
expo4 = ao_expo_ordered_transp(s, l)
call give_explicit_poly_and_gaussian( Q_new_tmp, Q_center_tmp, qq_tmp, fact_q_tmp, iorder_q, expo3, expo4 &
, K_power, L_power, K_center, L_center, dim1 )
cx = 0.d0
cy = 0.d0
cz = 0.d0
do ii = 1, nucl_num
expoii = j1b_gauss_pen(ii)
Centerii(1:3) = nucl_coord(ii, 1:3)
call gaussian_product(qq_tmp, Q_center_tmp, expoii, Centerii, factii, qq, Q_center)
fact_q = fact_q_tmp * factii
q_inv = 1.d0 / qq
! pol centerd on Q_center_tmp ==> centerd on Q_center
call pol_modif_center( Q_center_tmp, Q_center, iorder_q, Q_new_tmp, Q_new)
! ----------------------------------------------------------------------------------------------------
! x term:
ff = Q_center(1) - Centerii(1)
shift_Q = (/ 2, 0, 0 /)
cx = cx + expoii * general_primitive_integral_coul_shifted( dim1 &
, P_new, P_center, fact_p, pp, p_inv, iorder_p, shift_P &
, Q_new, Q_center, fact_q, qq, q_inv, iorder_q, shift_Q )
shift_Q = (/ 1, 0, 0 /)
cx = cx + expoii * 2.d0 * ff * general_primitive_integral_coul_shifted( dim1 &
, P_new, P_center, fact_p, pp, p_inv, iorder_p, shift_P &
, Q_new, Q_center, fact_q, qq, q_inv, iorder_q, shift_Q )
shift_Q = (/ 0, 0, 0 /)
cx = cx + expoii * ff * ff * general_primitive_integral_coul_shifted( dim1 &
, P_new, P_center, fact_p, pp, p_inv, iorder_p, shift_P &
, Q_new, Q_center, fact_q, qq, q_inv, iorder_q, shift_Q )
! ----------------------------------------------------------------------------------------------------
! ----------------------------------------------------------------------------------------------------
! y term:
ff = Q_center(2) - Centerii(2)
shift_Q = (/ 0, 2, 0 /)
cy = cy + expoii * general_primitive_integral_coul_shifted( dim1 &
, P_new, P_center, fact_p, pp, p_inv, iorder_p, shift_P &
, Q_new, Q_center, fact_q, qq, q_inv, iorder_q, shift_Q )
shift_Q = (/ 0, 1, 0 /)
cy = cy + expoii * 2.d0 * ff * general_primitive_integral_coul_shifted( dim1 &
, P_new, P_center, fact_p, pp, p_inv, iorder_p, shift_P &
, Q_new, Q_center, fact_q, qq, q_inv, iorder_q, shift_Q )
shift_Q = (/ 0, 0, 0 /)
cy = cy + expoii * ff * ff * general_primitive_integral_coul_shifted( dim1 &
, P_new, P_center, fact_p, pp, p_inv, iorder_p, shift_P &
, Q_new, Q_center, fact_q, qq, q_inv, iorder_q, shift_Q )
! ----------------------------------------------------------------------------------------------------
! ----------------------------------------------------------------------------------------------------
! z term:
ff = Q_center(3) - Centerii(3)
shift_Q = (/ 0, 0, 2 /)
cz = cz + expoii * general_primitive_integral_coul_shifted( dim1 &
, P_new, P_center, fact_p, pp, p_inv, iorder_p, shift_P &
, Q_new, Q_center, fact_q, qq, q_inv, iorder_q, shift_Q )
shift_Q = (/ 0, 0, 1 /)
cz = cz + expoii * 2.d0 * ff * general_primitive_integral_coul_shifted( dim1 &
, P_new, P_center, fact_p, pp, p_inv, iorder_p, shift_P &
, Q_new, Q_center, fact_q, qq, q_inv, iorder_q, shift_Q )
shift_Q = (/ 0, 0, 0 /)
cz = cz + expoii * ff * ff * general_primitive_integral_coul_shifted( dim1 &
, P_new, P_center, fact_p, pp, p_inv, iorder_p, shift_P &
, Q_new, Q_center, fact_q, qq, q_inv, iorder_q, shift_Q )
! ----------------------------------------------------------------------------------------------------
enddo
j1b_gauss_coul = j1b_gauss_coul + coef4 * ( cx + cy + cz )
enddo ! s
enddo ! r
enddo ! q
enddo ! p
! -------------------------------------------------------------------------------------------------------------------
! -------------------------------------------------------------------------------------------------------------------
! -------------------------------------------------------------------------------------------------------------------
!
! - [ 1 / r12 ] \sum_A a_A [ (r1-RA) \cdot (r2-RA) exp(-aA r1A^2) ]
!
! -------------------------------------------------------------------------------------------------------------------
do p = 1, ao_prim_num(i)
coef1 = ao_coef_normalized_ordered_transp(p, i)
expo1 = ao_expo_ordered_transp(p, i)
do q = 1, ao_prim_num(j)
coef2 = coef1 * ao_coef_normalized_ordered_transp(q, j)
expo2 = ao_expo_ordered_transp(q, j)
call give_explicit_poly_and_gaussian( P_new_tmp, P_center_tmp, pp_tmp, fact_p_tmp, iorder_p, expo1, expo2 &
, I_power, J_power, I_center, J_center, dim1 )
do r = 1, ao_prim_num(k)
coef3 = coef2 * ao_coef_normalized_ordered_transp(r, k)
expo3 = ao_expo_ordered_transp(r, k)
do s = 1, ao_prim_num(l)
coef4 = coef3 * ao_coef_normalized_ordered_transp(s, l)
expo4 = ao_expo_ordered_transp(s, l)
call give_explicit_poly_and_gaussian( Q_new, Q_center, qq, fact_q, iorder_q, expo3, expo4 &
, K_power, L_power, K_center, L_center, dim1 )
q_inv = 1.d0 / qq
cx = 0.d0
cy = 0.d0
cz = 0.d0
do ii = 1, nucl_num
expoii = j1b_gauss_pen(ii)
Centerii(1:3) = nucl_coord(ii, 1:3)
call gaussian_product(pp_tmp, P_center_tmp, expoii, Centerii, factii, pp, P_center)
fact_p = fact_p_tmp * factii
p_inv = 1.d0 / pp
! pol centerd on P_center_tmp ==> centerd on P_center
call pol_modif_center( P_center_tmp, P_center, iorder_p, P_new_tmp, P_new)
! ----------------------------------------------------------------------------------------------------
! x term:
ff = P_center(1) - Centerii(1)
gg = Q_center(1) - Centerii(1)
shift_p = (/ 1, 0, 0 /)
shift_Q = (/ 1, 0, 0 /)
cx = cx + expoii * general_primitive_integral_coul_shifted( dim1 &
, P_new, P_center, fact_p, pp, p_inv, iorder_p, shift_P &
, Q_new, Q_center, fact_q, qq, q_inv, iorder_q, shift_Q )
shift_p = (/ 1, 0, 0 /)
shift_Q = (/ 0, 0, 0 /)
cx = cx + expoii * gg * general_primitive_integral_coul_shifted( dim1 &
, P_new, P_center, fact_p, pp, p_inv, iorder_p, shift_P &
, Q_new, Q_center, fact_q, qq, q_inv, iorder_q, shift_Q )
shift_p = (/ 0, 0, 0 /)
shift_Q = (/ 1, 0, 0 /)
cx = cx + expoii * ff * general_primitive_integral_coul_shifted( dim1 &
, P_new, P_center, fact_p, pp, p_inv, iorder_p, shift_P &
, Q_new, Q_center, fact_q, qq, q_inv, iorder_q, shift_Q )
shift_p = (/ 0, 0, 0 /)
shift_Q = (/ 0, 0, 0 /)
cx = cx + expoii * ff * gg * general_primitive_integral_coul_shifted( dim1 &
, P_new, P_center, fact_p, pp, p_inv, iorder_p, shift_P &
, Q_new, Q_center, fact_q, qq, q_inv, iorder_q, shift_Q )
! ----------------------------------------------------------------------------------------------------
! ----------------------------------------------------------------------------------------------------
! y term:
ff = P_center(2) - Centerii(2)
gg = Q_center(2) - Centerii(2)
shift_p = (/ 0, 1, 0 /)
shift_Q = (/ 0, 1, 0 /)
cy = cy + expoii * general_primitive_integral_coul_shifted( dim1 &
, P_new, P_center, fact_p, pp, p_inv, iorder_p, shift_P &
, Q_new, Q_center, fact_q, qq, q_inv, iorder_q, shift_Q )
shift_p = (/ 0, 1, 0 /)
shift_Q = (/ 0, 0, 0 /)
cy = cy + expoii * gg * general_primitive_integral_coul_shifted( dim1 &
, P_new, P_center, fact_p, pp, p_inv, iorder_p, shift_P &
, Q_new, Q_center, fact_q, qq, q_inv, iorder_q, shift_Q )
shift_p = (/ 0, 0, 0 /)
shift_Q = (/ 0, 1, 0 /)
cy = cy + expoii * ff * general_primitive_integral_coul_shifted( dim1 &
, P_new, P_center, fact_p, pp, p_inv, iorder_p, shift_P &
, Q_new, Q_center, fact_q, qq, q_inv, iorder_q, shift_Q )
shift_p = (/ 0, 0, 0 /)
shift_Q = (/ 0, 0, 0 /)
cy = cy + expoii * ff * gg * general_primitive_integral_coul_shifted( dim1 &
, P_new, P_center, fact_p, pp, p_inv, iorder_p, shift_P &
, Q_new, Q_center, fact_q, qq, q_inv, iorder_q, shift_Q )
! ----------------------------------------------------------------------------------------------------
! ----------------------------------------------------------------------------------------------------
! z term:
ff = P_center(3) - Centerii(3)
gg = Q_center(3) - Centerii(3)
shift_p = (/ 0, 0, 1 /)
shift_Q = (/ 0, 0, 1 /)
cz = cz + expoii * general_primitive_integral_coul_shifted( dim1 &
, P_new, P_center, fact_p, pp, p_inv, iorder_p, shift_P &
, Q_new, Q_center, fact_q, qq, q_inv, iorder_q, shift_Q )
shift_p = (/ 0, 0, 1 /)
shift_Q = (/ 0, 0, 0 /)
cz = cz + expoii * gg * general_primitive_integral_coul_shifted( dim1 &
, P_new, P_center, fact_p, pp, p_inv, iorder_p, shift_P &
, Q_new, Q_center, fact_q, qq, q_inv, iorder_q, shift_Q )
shift_p = (/ 0, 0, 0 /)
shift_Q = (/ 0, 0, 1 /)
cz = cz + expoii * ff * general_primitive_integral_coul_shifted( dim1 &
, P_new, P_center, fact_p, pp, p_inv, iorder_p, shift_P &
, Q_new, Q_center, fact_q, qq, q_inv, iorder_q, shift_Q )
shift_p = (/ 0, 0, 0 /)
shift_Q = (/ 0, 0, 0 /)
cz = cz + expoii * ff * gg * general_primitive_integral_coul_shifted( dim1 &
, P_new, P_center, fact_p, pp, p_inv, iorder_p, shift_P &
, Q_new, Q_center, fact_q, qq, q_inv, iorder_q, shift_Q )
! ----------------------------------------------------------------------------------------------------
enddo
j1b_gauss_coul = j1b_gauss_coul - coef4 * ( cx + cy + cz )
enddo ! s
enddo ! r
enddo ! q
enddo ! p
! -------------------------------------------------------------------------------------------------------------------
! -------------------------------------------------------------------------------------------------------------------
! -------------------------------------------------------------------------------------------------------------------
!
! - [ 1 / r12 ] \sum_A a_A [ (r1-RA) \cdot (r2-RA) exp(-aA r2A^2) ]
!
! -------------------------------------------------------------------------------------------------------------------
do p = 1, ao_prim_num(i)
coef1 = ao_coef_normalized_ordered_transp(p, i)
expo1 = ao_expo_ordered_transp(p, i)
do q = 1, ao_prim_num(j)
coef2 = coef1 * ao_coef_normalized_ordered_transp(q, j)
expo2 = ao_expo_ordered_transp(q, j)
call give_explicit_poly_and_gaussian( P_new, P_center, pp, fact_p, iorder_p, expo1, expo2 &
, I_power, J_power, I_center, J_center, dim1 )
p_inv = 1.d0 / pp
do r = 1, ao_prim_num(k)
coef3 = coef2 * ao_coef_normalized_ordered_transp(r, k)
expo3 = ao_expo_ordered_transp(r, k)
do s = 1, ao_prim_num(l)
coef4 = coef3 * ao_coef_normalized_ordered_transp(s, l)
expo4 = ao_expo_ordered_transp(s, l)
call give_explicit_poly_and_gaussian( Q_new_tmp, Q_center_tmp, qq_tmp, fact_q_tmp, iorder_q, expo3, expo4 &
, K_power, L_power, K_center, L_center, dim1 )
cx = 0.d0
cy = 0.d0
cz = 0.d0
do ii = 1, nucl_num
expoii = j1b_gauss_pen(ii)
Centerii(1:3) = nucl_coord(ii, 1:3)
call gaussian_product(qq_tmp, Q_center_tmp, expoii, Centerii, factii, qq, Q_center)
fact_q = fact_q_tmp * factii
q_inv = 1.d0 / qq
! pol centerd on Q_center_tmp ==> centerd on Q_center
call pol_modif_center( Q_center_tmp, Q_center, iorder_q, Q_new_tmp, Q_new)
! ----------------------------------------------------------------------------------------------------
! x term:
ff = P_center(1) - Centerii(1)
gg = Q_center(1) - Centerii(1)
shift_p = (/ 1, 0, 0 /)
shift_Q = (/ 1, 0, 0 /)
cx = cx + expoii * general_primitive_integral_coul_shifted( dim1 &
, P_new, P_center, fact_p, pp, p_inv, iorder_p, shift_P &
, Q_new, Q_center, fact_q, qq, q_inv, iorder_q, shift_Q )
shift_p = (/ 1, 0, 0 /)
shift_Q = (/ 0, 0, 0 /)
cx = cx + expoii * gg * general_primitive_integral_coul_shifted( dim1 &
, P_new, P_center, fact_p, pp, p_inv, iorder_p, shift_P &
, Q_new, Q_center, fact_q, qq, q_inv, iorder_q, shift_Q )
shift_p = (/ 0, 0, 0 /)
shift_Q = (/ 1, 0, 0 /)
cx = cx + expoii * ff * general_primitive_integral_coul_shifted( dim1 &
, P_new, P_center, fact_p, pp, p_inv, iorder_p, shift_P &
, Q_new, Q_center, fact_q, qq, q_inv, iorder_q, shift_Q )
shift_p = (/ 0, 0, 0 /)
shift_Q = (/ 0, 0, 0 /)
cx = cx + expoii * ff * gg * general_primitive_integral_coul_shifted( dim1 &
, P_new, P_center, fact_p, pp, p_inv, iorder_p, shift_P &
, Q_new, Q_center, fact_q, qq, q_inv, iorder_q, shift_Q )
! ----------------------------------------------------------------------------------------------------
! ----------------------------------------------------------------------------------------------------
! y term:
ff = P_center(2) - Centerii(2)
gg = Q_center(2) - Centerii(2)
shift_p = (/ 0, 1, 0 /)
shift_Q = (/ 0, 1, 0 /)
cy = cy + expoii * general_primitive_integral_coul_shifted( dim1 &
, P_new, P_center, fact_p, pp, p_inv, iorder_p, shift_P &
, Q_new, Q_center, fact_q, qq, q_inv, iorder_q, shift_Q )
shift_p = (/ 0, 1, 0 /)
shift_Q = (/ 0, 0, 0 /)
cy = cy + expoii * gg * general_primitive_integral_coul_shifted( dim1 &
, P_new, P_center, fact_p, pp, p_inv, iorder_p, shift_P &
, Q_new, Q_center, fact_q, qq, q_inv, iorder_q, shift_Q )
shift_p = (/ 0, 0, 0 /)
shift_Q = (/ 0, 1, 0 /)
cy = cy + expoii * ff * general_primitive_integral_coul_shifted( dim1 &
, P_new, P_center, fact_p, pp, p_inv, iorder_p, shift_P &
, Q_new, Q_center, fact_q, qq, q_inv, iorder_q, shift_Q )
shift_p = (/ 0, 0, 0 /)
shift_Q = (/ 0, 0, 0 /)
cy = cy + expoii * ff * gg * general_primitive_integral_coul_shifted( dim1 &
, P_new, P_center, fact_p, pp, p_inv, iorder_p, shift_P &
, Q_new, Q_center, fact_q, qq, q_inv, iorder_q, shift_Q )
! ----------------------------------------------------------------------------------------------------
! ----------------------------------------------------------------------------------------------------
! z term:
ff = P_center(3) - Centerii(3)
gg = Q_center(3) - Centerii(3)
shift_p = (/ 0, 0, 1 /)
shift_Q = (/ 0, 0, 1 /)
cz = cz + expoii * general_primitive_integral_coul_shifted( dim1 &
, P_new, P_center, fact_p, pp, p_inv, iorder_p, shift_P &
, Q_new, Q_center, fact_q, qq, q_inv, iorder_q, shift_Q )
shift_p = (/ 0, 0, 1 /)
shift_Q = (/ 0, 0, 0 /)
cz = cz + expoii * gg * general_primitive_integral_coul_shifted( dim1 &
, P_new, P_center, fact_p, pp, p_inv, iorder_p, shift_P &
, Q_new, Q_center, fact_q, qq, q_inv, iorder_q, shift_Q )
shift_p = (/ 0, 0, 0 /)
shift_Q = (/ 0, 0, 1 /)
cz = cz + expoii * ff * general_primitive_integral_coul_shifted( dim1 &
, P_new, P_center, fact_p, pp, p_inv, iorder_p, shift_P &
, Q_new, Q_center, fact_q, qq, q_inv, iorder_q, shift_Q )
shift_p = (/ 0, 0, 0 /)
shift_Q = (/ 0, 0, 0 /)
cz = cz + expoii * ff * gg * general_primitive_integral_coul_shifted( dim1 &
, P_new, P_center, fact_p, pp, p_inv, iorder_p, shift_P &
, Q_new, Q_center, fact_q, qq, q_inv, iorder_q, shift_Q )
! ----------------------------------------------------------------------------------------------------
enddo
j1b_gauss_coul = j1b_gauss_coul - coef4 * ( cx + cy + cz )
enddo ! s
enddo ! r
enddo ! q
enddo ! p
! -------------------------------------------------------------------------------------------------------------------
! -------------------------------------------------------------------------------------------------------------------
return
end function j1b_gauss_coul
!______________________________________________________________________________________________________________________
!______________________________________________________________________________________________________________________
double precision function general_primitive_integral_coul_shifted( dim &
, P_new, P_center, fact_p, p, p_inv, iorder_p, shift_P &
, Q_new, Q_center, fact_q, q, q_inv, iorder_q, shift_Q )
include 'utils/constants.include.F'
implicit none
integer, intent(in) :: dim
integer, intent(in) :: iorder_p(3), shift_P(3)
integer, intent(in) :: iorder_q(3), shift_Q(3)
double precision, intent(in) :: P_new(0:max_dim,3), P_center(3), fact_p, p, p_inv
double precision, intent(in) :: Q_new(0:max_dim,3), Q_center(3), fact_q, q, q_inv
integer :: n_Ix, n_Iy, n_Iz, nx, ny, nz
integer :: ix, iy, iz, jx, jy, jz, i
integer :: n_pt_tmp, n_pt_out, iorder
integer :: ii, jj
double precision :: rho, dist
double precision :: dx(0:max_dim), Ix_pol(0:max_dim)
double precision :: dy(0:max_dim), Iy_pol(0:max_dim)
double precision :: dz(0:max_dim), Iz_pol(0:max_dim)
double precision :: a, b, c, d, e, f, accu, pq, const
double precision :: pq_inv, p10_1, p10_2, p01_1, p01_2, pq_inv_2
double precision :: d1(0:max_dim), d_poly(0:max_dim)
double precision :: p_plus_q
double precision :: rint_sum
general_primitive_integral_coul_shifted = 0.d0
!DIR$ ATTRIBUTES ALIGN : $IRP_ALIGN :: dx, Ix_pol, dy, Iy_pol, dz, Iz_pol
!DIR$ ATTRIBUTES ALIGN : $IRP_ALIGN :: d1, d_poly
! Gaussian Product
! ----------------
p_plus_q = (p+q)
pq = p_inv * 0.5d0 * q_inv
pq_inv = 0.5d0 / p_plus_q
p10_1 = q * pq ! 1/(2p)
p01_1 = p * pq ! 1/(2q)
pq_inv_2 = pq_inv + pq_inv
p10_2 = pq_inv_2 * p10_1 * q ! 0.5d0 * q / (pq + p*p)
p01_2 = pq_inv_2 * p01_1 * p ! 0.5d0 * p / (q*q + pq)
accu = 0.d0
iorder = iorder_p(1) + iorder_q(1) + iorder_p(1) + iorder_q(1)
iorder = iorder + shift_P(1) + shift_Q(1)
iorder = iorder + shift_P(1) + shift_Q(1)
!DIR$ VECTOR ALIGNED
do ix = 0, iorder
Ix_pol(ix) = 0.d0
enddo
n_Ix = 0
do ix = 0, iorder_p(1)
ii = ix + shift_P(1)
a = P_new(ix,1)
if(abs(a) < thresh) cycle
do jx = 0, iorder_q(1)
jj = jx + shift_Q(1)
d = a * Q_new(jx,1)
if(abs(d) < thresh) cycle
!DEC$ FORCEINLINE
call give_polynom_mult_center_x( P_center(1), Q_center(1), ii, jj &
, p, q, iorder, pq_inv, pq_inv_2, p10_1, p01_1, p10_2, p01_2, dx, nx )
!DEC$ FORCEINLINE
call add_poly_multiply(dx, nx, d, Ix_pol, n_Ix)
enddo
enddo
if(n_Ix == -1) then
return
endif
iorder = iorder_p(2) + iorder_q(2) + iorder_p(2) + iorder_q(2)
iorder = iorder + shift_P(2) + shift_Q(2)
iorder = iorder + shift_P(2) + shift_Q(2)
!DIR$ VECTOR ALIGNED
do ix = 0, iorder
Iy_pol(ix) = 0.d0
enddo
n_Iy = 0
do iy = 0, iorder_p(2)
if(abs(P_new(iy,2)) > thresh) then
ii = iy + shift_P(2)
b = P_new(iy,2)
do jy = 0, iorder_q(2)
jj = jy + shift_Q(2)
e = b * Q_new(jy,2)
if(abs(e) < thresh) cycle
!DEC$ FORCEINLINE
call give_polynom_mult_center_x( P_center(2), Q_center(2), ii, jj &
, p, q, iorder, pq_inv, pq_inv_2, p10_1, p01_1, p10_2, p01_2, dy, ny )
!DEC$ FORCEINLINE
call add_poly_multiply(dy, ny, e, Iy_pol, n_Iy)
enddo
endif
enddo
if(n_Iy == -1) then
return
endif
iorder = iorder_p(3) + iorder_q(3) + iorder_p(3) + iorder_q(3)
iorder = iorder + shift_P(3) + shift_Q(3)
iorder = iorder + shift_P(3) + shift_Q(3)
do ix = 0, iorder
Iz_pol(ix) = 0.d0
enddo
n_Iz = 0
do iz = 0, iorder_p(3)
if( abs(P_new(iz,3)) > thresh ) then
ii = iz + shift_P(3)
c = P_new(iz,3)
do jz = 0, iorder_q(3)
jj = jz + shift_Q(3)
f = c * Q_new(jz,3)
if(abs(f) < thresh) cycle
!DEC$ FORCEINLINE
call give_polynom_mult_center_x( P_center(3), Q_center(3), ii, jj &
, p, q, iorder, pq_inv, pq_inv_2, p10_1, p01_1, p10_2, p01_2, dz, nz )
!DEC$ FORCEINLINE
call add_poly_multiply(dz, nz, f, Iz_pol, n_Iz)
enddo
endif
enddo
if(n_Iz == -1) then
return
endif
rho = p * q * pq_inv_2
dist = (P_center(1) - Q_center(1)) * (P_center(1) - Q_center(1)) &
+ (P_center(2) - Q_center(2)) * (P_center(2) - Q_center(2)) &
+ (P_center(3) - Q_center(3)) * (P_center(3) - Q_center(3))
const = dist*rho
n_pt_tmp = n_Ix + n_Iy
do i = 0, n_pt_tmp
d_poly(i) = 0.d0
enddo
!DEC$ FORCEINLINE
call multiply_poly(Ix_pol, n_Ix, Iy_pol, n_Iy, d_poly, n_pt_tmp)
if(n_pt_tmp == -1) then
return
endif
n_pt_out = n_pt_tmp + n_Iz
do i = 0, n_pt_out
d1(i) = 0.d0
enddo
!DEC$ FORCEINLINE
call multiply_poly(d_poly, n_pt_tmp, Iz_pol, n_Iz, d1, n_pt_out)
accu = accu + rint_sum(n_pt_out, const, d1)
general_primitive_integral_coul_shifted = fact_p * fact_q * accu * pi_5_2 * p_inv * q_inv / dsqrt(p_plus_q)
return
end function general_primitive_integral_coul_shifted
!______________________________________________________________________________________________________________________
!______________________________________________________________________________________________________________________

433
src/ao_tc_eff_map/two_e_1bgauss_coul_acc.irp.f Normal file
View File

@ -0,0 +1,433 @@
double precision function j1b_gauss_coul_acc(i, j, k, l)
BEGIN_DOC
!
! integral in the AO basis:
! i(r1) j(r1) f(r12) k(r2) l(r2)
!
! with:
! f(r12) = - [ 0.5 / r12 ] (r1-r2) \cdot \sum_A (-2 a_A) [ r1A exp(-aA r1A^2) - r2A exp(-aA r2A^2) ]
! = [ 1 / r12 ] \sum_A a_A [ (r1-RA)^2 exp(-aA r1A^2)
! + (r2-RA)^2 exp(-aA r2A^2)
! - (r1-RA) \cdot (r2-RA) exp(-aA r1A^2)
! - (r1-RA) \cdot (r2-RA) exp(-aA r2A^2) ]
!
END_DOC
include 'utils/constants.include.F'
implicit none
integer, intent(in) :: i, j, k, l
integer :: p, q, r, s, ii
integer :: num_i, num_j, num_k, num_l, num_ii
integer :: I_power(3), J_power(3), K_power(3), L_power(3)
integer :: iorder_p(3), iorder_q(3)
integer :: shift_P(3), shift_Q(3)
integer :: dim1
double precision :: coef1, coef2, coef3, coef4
double precision :: expo1, expo2, expo3, expo4
double precision :: p1_inv, q1_inv, p2_inv, q2_inv
double precision :: P1_new(0:max_dim,3), P1_center(3), fact_p1, pp1
double precision :: P2_new(0:max_dim,3), P2_center(3), fact_p2, pp2
double precision :: Q1_new(0:max_dim,3), Q1_center(3), fact_q1, qq1
double precision :: Q2_new(0:max_dim,3), Q2_center(3), fact_q2, qq2
double precision :: I_center(3), J_center(3), K_center(3), L_center(3)
double precision :: expoii, factii, Centerii(3)
double precision :: ff, gg, cx, cy, cz
double precision :: general_primitive_integral_coul_shifted
!double precision :: j1b_gauss_coul_schwartz_accel
PROVIDE j1b_gauss_pen
dim1 = n_pt_max_integrals
! TODO
!if( ao_prim_num(i) * ao_prim_num(j) * ao_prim_num(k) * ao_prim_num(l) > 1024 ) then
! j1b_gauss_coul_schwartz_accel = j1b_gauss_coul_schwartz_accel(i, j, k, l)
! return
!endif
num_i = ao_nucl(i)
num_j = ao_nucl(j)
num_k = ao_nucl(k)
num_l = ao_nucl(l)
do p = 1, 3
I_power(p) = ao_power(i,p)
J_power(p) = ao_power(j,p)
K_power(p) = ao_power(k,p)
L_power(p) = ao_power(l,p)
I_center(p) = nucl_coord(num_i,p)
J_center(p) = nucl_coord(num_j,p)
K_center(p) = nucl_coord(num_k,p)
L_center(p) = nucl_coord(num_l,p)
enddo
j1b_gauss_coul_acc = 0.d0
do p = 1, ao_prim_num(i)
coef1 = ao_coef_normalized_ordered_transp(p, i)
expo1 = ao_expo_ordered_transp(p, i)
do q = 1, ao_prim_num(j)
coef2 = coef1 * ao_coef_normalized_ordered_transp(q, j)
expo2 = ao_expo_ordered_transp(q, j)
call give_explicit_poly_and_gaussian( P1_new, P1_center, pp1, fact_p1, iorder_p, expo1, expo2 &
, I_power, J_power, I_center, J_center, dim1 )
p1_inv = 1.d0 / pp1
do r = 1, ao_prim_num(k)
coef3 = coef2 * ao_coef_normalized_ordered_transp(r, k)
expo3 = ao_expo_ordered_transp(r, k)
do s = 1, ao_prim_num(l)
coef4 = coef3 * ao_coef_normalized_ordered_transp(s, l)
expo4 = ao_expo_ordered_transp(s, l)
call give_explicit_poly_and_gaussian( Q1_new, Q1_center, qq1, fact_q1, iorder_q, expo3, expo4 &
, K_power, L_power, K_center, L_center, dim1 )
q1_inv = 1.d0 / qq1
cx = 0.d0
cy = 0.d0
cz = 0.d0
do ii = 1, nucl_num
expoii = j1b_gauss_pen(ii)
Centerii(1:3) = nucl_coord(ii, 1:3)
call gaussian_product(pp1, P1_center, expoii, Centerii, factii, pp2, P2_center)
fact_p2 = fact_p1 * factii
p2_inv = 1.d0 / pp2
call pol_modif_center( P1_center, P2_center, iorder_p, P1_new, P2_new)
call gaussian_product(qq1, Q1_center, expoii, Centerii, factii, qq2, Q2_center)
fact_q2 = fact_q1 * factii
q2_inv = 1.d0 / qq2
call pol_modif_center( Q1_center, Q2_center, iorder_q, Q1_new, Q2_new)
! ----------------------------------------------------------------------------------------------------
! [ 1 / r12 ] \sum_A a_A [ (r1-RA)^2 exp(-aA r1A^2)
! ----------------------------------------------------------------------------------------------------
shift_Q = (/ 0, 0, 0 /)
! x term:
ff = P2_center(1) - Centerii(1)
shift_P = (/ 2, 0, 0 /)
cx = cx + expoii * general_primitive_integral_coul_shifted( dim1 &
, P2_new, P2_center, fact_p2, pp2, p2_inv, iorder_p, shift_P &
, Q1_new, Q1_center, fact_q1, qq1, q1_inv, iorder_q, shift_Q )
shift_P = (/ 1, 0, 0 /)
cx = cx + expoii * 2.d0 * ff * general_primitive_integral_coul_shifted( dim1 &
, P2_new, P2_center, fact_p2, pp2, p2_inv, iorder_p, shift_P &
, Q1_new, Q1_center, fact_q1, qq1, q1_inv, iorder_q, shift_Q )
shift_P = (/ 0, 0, 0 /)
cx = cx + expoii * ff * ff * general_primitive_integral_coul_shifted( dim1 &
, P2_new, P2_center, fact_p2, pp2, p2_inv, iorder_p, shift_P &
, Q1_new, Q1_center, fact_q1, qq1, q1_inv, iorder_q, shift_Q )
! y term:
ff = P2_center(2) - Centerii(2)
shift_P = (/ 0, 2, 0 /)
cy = cy + expoii * general_primitive_integral_coul_shifted( dim1 &
, P2_new, P2_center, fact_p2, pp2, p2_inv, iorder_p, shift_P &
, Q1_new, Q1_center, fact_q1, qq1, q1_inv, iorder_q, shift_Q )
shift_P = (/ 0, 1, 0 /)
cy = cy + expoii * 2.d0 * ff * general_primitive_integral_coul_shifted( dim1 &
, P2_new, P2_center, fact_p2, pp2, p2_inv, iorder_p, shift_P &
, Q1_new, Q1_center, fact_q1, qq1, q1_inv, iorder_q, shift_Q )
shift_P = (/ 0, 0, 0 /)
cy = cy + expoii * ff * ff * general_primitive_integral_coul_shifted( dim1 &
, P2_new, P2_center, fact_p2, pp2, p2_inv, iorder_p, shift_P &
, Q1_new, Q1_center, fact_q1, qq1, q1_inv, iorder_q, shift_Q )
! z term:
ff = P2_center(3) - Centerii(3)
shift_P = (/ 0, 0, 2 /)
cz = cz + expoii * general_primitive_integral_coul_shifted( dim1 &
, P2_new, P2_center, fact_p2, pp2, p2_inv, iorder_p, shift_P &
, Q1_new, Q1_center, fact_q1, qq1, q1_inv, iorder_q, shift_Q )
shift_P = (/ 0, 0, 1 /)
cz = cz + expoii * 2.d0 * ff * general_primitive_integral_coul_shifted( dim1 &
, P2_new, P2_center, fact_p2, pp2, p2_inv, iorder_p, shift_P &
, Q1_new, Q1_center, fact_q1, qq1, q1_inv, iorder_q, shift_Q )
shift_P = (/ 0, 0, 0 /)
cz = cz + expoii * ff * ff * general_primitive_integral_coul_shifted( dim1 &
, P2_new, P2_center, fact_p2, pp2, p2_inv, iorder_p, shift_P &
, Q1_new, Q1_center, fact_q1, qq1, q1_inv, iorder_q, shift_Q )
! ----------------------------------------------------------------------------------------------------
! ----------------------------------------------------------------------------------------------------
! [ 1 / r12 ] \sum_A a_A [ (r2-RA)^2 exp(-aA r2A^2)
! ----------------------------------------------------------------------------------------------------
shift_P = (/ 0, 0, 0 /)
! x term:
ff = Q2_center(1) - Centerii(1)
shift_Q = (/ 2, 0, 0 /)
cx = cx + expoii * general_primitive_integral_coul_shifted( dim1 &
, P1_new, P1_center, fact_p1, pp1, p1_inv, iorder_p, shift_P &
, Q2_new, Q2_center, fact_q2, qq2, q2_inv, iorder_q, shift_Q )
shift_Q = (/ 1, 0, 0 /)
cx = cx + expoii * 2.d0 * ff * general_primitive_integral_coul_shifted( dim1 &
, P1_new, P1_center, fact_p1, pp1, p1_inv, iorder_p, shift_P &
, Q2_new, Q2_center, fact_q2, qq2, q2_inv, iorder_q, shift_Q )
shift_Q = (/ 0, 0, 0 /)
cx = cx + expoii * ff * ff * general_primitive_integral_coul_shifted( dim1 &
, P1_new, P1_center, fact_p1, pp1, p1_inv, iorder_p, shift_P &
, Q2_new, Q2_center, fact_q2, qq2, q2_inv, iorder_q, shift_Q )
! y term:
ff = Q2_center(2) - Centerii(2)
shift_Q = (/ 0, 2, 0 /)
cy = cy + expoii * general_primitive_integral_coul_shifted( dim1 &
, P1_new, P1_center, fact_p1, pp1, p1_inv, iorder_p, shift_P &
, Q2_new, Q2_center, fact_q2, qq2, q2_inv, iorder_q, shift_Q )
shift_Q = (/ 0, 1, 0 /)
cy = cy + expoii * 2.d0 * ff * general_primitive_integral_coul_shifted( dim1 &
, P1_new, P1_center, fact_p1, pp1, p1_inv, iorder_p, shift_P &
, Q2_new, Q2_center, fact_q2, qq2, q2_inv, iorder_q, shift_Q )
shift_Q = (/ 0, 0, 0 /)
cy = cy + expoii * ff * ff * general_primitive_integral_coul_shifted( dim1 &
, P1_new, P1_center, fact_p1, pp1, p1_inv, iorder_p, shift_P &
, Q2_new, Q2_center, fact_q2, qq2, q2_inv, iorder_q, shift_Q )
! z term:
ff = Q2_center(3) - Centerii(3)
shift_Q = (/ 0, 0, 2 /)
cz = cz + expoii * general_primitive_integral_coul_shifted( dim1 &
, P1_new, P1_center, fact_p1, pp1, p1_inv, iorder_p, shift_P &
, Q2_new, Q2_center, fact_q2, qq2, q2_inv, iorder_q, shift_Q )
shift_Q = (/ 0, 0, 1 /)
cz = cz + expoii * 2.d0 * ff * general_primitive_integral_coul_shifted( dim1 &
, P1_new, P1_center, fact_p1, pp1, p1_inv, iorder_p, shift_P &
, Q2_new, Q2_center, fact_q2, qq2, q2_inv, iorder_q, shift_Q )
shift_Q = (/ 0, 0, 0 /)
cz = cz + expoii * ff * ff * general_primitive_integral_coul_shifted( dim1 &
, P1_new, P1_center, fact_p1, pp1, p1_inv, iorder_p, shift_P &
, Q2_new, Q2_center, fact_q2, qq2, q2_inv, iorder_q, shift_Q )
! ----------------------------------------------------------------------------------------------------
! ----------------------------------------------------------------------------------------------------
! - [ 1 / r12 ] \sum_A a_A [ (r1-RA) \cdot (r2-RA) exp(-aA r1A^2) ]
! ----------------------------------------------------------------------------------------------------
! x term:
ff = P2_center(1) - Centerii(1)
gg = Q1_center(1) - Centerii(1)
shift_p = (/ 1, 0, 0 /)
shift_Q = (/ 1, 0, 0 /)
cx = cx - expoii * general_primitive_integral_coul_shifted( dim1 &
, P2_new, P2_center, fact_p2, pp2, p2_inv, iorder_p, shift_P &
, Q1_new, Q1_center, fact_q1, qq1, q1_inv, iorder_q, shift_Q )
shift_p = (/ 1, 0, 0 /)
shift_Q = (/ 0, 0, 0 /)
cx = cx - expoii * gg * general_primitive_integral_coul_shifted( dim1 &
, P2_new, P2_center, fact_p2, pp2, p2_inv, iorder_p, shift_P &
, Q1_new, Q1_center, fact_q1, qq1, q1_inv, iorder_q, shift_Q )
shift_p = (/ 0, 0, 0 /)
shift_Q = (/ 1, 0, 0 /)
cx = cx - expoii * ff * general_primitive_integral_coul_shifted( dim1 &
, P2_new, P2_center, fact_p2, pp2, p2_inv, iorder_p, shift_P &
, Q1_new, Q1_center, fact_q1, qq1, q1_inv, iorder_q, shift_Q )
shift_p = (/ 0, 0, 0 /)
shift_Q = (/ 0, 0, 0 /)
cx = cx - expoii * ff * gg * general_primitive_integral_coul_shifted( dim1 &
, P2_new, P2_center, fact_p2, pp2, p2_inv, iorder_p, shift_P &
, Q1_new, Q1_center, fact_q1, qq1, q1_inv, iorder_q, shift_Q )
! y term:
ff = P2_center(2) - Centerii(2)
gg = Q1_center(2) - Centerii(2)
shift_p = (/ 0, 1, 0 /)
shift_Q = (/ 0, 1, 0 /)
cy = cy - expoii * general_primitive_integral_coul_shifted( dim1 &
, P2_new, P2_center, fact_p2, pp2, p2_inv, iorder_p, shift_P &
, Q1_new, Q1_center, fact_q1, qq1, q1_inv, iorder_q, shift_Q )
shift_p = (/ 0, 1, 0 /)
shift_Q = (/ 0, 0, 0 /)
cy = cy - expoii * gg * general_primitive_integral_coul_shifted( dim1 &
, P2_new, P2_center, fact_p2, pp2, p2_inv, iorder_p, shift_P &
, Q1_new, Q1_center, fact_q1, qq1, q1_inv, iorder_q, shift_Q )
shift_p = (/ 0, 0, 0 /)
shift_Q = (/ 0, 1, 0 /)
cy = cy - expoii * ff * general_primitive_integral_coul_shifted( dim1 &
, P2_new, P2_center, fact_p2, pp2, p2_inv, iorder_p, shift_P &
, Q1_new, Q1_center, fact_q1, qq1, q1_inv, iorder_q, shift_Q )
shift_p = (/ 0, 0, 0 /)
shift_Q = (/ 0, 0, 0 /)
cy = cy - expoii * ff * gg * general_primitive_integral_coul_shifted( dim1 &
, P2_new, P2_center, fact_p2, pp2, p2_inv, iorder_p, shift_P &
, Q1_new, Q1_center, fact_q1, qq1, q1_inv, iorder_q, shift_Q )
! z term:
ff = P2_center(3) - Centerii(3)
gg = Q1_center(3) - Centerii(3)
shift_p = (/ 0, 0, 1 /)
shift_Q = (/ 0, 0, 1 /)
cz = cz - expoii * general_primitive_integral_coul_shifted( dim1 &
, P2_new, P2_center, fact_p2, pp2, p2_inv, iorder_p, shift_P &
, Q1_new, Q1_center, fact_q1, qq1, q1_inv, iorder_q, shift_Q )
shift_p = (/ 0, 0, 1 /)
shift_Q = (/ 0, 0, 0 /)
cz = cz - expoii * gg * general_primitive_integral_coul_shifted( dim1 &
, P2_new, P2_center, fact_p2, pp2, p2_inv, iorder_p, shift_P &
, Q1_new, Q1_center, fact_q1, qq1, q1_inv, iorder_q, shift_Q )
shift_p = (/ 0, 0, 0 /)
shift_Q = (/ 0, 0, 1 /)
cz = cz - expoii * ff * general_primitive_integral_coul_shifted( dim1 &
, P2_new, P2_center, fact_p2, pp2, p2_inv, iorder_p, shift_P &
, Q1_new, Q1_center, fact_q1, qq1, q1_inv, iorder_q, shift_Q )
shift_p = (/ 0, 0, 0 /)
shift_Q = (/ 0, 0, 0 /)
cz = cz - expoii * ff * gg * general_primitive_integral_coul_shifted( dim1 &
, P2_new, P2_center, fact_p2, pp2, p2_inv, iorder_p, shift_P &
, Q1_new, Q1_center, fact_q1, qq1, q1_inv, iorder_q, shift_Q )
! ----------------------------------------------------------------------------------------------------
! ----------------------------------------------------------------------------------------------------
! - [ 1 / r12 ] \sum_A a_A [ (r1-RA) \cdot (r2-RA) exp(-aA r2A^2) ]
! ----------------------------------------------------------------------------------------------------
! x term:
ff = P1_center(1) - Centerii(1)
gg = Q2_center(1) - Centerii(1)
shift_p = (/ 1, 0, 0 /)
shift_Q = (/ 1, 0, 0 /)
cx = cx - expoii * general_primitive_integral_coul_shifted( dim1 &
, P1_new, P1_center, fact_p1, pp1, p1_inv, iorder_p, shift_P &
, Q2_new, Q2_center, fact_q2, qq2, q2_inv, iorder_q, shift_Q )
shift_p = (/ 1, 0, 0 /)
shift_Q = (/ 0, 0, 0 /)
cx = cx - expoii * gg * general_primitive_integral_coul_shifted( dim1 &
, P1_new, P1_center, fact_p1, pp1, p1_inv, iorder_p, shift_P &
, Q2_new, Q2_center, fact_q2, qq2, q2_inv, iorder_q, shift_Q )
shift_p = (/ 0, 0, 0 /)
shift_Q = (/ 1, 0, 0 /)
cx = cx - expoii * ff * general_primitive_integral_coul_shifted( dim1 &
, P1_new, P1_center, fact_p1, pp1, p1_inv, iorder_p, shift_P &
, Q2_new, Q2_center, fact_q2, qq2, q2_inv, iorder_q, shift_Q )
shift_p = (/ 0, 0, 0 /)
shift_Q = (/ 0, 0, 0 /)
cx = cx - expoii * ff * gg * general_primitive_integral_coul_shifted( dim1 &
, P1_new, P1_center, fact_p1, pp1, p1_inv, iorder_p, shift_P &
, Q2_new, Q2_center, fact_q2, qq2, q2_inv, iorder_q, shift_Q )
! y term:
ff = P1_center(2) - Centerii(2)
gg = Q2_center(2) - Centerii(2)
shift_p = (/ 0, 1, 0 /)
shift_Q = (/ 0, 1, 0 /)
cy = cy - expoii * general_primitive_integral_coul_shifted( dim1 &
, P1_new, P1_center, fact_p1, pp1, p1_inv, iorder_p, shift_P &
, Q2_new, Q2_center, fact_q2, qq2, q2_inv, iorder_q, shift_Q )
shift_p = (/ 0, 1, 0 /)
shift_Q = (/ 0, 0, 0 /)
cy = cy - expoii * gg * general_primitive_integral_coul_shifted( dim1 &
, P1_new, P1_center, fact_p1, pp1, p1_inv, iorder_p, shift_P &
, Q2_new, Q2_center, fact_q2, qq2, q2_inv, iorder_q, shift_Q )
shift_p = (/ 0, 0, 0 /)
shift_Q = (/ 0, 1, 0 /)
cy = cy - expoii * ff * general_primitive_integral_coul_shifted( dim1 &
, P1_new, P1_center, fact_p1, pp1, p1_inv, iorder_p, shift_P &
, Q2_new, Q2_center, fact_q2, qq2, q2_inv, iorder_q, shift_Q )
shift_p = (/ 0, 0, 0 /)
shift_Q = (/ 0, 0, 0 /)
cy = cy - expoii * ff * gg * general_primitive_integral_coul_shifted( dim1 &
, P1_new, P1_center, fact_p1, pp1, p1_inv, iorder_p, shift_P &
, Q2_new, Q2_center, fact_q2, qq2, q2_inv, iorder_q, shift_Q )
! z term:
ff = P1_center(3) - Centerii(3)
gg = Q2_center(3) - Centerii(3)
shift_p = (/ 0, 0, 1 /)
shift_Q = (/ 0, 0, 1 /)
cz = cz - expoii * general_primitive_integral_coul_shifted( dim1 &
, P1_new, P1_center, fact_p1, pp1, p1_inv, iorder_p, shift_P &
, Q2_new, Q2_center, fact_q2, qq2, q2_inv, iorder_q, shift_Q )
shift_p = (/ 0, 0, 1 /)
shift_Q = (/ 0, 0, 0 /)
cz = cz - expoii * gg * general_primitive_integral_coul_shifted( dim1 &
, P1_new, P1_center, fact_p1, pp1, p1_inv, iorder_p, shift_P &
, Q2_new, Q2_center, fact_q2, qq2, q2_inv, iorder_q, shift_Q )
shift_p = (/ 0, 0, 0 /)
shift_Q = (/ 0, 0, 1 /)
cz = cz - expoii * ff * general_primitive_integral_coul_shifted( dim1 &
, P1_new, P1_center, fact_p1, pp1, p1_inv, iorder_p, shift_P &
, Q2_new, Q2_center, fact_q2, qq2, q2_inv, iorder_q, shift_Q )
shift_p = (/ 0, 0, 0 /)
shift_Q = (/ 0, 0, 0 /)
cz = cz - expoii * ff * gg * general_primitive_integral_coul_shifted( dim1 &
, P1_new, P1_center, fact_p1, pp1, p1_inv, iorder_p, shift_P &
, Q2_new, Q2_center, fact_q2, qq2, q2_inv, iorder_q, shift_Q )
! ----------------------------------------------------------------------------------------------------
enddo
j1b_gauss_coul_acc = j1b_gauss_coul_acc + coef4 * ( cx + cy + cz )
enddo ! s
enddo ! r
enddo ! q
enddo ! p
return
end function j1b_gauss_coul_acc

397
src/ao_tc_eff_map/two_e_1bgauss_coul_debug.irp.f Normal file
View File

@ -0,0 +1,397 @@
double precision function j1b_gauss_coul_debug(i, j, k, l)
BEGIN_DOC
!
! integral in the AO basis:
! i(r1) j(r1) f(r12) k(r2) l(r2)
!
! with:
! f(r12) = - [ 0.5 / r12 ] (r1-r2) \cdot \sum_A (-2 a_A) [ r1A exp(-aA r1A^2) - r2A exp(-aA r2A^2) ]
! = [ 1 / r12 ] \sum_A a_A [ (r1-RA)^2 exp(-aA r1A^2)
! + (r2-RA)^2 exp(-aA r2A^2)
! - (r1-RA) \cdot (r2-RA) exp(-aA r1A^2)
! - (r1-RA) \cdot (r2-RA) exp(-aA r2A^2) ]
!
END_DOC
include 'utils/constants.include.F'
implicit none
integer, intent(in) :: i, j, k, l
integer :: p, q, r, s, ii
integer :: num_i, num_j, num_k, num_l, num_ii
integer :: I_power(3), J_power(3), K_power(3), L_power(3)
integer :: iorder_p(3), iorder_q(3)
integer :: shift_P(3), shift_Q(3)
integer :: dim1
double precision :: coef1, coef2, coef3, coef4
double precision :: expo1, expo2, expo3, expo4
double precision :: p_inv, q_inv
double precision :: P_new_tmp(0:max_dim,3), P_center_tmp(3), fact_p_tmp, pp_tmp
double precision :: Q_new_tmp(0:max_dim,3), Q_center_tmp(3), fact_q_tmp, qq_tmp
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 :: I_center(3), J_center(3), K_center(3), L_center(3)
double precision :: expoii, factii, Centerii(3)
double precision :: ff, gg, cx, cy, cz
double precision :: general_primitive_integral_coul_shifted
PROVIDE j1b_gauss_pen
dim1 = n_pt_max_integrals
num_i = ao_nucl(i)
num_j = ao_nucl(j)
num_k = ao_nucl(k)
num_l = ao_nucl(l)
do p = 1, 3
I_power(p) = ao_power(i,p)
J_power(p) = ao_power(j,p)
K_power(p) = ao_power(k,p)
L_power(p) = ao_power(l,p)
I_center(p) = nucl_coord(num_i,p)
J_center(p) = nucl_coord(num_j,p)
K_center(p) = nucl_coord(num_k,p)
L_center(p) = nucl_coord(num_l,p)
enddo
j1b_gauss_coul_debug = 0.d0
! -------------------------------------------------------------------------------------------------------------------
!
! [ 1 / r12 ] \sum_A a_A [ (r1-RA)^2 exp(-aA r1A^2)
!
! -------------------------------------------------------------------------------------------------------------------
shift_Q = (/ 0, 0, 0 /)
do p = 1, ao_prim_num(i)
coef1 = ao_coef_normalized_ordered_transp(p, i)
expo1 = ao_expo_ordered_transp(p, i)
do q = 1, ao_prim_num(j)
coef2 = coef1 * ao_coef_normalized_ordered_transp(q, j)
expo2 = ao_expo_ordered_transp(q, j)
call give_explicit_poly_and_gaussian( P_new_tmp, P_center_tmp, pp_tmp, fact_p_tmp, iorder_p, expo1, expo2 &
, I_power, J_power, I_center, J_center, dim1 )
do r = 1, ao_prim_num(k)
coef3 = coef2 * ao_coef_normalized_ordered_transp(r, k)
expo3 = ao_expo_ordered_transp(r, k)
do s = 1, ao_prim_num(l)
coef4 = coef3 * ao_coef_normalized_ordered_transp(s, l)
expo4 = ao_expo_ordered_transp(s, l)
call give_explicit_poly_and_gaussian( Q_new, Q_center, qq, fact_q, iorder_q, expo3, expo4 &
, K_power, L_power, K_center, L_center, dim1 )
q_inv = 1.d0 / qq
cx = 0.d0
do ii = 1, nucl_num
expoii = j1b_gauss_pen(ii)
Centerii(1:3) = nucl_coord(ii, 1:3)
call gaussian_product(pp_tmp, P_center_tmp, expoii, Centerii, factii, pp, P_center)
fact_p = fact_p_tmp * factii
p_inv = 1.d0 / pp
! pol centerd on P_center_tmp ==> centerd on P_center
call pol_modif_center( P_center_tmp, P_center, iorder_p, P_new_tmp, P_new)
! ----------------------------------------------------------------------------------------------------
! x term:
ff = P_center(1) - Centerii(1)
shift_P = (/ 2, 0, 0 /)
cx = cx + expoii * general_primitive_integral_coul_shifted( dim1 &
, P_new, P_center, fact_p, pp, p_inv, iorder_p, shift_P &
, Q_new, Q_center, fact_q, qq, q_inv, iorder_q, shift_Q )
shift_P = (/ 1, 0, 0 /)
cx = cx + expoii * 2.d0 * ff * general_primitive_integral_coul_shifted( dim1 &
, P_new, P_center, fact_p, pp, p_inv, iorder_p, shift_P &
, Q_new, Q_center, fact_q, qq, q_inv, iorder_q, shift_Q )
shift_P = (/ 0, 0, 0 /)
cx = cx + expoii * ff * ff * general_primitive_integral_coul_shifted( dim1 &
, P_new, P_center, fact_p, pp, p_inv, iorder_p, shift_P &
, Q_new, Q_center, fact_q, qq, q_inv, iorder_q, shift_Q )
! ----------------------------------------------------------------------------------------------------
enddo
j1b_gauss_coul_debug = j1b_gauss_coul_debug + coef4 * cx
enddo ! s
enddo ! r
enddo ! q
enddo ! p
! -------------------------------------------------------------------------------------------------------------------
! -------------------------------------------------------------------------------------------------------------------
! ! -------------------------------------------------------------------------------------------------------------------
! !
! ! [ 1 / r12 ] \sum_A a_A [ (r2-RA)^2 exp(-aA r2A^2)
! !
! ! -------------------------------------------------------------------------------------------------------------------
!
! shift_P = (/ 0, 0, 0 /)
!
! do p = 1, ao_prim_num(i)
! coef1 = ao_coef_normalized_ordered_transp(p, i)
! expo1 = ao_expo_ordered_transp(p, i)
!
! do q = 1, ao_prim_num(j)
! coef2 = coef1 * ao_coef_normalized_ordered_transp(q, j)
! expo2 = ao_expo_ordered_transp(q, j)
!
! call give_explicit_poly_and_gaussian( P_new, P_center, pp, fact_p, iorder_p, expo1, expo2 &
! , I_power, J_power, I_center, J_center, dim1 )
! p_inv = 1.d0 / pp
!
! do r = 1, ao_prim_num(k)
! coef3 = coef2 * ao_coef_normalized_ordered_transp(r, k)
! expo3 = ao_expo_ordered_transp(r, k)
!
! do s = 1, ao_prim_num(l)
! coef4 = coef3 * ao_coef_normalized_ordered_transp(s, l)
! expo4 = ao_expo_ordered_transp(s, l)
!
! call give_explicit_poly_and_gaussian( Q_new_tmp, Q_center_tmp, qq_tmp, fact_q_tmp, iorder_q, expo3, expo4 &
! , K_power, L_power, K_center, L_center, dim1 )
!
! cx = 0.d0
! do ii = 1, nucl_num
! expoii = j1b_gauss_pen(ii)
! Centerii(1:3) = nucl_coord(ii, 1:3)
!
! call gaussian_product(qq_tmp, Q_center_tmp, expoii, Centerii, factii, qq, Q_center)
!
! fact_q = fact_q_tmp * factii
! q_inv = 1.d0 / qq
!
! ! pol centerd on Q_center_tmp ==> centerd on Q_center
! call pol_modif_center( Q_center_tmp, Q_center, iorder_q, Q_new_tmp, Q_new)
!
! ! ----------------------------------------------------------------------------------------------------
! ! x term:
!
! ff = Q_center(1) - Centerii(1)
!
! shift_Q = (/ 2, 0, 0 /)
! cx = cx + expoii * general_primitive_integral_coul_shifted( dim1 &
! , P_new, P_center, fact_p, pp, p_inv, iorder_p, shift_P &
! , Q_new, Q_center, fact_q, qq, q_inv, iorder_q, shift_Q )
!
! shift_Q = (/ 1, 0, 0 /)
! cx = cx + expoii * 2.d0 * ff * general_primitive_integral_coul_shifted( dim1 &
! , P_new, P_center, fact_p, pp, p_inv, iorder_p, shift_P &
! , Q_new, Q_center, fact_q, qq, q_inv, iorder_q, shift_Q )
!
! shift_Q = (/ 0, 0, 0 /)
! cx = cx + expoii * ff * ff * general_primitive_integral_coul_shifted( dim1 &
! , P_new, P_center, fact_p, pp, p_inv, iorder_p, shift_P &
! , Q_new, Q_center, fact_q, qq, q_inv, iorder_q, shift_Q )
!
! ! ----------------------------------------------------------------------------------------------------
!
! enddo
!
! j1b_gauss_coul_debug = j1b_gauss_coul_debug + coef4 * cx
! enddo ! s
! enddo ! r
! enddo ! q
! enddo ! p
!
! ! -------------------------------------------------------------------------------------------------------------------
! ! -------------------------------------------------------------------------------------------------------------------
! -------------------------------------------------------------------------------------------------------------------
!
! - [ 1 / r12 ] \sum_A a_A [ (r1-RA) \cdot (r2-RA) exp(-aA r1A^2) ]
!
! -------------------------------------------------------------------------------------------------------------------
do p = 1, ao_prim_num(i)
coef1 = ao_coef_normalized_ordered_transp(p, i)
expo1 = ao_expo_ordered_transp(p, i)
do q = 1, ao_prim_num(j)
coef2 = coef1 * ao_coef_normalized_ordered_transp(q, j)
expo2 = ao_expo_ordered_transp(q, j)
call give_explicit_poly_and_gaussian( P_new_tmp, P_center_tmp, pp_tmp, fact_p_tmp, iorder_p, expo1, expo2 &
, I_power, J_power, I_center, J_center, dim1 )
do r = 1, ao_prim_num(k)
coef3 = coef2 * ao_coef_normalized_ordered_transp(r, k)
expo3 = ao_expo_ordered_transp(r, k)
do s = 1, ao_prim_num(l)
coef4 = coef3 * ao_coef_normalized_ordered_transp(s, l)
expo4 = ao_expo_ordered_transp(s, l)
call give_explicit_poly_and_gaussian( Q_new, Q_center, qq, fact_q, iorder_q, expo3, expo4 &
, K_power, L_power, K_center, L_center, dim1 )
q_inv = 1.d0 / qq
cx = 0.d0
do ii = 1, nucl_num
expoii = j1b_gauss_pen(ii)
Centerii(1:3) = nucl_coord(ii, 1:3)
call gaussian_product(pp_tmp, P_center_tmp, expoii, Centerii, factii, pp, P_center)
fact_p = fact_p_tmp * factii
p_inv = 1.d0 / pp
! pol centerd on P_center_tmp ==> centerd on P_center
call pol_modif_center( P_center_tmp, P_center, iorder_p, P_new_tmp, P_new)
! ----------------------------------------------------------------------------------------------------
! x term:
ff = P_center(1) - Centerii(1)
gg = Q_center(1) - Centerii(1)
shift_P = (/ 1, 0, 0 /)
shift_Q = (/ 1, 0, 0 /)
cx = cx + expoii * general_primitive_integral_coul_shifted( dim1 &
, P_new, P_center, fact_p, pp, p_inv, iorder_p, shift_P &
, Q_new, Q_center, fact_q, qq, q_inv, iorder_q, shift_Q )
shift_P = (/ 1, 0, 0 /)
shift_Q = (/ 0, 0, 0 /)
cx = cx + expoii * gg * general_primitive_integral_coul_shifted( dim1 &
, P_new, P_center, fact_p, pp, p_inv, iorder_p, shift_P &
, Q_new, Q_center, fact_q, qq, q_inv, iorder_q, shift_Q )
shift_P = (/ 0, 0, 0 /)
shift_Q = (/ 1, 0, 0 /)
cx = cx + expoii * ff * general_primitive_integral_coul_shifted( dim1 &
, P_new, P_center, fact_p, pp, p_inv, iorder_p, shift_P &
, Q_new, Q_center, fact_q, qq, q_inv, iorder_q, shift_Q )
shift_P = (/ 0, 0, 0 /)
shift_Q = (/ 0, 0, 0 /)
cx = cx + expoii * ff * gg * general_primitive_integral_coul_shifted( dim1 &
, P_new, P_center, fact_p, pp, p_inv, iorder_p, shift_P &
, Q_new, Q_center, fact_q, qq, q_inv, iorder_q, shift_Q )
! ----------------------------------------------------------------------------------------------------
enddo
j1b_gauss_coul_debug = j1b_gauss_coul_debug - coef4 * cx
enddo ! s
enddo ! r
enddo ! q
enddo ! p
! -------------------------------------------------------------------------------------------------------------------
! -------------------------------------------------------------------------------------------------------------------
! ! -------------------------------------------------------------------------------------------------------------------
! !
! ! - [ 1 / r12 ] \sum_A a_A [ (r1-RA) \cdot (r2-RA) exp(-aA r2A^2) ]
! !
! ! -------------------------------------------------------------------------------------------------------------------
!
! do p = 1, ao_prim_num(i)
! coef1 = ao_coef_normalized_ordered_transp(p, i)
! expo1 = ao_expo_ordered_transp(p, i)
!
! do q = 1, ao_prim_num(j)
! coef2 = coef1 * ao_coef_normalized_ordered_transp(q, j)
! expo2 = ao_expo_ordered_transp(q, j)
!
! call give_explicit_poly_and_gaussian( P_new, P_center, pp, fact_p, iorder_p, expo1, expo2 &
! , I_power, J_power, I_center, J_center, dim1 )
! p_inv = 1.d0 / pp
!
! do r = 1, ao_prim_num(k)
! coef3 = coef2 * ao_coef_normalized_ordered_transp(r, k)
! expo3 = ao_expo_ordered_transp(r, k)
!
! do s = 1, ao_prim_num(l)
! coef4 = coef3 * ao_coef_normalized_ordered_transp(s, l)
! expo4 = ao_expo_ordered_transp(s, l)
!
! call give_explicit_poly_and_gaussian( Q_new_tmp, Q_center_tmp, qq_tmp, fact_q_tmp, iorder_q, expo3, expo4 &
! , K_power, L_power, K_center, L_center, dim1 )
!
! cx = 0.d0
! do ii = 1, nucl_num
! expoii = j1b_gauss_pen(ii)
! Centerii(1:3) = nucl_coord(ii, 1:3)
!
! call gaussian_product(qq_tmp, Q_center_tmp, expoii, Centerii, factii, qq, Q_center)
!
! fact_q = fact_q_tmp * factii
! q_inv = 1.d0 / qq
!
! ! pol centerd on Q_center_tmp ==> centerd on Q_center
! call pol_modif_center( Q_center_tmp, Q_center, iorder_q, Q_new_tmp, Q_new)
!
! ! ----------------------------------------------------------------------------------------------------
! ! x term:
!
! ff = P_center(1) - Centerii(1)
! gg = Q_center(1) - Centerii(1)
!
! shift_P = (/ 1, 0, 0 /)
! shift_Q = (/ 1, 0, 0 /)
! cx = cx + expoii * general_primitive_integral_coul_shifted( dim1 &
! , P_new, P_center, fact_p, pp, p_inv, iorder_p, shift_P &
! , Q_new, Q_center, fact_q, qq, q_inv, iorder_q, shift_Q )
!
! shift_P = (/ 1, 0, 0 /)
! shift_Q = (/ 0, 0, 0 /)
! cx = cx + expoii * gg * general_primitive_integral_coul_shifted( dim1 &
! , P_new, P_center, fact_p, pp, p_inv, iorder_p, shift_P &
! , Q_new, Q_center, fact_q, qq, q_inv, iorder_q, shift_Q )
!
! shift_P = (/ 0, 0, 0 /)
! shift_Q = (/ 1, 0, 0 /)
! cx = cx + expoii * ff * general_primitive_integral_coul_shifted( dim1 &
! , P_new, P_center, fact_p, pp, p_inv, iorder_p, shift_P &
! , Q_new, Q_center, fact_q, qq, q_inv, iorder_q, shift_Q )
!
! shift_P = (/ 0, 0, 0 /)
! shift_Q = (/ 0, 0, 0 /)
! cx = cx + expoii * ff * gg * general_primitive_integral_coul_shifted( dim1 &
! , P_new, P_center, fact_p, pp, p_inv, iorder_p, shift_P &
! , Q_new, Q_center, fact_q, qq, q_inv, iorder_q, shift_Q )
!
! ! ----------------------------------------------------------------------------------------------------
!
! enddo
!
! j1b_gauss_coul_debug = j1b_gauss_coul_debug - coef4 * cx
!
! enddo ! s
! enddo ! r
! enddo ! q
! enddo ! p
!
! ! -------------------------------------------------------------------------------------------------------------------
! ! -------------------------------------------------------------------------------------------------------------------
return
end function j1b_gauss_coul_debug

324
src/ao_tc_eff_map/two_e_1bgauss_coul_modifdebug.irp.f Normal file
View File

@ -0,0 +1,324 @@
double precision function j1b_gauss_coul_modifdebug(i, j, k, l)
include 'utils/constants.include.F'
implicit none
integer, intent(in) :: i, j, k, l
integer :: p, q, r, s, ii
integer :: num_i, num_j, num_k, num_l, num_ii
integer :: I_power(3), J_power(3), K_power(3), L_power(3)
integer :: iorder_p(3), iorder_q(3)
integer :: shift_P(3), shift_Q(3)
integer :: dim1
double precision :: coef1, coef2, coef3, coef4
double precision :: expo1, expo2, expo3, expo4
double precision :: p_inv, q_inv
double precision :: P_new_tmp(0:max_dim,3), P_center_tmp(3), fact_p_tmp, pp_tmp
double precision :: Q_new_tmp(0:max_dim,3), Q_center_tmp(3), fact_q_tmp, qq_tmp
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 :: I_center(3), J_center(3), K_center(3), L_center(3)
double precision :: expoii, factii, Centerii(3)
double precision :: ff, gg, cx, cy, cz
double precision :: general_primitive_integral_coul
double precision :: general_primitive_integral_coul_shifted
double precision :: ao_two_e_integral
PROVIDE j1b_gauss_pen
dim1 = n_pt_max_integrals
num_i = ao_nucl(i)
num_j = ao_nucl(j)
num_k = ao_nucl(k)
num_l = ao_nucl(l)
do p = 1, 3
I_power(p) = ao_power(i,p)
J_power(p) = ao_power(j,p)
K_power(p) = ao_power(k,p)
L_power(p) = ao_power(l,p)
I_center(p) = nucl_coord(num_i,p)
J_center(p) = nucl_coord(num_j,p)
K_center(p) = nucl_coord(num_k,p)
L_center(p) = nucl_coord(num_l,p)
enddo
j1b_gauss_coul_modifdebug = 0.d0
! do ii = 1, nucl_num
! expoii = j1b_gauss_pen(ii)
! j1b_gauss_coul_modifdebug += expoii * ao_two_e_integral(i, j, k, l)
! enddo
! -------------------------------------------------------------------------------------------------------------------
!
! [ 1 / r12 ] \sum_A a_A exp(-aA r1A^2)
!
! -------------------------------------------------------------------------------------------------------------------
shift_P = (/ 0, 0, 0 /)
shift_Q = (/ 0, 0, 0 /)
do p = 1, ao_prim_num(i)
coef1 = ao_coef_normalized_ordered_transp(p, i)
expo1 = ao_expo_ordered_transp(p, i)
do q = 1, ao_prim_num(j)
coef2 = coef1 * ao_coef_normalized_ordered_transp(q, j)
expo2 = ao_expo_ordered_transp(q, j)
call give_explicit_poly_and_gaussian( P_new_tmp, P_center_tmp, pp_tmp, fact_p_tmp, iorder_p, expo1, expo2 &
, I_power, J_power, I_center, J_center, dim1 )
do r = 1, ao_prim_num(k)
coef3 = coef2 * ao_coef_normalized_ordered_transp(r, k)
expo3 = ao_expo_ordered_transp(r, k)
do s = 1, ao_prim_num(l)
coef4 = coef3 * ao_coef_normalized_ordered_transp(s, l)
expo4 = ao_expo_ordered_transp(s, l)
call give_explicit_poly_and_gaussian( Q_new, Q_center, qq, fact_q, iorder_q, expo3, expo4 &
, K_power, L_power, K_center, L_center, dim1 )
q_inv = 1.d0 / qq
cx = 0.d0
do ii = 1, nucl_num
expoii = j1b_gauss_pen(ii)
Centerii(1:3) = nucl_coord(ii, 1:3)
call gaussian_product(pp_tmp, P_center_tmp, expoii, Centerii, factii, pp, P_center)
fact_p = fact_p_tmp * factii
p_inv = 1.d0 / pp
P_new(:,:) = 0.d0
call pol_modif_center( P_center_tmp, P_center, iorder_p, P_new_tmp, P_new)
! ----------------------------------------------------------------------------------------------------
! x term:
cx = cx + expoii * general_primitive_integral_coul_shifted( dim1 &
, P_new, P_center, fact_p, pp, p_inv, iorder_p, shift_P &
, Q_new, Q_center, fact_q, qq, q_inv, iorder_q, shift_Q )
! ----------------------------------------------------------------------------------------------------
enddo
j1b_gauss_coul_modifdebug = j1b_gauss_coul_modifdebug + coef4 * cx
enddo ! s
enddo ! r
enddo ! q
enddo ! p
! -------------------------------------------------------------------------------------------------------------------
! -------------------------------------------------------------------------------------------------------------------
! -------------------------------------------------------------------------------------------------------------------
!
! [ 1 / r12 ] \sum_A a_A exp(-aA r2A^2)
!
! -------------------------------------------------------------------------------------------------------------------
shift_P = (/ 0, 0, 0 /)
shift_Q = (/ 0, 0, 0 /)
do p = 1, ao_prim_num(i)
coef1 = ao_coef_normalized_ordered_transp(p, i)
expo1 = ao_expo_ordered_transp(p, i)
do q = 1, ao_prim_num(j)
coef2 = coef1 * ao_coef_normalized_ordered_transp(q, j)
expo2 = ao_expo_ordered_transp(q, j)
call give_explicit_poly_and_gaussian( P_new, P_center, pp, fact_p, iorder_p, expo1, expo2 &
, I_power, J_power, I_center, J_center, dim1 )
p_inv = 1.d0 / pp
do r = 1, ao_prim_num(k)
coef3 = coef2 * ao_coef_normalized_ordered_transp(r, k)
expo3 = ao_expo_ordered_transp(r, k)
do s = 1, ao_prim_num(l)
coef4 = coef3 * ao_coef_normalized_ordered_transp(s, l)
expo4 = ao_expo_ordered_transp(s, l)
call give_explicit_poly_and_gaussian( Q_new_tmp, Q_center_tmp, qq_tmp, fact_q_tmp, iorder_q, expo3, expo4 &
, K_power, L_power, K_center, L_center, dim1 )
cx = 0.d0
do ii = 1, nucl_num
expoii = j1b_gauss_pen(ii)
Centerii(1:3) = nucl_coord(ii, 1:3)
call gaussian_product(qq_tmp, Q_center_tmp, expoii, Centerii, factii, qq, Q_center)
fact_q = fact_q_tmp * factii
Q_inv = 1.d0 / qq
call pol_modif_center( Q_center_tmp, Q_center, iorder_q, Q_new_tmp, Q_new)
! ----------------------------------------------------------------------------------------------------
! x term:
cx = cx + expoii * general_primitive_integral_coul_shifted( dim1 &
, P_new, P_center, fact_p, pp, p_inv, iorder_p, shift_P &
, Q_new, Q_center, fact_q, qq, q_inv, iorder_q, shift_Q )
! ----------------------------------------------------------------------------------------------------
enddo
j1b_gauss_coul_modifdebug = j1b_gauss_coul_modifdebug + coef4 * cx
enddo ! s
enddo ! r
enddo ! q
enddo ! p
! -------------------------------------------------------------------------------------------------------------------
! -------------------------------------------------------------------------------------------------------------------
return
end function j1b_gauss_coul_modifdebug
double precision function general_primitive_integral_coul(dim, &
P_new,P_center,fact_p,p,p_inv,iorder_p, &
Q_new,Q_center,fact_q,q,q_inv,iorder_q)
implicit none
BEGIN_DOC
! Computes the integral <pq|rs> where p,q,r,s are Gaussian primitives
END_DOC
integer,intent(in) :: dim
include 'utils/constants.include.F'
double precision, intent(in) :: P_new(0:max_dim,3),P_center(3),fact_p,p,p_inv
double precision, intent(in) :: Q_new(0:max_dim,3),Q_center(3),fact_q,q,q_inv
integer, intent(in) :: iorder_p(3)
integer, intent(in) :: iorder_q(3)
double precision :: r_cut,gama_r_cut,rho,dist
double precision :: dx(0:max_dim),Ix_pol(0:max_dim),dy(0:max_dim),Iy_pol(0:max_dim),dz(0:max_dim),Iz_pol(0:max_dim)
integer :: n_Ix,n_Iy,n_Iz,nx,ny,nz
double precision :: bla
integer :: ix,iy,iz,jx,jy,jz,i
double precision :: a,b,c,d,e,f,accu,pq,const
double precision :: pq_inv, p10_1, p10_2, p01_1, p01_2,pq_inv_2
integer :: n_pt_tmp,n_pt_out, iorder
double precision :: d1(0:max_dim),d_poly(0:max_dim),rint,d1_screened(0:max_dim)
general_primitive_integral_coul = 0.d0
!DIR$ ATTRIBUTES ALIGN : $IRP_ALIGN :: dx,Ix_pol,dy,Iy_pol,dz,Iz_pol
!DIR$ ATTRIBUTES ALIGN : $IRP_ALIGN :: d1, d_poly
! Gaussian Product
! ----------------
pq = p_inv*0.5d0*q_inv
pq_inv = 0.5d0/(p+q)
p10_1 = q*pq ! 1/(2p)
p01_1 = p*pq ! 1/(2q)
pq_inv_2 = pq_inv+pq_inv
p10_2 = pq_inv_2 * p10_1*q !0.5d0*q/(pq + p*p)
p01_2 = pq_inv_2 * p01_1*p !0.5d0*p/(q*q + pq)
accu = 0.d0
iorder = iorder_p(1)+iorder_q(1)+iorder_p(1)+iorder_q(1)
do ix=0,iorder
Ix_pol(ix) = 0.d0
enddo
n_Ix = 0
do ix = 0, iorder_p(1)
if (abs(P_new(ix,1)) < thresh) cycle
a = P_new(ix,1)
do jx = 0, iorder_q(1)
d = a*Q_new(jx,1)
if (abs(d) < thresh) cycle
!DIR$ FORCEINLINE
call give_polynom_mult_center_x(P_center(1),Q_center(1),ix,jx,p,q,iorder,pq_inv,pq_inv_2,p10_1,p01_1,p10_2,p01_2,dx,nx)
!DIR$ FORCEINLINE
call add_poly_multiply(dx,nx,d,Ix_pol,n_Ix)
enddo
enddo
if (n_Ix == -1) then
return
endif
iorder = iorder_p(2)+iorder_q(2)+iorder_p(2)+iorder_q(2)
do ix=0, iorder
Iy_pol(ix) = 0.d0
enddo
n_Iy = 0
do iy = 0, iorder_p(2)
if (abs(P_new(iy,2)) > thresh) then
b = P_new(iy,2)
do jy = 0, iorder_q(2)
e = b*Q_new(jy,2)
if (abs(e) < thresh) cycle
!DIR$ FORCEINLINE
call give_polynom_mult_center_x(P_center(2),Q_center(2),iy,jy,p,q,iorder,pq_inv,pq_inv_2,p10_1,p01_1,p10_2,p01_2,dy,ny)
!DIR$ FORCEINLINE
call add_poly_multiply(dy,ny,e,Iy_pol,n_Iy)
enddo
endif
enddo
if (n_Iy == -1) then
return
endif
iorder = iorder_p(3)+iorder_q(3)+iorder_p(3)+iorder_q(3)
do ix=0,iorder
Iz_pol(ix) = 0.d0
enddo
n_Iz = 0
do iz = 0, iorder_p(3)
if (abs(P_new(iz,3)) > thresh) then
c = P_new(iz,3)
do jz = 0, iorder_q(3)
f = c*Q_new(jz,3)
if (abs(f) < thresh) cycle
!DIR$ FORCEINLINE
call give_polynom_mult_center_x(P_center(3),Q_center(3),iz,jz,p,q,iorder,pq_inv,pq_inv_2,p10_1,p01_1,p10_2,p01_2,dz,nz)
!DIR$ FORCEINLINE
call add_poly_multiply(dz,nz,f,Iz_pol,n_Iz)
enddo
endif
enddo
if (n_Iz == -1) then
return
endif
rho = p*q *pq_inv_2
dist = (P_center(1) - Q_center(1))*(P_center(1) - Q_center(1)) + &
(P_center(2) - Q_center(2))*(P_center(2) - Q_center(2)) + &
(P_center(3) - Q_center(3))*(P_center(3) - Q_center(3))
const = dist*rho
n_pt_tmp = n_Ix+n_Iy
do i=0,n_pt_tmp
d_poly(i)=0.d0
enddo
!DIR$ FORCEINLINE
call multiply_poly(Ix_pol,n_Ix,Iy_pol,n_Iy,d_poly,n_pt_tmp)
if (n_pt_tmp == -1) then
return
endif
n_pt_out = n_pt_tmp+n_Iz
do i=0,n_pt_out
d1(i)=0.d0
enddo
!DIR$ FORCEINLINE
call multiply_poly(d_poly ,n_pt_tmp ,Iz_pol,n_Iz,d1,n_pt_out)
double precision :: rint_sum
accu = accu + rint_sum(n_pt_out,const,d1)
general_primitive_integral_coul = fact_p * fact_q * accu *pi_5_2*p_inv*q_inv/dsqrt(p+q)
end function general_primitive_integral_coul

102
src/ao_tc_eff_map/two_e_1bgauss_coulerf.irp.f Normal file
View File

@ -0,0 +1,102 @@
double precision function j1b_gauss_coulerf(i, j, k, l)
BEGIN_DOC
!
! integral in the AO basis:
! i(r1) j(r1) f(r12) k(r2) l(r2)
!
! with:
! f(r12) = - [ (0.5 - 0.5 erf(mu r12)) / r12 ] (r1-r2) \cdot \sum_A (-2 a_A) [ r1A exp(-aA r1A^2) - r2A exp(-aA r2A^2) ]
! = [ (1 - erf(mu r12) / r12 ] \sum_A a_A [ (r1-RA)^2 exp(-aA r1A^2)
! + (r2-RA)^2 exp(-aA r2A^2)
! - (r1-RA) \cdot (r2-RA) exp(-aA r1A^2)
! - (r1-RA) \cdot (r2-RA) exp(-aA r2A^2) ]
!
END_DOC
include 'utils/constants.include.F'
implicit none
integer, intent(in) :: i, j, k, l
integer :: p, q, r, s
integer :: num_i, num_j, num_k, num_l, num_ii
integer :: I_power(3), J_power(3), K_power(3), L_power(3)
integer :: iorder_p(3), iorder_q(3)
integer :: shift_P(3), shift_Q(3)
integer :: dim1
double precision :: coef1, coef2, coef3, coef4
double precision :: expo1, expo2, expo3, expo4
double precision :: P1_new(0:max_dim,3), P1_center(3), fact_p1, pp1, p1_inv
double precision :: Q1_new(0:max_dim,3), Q1_center(3), fact_q1, qq1, q1_inv
double precision :: I_center(3), J_center(3), K_center(3), L_center(3)
double precision :: ff, gg, cx, cy, cz
double precision :: j1b_gauss_coulerf_schwartz
PROVIDE j1b_gauss_pen
dim1 = n_pt_max_integrals
if( ao_prim_num(i) * ao_prim_num(j) * ao_prim_num(k) * ao_prim_num(l) > 1024 ) then
j1b_gauss_coulerf = j1b_gauss_coulerf_schwartz(i, j, k, l)
return
endif
num_i = ao_nucl(i)
num_j = ao_nucl(j)
num_k = ao_nucl(k)
num_l = ao_nucl(l)
do p = 1, 3
I_power(p) = ao_power(i,p)
J_power(p) = ao_power(j,p)
K_power(p) = ao_power(k,p)
L_power(p) = ao_power(l,p)
I_center(p) = nucl_coord(num_i,p)
J_center(p) = nucl_coord(num_j,p)
K_center(p) = nucl_coord(num_k,p)
L_center(p) = nucl_coord(num_l,p)
enddo
j1b_gauss_coulerf = 0.d0
do p = 1, ao_prim_num(i)
coef1 = ao_coef_normalized_ordered_transp(p, i)
expo1 = ao_expo_ordered_transp(p, i)
do q = 1, ao_prim_num(j)
coef2 = coef1 * ao_coef_normalized_ordered_transp(q, j)
expo2 = ao_expo_ordered_transp(q, j)
call give_explicit_poly_and_gaussian( P1_new, P1_center, pp1, fact_p1, iorder_p, expo1, expo2 &
, I_power, J_power, I_center, J_center, dim1 )
p1_inv = 1.d0 / pp1
do r = 1, ao_prim_num(k)
coef3 = coef2 * ao_coef_normalized_ordered_transp(r, k)
expo3 = ao_expo_ordered_transp(r, k)
do s = 1, ao_prim_num(l)
coef4 = coef3 * ao_coef_normalized_ordered_transp(s, l)
expo4 = ao_expo_ordered_transp(s, l)
call give_explicit_poly_and_gaussian( Q1_new, Q1_center, qq1, fact_q1, iorder_q, expo3, expo4 &
, K_power, L_power, K_center, L_center, dim1 )
q1_inv = 1.d0 / qq1
call get_cxcycz( dim1, cx, cy, cz &
, P1_center, P1_new, pp1, fact_p1, p1_inv, iorder_p &
, Q1_center, Q1_new, qq1, fact_q1, q1_inv, iorder_q )
j1b_gauss_coulerf = j1b_gauss_coulerf + coef4 * ( cx + cy + cz )
enddo ! s
enddo ! r
enddo ! q
enddo ! p
return
end function j1b_gauss_coulerf

624
src/ao_tc_eff_map/two_e_1bgauss_coulerf_schwartz.irp.f Normal file
View File

@ -0,0 +1,624 @@
double precision function j1b_gauss_coulerf_schwartz(i, j, k, l)
BEGIN_DOC
!
! integral in the AO basis:
! i(r1) j(r1) f(r12) k(r2) l(r2)
!
! with:
! f(r12) = - [ (0.5 - 0.5 erf(mu r12)) / r12 ] (r1-r2) \cdot \sum_A (-2 a_A) [ r1A exp(-aA r1A^2) - r2A exp(-aA r2A^2) ]
! = [ (1 - erf(mu r12) / r12 ] \sum_A a_A [ (r1-RA)^2 exp(-aA r1A^2)
! + (r2-RA)^2 exp(-aA r2A^2)
! - (r1-RA) \cdot (r2-RA) exp(-aA r1A^2)
! - (r1-RA) \cdot (r2-RA) exp(-aA r2A^2) ]
!
END_DOC
include 'utils/constants.include.F'
implicit none
integer, intent(in) :: i, j, k, l
integer :: p, q, r, s
integer :: num_i, num_j, num_k, num_l, num_ii
integer :: I_power(3), J_power(3), K_power(3), L_power(3)
integer :: iorder_p(3), iorder_q(3)
integer :: dim1
double precision :: coef1, coef2, coef3, coef4
double precision :: expo1, expo2, expo3, expo4
double precision :: P1_new(0:max_dim,3), P1_center(3), fact_p1, pp1, p1_inv
double precision :: Q1_new(0:max_dim,3), Q1_center(3), fact_q1, qq1, q1_inv
double precision :: I_center(3), J_center(3), K_center(3), L_center(3)
double precision :: cx, cy, cz
double precision :: schwartz_ij, thr
double precision, allocatable :: schwartz_kl(:,:)
PROVIDE j1b_gauss_pen
dim1 = n_pt_max_integrals
thr = ao_integrals_threshold * ao_integrals_threshold
num_i = ao_nucl(i)
num_j = ao_nucl(j)
num_k = ao_nucl(k)
num_l = ao_nucl(l)
do p = 1, 3
I_power(p) = ao_power(i,p)
J_power(p) = ao_power(j,p)
K_power(p) = ao_power(k,p)
L_power(p) = ao_power(l,p)
I_center(p) = nucl_coord(num_i,p)
J_center(p) = nucl_coord(num_j,p)
K_center(p) = nucl_coord(num_k,p)
L_center(p) = nucl_coord(num_l,p)
enddo
allocate( schwartz_kl(0:ao_prim_num(l) , 0:ao_prim_num(k)) )
schwartz_kl(0,0) = 0.d0
do r = 1, ao_prim_num(k)
expo3 = ao_expo_ordered_transp(r,k)
coef3 = ao_coef_normalized_ordered_transp(r,k) * ao_coef_normalized_ordered_transp(r,k)
schwartz_kl(0,r) = 0.d0
do s = 1, ao_prim_num(l)
expo4 = ao_expo_ordered_transp(s,l)
coef4 = coef3 * ao_coef_normalized_ordered_transp(s,l) * ao_coef_normalized_ordered_transp(s,l)
call give_explicit_poly_and_gaussian( Q1_new, Q1_center, qq1, fact_q1, iorder_q, expo3, expo4 &
, K_power, L_power, K_center, L_center, dim1 )
q1_inv = 1.d0 / qq1
call get_cxcycz( dim1, cx, cy, cz &
, Q1_center, Q1_new, qq1, fact_q1, q1_inv, iorder_q &
, Q1_center, Q1_new, qq1, fact_q1, q1_inv, iorder_q )
schwartz_kl(s,r) = coef4 * dabs( cx + cy + cz )
schwartz_kl(0,r) = max( schwartz_kl(0,r) , schwartz_kl(s,r) )
enddo
schwartz_kl(0,0) = max( schwartz_kl(0,r) , schwartz_kl(0,0) )
enddo
j1b_gauss_coulerf_schwartz = 0.d0
do p = 1, ao_prim_num(i)
expo1 = ao_expo_ordered_transp(p, i)
coef1 = ao_coef_normalized_ordered_transp(p, i)
do q = 1, ao_prim_num(j)
expo2 = ao_expo_ordered_transp(q, j)
coef2 = coef1 * ao_coef_normalized_ordered_transp(q, j)
call give_explicit_poly_and_gaussian( P1_new, P1_center, pp1, fact_p1, iorder_p, expo1, expo2 &
, I_power, J_power, I_center, J_center, dim1 )
p1_inv = 1.d0 / pp1
call get_cxcycz( dim1, cx, cy, cz &
, P1_center, P1_new, pp1, fact_p1, p1_inv, iorder_p &
, P1_center, P1_new, pp1, fact_p1, p1_inv, iorder_p )
schwartz_ij = coef2 * coef2 * dabs( cx + cy + cz )
if( schwartz_kl(0,0) * schwartz_ij < thr ) cycle
do r = 1, ao_prim_num(k)
if( schwartz_kl(0,r) * schwartz_ij < thr ) cycle
coef3 = coef2 * ao_coef_normalized_ordered_transp(r, k)
expo3 = ao_expo_ordered_transp(r, k)
do s = 1, ao_prim_num(l)
if( schwartz_kl(s,r) * schwartz_ij < thr ) cycle
coef4 = coef3 * ao_coef_normalized_ordered_transp(s, l)
expo4 = ao_expo_ordered_transp(s, l)
call give_explicit_poly_and_gaussian( Q1_new, Q1_center, qq1, fact_q1, iorder_q, expo3, expo4 &
, K_power, L_power, K_center, L_center, dim1 )
q1_inv = 1.d0 / qq1
call get_cxcycz( dim1, cx, cy, cz &
, P1_center, P1_new, pp1, fact_p1, p1_inv, iorder_p &
, Q1_center, Q1_new, qq1, fact_q1, q1_inv, iorder_q )
j1b_gauss_coulerf_schwartz = j1b_gauss_coulerf_schwartz + coef4 * ( cx + cy + cz )
enddo ! s
enddo ! r
enddo ! q
enddo ! p
deallocate( schwartz_kl )
return
end function j1b_gauss_coulerf_schwartz
subroutine get_cxcycz( dim1, cx, cy, cz &
, P1_center, P1_new, pp1, fact_p1, p1_inv, iorder_p &
, Q1_center, Q1_new, qq1, fact_q1, q1_inv, iorder_q )
include 'utils/constants.include.F'
implicit none
integer, intent(in) :: dim1
integer, intent(in) :: iorder_p(3), iorder_q(3)
double precision, intent(in) :: P1_new(0:max_dim,3), P1_center(3), fact_p1, pp1, p1_inv
double precision, intent(in) :: Q1_new(0:max_dim,3), Q1_center(3), fact_q1, qq1, q1_inv
double precision, intent(out) :: cx, cy, cz
integer :: ii
integer :: shift_P(3), shift_Q(3)
double precision :: expoii, factii, Centerii(3)
double precision :: P2_new(0:max_dim,3), P2_center(3), fact_p2, pp2, p2_inv
double precision :: Q2_new(0:max_dim,3), Q2_center(3), fact_q2, qq2, q2_inv
double precision :: ff, gg
double precision :: general_primitive_integral_erf_shifted
double precision :: general_primitive_integral_coul_shifted
cx = 0.d0
cy = 0.d0
cz = 0.d0
do ii = 1, nucl_num
expoii = j1b_gauss_pen(ii)
Centerii(1:3) = nucl_coord(ii, 1:3)
call gaussian_product(pp1, P1_center, expoii, Centerii, factii, pp2, P2_center)
fact_p2 = fact_p1 * factii
p2_inv = 1.d0 / pp2
call pol_modif_center( P1_center, P2_center, iorder_p, P1_new, P2_new )
call gaussian_product(qq1, Q1_center, expoii, Centerii, factii, qq2, Q2_center)
fact_q2 = fact_q1 * factii
q2_inv = 1.d0 / qq2
call pol_modif_center( Q1_center, Q2_center, iorder_q, Q1_new, Q2_new )
! ----------------------------------------------------------------------------------------------------
! [ (1-erf(mu r12)) / r12 ] \sum_A a_A [ (r1-RA)^2 exp(-aA r1A^2)
! ----------------------------------------------------------------------------------------------------
shift_Q = (/ 0, 0, 0 /)
! x term:
ff = P2_center(1) - Centerii(1)
shift_P = (/ 2, 0, 0 /)
cx = cx + expoii * general_primitive_integral_coul_shifted( dim1 &
, P2_new, P2_center, fact_p2, pp2, p2_inv, iorder_p, shift_P &
, Q1_new, Q1_center, fact_q1, qq1, q1_inv, iorder_q, shift_Q )
cx = cx - expoii * general_primitive_integral_erf_shifted( dim1 &
, P2_new, P2_center, fact_p2, pp2, p2_inv, iorder_p, shift_P &
, Q1_new, Q1_center, fact_q1, qq1, q1_inv, iorder_q, shift_Q )
shift_P = (/ 1, 0, 0 /)
cx = cx + expoii * 2.d0 * ff * general_primitive_integral_coul_shifted( dim1 &
, P2_new, P2_center, fact_p2, pp2, p2_inv, iorder_p, shift_P &
, Q1_new, Q1_center, fact_q1, qq1, q1_inv, iorder_q, shift_Q )
cx = cx - expoii * 2.d0 * ff * general_primitive_integral_erf_shifted( dim1 &
, P2_new, P2_center, fact_p2, pp2, p2_inv, iorder_p, shift_P &
, Q1_new, Q1_center, fact_q1, qq1, q1_inv, iorder_q, shift_Q )
shift_P = (/ 0, 0, 0 /)
cx = cx + expoii * ff * ff * general_primitive_integral_coul_shifted( dim1 &
, P2_new, P2_center, fact_p2, pp2, p2_inv, iorder_p, shift_P &
, Q1_new, Q1_center, fact_q1, qq1, q1_inv, iorder_q, shift_Q )
cx = cx - expoii * ff * ff * general_primitive_integral_erf_shifted( dim1 &
, P2_new, P2_center, fact_p2, pp2, p2_inv, iorder_p, shift_P &
, Q1_new, Q1_center, fact_q1, qq1, q1_inv, iorder_q, shift_Q )
! y term:
ff = P2_center(2) - Centerii(2)
shift_P = (/ 0, 2, 0 /)
cy = cy + expoii * general_primitive_integral_coul_shifted( dim1 &
, P2_new, P2_center, fact_p2, pp2, p2_inv, iorder_p, shift_P &
, Q1_new, Q1_center, fact_q1, qq1, q1_inv, iorder_q, shift_Q )
cy = cy - expoii * general_primitive_integral_erf_shifted( dim1 &
, P2_new, P2_center, fact_p2, pp2, p2_inv, iorder_p, shift_P &
, Q1_new, Q1_center, fact_q1, qq1, q1_inv, iorder_q, shift_Q )
shift_P = (/ 0, 1, 0 /)
cy = cy + expoii * 2.d0 * ff * general_primitive_integral_coul_shifted( dim1 &
, P2_new, P2_center, fact_p2, pp2, p2_inv, iorder_p, shift_P &
, Q1_new, Q1_center, fact_q1, qq1, q1_inv, iorder_q, shift_Q )
cy = cy - expoii * 2.d0 * ff * general_primitive_integral_erf_shifted( dim1 &
, P2_new, P2_center, fact_p2, pp2, p2_inv, iorder_p, shift_P &
, Q1_new, Q1_center, fact_q1, qq1, q1_inv, iorder_q, shift_Q )
shift_P = (/ 0, 0, 0 /)
cy = cy + expoii * ff * ff * general_primitive_integral_coul_shifted( dim1 &
, P2_new, P2_center, fact_p2, pp2, p2_inv, iorder_p, shift_P &
, Q1_new, Q1_center, fact_q1, qq1, q1_inv, iorder_q, shift_Q )
cy = cy - expoii * ff * ff * general_primitive_integral_erf_shifted( dim1 &
, P2_new, P2_center, fact_p2, pp2, p2_inv, iorder_p, shift_P &
, Q1_new, Q1_center, fact_q1, qq1, q1_inv, iorder_q, shift_Q )
! z term:
ff = P2_center(3) - Centerii(3)
shift_P = (/ 0, 0, 2 /)
cz = cz + expoii * general_primitive_integral_coul_shifted( dim1 &
, P2_new, P2_center, fact_p2, pp2, p2_inv, iorder_p, shift_P &
, Q1_new, Q1_center, fact_q1, qq1, q1_inv, iorder_q, shift_Q )
cz = cz - expoii * general_primitive_integral_erf_shifted( dim1 &
, P2_new, P2_center, fact_p2, pp2, p2_inv, iorder_p, shift_P &
, Q1_new, Q1_center, fact_q1, qq1, q1_inv, iorder_q, shift_Q )
shift_P = (/ 0, 0, 1 /)
cz = cz + expoii * 2.d0 * ff * general_primitive_integral_coul_shifted( dim1 &
, P2_new, P2_center, fact_p2, pp2, p2_inv, iorder_p, shift_P &
, Q1_new, Q1_center, fact_q1, qq1, q1_inv, iorder_q, shift_Q )
cz = cz - expoii * 2.d0 * ff * general_primitive_integral_erf_shifted( dim1 &
, P2_new, P2_center, fact_p2, pp2, p2_inv, iorder_p, shift_P &
, Q1_new, Q1_center, fact_q1, qq1, q1_inv, iorder_q, shift_Q )
shift_P = (/ 0, 0, 0 /)
cz = cz + expoii * ff * ff * general_primitive_integral_coul_shifted( dim1 &
, P2_new, P2_center, fact_p2, pp2, p2_inv, iorder_p, shift_P &
, Q1_new, Q1_center, fact_q1, qq1, q1_inv, iorder_q, shift_Q )
cz = cz - expoii * ff * ff * general_primitive_integral_erf_shifted( dim1 &
, P2_new, P2_center, fact_p2, pp2, p2_inv, iorder_p, shift_P &
, Q1_new, Q1_center, fact_q1, qq1, q1_inv, iorder_q, shift_Q )
! ----------------------------------------------------------------------------------------------------
! ----------------------------------------------------------------------------------------------------
! [ (1-erf(mu r12)) / r12 ] \sum_A a_A [ (r2-RA)^2 exp(-aA r2A^2)
! ----------------------------------------------------------------------------------------------------
shift_P = (/ 0, 0, 0 /)
! x term:
ff = Q2_center(1) - Centerii(1)
shift_Q = (/ 2, 0, 0 /)
cx = cx + expoii * general_primitive_integral_coul_shifted( dim1 &
, P1_new, P1_center, fact_p1, pp1, p1_inv, iorder_p, shift_P &
, Q2_new, Q2_center, fact_q2, qq2, q2_inv, iorder_q, shift_Q )
cx = cx - expoii * general_primitive_integral_erf_shifted( dim1 &
, P1_new, P1_center, fact_p1, pp1, p1_inv, iorder_p, shift_P &
, Q2_new, Q2_center, fact_q2, qq2, q2_inv, iorder_q, shift_Q )
shift_Q = (/ 1, 0, 0 /)
cx = cx + expoii * 2.d0 * ff * general_primitive_integral_coul_shifted( dim1 &
, P1_new, P1_center, fact_p1, pp1, p1_inv, iorder_p, shift_P &
, Q2_new, Q2_center, fact_q2, qq2, q2_inv, iorder_q, shift_Q )
cx = cx - expoii * 2.d0 * ff * general_primitive_integral_erf_shifted( dim1 &
, P1_new, P1_center, fact_p1, pp1, p1_inv, iorder_p, shift_P &
, Q2_new, Q2_center, fact_q2, qq2, q2_inv, iorder_q, shift_Q )
shift_Q = (/ 0, 0, 0 /)
cx = cx + expoii * ff * ff * general_primitive_integral_coul_shifted( dim1 &
, P1_new, P1_center, fact_p1, pp1, p1_inv, iorder_p, shift_P &
, Q2_new, Q2_center, fact_q2, qq2, q2_inv, iorder_q, shift_Q )
cx = cx - expoii * ff * ff * general_primitive_integral_erf_shifted( dim1 &
, P1_new, P1_center, fact_p1, pp1, p1_inv, iorder_p, shift_P &
, Q2_new, Q2_center, fact_q2, qq2, q2_inv, iorder_q, shift_Q )
! y term:
ff = Q2_center(2) - Centerii(2)
shift_Q = (/ 0, 2, 0 /)
cy = cy + expoii * general_primitive_integral_coul_shifted( dim1 &
, P1_new, P1_center, fact_p1, pp1, p1_inv, iorder_p, shift_P &
, Q2_new, Q2_center, fact_q2, qq2, q2_inv, iorder_q, shift_Q )
cy = cy - expoii * general_primitive_integral_erf_shifted( dim1 &
, P1_new, P1_center, fact_p1, pp1, p1_inv, iorder_p, shift_P &
, Q2_new, Q2_center, fact_q2, qq2, q2_inv, iorder_q, shift_Q )
shift_Q = (/ 0, 1, 0 /)
cy = cy + expoii * 2.d0 * ff * general_primitive_integral_coul_shifted( dim1 &
, P1_new, P1_center, fact_p1, pp1, p1_inv, iorder_p, shift_P &
, Q2_new, Q2_center, fact_q2, qq2, q2_inv, iorder_q, shift_Q )
cy = cy - expoii * 2.d0 * ff * general_primitive_integral_erf_shifted( dim1 &
, P1_new, P1_center, fact_p1, pp1, p1_inv, iorder_p, shift_P &
, Q2_new, Q2_center, fact_q2, qq2, q2_inv, iorder_q, shift_Q )
shift_Q = (/ 0, 0, 0 /)
cy = cy + expoii * ff * ff * general_primitive_integral_coul_shifted( dim1 &
, P1_new, P1_center, fact_p1, pp1, p1_inv, iorder_p, shift_P &
, Q2_new, Q2_center, fact_q2, qq2, q2_inv, iorder_q, shift_Q )
cy = cy - expoii * ff * ff * general_primitive_integral_erf_shifted( dim1 &
, P1_new, P1_center, fact_p1, pp1, p1_inv, iorder_p, shift_P &
, Q2_new, Q2_center, fact_q2, qq2, q2_inv, iorder_q, shift_Q )
! z term:
ff = Q2_center(3) - Centerii(3)
shift_Q = (/ 0, 0, 2 /)
cz = cz + expoii * general_primitive_integral_coul_shifted( dim1 &
, P1_new, P1_center, fact_p1, pp1, p1_inv, iorder_p, shift_P &
, Q2_new, Q2_center, fact_q2, qq2, q2_inv, iorder_q, shift_Q )
cz = cz - expoii * general_primitive_integral_erf_shifted( dim1 &
, P1_new, P1_center, fact_p1, pp1, p1_inv, iorder_p, shift_P &
, Q2_new, Q2_center, fact_q2, qq2, q2_inv, iorder_q, shift_Q )
shift_Q = (/ 0, 0, 1 /)
cz = cz + expoii * 2.d0 * ff * general_primitive_integral_coul_shifted( dim1 &
, P1_new, P1_center, fact_p1, pp1, p1_inv, iorder_p, shift_P &
, Q2_new, Q2_center, fact_q2, qq2, q2_inv, iorder_q, shift_Q )
cz = cz - expoii * 2.d0 * ff * general_primitive_integral_erf_shifted( dim1 &
, P1_new, P1_center, fact_p1, pp1, p1_inv, iorder_p, shift_P &
, Q2_new, Q2_center, fact_q2, qq2, q2_inv, iorder_q, shift_Q )
shift_Q = (/ 0, 0, 0 /)
cz = cz + expoii * ff * ff * general_primitive_integral_coul_shifted( dim1 &
, P1_new, P1_center, fact_p1, pp1, p1_inv, iorder_p, shift_P &
, Q2_new, Q2_center, fact_q2, qq2, q2_inv, iorder_q, shift_Q )
cz = cz - expoii * ff * ff * general_primitive_integral_erf_shifted( dim1 &
, P1_new, P1_center, fact_p1, pp1, p1_inv, iorder_p, shift_P &
, Q2_new, Q2_center, fact_q2, qq2, q2_inv, iorder_q, shift_Q )
! ----------------------------------------------------------------------------------------------------
! ----------------------------------------------------------------------------------------------------
! - [ (1-erf(mu r12)) / r12 ] \sum_A a_A [ (r1-RA) \cdot (r2-RA) exp(-aA r1A^2) ]
! ----------------------------------------------------------------------------------------------------
! x term:
ff = P2_center(1) - Centerii(1)
gg = Q1_center(1) - Centerii(1)
shift_p = (/ 1, 0, 0 /)
shift_Q = (/ 1, 0, 0 /)
cx = cx - expoii * general_primitive_integral_coul_shifted( dim1 &
, P2_new, P2_center, fact_p2, pp2, p2_inv, iorder_p, shift_P &
, Q1_new, Q1_center, fact_q1, qq1, q1_inv, iorder_q, shift_Q )
cx = cx + expoii * general_primitive_integral_erf_shifted( dim1 &
, P2_new, P2_center, fact_p2, pp2, p2_inv, iorder_p, shift_P &
, Q1_new, Q1_center, fact_q1, qq1, q1_inv, iorder_q, shift_Q )
shift_p = (/ 1, 0, 0 /)
shift_Q = (/ 0, 0, 0 /)
cx = cx - expoii * gg * general_primitive_integral_coul_shifted( dim1 &
, P2_new, P2_center, fact_p2, pp2, p2_inv, iorder_p, shift_P &
, Q1_new, Q1_center, fact_q1, qq1, q1_inv, iorder_q, shift_Q )
cx = cx + expoii * gg * general_primitive_integral_erf_shifted( dim1 &
, P2_new, P2_center, fact_p2, pp2, p2_inv, iorder_p, shift_P &
, Q1_new, Q1_center, fact_q1, qq1, q1_inv, iorder_q, shift_Q )
shift_p = (/ 0, 0, 0 /)
shift_Q = (/ 1, 0, 0 /)
cx = cx - expoii * ff * general_primitive_integral_coul_shifted( dim1 &
, P2_new, P2_center, fact_p2, pp2, p2_inv, iorder_p, shift_P &
, Q1_new, Q1_center, fact_q1, qq1, q1_inv, iorder_q, shift_Q )
cx = cx + expoii * ff * general_primitive_integral_erf_shifted( dim1 &
, P2_new, P2_center, fact_p2, pp2, p2_inv, iorder_p, shift_P &
, Q1_new, Q1_center, fact_q1, qq1, q1_inv, iorder_q, shift_Q )
shift_p = (/ 0, 0, 0 /)
shift_Q = (/ 0, 0, 0 /)
cx = cx - expoii * ff * gg * general_primitive_integral_coul_shifted( dim1 &
, P2_new, P2_center, fact_p2, pp2, p2_inv, iorder_p, shift_P &
, Q1_new, Q1_center, fact_q1, qq1, q1_inv, iorder_q, shift_Q )
cx = cx + expoii * ff * gg * general_primitive_integral_erf_shifted( dim1 &
, P2_new, P2_center, fact_p2, pp2, p2_inv, iorder_p, shift_P &
, Q1_new, Q1_center, fact_q1, qq1, q1_inv, iorder_q, shift_Q )
! y term:
ff = P2_center(2) - Centerii(2)
gg = Q1_center(2) - Centerii(2)
shift_p = (/ 0, 1, 0 /)
shift_Q = (/ 0, 1, 0 /)
cy = cy - expoii * general_primitive_integral_coul_shifted( dim1 &
, P2_new, P2_center, fact_p2, pp2, p2_inv, iorder_p, shift_P &
, Q1_new, Q1_center, fact_q1, qq1, q1_inv, iorder_q, shift_Q )
cy = cy + expoii * general_primitive_integral_erf_shifted( dim1 &
, P2_new, P2_center, fact_p2, pp2, p2_inv, iorder_p, shift_P &
, Q1_new, Q1_center, fact_q1, qq1, q1_inv, iorder_q, shift_Q )
shift_p = (/ 0, 1, 0 /)
shift_Q = (/ 0, 0, 0 /)
cy = cy - expoii * gg * general_primitive_integral_coul_shifted( dim1 &
, P2_new, P2_center, fact_p2, pp2, p2_inv, iorder_p, shift_P &
, Q1_new, Q1_center, fact_q1, qq1, q1_inv, iorder_q, shift_Q )
cy = cy + expoii * gg * general_primitive_integral_erf_shifted( dim1 &
, P2_new, P2_center, fact_p2, pp2, p2_inv, iorder_p, shift_P &
, Q1_new, Q1_center, fact_q1, qq1, q1_inv, iorder_q, shift_Q )
shift_p = (/ 0, 0, 0 /)
shift_Q = (/ 0, 1, 0 /)
cy = cy - expoii * ff * general_primitive_integral_coul_shifted( dim1 &
, P2_new, P2_center, fact_p2, pp2, p2_inv, iorder_p, shift_P &
, Q1_new, Q1_center, fact_q1, qq1, q1_inv, iorder_q, shift_Q )
cy = cy + expoii * ff * general_primitive_integral_erf_shifted( dim1 &
, P2_new, P2_center, fact_p2, pp2, p2_inv, iorder_p, shift_P &
, Q1_new, Q1_center, fact_q1, qq1, q1_inv, iorder_q, shift_Q )
shift_p = (/ 0, 0, 0 /)
shift_Q = (/ 0, 0, 0 /)
cy = cy - expoii * ff * gg * general_primitive_integral_coul_shifted( dim1 &
, P2_new, P2_center, fact_p2, pp2, p2_inv, iorder_p, shift_P &
, Q1_new, Q1_center, fact_q1, qq1, q1_inv, iorder_q, shift_Q )
cy = cy + expoii * ff * gg * general_primitive_integral_erf_shifted( dim1 &
, P2_new, P2_center, fact_p2, pp2, p2_inv, iorder_p, shift_P &
, Q1_new, Q1_center, fact_q1, qq1, q1_inv, iorder_q, shift_Q )
! z term:
ff = P2_center(3) - Centerii(3)
gg = Q1_center(3) - Centerii(3)
shift_p = (/ 0, 0, 1 /)
shift_Q = (/ 0, 0, 1 /)
cz = cz - expoii * general_primitive_integral_coul_shifted( dim1 &
, P2_new, P2_center, fact_p2, pp2, p2_inv, iorder_p, shift_P &
, Q1_new, Q1_center, fact_q1, qq1, q1_inv, iorder_q, shift_Q )
cz = cz + expoii * general_primitive_integral_erf_shifted( dim1 &
, P2_new, P2_center, fact_p2, pp2, p2_inv, iorder_p, shift_P &
, Q1_new, Q1_center, fact_q1, qq1, q1_inv, iorder_q, shift_Q )
shift_p = (/ 0, 0, 1 /)
shift_Q = (/ 0, 0, 0 /)
cz = cz - expoii * gg * general_primitive_integral_coul_shifted( dim1 &
, P2_new, P2_center, fact_p2, pp2, p2_inv, iorder_p, shift_P &
, Q1_new, Q1_center, fact_q1, qq1, q1_inv, iorder_q, shift_Q )
cz = cz + expoii * gg * general_primitive_integral_erf_shifted( dim1 &
, P2_new, P2_center, fact_p2, pp2, p2_inv, iorder_p, shift_P &
, Q1_new, Q1_center, fact_q1, qq1, q1_inv, iorder_q, shift_Q )
shift_p = (/ 0, 0, 0 /)
shift_Q = (/ 0, 0, 1 /)
cz = cz - expoii * ff * general_primitive_integral_coul_shifted( dim1 &
, P2_new, P2_center, fact_p2, pp2, p2_inv, iorder_p, shift_P &
, Q1_new, Q1_center, fact_q1, qq1, q1_inv, iorder_q, shift_Q )
cz = cz + expoii * ff * general_primitive_integral_erf_shifted( dim1 &
, P2_new, P2_center, fact_p2, pp2, p2_inv, iorder_p, shift_P &
, Q1_new, Q1_center, fact_q1, qq1, q1_inv, iorder_q, shift_Q )
shift_p = (/ 0, 0, 0 /)
shift_Q = (/ 0, 0, 0 /)
cz = cz - expoii * ff * gg * general_primitive_integral_coul_shifted( dim1 &
, P2_new, P2_center, fact_p2, pp2, p2_inv, iorder_p, shift_P &
, Q1_new, Q1_center, fact_q1, qq1, q1_inv, iorder_q, shift_Q )
cz = cz + expoii * ff * gg * general_primitive_integral_erf_shifted( dim1 &
, P2_new, P2_center, fact_p2, pp2, p2_inv, iorder_p, shift_P &
, Q1_new, Q1_center, fact_q1, qq1, q1_inv, iorder_q, shift_Q )
! ----------------------------------------------------------------------------------------------------
! ----------------------------------------------------------------------------------------------------
! - [ (1-erf(mu r12)) / r12 ] \sum_A a_A [ (r1-RA) \cdot (r2-RA) exp(-aA r2A^2) ]
! ----------------------------------------------------------------------------------------------------
! x term:
ff = P1_center(1) - Centerii(1)
gg = Q2_center(1) - Centerii(1)
shift_p = (/ 1, 0, 0 /)
shift_Q = (/ 1, 0, 0 /)
cx = cx - expoii * general_primitive_integral_coul_shifted( dim1 &
, P1_new, P1_center, fact_p1, pp1, p1_inv, iorder_p, shift_P &
, Q2_new, Q2_center, fact_q2, qq2, q2_inv, iorder_q, shift_Q )
cx = cx + expoii * general_primitive_integral_erf_shifted( dim1 &
, P1_new, P1_center, fact_p1, pp1, p1_inv, iorder_p, shift_P &
, Q2_new, Q2_center, fact_q2, qq2, q2_inv, iorder_q, shift_Q )
shift_p = (/ 1, 0, 0 /)
shift_Q = (/ 0, 0, 0 /)
cx = cx - expoii * gg * general_primitive_integral_coul_shifted( dim1 &
, P1_new, P1_center, fact_p1, pp1, p1_inv, iorder_p, shift_P &
, Q2_new, Q2_center, fact_q2, qq2, q2_inv, iorder_q, shift_Q )
cx = cx + expoii * gg * general_primitive_integral_erf_shifted( dim1 &
, P1_new, P1_center, fact_p1, pp1, p1_inv, iorder_p, shift_P &
, Q2_new, Q2_center, fact_q2, qq2, q2_inv, iorder_q, shift_Q )
shift_p = (/ 0, 0, 0 /)
shift_Q = (/ 1, 0, 0 /)
cx = cx - expoii * ff * general_primitive_integral_coul_shifted( dim1 &
, P1_new, P1_center, fact_p1, pp1, p1_inv, iorder_p, shift_P &
, Q2_new, Q2_center, fact_q2, qq2, q2_inv, iorder_q, shift_Q )
cx = cx + expoii * ff * general_primitive_integral_erf_shifted( dim1 &
, P1_new, P1_center, fact_p1, pp1, p1_inv, iorder_p, shift_P &
, Q2_new, Q2_center, fact_q2, qq2, q2_inv, iorder_q, shift_Q )
shift_p = (/ 0, 0, 0 /)
shift_Q = (/ 0, 0, 0 /)
cx = cx - expoii * ff * gg * general_primitive_integral_coul_shifted( dim1 &
, P1_new, P1_center, fact_p1, pp1, p1_inv, iorder_p, shift_P &
, Q2_new, Q2_center, fact_q2, qq2, q2_inv, iorder_q, shift_Q )
cx = cx + expoii * ff * gg * general_primitive_integral_erf_shifted( dim1 &
, P1_new, P1_center, fact_p1, pp1, p1_inv, iorder_p, shift_P &
, Q2_new, Q2_center, fact_q2, qq2, q2_inv, iorder_q, shift_Q )
! y term:
ff = P1_center(2) - Centerii(2)
gg = Q2_center(2) - Centerii(2)
shift_p = (/ 0, 1, 0 /)
shift_Q = (/ 0, 1, 0 /)
cy = cy - expoii * general_primitive_integral_coul_shifted( dim1 &
, P1_new, P1_center, fact_p1, pp1, p1_inv, iorder_p, shift_P &
, Q2_new, Q2_center, fact_q2, qq2, q2_inv, iorder_q, shift_Q )
cy = cy + expoii * general_primitive_integral_erf_shifted( dim1 &
, P1_new, P1_center, fact_p1, pp1, p1_inv, iorder_p, shift_P &
, Q2_new, Q2_center, fact_q2, qq2, q2_inv, iorder_q, shift_Q )
shift_p = (/ 0, 1, 0 /)
shift_Q = (/ 0, 0, 0 /)
cy = cy - expoii * gg * general_primitive_integral_coul_shifted( dim1 &
, P1_new, P1_center, fact_p1, pp1, p1_inv, iorder_p, shift_P &
, Q2_new, Q2_center, fact_q2, qq2, q2_inv, iorder_q, shift_Q )
cy = cy + expoii * gg * general_primitive_integral_erf_shifted( dim1 &
, P1_new, P1_center, fact_p1, pp1, p1_inv, iorder_p, shift_P &
, Q2_new, Q2_center, fact_q2, qq2, q2_inv, iorder_q, shift_Q )
shift_p = (/ 0, 0, 0 /)
shift_Q = (/ 0, 1, 0 /)
cy = cy - expoii * ff * general_primitive_integral_coul_shifted( dim1 &
, P1_new, P1_center, fact_p1, pp1, p1_inv, iorder_p, shift_P &
, Q2_new, Q2_center, fact_q2, qq2, q2_inv, iorder_q, shift_Q )
cy = cy + expoii * ff * general_primitive_integral_erf_shifted( dim1 &
, P1_new, P1_center, fact_p1, pp1, p1_inv, iorder_p, shift_P &
, Q2_new, Q2_center, fact_q2, qq2, q2_inv, iorder_q, shift_Q )
shift_p = (/ 0, 0, 0 /)
shift_Q = (/ 0, 0, 0 /)
cy = cy - expoii * ff * gg * general_primitive_integral_coul_shifted( dim1 &
, P1_new, P1_center, fact_p1, pp1, p1_inv, iorder_p, shift_P &
, Q2_new, Q2_center, fact_q2, qq2, q2_inv, iorder_q, shift_Q )
cy = cy + expoii * ff * gg * general_primitive_integral_erf_shifted( dim1 &
, P1_new, P1_center, fact_p1, pp1, p1_inv, iorder_p, shift_P &
, Q2_new, Q2_center, fact_q2, qq2, q2_inv, iorder_q, shift_Q )
! z term:
ff = P1_center(3) - Centerii(3)
gg = Q2_center(3) - Centerii(3)
shift_p = (/ 0, 0, 1 /)
shift_Q = (/ 0, 0, 1 /)
cz = cz - expoii * general_primitive_integral_coul_shifted( dim1 &
, P1_new, P1_center, fact_p1, pp1, p1_inv, iorder_p, shift_P &
, Q2_new, Q2_center, fact_q2, qq2, q2_inv, iorder_q, shift_Q )
cz = cz + expoii * general_primitive_integral_erf_shifted( dim1 &
, P1_new, P1_center, fact_p1, pp1, p1_inv, iorder_p, shift_P &
, Q2_new, Q2_center, fact_q2, qq2, q2_inv, iorder_q, shift_Q )
shift_p = (/ 0, 0, 1 /)
shift_Q = (/ 0, 0, 0 /)
cz = cz - expoii * gg * general_primitive_integral_coul_shifted( dim1 &
, P1_new, P1_center, fact_p1, pp1, p1_inv, iorder_p, shift_P &
, Q2_new, Q2_center, fact_q2, qq2, q2_inv, iorder_q, shift_Q )
cz = cz + expoii * gg * general_primitive_integral_erf_shifted( dim1 &
, P1_new, P1_center, fact_p1, pp1, p1_inv, iorder_p, shift_P &
, Q2_new, Q2_center, fact_q2, qq2, q2_inv, iorder_q, shift_Q )
shift_p = (/ 0, 0, 0 /)
shift_Q = (/ 0, 0, 1 /)
cz = cz - expoii * ff * general_primitive_integral_coul_shifted( dim1 &
, P1_new, P1_center, fact_p1, pp1, p1_inv, iorder_p, shift_P &
, Q2_new, Q2_center, fact_q2, qq2, q2_inv, iorder_q, shift_Q )
cz = cz + expoii * ff * general_primitive_integral_erf_shifted( dim1 &
, P1_new, P1_center, fact_p1, pp1, p1_inv, iorder_p, shift_P &
, Q2_new, Q2_center, fact_q2, qq2, q2_inv, iorder_q, shift_Q )
shift_p = (/ 0, 0, 0 /)
shift_Q = (/ 0, 0, 0 /)
cz = cz - expoii * ff * gg * general_primitive_integral_coul_shifted( dim1 &
, P1_new, P1_center, fact_p1, pp1, p1_inv, iorder_p, shift_P &
, Q2_new, Q2_center, fact_q2, qq2, q2_inv, iorder_q, shift_Q )
cz = cz + expoii * ff * gg * general_primitive_integral_erf_shifted( dim1 &
, P1_new, P1_center, fact_p1, pp1, p1_inv, iorder_p, shift_P &
, Q2_new, Q2_center, fact_q2, qq2, q2_inv, iorder_q, shift_Q )
! ----------------------------------------------------------------------------------------------------
enddo
return
end subroutine get_cxcycz

854
src/ao_tc_eff_map/two_e_1bgauss_erf.irp.f Normal file
View File

@ -0,0 +1,854 @@
double precision function j1b_gauss_erf(i, j, k, l)
BEGIN_DOC
!
! integral in the AO basis:
! i(r1) j(r1) f(r12) k(r2) l(r2)
!
! with:
! f(r12) = - [ -0.5 erf(mu r12) / r12 ] (r1-r2) \cdot \sum_A (-2 a_A) [ r1A exp(-aA r1A^2) - r2A exp(-aA r2A^2) ]
! = - [ erf(mu r12) / r12 ] \sum_A a_A [ (r1-RA)^2 exp(-aA r1A^2)
! + (r2-RA)^2 exp(-aA r2A^2)
! - (r1-RA) \cdot (r2-RA) exp(-aA r1A^2)
! - (r1-RA) \cdot (r2-RA) exp(-aA r2A^2) ]
!
END_DOC
include 'utils/constants.include.F'
implicit none
integer, intent(in) :: i, j, k, l
integer :: p, q, r, s, ii
integer :: num_i, num_j, num_k, num_l, num_ii
integer :: I_power(3), J_power(3), K_power(3), L_power(3)
integer :: iorder_p(3), iorder_q(3)
integer :: shift_P(3), shift_Q(3)
integer :: dim1
double precision :: coef1, coef2, coef3, coef4
double precision :: expo1, expo2, expo3, expo4
double precision :: p_inv, q_inv
double precision :: P_new_tmp(0:max_dim,3), P_center_tmp(3), fact_p_tmp, pp_tmp
double precision :: Q_new_tmp(0:max_dim,3), Q_center_tmp(3), fact_q_tmp, qq_tmp
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 :: I_center(3), J_center(3), K_center(3), L_center(3)
double precision :: expoii, factii, Centerii(3)
double precision :: ff, gg, cx, cy, cz
double precision :: general_primitive_integral_erf_shifted
PROVIDE mu_erf
PROVIDE j1b_gauss_pen
dim1 = n_pt_max_integrals
num_i = ao_nucl(i)
num_j = ao_nucl(j)
num_k = ao_nucl(k)
num_l = ao_nucl(l)
do p = 1, 3
I_power(p) = ao_power(i,p)
J_power(p) = ao_power(j,p)
K_power(p) = ao_power(k,p)
L_power(p) = ao_power(l,p)
I_center(p) = nucl_coord(num_i,p)
J_center(p) = nucl_coord(num_j,p)
K_center(p) = nucl_coord(num_k,p)
L_center(p) = nucl_coord(num_l,p)
enddo
j1b_gauss_erf = 0.d0
! -------------------------------------------------------------------------------------------------------------------
!
! - [ erf(mu r12) / r12 ] \sum_A a_A [ (r1-RA)^2 exp(-aA r1A^2)
!
! -------------------------------------------------------------------------------------------------------------------
shift_Q(1) = 0
shift_Q(2) = 0
shift_Q(3) = 0
do p = 1, ao_prim_num(i)
coef1 = ao_coef_normalized_ordered_transp(p, i)
expo1 = ao_expo_ordered_transp(p, i)
do q = 1, ao_prim_num(j)
coef2 = coef1 * ao_coef_normalized_ordered_transp(q, j)
expo2 = ao_expo_ordered_transp(q, j)
call give_explicit_poly_and_gaussian( P_new_tmp, P_center_tmp, pp_tmp, fact_p_tmp, iorder_p, expo1, expo2 &
, I_power, J_power, I_center, J_center, dim1 )
do r = 1, ao_prim_num(k)
coef3 = coef2 * ao_coef_normalized_ordered_transp(r, k)
expo3 = ao_expo_ordered_transp(r, k)
do s = 1, ao_prim_num(l)
coef4 = coef3 * ao_coef_normalized_ordered_transp(s, l)
expo4 = ao_expo_ordered_transp(s, l)
call give_explicit_poly_and_gaussian( Q_new, Q_center, qq, fact_q, iorder_q, expo3, expo4 &
, K_power, L_power, K_center, L_center, dim1 )
q_inv = 1.d0 / qq
cx = 0.d0
cy = 0.d0
cz = 0.d0
do ii = 1, nucl_num
expoii = j1b_gauss_pen(ii)
Centerii(1:3) = nucl_coord(ii, 1:3)
call gaussian_product(pp_tmp, P_center_tmp, expoii, Centerii, factii, pp, P_center)
fact_p = fact_p_tmp * factii
p_inv = 1.d0 / pp
! pol centerd on P_center_tmp ==> centerd on P_center
call pol_modif_center( P_center_tmp, P_center, iorder_p, P_new_tmp, P_new)
! ----------------------------------------------------------------------------------------------------
! x term:
shift_P(2) = 0
shift_P(3) = 0
ff = P_center(1) - Centerii(1)
shift_P(1) = 2
cx = cx + expoii * general_primitive_integral_erf_shifted( dim1 &
, P_new, P_center, fact_p, pp, p_inv, iorder_p, shift_P &
, Q_new, Q_center, fact_q, qq, q_inv, iorder_q, shift_Q )
shift_P(1) = 1
cx = cx + expoii * 2.d0 * ff * general_primitive_integral_erf_shifted( dim1 &
, P_new, P_center, fact_p, pp, p_inv, iorder_p, shift_P &
, Q_new, Q_center, fact_q, qq, q_inv, iorder_q, shift_Q )
shift_P(1) = 0
cx = cx + expoii * ff * ff * general_primitive_integral_erf_shifted( dim1 &
, P_new, P_center, fact_p, pp, p_inv, iorder_p, shift_P &
, Q_new, Q_center, fact_q, qq, q_inv, iorder_q, shift_Q )
! ----------------------------------------------------------------------------------------------------
! ----------------------------------------------------------------------------------------------------
! y term:
shift_P(1) = 0
shift_P(3) = 0
ff = P_center(2) - Centerii(2)
shift_P(2) = 2
cy = cy + expoii * general_primitive_integral_erf_shifted( dim1 &
, P_new, P_center, fact_p, pp, p_inv, iorder_p, shift_P &
, Q_new, Q_center, fact_q, qq, q_inv, iorder_q, shift_Q )
shift_P(2) = 1
cy = cy + expoii * 2.d0 * ff * general_primitive_integral_erf_shifted( dim1 &
, P_new, P_center, fact_p, pp, p_inv, iorder_p, shift_P &
, Q_new, Q_center, fact_q, qq, q_inv, iorder_q, shift_Q )
shift_P(2) = 0
cy = cy + expoii * ff * ff * general_primitive_integral_erf_shifted( dim1 &
, P_new, P_center, fact_p, pp, p_inv, iorder_p, shift_P &
, Q_new, Q_center, fact_q, qq, q_inv, iorder_q, shift_Q )
! ----------------------------------------------------------------------------------------------------
! ----------------------------------------------------------------------------------------------------
! z term:
shift_P(1) = 0
shift_P(2) = 0
ff = P_center(3) - Centerii(3)
shift_P(3) = 2
cz = cz + expoii * general_primitive_integral_erf_shifted( dim1 &
, P_new, P_center, fact_p, pp, p_inv, iorder_p, shift_P &
, Q_new, Q_center, fact_q, qq, q_inv, iorder_q, shift_Q )
shift_P(3) = 1
cz = cz + expoii * 2.d0 * ff * general_primitive_integral_erf_shifted( dim1 &
, P_new, P_center, fact_p, pp, p_inv, iorder_p, shift_P &
, Q_new, Q_center, fact_q, qq, q_inv, iorder_q, shift_Q )
shift_P(3) = 0
cz = cz + expoii * ff * ff * general_primitive_integral_erf_shifted( dim1 &
, P_new, P_center, fact_p, pp, p_inv, iorder_p, shift_P &
, Q_new, Q_center, fact_q, qq, q_inv, iorder_q, shift_Q )
! ----------------------------------------------------------------------------------------------------
enddo
j1b_gauss_erf = j1b_gauss_erf - coef4 * ( cx + cy + cz )
enddo ! s
enddo ! r
enddo ! q
enddo ! p
! -------------------------------------------------------------------------------------------------------------------
! -------------------------------------------------------------------------------------------------------------------
! -------------------------------------------------------------------------------------------------------------------
!
! - [ erf(mu r12) / r12 ] \sum_A a_A [ (r2-RA)^2 exp(-aA r2A^2)
!
! -------------------------------------------------------------------------------------------------------------------
shift_P(1) = 0
shift_P(2) = 0
shift_P(3) = 0
do p = 1, ao_prim_num(i)
coef1 = ao_coef_normalized_ordered_transp(p, i)
expo1 = ao_expo_ordered_transp(p, i)
do q = 1, ao_prim_num(j)
coef2 = coef1 * ao_coef_normalized_ordered_transp(q, j)
expo2 = ao_expo_ordered_transp(q, j)
call give_explicit_poly_and_gaussian( P_new, P_center, pp, fact_p, iorder_p, expo1, expo2 &
, I_power, J_power, I_center, J_center, dim1 )
p_inv = 1.d0 / pp
do r = 1, ao_prim_num(k)
coef3 = coef2 * ao_coef_normalized_ordered_transp(r, k)
expo3 = ao_expo_ordered_transp(r, k)
do s = 1, ao_prim_num(l)
coef4 = coef3 * ao_coef_normalized_ordered_transp(s, l)
expo4 = ao_expo_ordered_transp(s, l)
call give_explicit_poly_and_gaussian( Q_new_tmp, Q_center_tmp, qq_tmp, fact_q_tmp, iorder_q, expo3, expo4 &
, K_power, L_power, K_center, L_center, dim1 )
cx = 0.d0
cy = 0.d0
cz = 0.d0
do ii = 1, nucl_num
expoii = j1b_gauss_pen(ii)
Centerii(1:3) = nucl_coord(ii, 1:3)
call gaussian_product(qq_tmp, Q_center_tmp, expoii, Centerii, factii, qq, Q_center)
fact_q = fact_q_tmp * factii
q_inv = 1.d0 / qq
! pol centerd on Q_center_tmp ==> centerd on Q_center
call pol_modif_center( Q_center_tmp, Q_center, iorder_q, Q_new_tmp, Q_new)
! ----------------------------------------------------------------------------------------------------
! x term:
shift_Q(2) = 0
shift_Q(3) = 0
ff = Q_center(1) - Centerii(1)
shift_Q(1) = 2
cx = cx + expoii * general_primitive_integral_erf_shifted( dim1 &
, P_new, P_center, fact_p, pp, p_inv, iorder_p, shift_P &
, Q_new, Q_center, fact_q, qq, q_inv, iorder_q, shift_Q )
shift_Q(1) = 1
cx = cx + expoii * 2.d0 * ff * general_primitive_integral_erf_shifted( dim1 &
, P_new, P_center, fact_p, pp, p_inv, iorder_p, shift_P &
, Q_new, Q_center, fact_q, qq, q_inv, iorder_q, shift_Q )
shift_Q(1) = 0
cx = cx + expoii * ff * ff * general_primitive_integral_erf_shifted( dim1 &
, P_new, P_center, fact_p, pp, p_inv, iorder_p, shift_P &
, Q_new, Q_center, fact_q, qq, q_inv, iorder_q, shift_Q )
! ----------------------------------------------------------------------------------------------------
! ----------------------------------------------------------------------------------------------------
! y term:
shift_Q(1) = 0
shift_Q(3) = 0
ff = Q_center(2) - Centerii(2)
shift_Q(2) = 2
cy = cy + expoii * general_primitive_integral_erf_shifted( dim1 &
, P_new, P_center, fact_p, pp, p_inv, iorder_p, shift_P &
, Q_new, Q_center, fact_q, qq, q_inv, iorder_q, shift_Q )
shift_Q(2) = 1
cy = cy + expoii * 2.d0 * ff * general_primitive_integral_erf_shifted( dim1 &
, P_new, P_center, fact_p, pp, p_inv, iorder_p, shift_P &
, Q_new, Q_center, fact_q, qq, q_inv, iorder_q, shift_Q )
shift_Q(2) = 0
cy = cy + expoii * ff * ff * general_primitive_integral_erf_shifted( dim1 &
, P_new, P_center, fact_p, pp, p_inv, iorder_p, shift_P &
, Q_new, Q_center, fact_q, qq, q_inv, iorder_q, shift_Q )
! ----------------------------------------------------------------------------------------------------
! ----------------------------------------------------------------------------------------------------
! z term:
shift_Q(1) = 0
shift_Q(2) = 0
ff = Q_center(3) - Centerii(3)
shift_Q(3) = 2
cz = cz + expoii * general_primitive_integral_erf_shifted( dim1 &
, P_new, P_center, fact_p, pp, p_inv, iorder_p, shift_P &
, Q_new, Q_center, fact_q, qq, q_inv, iorder_q, shift_Q )
shift_Q(3) = 1
cz = cz + expoii * 2.d0 * ff * general_primitive_integral_erf_shifted( dim1 &
, P_new, P_center, fact_p, pp, p_inv, iorder_p, shift_P &
, Q_new, Q_center, fact_q, qq, q_inv, iorder_q, shift_Q )
shift_Q(3) = 0
cz = cz + expoii * ff * ff * general_primitive_integral_erf_shifted( dim1 &
, P_new, P_center, fact_p, pp, p_inv, iorder_p, shift_P &
, Q_new, Q_center, fact_q, qq, q_inv, iorder_q, shift_Q )
! ----------------------------------------------------------------------------------------------------
enddo
j1b_gauss_erf = j1b_gauss_erf - coef4 * ( cx + cy + cz )
enddo ! s
enddo ! r
enddo ! q
enddo ! p
! -------------------------------------------------------------------------------------------------------------------
! -------------------------------------------------------------------------------------------------------------------
! -------------------------------------------------------------------------------------------------------------------
!
! [ erf(mu r12) / r12 ] \sum_A a_A [ (r1-RA) \cdot (r2-RA) exp(-aA r1A^2) ]
!
! -------------------------------------------------------------------------------------------------------------------
do p = 1, ao_prim_num(i)
coef1 = ao_coef_normalized_ordered_transp(p, i)
expo1 = ao_expo_ordered_transp(p, i)
do q = 1, ao_prim_num(j)
coef2 = coef1 * ao_coef_normalized_ordered_transp(q, j)
expo2 = ao_expo_ordered_transp(q, j)
call give_explicit_poly_and_gaussian( P_new_tmp, P_center_tmp, pp_tmp, fact_p_tmp, iorder_p, expo1, expo2 &
, I_power, J_power, I_center, J_center, dim1 )
do r = 1, ao_prim_num(k)
coef3 = coef2 * ao_coef_normalized_ordered_transp(r, k)
expo3 = ao_expo_ordered_transp(r, k)
do s = 1, ao_prim_num(l)
coef4 = coef3 * ao_coef_normalized_ordered_transp(s, l)
expo4 = ao_expo_ordered_transp(s, l)
call give_explicit_poly_and_gaussian( Q_new, Q_center, qq, fact_q, iorder_q, expo3, expo4 &
, K_power, L_power, K_center, L_center, dim1 )
q_inv = 1.d0 / qq
cx = 0.d0
cy = 0.d0
cz = 0.d0
do ii = 1, nucl_num
expoii = j1b_gauss_pen(ii)
Centerii(1:3) = nucl_coord(ii, 1:3)
call gaussian_product(pp_tmp, P_center_tmp, expoii, Centerii, factii, pp, P_center)
fact_p = fact_p_tmp * factii
p_inv = 1.d0 / pp
! pol centerd on P_center_tmp ==> centerd on P_center
call pol_modif_center( P_center_tmp, P_center, iorder_p, P_new_tmp, P_new)
! ----------------------------------------------------------------------------------------------------
! x term:
shift_P(2) = 0
shift_P(3) = 0
shift_Q(2) = 0
shift_Q(3) = 0
ff = P_center(1) - Centerii(1)
gg = Q_center(1) - Centerii(1)
shift_P(1) = 1
shift_Q(1) = 1
cx = cx + expoii * general_primitive_integral_erf_shifted( dim1 &
, P_new, P_center, fact_p, pp, p_inv, iorder_p, shift_P &
, Q_new, Q_center, fact_q, qq, q_inv, iorder_q, shift_Q )
shift_P(1) = 1
shift_Q(1) = 0
cx = cx + expoii * gg * general_primitive_integral_erf_shifted( dim1 &
, P_new, P_center, fact_p, pp, p_inv, iorder_p, shift_P &
, Q_new, Q_center, fact_q, qq, q_inv, iorder_q, shift_Q )
shift_P(1) = 0
shift_Q(1) = 1
cx = cx + expoii * ff * general_primitive_integral_erf_shifted( dim1 &
, P_new, P_center, fact_p, pp, p_inv, iorder_p, shift_P &
, Q_new, Q_center, fact_q, qq, q_inv, iorder_q, shift_Q )
shift_P(1) = 0
shift_Q(1) = 0
cx = cx + expoii * ff * gg * general_primitive_integral_erf_shifted( dim1 &
, P_new, P_center, fact_p, pp, p_inv, iorder_p, shift_P &
, Q_new, Q_center, fact_q, qq, q_inv, iorder_q, shift_Q )
! ----------------------------------------------------------------------------------------------------
! ----------------------------------------------------------------------------------------------------
! y term:
shift_P(1) = 0
shift_P(3) = 0
shift_Q(1) = 0
shift_Q(3) = 0
ff = P_center(2) - Centerii(2)
gg = Q_center(2) - Centerii(2)
shift_P(2) = 1
shift_Q(2) = 1
cy = cy + expoii * general_primitive_integral_erf_shifted( dim1 &
, P_new, P_center, fact_p, pp, p_inv, iorder_p, shift_P &
, Q_new, Q_center, fact_q, qq, q_inv, iorder_q, shift_Q )
shift_P(2) = 1
shift_Q(2) = 0
cy = cy + expoii * gg * general_primitive_integral_erf_shifted( dim1 &
, P_new, P_center, fact_p, pp, p_inv, iorder_p, shift_P &
, Q_new, Q_center, fact_q, qq, q_inv, iorder_q, shift_Q )
shift_P(2) = 0
shift_Q(2) = 1
cy = cy + expoii * ff * general_primitive_integral_erf_shifted( dim1 &
, P_new, P_center, fact_p, pp, p_inv, iorder_p, shift_P &
, Q_new, Q_center, fact_q, qq, q_inv, iorder_q, shift_Q )
shift_P(2) = 0
shift_Q(2) = 0
cy = cy + expoii * ff * gg * general_primitive_integral_erf_shifted( dim1 &
, P_new, P_center, fact_p, pp, p_inv, iorder_p, shift_P &
, Q_new, Q_center, fact_q, qq, q_inv, iorder_q, shift_Q )
! ----------------------------------------------------------------------------------------------------
! ----------------------------------------------------------------------------------------------------
! z term:
shift_P(1) = 0
shift_P(2) = 0
shift_Q(1) = 0
shift_Q(2) = 0
ff = P_center(3) - Centerii(3)
gg = Q_center(3) - Centerii(3)
shift_P(3) = 1
shift_Q(3) = 1
cz = cz + expoii * general_primitive_integral_erf_shifted( dim1 &
, P_new, P_center, fact_p, pp, p_inv, iorder_p, shift_P &
, Q_new, Q_center, fact_q, qq, q_inv, iorder_q, shift_Q )
shift_P(3) = 1
shift_Q(3) = 0
cz = cz + expoii * gg * general_primitive_integral_erf_shifted( dim1 &
, P_new, P_center, fact_p, pp, p_inv, iorder_p, shift_P &
, Q_new, Q_center, fact_q, qq, q_inv, iorder_q, shift_Q )
shift_P(3) = 0
shift_Q(3) = 1
cz = cz + expoii * ff * general_primitive_integral_erf_shifted( dim1 &
, P_new, P_center, fact_p, pp, p_inv, iorder_p, shift_P &
, Q_new, Q_center, fact_q, qq, q_inv, iorder_q, shift_Q )
shift_P(3) = 0
shift_Q(3) = 0
cz = cz + expoii * ff * gg * general_primitive_integral_erf_shifted( dim1 &
, P_new, P_center, fact_p, pp, p_inv, iorder_p, shift_P &
, Q_new, Q_center, fact_q, qq, q_inv, iorder_q, shift_Q )
! ----------------------------------------------------------------------------------------------------
enddo
j1b_gauss_erf = j1b_gauss_erf + coef4 * ( cx + cy + cz )
enddo ! s
enddo ! r
enddo ! q
enddo ! p
! -------------------------------------------------------------------------------------------------------------------
! -------------------------------------------------------------------------------------------------------------------
! -------------------------------------------------------------------------------------------------------------------
!
! [ erf(mu r12) / r12 ] \sum_A a_A [ (r1-RA) \cdot (r2-RA) exp(-aA r2A^2) ]
!
! -------------------------------------------------------------------------------------------------------------------
do p = 1, ao_prim_num(i)
coef1 = ao_coef_normalized_ordered_transp(p, i)
expo1 = ao_expo_ordered_transp(p, i)
do q = 1, ao_prim_num(j)
coef2 = coef1 * ao_coef_normalized_ordered_transp(q, j)
expo2 = ao_expo_ordered_transp(q, j)
call give_explicit_poly_and_gaussian( P_new, P_center, pp, fact_p, iorder_p, expo1, expo2 &
, I_power, J_power, I_center, J_center, dim1 )
p_inv = 1.d0 / pp
do r = 1, ao_prim_num(k)
coef3 = coef2 * ao_coef_normalized_ordered_transp(r, k)
expo3 = ao_expo_ordered_transp(r, k)
do s = 1, ao_prim_num(l)
coef4 = coef3 * ao_coef_normalized_ordered_transp(s, l)
expo4 = ao_expo_ordered_transp(s, l)
call give_explicit_poly_and_gaussian( Q_new_tmp, Q_center_tmp, qq_tmp, fact_q_tmp, iorder_q, expo3, expo4 &
, K_power, L_power, K_center, L_center, dim1 )
cx = 0.d0
cy = 0.d0
cz = 0.d0
do ii = 1, nucl_num
expoii = j1b_gauss_pen(ii)
Centerii(1:3) = nucl_coord(ii, 1:3)
call gaussian_product(qq_tmp, Q_center_tmp, expoii, Centerii, factii, qq, Q_center)
fact_q = fact_q_tmp * factii
q_inv = 1.d0 / qq
! pol centerd on Q_center_tmp ==> centerd on Q_center
call pol_modif_center( Q_center_tmp, Q_center, iorder_q, Q_new_tmp, Q_new)
! ----------------------------------------------------------------------------------------------------
! x term:
shift_P(2) = 0
shift_P(3) = 0
shift_Q(2) = 0
shift_Q(3) = 0
ff = P_center(1) - Centerii(1)
gg = Q_center(1) - Centerii(1)
shift_P(1) = 1
shift_Q(1) = 1
cx = cx + expoii * general_primitive_integral_erf_shifted( dim1 &
, P_new, P_center, fact_p, pp, p_inv, iorder_p, shift_P &
, Q_new, Q_center, fact_q, qq, q_inv, iorder_q, shift_Q )
shift_P(1) = 1
shift_Q(1) = 0
cx = cx + expoii * gg * general_primitive_integral_erf_shifted( dim1 &
, P_new, P_center, fact_p, pp, p_inv, iorder_p, shift_P &
, Q_new, Q_center, fact_q, qq, q_inv, iorder_q, shift_Q )
shift_P(1) = 0
shift_Q(1) = 1
cx = cx + expoii * ff * general_primitive_integral_erf_shifted( dim1 &
, P_new, P_center, fact_p, pp, p_inv, iorder_p, shift_P &
, Q_new, Q_center, fact_q, qq, q_inv, iorder_q, shift_Q )
shift_P(1) = 0
shift_Q(1) = 0
cx = cx + expoii * ff * gg * general_primitive_integral_erf_shifted( dim1 &
, P_new, P_center, fact_p, pp, p_inv, iorder_p, shift_P &
, Q_new, Q_center, fact_q, qq, q_inv, iorder_q, shift_Q )
! ----------------------------------------------------------------------------------------------------
! ----------------------------------------------------------------------------------------------------
! y term:
shift_P(1) = 0
shift_P(3) = 0
shift_Q(1) = 0
shift_Q(3) = 0
ff = P_center(2) - Centerii(2)
gg = Q_center(2) - Centerii(2)
shift_P(2) = 1
shift_Q(2) = 1
cy = cy + expoii * general_primitive_integral_erf_shifted( dim1 &
, P_new, P_center, fact_p, pp, p_inv, iorder_p, shift_P &
, Q_new, Q_center, fact_q, qq, q_inv, iorder_q, shift_Q )
shift_P(2) = 1
shift_Q(2) = 0
cy = cy + expoii * gg * general_primitive_integral_erf_shifted( dim1 &
, P_new, P_center, fact_p, pp, p_inv, iorder_p, shift_P &
, Q_new, Q_center, fact_q, qq, q_inv, iorder_q, shift_Q )
shift_P(2) = 0
shift_Q(2) = 1
cy = cy + expoii * ff * general_primitive_integral_erf_shifted( dim1 &
, P_new, P_center, fact_p, pp, p_inv, iorder_p, shift_P &
, Q_new, Q_center, fact_q, qq, q_inv, iorder_q, shift_Q )
shift_P(2) = 0
shift_Q(2) = 0
cy = cy + expoii * ff * gg * general_primitive_integral_erf_shifted( dim1 &
, P_new, P_center, fact_p, pp, p_inv, iorder_p, shift_P &
, Q_new, Q_center, fact_q, qq, q_inv, iorder_q, shift_Q )
! ----------------------------------------------------------------------------------------------------
! ----------------------------------------------------------------------------------------------------
! z term:
shift_P(1) = 0
shift_P(2) = 0
shift_Q(1) = 0
shift_Q(2) = 0
ff = P_center(3) - Centerii(3)
gg = Q_center(3) - Centerii(3)
shift_P(3) = 1
shift_Q(3) = 1
cz = cz + expoii * general_primitive_integral_erf_shifted( dim1 &
, P_new, P_center, fact_p, pp, p_inv, iorder_p, shift_P &
, Q_new, Q_center, fact_q, qq, q_inv, iorder_q, shift_Q )
shift_P(3) = 1
shift_Q(3) = 0
cz = cz + expoii * gg * general_primitive_integral_erf_shifted( dim1 &
, P_new, P_center, fact_p, pp, p_inv, iorder_p, shift_P &
, Q_new, Q_center, fact_q, qq, q_inv, iorder_q, shift_Q )
shift_P(3) = 0
shift_Q(3) = 1
cz = cz + expoii * ff * general_primitive_integral_erf_shifted( dim1 &
, P_new, P_center, fact_p, pp, p_inv, iorder_p, shift_P &
, Q_new, Q_center, fact_q, qq, q_inv, iorder_q, shift_Q )
shift_P(3) = 0
shift_Q(3) = 0
cz = cz + expoii * ff * gg * general_primitive_integral_erf_shifted( dim1 &
, P_new, P_center, fact_p, pp, p_inv, iorder_p, shift_P &
, Q_new, Q_center, fact_q, qq, q_inv, iorder_q, shift_Q )
! ----------------------------------------------------------------------------------------------------
enddo
j1b_gauss_erf = j1b_gauss_erf + coef4 * ( cx + cy + cz )
enddo ! s
enddo ! r
enddo ! q
enddo ! p
! -------------------------------------------------------------------------------------------------------------------
! -------------------------------------------------------------------------------------------------------------------
return
end function j1b_gauss_erf
!______________________________________________________________________________________________________________________
!______________________________________________________________________________________________________________________
double precision function general_primitive_integral_erf_shifted( dim &
, P_new, P_center, fact_p, p, p_inv, iorder_p, shift_P &
, Q_new, Q_center, fact_q, q, q_inv, iorder_q, shift_Q )
include 'utils/constants.include.F'
implicit none
integer, intent(in) :: dim
integer, intent(in) :: iorder_p(3), shift_P(3)
integer, intent(in) :: iorder_q(3), shift_Q(3)
double precision, intent(in) :: P_new(0:max_dim,3), P_center(3), fact_p, p, p_inv
double precision, intent(in) :: Q_new(0:max_dim,3), Q_center(3), fact_q, q, q_inv
integer :: n_Ix, n_Iy, n_Iz, nx, ny, nz
integer :: ix, iy, iz, jx, jy, jz, i
integer :: n_pt_tmp, n_pt_out, iorder
integer :: ii, jj
double precision :: rho, dist
double precision :: dx(0:max_dim), Ix_pol(0:max_dim)
double precision :: dy(0:max_dim), Iy_pol(0:max_dim)
double precision :: dz(0:max_dim), Iz_pol(0:max_dim)
double precision :: a, b, c, d, e, f, accu, pq, const
double precision :: pq_inv, p10_1, p10_2, p01_1, p01_2, pq_inv_2
double precision :: d1(0:max_dim), d_poly(0:max_dim)
double precision :: p_plus_q
double precision :: rint_sum
general_primitive_integral_erf_shifted = 0.d0
!DIR$ ATTRIBUTES ALIGN : $IRP_ALIGN :: dx, Ix_pol, dy, Iy_pol, dz, Iz_pol
!DIR$ ATTRIBUTES ALIGN : $IRP_ALIGN :: d1, d_poly
! Gaussian Product
! ----------------
p_plus_q = (p+q) * ( (p*q)/(p+q) + mu_erf*mu_erf ) / (mu_erf*mu_erf)
pq = p_inv * 0.5d0 * q_inv
pq_inv = 0.5d0 / p_plus_q
p10_1 = q * pq ! 1/(2p)
p01_1 = p * pq ! 1/(2q)
pq_inv_2 = pq_inv + pq_inv
p10_2 = pq_inv_2 * p10_1 * q ! 0.5d0 * q / (pq + p*p)
p01_2 = pq_inv_2 * p01_1 * p ! 0.5d0 * p / (q*q + pq)
accu = 0.d0
iorder = iorder_p(1) + iorder_q(1) + iorder_p(1) + iorder_q(1)
iorder = iorder + shift_P(1) + shift_Q(1)
iorder = iorder + shift_P(1) + shift_Q(1)
!DIR$ VECTOR ALIGNED
do ix = 0, iorder
Ix_pol(ix) = 0.d0
enddo
n_Ix = 0
do ix = 0, iorder_p(1)
ii = ix + shift_P(1)
a = P_new(ix,1)
if(abs(a) < thresh) cycle
do jx = 0, iorder_q(1)
jj = jx + shift_Q(1)
d = a * Q_new(jx,1)
if(abs(d) < thresh) cycle
!DEC$ FORCEINLINE
call give_polynom_mult_center_x( P_center(1), Q_center(1), ii, jj &
, p, q, iorder, pq_inv, pq_inv_2, p10_1, p01_1, p10_2, p01_2, dx, nx )
!DEC$ FORCEINLINE
call add_poly_multiply(dx, nx, d, Ix_pol, n_Ix)
enddo
enddo
if(n_Ix == -1) then
return
endif
iorder = iorder_p(2) + iorder_q(2) + iorder_p(2) + iorder_q(2)
iorder = iorder + shift_P(2) + shift_Q(2)
iorder = iorder + shift_P(2) + shift_Q(2)
!DIR$ VECTOR ALIGNED
do ix = 0, iorder
Iy_pol(ix) = 0.d0
enddo
n_Iy = 0
do iy = 0, iorder_p(2)
if(abs(P_new(iy,2)) > thresh) then
ii = iy + shift_P(2)
b = P_new(iy,2)
do jy = 0, iorder_q(2)
jj = jy + shift_Q(2)
e = b * Q_new(jy,2)
if(abs(e) < thresh) cycle
!DEC$ FORCEINLINE
call give_polynom_mult_center_x( P_center(2), Q_center(2), ii, jj &
, p, q, iorder, pq_inv, pq_inv_2, p10_1, p01_1, p10_2, p01_2, dy, ny )
!DEC$ FORCEINLINE
call add_poly_multiply(dy, ny, e, Iy_pol, n_Iy)
enddo
endif
enddo
if(n_Iy == -1) then
return
endif
iorder = iorder_p(3) + iorder_q(3) + iorder_p(3) + iorder_q(3)
iorder = iorder + shift_P(3) + shift_Q(3)
iorder = iorder + shift_P(3) + shift_Q(3)
do ix = 0, iorder
Iz_pol(ix) = 0.d0
enddo
n_Iz = 0
do iz = 0, iorder_p(3)
if( abs(P_new(iz,3)) > thresh ) then
ii = iz + shift_P(3)
c = P_new(iz,3)
do jz = 0, iorder_q(3)
jj = jz + shift_Q(3)
f = c * Q_new(jz,3)
if(abs(f) < thresh) cycle
!DEC$ FORCEINLINE
call give_polynom_mult_center_x( P_center(3), Q_center(3), ii, jj &
, p, q, iorder, pq_inv, pq_inv_2, p10_1, p01_1, p10_2, p01_2, dz, nz )
!DEC$ FORCEINLINE
call add_poly_multiply(dz, nz, f, Iz_pol, n_Iz)
enddo
endif
enddo
if(n_Iz == -1) then
return
endif
rho = p * q * pq_inv_2
dist = (P_center(1) - Q_center(1)) * (P_center(1) - Q_center(1)) &
+ (P_center(2) - Q_center(2)) * (P_center(2) - Q_center(2)) &
+ (P_center(3) - Q_center(3)) * (P_center(3) - Q_center(3))
const = dist*rho
n_pt_tmp = n_Ix + n_Iy
do i = 0, n_pt_tmp
d_poly(i) = 0.d0
enddo
!DEC$ FORCEINLINE
call multiply_poly(Ix_pol, n_Ix, Iy_pol, n_Iy, d_poly, n_pt_tmp)
if(n_pt_tmp == -1) then
return
endif
n_pt_out = n_pt_tmp + n_Iz
do i = 0, n_pt_out
d1(i) = 0.d0
enddo
!DEC$ FORCEINLINE
call multiply_poly(d_poly, n_pt_tmp, Iz_pol, n_Iz, d1, n_pt_out)
accu = accu + rint_sum(n_pt_out, const, d1)
general_primitive_integral_erf_shifted = fact_p * fact_q * accu * pi_5_2 * p_inv * q_inv / dsqrt(p_plus_q)
return
end function general_primitive_integral_erf_shifted
!______________________________________________________________________________________________________________________
!______________________________________________________________________________________________________________________

433
src/ao_tc_eff_map/two_e_1bgauss_erf_acc.irp.f Normal file
View File

@ -0,0 +1,433 @@
double precision function j1b_gauss_erf_acc(i, j, k, l)
BEGIN_DOC
!
! integral in the AO basis:
! i(r1) j(r1) f(r12) k(r2) l(r2)
!
! with:
! f(r12) = - [ -0.5 erf(mu r12) / r12 ] (r1-r2) \cdot \sum_A (-2 a_A) [ r1A exp(-aA r1A^2) - r2A exp(-aA r2A^2) ]
! = - [ erf(mu r12) / r12 ] \sum_A a_A [ (r1-RA)^2 exp(-aA r1A^2)
! + (r2-RA)^2 exp(-aA r2A^2)
! - (r1-RA) \cdot (r2-RA) exp(-aA r1A^2)
! - (r1-RA) \cdot (r2-RA) exp(-aA r2A^2) ]
!
END_DOC
include 'utils/constants.include.F'
implicit none
integer, intent(in) :: i, j, k, l
integer :: p, q, r, s, ii
integer :: num_i, num_j, num_k, num_l, num_ii
integer :: I_power(3), J_power(3), K_power(3), L_power(3)
integer :: iorder_p(3), iorder_q(3)
integer :: shift_P(3), shift_Q(3)
integer :: dim1
double precision :: coef1, coef2, coef3, coef4
double precision :: expo1, expo2, expo3, expo4
double precision :: p1_inv, q1_inv, p2_inv, q2_inv
double precision :: P1_new(0:max_dim,3), P1_center(3), fact_p1, pp1
double precision :: P2_new(0:max_dim,3), P2_center(3), fact_p2, pp2
double precision :: Q1_new(0:max_dim,3), Q1_center(3), fact_q1, qq1
double precision :: Q2_new(0:max_dim,3), Q2_center(3), fact_q2, qq2
double precision :: I_center(3), J_center(3), K_center(3), L_center(3)
double precision :: expoii, factii, Centerii(3)
double precision :: ff, gg, cx, cy, cz
double precision :: general_primitive_integral_erf_shifted
!double precision :: j1b_gauss_erf_schwartz_accel
PROVIDE j1b_gauss_pen
dim1 = n_pt_max_integrals
! TODO
!if( ao_prim_num(i) * ao_prim_num(j) * ao_prim_num(k) * ao_prim_num(l) > 1024 ) then
! j1b_gauss_erf_schwartz_accel = j1b_gauss_erf_schwartz_accel(i, j, k, l)
! return
!endif
num_i = ao_nucl(i)
num_j = ao_nucl(j)
num_k = ao_nucl(k)
num_l = ao_nucl(l)
do p = 1, 3
I_power(p) = ao_power(i,p)
J_power(p) = ao_power(j,p)
K_power(p) = ao_power(k,p)
L_power(p) = ao_power(l,p)
I_center(p) = nucl_coord(num_i,p)
J_center(p) = nucl_coord(num_j,p)
K_center(p) = nucl_coord(num_k,p)
L_center(p) = nucl_coord(num_l,p)
enddo
j1b_gauss_erf_acc = 0.d0
do p = 1, ao_prim_num(i)
coef1 = ao_coef_normalized_ordered_transp(p, i)
expo1 = ao_expo_ordered_transp(p, i)
do q = 1, ao_prim_num(j)
coef2 = coef1 * ao_coef_normalized_ordered_transp(q, j)
expo2 = ao_expo_ordered_transp(q, j)
call give_explicit_poly_and_gaussian( P1_new, P1_center, pp1, fact_p1, iorder_p, expo1, expo2 &
, I_power, J_power, I_center, J_center, dim1 )
p1_inv = 1.d0 / pp1
do r = 1, ao_prim_num(k)
coef3 = coef2 * ao_coef_normalized_ordered_transp(r, k)
expo3 = ao_expo_ordered_transp(r, k)
do s = 1, ao_prim_num(l)
coef4 = coef3 * ao_coef_normalized_ordered_transp(s, l)
expo4 = ao_expo_ordered_transp(s, l)
call give_explicit_poly_and_gaussian( Q1_new, Q1_center, qq1, fact_q1, iorder_q, expo3, expo4 &
, K_power, L_power, K_center, L_center, dim1 )
q1_inv = 1.d0 / qq1
cx = 0.d0
cy = 0.d0
cz = 0.d0
do ii = 1, nucl_num
expoii = j1b_gauss_pen(ii)
Centerii(1:3) = nucl_coord(ii, 1:3)
call gaussian_product(pp1, P1_center, expoii, Centerii, factii, pp2, P2_center)
fact_p2 = fact_p1 * factii
p2_inv = 1.d0 / pp2
call pol_modif_center( P1_center, P2_center, iorder_p, P1_new, P2_new)
call gaussian_product(qq1, Q1_center, expoii, Centerii, factii, qq2, Q2_center)
fact_q2 = fact_q1 * factii
q2_inv = 1.d0 / qq2
call pol_modif_center( Q1_center, Q2_center, iorder_q, Q1_new, Q2_new)
! ----------------------------------------------------------------------------------------------------
! [ erf(mu r12) / r12 ] \sum_A a_A [ (r1-RA)^2 exp(-aA r1A^2)
! ----------------------------------------------------------------------------------------------------
shift_Q = (/ 0, 0, 0 /)
! x term:
ff = P2_center(1) - Centerii(1)
shift_P = (/ 2, 0, 0 /)
cx = cx + expoii * general_primitive_integral_erf_shifted( dim1 &
, P2_new, P2_center, fact_p2, pp2, p2_inv, iorder_p, shift_P &
, Q1_new, Q1_center, fact_q1, qq1, q1_inv, iorder_q, shift_Q )
shift_P = (/ 1, 0, 0 /)
cx = cx + expoii * 2.d0 * ff * general_primitive_integral_erf_shifted( dim1 &
, P2_new, P2_center, fact_p2, pp2, p2_inv, iorder_p, shift_P &
, Q1_new, Q1_center, fact_q1, qq1, q1_inv, iorder_q, shift_Q )
shift_P = (/ 0, 0, 0 /)
cx = cx + expoii * ff * ff * general_primitive_integral_erf_shifted( dim1 &
, P2_new, P2_center, fact_p2, pp2, p2_inv, iorder_p, shift_P &
, Q1_new, Q1_center, fact_q1, qq1, q1_inv, iorder_q, shift_Q )
! y term:
ff = P2_center(2) - Centerii(2)
shift_P = (/ 0, 2, 0 /)
cy = cy + expoii * general_primitive_integral_erf_shifted( dim1 &
, P2_new, P2_center, fact_p2, pp2, p2_inv, iorder_p, shift_P &
, Q1_new, Q1_center, fact_q1, qq1, q1_inv, iorder_q, shift_Q )
shift_P = (/ 0, 1, 0 /)
cy = cy + expoii * 2.d0 * ff * general_primitive_integral_erf_shifted( dim1 &
, P2_new, P2_center, fact_p2, pp2, p2_inv, iorder_p, shift_P &
, Q1_new, Q1_center, fact_q1, qq1, q1_inv, iorder_q, shift_Q )
shift_P = (/ 0, 0, 0 /)
cy = cy + expoii * ff * ff * general_primitive_integral_erf_shifted( dim1 &
, P2_new, P2_center, fact_p2, pp2, p2_inv, iorder_p, shift_P &
, Q1_new, Q1_center, fact_q1, qq1, q1_inv, iorder_q, shift_Q )
! z term:
ff = P2_center(3) - Centerii(3)
shift_P = (/ 0, 0, 2 /)
cz = cz + expoii * general_primitive_integral_erf_shifted( dim1 &
, P2_new, P2_center, fact_p2, pp2, p2_inv, iorder_p, shift_P &
, Q1_new, Q1_center, fact_q1, qq1, q1_inv, iorder_q, shift_Q )
shift_P = (/ 0, 0, 1 /)
cz = cz + expoii * 2.d0 * ff * general_primitive_integral_erf_shifted( dim1 &
, P2_new, P2_center, fact_p2, pp2, p2_inv, iorder_p, shift_P &
, Q1_new, Q1_center, fact_q1, qq1, q1_inv, iorder_q, shift_Q )
shift_P = (/ 0, 0, 0 /)
cz = cz + expoii * ff * ff * general_primitive_integral_erf_shifted( dim1 &
, P2_new, P2_center, fact_p2, pp2, p2_inv, iorder_p, shift_P &
, Q1_new, Q1_center, fact_q1, qq1, q1_inv, iorder_q, shift_Q )
! ----------------------------------------------------------------------------------------------------
! ----------------------------------------------------------------------------------------------------
! [ erf(mu r12) / r12 ] \sum_A a_A [ (r2-RA)^2 exp(-aA r2A^2)
! ----------------------------------------------------------------------------------------------------
shift_P = (/ 0, 0, 0 /)
! x term:
ff = Q2_center(1) - Centerii(1)
shift_Q = (/ 2, 0, 0 /)
cx = cx + expoii * general_primitive_integral_erf_shifted( dim1 &
, P1_new, P1_center, fact_p1, pp1, p1_inv, iorder_p, shift_P &
, Q2_new, Q2_center, fact_q2, qq2, q2_inv, iorder_q, shift_Q )
shift_Q = (/ 1, 0, 0 /)
cx = cx + expoii * 2.d0 * ff * general_primitive_integral_erf_shifted( dim1 &
, P1_new, P1_center, fact_p1, pp1, p1_inv, iorder_p, shift_P &
, Q2_new, Q2_center, fact_q2, qq2, q2_inv, iorder_q, shift_Q )
shift_Q = (/ 0, 0, 0 /)
cx = cx + expoii * ff * ff * general_primitive_integral_erf_shifted( dim1 &
, P1_new, P1_center, fact_p1, pp1, p1_inv, iorder_p, shift_P &
, Q2_new, Q2_center, fact_q2, qq2, q2_inv, iorder_q, shift_Q )
! y term:
ff = Q2_center(2) - Centerii(2)
shift_Q = (/ 0, 2, 0 /)
cy = cy + expoii * general_primitive_integral_erf_shifted( dim1 &
, P1_new, P1_center, fact_p1, pp1, p1_inv, iorder_p, shift_P &
, Q2_new, Q2_center, fact_q2, qq2, q2_inv, iorder_q, shift_Q )
shift_Q = (/ 0, 1, 0 /)
cy = cy + expoii * 2.d0 * ff * general_primitive_integral_erf_shifted( dim1 &
, P1_new, P1_center, fact_p1, pp1, p1_inv, iorder_p, shift_P &
, Q2_new, Q2_center, fact_q2, qq2, q2_inv, iorder_q, shift_Q )
shift_Q = (/ 0, 0, 0 /)
cy = cy + expoii * ff * ff * general_primitive_integral_erf_shifted( dim1 &
, P1_new, P1_center, fact_p1, pp1, p1_inv, iorder_p, shift_P &
, Q2_new, Q2_center, fact_q2, qq2, q2_inv, iorder_q, shift_Q )
! z term:
ff = Q2_center(3) - Centerii(3)
shift_Q = (/ 0, 0, 2 /)
cz = cz + expoii * general_primitive_integral_erf_shifted( dim1 &
, P1_new, P1_center, fact_p1, pp1, p1_inv, iorder_p, shift_P &
, Q2_new, Q2_center, fact_q2, qq2, q2_inv, iorder_q, shift_Q )
shift_Q = (/ 0, 0, 1 /)
cz = cz + expoii * 2.d0 * ff * general_primitive_integral_erf_shifted( dim1 &
, P1_new, P1_center, fact_p1, pp1, p1_inv, iorder_p, shift_P &
, Q2_new, Q2_center, fact_q2, qq2, q2_inv, iorder_q, shift_Q )
shift_Q = (/ 0, 0, 0 /)
cz = cz + expoii * ff * ff * general_primitive_integral_erf_shifted( dim1 &
, P1_new, P1_center, fact_p1, pp1, p1_inv, iorder_p, shift_P &
, Q2_new, Q2_center, fact_q2, qq2, q2_inv, iorder_q, shift_Q )
! ----------------------------------------------------------------------------------------------------
! ----------------------------------------------------------------------------------------------------
! - [ erf(mu r12) / r12 ] \sum_A a_A [ (r1-RA) \cdot (r2-RA) exp(-aA r1A^2) ]
! ----------------------------------------------------------------------------------------------------
! x term:
ff = P2_center(1) - Centerii(1)
gg = Q1_center(1) - Centerii(1)
shift_p = (/ 1, 0, 0 /)
shift_Q = (/ 1, 0, 0 /)
cx = cx - expoii * general_primitive_integral_erf_shifted( dim1 &
, P2_new, P2_center, fact_p2, pp2, p2_inv, iorder_p, shift_P &
, Q1_new, Q1_center, fact_q1, qq1, q1_inv, iorder_q, shift_Q )
shift_p = (/ 1, 0, 0 /)
shift_Q = (/ 0, 0, 0 /)
cx = cx - expoii * gg * general_primitive_integral_erf_shifted( dim1 &
, P2_new, P2_center, fact_p2, pp2, p2_inv, iorder_p, shift_P &
, Q1_new, Q1_center, fact_q1, qq1, q1_inv, iorder_q, shift_Q )
shift_p = (/ 0, 0, 0 /)
shift_Q = (/ 1, 0, 0 /)
cx = cx - expoii * ff * general_primitive_integral_erf_shifted( dim1 &
, P2_new, P2_center, fact_p2, pp2, p2_inv, iorder_p, shift_P &
, Q1_new, Q1_center, fact_q1, qq1, q1_inv, iorder_q, shift_Q )
shift_p = (/ 0, 0, 0 /)
shift_Q = (/ 0, 0, 0 /)
cx = cx - expoii * ff * gg * general_primitive_integral_erf_shifted( dim1 &
, P2_new, P2_center, fact_p2, pp2, p2_inv, iorder_p, shift_P &
, Q1_new, Q1_center, fact_q1, qq1, q1_inv, iorder_q, shift_Q )
! y term:
ff = P2_center(2) - Centerii(2)
gg = Q1_center(2) - Centerii(2)
shift_p = (/ 0, 1, 0 /)
shift_Q = (/ 0, 1, 0 /)
cy = cy - expoii * general_primitive_integral_erf_shifted( dim1 &
, P2_new, P2_center, fact_p2, pp2, p2_inv, iorder_p, shift_P &
, Q1_new, Q1_center, fact_q1, qq1, q1_inv, iorder_q, shift_Q )
shift_p = (/ 0, 1, 0 /)
shift_Q = (/ 0, 0, 0 /)
cy = cy - expoii * gg * general_primitive_integral_erf_shifted( dim1 &
, P2_new, P2_center, fact_p2, pp2, p2_inv, iorder_p, shift_P &
, Q1_new, Q1_center, fact_q1, qq1, q1_inv, iorder_q, shift_Q )
shift_p = (/ 0, 0, 0 /)
shift_Q = (/ 0, 1, 0 /)
cy = cy - expoii * ff * general_primitive_integral_erf_shifted( dim1 &
, P2_new, P2_center, fact_p2, pp2, p2_inv, iorder_p, shift_P &
, Q1_new, Q1_center, fact_q1, qq1, q1_inv, iorder_q, shift_Q )
shift_p = (/ 0, 0, 0 /)
shift_Q = (/ 0, 0, 0 /)
cy = cy - expoii * ff * gg * general_primitive_integral_erf_shifted( dim1 &
, P2_new, P2_center, fact_p2, pp2, p2_inv, iorder_p, shift_P &
, Q1_new, Q1_center, fact_q1, qq1, q1_inv, iorder_q, shift_Q )
! z term:
ff = P2_center(3) - Centerii(3)
gg = Q1_center(3) - Centerii(3)
shift_p = (/ 0, 0, 1 /)
shift_Q = (/ 0, 0, 1 /)
cz = cz - expoii * general_primitive_integral_erf_shifted( dim1 &
, P2_new, P2_center, fact_p2, pp2, p2_inv, iorder_p, shift_P &
, Q1_new, Q1_center, fact_q1, qq1, q1_inv, iorder_q, shift_Q )
shift_p = (/ 0, 0, 1 /)
shift_Q = (/ 0, 0, 0 /)
cz = cz - expoii * gg * general_primitive_integral_erf_shifted( dim1 &
, P2_new, P2_center, fact_p2, pp2, p2_inv, iorder_p, shift_P &
, Q1_new, Q1_center, fact_q1, qq1, q1_inv, iorder_q, shift_Q )
shift_p = (/ 0, 0, 0 /)
shift_Q = (/ 0, 0, 1 /)
cz = cz - expoii * ff * general_primitive_integral_erf_shifted( dim1 &
, P2_new, P2_center, fact_p2, pp2, p2_inv, iorder_p, shift_P &
, Q1_new, Q1_center, fact_q1, qq1, q1_inv, iorder_q, shift_Q )
shift_p = (/ 0, 0, 0 /)
shift_Q = (/ 0, 0, 0 /)
cz = cz - expoii * ff * gg * general_primitive_integral_erf_shifted( dim1 &
, P2_new, P2_center, fact_p2, pp2, p2_inv, iorder_p, shift_P &
, Q1_new, Q1_center, fact_q1, qq1, q1_inv, iorder_q, shift_Q )
! ----------------------------------------------------------------------------------------------------
! ----------------------------------------------------------------------------------------------------
! - [ erf(mu r12) / r12 ] \sum_A a_A [ (r1-RA) \cdot (r2-RA) exp(-aA r2A^2) ]
! ----------------------------------------------------------------------------------------------------
! x term:
ff = P1_center(1) - Centerii(1)
gg = Q2_center(1) - Centerii(1)
shift_p = (/ 1, 0, 0 /)
shift_Q = (/ 1, 0, 0 /)
cx = cx - expoii * general_primitive_integral_erf_shifted( dim1 &
, P1_new, P1_center, fact_p1, pp1, p1_inv, iorder_p, shift_P &
, Q2_new, Q2_center, fact_q2, qq2, q2_inv, iorder_q, shift_Q )
shift_p = (/ 1, 0, 0 /)
shift_Q = (/ 0, 0, 0 /)
cx = cx - expoii * gg * general_primitive_integral_erf_shifted( dim1 &
, P1_new, P1_center, fact_p1, pp1, p1_inv, iorder_p, shift_P &
, Q2_new, Q2_center, fact_q2, qq2, q2_inv, iorder_q, shift_Q )
shift_p = (/ 0, 0, 0 /)
shift_Q = (/ 1, 0, 0 /)
cx = cx - expoii * ff * general_primitive_integral_erf_shifted( dim1 &
, P1_new, P1_center, fact_p1, pp1, p1_inv, iorder_p, shift_P &
, Q2_new, Q2_center, fact_q2, qq2, q2_inv, iorder_q, shift_Q )
shift_p = (/ 0, 0, 0 /)
shift_Q = (/ 0, 0, 0 /)
cx = cx - expoii * ff * gg * general_primitive_integral_erf_shifted( dim1 &
, P1_new, P1_center, fact_p1, pp1, p1_inv, iorder_p, shift_P &
, Q2_new, Q2_center, fact_q2, qq2, q2_inv, iorder_q, shift_Q )
! y term:
ff = P1_center(2) - Centerii(2)
gg = Q2_center(2) - Centerii(2)
shift_p = (/ 0, 1, 0 /)
shift_Q = (/ 0, 1, 0 /)
cy = cy - expoii * general_primitive_integral_erf_shifted( dim1 &
, P1_new, P1_center, fact_p1, pp1, p1_inv, iorder_p, shift_P &
, Q2_new, Q2_center, fact_q2, qq2, q2_inv, iorder_q, shift_Q )
shift_p = (/ 0, 1, 0 /)
shift_Q = (/ 0, 0, 0 /)
cy = cy - expoii * gg * general_primitive_integral_erf_shifted( dim1 &
, P1_new, P1_center, fact_p1, pp1, p1_inv, iorder_p, shift_P &
, Q2_new, Q2_center, fact_q2, qq2, q2_inv, iorder_q, shift_Q )
shift_p = (/ 0, 0, 0 /)
shift_Q = (/ 0, 1, 0 /)
cy = cy - expoii * ff * general_primitive_integral_erf_shifted( dim1 &
, P1_new, P1_center, fact_p1, pp1, p1_inv, iorder_p, shift_P &
, Q2_new, Q2_center, fact_q2, qq2, q2_inv, iorder_q, shift_Q )
shift_p = (/ 0, 0, 0 /)
shift_Q = (/ 0, 0, 0 /)
cy = cy - expoii * ff * gg * general_primitive_integral_erf_shifted( dim1 &
, P1_new, P1_center, fact_p1, pp1, p1_inv, iorder_p, shift_P &
, Q2_new, Q2_center, fact_q2, qq2, q2_inv, iorder_q, shift_Q )
! z term:
ff = P1_center(3) - Centerii(3)
gg = Q2_center(3) - Centerii(3)
shift_p = (/ 0, 0, 1 /)
shift_Q = (/ 0, 0, 1 /)
cz = cz - expoii * general_primitive_integral_erf_shifted( dim1 &
, P1_new, P1_center, fact_p1, pp1, p1_inv, iorder_p, shift_P &
, Q2_new, Q2_center, fact_q2, qq2, q2_inv, iorder_q, shift_Q )
shift_p = (/ 0, 0, 1 /)
shift_Q = (/ 0, 0, 0 /)
cz = cz - expoii * gg * general_primitive_integral_erf_shifted( dim1 &
, P1_new, P1_center, fact_p1, pp1, p1_inv, iorder_p, shift_P &
, Q2_new, Q2_center, fact_q2, qq2, q2_inv, iorder_q, shift_Q )
shift_p = (/ 0, 0, 0 /)
shift_Q = (/ 0, 0, 1 /)
cz = cz - expoii * ff * general_primitive_integral_erf_shifted( dim1 &
, P1_new, P1_center, fact_p1, pp1, p1_inv, iorder_p, shift_P &
, Q2_new, Q2_center, fact_q2, qq2, q2_inv, iorder_q, shift_Q )
shift_p = (/ 0, 0, 0 /)
shift_Q = (/ 0, 0, 0 /)
cz = cz - expoii * ff * gg * general_primitive_integral_erf_shifted( dim1 &
, P1_new, P1_center, fact_p1, pp1, p1_inv, iorder_p, shift_P &
, Q2_new, Q2_center, fact_q2, qq2, q2_inv, iorder_q, shift_Q )
! ----------------------------------------------------------------------------------------------------
enddo
j1b_gauss_erf_acc = j1b_gauss_erf_acc - coef4 * ( cx + cy + cz )
enddo ! s
enddo ! r
enddo ! q
enddo ! p
return
end function j1b_gauss_erf_acc

326
src/ao_tc_eff_map/two_e_ints_gauss.irp.f Normal file
View File

@ -0,0 +1,326 @@
double precision function ao_tc_sym_two_e_pot(i,j,k,l)
implicit none
BEGIN_DOC
! integral of the AO basis <ik|jl> or (ij|kl)
! i(r1) j(r1) (tc_pot(r12,mu)) k(r2) l(r2)
!
! where (tc_pot(r12,mu)) is the scalar part of the potential EXCLUDING the term erf(mu r12)/r12.
!
! See Eq. (32) of JCP 154, 084119 (2021).
END_DOC
integer,intent(in) :: i,j,k,l
integer :: p,q,r,s
double precision :: I_center(3),J_center(3),K_center(3),L_center(3)
integer :: num_i,num_j,num_k,num_l,dim1,I_power(3),J_power(3),K_power(3),L_power(3)
double precision :: integral
include 'utils/constants.include.F'
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
integer :: iorder_p(3), iorder_q(3)
double precision, allocatable :: schwartz_kl(:,:)
double precision :: schwartz_ij
double precision :: scw_gauss_int,general_primitive_integral_gauss
dim1 = n_pt_max_integrals
num_i = ao_nucl(i)
num_j = ao_nucl(j)
num_k = ao_nucl(k)
num_l = ao_nucl(l)
ao_tc_sym_two_e_pot = 0.d0
double precision :: thr
thr = ao_integrals_threshold*ao_integrals_threshold
allocate(schwartz_kl(0:ao_prim_num(l),0:ao_prim_num(k)))
double precision :: coef3
double precision :: coef2
double precision :: p_inv,q_inv
double precision :: coef1
double precision :: coef4
do p = 1, 3
I_power(p) = ao_power(i,p)
J_power(p) = ao_power(j,p)
K_power(p) = ao_power(k,p)
L_power(p) = ao_power(l,p)
I_center(p) = nucl_coord(num_i,p)
J_center(p) = nucl_coord(num_j,p)
K_center(p) = nucl_coord(num_k,p)
L_center(p) = nucl_coord(num_l,p)
enddo
schwartz_kl(0,0) = 0.d0
do r = 1, ao_prim_num(k)
coef1 = ao_coef_normalized_ordered_transp(r,k)*ao_coef_normalized_ordered_transp(r,k)
schwartz_kl(0,r) = 0.d0
do s = 1, ao_prim_num(l)
coef2 = coef1 * ao_coef_normalized_ordered_transp(s,l) * ao_coef_normalized_ordered_transp(s,l)
call give_explicit_poly_and_gaussian(Q_new,Q_center,qq,fact_q,iorder_q,&
ao_expo_ordered_transp(r,k),ao_expo_ordered_transp(s,l), &
K_power,L_power,K_center,L_center,dim1)
q_inv = 1.d0/qq
scw_gauss_int = general_primitive_integral_gauss(dim1, &
Q_new,Q_center,fact_q,qq,q_inv,iorder_q, &
Q_new,Q_center,fact_q,qq,q_inv,iorder_q)
schwartz_kl(s,r) = dabs(scw_gauss_int * coef2)
schwartz_kl(0,r) = max(schwartz_kl(0,r),schwartz_kl(s,r))
enddo
schwartz_kl(0,0) = max(schwartz_kl(0,r),schwartz_kl(0,0))
enddo
do p = 1, ao_prim_num(i)
coef1 = ao_coef_normalized_ordered_transp(p,i)
do q = 1, ao_prim_num(j)
coef2 = coef1*ao_coef_normalized_ordered_transp(q,j)
call give_explicit_poly_and_gaussian(P_new,P_center,pp,fact_p,iorder_p,&
ao_expo_ordered_transp(p,i),ao_expo_ordered_transp(q,j), &
I_power,J_power,I_center,J_center,dim1)
p_inv = 1.d0/pp
scw_gauss_int = general_primitive_integral_gauss(dim1, &
P_new,P_center,fact_p,pp,p_inv,iorder_p, &
P_new,P_center,fact_p,pp,p_inv,iorder_p)
schwartz_ij = dabs(scw_gauss_int * coef2*coef2)
if (schwartz_kl(0,0)*schwartz_ij < thr) then
cycle
endif
do r = 1, ao_prim_num(k)
if (schwartz_kl(0,r)*schwartz_ij < thr) then
cycle
endif
coef3 = coef2*ao_coef_normalized_ordered_transp(r,k)
do s = 1, ao_prim_num(l)
if (schwartz_kl(s,r)*schwartz_ij < thr) then
cycle
endif
coef4 = coef3*ao_coef_normalized_ordered_transp(s,l)
call give_explicit_poly_and_gaussian(Q_new,Q_center,qq,fact_q,iorder_q, &
ao_expo_ordered_transp(r,k),ao_expo_ordered_transp(s,l), &
K_power,L_power,K_center,L_center,dim1)
q_inv = 1.d0/qq
integral = general_primitive_integral_gauss(dim1, &
P_new,P_center,fact_p,pp,p_inv,iorder_p, &
Q_new,Q_center,fact_q,qq,q_inv,iorder_q)
ao_tc_sym_two_e_pot = ao_tc_sym_two_e_pot + coef4 * integral
enddo ! s
enddo ! r
enddo ! q
enddo ! p
deallocate (schwartz_kl)
end
double precision function general_primitive_integral_gauss(dim, &
P_new,P_center,fact_p,p,p_inv,iorder_p, &
Q_new,Q_center,fact_q,q,q_inv,iorder_q)
implicit none
BEGIN_DOC
! Computes the integral <pq|rs> where p,q,r,s are Gaussian primitives
END_DOC
integer,intent(in) :: dim
include 'utils/constants.include.F'
double precision, intent(in) :: P_new(0:max_dim,3),P_center(3),fact_p,p,p_inv
double precision, intent(in) :: Q_new(0:max_dim,3),Q_center(3),fact_q,q,q_inv
integer, intent(in) :: iorder_p(3)
integer, intent(in) :: iorder_q(3)
double precision :: r_cut,gama_r_cut,rho,dist
double precision :: dx(0:max_dim),Ix_pol(0:max_dim),dy(0:max_dim),Iy_pol(0:max_dim),dz(0:max_dim),Iz_pol(0:max_dim)
integer :: n_Ix,n_Iy,n_Iz,nx,ny,nz
double precision :: bla
integer :: ix,iy,iz,jx,jy,jz,i
double precision :: a,b,c,d,e,f,accu,pq,const
double precision :: pq_inv, p10_1, p10_2, p01_1, p01_2,pq_inv_2
integer :: n_pt_tmp,n_pt_out, iorder
double precision :: d1(0:max_dim),d_poly(0:max_dim),rint,d1_screened(0:max_dim)
double precision :: thr
thr = ao_integrals_threshold
general_primitive_integral_gauss = 0.d0
!DIR$ ATTRIBUTES ALIGN : $IRP_ALIGN :: dx,Ix_pol,dy,Iy_pol,dz,Iz_pol
!DIR$ ATTRIBUTES ALIGN : $IRP_ALIGN :: d1, d_poly
! Gaussian Product
! ----------------
pq = p_inv*0.5d0*q_inv
pq_inv = 0.5d0/(p+q)
p10_1 = q*pq ! 1/(2p)
p01_1 = p*pq ! 1/(2q)
pq_inv_2 = pq_inv+pq_inv
p10_2 = pq_inv_2 * p10_1*q !0.5d0*q/(pq + p*p)
p01_2 = pq_inv_2 * p01_1*p !0.5d0*p/(q*q + pq)
accu = 0.d0
iorder = iorder_p(1)+iorder_q(1)+iorder_p(1)+iorder_q(1)
do ix=0,iorder
Ix_pol(ix) = 0.d0
enddo
n_Ix = 0
do ix = 0, iorder_p(1)
if (abs(P_new(ix,1)) < thr) cycle
a = P_new(ix,1)
do jx = 0, iorder_q(1)
d = a*Q_new(jx,1)
if (abs(d) < thr) cycle
!DIR$ FORCEINLINE
call give_polynom_mult_center_x(P_center(1),Q_center(1),ix,jx,p,q,iorder,pq_inv,pq_inv_2,p10_1,p01_1,p10_2,p01_2,dx,nx)
!DIR$ FORCEINLINE
call add_poly_multiply(dx,nx,d,Ix_pol,n_Ix)
enddo
enddo
if (n_Ix == -1) then
return
endif
iorder = iorder_p(2)+iorder_q(2)+iorder_p(2)+iorder_q(2)
do ix=0, iorder
Iy_pol(ix) = 0.d0
enddo
n_Iy = 0
do iy = 0, iorder_p(2)
if (abs(P_new(iy,2)) > thr) then
b = P_new(iy,2)
do jy = 0, iorder_q(2)
e = b*Q_new(jy,2)
if (abs(e) < thr) cycle
!DIR$ FORCEINLINE
call give_polynom_mult_center_x(P_center(2),Q_center(2),iy,jy,p,q,iorder,pq_inv,pq_inv_2,p10_1,p01_1,p10_2,p01_2,dy,ny)
!DIR$ FORCEINLINE
call add_poly_multiply(dy,ny,e,Iy_pol,n_Iy)
enddo
endif
enddo
if (n_Iy == -1) then
return
endif
iorder = iorder_p(3)+iorder_q(3)+iorder_p(3)+iorder_q(3)
do ix=0,iorder
Iz_pol(ix) = 0.d0
enddo
n_Iz = 0
do iz = 0, iorder_p(3)
if (abs(P_new(iz,3)) > thr) then
c = P_new(iz,3)
do jz = 0, iorder_q(3)
f = c*Q_new(jz,3)
if (abs(f) < thr) cycle
!DIR$ FORCEINLINE
call give_polynom_mult_center_x(P_center(3),Q_center(3),iz,jz,p,q,iorder,pq_inv,pq_inv_2,p10_1,p01_1,p10_2,p01_2,dz,nz)
!DIR$ FORCEINLINE
call add_poly_multiply(dz,nz,f,Iz_pol,n_Iz)
enddo
endif
enddo
if (n_Iz == -1) then
return
endif
rho = p*q *pq_inv_2
dist = (P_center(1) - Q_center(1))*(P_center(1) - Q_center(1)) + &
(P_center(2) - Q_center(2))*(P_center(2) - Q_center(2)) + &
(P_center(3) - Q_center(3))*(P_center(3) - Q_center(3))
const = dist*rho
n_pt_tmp = n_Ix+n_Iy
do i=0,n_pt_tmp
d_poly(i)=0.d0
enddo
!DIR$ FORCEINLINE
call multiply_poly(Ix_pol,n_Ix,Iy_pol,n_Iy,d_poly,n_pt_tmp)
if (n_pt_tmp == -1) then
return
endif
n_pt_out = n_pt_tmp+n_Iz
do i=0,n_pt_out
d1(i)=0.d0
enddo
!DIR$ FORCEINLINE
call multiply_poly(d_poly ,n_pt_tmp ,Iz_pol,n_Iz,d1,n_pt_out)
double precision :: aa,c_a,t_a,rho_old,w_a,pi_3,prefactor,inv_pq_3_2
double precision :: gauss_int
integer :: m
gauss_int = 0.d0
pi_3 = pi*pi*pi
inv_pq_3_2 = (p_inv * q_inv)**(1.5d0)
rho_old = (p*q)/(p+q)
prefactor = pi_3 * inv_pq_3_2 * fact_p * fact_q
do i = 1, n_gauss_eff_pot ! browse the gaussians with different expo/coef
aa = expo_gauss_eff_pot(i)
c_a = coef_gauss_eff_pot(i)
t_a = dsqrt( aa /(rho_old + aa) )
w_a = dexp(-t_a*t_a*rho_old*dist)
accu = 0.d0
! evaluation of the polynom Ix(t_a) * Iy(t_a) * Iz(t_a)
do m = 0, n_pt_out,2
accu += d1(m) * (t_a)**(dble(m))
enddo
! equation A8 of PRA-70-062505 (2004) of Toul. Col. Sav.
gauss_int = gauss_int + c_a * prefactor * (1.d0 - t_a*t_a)**(1.5d0) * w_a * accu
enddo
general_primitive_integral_gauss = gauss_int
end
subroutine compute_ao_integrals_gauss_jl(j,l,n_integrals,buffer_i,buffer_value)
implicit none
use map_module
BEGIN_DOC
! Parallel client for AO integrals
END_DOC
integer, intent(in) :: j,l
integer,intent(out) :: n_integrals
integer(key_kind),intent(out) :: buffer_i(ao_num*ao_num)
real(integral_kind),intent(out) :: buffer_value(ao_num*ao_num)
integer :: i,k
double precision :: cpu_1,cpu_2, wall_1, wall_2
double precision :: integral, wall_0
double precision :: thr,ao_tc_sym_two_e_pot
integer :: kk, m, j1, i1
logical, external :: ao_two_e_integral_zero
thr = ao_integrals_threshold
n_integrals = 0
j1 = j+ishft(l*l-l,-1)
do k = 1, ao_num ! r1
i1 = ishft(k*k-k,-1)
if (i1 > j1) then
exit
endif
do i = 1, k
i1 += 1
if (i1 > j1) then
exit
endif
! if (ao_two_e_integral_zero(i,j,k,l)) then
if (.False.) then
cycle
endif
if (ao_two_e_integral_erf_schwartz(i,k)*ao_two_e_integral_erf_schwartz(j,l) < thr ) then
cycle
endif
!DIR$ FORCEINLINE
integral = ao_tc_sym_two_e_pot(i,k,j,l) ! i,k : r1 j,l : r2
if (abs(integral) < thr) then
cycle
endif
n_integrals += 1
!DIR$ FORCEINLINE
call two_e_integrals_index(i,j,k,l,buffer_i(n_integrals))
buffer_value(n_integrals) = integral
enddo
enddo
end

7
src/ao_two_e_ints/EZFIO.cfg
View File

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

57
src/ao_two_e_ints/gauss_legendre.irp.f
View File

@ -1,57 +0,0 @@
BEGIN_PROVIDER [ double precision, gauleg_t2, (n_pt_max_integrals,n_pt_max_integrals/2) ]
&BEGIN_PROVIDER [ double precision, gauleg_w, (n_pt_max_integrals,n_pt_max_integrals/2) ]
implicit none
BEGIN_DOC
! t_w(i,1,k) = w(i)
! t_w(i,2,k) = t(i)
END_DOC
integer :: i,j,l
l=0
do i = 2,n_pt_max_integrals,2
l = l+1
call gauleg(0.d0,1.d0,gauleg_t2(1,l),gauleg_w(1,l),i)
do j=1,i
gauleg_t2(j,l) *= gauleg_t2(j,l)
enddo
enddo
END_PROVIDER
subroutine gauleg(x1,x2,x,w,n)
implicit none
BEGIN_DOC
! Gauss-Legendre
END_DOC
integer, intent(in) :: n
double precision, intent(in) :: x1, x2
double precision, intent (out) :: x(n),w(n)
double precision, parameter :: eps=3.d-14
integer :: m,i,j
double precision :: xm, xl, z, z1, p1, p2, p3, pp, dn
m=(n+1)/2
xm=0.5d0*(x2+x1)
xl=0.5d0*(x2-x1)
dn = dble(n)
do i=1,m
z=dcos(3.141592654d0*(dble(i)-.25d0)/(dble(n)+.5d0))
z1 = z+1.d0
do while (dabs(z-z1) > eps)
p1=1.d0
p2=0.d0
do j=1,n
p3=p2
p2=p1
p1=(dble(j+j-1)*z*p2-dble(j-1)*p3)/j
enddo
pp=dn*(z*p1-p2)/(z*z-1.d0)
z1=z
z=z1-p1/pp
end do
x(i)=xm-xl*z
x(n+1-i)=xm+xl*z
w(i)=(xl+xl)/((1.d0-z*z)*pp*pp)
w(n+1-i)=w(i)
enddo
end

4
src/ao_two_e_ints/map_integrals.irp.f
View File

@ -326,9 +326,9 @@ double precision function get_ao_two_e_integral(i,j,k,l,map) result(result)
use map_module
implicit none
BEGIN_DOC
! Gets one AO bi-electronic integral from the AO map
! Gets one AO bi-electronic integral from the AO map in PHYSICIST NOTATION
!
! i,j,k,l in physicist notation <ij|kl>
! <1:k, 2:l |1:i, 2:j>
END_DOC
integer, intent(in) :: i,j,k,l
integer(key_kind) :: idx

191
src/ao_two_e_ints/test_cosgtos_1e.irp.f Normal file
View File

@ -0,0 +1,191 @@
! ---
program test_cosgtos
implicit none
integer :: i, j
call init_expo()
! call test_coef()
call test_1e_kin()
call test_1e_coul()
i = 1
j = 1
! call test_1e_coul_real(i, j)
! call test_1e_coul_cpx (i, j)
end
! ---
subroutine init_expo()
implicit none
integer :: i, j
double precision, allocatable :: expo_im(:,:)
allocate(expo_im(ao_num, ao_prim_num_max))
do j = 1, ao_prim_num_max
do i = 1, ao_num
ao_expoim_cosgtos(i,j) = 0.d0
enddo
enddo
call ezfio_set_cosgtos_ao_int_ao_expoim_cosgtos(expo_im)
deallocate(expo_im)
end subroutine init_expo
! ---
subroutine test_coef()
implicit none
integer :: i, j
double precision :: coef, coef_gtos, coef_cosgtos
double precision :: delta, accu_abs
print*, ' check coefs'
accu_abs = 0.d0
accu_abs = 0.d0
do i = 1, ao_num
do j = 1, ao_prim_num(i)
coef = ao_coef(i,j)
coef_gtos = 1.d0 * ao_coef_normalized_ordered_transp(j,i)
coef_cosgtos = 2.d0 * ao_coef_norm_ord_transp_cosgtos (j,i)
delta = dabs(coef_gtos - coef_cosgtos)
accu_abs += delta
if(delta .gt. 1.d-10) then
print*, ' problem on: '
print*, i, j
print*, coef_gtos, coef_cosgtos, delta
print*, coef
stop
endif
enddo
enddo
print*, 'accu_abs = ', accu_abs
end subroutine test_coef
! ---
subroutine test_1e_kin()
implicit none
integer :: i, j
double precision :: integral_gtos, integral_cosgtos
double precision :: delta, accu_abs
print*, ' check kin 1e integrals'
accu_abs = 0.d0
accu_abs = 0.d0
do j = 1, ao_num
do i = 1, ao_num
integral_gtos = ao_kinetic_integrals (i,j)
integral_cosgtos = ao_kinetic_integrals_cosgtos(i,j)
delta = dabs(integral_gtos - integral_cosgtos)
accu_abs += delta
if(delta .gt. 1.d-7) then
print*, ' problem on: '
print*, i, j
print*, integral_gtos, integral_cosgtos, delta
!stop
endif
enddo
enddo
print*,'accu_abs = ', accu_abs
end subroutine test_1e_kin
! ---
subroutine test_1e_coul()
implicit none
integer :: i, j
double precision :: integral_gtos, integral_cosgtos
double precision :: delta, accu_abs
print*, ' check Coulomb 1e integrals'
accu_abs = 0.d0
accu_abs = 0.d0
do j = 1, ao_num
do i = 1, ao_num
integral_gtos = ao_integrals_n_e (i,j)
integral_cosgtos = ao_integrals_n_e_cosgtos(i,j)
delta = dabs(integral_gtos - integral_cosgtos)
accu_abs += delta
if(delta .gt. 1.d-7) then
print*, ' problem on: '
print*, i, j
print*, integral_gtos, integral_cosgtos, delta
!stop
endif
enddo
enddo
print*,'accu_abs = ', accu_abs
end subroutine test_1e_coul
! ---
subroutine test_1e_coul_cpx(i, j)
implicit none
integer, intent(in) :: i, j
double precision :: integral
integral = ao_integrals_n_e_cosgtos(i,j)
print*, ' cpx Coulomb 1e integrals', integral
end subroutine test_1e_coul_cpx
! ---
subroutine test_1e_coul_real(i, j)
implicit none
integer, intent(in) :: i, j
double precision :: integral
integral = ao_integrals_n_e(i,j)
print*, ' real Coulomb 1e integrals', integral
end subroutine test_1e_coul_real
! ---

165
src/ao_two_e_ints/test_cosgtos_2e.irp.f Normal file
View File

@ -0,0 +1,165 @@
! ---
program test_cosgtos
implicit none
integer :: iao, jao, kao, lao
call init_expo()
! call test_coef()
call test_2e()
iao = 1
jao = 1
kao = 1
lao = 21
! call test_2e_cpx (iao, jao, kao, lao)
! call test_2e_real(iao, jao, kao, lao)
end
! ---
subroutine init_expo()
implicit none
integer :: i, j
double precision, allocatable :: expo_im(:,:)
allocate(expo_im(ao_num, ao_prim_num_max))
do j = 1, ao_prim_num_max
do i = 1, ao_num
ao_expoim_cosgtos(i,j) = 0.d0
enddo
enddo
call ezfio_set_cosgtos_ao_int_ao_expoim_cosgtos(expo_im)
deallocate(expo_im)
end subroutine init_expo
! ---
subroutine test_coef()
implicit none
integer :: i, j
double precision :: coef, coef_gtos, coef_cosgtos
double precision :: delta, accu_abs
print*, ' check coefs'
accu_abs = 0.d0
accu_abs = 0.d0
do i = 1, ao_num
do j = 1, ao_prim_num(i)
coef = ao_coef(i,j)
coef_gtos = 1.d0 * ao_coef_normalized_ordered_transp(j,i)
coef_cosgtos = 2.d0 * ao_coef_norm_ord_transp_cosgtos (j,i)
delta = dabs(coef_gtos - coef_cosgtos)
accu_abs += delta
if(delta .gt. 1.d-10) then
print*, ' problem on: '
print*, i, j
print*, coef_gtos, coef_cosgtos, delta
print*, coef
stop
endif
enddo
enddo
print*, 'accu_abs = ', accu_abs
end subroutine test_coef
! ---
subroutine test_2e()
implicit none
integer :: iao, jao, kao, lao
double precision :: integral_gtos, integral_cosgtos
double precision :: delta, accu_abs
double precision :: ao_two_e_integral, ao_two_e_integral_cosgtos
print*, ' check integrals'
accu_abs = 0.d0
accu_abs = 0.d0
! iao = 1
! jao = 1
! kao = 1
! lao = 24
do iao = 1, ao_num ! r1
do jao = 1, ao_num ! r2
do kao = 1, ao_num ! r1
do lao = 1, ao_num ! r2
integral_gtos = ao_two_e_integral (iao, kao, jao, lao)
integral_cosgtos = ao_two_e_integral_cosgtos(iao, kao, jao, lao)
delta = dabs(integral_gtos - integral_cosgtos)
accu_abs += delta
if(delta .gt. 1.d-7) then
print*, ' problem on: '
print*, iao, jao, kao, lao
print*, integral_gtos, integral_cosgtos, delta
!stop
endif
enddo
enddo
enddo
enddo
print*,'accu_abs = ', accu_abs
end subroutine test_2e
! ---
subroutine test_2e_cpx(iao, jao, kao, lao)
implicit none
integer, intent(in) :: iao, jao, kao, lao
double precision :: integral
double precision :: ao_two_e_integral_cosgtos
integral = ao_two_e_integral_cosgtos(iao, kao, jao, lao)
print *, ' cosgtos: ', integral
end subroutine test_2e_cpx
! ---
subroutine test_2e_real(iao, jao, kao, lao)
implicit none
integer, intent(in) :: iao, jao, kao, lao
double precision :: integral
double precision :: ao_two_e_integral
integral = ao_two_e_integral(iao, kao, jao, lao)
print *, ' gtos: ', integral
end subroutine test_2e_real
! ---

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

@ -1,108 +1,132 @@
! ---
double precision function ao_two_e_integral(i,j,k,l)
implicit none
BEGIN_DOC
! integral of the AO basis <ik|jl> or (ij|kl)
! i(r1) j(r1) 1/r12 k(r2) l(r2)
END_DOC
integer,intent(in) :: i,j,k,l
integer :: p,q,r,s
double precision :: I_center(3),J_center(3),K_center(3),L_center(3)
integer :: num_i,num_j,num_k,num_l,dim1,I_power(3),J_power(3),K_power(3),L_power(3)
double precision :: integral
implicit none
include 'utils/constants.include.F'
integer, intent(in) :: i, j, k, l
integer :: p, q, r, s
integer :: num_i,num_j,num_k,num_l,dim1,I_power(3),J_power(3),K_power(3),L_power(3)
integer :: iorder_p(3), iorder_q(3)
double precision :: I_center(3), J_center(3), K_center(3), L_center(3)
double precision :: integral
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
integer :: iorder_p(3), iorder_q(3)
double precision :: ao_two_e_integral_schwartz_accel
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
double precision :: ao_two_e_integral_cosgtos
dim1 = n_pt_max_integrals
num_i = ao_nucl(i)
num_j = ao_nucl(j)
num_k = ao_nucl(k)
num_l = ao_nucl(l)
ao_two_e_integral = 0.d0
if(use_cosgtos) then
!print *, ' use_cosgtos for ao_two_e_integral ?', use_cosgtos
if (num_i /= num_j .or. num_k /= num_l .or. num_j /= num_k)then
do p = 1, 3
I_power(p) = ao_power(i,p)
J_power(p) = ao_power(j,p)
K_power(p) = ao_power(k,p)
L_power(p) = ao_power(l,p)
I_center(p) = nucl_coord(num_i,p)
J_center(p) = nucl_coord(num_j,p)
K_center(p) = nucl_coord(num_k,p)
L_center(p) = nucl_coord(num_l,p)
enddo
ao_two_e_integral = ao_two_e_integral_cosgtos(i,j,k,l)
double precision :: coef1, coef2, coef3, coef4
double precision :: p_inv,q_inv
double precision :: general_primitive_integral
else
do p = 1, ao_prim_num(i)
coef1 = ao_coef_normalized_ordered_transp(p,i)
do q = 1, ao_prim_num(j)
coef2 = coef1*ao_coef_normalized_ordered_transp(q,j)
call give_explicit_poly_and_gaussian(P_new,P_center,pp,fact_p,iorder_p,&
ao_expo_ordered_transp(p,i),ao_expo_ordered_transp(q,j), &
I_power,J_power,I_center,J_center,dim1)
p_inv = 1.d0/pp
do r = 1, ao_prim_num(k)
coef3 = coef2*ao_coef_normalized_ordered_transp(r,k)
do s = 1, ao_prim_num(l)
coef4 = coef3*ao_coef_normalized_ordered_transp(s,l)
call give_explicit_poly_and_gaussian(Q_new,Q_center,qq,fact_q,iorder_q,&
ao_expo_ordered_transp(r,k),ao_expo_ordered_transp(s,l), &
K_power,L_power,K_center,L_center,dim1)
q_inv = 1.d0/qq
integral = general_primitive_integral(dim1, &
P_new,P_center,fact_p,pp,p_inv,iorder_p, &
Q_new,Q_center,fact_q,qq,q_inv,iorder_q)
ao_two_e_integral = ao_two_e_integral + coef4 * integral
enddo ! s
enddo ! r
enddo ! q
enddo ! p
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
do p = 1, 3
I_power(p) = ao_power(i,p)
J_power(p) = ao_power(j,p)
K_power(p) = ao_power(k,p)
L_power(p) = ao_power(l,p)
enddo
double precision :: ERI
dim1 = n_pt_max_integrals
do p = 1, ao_prim_num(i)
coef1 = ao_coef_normalized_ordered_transp(p,i)
do q = 1, ao_prim_num(j)
coef2 = coef1*ao_coef_normalized_ordered_transp(q,j)
do r = 1, ao_prim_num(k)
coef3 = coef2*ao_coef_normalized_ordered_transp(r,k)
do s = 1, ao_prim_num(l)
coef4 = coef3*ao_coef_normalized_ordered_transp(s,l)
integral = ERI( &
ao_expo_ordered_transp(p,i),ao_expo_ordered_transp(q,j),ao_expo_ordered_transp(r,k),ao_expo_ordered_transp(s,l),&
I_power(1),J_power(1),K_power(1),L_power(1), &
I_power(2),J_power(2),K_power(2),L_power(2), &
I_power(3),J_power(3),K_power(3),L_power(3))
ao_two_e_integral = ao_two_e_integral + coef4 * integral
enddo ! s
enddo ! r
enddo ! q
enddo ! p
num_i = ao_nucl(i)
num_j = ao_nucl(j)
num_k = ao_nucl(k)
num_l = ao_nucl(l)
ao_two_e_integral = 0.d0
if (num_i /= num_j .or. num_k /= num_l .or. num_j /= num_k)then
do p = 1, 3
I_power(p) = ao_power(i,p)
J_power(p) = ao_power(j,p)
K_power(p) = ao_power(k,p)
L_power(p) = ao_power(l,p)
I_center(p) = nucl_coord(num_i,p)
J_center(p) = nucl_coord(num_j,p)
K_center(p) = nucl_coord(num_k,p)
L_center(p) = nucl_coord(num_l,p)
enddo
double precision :: coef1, coef2, coef3, coef4
double precision :: p_inv,q_inv
double precision :: general_primitive_integral
do p = 1, ao_prim_num(i)
coef1 = ao_coef_normalized_ordered_transp(p,i)
do q = 1, ao_prim_num(j)
coef2 = coef1*ao_coef_normalized_ordered_transp(q,j)
call give_explicit_poly_and_gaussian(P_new,P_center,pp,fact_p,iorder_p,&
ao_expo_ordered_transp(p,i),ao_expo_ordered_transp(q,j), &
I_power,J_power,I_center,J_center,dim1)
p_inv = 1.d0/pp
do r = 1, ao_prim_num(k)
coef3 = coef2*ao_coef_normalized_ordered_transp(r,k)
do s = 1, ao_prim_num(l)
coef4 = coef3*ao_coef_normalized_ordered_transp(s,l)
call give_explicit_poly_and_gaussian(Q_new,Q_center,qq,fact_q,iorder_q,&
ao_expo_ordered_transp(r,k),ao_expo_ordered_transp(s,l), &
K_power,L_power,K_center,L_center,dim1)
q_inv = 1.d0/qq
integral = general_primitive_integral(dim1, &
P_new,P_center,fact_p,pp,p_inv,iorder_p, &
Q_new,Q_center,fact_q,qq,q_inv,iorder_q)
ao_two_e_integral = ao_two_e_integral + coef4 * integral
enddo ! s
enddo ! r
enddo ! q
enddo ! p
else
do p = 1, 3
I_power(p) = ao_power(i,p)
J_power(p) = ao_power(j,p)
K_power(p) = ao_power(k,p)
L_power(p) = ao_power(l,p)
enddo
double precision :: ERI
do p = 1, ao_prim_num(i)
coef1 = ao_coef_normalized_ordered_transp(p,i)
do q = 1, ao_prim_num(j)
coef2 = coef1*ao_coef_normalized_ordered_transp(q,j)
do r = 1, ao_prim_num(k)
coef3 = coef2*ao_coef_normalized_ordered_transp(r,k)
do s = 1, ao_prim_num(l)
coef4 = coef3*ao_coef_normalized_ordered_transp(s,l)
integral = ERI( &
ao_expo_ordered_transp(p,i),ao_expo_ordered_transp(q,j),ao_expo_ordered_transp(r,k),ao_expo_ordered_transp(s,l),&
I_power(1),J_power(1),K_power(1),L_power(1), &
I_power(2),J_power(2),K_power(2),L_power(2), &
I_power(3),J_power(3),K_power(3),L_power(3))
ao_two_e_integral = ao_two_e_integral + coef4 * integral
enddo ! s
enddo ! r
enddo ! q
enddo ! p
endif
endif
endif
end
! ---
double precision function ao_two_e_integral_schwartz_accel(i,j,k,l)
implicit none
BEGIN_DOC
@ -420,14 +444,17 @@ BEGIN_PROVIDER [ logical, ao_two_e_integrals_in_map ]
END_PROVIDER
BEGIN_PROVIDER [ double precision, ao_two_e_integral_schwartz,(ao_num,ao_num) ]
implicit none
! ---
BEGIN_PROVIDER [ double precision, ao_two_e_integral_schwartz, (ao_num, ao_num) ]
BEGIN_DOC
! Needed to compute Schwartz inequalities
END_DOC
integer :: i,k
double precision :: ao_two_e_integral,cpu_1,cpu_2, wall_1, wall_2
implicit none
integer :: i, k
double precision :: ao_two_e_integral,cpu_1,cpu_2, wall_1, wall_2
ao_two_e_integral_schwartz(1,1) = ao_two_e_integral(1,1,1,1)
!$OMP PARALLEL DO PRIVATE(i,k) &
@ -444,6 +471,7 @@ BEGIN_PROVIDER [ double precision, ao_two_e_integral_schwartz,(ao_num,ao_num) ]
END_PROVIDER
! ---
double precision function general_primitive_integral(dim, &
P_new,P_center,fact_p,p,p_inv,iorder_p, &
@ -575,7 +603,10 @@ double precision function general_primitive_integral(dim, &
!DIR$ FORCEINLINE
call multiply_poly(d_poly ,n_pt_tmp ,Iz_pol,n_Iz,d1,n_pt_out)
double precision :: rint_sum
accu = accu + rint_sum(n_pt_out,const,d1)
! print *, n_pt_out, d1(0:n_pt_out)
! print *, accu
general_primitive_integral = fact_p * fact_q * accu *pi_5_2*p_inv*q_inv/dsqrt(p+q)
end
@ -840,6 +871,15 @@ subroutine give_polynom_mult_center_x(P_center,Q_center,a_x,d_x,p,q,n_pt_in,pq_i
!DIR$ FORCEINLINE
call I_x1_pol_mult(a_x,d_x,B10,B01,B00,C00,D00,d,n_pt1,n_pt_in)
n_pt_out = n_pt1
! print *, ' '
! print *, a_x, d_x
! print *, B10, B01, B00, C00, D00
! print *, n_pt1, d(0:n_pt1)
! print *, ' '
if(n_pt1<0)then
n_pt_out = -1
do i = 0,n_pt_in

1
src/basis/EZFIO.cfg
View File

@ -72,4 +72,3 @@ doc: Exponents in the shell
size: (basis.prim_num)
interface: ezfio, provider

159
src/basis/basis.irp.f
View File

@ -1,67 +1,11 @@
BEGIN_PROVIDER [ double precision, shell_normalization_factor , (shell_num) ]
implicit none
BEGIN_DOC
! Number of primitives per |AO|
END_DOC
logical :: has
PROVIDE ezfio_filename
if (mpi_master) then
if (size(shell_normalization_factor) == 0) return
call ezfio_has_basis_shell_normalization_factor(has)
if (has) then
write(6,'(A)') '.. >>>>> [ IO READ: shell_normalization_factor ] <<<<< ..'
call ezfio_get_basis_shell_normalization_factor(shell_normalization_factor)
else
double precision :: norm,overlap_x,overlap_y,overlap_z,C_A(3), c
integer :: l, powA(3), nz
integer :: i,j,k
nz=100
C_A(1) = 0.d0
C_A(2) = 0.d0
C_A(3) = 0.d0
do i=1,shell_num
powA(1) = shell_ang_mom(i)
powA(2) = 0
powA(3) = 0
norm = 0.d0
do k=1, prim_num
if (shell_index(k) /= i) cycle
do j=1, prim_num
if (shell_index(j) /= i) cycle
call overlap_gaussian_xyz(C_A,C_A,prim_expo(j),prim_expo(k), &
powA,powA,overlap_x,overlap_y,overlap_z,c,nz)
norm = norm+c*prim_coef(j)*prim_coef(k) * prim_normalization_factor(j) * prim_normalization_factor(k)
enddo
enddo
shell_normalization_factor(i) = 1.d0/dsqrt(norm)
enddo
endif
endif
IRP_IF MPI_DEBUG
print *, irp_here, mpi_rank
call MPI_BARRIER(MPI_COMM_WORLD, ierr)
IRP_ENDIF
IRP_IF MPI
include 'mpif.h'
integer :: ierr
call MPI_BCAST( shell_normalization_factor, (shell_num), MPI_DOUBLE_PRECISION, 0, MPI_COMM_WORLD, ierr)
if (ierr /= MPI_SUCCESS) then
stop 'Unable to read shell_normalization_factor with MPI'
endif
IRP_ENDIF
call write_time(6)
BEGIN_PROVIDER [ integer, shell_prim_num_max ]
implicit none
BEGIN_DOC
! Max number of primitives.
END_DOC
shell_prim_num_max = maxval(shell_prim_num)
END_PROVIDER
BEGIN_PROVIDER [ double precision, prim_normalization_factor , (prim_num) ]
implicit none
BEGIN_DOC
@ -120,3 +64,94 @@ BEGIN_PROVIDER [ double precision, prim_normalization_factor , (prim_num) ]
call write_time(6)
END_PROVIDER
BEGIN_PROVIDER [ double precision, shell_coef , (shell_num, shell_prim_num_max) ]
&BEGIN_PROVIDER [ double precision, shell_expo , (shell_num, shell_prim_num_max) ]
implicit none
BEGIN_DOC
! Primitive coefficients and exponents for each shell.
END_DOC
integer :: i, idx
integer :: count(shell_num)
count(:) = 0
do i=1, prim_num
idx = shell_index(i)
count(idx) += 1
shell_coef(idx, count(idx)) = prim_coef(i)
shell_expo(idx, count(idx)) = prim_expo(i)
end do
END_PROVIDER
BEGIN_PROVIDER [ double precision, shell_coef_normalized, (shell_num,shell_prim_num_max) ]
&BEGIN_PROVIDER [ double precision, shell_normalization_factor, (shell_num) ]
implicit none
BEGIN_DOC
! Coefficients including the |shell| normalization
END_DOC
logical :: has
PROVIDE ezfio_filename
shell_normalization_factor(:) = 1.d0
if (mpi_master) then
if (size(shell_normalization_factor) == 0) return
call ezfio_has_basis_shell_normalization_factor(has)
if (has) then
write(6,'(A)') '.. >>>>> [ IO READ: shell_normalization_factor ] <<<<< ..'
call ezfio_get_basis_shell_normalization_factor(shell_normalization_factor)
endif
endif
IRP_IF MPI_DEBUG
print *, irp_here, mpi_rank
call MPI_BARRIER(MPI_COMM_WORLD, ierr)
IRP_ENDIF
IRP_IF MPI
include 'mpif.h'
integer :: ierr
call MPI_BCAST( shell_normalization_factor, (shell_num), MPI_DOUBLE_PRECISION, 0, MPI_COMM_WORLD, ierr)
if (ierr /= MPI_SUCCESS) then
stop 'Unable to read shell_normalization_factor with MPI'
endif
IRP_ENDIF
call write_time(6)
double precision :: norm,overlap_x,overlap_y,overlap_z,C_A(3), c
integer :: l, powA(3), nz
integer :: i,j,k
nz=100
C_A = 0.d0
powA = 0
shell_coef_normalized = 0.d0
do i=1,shell_num
powA(1) = shell_ang_mom(i)
! Normalization of the primitives
if (primitives_normalized) then
do j=1,shell_prim_num(i)
call overlap_gaussian_xyz(C_A,C_A,shell_expo(i,j),shell_expo(i,j), &
powA,powA,overlap_x,overlap_y,overlap_z,norm,nz)
shell_coef_normalized(i,j) = shell_coef(i,j)/dsqrt(norm)
enddo
else
do j=1,shell_prim_num(i)
shell_coef_normalized(i,j) = shell_coef(i,j)
enddo
endif
! Normalization of the contracted basis functions
norm = 0.d0
do j=1,shell_prim_num(i)
do k=1,shell_prim_num(i)
call overlap_gaussian_xyz(C_A,C_A,shell_expo(i,j),shell_expo(i,k),powA,powA,overlap_x,overlap_y,overlap_z,c,nz)
norm = norm+c*shell_coef_normalized(i,j)*shell_coef_normalized(i,k)
enddo
enddo
shell_normalization_factor(i) *= 1.d0/dsqrt(norm)
enddo
END_PROVIDER

57
src/basis_correction/pbe_ueg_self_contained.irp.f Normal file
View File

@ -0,0 +1,57 @@
double precision function ecmd_pbe_ueg_self_cont(dens,spin_pol,mu,e_PBE)
implicit none
! dens = total density
! spin_pol = spin_polarization (n_a - n_b)/dens
! e_PBE = PBE correlation (mu=0) energy evaluated at dens,spin_pol (and grad_rho)
! e_PBE = epsilon_PBE * dens which means that it is not the energy density but the energy density X the density
double precision, intent(in) :: dens,spin_pol,mu,e_PBE
double precision :: rho_a,rho_b,pi,g0_UEG_func,denom,beta
pi = dacos(-1.d0)
rho_a = (dens * spin_pol + dens)*0.5d0
rho_b = (dens - dens * spin_pol)*0.5d0
if(mu == 0.d0) then
ecmd_pbe_ueg_self_cont = e_PBE
else
! note: the on-top pair density is (1-zeta^2) rhoc^2 g0 = 4 rhoa * rhob * g0
denom = (-2.d0+sqrt(2d0))*sqrt(2.d0*pi) * 4.d0*rho_a*rho_b*g0_UEG_func(rho_a,rho_b)
if (dabs(denom) > 1.d-12) then
beta = (3.d0*e_PBE)/denom
ecmd_pbe_ueg_self_cont=e_PBE/(1.d0+beta*mu**3)
else
ecmd_pbe_ueg_self_cont=0.d0
endif
endif
end
double precision function g0_UEG_func(rho_a,rho_b)
! Pair distribution function g0(n_alpha,n_beta) of the Colombic UEG
!
! Taken from Eq. (46) P. Gori-Giorgi and A. Savin, Phys. Rev. A 73, 032506 (2006).
implicit none
double precision, intent(in) :: rho_a,rho_b
double precision :: rho,pi,x
double precision :: B, C, D, E, d2, rs, ahd
rho = rho_a+rho_b
pi = 4d0 * datan(1d0)
ahd = -0.36583d0
d2 = 0.7524d0
B = -2d0 * ahd - d2
C = 0.08193d0
D = -0.01277d0
E = 0.001859d0
x = -d2*rs
if (dabs(rho) > 1.d-20) then
rs = (3d0 / (4d0*pi*rho))**(1d0/3d0)
x = -d2*rs
if(dabs(x).lt.50.d0)then
g0_UEG_func= 0.5d0 * (1d0+ rs* (-B + rs*(C + rs*(D + rs*E))))*dexp(x)
else
g0_UEG_func= 0.d0
endif
else
g0_UEG_func= 0.d0
endif
g0_UEG_func = max(g0_UEG_func,1.d-14)
end

63
src/basis_correction/print_routine.irp.f
View File

@ -38,7 +38,7 @@ 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_ful")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 '
@ -80,3 +80,64 @@ subroutine print_basis_correction
end
subroutine print_all_basis_correction
implicit none
integer :: istate
provide mu_average_prov
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
print*, ''
print*, ''
print*, '****************************************'
print*, '****************************************'
print*, 'Basis set correction for WFT using DFT Ecmd functionals'
print*, 'These functionals are accurate for short-range correlation'
print*, ''
print*, 'For more details look at Journal of Chemical Physics 149, 194301 1-15 (2018) '
print*, ' Journal of Physical Chemistry Letters 10, 2931-2937 (2019) '
print*, ' ???REF SC?'
print*, '****************************************'
print*, '****************************************'
print*, 'mu_of_r_potential = ',mu_of_r_potential
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*,'********************************************'
print*,'Functionals more suited for weak correlation'
print*,'********************************************'
print*,'+) LDA Ecmd functional : purely based on the UEG (JCP,149,194301,1-15 (2018)) '
do istate = 1, N_states
write(*, '(A29,X,I3,X,A3,X,F16.10)') ' ECMD LDA , state ',istate,' = ',ecmd_lda_mu_of_r(istate)
enddo
print*,'+) PBE-UEG Ecmd functional : PBE at mu=0, UEG ontop pair density at large mu (JPCL, 10, 2931-2937 (2019))'
do istate = 1, N_states
write(*, '(A29,X,I3,X,A3,X,F16.10)') ' ECMD PBE-UEG , state ',istate,' = ',ecmd_pbe_ueg_mu_of_r(istate)
enddo
print*,''
print*,'********************************************'
print*,'********************************************'
print*,'+) PBE-on-top Ecmd functional : (??????? REF-SCF ??????????)'
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 : (??????? REF-SCF ??????????)'
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)
enddo
print*,''
print*,''
print*,'**************'
do istate = 1, N_states
write(*, '(A29,X,I3,X,A3,X,F16.10)') ' Average mu(r) , state ',istate,' = ',mu_average_prov(istate)
enddo
end

7
src/basis_correction/print_su_pbe_ot.irp.f
View File

@ -20,9 +20,10 @@ subroutine print_su_pbe_ot
integer :: istate
do istate = 1, N_states
write(*, '(A29,X,I3,X,A3,X,F16.10)') ' ECMD PBE-UEG , state ',istate,' = ',ecmd_pbe_ueg_mu_of_r(istate)
write(*, '(A29,X,I3,X,A3,X,F16.10)') ' ecmd_pbe_ueg_test , state ',istate,' = ',ecmd_pbe_ueg_test(istate)
enddo
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)
enddo
! 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)
! enddo
end

84
src/basis_correction/test_ueg_self_contained.irp.f Normal file
View File

@ -0,0 +1,84 @@
program test_sc
implicit none
integer :: m
double precision :: r(3),f_hf,on_top,mu,sqpi
double precision :: rho_a,rho_b,w_hf,dens,delta_rho,e_pbe
double precision :: grad_rho_a(3),grad_rho_b(3),grad_rho_a_2(3),grad_rho_b_2(3),grad_rho_a_b(3)
double precision :: sigmacc,sigmaco,sigmaoo,spin_pol
double precision :: eps_c_md_PBE , ecmd_pbe_ueg_self_cont
r = 0.D0
r(3) = 1.D0
call f_HF_valence_ab(r,r,f_hf,on_top)
sqpi = dsqrt(dacos(-1.d0))
if(on_top.le.1.d-12.or.f_hf.le.0.d0.or.f_hf * on_top.lt.0.d0)then
w_hf = 1.d+10
else
w_hf = f_hf / on_top
endif
mu = sqpi * 0.5d0 * w_hf
call density_and_grad_alpha_beta(r,rho_a,rho_b, grad_rho_a, grad_rho_b)
dens = rho_a + rho_b
delta_rho = rho_a - rho_b
spin_pol = delta_rho/(max(1.d-10,dens))
grad_rho_a_2 = 0.d0
grad_rho_b_2 = 0.d0
grad_rho_a_b = 0.d0
do m = 1, 3
grad_rho_a_2 += grad_rho_a(m)*grad_rho_a(m)
grad_rho_b_2 += grad_rho_b(m)*grad_rho_b(m)
grad_rho_a_b += grad_rho_a(m)*grad_rho_b(m)
enddo
call grad_rho_ab_to_grad_rho_oc(grad_rho_a_2,grad_rho_b_2,grad_rho_a_b,sigmaoo,sigmacc,sigmaco)
! call the PBE energy
print*,'f_hf,on_top = ',f_hf,on_top
print*,'mu = ',mu
print*,'dens,spin_pol',dens,spin_pol
call ec_pbe_only(0.d0,dens,delta_rho,sigmacc,sigmaco,sigmaoo,e_PBE)
print*,'e_PBE = ',e_PBE
eps_c_md_PBE = ecmd_pbe_ueg_self_cont(dens,spin_pol,mu,e_PBE)
print*,'eps_c_md_PBE = ',eps_c_md_PBE
print*,''
print*,''
print*,''
print*,'energy_c' ,energy_c
integer::ipoint
double precision :: weight , accu
accu = 0.d0
do ipoint = 1, n_points_final_grid
r = final_grid_points(:,ipoint)
weight = final_weight_at_r_vector(ipoint)
call f_HF_valence_ab(r,r,f_hf,on_top)
sqpi = dsqrt(dacos(-1.d0))
if(on_top.le.1.d-12.or.f_hf.le.0.d0.or.f_hf * on_top.lt.0.d0)then
w_hf = 1.d+10
else
w_hf = f_hf / on_top
endif
mu = sqpi * 0.5d0 * w_hf
call density_and_grad_alpha_beta(r,rho_a,rho_b, grad_rho_a, grad_rho_b)
dens = rho_a + rho_b
delta_rho = rho_a - rho_b
spin_pol = delta_rho/(max(1.d-10,dens))
grad_rho_a_2 = 0.d0
grad_rho_b_2 = 0.d0
grad_rho_a_b = 0.d0
do m = 1, 3
grad_rho_a_2 += grad_rho_a(m)*grad_rho_a(m)
grad_rho_b_2 += grad_rho_b(m)*grad_rho_b(m)
grad_rho_a_b += grad_rho_a(m)*grad_rho_b(m)
enddo
call grad_rho_ab_to_grad_rho_oc(grad_rho_a_2,grad_rho_b_2,grad_rho_a_b,sigmaoo,sigmacc,sigmaco)
! call the PBE energy
call ec_pbe_only(0.d0,dens,delta_rho,sigmacc,sigmaco,sigmaoo,e_PBE)
eps_c_md_PBE = ecmd_pbe_ueg_self_cont(dens,spin_pol,mu,e_PBE)
write(33,'(100(F16.10,X))')r(:), weight, w_hf, on_top, mu, dens, spin_pol, e_PBE, eps_c_md_PBE
accu += weight * eps_c_md_PBE
enddo
print*,'accu = ',accu
write(*, *) ' ECMD PBE-UEG ',ecmd_pbe_ueg_mu_of_r(1)
write(*, *) ' ecmd_pbe_ueg_test ',ecmd_pbe_ueg_test(1)
end

51
src/basis_correction/weak_corr_func.irp.f
View File

@ -81,3 +81,54 @@ BEGIN_PROVIDER [double precision, ecmd_pbe_ueg_mu_of_r, (N_states)]
print*,'Time for the ecmd_pbe_ueg_mu_of_r:',wall1-wall0
END_PROVIDER
BEGIN_PROVIDER [double precision, ecmd_pbe_ueg_test, (N_states)]
BEGIN_DOC
! test of the routines contained in pbe_ueg_self_contained.irp.f
END_DOC
implicit none
double precision :: weight
integer :: ipoint,istate,m
double precision :: mu,rho_a,rho_b
double precision :: dens,spin_pol,grad_rho,e_PBE,delta_rho
double precision :: ecmd_pbe_ueg_self_cont,eps_c_md_PBE
ecmd_pbe_ueg_test = 0.d0
do istate = 1, N_states
do ipoint = 1, n_points_final_grid
weight=final_weight_at_r_vector(ipoint)
! mu(r) defined by Eq. (37) of J. Chem. Phys. 149, 194301 (2018)
mu = mu_of_r_prov(ipoint,istate)
! conversion from rho_a,rho_b --> dens,spin_pol
rho_a = one_e_dm_and_grad_alpha_in_r(4,ipoint,istate)
rho_b = one_e_dm_and_grad_beta_in_r(4,ipoint,istate)
dens = rho_a + rho_b
spin_pol = (rho_a - rho_b)/(max(dens,1.d-12))
delta_rho = rho_a - rho_b
! conversion from grad_rho_a ... to sigma
double precision :: grad_rho_a(3),grad_rho_b(3),grad_rho_a_2(3),grad_rho_b_2(3),grad_rho_a_b(3)
double precision :: sigmacc,sigmaco,sigmaoo
grad_rho_b(1:3) = one_e_dm_and_grad_beta_in_r(1:3,ipoint,istate)
grad_rho_a(1:3) = one_e_dm_and_grad_alpha_in_r(1:3,ipoint,istate)
grad_rho_a_2 = 0.d0
grad_rho_b_2 = 0.d0
grad_rho_a_b = 0.d0
do m = 1, 3
grad_rho_a_2 += grad_rho_a(m)*grad_rho_a(m)
grad_rho_b_2 += grad_rho_b(m)*grad_rho_b(m)
grad_rho_a_b += grad_rho_a(m)*grad_rho_b(m)
enddo
call grad_rho_ab_to_grad_rho_oc(grad_rho_a_2,grad_rho_b_2,grad_rho_a_b,sigmaoo,sigmacc,sigmaco)
! call the PBE energy
call ec_pbe_only(0.d0,dens,delta_rho,sigmacc,sigmaco,sigmaoo,e_PBE)
eps_c_md_PBE = ecmd_pbe_ueg_self_cont(dens,spin_pol,mu,e_PBE)
ecmd_pbe_ueg_test(istate) += eps_c_md_PBE * weight
enddo
enddo
!
END_PROVIDER

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

@ -64,7 +64,8 @@ END_PROVIDER
END_PROVIDER
BEGIN_PROVIDER [double precision, grid_points_per_atom, (3,n_points_integration_angular,n_points_radial_grid,nucl_num)]
BEGIN_PROVIDER [double precision, grid_points_per_atom, (3,n_points_integration_angular,n_points_radial_grid,nucl_num)]
&BEGIN_PROVIDER [double precision, radial_points_per_atom, (n_points_radial_grid,nucl_num)]
BEGIN_DOC
! x,y,z coordinates of grid points used for integration in 3d space
END_DOC
@ -72,6 +73,7 @@ BEGIN_PROVIDER [double precision, grid_points_per_atom, (3,n_points_integration_
integer :: i,j,k
double precision :: dr,x_ref,y_ref,z_ref
double precision :: knowles_function
radial_points_per_atom = 0.D0
do i = 1, nucl_num
x_ref = nucl_coord(i,1)
y_ref = nucl_coord(i,2)
@ -83,7 +85,7 @@ BEGIN_PROVIDER [double precision, grid_points_per_atom, (3,n_points_integration_
! value of the radial coordinate for the integration
r = knowles_function(alpha_knowles(grid_atomic_number(i)),m_knowles,x)
radial_points_per_atom(j,i) = r
! explicit values of the grid points centered around each atom
do k = 1, n_points_integration_angular
grid_points_per_atom(1,k,j,i) = &

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

@ -58,17 +58,3 @@ END_PROVIDER
enddo
END_PROVIDER
BEGIN_PROVIDER [double precision, final_grid_points_transp, (n_points_final_grid,3)]
implicit none
BEGIN_DOC
! Transposed final_grid_points
END_DOC
integer :: i,j
do j=1,3
do i=1,n_points_final_grid
final_grid_points_transp(i,j) = final_grid_points(j,i)
enddo
enddo
END_PROVIDER

3
src/bi_ort_ints/NEED Normal file
View File

@ -0,0 +1,3 @@
non_h_ints_mu
ao_tc_eff_map
bi_ortho_mos

25
src/bi_ort_ints/README.rst Normal file
View File

@ -0,0 +1,25 @@
===========
bi_ort_ints
===========
This module contains all necessary integrals for the TC Hamiltonian in a bi-orthonormal (BO) MO Basis.
See in bi_ortho_basis for more information.
The main providers are :
One-electron integrals
----------------------
+) ao_one_e_integrals_tc_tot : total one-electron Hamiltonian which might include non hermitian part coming from one-e correlation factor.
+) mo_bi_ortho_tc_one_e : one-electron Hamiltonian (h_core+one-J terms) on the BO-MO basis.
+) mo_bi_orth_bipole_x : x-component of the dipole operator on the BO-MO basis. (Same for y,z)
Two-electron integrals
----------------------
+) ao_two_e_tc_tot : Total two-electron operator (including the non-hermitian term of the TC Hamiltonian) on the AO basis
+) mo_bi_ortho_tc_two_e : Total two-electron operator on the BO-MO basis
Three-electron integrals
------------------------
+) three_body_ints_bi_ort : 6-indices three-electron tensor (-L) on the BO-MO basis. WARNING :: N^6 storage !
+) three_e_3_idx_direct_bi_ort : DIRECT term with 3 different indices of the -L operator. These terms appear in the DIAGONAL matrix element of the -L operator. The 5 other permutations needed to compute matrix elements can be found in three_body_ijm.irp.f
+) three_e_4_idx_direct_bi_ort : DIRECT term with 4 different indices of the -L operator. These terms appear in the OFF-DIAGONAL matrix element of the -L operator including SINGLE EXCITATIONS. The 5 other permutations needed to compute matrix elements can be found in three_body_ijmk.irp.f
+) three_e_5_idx_direct_bi_ort : DIRECT term with 5 different indices of the -L operator. These terms appear in the OFF-DIAGONAL matrix element of the -L operator including DOUBLE EXCITATIONS. The 5 other permutations needed to compute matrix elements can be found in three_body_ijmkl.irp.f

21
src/bi_ort_ints/bi_ort_ints.irp.f Normal file
View File

@ -0,0 +1,21 @@
program bi_ort_ints
implicit none
BEGIN_DOC
! TODO : Put the documentation of the program here
END_DOC
my_grid_becke = .True.
my_n_pt_r_grid = 30
my_n_pt_a_grid = 50
touch my_grid_becke my_n_pt_r_grid my_n_pt_a_grid
! call test_overlap
! call routine_twoe
! call routine_onee
! call test_v_ki_bi_ortho
! call test_x_v_ki_bi_ortho
! call test_3_body_bi_ort
! call test_3_e_diag
! call test_3_e_diag_cycle1
! call test_3_e
! call routine_test_one_int
end

70
src/bi_ort_ints/one_e_bi_ort.irp.f Normal file
View File

@ -0,0 +1,70 @@
! ---
BEGIN_PROVIDER [double precision, ao_one_e_integrals_tc_tot, (ao_num,ao_num)]
implicit none
integer :: i, j
ao_one_e_integrals_tc_tot = ao_one_e_integrals
provide j1b_gauss
if(j1b_gauss .eq. 1) then
do i = 1, ao_num
do j = 1, ao_num
ao_one_e_integrals_tc_tot(j,i) += ( j1b_gauss_hermI (j,i) &
+ j1b_gauss_hermII (j,i) &
+ j1b_gauss_nonherm(j,i) )
enddo
enddo
endif
END_PROVIDER
BEGIN_PROVIDER [ double precision, mo_bi_ortho_tc_one_e, (mo_num, mo_num)]
implicit none
BEGIN_DOC
! mo_bi_ortho_tc_one_e(k,i) = <MO^L_k | h_c | MO^R_i>
END_DOC
integer :: i,k,p,q
call ao_to_mo_bi_ortho(ao_one_e_integrals_tc_tot, ao_num, mo_bi_ortho_tc_one_e, mo_num)
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 MO_i * x MO_j
! array of the integrals of MO_i * y MO_j
! array of the integrals of MO_i * z MO_j
END_DOC
implicit none
call ao_to_mo_bi_ortho( &
ao_dipole_x, &
size(ao_dipole_x,1), &
mo_bi_orth_bipole_x, &
size(mo_bi_orth_bipole_x,1) &
)
call ao_to_mo_bi_ortho( &
ao_dipole_y, &
size(ao_dipole_y,1), &
mo_bi_orth_bipole_y, &
size(mo_bi_orth_bipole_y,1) &
)
call ao_to_mo_bi_ortho( &
ao_dipole_z, &
size(ao_dipole_z,1), &
mo_bi_orth_bipole_z, &
size(mo_bi_orth_bipole_z,1) &
)
END_PROVIDER

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