LCPQ
/
qp2
mirror of https://github.com/QuantumPackage/qp2.git
9
1
Fork 0
Code Releases Activity

Merge branch 'AbdAmmar-dev' into cleaning_dft

This commit is contained in:
eginer 2022-09-30 15:27:55 +02:00
parent 2a99a0709a 49acd2e2bf
commit 7c1c761ea8
143 changed files with 7327 additions and 3507 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

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()

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

19
ocaml/Command_line.ml
View File

@ -1,5 +1,3 @@
exception Error of string
type short_opt = char
type long_opt = string
type optional = Mandatory | Optional
@ -183,16 +181,15 @@ let set_specs specs_in =
Getopt.parse_cmdline cmd_specs (fun x -> anon_args := !anon_args @ [x]);
if show_help () then
help ()
else
(* Check that all mandatory arguments are set *)
List.filter (fun x -> x.short <> ' ' && x.opt = Mandatory) !specs
|> List.iter (fun x ->
match get x.long with
| Some _ -> ()
| None -> raise (Error ("--"^x.long^" option is missing."))
)
(help () ; exit 0);
(* Check that all mandatory arguments are set *)
List.filter (fun x -> x.short <> ' ' && x.opt = Mandatory) !specs
|> List.iter (fun x ->
match get x.long with
| Some _ -> ()
| None -> failwith ("Error: --"^x.long^" option is missing.")
)
;;

2
ocaml/Command_line.mli
View File

@ -59,8 +59,6 @@ let () =
*)
exception Error of string
type short_opt = char
type long_opt = string

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

4
ocaml/Molecule.ml
View File

@ -101,7 +101,7 @@ let to_string_general ~f m =
|> String.concat "\n"
let to_string =
to_string_general ~f:(fun x -> Atom.to_string ~units:Units.Angstrom x)
to_string_general ~f:(fun x -> Atom.to_string Units.Angstrom x)
let to_xyz =
to_string_general ~f:Atom.to_xyz
@ -113,7 +113,7 @@ let of_xyz_string
s =
let l = String_ext.split s ~on:'\n'
|> List.filter (fun x -> x <> "")
|> list_map (fun x -> Atom.of_string ~units x)
|> list_map (fun x -> Atom.of_string units x)
in
let ne = ( get_charge {
nuclei=l ;

4
ocaml/Qputils.ml
View File

@ -56,7 +56,3 @@ let string_of_string s = s
let list_map f l =
List.rev_map f l
|> List.rev
let socket_convert socket =
((Obj.magic (Obj.repr socket)) : [ `Xsub ] Zmq.Socket.t )

97
ocaml/qp_create_ezfio.ml
View File

@ -91,7 +91,7 @@ let run ?o b au c d m p cart xyz_file =
| Element e -> Element.to_string e
| Int_elem (i,e) -> Printf.sprintf "%d,%s" (Nucl_number.to_int i) (Element.to_string e)
in
Hashtbl.find basis_table key
Hashtbl.find basis_table key
in
let temp_filename =
@ -132,7 +132,7 @@ let run ?o b au c d m p cart xyz_file =
Element.to_string elem.Atom.element
in
Hashtbl.add basis_table key new_channel
) nuclei
) nuclei
end
| Some (key, basis) -> (*Aux basis *)
begin
@ -277,16 +277,6 @@ let run ?o b au c d m p cart xyz_file =
) nuclei
in
let z_core =
List.map (fun x ->
Positive_int.to_int x.Pseudo.n_elec
|> float_of_int
) pseudo
in
let nucl_num = (List.length z_core) in
Ezfio.set_pseudo_nucl_charge_remove (Ezfio.ezfio_array_of_list
~rank:1 ~dim:[| nucl_num |] ~data:z_core);
let molecule =
let n_elec_to_remove =
List.fold_left (fun accu x ->
@ -303,13 +293,13 @@ let run ?o b au c d m p cart xyz_file =
Molecule.nuclei =
let charges =
list_map (fun x -> Positive_int.to_int x.Pseudo.n_elec
|> Float.of_int) pseudo
|> Float.of_int) pseudo
|> Array.of_list
in
List.mapi (fun i x ->
{ x with Atom.charge = (Charge.to_float x.Atom.charge) -. charges.(i)
|> Charge.of_float }
) molecule.Molecule.nuclei
) molecule.Molecule.nuclei
}
in
let nuclei =
@ -366,11 +356,11 @@ let run ?o b au c d m p cart xyz_file =
in
if (x > accu) then x
else accu
) 0 x.Pseudo.non_local
) 0 x.Pseudo.non_local
in
if (x > accu) then x
else accu
) 0 pseudo
) 0 pseudo
in
let kmax =
@ -378,10 +368,10 @@ let run ?o b au c d m p cart xyz_file =
list_map (fun x ->
List.filter (fun (y,_) ->
(Positive_int.to_int y.Pseudo.GaussianPrimitive_non_local.proj) = i)
x.Pseudo.non_local
|> List.length ) pseudo
x.Pseudo.non_local
|> List.length ) pseudo
|> List.fold_left (fun accu x ->
if accu > x then accu else x) 0
if accu > x then accu else x) 0
)
|> Array.fold_left (fun accu i ->
if i > accu then i else accu) 0
@ -406,11 +396,11 @@ let run ?o b au c d m p cart xyz_file =
in
tmp_array_dz_k.(i).(j) <- y;
tmp_array_n_k.(i).(j) <- z;
) x.Pseudo.local
) x.Pseudo.local
) pseudo ;
let concat_2d tmp_array =
let data =
Array.map Array.to_list tmp_array
Array.map Array.to_list tmp_array
|> Array.to_list
|> List.concat
in
@ -448,14 +438,14 @@ let run ?o b au c d m p cart xyz_file =
tmp_array_dz_kl.(k).(i).(j) <- y;
tmp_array_n_kl.(k).(i).(j) <- z;
last_idx.(k) <- i+1;
) x.Pseudo.non_local
) x.Pseudo.non_local
) pseudo ;
let concat_3d tmp_array =
let data =
Array.map (fun x ->
Array.map Array.to_list x
|> Array.to_list
|> List.concat) tmp_array
|> List.concat) tmp_array
|> Array.to_list
|> List.concat
in
@ -523,8 +513,8 @@ let run ?o b au c d m p cart xyz_file =
Ezfio.set_ao_basis_ao_num ao_num;
Ezfio.set_ao_basis_ao_basis b;
Ezfio.set_basis_basis b;
let ao_prim_num = list_map (fun (_,g,_) -> List.length g.Gto.lc) long_basis
and ao_nucl = list_map (fun (_,_,n) -> Nucl_number.to_int n) long_basis
let ao_prim_num = list_map (fun (_,g,_) -> List.length g.Gto.lc) long_basis
and ao_nucl = list_map (fun (_,_,n) -> Nucl_number.to_int n) long_basis
and ao_power=
let l = list_map (fun (x,_,_) -> x) long_basis in
(list_map (fun t -> Positive_int.to_int Angmom.Xyz.(t.x)) l)@
@ -536,7 +526,7 @@ let run ?o b au c d m p cart xyz_file =
else s) 0 ao_prim_num
in
let gtos =
list_map (fun (_,x,_) -> x) long_basis
list_map (fun (_,x,_) -> x) long_basis
in
let create_expo_coef ec =
@ -544,10 +534,10 @@ let run ?o b au c d m p cart xyz_file =
begin match ec with
| `Coefs -> list_map (fun x->
list_map (fun (_,coef) ->
AO_coef.to_float coef) x.Gto.lc) gtos
AO_coef.to_float coef) x.Gto.lc) gtos
| `Expos -> list_map (fun x->
list_map (fun (prim,_) -> AO_expo.to_float
prim.GaussianPrimitive.expo) x.Gto.lc) gtos
prim.GaussianPrimitive.expo) x.Gto.lc) gtos
end
in
let rec get_n n accu = function
@ -577,7 +567,7 @@ let run ?o b au c d m p cart xyz_file =
list_map ( fun (g,_) -> g.Gto.lc ) basis
in
let ang_mom =
list_map (fun (l : (GaussianPrimitive.t * Qptypes.AO_coef.t) list) ->
list_map (fun (l : (GaussianPrimitive.t * Qptypes.AO_coef.t) list) ->
let x, _ = List.hd l in
Angmom.to_l x.GaussianPrimitive.sym |> Qptypes.Positive_int.to_int
) lc
@ -587,7 +577,7 @@ let run ?o b au c d m p cart xyz_file =
|> List.concat
in
let coef =
list_map (fun l ->
list_map (fun l ->
list_map (fun (_,x) -> Qptypes.AO_coef.to_float x) l
) lc
|> List.concat
@ -595,16 +585,12 @@ let run ?o b au c d m p cart xyz_file =
let shell_prim_num =
list_map List.length lc
in
let shell_idx =
let rec make_list n accu = function
| 0 -> accu
| i -> make_list n (n :: accu) (i-1)
in
let shell_prim_idx =
let rec aux count accu = function
| [] -> List.rev accu
| l::rest ->
let new_l = make_list count accu (List.length l) in
aux (count+1) new_l rest
let newcount = count+(List.length l) in
aux newcount (count::accu) rest
in
aux 1 [] lc
in
@ -616,18 +602,26 @@ let run ?o b au c d m p cart xyz_file =
~rank:1 ~dim:[| shell_num |] ~data:shell_prim_num);
Ezfio.set_basis_shell_ang_mom (Ezfio.ezfio_array_of_list
~rank:1 ~dim:[| shell_num |] ~data:ang_mom ) ;
Ezfio.set_basis_shell_index (Ezfio.ezfio_array_of_list
~rank:1 ~dim:[| prim_num |] ~data:shell_idx) ;
Ezfio.set_basis_shell_prim_index (Ezfio.ezfio_array_of_list
~rank:1 ~dim:[| shell_num |] ~data:shell_prim_idx) ;
Ezfio.set_basis_basis_nucleus_index (Ezfio.ezfio_array_of_list
~rank:1 ~dim:[| shell_num |]
~data:( list_map (fun (_,n) -> Nucl_number.to_int n) basis)
) ;
~rank:1 ~dim:[| nucl_num |]
~data:(
list_map (fun (_,n) -> Nucl_number.to_int n) basis
|> List.fold_left (fun accu i ->
match accu with
| [] -> []
| (h,j) :: rest -> if j == i then ((h+1,j)::rest) else ((h+1,i)::(h+1,j)::rest)
) [(0,0)]
|> List.rev
|> List.map fst
)) ;
Ezfio.set_basis_nucleus_shell_num(Ezfio.ezfio_array_of_list
~rank:1 ~dim:[| nucl_num |]
~data:(
list_map (fun (_,n) -> Nucl_number.to_int n) basis
|> List.fold_left (fun accu i ->
match accu with
|> List.fold_left (fun accu i ->
match accu with
| [] -> [(1,i)]
| (h,j) :: rest -> if j == i then ((h+1,j)::rest) else ((1,i)::(h,j)::rest)
) []
@ -677,7 +671,6 @@ let run ?o b au c d m p cart xyz_file =
let () =
try (
let open Command_line in
begin
@ -724,7 +717,7 @@ If a file with the same name as the basis set exists, this file will be read. O
anonymous "FILE" Mandatory "Input file in xyz format or z-matrix.";
]
|> set_specs
|> set_specs
end;
@ -735,7 +728,7 @@ If a file with the same name as the basis set exists, this file will be read. O
let basis =
match Command_line.get "basis" with
| None -> ""
| None -> assert false
| Some x -> x
in
@ -748,7 +741,7 @@ If a file with the same name as the basis set exists, this file will be read. O
| None -> 0
| Some x -> ( if x.[0] = 'm' then
~- (int_of_string (String.sub x 1 (String.length x - 1)))
else
else
int_of_string x )
in
@ -774,14 +767,10 @@ If a file with the same name as the basis set exists, this file will be read. O
let xyz_filename =
match Command_line.anon_args () with
| [] -> failwith "input file is missing"
| x::_ -> x
| [x] -> x
| _ -> (Command_line.help () ; failwith "input file is missing")
in
run ?o:output basis au charge dummy multiplicity pseudo cart xyz_filename
)
with
| Failure txt -> Printf.eprintf "Fatal error: %s\n%!" txt
| Command_line.Error txt -> Printf.eprintf "Command line error: %s\n%!" txt

2
ocaml/qp_run.ml
View File

@ -110,7 +110,7 @@ let run slave ?prefix exe ezfio_file =
let task_thread =
let thread =
Thread.create ( fun () ->
TaskServer.run ~port:port_number )
TaskServer.run port_number )
in
thread ();
in

131
ocaml/qp_tunnel.ml
View File

@ -2,7 +2,7 @@ open Qputils
open Qptypes
type ezfio_or_address = EZFIO of string | ADDRESS of string
type req_or_sub = REQ | SUB
type req_or_sub = REQ | SUB
let localport = 42379
@ -29,7 +29,7 @@ let () =
end;
let arg =
let x =
let x =
match Command_line.anon_args () with
| [x] -> x
| _ -> begin
@ -44,7 +44,7 @@ let () =
in
let localhost =
let localhost =
Lazy.force TaskServer.ip_address
in
@ -52,28 +52,28 @@ let () =
let long_address =
match arg with
| ADDRESS x -> x
| EZFIO x ->
let ic =
| EZFIO x ->
let ic =
Filename.concat (Qpackage.ezfio_work x) "qp_run_address"
|> open_in
in
let result =
let result =
input_line ic
|> String.trim
in
close_in ic;
result
in
let protocol, address, port =
match String.split_on_char ':' long_address with
| t :: a :: p :: [] -> t, a, int_of_string p
| _ -> failwith @@
| _ -> failwith @@
Printf.sprintf "%s : Malformed address" long_address
in
let zmq_context =
let zmq_context =
Zmq.Context.create ()
in
@ -105,10 +105,10 @@ let () =
let create_socket sock_type bind_or_connect addr =
let socket =
let socket =
Zmq.Socket.create zmq_context sock_type
in
let () =
let () =
try
bind_or_connect socket addr
with
@ -131,64 +131,37 @@ let () =
Sys.set_signal Sys.sigint handler;
let new_thread_req addr_in addr_out =
let new_thread req_or_sub addr_in addr_out =
let socket_in, socket_out =
match req_or_sub with
| REQ ->
create_socket Zmq.Socket.router Zmq.Socket.bind addr_in,
create_socket Zmq.Socket.dealer Zmq.Socket.connect addr_out
in
let action_in =
fun () -> Zmq.Socket.recv_all socket_in |> Zmq.Socket.send_all socket_out
in
let action_out =
fun () -> Zmq.Socket.recv_all socket_out |> Zmq.Socket.send_all socket_in
in
let pollitem =
Zmq.Poll.mask_of
[| (socket_convert socket_in, Zmq.Poll.In) ; (socket_convert socket_out, Zmq.Poll.In) |]
in
while !run_status do
let polling =
Zmq.Poll.poll ~timeout:1000 pollitem
in
match polling with
| [| Some Zmq.Poll.In ; Some Zmq.Poll.In |] -> ( action_out () ; action_in () )
| [| _ ; Some Zmq.Poll.In |] -> action_out ()
| [| Some Zmq.Poll.In ; _ |] -> action_in ()
| _ -> ()
done;
Zmq.Socket.close socket_in;
Zmq.Socket.close socket_out;
in
let new_thread_sub addr_in addr_out =
let socket_in, socket_out =
| SUB ->
create_socket Zmq.Socket.sub Zmq.Socket.connect addr_in,
create_socket Zmq.Socket.pub Zmq.Socket.bind addr_out
in
Zmq.Socket.subscribe socket_in "";
if req_or_sub = SUB then
Zmq.Socket.subscribe socket_in "";
let action_in =
fun () -> Zmq.Socket.recv_all socket_in |> Zmq.Socket.send_all socket_out
let action_in =
match req_or_sub with
| REQ -> (fun () -> Zmq.Socket.recv_all socket_in |> Zmq.Socket.send_all socket_out)
| SUB -> (fun () -> Zmq.Socket.recv_all socket_in |> Zmq.Socket.send_all socket_out)
in
let action_out =
fun () -> ()
let action_out =
match req_or_sub with
| REQ -> (fun () -> Zmq.Socket.recv_all socket_out |> Zmq.Socket.send_all socket_in )
| SUB -> (fun () -> () )
in
let pollitem =
Zmq.Poll.mask_of
[| (socket_convert socket_in, Zmq.Poll.In) ; (socket_convert socket_out, Zmq.Poll.In) |]
[| (socket_in, Zmq.Poll.In) ; (socket_out, Zmq.Poll.In) |]
in
@ -200,8 +173,8 @@ let () =
match polling with
| [| Some Zmq.Poll.In ; Some Zmq.Poll.In |] -> ( action_out () ; action_in () )
| [| _ ; Some Zmq.Poll.In |] -> action_out ()
| [| Some Zmq.Poll.In ; _ |] -> action_in ()
| [| _ ; Some Zmq.Poll.In |] -> action_out ()
| [| Some Zmq.Poll.In ; _ |] -> action_in ()
| _ -> ()
done;
@ -220,8 +193,8 @@ let () =
Printf.sprintf "tcp://*:%d" localport
in
let f () =
new_thread_req addr_in addr_out
let f () =
new_thread REQ addr_in addr_out
in
(Thread.create f) ()
@ -238,8 +211,8 @@ let () =
Printf.sprintf "tcp://*:%d" (localport+2)
in
let f () =
new_thread_req addr_in addr_out
let f () =
new_thread REQ addr_in addr_out
in
(Thread.create f) ()
in
@ -254,8 +227,8 @@ let () =
Printf.sprintf "tcp://*:%d" (localport+1)
in
let f () =
new_thread_sub addr_in addr_out
let f () =
new_thread SUB addr_in addr_out
in
(Thread.create f) ()
in
@ -263,7 +236,7 @@ let () =
let input_thread =
let f () =
let f () =
let addr_out =
match arg with
| EZFIO _ -> None
@ -275,22 +248,22 @@ let () =
Printf.sprintf "tcp://*:%d" (localport+9)
in
let socket_in =
let socket_in =
create_socket Zmq.Socket.rep Zmq.Socket.bind addr_in
in
let socket_out =
match addr_out with
match addr_out with
| Some addr_out -> Some (
create_socket Zmq.Socket.req Zmq.Socket.connect addr_out)
| None -> None
in
let temp_file =
let temp_file =
Filename.temp_file "qp_tunnel" ".tar.gz"
in
let get_ezfio_filename () =
let get_ezfio_filename () =
match arg with
| EZFIO x -> x
| ADDRESS _ ->
@ -304,9 +277,9 @@ let () =
end
in
let get_input () =
let get_input () =
match arg with
| EZFIO x ->
| EZFIO x ->
begin
Printf.sprintf "tar --exclude=\"*.gz.*\" -zcf %s %s" temp_file x
|> Sys.command |> ignore;
@ -318,11 +291,11 @@ let () =
in
ignore @@ Unix.lseek fd 0 Unix.SEEK_SET ;
let bstr =
Unix.map_file fd Bigarray.char
Unix.map_file fd Bigarray.char
Bigarray.c_layout false [| len |]
|> Bigarray.array1_of_genarray
in
let result =
let result =
String.init len (fun i -> bstr.{i}) ;
in
Unix.close fd;
@ -340,7 +313,7 @@ let () =
end
in
let () =
let () =
match socket_out with
| None -> ()
| Some socket_out ->
@ -356,7 +329,7 @@ let () =
| ADDRESS _ ->
begin
Printf.printf "Getting input... %!";
let ezfio_filename =
let ezfio_filename =
get_ezfio_filename ()
in
Printf.printf "%s%!" ezfio_filename;
@ -370,7 +343,7 @@ let () =
|> Sys.command |> ignore ;
let oc =
Filename.concat (Qpackage.ezfio_work ezfio_filename) "qp_run_address"
|> open_out
|> open_out
in
Printf.fprintf oc "tcp://%s:%d\n" localhost localport;
close_out oc;
@ -386,9 +359,9 @@ let () =
let action () =
match Zmq.Socket.recv socket_in with
| "get_input" -> get_input ()
|> Zmq.Socket.send socket_in
|> Zmq.Socket.send socket_in
| "get_ezfio_filename" -> get_ezfio_filename ()
|> Zmq.Socket.send socket_in
|> Zmq.Socket.send socket_in
| "test" -> Zmq.Socket.send socket_in "OK"
| x -> Printf.sprintf "Message '%s' not understood" x
|> Zmq.Socket.send socket_in
@ -399,7 +372,7 @@ On remote hosts, create ssh tunnel using:
ssh -L %d:%s:%d -L %d:%s:%d -L %d:%s:%d -L %d:%s:%d %s &
Or from this host connect to clients using:
ssh -R %d:localhost:%d -R %d:localhost:%d -R %d:localhost:%d -R %d:localhost:%d <host> &
%!"
%!"
(port ) localhost (localport )
(port+1) localhost (localport+1)
(port+2) localhost (localport+2)
@ -419,12 +392,12 @@ Or from this host connect to clients using:
match polling.(0) with
| Some Zmq.Poll.In -> action ()
| None -> ()
| Some Zmq.Poll.In_out
| Some Zmq.Poll.In_out
| Some Zmq.Poll.Out -> ()
done;
let () =
let () =
match socket_out with
| Some socket_out -> Zmq.Socket.close socket_out
| None -> ()
@ -442,7 +415,7 @@ Or from this host connect to clients using:
Thread.join ocaml_thread;
Zmq.Context.terminate zmq_context;
Printf.printf "qp_tunnel exited properly.\n"

2
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]

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

@ -16,7 +16,7 @@ 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_coef , (ao_num,ao_prim_num_max) ]
&BEGIN_PROVIDER [ double precision, ao_expo , (ao_num,ao_prim_num_max) ]
implicit none
BEGIN_DOC

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) ]

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

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

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

@ -327,8 +327,6 @@ double precision function get_ao_two_e_integral(i,j,k,l,map) result(result)
implicit none
BEGIN_DOC
! Gets one AO bi-electronic integral from the AO map
!
! i,j,k,l in physicist notation <ij|kl>
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

10
src/basis/EZFIO.cfg
View File

@ -37,16 +37,16 @@ doc: Number of primitives in a shell
size: (basis.shell_num)
interface: ezfio, provider
[shell_index]
[shell_prim_index]
type: integer
doc: Index of the shell for each primitive
size: (basis.prim_num)
doc: Max number of primitives in a shell
size: (basis.shell_num)
interface: ezfio, provider
[basis_nucleus_index]
type: integer
doc: Nucleus on which the shell is centered
size: (basis.shell_num)
doc: Index of the nucleus on which the shell is centered
size: (nuclei.nucl_num)
interface: ezfio, provider
[prim_normalization_factor]

2
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 '

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

15
src/bitmask/bitmasks_routines.irp.f
View File

@ -268,21 +268,6 @@ subroutine print_spindet(string,Nint)
end
subroutine print_det_one_dimension(string,Nint)
use bitmasks
implicit none
BEGIN_DOC
! Subroutine to print the content of a determinant using the '+-' notation
END_DOC
integer, intent(in) :: Nint
integer(bit_kind), intent(in) :: string(Nint)
character*(2048) :: output(1)
call bitstring_to_str( output(1), string, Nint )
print *, trim(output(1))
end
logical function is_integer_in_string(bite,string,Nint)
use bitmasks
implicit none

12
src/cipsi/EZFIO.cfg
View File

@ -1,3 +1,9 @@
[pert_2rdm]
type: logical
doc: If true, computes the one- and two-body rdms with perturbation theory
interface: ezfio,provider,ocaml
default: False
[save_wf_after_selection]
type: logical
doc: If true, saves the wave function after the selection, before the diagonalization
@ -34,9 +40,3 @@ doc: Maximum number of excitation for beta determinants with respect to the Hart
interface: ezfio,ocaml,provider
default: -1
[twice_hierarchy_max]
type: integer
doc: Twice the maximum hierarchy parameter (excitation degree plus half the seniority number). Using -1 selects all determinants
interface: ezfio,ocaml,provider
default: -1

1
src/cipsi/NEED
View File

@ -2,4 +2,5 @@ perturbation
zmq
mpi
iterations
two_body_rdm
csf

4
src/cipsi/cipsi.irp.f
View File

@ -70,8 +70,8 @@ subroutine run_cipsi
do while ( &
(N_det < N_det_max) .and. &
(sum(abs(pt2_data % pt2(1:N_states)) * state_average_weight(1:N_states)) > pt2_max) .and. &
(sum(abs(pt2_data % variance(1:N_states)) * state_average_weight(1:N_states)) > variance_max) .and. &
(maxval(abs(pt2_data % pt2(1:N_states))) > pt2_max) .and. &
(maxval(abs(pt2_data % variance(1:N_states))) > variance_max) .and. &
(correlation_energy_ratio <= correlation_energy_ratio_max) &
)
write(*,'(A)') '--------------------------------------------------------------------------------'

183
src/cipsi/pert_rdm_providers.irp.f Normal file
View File

@ -0,0 +1,183 @@
use bitmasks
use omp_lib
BEGIN_PROVIDER [ integer(omp_lock_kind), pert_2rdm_lock]
use f77_zmq
implicit none
call omp_init_lock(pert_2rdm_lock)
END_PROVIDER
BEGIN_PROVIDER [integer, n_orb_pert_rdm]
implicit none
n_orb_pert_rdm = n_act_orb
END_PROVIDER
BEGIN_PROVIDER [integer, list_orb_reverse_pert_rdm, (mo_num)]
implicit none
list_orb_reverse_pert_rdm = list_act_reverse
END_PROVIDER
BEGIN_PROVIDER [integer, list_orb_pert_rdm, (n_orb_pert_rdm)]
implicit none
list_orb_pert_rdm = list_act
END_PROVIDER
BEGIN_PROVIDER [double precision, pert_2rdm_provider, (n_orb_pert_rdm,n_orb_pert_rdm,n_orb_pert_rdm,n_orb_pert_rdm)]
implicit none
pert_2rdm_provider = 0.d0
END_PROVIDER
subroutine fill_buffer_double_rdm(i_generator, sp, h1, h2, bannedOrb, banned, fock_diag_tmp, E0, pt2_data, mat, buf, psi_det_connection, psi_coef_connection_reverse, n_det_connection)
use bitmasks
use selection_types
implicit none
integer, intent(in) :: n_det_connection
double precision, intent(in) :: psi_coef_connection_reverse(N_states,n_det_connection)
integer(bit_kind), intent(in) :: psi_det_connection(N_int,2,n_det_connection)
integer, intent(in) :: i_generator, sp, h1, h2
double precision, intent(in) :: mat(N_states, mo_num, mo_num)
logical, intent(in) :: bannedOrb(mo_num, 2), banned(mo_num, mo_num)
double precision, intent(in) :: fock_diag_tmp(mo_num)
double precision, intent(in) :: E0(N_states)
type(pt2_type), intent(inout) :: pt2_data
type(selection_buffer), intent(inout) :: buf
logical :: ok
integer :: s1, s2, p1, p2, ib, j, istate, jstate
integer(bit_kind) :: mask(N_int, 2), det(N_int, 2)
double precision :: e_pert, delta_E, val, Hii, sum_e_pert, tmp, alpha_h_psi, coef(N_states)
double precision, external :: diag_H_mat_elem_fock
double precision :: E_shift
logical, external :: detEq
double precision, allocatable :: values(:)
integer, allocatable :: keys(:,:)
integer :: nkeys
integer :: sze_buff
sze_buff = 5 * mo_num ** 2
allocate(keys(4,sze_buff),values(sze_buff))
nkeys = 0
if(sp == 3) then
s1 = 1
s2 = 2
else
s1 = sp
s2 = sp
end if
call apply_holes(psi_det_generators(1,1,i_generator), s1, h1, s2, h2, mask, ok, N_int)
E_shift = 0.d0
if (h0_type == 'CFG') then
j = det_to_configuration(i_generator)
E_shift = psi_det_Hii(i_generator) - psi_configuration_Hii(j)
endif
do p1=1,mo_num
if(bannedOrb(p1, s1)) cycle
ib = 1
if(sp /= 3) ib = p1+1
do p2=ib,mo_num
! -----
! /!\ Generating only single excited determinants doesn't work because a
! determinant generated by a single excitation may be doubly excited wrt
! to a determinant of the future. In that case, the determinant will be
! detected as already generated when generating in the future with a
! double excitation.
!
! if (.not.do_singles) then
! if ((h1 == p1) .or. (h2 == p2)) then
! cycle
! endif
! endif
!
! if (.not.do_doubles) then
! if ((h1 /= p1).and.(h2 /= p2)) then
! cycle
! endif
! endif
! -----
if(bannedOrb(p2, s2)) cycle
if(banned(p1,p2)) cycle
if( sum(abs(mat(1:N_states, p1, p2))) == 0d0) cycle
call apply_particles(mask, s1, p1, s2, p2, det, ok, N_int)
if (do_only_cas) then
integer, external :: number_of_holes, number_of_particles
if (number_of_particles(det)>0) then
cycle
endif
if (number_of_holes(det)>0) then
cycle
endif
endif
if (do_ddci) then
logical, external :: is_a_two_holes_two_particles
if (is_a_two_holes_two_particles(det)) then
cycle
endif
endif
if (do_only_1h1p) then
logical, external :: is_a_1h1p
if (.not.is_a_1h1p(det)) cycle
endif
Hii = diag_H_mat_elem_fock(psi_det_generators(1,1,i_generator),det,fock_diag_tmp,N_int)
sum_e_pert = 0d0
integer :: degree
call get_excitation_degree(det,HF_bitmask,degree,N_int)
if(degree == 2)cycle
do istate=1,N_states
delta_E = E0(istate) - Hii + E_shift
alpha_h_psi = mat(istate, p1, p2)
val = alpha_h_psi + alpha_h_psi
tmp = dsqrt(delta_E * delta_E + val * val)
if (delta_E < 0.d0) then
tmp = -tmp
endif
e_pert = 0.5d0 * (tmp - delta_E)
coef(istate) = e_pert / alpha_h_psi
print*,e_pert,coef,alpha_h_psi
pt2_data % pt2(istate) += e_pert
pt2_data % variance(istate) += alpha_h_psi * alpha_h_psi
enddo
do istate=1,N_states
alpha_h_psi = mat(istate, p1, p2)
e_pert = coef(istate) * alpha_h_psi
do jstate=1,N_states
pt2_data % overlap(jstate,jstate) = coef(istate) * coef(jstate)
enddo
if (weight_selection /= 5) then
! Energy selection
sum_e_pert = sum_e_pert + e_pert * selection_weight(istate)
else
! Variance selection
sum_e_pert = sum_e_pert - alpha_h_psi * alpha_h_psi * selection_weight(istate)
endif
end do
call give_2rdm_pert_contrib(det,coef,psi_det_connection,psi_coef_connection_reverse,n_det_connection,nkeys,keys,values,sze_buff)
if(sum_e_pert <= buf%mini) then
call add_to_selection_buffer(buf, det, sum_e_pert)
end if
end do
end do
call update_keys_values(keys,values,nkeys,n_orb_pert_rdm,pert_2rdm_provider,pert_2rdm_lock)
end

124
src/cipsi/pt2_stoch_routines.irp.f
View File

@ -117,6 +117,7 @@ subroutine ZMQ_pt2(E, pt2_data, pt2_data_err, relative_error, N_in)
integer(ZMQ_PTR) :: zmq_to_qp_run_socket, zmq_socket_pull
integer, intent(in) :: N_in
! integer, intent(inout) :: N_in
double precision, intent(in) :: relative_error, E(N_states)
type(pt2_type), intent(inout) :: pt2_data, pt2_data_err
!
@ -131,8 +132,8 @@ subroutine ZMQ_pt2(E, pt2_data, pt2_data_err, relative_error, N_in)
PROVIDE psi_bilinear_matrix_transp_rows_loc psi_bilinear_matrix_transp_columns
PROVIDE psi_bilinear_matrix_transp_order psi_selectors_coef_transp psi_det_sorted
PROVIDE psi_det_hii selection_weight pseudo_sym
PROVIDE list_act list_inact list_core list_virt list_del seniority_max
PROVIDE excitation_beta_max excitation_alpha_max excitation_max
PROVIDE n_act_orb n_inact_orb n_core_orb n_virt_orb n_del_orb seniority_max
PROVIDE pert_2rdm excitation_beta_max excitation_alpha_max excitation_max
if (h0_type == 'CFG') then
PROVIDE psi_configuration_hii det_to_configuration
@ -287,16 +288,12 @@ subroutine ZMQ_pt2(E, pt2_data, pt2_data_err, relative_error, N_in)
call write_int(6,nproc_target,'Number of threads for PT2')
call write_double(6,mem,'Memory (Gb)')
call set_multiple_levels_omp(.False.)
call omp_set_max_active_levels(1)
! old
!print '(A)', '========== ======================= ===================== ===================== ==========='
!print '(A)', ' Samples Energy Variance Norm^2 Seconds'
!print '(A)', '========== ======================= ===================== ===================== ==========='
print '(A)', '========== ==================== ================ ================ ================ ============= ==========='
print '(A)', ' Samples Energy PT2 Variance Norm^2 Convergence Seconds'
print '(A)', '========== ==================== ================ ================ ================ ============= ==========='
print '(A)', '========== ======================= ===================== ===================== ==========='
print '(A)', ' Samples Energy Variance Norm^2 Seconds'
print '(A)', '========== ======================= ===================== ===================== ==========='
PROVIDE global_selection_buffer
@ -318,17 +315,14 @@ subroutine ZMQ_pt2(E, pt2_data, pt2_data_err, relative_error, N_in)
endif
!$OMP END PARALLEL
call end_parallel_job(zmq_to_qp_run_socket, zmq_socket_pull, 'pt2')
call set_multiple_levels_omp(.True.)
call omp_set_max_active_levels(8)
! old
!print '(A)', '========== ======================= ===================== ===================== ==========='
print '(A)', '========== ==================== ================ ================ ================ ============= ==========='
print '(A)', '========== ======================= ===================== ===================== ==========='
do k=1,N_states
pt2_overlap(pt2_stoch_istate,k) = pt2_data % overlap(k,pt2_stoch_istate)
enddo
SOFT_TOUCH pt2_overlap
do k=1,N_states
pt2_overlap(pt2_stoch_istate,k) = pt2_data % overlap(k,pt2_stoch_istate)
enddo
SOFT_TOUCH pt2_overlap
enddo
FREE pt2_stoch_istate
@ -421,17 +415,6 @@ subroutine pt2_collector(zmq_socket_pull, E, relative_error, pt2_data, pt2_data_
double precision :: rss
double precision, external :: memory_of_double, memory_of_int
character(len=20) :: format_str1, str_error1, format_str2, str_error2
character(len=20) :: format_str3, str_error3, format_str4, str_error4
character(len=20) :: format_value1, format_value2, format_value3, format_value4
character(len=20) :: str_value1, str_value2, str_value3, str_value4
character(len=20) :: str_conv
double precision :: value1, value2, value3, value4
double precision :: error1, error2, error3, error4
integer :: size1,size2,size3,size4
double precision :: conv_crit
sending =.False.
rss = memory_of_int(pt2_n_tasks_max*2+N_det_generators*2)
@ -541,74 +524,28 @@ subroutine pt2_collector(zmq_socket_pull, E, relative_error, pt2_data, pt2_data_
! 1/(N-1.5) : see Brugger, The American Statistician (23) 4 p. 32 (1969)
if(c > 2) then
eqt = dabs((pt2_data_S2(t) % pt2(pt2_stoch_istate) / c) - (pt2_data_S(t) % pt2(pt2_stoch_istate)/c)**2) ! dabs for numerical stability
eqt = dsqrt(eqt / (dble(c) - 1.5d0))
eqt = sqrt(eqt / (dble(c) - 1.5d0))
pt2_data_err % pt2(pt2_stoch_istate) = eqt
eqt = dabs((pt2_data_S2(t) % variance(pt2_stoch_istate) / c) - (pt2_data_S(t) % variance(pt2_stoch_istate)/c)**2) ! dabs for numerical stability
eqt = dsqrt(eqt / (dble(c) - 1.5d0))
eqt = sqrt(eqt / (dble(c) - 1.5d0))
pt2_data_err % variance(pt2_stoch_istate) = eqt
eqta(:) = dabs((pt2_data_S2(t) % overlap(:,pt2_stoch_istate) / c) - (pt2_data_S(t) % overlap(:,pt2_stoch_istate)/c)**2) ! dabs for numerical stability
eqta(:) = dsqrt(eqta(:) / (dble(c) - 1.5d0))
eqta(:) = sqrt(eqta(:) / (dble(c) - 1.5d0))
pt2_data_err % overlap(:,pt2_stoch_istate) = eqta(:)
if ((time - time1 > 1.d0) .or. (n==N_det_generators)) then
time1 = time
value1 = pt2_data % pt2(pt2_stoch_istate) + E
error1 = pt2_data_err % pt2(pt2_stoch_istate)
value2 = pt2_data % pt2(pt2_stoch_istate)
error2 = pt2_data_err % pt2(pt2_stoch_istate)
value3 = pt2_data % variance(pt2_stoch_istate)
error3 = pt2_data_err % variance(pt2_stoch_istate)
value4 = pt2_data % overlap(pt2_stoch_istate,pt2_stoch_istate)
error4 = pt2_data_err % overlap(pt2_stoch_istate,pt2_stoch_istate)
! Max size of the values (FX.Y) with X=size
size1 = 15
size2 = 12
size3 = 12
size4 = 12
! To generate the format: number(error)
call format_w_error(value1,error1,size1,8,format_value1,str_error1)
call format_w_error(value2,error2,size2,8,format_value2,str_error2)
call format_w_error(value3,error3,size3,8,format_value3,str_error3)
call format_w_error(value4,error4,size4,8,format_value4,str_error4)
! value > string with the right format
write(str_value1,'('//format_value1//')') value1
write(str_value2,'('//format_value2//')') value2
write(str_value3,'('//format_value3//')') value3
write(str_value4,'('//format_value4//')') value4
! Convergence criterion
conv_crit = dabs(pt2_data_err % pt2(pt2_stoch_istate)) / &
(1.d-20 + dabs(pt2_data % pt2(pt2_stoch_istate)) )
write(str_conv,'(G10.3)') conv_crit
write(*,'(I10,X,X,A20,X,A16,X,A16,X,A16,X,A12,X,F10.1)') c,&
adjustl(adjustr(str_value1)//'('//str_error1(1:1)//')'),&
adjustl(adjustr(str_value2)//'('//str_error2(1:1)//')'),&
adjustl(adjustr(str_value3)//'('//str_error3(1:1)//')'),&
adjustl(adjustr(str_value4)//'('//str_error4(1:1)//')'),&
adjustl(str_conv),&
time-time0
! Old print
!print '(I10, X, F12.6, X, G10.3, X, F10.6, X, G10.3, X, F10.6, X, G10.3, X, F10.1,1pE16.6,1pE16.6)', c, &
! pt2_data % pt2(pt2_stoch_istate) +E, &
! pt2_data_err % pt2(pt2_stoch_istate), &
! pt2_data % variance(pt2_stoch_istate), &
! pt2_data_err % variance(pt2_stoch_istate), &
! pt2_data % overlap(pt2_stoch_istate,pt2_stoch_istate), &
! pt2_data_err % overlap(pt2_stoch_istate,pt2_stoch_istate), &
! time-time0, &
! pt2_data % pt2(pt2_stoch_istate), &
! dabs(pt2_data_err % pt2(pt2_stoch_istate)) / &
! (1.d-20 + dabs(pt2_data % pt2(pt2_stoch_istate)) )
print '(I10, X, F12.6, X, G10.3, X, F10.6, X, G10.3, X, F10.6, X, G10.3, X, F10.4)', c, &
pt2_data % pt2(pt2_stoch_istate) +E, &
pt2_data_err % pt2(pt2_stoch_istate), &
pt2_data % variance(pt2_stoch_istate), &
pt2_data_err % variance(pt2_stoch_istate), &
pt2_data % overlap(pt2_stoch_istate,pt2_stoch_istate), &
pt2_data_err % overlap(pt2_stoch_istate,pt2_stoch_istate), &
time-time0
if (stop_now .or. ( &
(do_exit .and. (dabs(pt2_data_err % pt2(pt2_stoch_istate)) / &
(1.d-20 + dabs(pt2_data % pt2(pt2_stoch_istate)) ) <= relative_error))) ) then
@ -639,11 +576,11 @@ subroutine pt2_collector(zmq_socket_pull, E, relative_error, pt2_data, pt2_data_
endif
do i=1,n_tasks
if(index(i).gt.size(pt2_data_I,1).or.index(i).lt.1)then
print*,'PB !!!'
print*,'If you see this, send a bug report with the following content'
print*,irp_here
print*,'i,index(i),size(pt2_data_I,1) = ',i,index(i),size(pt2_data_I,1)
stop -1
print*,'PB !!!'
print*,'If you see this, send a bug report with the following content'
print*,irp_here
print*,'i,index(i),size(pt2_data_I,1) = ',i,index(i),size(pt2_data_I,1)
stop -1
endif
call pt2_add(pt2_data_I(index(i)),1.d0,pt2_data_task(i))
f(index(i)) -= 1
@ -906,8 +843,9 @@ END_PROVIDER
do t=1, pt2_N_teeth
tooth_width = tilde_cW(pt2_n_0(t+1)) - tilde_cW(pt2_n_0(t))
if (tooth_width == 0.d0) then
tooth_width = max(1.d-15,sum(tilde_w(pt2_n_0(t):pt2_n_0(t+1))))
tooth_width = sum(tilde_w(pt2_n_0(t):pt2_n_0(t+1)))
endif
ASSERT(tooth_width > 0.d0)
do i=pt2_n_0(t)+1, pt2_n_0(t+1)
pt2_w(i) = tilde_w(i) * pt2_W_T / tooth_width
end do

55
src/cipsi/run_pt2_slave.irp.f
View File

@ -31,11 +31,12 @@ subroutine run_pt2_slave(thread,iproc,energy)
double precision, intent(in) :: energy(N_states_diag)
integer, intent(in) :: thread, iproc
if (N_det > 100000 ) then
call run_pt2_slave_large(thread,iproc,energy)
else
call run_pt2_slave_small(thread,iproc,energy)
endif
call run_pt2_slave_large(thread,iproc,energy)
! if (N_det > nproc*(elec_alpha_num * (mo_num-elec_alpha_num))**2) then
! call run_pt2_slave_large(thread,iproc,energy)
! else
! call run_pt2_slave_small(thread,iproc,energy)
! endif
end
subroutine run_pt2_slave_small(thread,iproc,energy)
@ -66,6 +67,7 @@ subroutine run_pt2_slave_small(thread,iproc,energy)
double precision, external :: memory_of_double, memory_of_int
integer :: bsize ! Size of selection buffers
! logical :: sending
allocate(task_id(pt2_n_tasks_max), task(pt2_n_tasks_max))
allocate(pt2_data(pt2_n_tasks_max), i_generator(pt2_n_tasks_max), subset(pt2_n_tasks_max))
@ -83,6 +85,7 @@ subroutine run_pt2_slave_small(thread,iproc,energy)
buffer_ready = .False.
n_tasks = 1
! sending = .False.
done = .False.
do while (.not.done)
@ -116,13 +119,14 @@ subroutine run_pt2_slave_small(thread,iproc,energy)
do k=1,n_tasks
call pt2_alloc(pt2_data(k),N_states)
b%cur = 0
! double precision :: time2
! call wall_time(time2)
!double precision :: time2
!call wall_time(time2)
call select_connected(i_generator(k),energy,pt2_data(k),b,subset(k),pt2_F(i_generator(k)))
! call wall_time(time1)
! print *, i_generator(1), time1-time2, n_tasks, pt2_F(i_generator(1))
!call wall_time(time1)
!print *, i_generator(1), time1-time2, n_tasks, pt2_F(i_generator(1))
enddo
call wall_time(time1)
!print *, '-->', i_generator(1), time1-time0, n_tasks
integer, external :: tasks_done_to_taskserver
if (tasks_done_to_taskserver(zmq_to_qp_run_socket,worker_id,task_id,n_tasks) == -1) then
@ -160,11 +164,6 @@ end subroutine
subroutine run_pt2_slave_large(thread,iproc,energy)
use selection_types
use f77_zmq
BEGIN_DOC
! This subroutine can miss important determinants when the PT2 is completely
! computed. It should be called only for large workloads where the PT2 is
! interrupted before the end
END_DOC
implicit none
double precision, intent(in) :: energy(N_states_diag)
@ -190,12 +189,8 @@ subroutine run_pt2_slave_large(thread,iproc,energy)
integer :: bsize ! Size of selection buffers
logical :: sending
double precision :: time_shift
PROVIDE global_selection_buffer global_selection_buffer_lock
call random_number(time_shift)
time_shift = time_shift*15.d0
zmq_to_qp_run_socket = new_zmq_to_qp_run_socket()
@ -213,9 +208,6 @@ subroutine run_pt2_slave_large(thread,iproc,energy)
sending = .False.
done = .False.
double precision :: time0, time1
call wall_time(time0)
time0 = time0+time_shift
do while (.not.done)
integer, external :: get_tasks_from_taskserver
@ -242,28 +234,25 @@ subroutine run_pt2_slave_large(thread,iproc,energy)
ASSERT (b%N == bsize)
endif
double precision :: time0, time1
call wall_time(time0)
call pt2_alloc(pt2_data,N_states)
b%cur = 0
call select_connected(i_generator,energy,pt2_data,b,subset,pt2_F(i_generator))
call wall_time(time1)
integer, external :: tasks_done_to_taskserver
if (tasks_done_to_taskserver(zmq_to_qp_run_socket,worker_id,task_id,n_tasks) == -1) then
done = .true.
endif
call sort_selection_buffer(b)
call wall_time(time1)
! if (time1-time0 > 15.d0) then
call omp_set_lock(global_selection_buffer_lock)
global_selection_buffer%mini = b%mini
call merge_selection_buffers(b,global_selection_buffer)
b%cur=0
call omp_unset_lock(global_selection_buffer_lock)
call wall_time(time0)
! endif
call push_pt2_results_async_recv(zmq_socket_push,b%mini,sending)
if ( iproc == 1 .or. i_generator < 100 .or. done) then
call omp_set_lock(global_selection_buffer_lock)
global_selection_buffer%mini = b%mini
call merge_selection_buffers(b,global_selection_buffer)
b%cur=0
call omp_unset_lock(global_selection_buffer_lock)
if ( iproc == 1 ) then
call omp_set_lock(global_selection_buffer_lock)
call push_pt2_results_async_send(zmq_socket_push, (/i_generator/), (/pt2_data/), global_selection_buffer, (/task_id/), 1,sending)
global_selection_buffer%cur = 0

8
src/cipsi/run_selection_slave.irp.f
View File

@ -61,14 +61,10 @@ subroutine run_selection_slave(thread,iproc,energy)
if (N /= buf%N) then
print *, 'N=', N
print *, 'buf%N=', buf%N
print *, 'In ', irp_here, ': N /= buf%N'
stop -1
print *, 'bug in ', irp_here
stop '-1'
end if
end if
if (i_generator > N_det_generators) then
print *, 'In ', irp_here, ': i_generator > N_det_generators'
stop -1
endif
call select_connected(i_generator,energy,pt2_data,buf,subset,pt2_F(i_generator))
endif

102
src/cipsi/selection.irp.f
View File

@ -195,10 +195,7 @@ subroutine select_singles_and_doubles(i_generator,hole_mask,particle_mask,fock_d
integer :: l_a, nmax, idx
integer, allocatable :: indices(:), exc_degree(:), iorder(:)
! Removed to avoid introducing determinants already presents in the wf
!double precision, parameter :: norm_thr = 1.d-16
double precision, parameter :: norm_thr = 1.d-16
allocate (indices(N_det), &
exc_degree(max(N_det_alpha_unique,N_det_beta_unique)))
@ -218,11 +215,10 @@ subroutine select_singles_and_doubles(i_generator,hole_mask,particle_mask,fock_d
i = psi_bilinear_matrix_rows(l_a)
if (nt + exc_degree(i) <= 4) then
idx = psi_det_sorted_order(psi_bilinear_matrix_order(l_a))
! Removed to avoid introducing determinants already presents in the wf
!if (psi_average_norm_contrib_sorted(idx) > norm_thr) then
if (psi_average_norm_contrib_sorted(idx) > norm_thr) then
indices(k) = idx
k=k+1
!endif
endif
endif
enddo
enddo
@ -246,11 +242,10 @@ subroutine select_singles_and_doubles(i_generator,hole_mask,particle_mask,fock_d
idx = psi_det_sorted_order( &
psi_bilinear_matrix_order( &
psi_bilinear_matrix_transp_order(l_a)))
! Removed to avoid introducing determinants already presents in the wf
!if (psi_average_norm_contrib_sorted(idx) > norm_thr) then
if (psi_average_norm_contrib_sorted(idx) > norm_thr) then
indices(k) = idx
k=k+1
!endif
endif
endif
enddo
enddo
@ -258,6 +253,8 @@ subroutine select_singles_and_doubles(i_generator,hole_mask,particle_mask,fock_d
deallocate(exc_degree)
nmax=k-1
call isort_noidx(indices,nmax)
! Start with 32 elements. Size will double along with the filtering.
allocate(preinteresting(0:32), prefullinteresting(0:32), &
interesting(0:32), fullinteresting(0:32))
@ -467,21 +464,27 @@ subroutine select_singles_and_doubles(i_generator,hole_mask,particle_mask,fock_d
allocate (fullminilist (N_int, 2, fullinteresting(0)), &
minilist (N_int, 2, interesting(0)) )
! if(pert_2rdm)then
! allocate(coef_fullminilist_rev(N_states,fullinteresting(0)))
! do i=1,fullinteresting(0)
! do j = 1, N_states
! coef_fullminilist_rev(j,i) = psi_coef_sorted(fullinteresting(i),j)
! enddo
! enddo
! endif
if(pert_2rdm)then
allocate(coef_fullminilist_rev(N_states,fullinteresting(0)))
do i=1,fullinteresting(0)
do j = 1, N_states
coef_fullminilist_rev(j,i) = psi_coef_sorted(fullinteresting(i),j)
enddo
enddo
endif
do i=1,fullinteresting(0)
fullminilist(:,:,i) = psi_det_sorted(:,:,fullinteresting(i))
do k=1,N_int
fullminilist(k,1,i) = psi_det_sorted(k,1,fullinteresting(i))
fullminilist(k,2,i) = psi_det_sorted(k,2,fullinteresting(i))
enddo
enddo
do i=1,interesting(0)
minilist(:,:,i) = psi_det_sorted(:,:,interesting(i))
do k=1,N_int
minilist(k,1,i) = psi_det_sorted(k,1,interesting(i))
minilist(k,2,i) = psi_det_sorted(k,2,interesting(i))
enddo
enddo
do s2=s1,2
@ -528,19 +531,19 @@ subroutine select_singles_and_doubles(i_generator,hole_mask,particle_mask,fock_d
call splash_pq(mask, sp, minilist, i_generator, interesting(0), bannedOrb, banned, mat, interesting)
! if(.not.pert_2rdm)then
if(.not.pert_2rdm)then
call fill_buffer_double(i_generator, sp, h1, h2, bannedOrb, banned, fock_diag_tmp, E0, pt2_data, mat, buf)
! else
! call fill_buffer_double_rdm(i_generator, sp, h1, h2, bannedOrb, banned, fock_diag_tmp, E0, pt2_data, mat, buf,fullminilist, coef_fullminilist_rev, fullinteresting(0))
! endif
else
call fill_buffer_double_rdm(i_generator, sp, h1, h2, bannedOrb, banned, fock_diag_tmp, E0, pt2_data, mat, buf,fullminilist, coef_fullminilist_rev, fullinteresting(0))
endif
end if
enddo
if(s1 /= s2) monoBdo = .false.
enddo
deallocate(fullminilist,minilist)
! if(pert_2rdm)then
! deallocate(coef_fullminilist_rev)
! endif
if(pert_2rdm)then
deallocate(coef_fullminilist_rev)
endif
enddo
enddo
deallocate(preinteresting, prefullinteresting, interesting, fullinteresting)
@ -569,7 +572,6 @@ subroutine fill_buffer_double(i_generator, sp, h1, h2, bannedOrb, banned, fock_d
double precision, external :: diag_H_mat_elem_fock
double precision :: E_shift
double precision :: s_weight(N_states,N_states)
logical, external :: is_in_wavefunction
PROVIDE dominant_dets_of_cfgs N_dominant_dets_of_cfgs
do jstate=1,N_states
do istate=1,N_states
@ -711,25 +713,6 @@ subroutine fill_buffer_double(i_generator, sp, h1, h2, bannedOrb, banned, fock_d
if (do_cycle) cycle
endif
if (twice_hierarchy_max >= 0) then
s = 0
do k=1,N_int
s = s + popcnt(ieor(det(k,1),det(k,2)))
enddo
if ( mod(s,2)>0 ) stop 'For now, hierarchy CI is defined only for an even number of electrons'
if (excitation_ref == 1) then
call get_excitation_degree(HF_bitmask,det(1,1),degree,N_int)
else if (excitation_ref == 2) then
stop 'For now, hierarchy CI is defined only for a single reference determinant'
! do k=1,N_dominant_dets_of_cfgs
! call get_excitation_degree(dominant_dets_of_cfgs(1,1,k),det(1,1),degree,N_int)
! enddo
endif
integer :: twice_hierarchy
twice_hierarchy = degree + s/2
if (twice_hierarchy > twice_hierarchy_max) cycle
endif
Hii = diag_H_mat_elem_fock(psi_det_generators(1,1,i_generator),det,fock_diag_tmp,N_int)
w = 0d0
@ -800,9 +783,7 @@ subroutine fill_buffer_double(i_generator, sp, h1, h2, bannedOrb, banned, fock_d
alpha_h_psi = mat(istate, p1, p2)
do k=1,N_states
pt2_data % overlap(k,istate) = pt2_data % overlap(k,istate) + coef(k) * coef(istate)
end do
pt2_data % overlap(:,istate) = pt2_data % overlap(:,istate) + coef(:) * coef(istate)
pt2_data % variance(istate) = pt2_data % variance(istate) + alpha_h_psi * alpha_h_psi
pt2_data % pt2(istate) = pt2_data % pt2(istate) + e_pert(istate)
@ -853,27 +834,8 @@ subroutine fill_buffer_double(i_generator, sp, h1, h2, bannedOrb, banned, fock_d
endif
end select
! To force the inclusion of determinants with a positive pt2 contribution
if (e_pert(istate) > 1d-8) then
w = -huge(1.0)
endif
end do
!!!BEGIN_DEBUG
! ! To check if the pt2 is taking determinants already in the wf
! if (is_in_wavefunction(det(N_int,1),N_int)) then
! print*, 'A determinant contributing to the pt2 is already in'
! print*, 'the wave function:'
! call print_det(det(N_int,1),N_int)
! print*,'contribution to the pt2 for the states:', e_pert(:)
! print*,'error in the filtering in'
! print*, 'cipsi/selection.irp.f sub: selecte_singles_and_doubles'
! print*, 'abort'
! call abort
! endif
!!!END_DEBUG
integer(bit_kind) :: occ(N_int,2), n
if (h0_type == 'CFG') then
@ -1594,7 +1556,7 @@ subroutine bitstring_to_list_in_selection( string, list, n_elements, Nint)
use bitmasks
implicit none
BEGIN_DOC
! Gives the indices(+1) of the bits set to 1 in the bit string
! Gives the inidices(+1) of the bits set to 1 in the bit string
END_DOC
integer, intent(in) :: Nint
integer(bit_kind), intent(in) :: string(Nint)

92
src/cipsi/selection_buffer.irp.f
View File

@ -60,7 +60,6 @@ subroutine add_to_selection_buffer(b, det, val)
b%val(b%cur) = val
if(b%cur == size(b%val)) then
call sort_selection_buffer(b)
b%cur = b%cur-1
end if
end if
end subroutine
@ -87,56 +86,43 @@ subroutine merge_selection_buffers(b1, b2)
double precision :: rss
double precision, external :: memory_of_double
sze = max(size(b1%val), size(b2%val))
! rss = memory_of_double(sze) + 2*N_int*memory_of_double(sze)
! call check_mem(rss,irp_here)
rss = memory_of_double(sze) + 2*N_int*memory_of_double(sze)
call check_mem(rss,irp_here)
allocate(val(sze), detmp(N_int, 2, sze))
i1=1
i2=1
select case (N_int)
BEGIN_TEMPLATE
case $case
do i=1,nmwen
if ( (i1 > b1%cur).and.(i2 > b2%cur) ) then
exit
else if (i1 > b1%cur) then
val(i) = b2%val(i2)
detmp(1:$N_int,1,i) = b2%det(1:$N_int,1,i2)
detmp(1:$N_int,2,i) = b2%det(1:$N_int,2,i2)
i2=i2+1
else if (i2 > b2%cur) then
val(i) = b1%val(i1)
detmp(1:$N_int,1,i) = b1%det(1:$N_int,1,i1)
detmp(1:$N_int,2,i) = b1%det(1:$N_int,2,i1)
i1=i1+1
do i=1,nmwen
if ( (i1 > b1%cur).and.(i2 > b2%cur) ) then
exit
else if (i1 > b1%cur) then
val(i) = b2%val(i2)
detmp(1:N_int,1,i) = b2%det(1:N_int,1,i2)
detmp(1:N_int,2,i) = b2%det(1:N_int,2,i2)
i2=i2+1
else if (i2 > b2%cur) then
val(i) = b1%val(i1)
detmp(1:N_int,1,i) = b1%det(1:N_int,1,i1)
detmp(1:N_int,2,i) = b1%det(1:N_int,2,i1)
i1=i1+1
else
if (b1%val(i1) <= b2%val(i2)) then
val(i) = b1%val(i1)
detmp(1:N_int,1,i) = b1%det(1:N_int,1,i1)
detmp(1:N_int,2,i) = b1%det(1:N_int,2,i1)
i1=i1+1
else
if (b1%val(i1) <= b2%val(i2)) then
val(i) = b1%val(i1)
detmp(1:$N_int,1,i) = b1%det(1:$N_int,1,i1)
detmp(1:$N_int,2,i) = b1%det(1:$N_int,2,i1)
i1=i1+1
else
val(i) = b2%val(i2)
detmp(1:$N_int,1,i) = b2%det(1:$N_int,1,i2)
detmp(1:$N_int,2,i) = b2%det(1:$N_int,2,i2)
i2=i2+1
endif
val(i) = b2%val(i2)
detmp(1:N_int,1,i) = b2%det(1:N_int,1,i2)
detmp(1:N_int,2,i) = b2%det(1:N_int,2,i2)
i2=i2+1
endif
enddo
do i=nmwen+1,b2%N
val(i) = 0.d0
! detmp(1:$N_int,1,i) = 0_bit_kind
! detmp(1:$N_int,2,i) = 0_bit_kind
enddo
SUBST [ case, N_int ]
(1); 1;;
(2); 2;;
(3); 3;;
(4); 4;;
default; N_int;;
END_TEMPLATE
end select
endif
enddo
deallocate(b2%det, b2%val)
do i=nmwen+1,b2%N
val(i) = 0.d0
detmp(1:N_int,1:2,i) = 0_bit_kind
enddo
b2%det => detmp
b2%val => val
b2%mini = min(b2%mini,b2%val(b2%N))
@ -158,8 +144,8 @@ subroutine sort_selection_buffer(b)
double precision :: rss
double precision, external :: memory_of_double, memory_of_int
! rss = memory_of_int(b%cur) + 2*N_int*memory_of_double(size(b%det,3))
! call check_mem(rss,irp_here)
rss = memory_of_int(b%cur) + 2*N_int*memory_of_double(size(b%det,3))
call check_mem(rss,irp_here)
allocate(iorder(b%cur), detmp(N_int, 2, size(b%det,3)))
do i=1,b%cur
iorder(i) = i
@ -239,14 +225,14 @@ subroutine make_selection_buffer_s2(b)
endif
dup = .True.
do k=1,N_int
if ( (tmp_array(k,1,i) /= tmp_array(k,1,j)) .or. &
(tmp_array(k,2,i) /= tmp_array(k,2,j)) ) then
if ( (tmp_array(k,1,i) /= tmp_array(k,1,j)) &
.or. (tmp_array(k,2,i) /= tmp_array(k,2,j)) ) then
dup = .False.
exit
endif
enddo
if (dup) then
val(i) = min(val(i), val(j))
val(i) = max(val(i), val(j))
duplicate(j) = .True.
endif
j+=1
@ -296,6 +282,9 @@ subroutine make_selection_buffer_s2(b)
call configuration_to_dets_size(o(1,1,i),sze,elec_alpha_num,N_int)
n_d = n_d + sze
if (n_d > b%cur) then
! if (n_d - b%cur > b%cur - n_d + sze) then
! n_d = n_d - sze
! endif
exit
endif
enddo
@ -340,11 +329,10 @@ subroutine remove_duplicates_in_selection_buffer(b)
integer(bit_kind), allocatable :: tmp_array(:,:,:)
logical, allocatable :: duplicate(:)
n_d = b%cur
logical :: found_duplicates
double precision :: rss
double precision, external :: memory_of_double
n_d = b%cur
rss = (4*N_int+4)*memory_of_double(n_d)
call check_mem(rss,irp_here)

24
src/cipsi/selection_weight.irp.f
View File

@ -38,11 +38,11 @@ subroutine update_pt2_and_variance_weights(pt2_data, N_st)
avg = sum(pt2(1:N_st)) / dble(N_st) + 1.d-32 ! Avoid future division by zero
dt = 4.d0 !* selection_factor
dt = 8.d0 !* selection_factor
do k=1,N_st
element = pt2(k) !exp(dt*(pt2(k)/avg - 1.d0))
! element = min(2.0d0 , element)
! element = max(0.5d0 , element)
element = exp(dt*(pt2(k)/avg - 1.d0))
element = min(2.0d0 , element)
element = max(0.5d0 , element)
pt2_match_weight(k) *= element
enddo
@ -50,9 +50,9 @@ subroutine update_pt2_and_variance_weights(pt2_data, N_st)
avg = sum(variance(1:N_st)) / dble(N_st) + 1.d-32 ! Avoid future division by zero
do k=1,N_st
element = variance(k) ! exp(dt*(variance(k)/avg -1.d0))
! element = min(2.0d0 , element)
! element = max(0.5d0 , element)
element = exp(dt*(variance(k)/avg -1.d0))
element = min(2.0d0 , element)
element = max(0.5d0 , element)
variance_match_weight(k) *= element
enddo
@ -62,9 +62,6 @@ subroutine update_pt2_and_variance_weights(pt2_data, N_st)
variance_match_weight(:) = 1.d0
endif
pt2_match_weight(:) = pt2_match_weight(:)/sum(pt2_match_weight(:))
variance_match_weight(:) = variance_match_weight(:)/sum(variance_match_weight(:))
threshold_davidson_pt2 = min(1.d-6, &
max(threshold_davidson, 1.e-1 * PT2_relative_error * minval(abs(pt2(1:N_states)))) )
@ -90,7 +87,7 @@ BEGIN_PROVIDER [ double precision, selection_weight, (N_states) ]
selection_weight(1:N_states) = c0_weight(1:N_states)
case (2)
print *, 'Using PT2-matching weight in selection'
print *, 'Using pt2-matching weight in selection'
selection_weight(1:N_states) = c0_weight(1:N_states) * pt2_match_weight(1:N_states)
print *, '# PT2 weight ', real(pt2_match_weight(:),4)
@ -100,7 +97,7 @@ BEGIN_PROVIDER [ double precision, selection_weight, (N_states) ]
print *, '# var weight ', real(variance_match_weight(:),4)
case (4)
print *, 'Using variance- and PT2-matching weights in selection'
print *, 'Using variance- and pt2-matching weights in selection'
selection_weight(1:N_states) = c0_weight(1:N_states) * sqrt(variance_match_weight(1:N_states) * pt2_match_weight(1:N_states))
print *, '# PT2 weight ', real(pt2_match_weight(:),4)
print *, '# var weight ', real(variance_match_weight(:),4)
@ -115,7 +112,7 @@ BEGIN_PROVIDER [ double precision, selection_weight, (N_states) ]
selection_weight(1:N_states) = c0_weight(1:N_states)
case (7)
print *, 'Input weights multiplied by variance- and PT2-matching'
print *, 'Input weights multiplied by variance- and pt2-matching'
selection_weight(1:N_states) = c0_weight(1:N_states) * sqrt(variance_match_weight(1:N_states) * pt2_match_weight(1:N_states)) * state_average_weight(1:N_states)
print *, '# PT2 weight ', real(pt2_match_weight(:),4)
print *, '# var weight ', real(variance_match_weight(:),4)
@ -131,7 +128,6 @@ BEGIN_PROVIDER [ double precision, selection_weight, (N_states) ]
print *, '# var weight ', real(variance_match_weight(:),4)
end select
selection_weight(:) = selection_weight(:)/sum(selection_weight(:))
print *, '# Total weight ', real(selection_weight(:),4)
END_PROVIDER

8
src/cipsi/slave_cipsi.irp.f
View File

@ -4,7 +4,7 @@ subroutine run_slave_cipsi
! Helper program for distributed parallelism
END_DOC
call set_multiple_levels_omp(.False.)
call omp_set_max_active_levels(1)
distributed_davidson = .False.
read_wf = .False.
SOFT_TOUCH read_wf distributed_davidson
@ -171,9 +171,9 @@ subroutine run_slave_main
call write_double(6,(t1-t0),'Broadcast time')
!---
call set_multiple_levels_omp(.True.)
call omp_set_max_active_levels(8)
call davidson_slave_tcp(0)
call set_multiple_levels_omp(.False.)
call omp_set_max_active_levels(1)
print *, mpi_rank, ': Davidson done'
!---
@ -311,7 +311,7 @@ subroutine run_slave_main
if (mpi_master) then
print *, 'Running PT2'
endif
!$OMP PARALLEL PRIVATE(i) NUM_THREADS(nproc_target)
!$OMP PARALLEL PRIVATE(i) NUM_THREADS(nproc_target+1)
i = omp_get_thread_num()
call run_pt2_slave(0,i,pt2_e0_denominator)
!$OMP END PARALLEL

4
src/cipsi/stochastic_cipsi.irp.f
View File

@ -69,8 +69,8 @@ subroutine run_stochastic_cipsi
do while ( &
(N_det < N_det_max) .and. &
(sum(abs(pt2_data % pt2(1:N_states)) * state_average_weight(1:N_states)) > pt2_max) .and. &
(sum(abs(pt2_data % variance(1:N_states)) * state_average_weight(1:N_states)) > variance_max) .and. &
(maxval(abs(pt2_data % pt2(1:N_states))) > pt2_max) .and. &
(maxval(abs(pt2_data % variance(1:N_states))) > variance_max) .and. &
(correlation_energy_ratio <= correlation_energy_ratio_max) &
)
write(*,'(A)') '--------------------------------------------------------------------------------'

223
src/cipsi/update_2rdm.irp.f Normal file
View File

@ -0,0 +1,223 @@
use bitmasks
subroutine give_2rdm_pert_contrib(det,coef,psi_det_connection,psi_coef_connection_reverse,n_det_connection,nkeys,keys,values,sze_buff)
implicit none
integer, intent(in) :: n_det_connection,sze_buff
double precision, intent(in) :: coef(N_states)
integer(bit_kind), intent(in) :: det(N_int,2)
integer(bit_kind), intent(in) :: psi_det_connection(N_int,2,n_det_connection)
double precision, intent(in) :: psi_coef_connection_reverse(N_states,n_det_connection)
integer, intent(inout) :: keys(4,sze_buff),nkeys
double precision, intent(inout) :: values(sze_buff)
integer :: i,j
integer :: exc(0:2,2,2)
integer :: degree
double precision :: phase, contrib
do i = 1, n_det_connection
call get_excitation(det,psi_det_connection(1,1,i),exc,degree,phase,N_int)
if(degree.gt.2)cycle
contrib = 0.d0
do j = 1, N_states
contrib += state_average_weight(j) * psi_coef_connection_reverse(j,i) * phase * coef(j)
enddo
! case of single excitations
if(degree == 1)then
if (nkeys + 6 * elec_alpha_num .ge. sze_buff)then
call update_keys_values(keys,values,nkeys,n_orb_pert_rdm,pert_2rdm_provider,pert_2rdm_lock)
nkeys = 0
endif
call update_buffer_single_exc_rdm(det,psi_det_connection(1,1,i),exc,phase,contrib,nkeys,keys,values,sze_buff)
else
!! case of double excitations
! if (nkeys + 4 .ge. sze_buff)then
! call update_keys_values(keys,values,nkeys,n_orb_pert_rdm,pert_2rdm_provider,pert_2rdm_lock)
! nkeys = 0
! endif
! call update_buffer_double_exc_rdm(exc,phase,contrib,nkeys,keys,values,sze_buff)
endif
enddo
!call update_keys_values(keys,values,nkeys,n_orb_pert_rdm,pert_2rdm_provider,pert_2rdm_lock)
!nkeys = 0
end
subroutine update_buffer_single_exc_rdm(det1,det2,exc,phase,contrib,nkeys,keys,values,sze_buff)
implicit none
integer, intent(in) :: sze_buff
integer(bit_kind), intent(in) :: det1(N_int,2)
integer(bit_kind), intent(in) :: det2(N_int,2)
integer,intent(in) :: exc(0:2,2,2)
double precision,intent(in) :: phase, contrib
integer, intent(inout) :: nkeys, keys(4,sze_buff)
double precision, intent(inout):: values(sze_buff)
integer :: occ(N_int*bit_kind_size,2)
integer :: n_occ_ab(2),ispin,other_spin
integer :: h1,h2,p1,p2,i
call bitstring_to_list_ab(det1, occ, n_occ_ab, N_int)
if (exc(0,1,1) == 1) then
! Mono alpha
h1 = exc(1,1,1)
p1 = exc(1,2,1)
ispin = 1
other_spin = 2
else
! Mono beta
h1 = exc(1,1,2)
p1 = exc(1,2,2)
ispin = 2
other_spin = 1
endif
if(list_orb_reverse_pert_rdm(h1).lt.0)return
h1 = list_orb_reverse_pert_rdm(h1)
if(list_orb_reverse_pert_rdm(p1).lt.0)return
p1 = list_orb_reverse_pert_rdm(p1)
!update the alpha/beta part
do i = 1, n_occ_ab(other_spin)
h2 = occ(i,other_spin)
if(list_orb_reverse_pert_rdm(h2).lt.0)return
h2 = list_orb_reverse_pert_rdm(h2)
nkeys += 1
values(nkeys) = 0.5d0 * contrib * phase
keys(1,nkeys) = h1
keys(2,nkeys) = h2
keys(3,nkeys) = p1
keys(4,nkeys) = h2
nkeys += 1
values(nkeys) = 0.5d0 * contrib * phase
keys(1,nkeys) = h2
keys(2,nkeys) = h1
keys(3,nkeys) = h2
keys(4,nkeys) = p1
enddo
!update the same spin part
!do i = 1, n_occ_ab(ispin)
! h2 = occ(i,ispin)
! if(list_orb_reverse_pert_rdm(h2).lt.0)return
! h2 = list_orb_reverse_pert_rdm(h2)
! nkeys += 1
! values(nkeys) = 0.5d0 * contrib * phase
! keys(1,nkeys) = h1
! keys(2,nkeys) = h2
! keys(3,nkeys) = p1
! keys(4,nkeys) = h2
! nkeys += 1
! values(nkeys) = - 0.5d0 * contrib * phase
! keys(1,nkeys) = h1
! keys(2,nkeys) = h2
! keys(3,nkeys) = h2
! keys(4,nkeys) = p1
!
! nkeys += 1
! values(nkeys) = 0.5d0 * contrib * phase
! keys(1,nkeys) = h2
! keys(2,nkeys) = h1
! keys(3,nkeys) = h2
! keys(4,nkeys) = p1
! nkeys += 1
! values(nkeys) = - 0.5d0 * contrib * phase
! keys(1,nkeys) = h2
! keys(2,nkeys) = h1
! keys(3,nkeys) = p1
! keys(4,nkeys) = h2
!enddo
end
subroutine update_buffer_double_exc_rdm(exc,phase,contrib,nkeys,keys,values,sze_buff)
implicit none
integer, intent(in) :: sze_buff
integer,intent(in) :: exc(0:2,2,2)
double precision,intent(in) :: phase, contrib
integer, intent(inout) :: nkeys, keys(4,sze_buff)
double precision, intent(inout):: values(sze_buff)
integer :: h1,h2,p1,p2
if (exc(0,1,1) == 1) then
! Double alpha/beta
h1 = exc(1,1,1)
h2 = exc(1,1,2)
p1 = exc(1,2,1)
p2 = exc(1,2,2)
! check if the orbitals involved are within the orbital range
if(list_orb_reverse_pert_rdm(h1).lt.0)return
h1 = list_orb_reverse_pert_rdm(h1)
if(list_orb_reverse_pert_rdm(h2).lt.0)return
h2 = list_orb_reverse_pert_rdm(h2)
if(list_orb_reverse_pert_rdm(p1).lt.0)return
p1 = list_orb_reverse_pert_rdm(p1)
if(list_orb_reverse_pert_rdm(p2).lt.0)return
p2 = list_orb_reverse_pert_rdm(p2)
nkeys += 1
values(nkeys) = 0.5d0 * contrib * phase
keys(1,nkeys) = h1
keys(2,nkeys) = h2
keys(3,nkeys) = p1
keys(4,nkeys) = p2
nkeys += 1
values(nkeys) = 0.5d0 * contrib * phase
keys(1,nkeys) = p1
keys(2,nkeys) = p2
keys(3,nkeys) = h1
keys(4,nkeys) = h2
else
if (exc(0,1,1) == 2) then
! Double alpha/alpha
h1 = exc(1,1,1)
h2 = exc(2,1,1)
p1 = exc(1,2,1)
p2 = exc(2,2,1)
else if (exc(0,1,2) == 2) then
! Double beta
h1 = exc(1,1,2)
h2 = exc(2,1,2)
p1 = exc(1,2,2)
p2 = exc(2,2,2)
endif
! check if the orbitals involved are within the orbital range
if(list_orb_reverse_pert_rdm(h1).lt.0)return
h1 = list_orb_reverse_pert_rdm(h1)
if(list_orb_reverse_pert_rdm(h2).lt.0)return
h2 = list_orb_reverse_pert_rdm(h2)
if(list_orb_reverse_pert_rdm(p1).lt.0)return
p1 = list_orb_reverse_pert_rdm(p1)
if(list_orb_reverse_pert_rdm(p2).lt.0)return
p2 = list_orb_reverse_pert_rdm(p2)
nkeys += 1
values(nkeys) = 0.5d0 * contrib * phase
keys(1,nkeys) = h1
keys(2,nkeys) = h2
keys(3,nkeys) = p1
keys(4,nkeys) = p2
nkeys += 1
values(nkeys) = - 0.5d0 * contrib * phase
keys(1,nkeys) = h1
keys(2,nkeys) = h2
keys(3,nkeys) = p2
keys(4,nkeys) = p1
nkeys += 1
values(nkeys) = 0.5d0 * contrib * phase
keys(1,nkeys) = h2
keys(2,nkeys) = h1
keys(3,nkeys) = p2
keys(4,nkeys) = p1
nkeys += 1
values(nkeys) = - 0.5d0 * contrib * phase
keys(1,nkeys) = h2
keys(2,nkeys) = h1
keys(3,nkeys) = p1
keys(4,nkeys) = p2
endif
end

2
src/cipsi/zmq_selection.irp.f
View File

@ -22,7 +22,7 @@ subroutine ZMQ_selection(N_in, pt2_data)
PROVIDE psi_bilinear_matrix_transp_rows_loc psi_bilinear_matrix_transp_columns
PROVIDE psi_bilinear_matrix_transp_order selection_weight pseudo_sym
PROVIDE n_act_orb n_inact_orb n_core_orb n_virt_orb n_del_orb seniority_max
PROVIDE excitation_beta_max excitation_alpha_max excitation_max
PROVIDE pert_2rdm excitation_beta_max excitation_alpha_max excitation_max
call new_parallel_job(zmq_to_qp_run_socket,zmq_socket_pull,'selection')

11
src/cis/cis.irp.f
View File

@ -62,7 +62,6 @@ subroutine run
else
call H_apply_cis
endif
print*,''
print *, 'N_det = ', N_det
print*,'******************************'
print *, 'Energies of the states:'
@ -70,18 +69,16 @@ subroutine run
print *, i, CI_energy(i)
enddo
if (N_states > 1) then
print*,''
print*,'******************************************************'
print*,'Excitation energies (au) (eV)'
print*,'******************************'
print*,'Excitation energies '
do i = 2, N_states
print*, i ,CI_energy(i) - CI_energy(1), (CI_energy(i) - CI_energy(1)) * ha_to_ev
print*, i ,CI_energy(i) - CI_energy(1)
enddo
print*,''
endif
call ezfio_set_cis_energy(CI_energy)
psi_coef = ci_eigenvectors
SOFT_TOUCH psi_coef
call save_wavefunction_truncated(save_threshold)
call save_wavefunction_truncated(1.d-12)
end

7
src/cis_read/EZFIO.cfg
View File

@ -1,7 +0,0 @@
[energy]
type: double precision
doc: Variational |CIS| energy
interface: ezfio
size: (determinants.n_states)

3
src/cis_read/NEED
View File

@ -1,3 +0,0 @@
selectors_full
generators_full
davidson_undressed

5
src/cis_read/README.rst
View File

@ -1,5 +0,0 @@
===
cis_read
===
Reads the input WF and performs all singles on top of it.

88
src/cis_read/cis_read.irp.f
View File

@ -1,88 +0,0 @@
program cis
implicit none
BEGIN_DOC
!
! Configuration Interaction with Single excitations.
!
! This program takes a reference Slater determinant of ROHF-like
! occupancy, and performs all single excitations on top of it.
! Disregarding spatial symmetry, it computes the `n_states` lowest
! eigenstates of that CI matrix. (see :option:`determinants n_states`)
!
! This program can be useful in many cases:
!
!
! 1. Ground state calculation
!
! To be sure to have the lowest |SCF| solution, perform an :ref:`scf`
! (see the :ref:`module_hartree_fock` module), then a :ref:`cis`, save the
! natural orbitals (see :ref:`save_natorb`) and re-run an :ref:`scf`
! optimization from this |MO| guess.
!
!
! 2. Excited states calculations
!
! The lowest excited states are much likely to be dominated by
! single-excitations. Therefore, running a :ref:`cis` will save the
! `n_states` lowest states within the |CIS| space in the |EZFIO|
! directory, which can afterwards be used as guess wave functions for
! a further multi-state |FCI| calculation if :option:`determinants
! read_wf` is set to |true| before running the :ref:`fci` executable.
!
!
! If :option:`determinants s2_eig` is set to |true|, the |CIS|
! will only retain states having the expected |S^2| value (see
! :option:`determinants expected_s2`). Otherwise, the |CIS| will take
! the lowest :option:`determinants n_states`, whatever multiplicity
! they are.
!
! .. note::
!
! To discard some orbitals, use the :ref:`qp_set_mo_class`
! command to specify:
!
! * *core* orbitals which will be always doubly occupied
!
! * *act* orbitals where an electron can be either excited from or to
!
! * *del* orbitals which will be never occupied
!
END_DOC
read_wf = .True.
TOUCH read_wf
call run
end
subroutine run
implicit none
integer :: i
if(pseudo_sym)then
call H_apply_cis_sym
else
call H_apply_cis
endif
print*,''
print *, 'N_det = ', N_det
print*,'******************************'
print *, 'Energies of the states:'
do i = 1,N_states
print *, i, CI_energy(i)
enddo
if (N_states > 1) then
print*,''
print*,'******************************************************'
print*,'Excitation energies (au) (eV)'
do i = 2, N_states
print*, i ,CI_energy(i) - CI_energy(1), (CI_energy(i) - CI_energy(1))/0.0367502d0
enddo
print*,''
endif
call ezfio_set_cis_energy(CI_energy)
psi_coef = ci_eigenvectors
SOFT_TOUCH psi_coef
call save_wavefunction_truncated(save_threshold)
end

14
src/cis_read/h_apply.irp.f
View File

@ -1,14 +0,0 @@
! Generates subroutine H_apply_cis
! --------------------------------
BEGIN_SHELL [ /usr/bin/env python3 ]
from generate_h_apply import H_apply
H = H_apply("cis",do_double_exc=False)
print(H)
H = H_apply("cis_sym",do_double_exc=False)
H.filter_only_connected_to_hf()
print(H)
END_SHELL

94
src/cisd/cisd.irp.f
View File

@ -47,37 +47,6 @@ program cisd
PROVIDE N_states
read_wf = .False.
SOFT_TOUCH read_wf
integer :: i,k
if(pseudo_sym)then
call H_apply_cisd_sym
else
call H_apply_cisd
endif
double precision :: r1, r2
double precision, allocatable :: U_csf(:,:)
allocate(U_csf(N_csf,N_states))
U_csf = 0.d0
U_csf(1,1) = 1.d0
do k=2,N_states
do i=1,N_csf
call random_number(r1)
call random_number(r2)
r1 = dsqrt(-2.d0*dlog(r1))
r2 = dacos(-1.d0)*2.d0*r2
U_csf(i,k) = r1*dcos(r2)
enddo
U_csf(k,k) = U_csf(k,k) +100.d0
enddo
do k=1,N_states
call normalize(U_csf(1,k),N_csf)
enddo
call convertWFfromCSFtoDET(N_states,U_csf(1,1),psi_coef(1,1))
deallocate(U_csf)
SOFT_TOUCH psi_coef
call run
end
@ -87,16 +56,20 @@ subroutine run
double precision :: cisdq(N_states), delta_e
double precision,external :: diag_h_mat_elem
if(pseudo_sym)then
call H_apply_cisd_sym
else
call H_apply_cisd
endif
psi_coef = ci_eigenvectors
call save_wavefunction_truncated(save_threshold)
SOFT_TOUCH psi_coef
call save_wavefunction
call ezfio_set_cisd_energy(CI_energy)
do i = 1,N_states
k = maxloc(dabs(psi_coef_sorted(1:N_det,i)),dim=1)
delta_E = CI_electronic_energy(i) - diag_h_mat_elem(psi_det_sorted(1,1,k),N_int)
if (elec_alpha_num + elec_beta_num >= 4) then
cisdq(i) = CI_energy(i) + delta_E * (1.d0 - psi_coef_sorted(k,i)**2)
endif
cisdq(i) = CI_energy(i) + delta_E * (1.d0 - psi_coef_sorted(k,i)**2)
enddo
print *, 'N_det = ', N_det
print*,''
@ -105,43 +78,26 @@ subroutine run
do i = 1,N_states
print *, i, CI_energy(i)
enddo
if (elec_alpha_num + elec_beta_num >= 4) then
print*,''
print*,'******************************'
print *, 'CISD+Q Energies'
do i = 1,N_states
print *, i, cisdq(i)
enddo
if (N_states > 1) then
print*,''
print*,'******************************'
print *, 'CISD+Q Energies'
do i = 1,N_states
print *, i, cisdq(i)
print*,'Excitation energies (au) (CISD+Q)'
do i = 2, N_states
print*, i ,CI_energy(i) - CI_energy(1), cisdq(i) - cisdq(1)
enddo
print*,''
print*,'******************************'
print*,'Excitation energies (eV) (CISD+Q)'
do i = 2, N_states
print*, i ,(CI_energy(i) - CI_energy(1))/0.0367502d0, &
(cisdq(i) - cisdq(1)) / 0.0367502d0
enddo
endif
if (N_states > 1) then
if (elec_alpha_num + elec_beta_num >= 4) then
print*,''
print*,'******************************'
print*,'Excitation energies (au) (CISD+Q)'
do i = 2, N_states
print*, i ,CI_energy(i) - CI_energy(1), cisdq(i) - cisdq(1)
enddo
print*,''
print*,'******************************'
print*,'Excitation energies (eV) (CISD+Q)'
do i = 2, N_states
print*, i ,(CI_energy(i) - CI_energy(1)) * ha_to_ev, &
(cisdq(i) - cisdq(1)) * ha_to_ev
enddo
else
print*,''
print*,'******************************'
print*,'Excitation energies (au) (CISD)'
do i = 2, N_states
print*, i ,CI_energy(i) - CI_energy(1)
enddo
print*,''
print*,'******************************'
print*,'Excitation energies (eV) (CISD)'
do i = 2, N_states
print*, i ,(CI_energy(i) - CI_energy(1)) * ha_to_ev
enddo
endif
endif
end

24
src/csf/configurations.irp.f
View File

@ -779,7 +779,6 @@ subroutine binary_search_cfg(cfgInp,addcfg)
end subroutine
BEGIN_PROVIDER [ integer, psi_configuration_to_psi_det, (2,N_configuration) ]
&BEGIN_PROVIDER [ integer, psi_configuration_n_det, (N_configuration) ]
&BEGIN_PROVIDER [ integer, psi_configuration_to_psi_det_data, (N_det) ]
implicit none
@ -868,29 +867,6 @@ end subroutine
enddo
deallocate(dets, old_order)
integer :: ndet_conf
do i = 1, N_configuration
ndet_conf = psi_configuration_to_psi_det(2,i) - psi_configuration_to_psi_det(1,i) + 1
psi_configuration_n_det(i) = ndet_conf
enddo
END_PROVIDER
BEGIN_PROVIDER [ integer, n_elec_alpha_for_psi_configuration, (N_configuration)]
implicit none
integer :: i,j,k,l
integer(bit_kind) :: det_tmp(N_int,2),det_alpha(N_int)
n_elec_alpha_for_psi_configuration = 0
do i = 1, N_configuration
j = psi_configuration_to_psi_det(2,i)
det_tmp(:,:) = psi_det(:,:,j)
k = 0
do l = 1, N_int
det_alpha(N_int) = iand(det_tmp(l,1),psi_configuration(l,1,i))
k += popcnt(det_alpha(l))
enddo
n_elec_alpha_for_psi_configuration(i) = k
enddo
END_PROVIDER

23
src/csf/conversion.irp.f
View File

@ -1,15 +1,3 @@
BEGIN_PROVIDER [ double precision, psi_csf_coef, (N_csf, N_states) ]
implicit none
BEGIN_DOC
! Wafe function in CSF basis
END_DOC
double precision, allocatable :: buffer(:,:)
allocate ( buffer(N_det, N_states) )
buffer(1:N_det, 1:N_states) = psi_coef(1:N_det, 1:N_states)
call convertWFfromDETtoCSF(N_states, buffer, psi_csf_coef)
END_PROVIDER
subroutine convertWFfromDETtoCSF(N_st,psi_coef_det_in, psi_coef_cfg_out)
use cfunctions
use bitmasks
@ -38,8 +26,6 @@ subroutine convertWFfromDETtoCSF(N_st,psi_coef_det_in, psi_coef_cfg_out)
integer s, bfIcfg
integer countcsf
integer MS
MS = elec_alpha_num-elec_beta_num
countcsf = 0
phasedet = 1.0d0
do i = 1,N_configuration
@ -58,17 +44,12 @@ subroutine convertWFfromDETtoCSF(N_st,psi_coef_det_in, psi_coef_cfg_out)
enddo
enddo
s = 0 ! s == total number of SOMOs
s = 0
do k=1,N_int
if (psi_configuration(k,1,i) == 0_bit_kind) cycle
s = s + popcnt(psi_configuration(k,1,i))
enddo
if(iand(s,1) .EQ. 0) then
bfIcfg = max(1,nint((binom(s,s/2)-binom(s,(s/2)+1))))
else
bfIcfg = max(1,nint((binom(s,(s+1)/2)-binom(s,((s+1)/2)+1))))
endif
bfIcfg = max(1,nint((binom(s,(s+1)/2)-binom(s,((s+1)/2)+1))))
! perhaps blocking with CFGs of same seniority
! can be more efficient

75
src/csf/sigma_vector.irp.f
View File

@ -1,12 +1,9 @@
real*8 function logabsgamma(x)
implicit none
real*8, intent(in) :: x
logabsgamma = 1.d32 ! Avoid floating point exception
if (x>0.d0) then
logabsgamma = log(abs(gamma(x)))
endif
logabsgamma = log(abs(gamma(x)))
end function logabsgamma
BEGIN_PROVIDER [ integer, NSOMOMax]
&BEGIN_PROVIDER [ integer, NCSFMax]
&BEGIN_PROVIDER [ integer*8, NMO]
@ -51,60 +48,42 @@
if(cfg_seniority_index(i+2) > ncfgpersomo) then
ncfgpersomo = cfg_seniority_index(i+2)
else
! l = i+k+2
! Loop over l with a constraint to ensure that l <= size(cfg_seniority_index,1)-1
! Old version commented just below
do l = min(size(cfg_seniority_index,1)-1, i+2), size(cfg_seniority_index,1)-1, 2
if (cfg_seniority_index(l) >= ncfgpersomo) then
ncfgpersomo = cfg_seniority_index(l)
endif
k = 0
do while(cfg_seniority_index(i+2+k) < ncfgpersomo)
k = k + 2
ncfgpersomo = cfg_seniority_index(i+2+k)
enddo
!k = 0
!if ((i+2+k) < size(cfg_seniority_index,1)) then
! do while(cfg_seniority_index(i+2+k) < ncfgpersomo)
! k = k + 2
! if ((i+2+k) >= size(cfg_seniority_index,1)) then
! exit
! endif
! ncfgpersomo = cfg_seniority_index(i+2+k)
! enddo
!endif
endif
endif
ncfg = ncfgpersomo - ncfgprev
if(i .EQ. 0 .OR. i .EQ. 1) then
dimcsfpercfg = 1
elseif( i .EQ. 3) then
dimcsfpercfg = 2
if(iand(MS,1) .EQ. 0) then
!dimcsfpercfg = max(1,nint((binom(i,i/2)-binom(i,i/2+1))))
binom1 = dexp(logabsgamma(1.0d0*(i+1)) &
- logabsgamma(1.0d0*((i/2)+1)) &
- logabsgamma(1.0d0*(i-((i/2))+1)));
binom2 = dexp(logabsgamma(1.0d0*(i+1)) &
- logabsgamma(1.0d0*(((i/2)+1)+1)) &
- logabsgamma(1.0d0*(i-((i/2)+1)+1)));
dimcsfpercfg = max(1,nint(binom1 - binom2))
else
if(iand(MS,1) .EQ. 0) then
dimcsfpercfg = max(1,nint((binom(i,i/2)-binom(i,i/2+1))))
else
dimcsfpercfg = max(1,nint((binom(i,(i+1)/2)-binom(i,(i+3)/2))))
endif
!dimcsfpercfg = max(1,nint((binom(i,(i+1)/2)-binom(i,(i+3)/2))))
binom1 = dexp(logabsgamma(1.0d0*(i+1)) &
- logabsgamma(1.0d0*(((i+1)/2)+1)) &
- logabsgamma(1.0d0*(i-(((i+1)/2))+1)));
binom2 = dexp(logabsgamma(1.0d0*(i+1)) &
- logabsgamma(1.0d0*((((i+3)/2)+1)+1)) &
- logabsgamma(1.0d0*(i-(((i+3)/2)+1)+1)));
dimcsfpercfg = max(1,nint(binom1 - binom2))
endif
n_CSF += ncfg * dimcsfpercfg
if(cfg_seniority_index(i+2) > ncfgprev) then
ncfgprev = cfg_seniority_index(i+2)
else
! l = i+k+2
! Loop over l with a constraint to ensure that l <= size(cfg_seniority_index,1)-1
! Old version commented just below
do l = min(size(cfg_seniority_index,1)-1, i+2), size(cfg_seniority_index,1)-1, 2
if (cfg_seniority_index(l) >= ncfgprev) then
ncfgprev = cfg_seniority_index(l)
endif
k = 0
do while(cfg_seniority_index(i+2+k) < ncfgprev)
k = k + 2
ncfgprev = cfg_seniority_index(i+2+k)
enddo
!k = 0
!if ((i+2+k) < size(cfg_seniority_index,1)) then
! do while(cfg_seniority_index(i+2+k) < ncfgprev)
! k = k + 2
! if ((i+2+k) >= size(cfg_seniority_index,1)) then
! exit
! endif
! ncfgprev = cfg_seniority_index(i+2+k)
! enddo
!endif
endif
enddo
END_PROVIDER

3
src/dav_general_mat/NEED
View File

@ -1 +1,2 @@
davidson_undressed
determinants
davidson_keywords

32
src/dav_general_mat/dav_diag_dressed_ext_rout.irp.f
View File

@ -1,5 +1,5 @@
subroutine davidson_general_ext_rout_diag_dressed(u_in,H_jj,Dress_jj,energies,sze,N_st,N_st_diag_in,converged,hcalc)
subroutine davidson_general_ext_rout(u_in,H_jj,Dress_jj,energies,sze,N_st,N_st_diag_in,converged,hcalc)
use mmap_module
implicit none
BEGIN_DOC
@ -412,6 +412,36 @@ subroutine davidson_general_ext_rout_diag_dressed(u_in,H_jj,Dress_jj,energies,sz
FREE nthreads_davidson
end
subroutine hcalc_template(v,u,N_st,sze)
use bitmasks
implicit none
BEGIN_DOC
! Template of routine for the application of H
!
! Here, it is done with the Hamiltonian matrix
!
! on the set of determinants of psi_det
!
! Computes $v = H | u \rangle$
!
END_DOC
integer, intent(in) :: N_st,sze
double precision, intent(in) :: u(sze,N_st)
double precision, intent(inout) :: v(sze,N_st)
integer :: i,j,istate
v = 0.d0
do istate = 1, N_st
do i = 1, sze
do j = 1, sze
v(i,istate) += H_matrix_all_dets(j,i) * u(j,istate)
enddo
enddo
do i = 1, sze
v(i,istate) += u(i,istate) * nuclear_repulsion
enddo
enddo
end
subroutine dressing_diag_uv(v,u,dress_diag,N_st,sze)
implicit none
BEGIN_DOC

4
src/dav_general_mat/dav_ext_rout.irp.f
View File

@ -247,8 +247,8 @@ subroutine davidson_general_ext_rout(u_in,H_jj,energies,sze,N_st,N_st_diag_in,co
if (state_following) then
overlap = -1.d0
do k=1,shift2
do i=1,shift2
do i=1,shift2
do k=1,shift2
overlap(k,i) = dabs(y(k,i))
enddo
enddo

233
src/dav_general_mat/dav_ext_rout_nonsym_B1space.irp.f
View File

@ -34,7 +34,7 @@ subroutine davidson_general_ext_rout_nonsym_b1space(u_in, H_jj, energies, sze, N
character*(16384) :: write_buffer
integer :: iter, N_st_diag
integer :: i, j, k, m
integer :: i, j, k, l, m
integer :: iter2, itertot
logical :: disk_based
integer :: shift, shift2, itermax
@ -49,8 +49,8 @@ subroutine davidson_general_ext_rout_nonsym_b1space(u_in, H_jj, energies, sze, N
double precision, allocatable :: y(:,:), h(:,:), lambda(:)
double precision, allocatable :: residual_norm(:)
integer :: i_omax
double precision :: lambda_tmp
integer, allocatable :: i_omax(:)
double precision, allocatable :: U_tmp(:), overlap(:)
double precision, allocatable :: W(:,:)
@ -181,7 +181,8 @@ subroutine davidson_general_ext_rout_nonsym_b1space(u_in, H_jj, energies, sze, N
h(N_st_diag*itermax,N_st_diag*itermax), &
y(N_st_diag*itermax,N_st_diag*itermax), &
lambda(N_st_diag*itermax), &
residual_norm(N_st_diag) &
residual_norm(N_st_diag), &
i_omax(N_st) &
)
U = 0.d0
@ -313,59 +314,42 @@ subroutine davidson_general_ext_rout_nonsym_b1space(u_in, H_jj, energies, sze, N
! end test ------------------------------------------------------------------------
!
! TODO
! state_following is more efficient
do l = 1, N_st
allocate( overlap(N_st_diag) )
allocate( overlap(N_st_diag) )
do k = 1, N_st_diag
overlap(k) = 0.d0
do i = 1, sze
overlap(k) = overlap(k) + U(i,shift2+k) * u_in(i,1)
do k = 1, N_st_diag
overlap(k) = 0.d0
do i = 1, sze
overlap(k) = overlap(k) + U(i,shift2+k) * u_in(i,l)
enddo
overlap(k) = dabs(overlap(k))
!print *, ' overlap =', k, overlap(k)
enddo
overlap(k) = dabs(overlap(k))
!print *, ' overlap =', k, overlap(k)
enddo
lambda_tmp = 0.d0
do k = 1, N_st_diag
if(overlap(k) .gt. lambda_tmp) then
i_omax = k
lambda_tmp = overlap(k)
lambda_tmp = 0.d0
do k = 1, N_st_diag
if(overlap(k) .gt. lambda_tmp) then
i_omax(l) = k
lambda_tmp = overlap(k)
endif
enddo
deallocate(overlap)
if(lambda_tmp .lt. 0.7d0) then
print *, ' very small overlap ...', l, i_omax(l)
print *, ' max overlap = ', lambda_tmp
stop
endif
if(i_omax(l) .ne. l) then
print *, ' !!! WARNONG !!!'
print *, ' index of state', l, i_omax(l)
endif
enddo
deallocate(overlap)
if( lambda_tmp .lt. 0.5d0) then
print *, ' very small overlap..'
print*, ' max overlap = ', lambda_tmp, i_omax
stop
endif
! lambda_tmp = lambda(1)
! lambda(1) = lambda(i_omax)
! lambda(i_omax) = lambda_tmp
!
! allocate( U_tmp(sze) )
! do i = 1, sze
! U_tmp(i) = U(i,shift2+1)
! U(i,shift2+1) = U(i,shift2+i_omax)
! U(i,shift2+i_omax) = U_tmp(i)
! enddo
! deallocate(U_tmp)
!
! allocate( U_tmp(N_st_diag*itermax) )
! do i = 1, shift2
! U_tmp(i) = y(i,1)
! y(i,1) = y(i,i_omax)
! y(i,i_omax) = U_tmp(i)
! enddo
! deallocate(U_tmp)
! ---
!do k = 1, N_st_diag
! call normalize(U(1,shift2+k), sze)
!enddo
! ---
! y(:,k) = rk
! W(:,k) = H x Bk
@ -385,16 +369,17 @@ subroutine davidson_general_ext_rout_nonsym_b1space(u_in, H_jj, energies, sze, N
do i = 1, sze
U(i,shift2+k) = (lambda(k) * U(i,shift2+k) - W(i,shift2+k)) / max(H_jj(i)-lambda(k), 1.d-2)
enddo
!if(k <= N_st) then
! residual_norm(k) = u_dot_u(U(1,shift2+k), sze)
! to_print(1,k) = lambda(k)
! to_print(2,k) = residual_norm(k)
!endif
if(k <= N_st) then
l = k
residual_norm(k) = u_dot_u(U(1,shift2+l), sze)
to_print(1,k) = lambda(l)
to_print(2,k) = residual_norm(l)
endif
enddo
!$OMP END PARALLEL DO
residual_norm(1) = u_dot_u(U(1,shift2+i_omax), sze)
to_print(1,1) = lambda(i_omax)
to_print(2,1) = residual_norm(1)
!residual_norm(1) = u_dot_u(U(1,shift2+1), sze)
!to_print(1,1) = lambda(1)
!to_print(2,1) = residual_norm(1)
if( (itertot > 1) .and. (iter == 1) ) then
@ -479,140 +464,10 @@ subroutine davidson_general_ext_rout_nonsym_b1space(u_in, H_jj, energies, sze, N
call write_time(6)
deallocate(W)
deallocate(U, h, y, lambda, residual_norm)
deallocate(U, h, y, lambda, residual_norm, i_omax)
FREE nthreads_davidson
end subroutine davidson_general_ext_rout_nonsym_b1space
! ---
subroutine diag_nonsym_right(n, A, A_ldim, V, V_ldim, energy, E_ldim)
implicit none
integer, intent(in) :: n, A_ldim, V_ldim, E_ldim
double precision, intent(in) :: A(A_ldim,n)
double precision, intent(out) :: energy(E_ldim), V(V_ldim,n)
character*1 :: JOBVL, JOBVR, BALANC, SENSE
integer :: i, j
integer :: ILO, IHI, lda, ldvl, ldvr, LWORK, INFO
double precision :: ABNRM
integer, allocatable :: iorder(:), IWORK(:)
double precision, allocatable :: WORK(:), SCALE_array(:), RCONDE(:), RCONDV(:)
double precision, allocatable :: Atmp(:,:), WR(:), WI(:), VL(:,:), VR(:,:), Vtmp(:)
double precision, allocatable :: energy_loc(:), V_loc(:,:)
allocate( Atmp(n,n), WR(n), WI(n), VL(1,1), VR(n,n) )
do i = 1, n
do j = 1, n
Atmp(j,i) = A(j,i)
enddo
enddo
JOBVL = "N" ! computes the left eigenvectors
JOBVR = "V" ! computes the right eigenvectors
BALANC = "B" ! Diagonal scaling and Permutation for optimization
SENSE = "V" ! Determines which reciprocal condition numbers are computed
lda = n
ldvr = n
ldvl = 1
allocate( WORK(1), SCALE_array(n), RCONDE(n), RCONDV(n), IWORK(2*n-2) )
LWORK = -1 ! to ask for the optimal size of WORK
call dgeevx( BALANC, JOBVL, JOBVR, SENSE & ! CHARACTERS
, n, Atmp, lda & ! MATRIX TO DIAGONALIZE
, WR, WI & ! REAL AND IMAGINARY PART OF EIGENVALUES
, VL, ldvl, VR, ldvr & ! LEFT AND RIGHT EIGENVECTORS
, ILO, IHI, SCALE_array, ABNRM, RCONDE, RCONDV & ! OUTPUTS OF OPTIMIZATION
, WORK, LWORK, IWORK, INFO )
if(INFO .ne. 0) then
print*, 'first dgeevx failed !!', INFO
stop
endif
LWORK = max(int(work(1)), 1) ! this is the optimal size of WORK
deallocate(WORK)
allocate(WORK(LWORK))
call dgeevx( BALANC, JOBVL, JOBVR, SENSE &
, n, Atmp, lda &
, WR, WI &
, VL, ldvl, VR, ldvr &
, ILO, IHI, SCALE_array, ABNRM, RCONDE, RCONDV &
, WORK, LWORK, IWORK, INFO )
if(INFO .ne. 0) then
print*, 'second dgeevx failed !!', INFO
stop
endif
deallocate( WORK, SCALE_array, RCONDE, RCONDV, IWORK )
deallocate( VL, Atmp )
allocate( energy_loc(n), V_loc(n,n) )
energy_loc = 0.d0
V_loc = 0.d0
i = 1
do while(i .le. n)
! print*, i, WR(i), WI(i)
if( dabs(WI(i)) .gt. 1e-7 ) then
print*, ' Found an imaginary component to eigenvalue'
print*, ' Re(i) + Im(i)', i, WR(i), WI(i)
energy_loc(i) = WR(i)
do j = 1, n
V_loc(j,i) = WR(i) * VR(j,i) - WI(i) * VR(j,i+1)
enddo
energy_loc(i+1) = WI(i)
do j = 1, n
V_loc(j,i+1) = WR(i) * VR(j,i+1) + WI(i) * VR(j,i)
enddo
i = i + 2
else
energy_loc(i) = WR(i)
do j = 1, n
V_loc(j,i) = VR(j,i)
enddo
i = i + 1
endif
enddo
deallocate(WR, WI, VR)
! ordering
! do j = 1, n
! write(444, '(100(1X, F16.10))') (V_loc(j,i), i=1,5)
! enddo
allocate( iorder(n) )
do i = 1, n
iorder(i) = i
enddo
call dsort(energy_loc, iorder, n)
do i = 1, n
energy(i) = energy_loc(i)
do j = 1, n
V(j,i) = V_loc(j,iorder(i))
enddo
enddo
deallocate(iorder)
! do j = 1, n
! write(445, '(100(1X, F16.10))') (V_loc(j,i), i=1,5)
! enddo
deallocate(V_loc, energy_loc)
end subroutine diag_nonsym_right
! ---

4
src/dav_general_mat/dav_general.irp.f
View File

@ -258,8 +258,8 @@ subroutine davidson_general(u_in,H_jj,energies,dim_in,sze,N_st,N_st_diag_in,conv
if (state_following) then
overlap = -1.d0
do k=1,shift2
do i=1,shift2
do i=1,shift2
do k=1,shift2
overlap(k,i) = dabs(y(k,i))
enddo
enddo

48
src/davidson/EZFIO.cfg
View File

@ -1,63 +1,15 @@
[threshold_davidson]
type: Threshold
doc: Thresholds of Davidson's algorithm if threshold_davidson_from_pt2 is false.
interface: ezfio,provider,ocaml
default: 1.e-10
[threshold_davidson_from_pt2]
type: logical
doc: Thresholds of Davidson's algorithm is set to E(rPT2)*threshold_davidson_from_pt2
interface: ezfio,provider,ocaml
default: false
[n_states_diag]
type: States_number
doc: Controls the number of states to consider during the Davdison diagonalization. The number of states is n_states * n_states_diag
default: 4
interface: ezfio,ocaml
[davidson_sze_max]
type: Strictly_positive_int
doc: Number of micro-iterations before re-contracting
default: 15
interface: ezfio,provider,ocaml
[state_following]
type: logical
doc: If |true|, the states are re-ordered to match the input states
default: False
interface: ezfio,provider,ocaml
[disk_based_davidson]
type: logical
doc: If |true|, a memory-mapped file may be used to store the W and S2 vectors if not enough RAM is available
default: True
interface: ezfio,provider,ocaml
[csf_based]
type: logical
doc: If |true|, use the CSF-based algorithm
default: False
interface: ezfio,provider,ocaml
[distributed_davidson]
type: logical
doc: If |true|, use the distributed algorithm
default: True
interface: ezfio,provider,ocaml
[only_expected_s2]
type: logical
doc: If |true|, use filter out all vectors with bad |S^2| values
default: True
interface: ezfio,provider,ocaml
[n_det_max_full]
type: Det_number_max
doc: Maximum number of determinants where |H| is fully diagonalized
interface: ezfio,provider,ocaml
default: 1000
[without_diagonal]
type: logical
doc: If |true|, don't use denominator

1
src/davidson/NEED
View File

@ -1 +1,2 @@
csf
davidson_keywords

28
src/davidson/davidson_parallel.irp.f
View File

@ -508,7 +508,7 @@ subroutine H_S2_u_0_nstates_zmq(v_0,s_0,u_0,N_st,sze)
endif
call set_multiple_levels_omp(.True.)
call omp_set_max_active_levels(5)
!$OMP PARALLEL DEFAULT(shared) NUM_THREADS(2) PRIVATE(ithread)
ithread = omp_get_thread_num()
@ -546,19 +546,19 @@ end
BEGIN_PROVIDER [ integer, nthreads_davidson ]
implicit none
BEGIN_DOC
! Number of threads for Davidson
END_DOC
nthreads_davidson = nproc
character*(32) :: env
call getenv('QP_NTHREADS_DAVIDSON',env)
if (trim(env) /= '') then
read(env,*) nthreads_davidson
call write_int(6,nthreads_davidson,'Target number of threads for <Psi|H|Psi>')
endif
END_PROVIDER
!BEGIN_PROVIDER [ integer, nthreads_davidson ]
! implicit none
! BEGIN_DOC
! ! Number of threads for Davidson
! END_DOC
! nthreads_davidson = nproc
! character*(32) :: env
! call getenv('QP_NTHREADS_DAVIDSON',env)
! if (trim(env) /= '') then
! read(env,*) nthreads_davidson
! call write_int(6,nthreads_davidson,'Target number of threads for <Psi|H|Psi>')
! endif
!END_PROVIDER
integer function zmq_put_N_states_diag(zmq_to_qp_run_socket,worker_id)

3
src/davidson/davidson_parallel_csf.irp.f
View File

@ -464,8 +464,7 @@ subroutine H_u_0_nstates_zmq(v_0,u_0,N_st,sze)
print *, irp_here, ': Failed in zmq_set_running'
endif
call set_multiple_levels_omp(.True.)
call omp_set_max_active_levels(4)
!$OMP PARALLEL DEFAULT(shared) NUM_THREADS(2) PRIVATE(ithread)
ithread = omp_get_thread_num()
if (ithread == 0 ) then

3
src/davidson/davidson_parallel_nos2.irp.f
View File

@ -464,8 +464,7 @@ subroutine H_u_0_nstates_zmq(v_0,u_0,N_st,sze)
print *, irp_here, ': Failed in zmq_set_running'
endif
call set_multiple_levels_omp(.True.)
call omp_set_max_active_levels(4)
!$OMP PARALLEL DEFAULT(shared) NUM_THREADS(2) PRIVATE(ithread)
ithread = omp_get_thread_num()
if (ithread == 0 ) then

44
src/davidson/diagonalization_hcsf_dressed.irp.f
View File

@ -125,7 +125,7 @@ subroutine davidson_diag_csf_hjj(dets_in,u_in,H_jj,energies,dim_in,sze,sze_csf,N
stop -1
endif
itermax = max(2,min(davidson_sze_max, sze_csf/N_st_diag))+1
itermax = max(2,min(davidson_sze_max, sze/N_st_diag))+1
itertot = 0
if (state_following) then
@ -264,20 +264,29 @@ subroutine davidson_diag_csf_hjj(dets_in,u_in,H_jj,energies,dim_in,sze,sze_csf,N
! ===================
converged = .False.
call convertWFfromDETtoCSF(N_st_diag,u_in(1,1),U_csf(1,1))
do k=N_st+1,N_st_diag
do i=1,sze_csf
do i=1,sze
call random_number(r1)
call random_number(r2)
r1 = dsqrt(-2.d0*dlog(r1))
r2 = dtwo_pi*r2
U_csf(i,k) = r1*dcos(r2) * u_csf(i,k-N_st)
u_in(i,k) = r1*dcos(r2) * u_in(i,k-N_st)
enddo
U_csf(k,k) = u_csf(k,k) + 10.d0
u_in(k,k) = u_in(k,k) + 10.d0
enddo
do k=1,N_st_diag
call normalize(U_csf(1,k),sze_csf)
call normalize(u_in(1,k),sze)
enddo
do k=1,N_st_diag
do i=1,sze
U(i,k) = u_in(i,k)
enddo
enddo
! Make random verctors eigenstates of S2
call convertWFfromDETtoCSF(N_st_diag,U(1,1),U_csf(1,1))
call convertWFfromCSFtoDET(N_st_diag,U_csf(1,1),U(1,1))
do while (.not.converged)
@ -291,7 +300,7 @@ subroutine davidson_diag_csf_hjj(dets_in,u_in,H_jj,energies,dim_in,sze,sze_csf,N
shift = N_st_diag*(iter-1)
shift2 = N_st_diag*iter
! if ((iter > 1).or.(itertot == 1)) then
if ((iter > 1).or.(itertot == 1)) then
! Compute |W_k> = \sum_i |i><i|H|u_k>
! -----------------------------------
@ -301,10 +310,10 @@ subroutine davidson_diag_csf_hjj(dets_in,u_in,H_jj,energies,dim_in,sze,sze_csf,N
else
call H_u_0_nstates_openmp(W,U,N_st_diag,sze)
endif
! else
! ! Already computed in update below
! continue
! endif
else
! Already computed in update below
continue
endif
if (dressing_state > 0) then
@ -500,8 +509,17 @@ subroutine davidson_diag_csf_hjj(dets_in,u_in,H_jj,energies,dim_in,sze,sze_csf,N
enddo
! Re-contract U
! -------------
! Re-contract U and update W
! --------------------------------
call dgemm('N','N', sze_csf, N_st_diag, shift2, 1.d0, &
W_csf, size(W_csf,1), y, size(y,1), 0.d0, u_in, size(u_in,1))
do k=1,N_st_diag
do i=1,sze_csf
W_csf(i,k) = u_in(i,k)
enddo
enddo
call convertWFfromCSFtoDET(N_st_diag,W_csf,W)
call dgemm('N','N', sze_csf, N_st_diag, shift2, 1.d0, &
U_csf, size(U_csf,1), y, size(y,1), 0.d0, u_in, size(u_in,1))

39
src/davidson/diagonalization_hs2_dressed.irp.f
View File

@ -14,14 +14,14 @@ BEGIN_PROVIDER [ character*(64), diag_algorithm ]
endif
END_PROVIDER
BEGIN_PROVIDER [ double precision, threshold_davidson_pt2 ]
implicit none
BEGIN_DOC
! Threshold of Davidson's algorithm, using PT2 as a guide
END_DOC
threshold_davidson_pt2 = threshold_davidson
END_PROVIDER
!BEGIN_PROVIDER [ double precision, threshold_davidson_pt2 ]
! implicit none
! BEGIN_DOC
! ! Threshold of Davidson's algorithm, using PT2 as a guide
! END_DOC
! threshold_davidson_pt2 = threshold_davidson
!
!END_PROVIDER
@ -66,7 +66,7 @@ subroutine davidson_diag_hs2(dets_in,u_in,s2_out,dim_in,energies,sze,N_st,N_st_d
double precision, allocatable :: H_jj(:)
double precision, external :: diag_H_mat_elem, diag_S_mat_elem
integer :: i,k
integer :: i,k,l
ASSERT (N_st > 0)
ASSERT (sze > 0)
ASSERT (Nint > 0)
@ -86,10 +86,15 @@ subroutine davidson_diag_hs2(dets_in,u_in,s2_out,dim_in,energies,sze,N_st,N_st_d
!$OMP END PARALLEL
if (dressing_state > 0) then
do k=1,N_st
do i=1,sze
H_jj(i) += u_in(i,k) * dressing_column_h(i,k)
do k = 1, N_st
do i = 1, sze
H_jj(i) += u_in(i,k) * dressing_column_h(i,k)
enddo
!l = dressed_column_idx(k)
!H_jj(l) += u_in(l,k) * dressing_column_h(l,k)
enddo
endif
@ -349,7 +354,7 @@ subroutine davidson_diag_hjj_sjj(dets_in,u_in,H_jj,s2_out,energies,dim_in,sze,N_
shift = N_st_diag*(iter-1)
shift2 = N_st_diag*iter
! if ((iter > 1).or.(itertot == 1)) then
if ((iter > 1).or.(itertot == 1)) then
! Compute |W_k> = \sum_i |i><i|H|u_k>
! -----------------------------------
@ -359,10 +364,10 @@ subroutine davidson_diag_hjj_sjj(dets_in,u_in,H_jj,s2_out,energies,dim_in,sze,N_
call H_S2_u_0_nstates_openmp(W(1,shift+1),S_d,U(1,shift+1),N_st_diag,sze)
endif
S(1:sze,shift+1:shift+N_st_diag) = real(S_d(1:sze,1:N_st_diag))
! else
! ! Already computed in update below
! continue
! endif
else
! Already computed in update below
continue
endif
if (dressing_state > 0) then

541
src/davidson/diagonalization_nonsym_h_dressed.irp.f Normal file
View File

@ -0,0 +1,541 @@
! ---
subroutine davidson_diag_nonsym_h(dets_in, u_in, dim_in, energies, sze, N_st, N_st_diag, Nint, dressing_state, converged)
BEGIN_DOC
!
! non-sym Davidson diagonalization.
!
! dets_in : bitmasks corresponding to determinants
!
! u_in : guess coefficients on the various states. Overwritten on exit
!
! dim_in : leftmost dimension of u_in
!
! sze : Number of determinants
!
! N_st : Number of eigenstates
!
! Initial guess vectors are not necessarily orthonormal
!
END_DOC
use bitmasks
implicit none
integer, intent(in) :: dim_in, sze, N_st, N_st_diag, Nint
integer, intent(in) :: dressing_state
integer(bit_kind), intent(in) :: dets_in(Nint,2,sze)
logical, intent(out) :: converged
double precision, intent(out) :: energies(N_st_diag)
double precision, intent(inout) :: u_in(dim_in,N_st_diag)
integer :: i, k, l
double precision :: f
double precision, allocatable :: H_jj(:)
double precision, external :: diag_H_mat_elem
ASSERT (N_st > 0)
ASSERT (sze > 0)
ASSERT (Nint > 0)
ASSERT (Nint == N_int)
PROVIDE mo_two_e_integrals_in_map
allocate(H_jj(sze))
H_jj(1) = diag_H_mat_elem(dets_in(1,1,1), Nint)
!$OMP PARALLEL DEFAULT(NONE) &
!$OMP SHARED(sze, H_jj, dets_in, Nint) &
!$OMP PRIVATE(i)
!$OMP DO SCHEDULE(static)
do i = 2, sze
H_jj(i) = diag_H_mat_elem(dets_in(1,1,i), Nint)
enddo
!$OMP END DO
!$OMP END PARALLEL
if(dressing_state > 0) then
do k = 1, N_st
do l = 1, N_st
f = overlap_states_inv(k,l)
!do i = 1, N_det
! H_jj(i) += f * dressing_delta(i,k) * psi_coef(i,l)
do i = 1, dim_in
H_jj(i) += f * dressing_delta(i,k) * u_in(i,l)
enddo
enddo
enddo
endif
call davidson_diag_nonsym_hjj(dets_in, u_in, H_jj, energies, dim_in, sze, N_st, N_st_diag, Nint, dressing_state, converged)
deallocate(H_jj)
end subroutine davidson_diag_nonsym_h
! ---
subroutine davidson_diag_nonsym_hjj(dets_in, u_in, H_jj, energies, dim_in, sze, N_st, N_st_diag_in, Nint, dressing_state, converged)
BEGIN_DOC
!
! non-sym Davidson diagonalization with specific diagonal elements of the H matrix
!
! H_jj : specific diagonal H matrix elements to diagonalize de Davidson
!
! dets_in : bitmasks corresponding to determinants
!
! u_in : guess coefficients on the various states. Overwritten on exit
!
! dim_in : leftmost dimension of u_in
!
! sze : Number of determinants
!
! N_st : Number of eigenstates
!
! N_st_diag_in : Number of states in which H is diagonalized. Assumed > sze
!
! Initial guess vectors are not necessarily orthonormal
!
END_DOC
include 'constants.include.F'
use bitmasks
use mmap_module
implicit none
integer, intent(in) :: dim_in, sze, N_st, N_st_diag_in, Nint
integer, intent(in) :: dressing_state
integer(bit_kind), intent(in) :: dets_in(Nint,2,sze)
double precision, intent(in) :: H_jj(sze)
double precision, intent(out) :: energies(N_st_diag_in)
logical, intent(inout) :: converged
double precision, intent(inout) :: u_in(dim_in,N_st_diag_in)
logical :: disk_based
character*(16384) :: write_buffer
integer :: i, j, k, l, m
integer :: iter, N_st_diag, itertot, shift, shift2, itermax, istate
integer :: nproc_target
integer :: order(N_st_diag_in)
integer :: maxab
double precision :: rss
double precision :: cmax
double precision :: to_print(2,N_st)
double precision :: r1, r2
double precision :: f
double precision, allocatable :: y(:,:), h(:,:), lambda(:)
double precision, allocatable :: s_tmp(:,:), u_tmp(:,:)
double precision, allocatable :: residual_norm(:)
double precision, allocatable :: U(:,:), overlap(:,:)
double precision, pointer :: W(:,:)
double precision, external :: u_dot_u
N_st_diag = N_st_diag_in
!DIR$ ATTRIBUTES ALIGN : $IRP_ALIGN :: U, W, y, h, lambda
if(N_st_diag*3 > sze) then
print *, 'error in Davidson :'
print *, 'Increase n_det_max_full to ', N_st_diag*3
stop -1
endif
itermax = max(2, min(davidson_sze_max, sze/N_st_diag)) + 1
itertot = 0
if(state_following) then
allocate(overlap(N_st_diag*itermax, N_st_diag*itermax))
else
allocate(overlap(1,1)) ! avoid 'if' for deallocate
endif
overlap = 0.d0
PROVIDE nuclear_repulsion expected_s2 psi_bilinear_matrix_order psi_bilinear_matrix_order_reverse threshold_davidson_pt2 threshold_davidson_from_pt2
PROVIDE threshold_nonsym_davidson
call write_time(6)
write(6,'(A)') ''
write(6,'(A)') 'Davidson Diagonalization'
write(6,'(A)') '------------------------'
write(6,'(A)') ''
! Find max number of cores to fit in memory
! -----------------------------------------
nproc_target = nproc
maxab = max(N_det_alpha_unique, N_det_beta_unique) + 1
m=1
disk_based = .False.
call resident_memory(rss)
do
r1 = 8.d0 * &! bytes
( dble(sze)*(N_st_diag*itermax) &! U
+ 1.0d0*dble(sze*m)*(N_st_diag*itermax) &! W
+ 3.0d0*(N_st_diag*itermax)**2 &! h,y,s_tmp
+ 1.d0*(N_st_diag*itermax) &! lambda
+ 1.d0*(N_st_diag) &! residual_norm
! In H_u_0_nstates_zmq
+ 2.d0*(N_st_diag*N_det) &! u_t, v_t, on collector
+ 2.d0*(N_st_diag*N_det) &! u_t, v_t, on slave
+ 0.5d0*maxab &! idx0 in H_u_0_nstates_openmp_work_*
+ nproc_target * &! In OMP section
( 1.d0*(N_int*maxab) &! buffer
+ 3.5d0*(maxab) ) &! singles_a, singles_b, doubles, idx
) / 1024.d0**3
if(nproc_target == 0) then
call check_mem(r1, irp_here)
nproc_target = 1
exit
endif
if(r1+rss < qp_max_mem) then
exit
endif
if(itermax > 4) then
itermax = itermax - 1
else if(m==1 .and. disk_based_davidson) then
m = 0
disk_based = .True.
itermax = 6
else
nproc_target = nproc_target - 1
endif
enddo
nthreads_davidson = nproc_target
TOUCH nthreads_davidson
call write_int(6, N_st, 'Number of states')
call write_int(6, N_st_diag, 'Number of states in diagonalization')
call write_int(6, sze, 'Number of determinants')
call write_int(6, nproc_target, 'Number of threads for diagonalization')
call write_double(6, r1, 'Memory(Gb)')
if(disk_based) then
print *, 'Using swap space to reduce RAM'
endif
!---------------
write(6,'(A)') ''
write_buffer = '====='
do i = 1, N_st
write_buffer = trim(write_buffer)//' ================ ==========='
enddo
write(6, '(A)') write_buffer(1:6+41*N_st)
write_buffer = 'Iter'
do i = 1, N_st
write_buffer = trim(write_buffer)//' Energy Residual '
enddo
write(6,'(A)') write_buffer(1:6+41*N_st)
write_buffer = '====='
do i = 1, N_st
write_buffer = trim(write_buffer)//' ================ ==========='
enddo
write(6,'(A)') write_buffer(1:6+41*N_st)
if(disk_based) then
! Create memory-mapped files for W and S
type(c_ptr) :: ptr_w, ptr_s
integer :: fd_s, fd_w
call mmap(trim(ezfio_work_dir)//'davidson_w', (/int(sze,8),int(N_st_diag*itermax,8)/),&
8, fd_w, .False., ptr_w)
call c_f_pointer(ptr_w, w, (/sze,N_st_diag*itermax/))
else
allocate(W(sze,N_st_diag*itermax))
endif
allocate( &
! Large
U(sze,N_st_diag*itermax), &
! Small
h(N_st_diag*itermax,N_st_diag*itermax), &
y(N_st_diag*itermax,N_st_diag*itermax), &
s_tmp(N_st_diag*itermax,N_st_diag*itermax), &
residual_norm(N_st_diag), &
lambda(N_st_diag*itermax), &
u_tmp(N_st,N_st_diag))
h = 0.d0
U = 0.d0
y = 0.d0
s_tmp = 0.d0
ASSERT (N_st > 0)
ASSERT (N_st_diag >= N_st)
ASSERT (sze > 0)
ASSERT (Nint > 0)
ASSERT (Nint == N_int)
! Davidson iterations
! ===================
converged = .False.
do k = N_st+1, N_st_diag
do i = 1, sze
call random_number(r1)
call random_number(r2)
r1 = dsqrt(-2.d0*dlog(r1))
r2 = dtwo_pi*r2
u_in(i,k) = r1*dcos(r2) * u_in(i,k-N_st)
enddo
u_in(k,k) = u_in(k,k) + 10.d0
enddo
do k = 1, N_st_diag
call normalize(u_in(1,k), sze)
enddo
do k = 1, N_st_diag
do i = 1, sze
U(i,k) = u_in(i,k)
enddo
enddo
do while (.not.converged)
itertot = itertot + 1
if(itertot == 8) then
exit
endif
do iter = 1, itermax-1
shift = N_st_diag*(iter-1)
shift2 = N_st_diag*iter
if( (iter > 1) .or. (itertot == 1) ) then
! Gram-Schmidt to orthogonalize all new guess with the previous vectors
call ortho_qr(U, size(U, 1), sze, shift2)
call ortho_qr(U, size(U, 1), sze, shift2)
! Compute |W_k> = \sum_i |i><i|H|u_k>
! -----------------------------------
if( (sze > 100000) .and. distributed_davidson ) then
call H_u_0_nstates_zmq (W(1,shift+1), U(1,shift+1), N_st_diag, sze)
else
call H_u_0_nstates_openmp(W(1,shift+1), U(1,shift+1), N_st_diag, sze)
endif
else
! Already computed in update below
continue
endif
if(dressing_state > 0) then
call dgemm( 'T', 'N', N_st, N_st_diag, sze, 1.d0 &
, psi_coef, size(psi_coef, 1), U(1, shift+1), size(U, 1) &
, 0.d0, u_tmp, size(u_tmp, 1))
do istate = 1, N_st_diag
do k = 1, N_st
do l = 1, N_st
f = overlap_states_inv(k,l)
do i = 1, sze
W(i,shift+istate) += f * dressing_delta(i,k) * u_tmp(l,istate)
enddo
enddo
enddo
enddo
endif
! Compute h_kl = <u_k | W_l> = <u_k| H |u_l>
! -------------------------------------------
call dgemm( 'T', 'N', shift2, shift2, sze, 1.d0 &
, U, size(U, 1), W, size(W, 1) &
, 0.d0, h, size(h, 1))
! Diagonalize h
! ---------------
call diag_nonsym_right(shift2, h(1,1), size(h, 1), y(1,1), size(y, 1), lambda(1), size(lambda, 1))
if (state_following) then
overlap = -1.d0
do k = 1, shift2
do i = 1, shift2
overlap(k,i) = dabs(y(k,i))
enddo
enddo
do k = 1, N_st
cmax = -1.d0
do i = 1, N_st
if(overlap(i,k) > cmax) then
cmax = overlap(i,k)
order(k) = i
endif
enddo
do i = 1, N_st_diag
overlap(order(k),i) = -1.d0
enddo
enddo
overlap = y
do k = 1, N_st
l = order(k)
if (k /= l) then
y(1:shift2,k) = overlap(1:shift2,l)
endif
enddo
do k = 1, N_st
overlap(k,1) = lambda(k)
enddo
endif
! Express eigenvectors of h in the determinant basis
! --------------------------------------------------
call dgemm( 'N', 'N', sze, N_st_diag, shift2, 1.d0 &
, U, size(U, 1), y, size(y, 1) &
, 0.d0, U(1,shift2+1), size(U, 1))
do k = 1, N_st_diag
call normalize(U(1,shift2+k), sze)
enddo
call dgemm( 'N', 'N', sze, N_st_diag, shift2, 1.d0 &
, W, size(W, 1), y, size(y, 1) &
, 0.d0, W(1,shift2+1), size(W,1))
! Compute residual vector and davidson step
! -----------------------------------------
!$OMP PARALLEL DO DEFAULT(SHARED) PRIVATE(i,k)
do k = 1, N_st_diag
do i = 1, sze
U(i,shift2+k) = (lambda(k) * U(i,shift2+k) - W(i,shift2+k)) / max(H_jj(i)-lambda(k), 1.d-2)
enddo
if(k <= N_st) then
residual_norm(k) = u_dot_u(U(1,shift2+k), sze)
to_print(1,k) = lambda(k) + nuclear_repulsion
to_print(2,k) = residual_norm(k)
endif
enddo
!$OMP END PARALLEL DO
if((itertot>1).and.(iter == 1)) then
!don't print
continue
else
write(*, '(1X, I3, 1X, 100(1X, F16.10, 1X, E11.3))') iter-1, to_print(1:2,1:N_st)
endif
! Check convergence
if(iter > 1) then
if(threshold_davidson_from_pt2) then
converged = dabs(maxval(residual_norm(1:N_st))) < threshold_davidson_pt2
else
converged = dabs(maxval(residual_norm(1:N_st))) < threshold_nonsym_davidson
endif
endif
do k = 1, N_st
if(residual_norm(k) > 1.d8) then
print *, 'Davidson failed'
stop -1
endif
enddo
if(converged) then
exit
endif
logical, external :: qp_stop
if(qp_stop()) then
converged = .True.
exit
endif
enddo
! Re-contract U and update W
! --------------------------------
call dgemm( 'N', 'N', sze, N_st_diag, shift2, 1.d0 &
, W, size(W, 1), y, size(y, 1) &
, 0.d0, u_in, size(u_in, 1))
do k = 1, N_st_diag
do i = 1, sze
W(i,k) = u_in(i,k)
enddo
enddo
call dgemm( 'N', 'N', sze, N_st_diag, shift2, 1.d0 &
, U, size(U, 1), y, size(y, 1), 0.d0 &
, u_in, size(u_in, 1))
do k = 1, N_st_diag
do i = 1, sze
U(i,k) = u_in(i,k)
enddo
enddo
enddo
call nullify_small_elements(sze, N_st_diag, U, size(U, 1), threshold_davidson_pt2)
do k = 1, N_st_diag
do i = 1, sze
u_in(i,k) = U(i,k)
enddo
enddo
do k = 1, N_st_diag
energies(k) = lambda(k)
enddo
write_buffer = '======'
do i = 1, N_st
write_buffer = trim(write_buffer)//' ================ ==========='
enddo
write(6,'(A)') trim(write_buffer)
write(6,'(A)') ''
call write_time(6)
if(disk_based) then
! Remove temp files
integer, external :: getUnitAndOpen
call munmap( (/int(sze,8),int(N_st_diag*itermax,8)/), 8, fd_w, ptr_w )
fd_w = getUnitAndOpen(trim(ezfio_work_dir)//'davidson_w','r')
close(fd_w,status='delete')
else
deallocate(W)
endif
deallocate ( &
residual_norm, &
U, overlap, &
h, y, s_tmp, &
lambda, &
u_tmp &
)
FREE nthreads_davidson
end subroutine davidson_diag_nonsym_hjj
! ---

11
src/davidson/diagonalize_ci.irp.f
View File

@ -1,19 +1,9 @@
BEGIN_PROVIDER [ character*(3), sigma_vector_algorithm ]
implicit none
BEGIN_DOC
! If 'det', use <Psi_det|H|Psi_det> in Davidson
!
! If 'cfg', use <Psi_csf|H|Psi_csf> in Davidson
END_DOC
sigma_vector_algorithm = 'det'
END_PROVIDER
BEGIN_PROVIDER [ double precision, CI_energy, (N_states_diag) ]
implicit none
BEGIN_DOC
! :c:data:`n_states` lowest eigenvalues of the |CI| matrix
END_DOC
PROVIDE distributed_davidson
integer :: j
character*(8) :: st
@ -298,7 +288,6 @@ subroutine diagonalize_CI
! eigenstates of the |CI| matrix.
END_DOC
integer :: i,j
PROVIDE distributed_davidson
do j=1,N_states
do i=1,N_det
psi_coef(i,j) = CI_eigenvectors(i,j)

78
src/davidson/input.irp.f
View File

@ -1,39 +1,39 @@
BEGIN_PROVIDER [ integer, n_states_diag ]
implicit none
BEGIN_DOC
! Number of states to consider during the Davdison diagonalization
END_DOC
logical :: has
PROVIDE ezfio_filename
if (mpi_master) then
call ezfio_has_davidson_n_states_diag(has)
if (has) then
call ezfio_get_davidson_n_states_diag(n_states_diag)
else
print *, 'davidson/n_states_diag not found in EZFIO file'
stop 1
endif
n_states_diag = max(2,N_states * N_states_diag)
endif
IRP_IF MPI_DEBUG
print *, irp_here, mpi_rank
call MPI_BARRIER(MPI_COMM_WORLD, ierr)
IRP_ENDIF
IRP_IF MPI
include 'mpif.h'
integer :: ierr
call MPI_BCAST( n_states_diag, 1, MPI_INTEGER, 0, MPI_COMM_WORLD, ierr)
if (ierr /= MPI_SUCCESS) then
stop 'Unable to read n_states_diag with MPI'
endif
IRP_ENDIF
call write_time(6)
if (mpi_master) then
write(6, *) 'Read n_states_diag'
endif
END_PROVIDER
!BEGIN_PROVIDER [ integer, n_states_diag ]
! implicit none
! BEGIN_DOC
!! Number of states to consider during the Davdison diagonalization
! END_DOC
!
! logical :: has
! PROVIDE ezfio_filename
! if (mpi_master) then
!
! call ezfio_has_davidson_n_states_diag(has)
! if (has) then
! call ezfio_get_davidson_n_states_diag(n_states_diag)
! else
! print *, 'davidson/n_states_diag not found in EZFIO file'
! stop 1
! endif
! n_states_diag = max(2,N_states * N_states_diag)
! endif
! IRP_IF MPI_DEBUG
! print *, irp_here, mpi_rank
! call MPI_BARRIER(MPI_COMM_WORLD, ierr)
! IRP_ENDIF
! IRP_IF MPI
! include 'mpif.h'
! integer :: ierr
! call MPI_BCAST( n_states_diag, 1, MPI_INTEGER, 0, MPI_COMM_WORLD, ierr)
! if (ierr /= MPI_SUCCESS) then
! stop 'Unable to read n_states_diag with MPI'
! endif
! IRP_ENDIF
!
! call write_time(6)
! if (mpi_master) then
! write(6, *) 'Read n_states_diag'
! endif
!
!END_PROVIDER
!

40
src/davidson/overlap_states.irp.f Normal file
View File

@ -0,0 +1,40 @@
! ---
BEGIN_PROVIDER [ double precision, overlap_states, (N_states,N_states) ]
&BEGIN_PROVIDER [ double precision, overlap_states_inv, (N_states,N_states) ]
BEGIN_DOC
!
! S_kl = ck.T x cl
! = psi_coef(:,k).T x psi_coef(:,l)
!
END_DOC
implicit none
integer :: i
double precision :: o_tmp
if(N_states == 1) then
o_tmp = 0.d0
do i = 1, N_det
o_tmp = o_tmp + psi_coef(i,1) * psi_coef(i,1)
enddo
overlap_states (1,1) = o_tmp
overlap_states_inv(1,1) = 1.d0 / o_tmp
else
call dgemm( 'T', 'N', N_states, N_states, N_det, 1.d0 &
, psi_coef, size(psi_coef, 1), psi_coef, size(psi_coef, 1) &
, 0.d0, overlap_states, size(overlap_states, 1) )
call get_inverse(overlap_states, N_states, N_states, overlap_states_inv, N_states)
endif
END_PROVIDER
! ---

0
src/two_body_rdm/print_e_components.irp.f → src/davidson/print_e_components.irp.f
View File

16
src/davidson/u0_hs2_u0.irp.f
View File

@ -203,7 +203,7 @@ subroutine H_S2_u_0_nstates_openmp_work_$N_int(v_t,s_t,u_t,N_st,sze,istart,iend,
integer, allocatable :: doubles(:)
integer, allocatable :: singles_a(:)
integer, allocatable :: singles_b(:)
integer, allocatable :: idx(:), buffer_lrow(:), idx0(:)
integer, allocatable :: idx(:), idx0(:)
integer :: maxab, n_singles_a, n_singles_b, kcol_prev
integer*8 :: k8
logical :: compute_singles
@ -253,7 +253,7 @@ compute_singles=.True.
!$OMP PRIVATE(krow, kcol, tmp_det, spindet, k_a, k_b, i, &
!$OMP lcol, lrow, l_a, l_b, utl, kk, u_is_sparse, &
!$OMP buffer, doubles, n_doubles, umax, &
!$OMP tmp_det2, hij, sij, idx, buffer_lrow, l, kcol_prev, &
!$OMP tmp_det2, hij, sij, idx, l, kcol_prev, &
!$OMP singles_a, n_singles_a, singles_b, ratio, &
!$OMP n_singles_b, k8, last_found,left,right,right_max)
@ -264,7 +264,7 @@ compute_singles=.True.
singles_a(maxab), &
singles_b(maxab), &
doubles(maxab), &
idx(maxab), buffer_lrow(maxab), utl(N_st,block_size))
idx(maxab), utl(N_st,block_size))
kcol_prev=-1
@ -332,20 +332,18 @@ compute_singles=.True.
l_a = psi_bilinear_matrix_columns_loc(lcol)
ASSERT (l_a <= N_det)
!DIR$ UNROLL(8)
!DIR$ LOOP COUNT avg(50000)
do j=1,psi_bilinear_matrix_columns_loc(lcol+1) - psi_bilinear_matrix_columns_loc(lcol)
lrow = psi_bilinear_matrix_rows(l_a)
ASSERT (lrow <= N_det_alpha_unique)
buffer_lrow(j) = lrow
buffer(1:$N_int,j) = psi_det_alpha_unique(1:$N_int, lrow) ! hot spot
ASSERT (l_a <= N_det)
idx(j) = l_a
l_a = l_a+1
enddo
do j=1,psi_bilinear_matrix_columns_loc(lcol+1) - psi_bilinear_matrix_columns_loc(lcol)
buffer(1:$N_int,j) = psi_det_alpha_unique(1:$N_int, buffer_lrow(j)) ! hot spot
enddo
j = j-1
call get_all_spin_singles_$N_int( &
@ -791,7 +789,7 @@ compute_singles=.True.
end do
!$OMP END DO
deallocate(buffer, singles_a, singles_b, doubles, idx, buffer_lrow, utl)
deallocate(buffer, singles_a, singles_b, doubles, idx, utl)
!$OMP END PARALLEL
end

318
src/davidson_dressed/diagonalize_ci.irp.f
View File

@ -12,7 +12,7 @@ BEGIN_PROVIDER [ double precision, CI_energy_dressed, (N_states_diag) ]
enddo
do j=1,min(N_det,N_states)
write(st,'(I4)') j
call write_double(6,CI_energy_dressed(j),'Energy dressed of state '//trim(st))
call write_double(6,CI_energy_dressed(j),'Energy of state '//trim(st))
call write_double(6,CI_eigenvectors_s2_dressed(j),'S^2 of state '//trim(st))
enddo
@ -21,201 +21,133 @@ END_PROVIDER
BEGIN_PROVIDER [ double precision, CI_electronic_energy_dressed, (N_states_diag) ]
&BEGIN_PROVIDER [ double precision, CI_eigenvectors_dressed, (N_det,N_states_diag) ]
&BEGIN_PROVIDER [ double precision, CI_eigenvectors_s2_dressed, (N_states_diag) ]
BEGIN_DOC
! Eigenvectors/values of the CI matrix
END_DOC
implicit none
double precision :: ovrlp,u_dot_v
integer :: i_good_state
integer, allocatable :: index_good_state_array(:)
logical, allocatable :: good_state_array(:)
double precision, allocatable :: s2_values_tmp(:)
integer :: i_other_state
double precision, allocatable :: eigenvectors(:,:), eigenvectors_s2(:,:), eigenvalues(:)
integer :: i_state
double precision :: e_0
integer :: i,j,k,mrcc_state
double precision, allocatable :: s2_eigvalues(:)
double precision, allocatable :: e_array(:)
integer, allocatable :: iorder(:)
logical :: converged
logical :: do_csf
PROVIDE threshold_davidson nthreads_davidson
! Guess values for the "N_states" states of the CI_eigenvectors_dressed
do j=1,min(N_states,N_det)
do i=1,N_det
CI_eigenvectors_dressed(i,j) = psi_coef(i,j)
enddo
enddo
do j=min(N_states,N_det)+1,N_states_diag
do i=1,N_det
CI_eigenvectors_dressed(i,j) = 0.d0
enddo
enddo
do_csf = s2_eig .and. only_expected_s2 .and. csf_based
if (diag_algorithm == "Davidson") then
do j=1,min(N_states,N_det)
do i=1,N_det
CI_eigenvectors_dressed(i,j) = psi_coef(i,j)
BEGIN_DOC
! Eigenvectors/values of the CI matrix
END_DOC
implicit none
double precision :: ovrlp,u_dot_v
integer :: i_good_state
integer, allocatable :: index_good_state_array(:)
logical, allocatable :: good_state_array(:)
double precision, allocatable :: s2_values_tmp(:)
integer :: i_other_state
double precision, allocatable :: eigenvectors(:,:), eigenvectors_s2(:,:), eigenvalues(:)
integer :: i_state
double precision :: e_0
integer :: i,j,k,mrcc_state
double precision, allocatable :: s2_eigvalues(:)
double precision, allocatable :: e_array(:)
integer, allocatable :: iorder(:)
PROVIDE threshold_davidson nthreads_davidson
! Guess values for the "N_states" states of the CI_eigenvectors_dressed
do j=1,min(N_states,N_det)
do i=1,N_det
CI_eigenvectors_dressed(i,j) = psi_coef(i,j)
enddo
enddo
do j=min(N_states,N_det)+1,N_states_diag
do i=1,N_det
CI_eigenvectors_dressed(i,j) = 0.d0
enddo
enddo
if (diag_algorithm == "Davidson") then
do j=1,min(N_states,N_det)
do i=1,N_det
CI_eigenvectors_dressed(i,j) = psi_coef(i,j)
enddo
enddo
logical :: converged
converged = .False.
call davidson_diag_HS2(psi_det,CI_eigenvectors_dressed, CI_eigenvectors_s2_dressed,&
size(CI_eigenvectors_dressed,1), CI_electronic_energy_dressed,&
N_det,min(N_det,N_states),min(N_det,N_states_diag),N_int,1,converged)
else if (diag_algorithm == "Lapack") then
allocate (eigenvectors(size(H_matrix_dressed,1),N_det))
allocate (eigenvalues(N_det))
call lapack_diag(eigenvalues,eigenvectors, &
H_matrix_dressed,size(H_matrix_dressed,1),N_det)
CI_electronic_energy_dressed(:) = 0.d0
if (s2_eig) then
i_state = 0
allocate (s2_eigvalues(N_det))
allocate(index_good_state_array(N_det),good_state_array(N_det))
good_state_array = .False.
call u_0_S2_u_0(s2_eigvalues,eigenvectors,N_det,psi_det,N_int,&
N_det,size(eigenvectors,1))
do j=1,N_det
! Select at least n_states states with S^2 values closed to "expected_s2"
if(dabs(s2_eigvalues(j)-expected_s2).le.0.5d0)then
i_state +=1
index_good_state_array(i_state) = j
good_state_array(j) = .True.
endif
if(i_state.eq.N_states) then
exit
endif
enddo
enddo
converged = .False.
if (do_csf) then
call davidson_diag_H_csf(psi_det,CI_eigenvectors_dressed, &
size(CI_eigenvectors_dressed,1),CI_electronic_energy_dressed, &
N_det,N_csf,min(N_det,N_states),min(N_det,N_states_diag),N_int,1,converged)
if(i_state .ne.0)then
! Fill the first "i_state" states that have a correct S^2 value
do j = 1, i_state
do i=1,N_det
CI_eigenvectors_dressed(i,j) = eigenvectors(i,index_good_state_array(j))
enddo
CI_electronic_energy_dressed(j) = eigenvalues(index_good_state_array(j))
CI_eigenvectors_s2_dressed(j) = s2_eigvalues(index_good_state_array(j))
enddo
i_other_state = 0
do j = 1, N_det
if(good_state_array(j))cycle
i_other_state +=1
if(i_state+i_other_state.gt.n_states_diag)then
exit
endif
do i=1,N_det
CI_eigenvectors_dressed(i,i_state+i_other_state) = eigenvectors(i,j)
enddo
CI_electronic_energy_dressed(i_state+i_other_state) = eigenvalues(j)
CI_eigenvectors_s2_dressed(i_state+i_other_state) = s2_eigvalues(i_state+i_other_state)
enddo
else
print*,''
print*,'!!!!!!!! WARNING !!!!!!!!!'
print*,' Within the ',N_det,'determinants selected'
print*,' and the ',N_states_diag,'states requested'
print*,' We did not find any state with S^2 values close to ',expected_s2
print*,' We will then set the first N_states eigenvectors of the H matrix'
print*,' as the CI_eigenvectors_dressed'
print*,' You should consider more states and maybe ask for s2_eig to be .True. or just enlarge the CI space'
print*,''
do j=1,min(N_states_diag,N_det)
do i=1,N_det
CI_eigenvectors_dressed(i,j) = eigenvectors(i,j)
enddo
CI_electronic_energy_dressed(j) = eigenvalues(j)
CI_eigenvectors_s2_dressed(j) = s2_eigvalues(j)
enddo
endif
deallocate(index_good_state_array,good_state_array)
deallocate(s2_eigvalues)
else
call davidson_diag_HS2(psi_det,CI_eigenvectors_dressed, CI_eigenvectors_s2_dressed,&
size(CI_eigenvectors_dressed,1), CI_electronic_energy_dressed,&
N_det,min(N_det,N_states),min(N_det,N_states_diag),N_int,1,converged)
call u_0_S2_u_0(CI_eigenvectors_s2_dressed,eigenvectors,N_det,psi_det,N_int,&
min(N_det,N_states_diag),size(eigenvectors,1))
! Select the "N_states_diag" states of lowest energy
do j=1,min(N_det,N_states_diag)
do i=1,N_det
CI_eigenvectors_dressed(i,j) = eigenvectors(i,j)
enddo
CI_electronic_energy_dressed(j) = eigenvalues(j)
enddo
endif
integer :: N_states_diag_save
N_states_diag_save = N_states_diag
do while (.not.converged)
double precision, allocatable :: CI_electronic_energy_tmp (:)
double precision, allocatable :: CI_eigenvectors_tmp (:,:)
double precision, allocatable :: CI_s2_tmp (:)
N_states_diag *= 2
TOUCH N_states_diag
if (do_csf) then
allocate (CI_electronic_energy_tmp (N_states_diag) )
allocate (CI_eigenvectors_tmp (N_det,N_states_diag) )
CI_electronic_energy_tmp(1:N_states_diag_save) = CI_electronic_energy_dressed(1:N_states_diag_save)
CI_eigenvectors_tmp(1:N_det,1:N_states_diag_save) = CI_eigenvectors_dressed(1:N_det,1:N_states_diag_save)
call davidson_diag_H_csf(psi_det,CI_eigenvectors_tmp, &
size(CI_eigenvectors_tmp,1),CI_electronic_energy_tmp, &
N_det,N_csf,min(N_det,N_states),min(N_det,N_states_diag),N_int,1,converged)
CI_electronic_energy_dressed(1:N_states_diag_save) = CI_electronic_energy_tmp(1:N_states_diag_save)
CI_eigenvectors_dressed(1:N_det,1:N_states_diag_save) = CI_eigenvectors_tmp(1:N_det,1:N_states_diag_save)
deallocate (CI_electronic_energy_tmp)
deallocate (CI_eigenvectors_tmp)
else
allocate (CI_electronic_energy_tmp (N_states_diag) )
allocate (CI_eigenvectors_tmp (N_det,N_states_diag) )
allocate (CI_s2_tmp (N_states_diag) )
CI_electronic_energy_tmp(1:N_states_diag_save) = CI_electronic_energy_dressed(1:N_states_diag_save)
CI_eigenvectors_tmp(1:N_det,1:N_states_diag_save) = CI_eigenvectors_dressed(1:N_det,1:N_states_diag_save)
CI_s2_tmp(1:N_states_diag_save) = CI_eigenvectors_s2_dressed(1:N_states_diag_save)
call davidson_diag_HS2(psi_det,CI_eigenvectors_tmp, CI_s2_tmp, &
size(CI_eigenvectors_tmp,1),CI_electronic_energy_tmp, &
N_det,min(N_det,N_states),min(N_det,N_states_diag),N_int,1,converged)
CI_electronic_energy_dressed(1:N_states_diag_save) = CI_electronic_energy_tmp(1:N_states_diag_save)
CI_eigenvectors_dressed(1:N_det,1:N_states_diag_save) = CI_eigenvectors_tmp(1:N_det,1:N_states_diag_save)
CI_eigenvectors_s2_dressed(1:N_states_diag_save) = CI_s2_tmp(1:N_states_diag_save)
deallocate (CI_electronic_energy_tmp)
deallocate (CI_eigenvectors_tmp)
deallocate (CI_s2_tmp)
endif
enddo
if (N_states_diag > N_states_diag_save) then
N_states_diag = N_states_diag_save
TOUCH N_states_diag
endif
else if (diag_algorithm == "Lapack") then
print *, 'Diagonalization of H using Lapack'
allocate (eigenvectors(size(H_matrix_dressed,1),N_det))
allocate (eigenvalues(N_det))
call lapack_diag(eigenvalues,eigenvectors, &
H_matrix_dressed,size(H_matrix_dressed,1),N_det)
CI_electronic_energy_dressed(:) = 0.d0
if (s2_eig) then
i_state = 0
allocate (s2_eigvalues(N_det))
allocate(index_good_state_array(N_det),good_state_array(N_det))
good_state_array = .False.
call u_0_S2_u_0(s2_eigvalues,eigenvectors,N_det,psi_det,N_int,&
N_det,size(eigenvectors,1))
do j=1,N_det
! Select at least n_states states with S^2 values closed to "expected_s2"
if(dabs(s2_eigvalues(j)-expected_s2).le.0.5d0)then
i_state +=1
index_good_state_array(i_state) = j
good_state_array(j) = .True.
endif
if(i_state.eq.N_states) then
exit
endif
enddo
if(i_state .ne.0)then
! Fill the first "i_state" states that have a correct S^2 value
do j = 1, i_state
do i=1,N_det
CI_eigenvectors_dressed(i,j) = eigenvectors(i,index_good_state_array(j))
enddo
CI_electronic_energy_dressed(j) = eigenvalues(index_good_state_array(j))
CI_eigenvectors_s2_dressed(j) = s2_eigvalues(index_good_state_array(j))
enddo
i_other_state = 0
do j = 1, N_det
if(good_state_array(j))cycle
i_other_state +=1
if(i_state+i_other_state.gt.n_states_diag)then
exit
endif
do i=1,N_det
CI_eigenvectors_dressed(i,i_state+i_other_state) = eigenvectors(i,j)
enddo
CI_electronic_energy_dressed(i_state+i_other_state) = eigenvalues(j)
CI_eigenvectors_s2_dressed(i_state+i_other_state) = s2_eigvalues(i_state+i_other_state)
enddo
else
print*,''
print*,'!!!!!!!! WARNING !!!!!!!!!'
print*,' Within the ',N_det,'determinants selected'
print*,' and the ',N_states_diag,'states requested'
print*,' We did not find any state with S^2 values close to ',expected_s2
print*,' We will then set the first N_states eigenvectors of the H matrix'
print*,' as the CI_eigenvectors_dressed'
print*,' You should consider more states and maybe ask for s2_eig to be .True. or just enlarge the CI space'
print*,''
do j=1,min(N_states_diag,N_det)
do i=1,N_det
CI_eigenvectors_dressed(i,j) = eigenvectors(i,j)
enddo
CI_electronic_energy_dressed(j) = eigenvalues(j)
CI_eigenvectors_s2_dressed(j) = s2_eigvalues(j)
enddo
endif
deallocate(index_good_state_array,good_state_array)
deallocate(s2_eigvalues)
else
call u_0_S2_u_0(CI_eigenvectors_s2_dressed,eigenvectors,N_det,psi_det,N_int,&
min(N_det,N_states_diag),size(eigenvectors,1))
! Select the "N_states_diag" states of lowest energy
do j=1,min(N_det,N_states_diag)
do i=1,N_det
CI_eigenvectors_dressed(i,j) = eigenvectors(i,j)
enddo
CI_electronic_energy_dressed(j) = eigenvalues(j)
enddo
endif
deallocate(eigenvectors,eigenvalues)
endif
deallocate(eigenvectors,eigenvalues)
endif
END_PROVIDER

188
src/davidson_dressed/nonsym_diagonalize_ci.irp.f Normal file
View File

@ -0,0 +1,188 @@
! ---
BEGIN_PROVIDER [ double precision, CI_energy_nonsym_dressed, (N_states_diag) ]
BEGIN_DOC
! N_states lowest eigenvalues of the CI matrix
END_DOC
implicit none
integer :: j
character*(8) :: st
call write_time(6)
do j = 1, min(N_det, N_states_diag)
CI_energy_nonsym_dressed(j) = CI_electronic_energy_nonsym_dressed(j) + nuclear_repulsion
enddo
do j = 1, min(N_det, N_states)
write(st, '(I4)') j
call write_double(6, CI_energy_nonsym_dressed(j), 'Energy of state '//trim(st))
enddo
END_PROVIDER
! ---
BEGIN_PROVIDER [ double precision, CI_electronic_energy_nonsym_dressed, (N_states_diag) ]
&BEGIN_PROVIDER [ double precision, CI_eigenvectors_nonsym_dressed, (N_det,N_states_diag) ]
BEGIN_DOC
! Eigenvectors/values of the CI matrix
END_DOC
implicit none
logical :: converged
integer :: i, j, k
integer :: i_other_state
integer :: i_state
logical, allocatable :: good_state_array(:)
integer, allocatable :: index_good_state_array(:)
double precision, allocatable :: eigenvectors(:,:), eigenvalues(:)
PROVIDE threshold_nonsym_davidson nthreads_davidson
! Guess values for the "N_states" states of the CI_eigenvectors_nonsym_dressed
do j = 1, min(N_states, N_det)
do i = 1, N_det
CI_eigenvectors_nonsym_dressed(i,j) = psi_coef(i,j)
enddo
enddo
do j = min(N_states, N_det)+1, N_states_diag
do i = 1, N_det
CI_eigenvectors_nonsym_dressed(i,j) = 0.d0
enddo
enddo
! ---
if(diag_algorithm == "Davidson") then
ASSERT(n_states_diag .lt. n_states)
do j = 1, min(N_states, N_det)
do i = 1, N_det
CI_eigenvectors_nonsym_dressed(i,j) = psi_coef(i,j)
enddo
enddo
converged = .False.
call davidson_diag_nonsym_h( psi_det, CI_eigenvectors_nonsym_dressed &
, size(CI_eigenvectors_nonsym_dressed, 1) &
, CI_electronic_energy_nonsym_dressed &
, N_det, min(N_det, N_states), min(N_det, N_states_diag), N_int, 1, converged )
else if(diag_algorithm == "Lapack") then
allocate(eigenvectors(size(H_matrix_nonsym_dressed, 1),N_det))
allocate(eigenvalues(N_det))
call diag_nonsym_right( N_det, H_matrix_nonsym_dressed, size(H_matrix_nonsym_dressed, 1) &
, eigenvectors, size(eigenvectors, 1), eigenvalues, size(eigenvalues, 1) )
CI_electronic_energy_nonsym_dressed(:) = 0.d0
! Select the "N_states_diag" states of lowest energy
do j = 1, min(N_det, N_states_diag)
do i = 1, N_det
CI_eigenvectors_nonsym_dressed(i,j) = eigenvectors(i,j)
enddo
CI_electronic_energy_nonsym_dressed(j) = eigenvalues(j)
enddo
deallocate(eigenvectors, eigenvalues)
! --- ---
endif
! ---
END_PROVIDER
! ---
subroutine diagonalize_CI_nonsym_dressed()
BEGIN_DOC
! Replace the coefficients of the CI states by the coefficients of the
! eigenstates of the CI matrix
END_DOC
implicit none
integer :: i, j
PROVIDE dressing_delta
do j = 1, N_states
do i = 1, N_det
psi_coef(i,j) = CI_eigenvectors_nonsym_dressed(i,j)
enddo
enddo
SOFT_TOUCH psi_coef
end subroutine diagonalize_CI_nonsym_dressed
! ---
BEGIN_PROVIDER [ double precision, H_matrix_nonsym_dressed, (N_det,N_det) ]
BEGIN_DOC
! Dressed H with Delta_ij
END_DOC
implicit none
integer :: i, j, l, k
double precision :: f
H_matrix_nonsym_dressed(1:N_det,1:N_det) = h_matrix_all_dets(1:N_det,1:N_det)
if(N_states == 1) then
! !symmetric formula
! l = dressed_column_idx(1)
! f = 1.0d0/psi_coef(l,1)
! do i=1,N_det
! h_matrix_nonsym_dressed(i,l) += dressing_column_h(i,1) *f
! h_matrix_nonsym_dressed(l,i) += dressing_column_h(i,1) *f
! enddo
! l = dressed_column_idx(1)
! f = 1.0d0 / psi_coef(l,1)
! do j = 1, N_det
! H_matrix_nonsym_dressed(j,l) += f * dressing_delta(j,1)
! enddo
k = 1
l = 1
f = overlap_states_inv(k,l)
do j = 1, N_det
do i = 1, N_det
H_matrix_nonsym_dressed(i,j) = H_matrix_nonsym_dressed(i,j) + f * dressing_delta(i,k) * psi_coef(j,l)
enddo
enddo
else
do k = 1, N_states
do l = 1, N_states
f = overlap_states_inv(k,l)
do j = 1, N_det
do i = 1, N_det
H_matrix_nonsym_dressed(i,j) = H_matrix_nonsym_dressed(i,j) + f * dressing_delta(i,k) * psi_coef(j,l)
enddo
enddo
enddo
enddo
endif
END_PROVIDER
! ---

2
src/davidson_undressed/null_dressing_vector.irp.f
View File

@ -1,10 +1,12 @@
BEGIN_PROVIDER [ double precision, dressing_column_h, (N_det,N_states) ]
&BEGIN_PROVIDER [ double precision, dressing_column_s, (N_det,N_states) ]
&BEGIN_PROVIDER [ double precision, dressing_delta , (N_det,N_states) ]
implicit none
BEGIN_DOC
! Null dressing vectors
END_DOC
dressing_column_h(:,:) = 0.d0
dressing_column_s(:,:) = 0.d0
dressing_delta (:,:) = 0.d0
END_PROVIDER

17
src/determinants/EZFIO.cfg
View File

@ -42,13 +42,13 @@ default: 2
[weight_selection]
type: integer
doc: Weight used in the selection. 0: input state-average weight, 1: 1./(c_0^2), 2: PT2 matching, 3: variance matching, 4: variance and PT2 matching, 5: variance minimization and matching, 6: CI coefficients 7: input state-average multiplied by variance and PT2 matching 8: input state-average multiplied by PT2 matching 9: input state-average multiplied by variance matching
doc: Weight used in the selection. 0: input state-average weight, 1: 1./(c_0^2), 2: rPT2 matching, 3: variance matching, 4: variance and rPT2 matching, 5: variance minimization and matching, 6: CI coefficients 7: input state-average multiplied by variance and rPT2 matching 8: input state-average multiplied by rPT2 matching 9: input state-average multiplied by variance matching
interface: ezfio,provider,ocaml
default: 1
[threshold_generators]
type: Threshold
doc: Thresholds on generators (fraction of the square of the norm)
doc: Thresholds on generators (fraction of the square of the norm)
interface: ezfio,provider,ocaml
default: 0.999
@ -80,7 +80,7 @@ type: integer
[psi_coef]
interface: ezfio
doc: Coefficients of the wave function
type: double precision
type: double precision
size: (determinants.n_det,determinants.n_states)
[psi_det]
@ -92,7 +92,7 @@ size: (determinants.n_int*determinants.bit_kind/8,2,determinants.n_det)
[psi_coef_qp_edit]
interface: ezfio
doc: Coefficients of the wave function
type: double precision
type: double precision
size: (determinants.n_det_qp_edit,determinants.n_states)
[psi_det_qp_edit]
@ -126,18 +126,13 @@ default: 1.
[thresh_sym]
type: Threshold
doc: Thresholds to check if a determinant is connected with HF
doc: Thresholds to check if a determinant is connected with HF
interface: ezfio,provider,ocaml
default: 1.e-15
[pseudo_sym]
type: logical
doc: If |true|, discard any Slater determinants with an interaction smaller than thresh_sym with HF.
doc: If |true|, discard any Slater determinants with an interaction smaller than thresh_sym with HF.
interface: ezfio,provider,ocaml
default: False
[save_threshold]
type: Threshold
doc: Cut-off to apply to the CI coefficients when the wave function is stored
interface: ezfio,provider,ocaml
default: 1.e-14

95
src/determinants/density_matrix.irp.f
View File

@ -262,86 +262,17 @@ subroutine set_natural_mos
iorb = list_virt(i)
do j = 1, n_core_inact_act_orb
jorb = list_core_inact_act(j)
if(one_e_dm_mo(iorb,jorb).ne. 0.d0)then
print*,'AHAHAH'
print*,iorb,jorb,one_e_dm_mo(iorb,jorb)
stop
endif
enddo
enddo
call mo_as_svd_vectors_of_mo_matrix_eig(one_e_dm_mo,size(one_e_dm_mo,1),mo_num,mo_num,mo_occ,label)
soft_touch mo_occ
end
subroutine save_natural_mos_canon_label
implicit none
BEGIN_DOC
! Save natural orbitals, obtained by diagonalization of the one-body density matrix in
! the |MO| basis
END_DOC
call set_natural_mos_canon_label
call nullify_small_elements(ao_num,mo_num,mo_coef,size(mo_coef,1),1.d-10)
call orthonormalize_mos
call save_mos
end
subroutine set_natural_mos_canon_label
implicit none
BEGIN_DOC
! Set natural orbitals, obtained by diagonalization of the one-body density matrix
! in the |MO| basis
END_DOC
character*(64) :: label
double precision, allocatable :: tmp(:,:)
label = "Canonical"
integer :: i,j,iorb,jorb
do i = 1, n_virt_orb
iorb = list_virt(i)
do j = 1, n_core_inact_act_orb
jorb = list_core_inact_act(j)
enddo
enddo
call mo_as_svd_vectors_of_mo_matrix_eig(one_e_dm_mo,size(one_e_dm_mo,1),mo_num,mo_num,mo_occ,label)
soft_touch mo_occ
end
subroutine set_natorb_no_ov_rot
implicit none
BEGIN_DOC
! Set natural orbitals, obtained by diagonalization of the one-body density matrix
! in the |MO| basis
END_DOC
character*(64) :: label
double precision, allocatable :: tmp(:,:)
allocate(tmp(mo_num, mo_num))
label = "Natural"
tmp = one_e_dm_mo
integer :: i,j,iorb,jorb
do i = 1, n_virt_orb
iorb = list_virt(i)
do j = 1, n_core_inact_act_orb
jorb = list_core_inact_act(j)
tmp(iorb, jorb) = 0.d0
tmp(jorb, iorb) = 0.d0
enddo
enddo
call mo_as_svd_vectors_of_mo_matrix_eig(tmp,size(tmp,1),mo_num,mo_num,mo_occ,label)
soft_touch mo_occ
end
subroutine save_natural_mos_no_ov_rot
implicit none
BEGIN_DOC
! Save natural orbitals, obtained by diagonalization of the one-body density matrix in
! the |MO| basis
END_DOC
call set_natorb_no_ov_rot
call nullify_small_elements(ao_num,mo_num,mo_coef,size(mo_coef,1),1.d-10)
call orthonormalize_mos
call save_mos
end
subroutine save_natural_mos
implicit none
BEGIN_DOC
@ -368,12 +299,12 @@ BEGIN_PROVIDER [ double precision, c0_weight, (N_states) ]
c = maxval(psi_coef(:,i) * psi_coef(:,i))
c0_weight(i) = 1.d0/(c+1.d-20)
enddo
c = 1.d0/sum(c0_weight(:))
c = 1.d0/minval(c0_weight(:))
do i=1,N_states
c0_weight(i) = c0_weight(i) * c
enddo
else
c0_weight(:) = 1.d0
c0_weight = 1.d0
endif
END_PROVIDER
@ -390,7 +321,7 @@ BEGIN_PROVIDER [ double precision, state_average_weight, (N_states) ]
if (weight_one_e_dm == 0) then
state_average_weight(:) = c0_weight(:)
else if (weight_one_e_dm == 1) then
state_average_weight(:) = 1.d0/N_states
state_average_weight(:) = 1./N_states
else
call ezfio_has_determinants_state_average_weight(exists)
if (exists) then
@ -453,14 +384,6 @@ END_PROVIDER
END_PROVIDER
BEGIN_PROVIDER [ double precision, one_e_dm_ao, (ao_num, ao_num)]
implicit none
BEGIN_DOC
! one_e_dm_ao = one_e_dm_ao_alpha + one_e_dm_ao_beta
END_DOC
one_e_dm_ao = one_e_dm_ao_alpha + one_e_dm_ao_beta
END_PROVIDER
subroutine get_occupation_from_dets(istate,occupation)
implicit none

122
src/determinants/determinants.irp.f
View File

@ -77,31 +77,28 @@ BEGIN_PROVIDER [ integer, psi_det_size ]
END_DOC
PROVIDE ezfio_filename
logical :: exists
psi_det_size = N_states
PROVIDE mpi_master
if (read_wf) then
if (mpi_master) then
call ezfio_has_determinants_n_det(exists)
if (exists) then
call ezfio_get_determinants_n_det(psi_det_size)
else
psi_det_size = N_states
endif
call write_int(6,psi_det_size,'Dimension of the psi arrays')
if (mpi_master) then
call ezfio_has_determinants_n_det(exists)
if (exists) then
call ezfio_get_determinants_n_det(psi_det_size)
else
psi_det_size = 1
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( psi_det_size, 1, MPI_INTEGER, 0, MPI_COMM_WORLD, ierr)
if (ierr /= MPI_SUCCESS) then
stop 'Unable to read psi_det_size with MPI'
endif
IRP_ENDIF
call write_int(6,psi_det_size,'Dimension of the psi arrays')
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( psi_det_size, 1, MPI_INTEGER, 0, MPI_COMM_WORLD, ierr)
if (ierr /= MPI_SUCCESS) then
stop 'Unable to read psi_det_size with MPI'
endif
IRP_ENDIF
END_PROVIDER
@ -174,22 +171,24 @@ BEGIN_PROVIDER [ integer(bit_kind), psi_det, (N_int,2,psi_det_size) ]
END_PROVIDER
! ---
BEGIN_PROVIDER [ double precision, psi_coef, (psi_det_size,N_states) ]
implicit none
BEGIN_DOC
! The wave function coefficients. Initialized with Hartree-Fock if the |EZFIO| file
! is empty.
END_DOC
implicit none
integer :: i,k, N_int2
logical :: exists
character*(64) :: label
PROVIDE read_wf N_det mo_label ezfio_filename
psi_coef = 0.d0
do i=1,min(N_states,psi_det_size)
do i = 1, min(N_states, psi_det_size)
psi_coef(i,i) = 1.d0
enddo
@ -233,10 +232,10 @@ BEGIN_PROVIDER [ double precision, psi_coef, (psi_det_size,N_states) ]
endif
IRP_ENDIF
END_PROVIDER
! ---
BEGIN_PROVIDER [ double precision, psi_average_norm_contrib, (psi_det_size) ]
implicit none
BEGIN_DOC
@ -543,7 +542,7 @@ subroutine save_wavefunction_general(ndet,nstates,psidet,dim_psicoef,psicoef)
integer :: i,j,k, ndet_qp_edit
if (mpi_master) then
ndet_qp_edit = min(ndet,10000)
ndet_qp_edit = min(ndet,N_det_qp_edit)
call ezfio_set_determinants_N_int(N_int)
call ezfio_set_determinants_bit_kind(bit_kind)
@ -653,6 +652,71 @@ subroutine save_wavefunction_general_unormalized(ndet,nstates,psidet,dim_psicoef
end
subroutine save_wavefunction_general_unormalized(ndet,nstates,psidet,dim_psicoef,psicoef)
implicit none
BEGIN_DOC
! Save the wave function into the |EZFIO| file
END_DOC
use bitmasks
include 'constants.include.F'
integer, intent(in) :: ndet,nstates,dim_psicoef
integer(bit_kind), intent(in) :: psidet(N_int,2,ndet)
double precision, intent(in) :: psicoef(dim_psicoef,nstates)
integer*8, allocatable :: psi_det_save(:,:,:)
double precision, allocatable :: psi_coef_save(:,:)
double precision :: accu_norm
integer :: i,j,k, ndet_qp_edit
if (mpi_master) then
ndet_qp_edit = min(ndet,N_det_qp_edit)
call ezfio_set_determinants_N_int(N_int)
call ezfio_set_determinants_bit_kind(bit_kind)
call ezfio_set_determinants_N_det(ndet)
call ezfio_set_determinants_N_det_qp_edit(ndet_qp_edit)
call ezfio_set_determinants_n_states(nstates)
call ezfio_set_determinants_mo_label(mo_label)
allocate (psi_det_save(N_int,2,ndet))
do i=1,ndet
do j=1,2
do k=1,N_int
psi_det_save(k,j,i) = transfer(psidet(k,j,i),1_8)
enddo
enddo
enddo
call ezfio_set_determinants_psi_det(psi_det_save)
call ezfio_set_determinants_psi_det_qp_edit(psi_det_save)
deallocate (psi_det_save)
allocate (psi_coef_save(ndet,nstates))
do k=1,nstates
do i=1,ndet
psi_coef_save(i,k) = psicoef(i,k)
enddo
enddo
call ezfio_set_determinants_psi_coef(psi_coef_save)
deallocate (psi_coef_save)
allocate (psi_coef_save(ndet_qp_edit,nstates))
do k=1,nstates
do i=1,ndet_qp_edit
psi_coef_save(i,k) = psicoef(i,k)
enddo
enddo
call ezfio_set_determinants_psi_coef_qp_edit(psi_coef_save)
deallocate (psi_coef_save)
call write_int(6,ndet,'Saved determinants')
endif
end

41
src/determinants/dipole_moments.irp.f
View File

@ -9,7 +9,7 @@
double precision :: weight, r(3)
double precision :: cpu0,cpu1,nuclei_part_z,nuclei_part_y,nuclei_part_x
! call cpu_time(cpu0)
call cpu_time(cpu0)
z_dipole_moment = 0.d0
y_dipole_moment = 0.d0
x_dipole_moment = 0.d0
@ -26,10 +26,10 @@
enddo
enddo
! print*,'electron part for z_dipole = ',z_dipole_moment
! print*,'electron part for y_dipole = ',y_dipole_moment
! print*,'electron part for x_dipole = ',x_dipole_moment
!
print*,'electron part for z_dipole = ',z_dipole_moment
print*,'electron part for y_dipole = ',y_dipole_moment
print*,'electron part for x_dipole = ',x_dipole_moment
nuclei_part_z = 0.d0
nuclei_part_y = 0.d0
nuclei_part_x = 0.d0
@ -38,43 +38,28 @@
nuclei_part_y += nucl_charge(i) * nucl_coord(i,2)
nuclei_part_x += nucl_charge(i) * nucl_coord(i,1)
enddo
! print*,'nuclei part for z_dipole = ',nuclei_part_z
! print*,'nuclei part for y_dipole = ',nuclei_part_y
! print*,'nuclei part for x_dipole = ',nuclei_part_x
!
print*,'nuclei part for z_dipole = ',nuclei_part_z
print*,'nuclei part for y_dipole = ',nuclei_part_y
print*,'nuclei part for x_dipole = ',nuclei_part_x
do istate = 1, N_states
z_dipole_moment(istate) += nuclei_part_z
y_dipole_moment(istate) += nuclei_part_y
x_dipole_moment(istate) += nuclei_part_x
enddo
! call cpu_time(cpu1)
! print*,'Time to provide the dipole moment :',cpu1-cpu0
call cpu_time(cpu1)
print*,'Time to provide the dipole moment :',cpu1-cpu0
END_PROVIDER
subroutine print_dipole_moments
subroutine print_z_dipole_moment_only
implicit none
integer :: i
print*, ''
print*, ''
print*, '****************************************'
write(*,'(A10)',advance='no') ' State : '
do i = 1,N_states
write(*,'(i16)',advance='no') i
end do
write(*,*) ''
write(*,'(A23,100(1pE16.8))') 'x_dipole_moment (au) = ',x_dipole_moment
write(*,'(A23,100(1pE16.8))') 'y_dipole_moment (au) = ',y_dipole_moment
write(*,'(A23,100(1pE16.8))') 'z_dipole_moment (au) = ',z_dipole_moment
write(*,*) ''
write(*,'(A23,100(1pE16.8))') 'x_dipole_moment (D) = ',x_dipole_moment * au_to_D
write(*,'(A23,100(1pE16.8))') 'y_dipole_moment (D) = ',y_dipole_moment * au_to_D
write(*,'(A23,100(1pE16.8))') 'z_dipole_moment (D) = ',z_dipole_moment * au_to_D
!print*, 'x_dipole_moment = ',x_dipole_moment
!print*, 'y_dipole_moment = ',y_dipole_moment
!print*, 'z_dipole_moment = ',z_dipole_moment
print*, 'z_dipole_moment = ',z_dipole_moment
print*, '****************************************'
end

5
src/determinants/h_apply.irp.f
View File

@ -322,7 +322,10 @@ subroutine fill_H_apply_buffer_no_selection(n_selected,det_buffer,Nint,iproc)
ASSERT (sum(popcnt(H_apply_buffer(iproc)%det(:,2,i))) == elec_beta_num)
enddo
do i=1,n_selected
H_apply_buffer(iproc)%det(:,:,i+H_apply_buffer(iproc)%N_det) = det_buffer(:,:,i)
do j=1,N_int
H_apply_buffer(iproc)%det(j,1,i+H_apply_buffer(iproc)%N_det) = det_buffer(j,1,i)
H_apply_buffer(iproc)%det(j,2,i+H_apply_buffer(iproc)%N_det) = det_buffer(j,2,i)
enddo
ASSERT (sum(popcnt(H_apply_buffer(iproc)%det(:,1,i+H_apply_buffer(iproc)%N_det)) )== elec_alpha_num)
ASSERT (sum(popcnt(H_apply_buffer(iproc)%det(:,2,i+H_apply_buffer(iproc)%N_det))) == elec_beta_num)
enddo

6
src/determinants/s2.irp.f
View File

@ -103,17 +103,13 @@ BEGIN_PROVIDER [ double precision, expected_s2]
END_PROVIDER
BEGIN_PROVIDER [ double precision, s2_values, (N_states) ]
&BEGIN_PROVIDER [ double precision, s_values, (N_states) ]
BEGIN_PROVIDER [ double precision, s2_values, (N_states) ]
implicit none
BEGIN_DOC
! array of the averaged values of the S^2 operator on the various states
END_DOC
integer :: i
call u_0_S2_u_0(s2_values,psi_coef,n_det,psi_det,N_int,N_states,psi_det_size)
do i = 1, N_states
s_values(i) = 0.5d0 *(-1.d0 + dsqrt(1.d0 + 4 * s2_values(i)))
enddo
END_PROVIDER

40
src/determinants/slater_rules.irp.f
View File

@ -438,7 +438,7 @@ subroutine bitstring_to_list_ab( string, list, n_elements, Nint)
use bitmasks
implicit none
BEGIN_DOC
! Gives the indices(+1) of the bits set to 1 in the bit string
! Gives the inidices(+1) of the bits set to 1 in the bit string
! For alpha/beta determinants.
END_DOC
integer, intent(in) :: Nint
@ -472,35 +472,6 @@ subroutine bitstring_to_list_ab( string, list, n_elements, Nint)
end
!subroutine bitstring_to_list( string, list, n_elements, Nint)
! use bitmasks
! implicit none
! BEGIN_DOC
! ! Gives the indices(+1) of the bits set to 1 in the bit string
! END_DOC
! integer, intent(in) :: Nint
! integer(bit_kind), intent(in) :: string(Nint)
! integer, intent(out) :: list(Nint*bit_kind_size)
! integer, intent(out) :: n_elements
!
! integer :: i, j, ishift
! integer(bit_kind) :: l
!
! n_elements = 0
! ishift = 1
! do i=1,Nint
! l = string(i)
! do while (l /= 0_bit_kind)
! j = trailz(l)
! n_elements = n_elements + 1
! l = ibclr(l,j)
! list(n_elements) = ishift+j
! enddo
! ishift = ishift + bit_kind_size
! enddo
!
!end
subroutine i_H_j_s2(key_i,key_j,Nint,hij,s2)
use bitmasks
@ -623,8 +594,7 @@ subroutine i_H_j(key_i,key_j,Nint,hij)
integer :: occ(Nint*bit_kind_size,2)
double precision :: diag_H_mat_elem, phase
integer :: n_occ_ab(2)
PROVIDE mo_two_e_integrals_in_map mo_integrals_map big_array_exchange_integrals
PROVIDE ao_one_e_integrals mo_one_e_integrals
PROVIDE mo_two_e_integrals_in_map mo_integrals_map big_array_exchange_integrals
ASSERT (Nint > 0)
ASSERT (Nint == N_int)
@ -682,6 +652,7 @@ subroutine i_H_j(key_i,key_j,Nint,hij)
case (1)
call get_single_excitation(key_i,key_j,exc,phase,Nint)
!DIR$ FORCEINLINE
call bitstring_to_list_ab(key_i, occ, n_occ_ab, Nint)
if (exc(0,1,1) == 1) then
! Single alpha
m = exc(1,1,1)
@ -700,6 +671,10 @@ subroutine i_H_j(key_i,key_j,Nint,hij)
end select
end
subroutine i_H_j_verbose(key_i,key_j,Nint,hij,hmono,hdouble,phase)
use bitmasks
implicit none
@ -1034,6 +1009,7 @@ subroutine i_H_psi(key,keys,coef,Nint,Ndet,Ndet_max,Nstate,i_H_psi_array)
end
subroutine i_H_psi_minilist(key,keys,idx_key,N_minilist,coef,Nint,Ndet,Ndet_max,Nstate,i_H_psi_array)
use bitmasks
implicit none

3
src/determinants/slater_rules_wee_mono.irp.f
View File

@ -282,7 +282,9 @@ subroutine i_H_j_two_e(key_i,key_j,Nint,hij)
double precision :: get_two_e_integral
integer :: m,n,p,q
integer :: i,j,k
integer :: occ(Nint*bit_kind_size,2)
double precision :: diag_H_mat_elem, phase,phase_2
integer :: n_occ_ab(2)
PROVIDE mo_two_e_integrals_in_map mo_integrals_map big_array_exchange_integrals ref_bitmask_two_e_energy
ASSERT (Nint > 0)
@ -340,6 +342,7 @@ subroutine i_H_j_two_e(key_i,key_j,Nint,hij)
case (1)
call get_single_excitation(key_i,key_j,exc,phase,Nint)
!DIR$ FORCEINLINE
call bitstring_to_list_ab(key_i, occ, n_occ_ab, Nint)
if (exc(0,1,1) == 1) then
! Mono alpha
m = exc(1,1,1)

5
src/determinants/spindeterminants.ezfio_config
View File

@ -9,8 +9,11 @@ spindeterminants
psi_det_beta integer*8 (spindeterminants_n_int*spindeterminants_bit_kind/8,spindeterminants_n_det_beta)
psi_coef_matrix_rows integer (spindeterminants_n_det)
psi_coef_matrix_columns integer (spindeterminants_n_det)
psi_coef_matrix_values double precision (spindeterminants_n_det,spindeterminants_n_states)
psi_coef_matrix_values double precision (spindeterminants_n_det,spindeterminants_n_states)
psi_left_coef_matrix_values double precision (spindeterminants_n_det,spindeterminants_n_states)
n_svd_coefs integer
n_svd_alpha integer
n_svd_beta integer
psi_svd_alpha double precision (spindeterminants_n_det_alpha,spindeterminants_n_svd_coefs,spindeterminants_n_states)
psi_svd_beta double precision (spindeterminants_n_det_beta,spindeterminants_n_svd_coefs,spindeterminants_n_states)
psi_svd_coefs double precision (spindeterminants_n_svd_coefs,spindeterminants_n_states)

2
src/determinants/spindeterminants.irp.f
View File

@ -585,7 +585,7 @@ END_PROVIDER
enddo
!$OMP ENDDO
!$OMP END PARALLEL
call i8sort(to_sort, psi_bilinear_matrix_transp_order, N_det)
call i8radix_sort(to_sort, psi_bilinear_matrix_transp_order, N_det,-1)
call iset_order(psi_bilinear_matrix_transp_rows,psi_bilinear_matrix_transp_order,N_det)
call iset_order(psi_bilinear_matrix_transp_columns,psi_bilinear_matrix_transp_order,N_det)
!$OMP PARALLEL DO DEFAULT(SHARED) PRIVATE(l)

12
src/determinants/utils.irp.f
View File

@ -6,10 +6,9 @@ BEGIN_PROVIDER [ double precision, H_matrix_all_dets,(N_det,N_det) ]
END_DOC
integer :: i,j,k
double precision :: hij
integer :: degree(N_det),idx(0:N_det)
call i_H_j(psi_det(1,1,1),psi_det(1,1,1),N_int,hij)
print*,'Providing the H_matrix_all_dets ...'
!$OMP PARALLEL DO SCHEDULE(GUIDED) DEFAULT(NONE) PRIVATE(i,j,hij,degree,idx,k) &
!$OMP PARALLEL DO SCHEDULE(GUIDED) DEFAULT(NONE) PRIVATE(i,j,hij,k) &
!$OMP SHARED (N_det, psi_det, N_int,H_matrix_all_dets)
do i =1,N_det
do j = i, N_det
@ -30,15 +29,16 @@ BEGIN_PROVIDER [ double precision, H_matrix_diag_all_dets,(N_det) ]
END_DOC
integer :: i
double precision :: hij
integer :: degree(N_det)
call i_H_j(psi_det(1,1,1),psi_det(1,1,1),N_int,hij)
!$OMP PARALLEL DO SCHEDULE(GUIDED) DEFAULT(NONE) PRIVATE(i,hij,degree) &
!$OMP PARALLEL DO SCHEDULE(GUIDED) DEFAULT(NONE) PRIVATE(i,hij) &
!$OMP SHARED (N_det, psi_det, N_int,H_matrix_diag_all_dets)
do i =1,N_det
call i_H_j(psi_det(1,1,i),psi_det(1,1,i),N_int,hij)
H_matrix_diag_all_dets(i) = hij
enddo
!$OMP END PARALLEL DO
END_PROVIDER
@ -50,9 +50,8 @@ BEGIN_PROVIDER [ double precision, S2_matrix_all_dets,(N_det,N_det) ]
END_DOC
integer :: i,j,k
double precision :: sij
integer :: degree(N_det),idx(0:N_det)
call get_s2(psi_det(1,1,1),psi_det(1,1,1),N_int,sij)
!$OMP PARALLEL DO SCHEDULE(GUIDED) DEFAULT(NONE) PRIVATE(i,j,sij,degree,idx,k) &
!$OMP PARALLEL DO SCHEDULE(GUIDED) DEFAULT(NONE) PRIVATE(i,j,sij,k) &
!$OMP SHARED (N_det, psi_det, N_int,S2_matrix_all_dets)
do i =1,N_det
do j = i, N_det
@ -63,4 +62,3 @@ BEGIN_PROVIDER [ double precision, S2_matrix_all_dets,(N_det,N_det) ]
enddo
!$OMP END PARALLEL DO
END_PROVIDER

1
src/dft_one_e/NEED
View File

@ -6,4 +6,3 @@ ao_one_e_ints
ao_two_e_ints
mo_two_e_erf_ints
ao_two_e_erf_ints
mu_of_r

70
src/dft_one_e/mu_erf_dft.irp.f
View File

@ -8,73 +8,3 @@ BEGIN_PROVIDER [double precision, mu_erf_dft]
mu_erf_dft = mu_erf
END_PROVIDER
BEGIN_PROVIDER [double precision, mu_of_r_dft, (n_points_final_grid)]
implicit none
integer :: i
if(mu_dft_type == "Read")then
call ezfio_get_mu_of_r_mu_of_r_disk(mu_of_r_dft)
else
do i = 1, n_points_final_grid
if(mu_dft_type == "cst")then
mu_of_r_dft(i) = mu_erf_dft
else if(mu_dft_type == "hf")then
mu_of_r_dft(i) = mu_of_r_hf(i)
else if(mu_dft_type == "rsc")then
mu_of_r_dft(i) = mu_rsc_of_r(i)
else if(mu_dft_type == "grad_rho")then
mu_of_r_dft(i) = mu_grad_rho(i)
else
print*,'mu_dft_type is not of good type = ',mu_dft_type
print*,'it must be of type Read, cst, hf, rsc'
print*,'Stopping ...'
stop
endif
enddo
endif
END_PROVIDER
BEGIN_PROVIDER [double precision, mu_rsc_of_r, (n_points_final_grid)]
implicit none
integer :: i
double precision :: mu_rs_c,rho,r(3), dm_a, dm_b
do i = 1, n_points_final_grid
r(1) = final_grid_points(1,i)
r(2) = final_grid_points(2,i)
r(3) = final_grid_points(3,i)
call dm_dft_alpha_beta_at_r(r,dm_a,dm_b)
rho = dm_a + dm_b
mu_rsc_of_r(i) = mu_rs_c(rho)
enddo
END_PROVIDER
BEGIN_PROVIDER [double precision, mu_grad_rho, (n_points_final_grid)]
implicit none
integer :: i
double precision :: mu_grad_rho_func, r(3)
do i = 1, n_points_final_grid
r(1) = final_grid_points(1,i)
r(2) = final_grid_points(2,i)
r(3) = final_grid_points(3,i)
mu_grad_rho(i) = mu_grad_rho_func(r)
enddo
END_PROVIDER
BEGIN_PROVIDER [double precision, mu_of_r_dft_average]
implicit none
integer :: i
double precision :: mu_rs_c,rho,r(3), dm_a, dm_b
mu_of_r_dft_average = 0.d0
do i = 1, n_points_final_grid
r(1) = final_grid_points(1,i)
r(2) = final_grid_points(2,i)
r(3) = final_grid_points(3,i)
call dm_dft_alpha_beta_at_r(r,dm_a,dm_b)
rho = dm_a + dm_b
if(mu_of_r_dft(i).gt.1.d+3)cycle
mu_of_r_dft_average += rho * mu_of_r_dft(i) * final_weight_at_r_vector(i)
enddo
mu_of_r_dft_average = mu_of_r_dft_average / dble(elec_alpha_num + elec_beta_num)
print*,'mu_of_r_dft_average = ',mu_of_r_dft_average
END_PROVIDER

37
src/dft_utils_func/mu_of_r_dft.irp.f
View File

@ -1,37 +0,0 @@
double precision function mu_rs_c(rho)
implicit none
double precision, intent(in) :: rho
include 'constants.include.F'
double precision :: cst_rs,alpha_rs,rs
cst_rs = (4.d0 * dacos(-1.d0)/3.d0)**(-1.d0/3.d0)
alpha_rs = 2.d0 * dsqrt((9.d0 * dacos(-1.d0)/4.d0)**(-1.d0/3.d0)) / sqpi
rs = cst_rs * rho**(-1.d0/3.d0)
mu_rs_c = alpha_rs/dsqrt(rs)
end
double precision function mu_grad_rho_func(r)
implicit none
double precision , intent(in) :: r(3)
integer :: m
double precision :: rho, dm_a, dm_b, grad_dm_a(3), grad_dm_b(3)
double precision :: eta, grad_rho(3), grad_sqr
eta = mu_erf
call density_and_grad_alpha_beta(r,dm_a,dm_b, grad_dm_a, grad_dm_b)
rho = dm_a + dm_b
do m = 1,3
grad_rho(m) = grad_dm_a(m) + grad_dm_b(m)
enddo
grad_sqr=0.d0
do m = 1,3
grad_sqr=grad_sqr+grad_rho(m)*grad_rho(m)
enddo
grad_sqr = dsqrt(grad_sqr)
if (rho<1.d-12) then
mu_grad_rho_func = 1.d-10
else
mu_grad_rho_func = eta * grad_sqr / rho
endif
end

13
src/dft_utils_func/mu_rsc.irp.f Normal file
View File

@ -0,0 +1,13 @@
double precision function mu_rs_c(rho)
implicit none
double precision, intent(in) :: rho
include 'constants.include.F'
double precision :: cst_rs,alpha_rs,rs
cst_rs = (4.d0 * dacos(-1.d0)/3.d0)**(-1.d0/3.d0)
alpha_rs = 2.d0 * dsqrt((9.d0 * dacos(-1.d0)/4.d0)**(-1.d0/3.d0)) / sqpi
rs = cst_rs * rho**(-1.d0/3.d0)
mu_rs_c = alpha_rs/dsqrt(rs)
end

4
src/dft_utils_func/on_top_from_ueg.irp.f
View File

@ -37,15 +37,13 @@ double precision function g0_UEG_mu_inf(rho_a,rho_b)
rs = (3d0 / (4d0*pi*rho))**(1d0/3d0) ! JT: serious bug fixed 20/03/19
x = -d2*rs
if(dabs(x).lt.50.d0)then
! g0_UEG_mu_inf= 0.5d0 * (1d0- B*rs + C*rs**2 + D*rs**3 + E*rs**4)*dexp(x)
g0_UEG_mu_inf= 0.5d0 * (1d0+ rs* (-B + rs*(C + rs*(D + rs*E))))*dexp(x)
g0_UEG_mu_inf= 0.5d0 * (1d0- B*rs + C*rs**2 + D*rs**3 + E*rs**4)*dexp(x)
else
g0_UEG_mu_inf= 0.d0
endif
else
g0_UEG_mu_inf= 0.d0
endif
g0_UEG_mu_inf = max(g0_UEG_mu_inf,1.d-14)
end

34
src/dft_utils_in_r/ao_in_r.irp.f
View File

@ -91,19 +91,7 @@
enddo
END_PROVIDER
BEGIN_PROVIDER [double precision, aos_lapl_in_r_array_transp, (ao_num, n_points_final_grid,3)]
implicit none
integer :: i,j,m
do i = 1, n_points_final_grid
do j = 1, ao_num
do m = 1, 3
aos_lapl_in_r_array_transp(j,i,m) = aos_lapl_in_r_array(m,j,i)
enddo
enddo
enddo
END_PROVIDER
BEGIN_PROVIDER [double precision, aos_lapl_in_r_array, (3,ao_num,n_points_final_grid)]
BEGIN_PROVIDER[double precision, aos_lapl_in_r_array, (ao_num,n_points_final_grid,3)]
implicit none
BEGIN_DOC
! aos_lapl_in_r_array(i,j,k) = value of the kth component of the laplacian of jth ao on the ith grid point
@ -112,20 +100,20 @@
END_DOC
integer :: i,j,m
double precision :: aos_array(ao_num), r(3)
double precision :: aos_grad_array(3,ao_num)
double precision :: aos_lapl_array(3,ao_num)
double precision :: aos_grad_array(ao_num,3)
double precision :: aos_lapl_array(ao_num,3)
!$OMP PARALLEL DO &
!$OMP DEFAULT (NONE) &
!$OMP PRIVATE (i,r,aos_array,aos_grad_array,aos_lapl_array,j,m) &
!$OMP SHARED(aos_lapl_in_r_array,n_points_final_grid,ao_num,final_grid_points)
do i = 1, n_points_final_grid
r(1) = final_grid_points(1,i)
r(2) = final_grid_points(2,i)
r(3) = final_grid_points(3,i)
call give_all_aos_and_grad_and_lapl_at_r(r,aos_array,aos_grad_array,aos_lapl_array)
do j = 1, ao_num
do m = 1, 3
aos_lapl_in_r_array(m,j,i) = aos_lapl_array(m,j)
do m = 1, 3
do i = 1, n_points_final_grid
r(1) = final_grid_points(1,i)
r(2) = final_grid_points(2,i)
r(3) = final_grid_points(3,i)
call give_all_aos_and_grad_and_lapl_at_r(r,aos_array,aos_grad_array,aos_lapl_array)
do j = 1, ao_num
aos_lapl_in_r_array(j,i,m) = aos_lapl_array(j,m)
enddo
enddo
enddo

39
src/dft_utils_in_r/ints_grad.irp.f
View File

@ -1,39 +0,0 @@
BEGIN_PROVIDER [ double precision, mo_grad_ints, (mo_num, mo_num,3)]
implicit none
BEGIN_DOC
! mo_grad_ints(i,j,m) = <phi_i^MO | d/dx | phi_j^MO>
END_DOC
integer :: i,j,ipoint,m
double precision :: weight
mo_grad_ints = 0.d0
do m = 1, 3
do ipoint = 1, n_points_final_grid
weight = final_weight_at_r_vector(ipoint)
do j = 1, mo_num
do i = 1, mo_num
mo_grad_ints(i,j,m) += mos_grad_in_r_array(j,ipoint,m) * mos_in_r_array(i,ipoint) * weight
enddo
enddo
enddo
enddo
END_PROVIDER
BEGIN_PROVIDER [ double precision, mo_grad_ints_transp, (3,mo_num, mo_num)]
implicit none
BEGIN_DOC
! mo_grad_ints(i,j,m) = <phi_i^MO | d/dx | phi_j^MO>
END_DOC
integer :: i,j,ipoint,m
double precision :: weight
do m = 1, 3
do j = 1, mo_num
do i = 1, mo_num
mo_grad_ints_transp(m,i,j) = mo_grad_ints(i,j,m)
enddo
enddo
enddo
END_PROVIDER

2
src/dft_utils_in_r/mo_in_r.irp.f
View File

@ -138,7 +138,7 @@
integer :: m
mos_lapl_in_r_array = 0.d0
do m=1,3
call dgemm('N','N',mo_num,n_points_final_grid,ao_num,1.d0,mo_coef_transp,mo_num,aos_lapl_in_r_array_transp(1,1,m),ao_num,0.d0,mos_lapl_in_r_array(1,1,m),mo_num)
call dgemm('N','N',mo_num,n_points_final_grid,ao_num,1.d0,mo_coef_transp,mo_num,aos_lapl_in_r_array(1,1,m),ao_num,0.d0,mos_lapl_in_r_array(1,1,m),mo_num)
enddo
END_PROVIDER

2
src/dressing/alpha_factory.irp.f
View File

@ -1179,7 +1179,7 @@ subroutine bitstring_to_list_in_selection( string, list, n_elements, Nint)
use bitmasks
implicit none
BEGIN_DOC
! Gives the indices(+1) of the bits set to 1 in the bit string
! Gives the inidices(+1) of the bits set to 1 in the bit string
END_DOC
integer, intent(in) :: Nint
integer(bit_kind), intent(in) :: string(Nint)

6
src/dressing/run_dress_slave.irp.f
View File

@ -72,7 +72,7 @@ subroutine run_dress_slave(thread,iproce,energy)
provide psi_energy
ending = dress_N_cp+1
ntask_tbd = 0
call set_multiple_levels_omp(.True.)
call omp_set_max_active_levels(8)
!$OMP PARALLEL DEFAULT(SHARED) &
!$OMP PRIVATE(interesting, breve_delta_m, task_id) &
@ -84,7 +84,7 @@ subroutine run_dress_slave(thread,iproce,energy)
zmq_socket_push = new_zmq_push_socket(thread)
integer, external :: connect_to_taskserver
!$OMP CRITICAL
call set_multiple_levels_omp(.False.)
call omp_set_max_active_levels(1)
if (connect_to_taskserver(zmq_to_qp_run_socket,worker_id,thread) == -1) then
print *, irp_here, ': Unable to connect to task server'
stop -1
@ -296,7 +296,7 @@ subroutine run_dress_slave(thread,iproce,energy)
!$OMP END CRITICAL
!$OMP END PARALLEL
call set_multiple_levels_omp(.False.)
call omp_set_max_active_levels(1)
! do i=0,dress_N_cp+1
! call omp_destroy_lock(lck_sto(i))
! end do

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