LCPQ/qp2
9
1
Fork 0
mirror of https://github.com/QuantumPackage/qp2.git synced 2024-11-07 14:03:37 +01:00
Code Releases Activity

Merge branch 'cleaning_dft' into dev-tc

Browse Source
This commit is contained in:
eginer 2022-10-03 14:31:30 +02:00
commit b3f425f57e
142 changed files with 7217 additions and 3467 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

9
ocaml/Command_line.ml
View File

@ -1,5 +1,3 @@
exception Error of string
type short_opt = char type short_opt = char
type long_opt = string type long_opt = string
type optional = Mandatory | Optional 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]); Getopt.parse_cmdline cmd_specs (fun x -> anon_args := !anon_args @ [x]);
if show_help () then if show_help () then
help () (help () ; exit 0);
else
(* Check that all mandatory arguments are set *) (* Check that all mandatory arguments are set *)
List.filter (fun x -> x.short <> ' ' && x.opt = Mandatory) !specs List.filter (fun x -> x.short <> ' ' && x.opt = Mandatory) !specs
|> List.iter (fun x -> |> List.iter (fun x ->
match get x.long with match get x.long with
| Some _ -> () | Some _ -> ()
| None -> raise (Error ("--"^x.long^" option is missing.")) | 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 short_opt = char
type long_opt = string 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" |> String.concat "\n"
let to_string = 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 = let to_xyz =
to_string_general ~f:Atom.to_xyz to_string_general ~f:Atom.to_xyz
@ -113,7 +113,7 @@ let of_xyz_string
s = s =
let l = String_ext.split s ~on:'\n' let l = String_ext.split s ~on:'\n'
|> List.filter (fun x -> x <> "") |> List.filter (fun x -> x <> "")
|> list_map (fun x -> Atom.of_string ~units x) |> list_map (fun x -> Atom.of_string units x)
in in
let ne = ( get_charge { let ne = ( get_charge {
nuclei=l ; nuclei=l ;

4
ocaml/Qputils.ml
View File

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

13
ocaml/qp_create_ezfio.ml
View File

@ -677,15 +677,12 @@ let run ?o b au c d m p cart xyz_file =
let () = let () =
try (
let open Command_line in let open Command_line in
begin begin
"Creates an EZFIO directory from a standard xyz file or from a z-matrix file in Gaussian format. The basis set is defined as a single string if all the atoms are taken from the same basis set, otherwise specific elements can be defined as follows: "Creates an EZFIO directory from a standard xyz file or from a z-matrix file in Gaussian format. The basis set is defined as a single string if all the atoms are taken from the same basis set, otherwise specific elements can be defined as follows:
-b \"cc-pcvdz | H:cc-pvdz | C:6-31g\" -b \"cc-pcvdz | H:cc-pvdz | C:6-31g\"
-b \"cc-pvtz | 1,H:sto-3g | 3,H:6-31g\" -b \"cc-pvtz | 1,H:sto-3g | 3,H:6-31g\"
If a file with the same name as the basis set exists, this file will be read. Otherwise, the basis set is obtained from the database. If a file with the same name as the basis set exists, this file will be read. Otherwise, the basis set is obtained from the database.
" |> set_description_doc ; " |> set_description_doc ;
set_header_doc (Sys.argv.(0) ^ " - Quantum Package command"); set_header_doc (Sys.argv.(0) ^ " - Quantum Package command");
@ -735,7 +732,7 @@ If a file with the same name as the basis set exists, this file will be read. O
let basis = let basis =
match Command_line.get "basis" with match Command_line.get "basis" with
| None -> "" | None -> assert false
| Some x -> x | Some x -> x
in in
@ -774,14 +771,10 @@ If a file with the same name as the basis set exists, this file will be read. O
let xyz_filename = let xyz_filename =
match Command_line.anon_args () with match Command_line.anon_args () with
| [] -> failwith "input file is missing" | [x] -> x
| x::_ -> x | _ -> (Command_line.help () ; failwith "input file is missing")
in in
run ?o:output basis au charge dummy multiplicity pseudo cart xyz_filename 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 task_thread =
let thread = let thread =
Thread.create ( fun () -> Thread.create ( fun () ->
TaskServer.run ~port:port_number ) TaskServer.run port_number )
in in
thread (); thread ();
in in

57
ocaml/qp_tunnel.ml
View File

@ -131,64 +131,37 @@ let () =
Sys.set_signal Sys.sigint handler; 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 = 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.router Zmq.Socket.bind addr_in,
create_socket Zmq.Socket.dealer Zmq.Socket.connect addr_out create_socket Zmq.Socket.dealer Zmq.Socket.connect addr_out
in | SUB ->
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 =
create_socket Zmq.Socket.sub Zmq.Socket.connect addr_in, create_socket Zmq.Socket.sub Zmq.Socket.connect addr_in,
create_socket Zmq.Socket.pub Zmq.Socket.bind addr_out create_socket Zmq.Socket.pub Zmq.Socket.bind addr_out
in in
if req_or_sub = SUB then
Zmq.Socket.subscribe socket_in ""; Zmq.Socket.subscribe socket_in "";
let action_in = let action_in =
fun () -> Zmq.Socket.recv_all socket_in |> Zmq.Socket.send_all socket_out 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 in
let action_out = let action_out =
fun () -> () match req_or_sub with
| REQ -> (fun () -> Zmq.Socket.recv_all socket_out |> Zmq.Socket.send_all socket_in )
| SUB -> (fun () -> () )
in in
let pollitem = let pollitem =
Zmq.Poll.mask_of 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 in
@ -221,7 +194,7 @@ let () =
in in
let f () = let f () =
new_thread_req addr_in addr_out new_thread REQ addr_in addr_out
in in
(Thread.create f) () (Thread.create f) ()
@ -239,7 +212,7 @@ let () =
in in
let f () = let f () =
new_thread_req addr_in addr_out new_thread REQ addr_in addr_out
in in
(Thread.create f) () (Thread.create f) ()
in in
@ -255,7 +228,7 @@ let () =
in in
let f () = let f () =
new_thread_sub addr_in addr_out new_thread SUB addr_in addr_out
in in
(Thread.create f) () (Thread.create f) ()
in in

2
src/ao_basis/EZFIO.cfg
View File

@ -17,7 +17,7 @@ interface: ezfio, provider
[ao_prim_num_max] [ao_prim_num_max]
type: integer type: integer
doc: Maximum number of primitives doc: Maximum number of primitives
default: =maxval(ao_basis.ao_prim_num) #default: =maxval(ao_basis.ao_prim_num)
interface: ezfio interface: ezfio
[ao_nucl] [ao_nucl]

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

@ -16,7 +16,7 @@ BEGIN_PROVIDER [ integer, ao_shell, (ao_num) ]
END_PROVIDER 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) ] &BEGIN_PROVIDER [ double precision, ao_expo , (ao_num,ao_prim_num_max) ]
implicit none implicit none
BEGIN_DOC 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) integer :: power_ao(3)
double precision :: accu,dx,dy,dz,r2 double precision :: accu,dx,dy,dz,r2
num_ao = ao_nucl(i) num_ao = ao_nucl(i)
! power_ao(1:3)= ao_power(i,1:3) power_ao(1:3)= ao_power(i,1:3)
! center_ao(1:3) = nucl_coord(num_ao,1:3) center_ao(1:3) = nucl_coord(num_ao,1:3)
! dx = (r(1) - center_ao(1)) dx = (r(1) - center_ao(1))
! dy = (r(2) - center_ao(2)) dy = (r(2) - center_ao(2))
! dz = (r(3) - center_ao(3)) dz = (r(3) - center_ao(3))
! r2 = dx*dx + dy*dy + dz*dz r2 = dx*dx + dy*dy + dz*dz
! dx = dx**power_ao(1) dx = dx**power_ao(1)
! dy = dy**power_ao(2) dy = dy**power_ao(2)
! dz = dz**power_ao(3) dz = dz**power_ao(3)
accu = 0.d0 accu = 0.d0
! do m=1,ao_prim_num(i) do m=1,ao_prim_num(i)
! beta = ao_expo_ordered_transp(m,i) beta = ao_expo_ordered_transp(m,i)
! accu += ao_coef_normalized_ordered_transp(m,i) * dexp(-beta*r2) accu += ao_coef_normalized_ordered_transp(m,i) * dexp(-beta*r2)
! enddo enddo
ao_value = accu * dx * dy * dz ao_value = accu * dx * dy * dz
end end

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

@ -1,7 +1,7 @@
! Spherical to cartesian transformation matrix obtained with ! Spherical to cartesian transformation matrix obtained with
! Horton (http://theochem.github.com/horton/, 2015) ! 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 ! Second index is the index of the spherical AO
BEGIN_PROVIDER [ double precision, cart_to_sphe_0, (1,1) ] 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 ao_basis
pseudo pseudo
cosgtos_ao_int

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

@ -1,27 +1,47 @@
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_PROVIDER [ double precision, ao_overlap , (ao_num, ao_num) ]
implicit none &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 BEGIN_DOC
! Overlap between atomic basis functions: ! Overlap between atomic basis functions:
! !
! :math:`\int \chi_i(r) \chi_j(r) dr` ! :math:`\int \chi_i(r) \chi_j(r) dr`
END_DOC END_DOC
integer :: i,j,n,l
double precision :: f implicit none
integer :: dim1 integer :: i, j, n, l, dim1, power_A(3), power_B(3)
double precision :: overlap, overlap_x, overlap_y, overlap_z double precision :: overlap, overlap_x, overlap_y, overlap_z
double precision :: alpha, beta, c double precision :: alpha, beta, c
double precision :: A_center(3), B_center(3) 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_x = 0.d0
ao_overlap_y = 0.d0 ao_overlap_y = 0.d0
ao_overlap_z = 0.d0 ao_overlap_z = 0.d0
if (read_ao_integrals_overlap) then
if(read_ao_integrals_overlap) then
call ezfio_get_ao_one_e_ints_ao_integrals_overlap(ao_overlap(1:ao_num, 1:ao_num)) 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' print *, 'AO overlap integrals read from disk'
else
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 else
dim1=100 dim1=100
@ -69,7 +89,11 @@
enddo enddo
enddo enddo
!$OMP END PARALLEL DO !$OMP END PARALLEL DO
endif endif
endif
if (write_ao_integrals_overlap) then if (write_ao_integrals_overlap) then
call ezfio_set_ao_one_e_ints_ao_integrals_overlap(ao_overlap(1:ao_num, 1:ao_num)) 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' print *, 'AO overlap integrals written to disk'
@ -77,6 +101,8 @@
END_PROVIDER END_PROVIDER
! ---
BEGIN_PROVIDER [ double precision, ao_overlap_imag, (ao_num, ao_num) ] BEGIN_PROVIDER [ double precision, ao_overlap_imag, (ao_num, ao_num) ]
implicit none implicit none
BEGIN_DOC BEGIN_DOC
@ -85,6 +111,8 @@ BEGIN_PROVIDER [ double precision, ao_overlap_imag, (ao_num, ao_num) ]
ao_overlap_imag = 0.d0 ao_overlap_imag = 0.d0
END_PROVIDER END_PROVIDER
! ---
BEGIN_PROVIDER [ complex*16, ao_overlap_complex, (ao_num, ao_num) ] BEGIN_PROVIDER [ complex*16, ao_overlap_complex, (ao_num, ao_num) ]
implicit none implicit none
BEGIN_DOC BEGIN_DOC
@ -98,37 +126,39 @@ BEGIN_PROVIDER [ complex*16, ao_overlap_complex, (ao_num, ao_num) ]
enddo enddo
END_PROVIDER 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 BEGIN_DOC
! Overlap between absolute values of atomic basis functions: ! Overlap between absolute values of atomic basis functions:
! !
! :math:`\int |\chi_i(r)| |\chi_j(r)| dr` ! :math:`\int |\chi_i(r)| |\chi_j(r)| dr`
END_DOC END_DOC
integer :: i,j,n,l
double precision :: f implicit none
integer :: dim1 integer :: i, j, n, l, dim1, power_A(3), power_B(3)
double precision :: overlap, overlap_x, overlap_y, overlap_z double precision :: overlap_x, overlap_y, overlap_z
double precision :: alpha, beta double precision :: alpha, beta
double precision :: A_center(3), B_center(3) double precision :: A_center(3), B_center(3)
integer :: power_A(3), power_B(3)
double precision :: lower_exp_val, dx double precision :: lower_exp_val, dx
if (is_periodic) then
do j=1,ao_num if(is_periodic) then
do i= 1,ao_num
ao_overlap_abs(i,j)= cdabs(ao_overlap_complex(i,j)) do j = 1, ao_num
do i = 1, ao_num
ao_overlap_abs(i,j) = cdabs(ao_overlap_complex(i,j))
enddo enddo
enddo enddo
else else
dim1=100 dim1=100
lower_exp_val = 40.d0 lower_exp_val = 40.d0
!$OMP PARALLEL DO SCHEDULE(GUIDED) & !$OMP PARALLEL DO SCHEDULE(GUIDED) &
!$OMP DEFAULT(NONE) & !$OMP DEFAULT(NONE) &
!$OMP PRIVATE(A_center,B_center,power_A,power_B, & !$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 alpha, beta,i,j,dx) &
!$OMP SHARED(nucl_coord,ao_power,ao_prim_num, & !$OMP SHARED(nucl_coord,ao_power,ao_prim_num, &
!$OMP ao_overlap_abs,ao_num,ao_coef_normalized_ordered_transp,ao_nucl,& !$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
enddo enddo
!$OMP END PARALLEL DO !$OMP END PARALLEL DO
endif endif
END_PROVIDER END_PROVIDER
! ---
BEGIN_PROVIDER [ double precision, S_inv,(ao_num,ao_num) ] BEGIN_PROVIDER [ double precision, S_inv,(ao_num,ao_num) ]
implicit none implicit none
BEGIN_DOC BEGIN_DOC

36
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 BEGIN_DOC
! Second derivative matrix elements in the |AO| basis. ! Second derivative matrix elements in the |AO| basis.
! !
@ -11,15 +14,28 @@
! \langle \chi_i(x,y,z) | \frac{\partial^2}{\partial x^2} |\chi_j (x,y,z) \rangle ! \langle \chi_i(x,y,z) | \frac{\partial^2}{\partial x^2} |\chi_j (x,y,z) \rangle
! !
END_DOC END_DOC
integer :: i,j,n,l
double precision :: f implicit none
integer :: dim1 integer :: i, j, n, l, dim1, power_A(3), power_B(3)
double precision :: overlap, overlap_y, overlap_z double precision :: overlap, overlap_y, overlap_z
double precision :: overlap_x0, overlap_y0, overlap_z0 double precision :: overlap_x0, overlap_y0, overlap_z0
double precision :: alpha, beta, c double precision :: alpha, beta, c
double precision :: A_center(3), B_center(3) double precision :: A_center(3), B_center(3)
integer :: power_A(3), power_B(3)
double precision :: d_a_2,d_2 double precision :: d_a_2,d_2
if(use_cosgtos) then
!print*, 'use_cosgtos for ao_kinetic_integrals ?', use_cosgtos
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
else
dim1=100 dim1=100
! -- Dummy call to provide everything ! -- Dummy call to provide everything
@ -117,8 +133,12 @@
enddo enddo
!$OMP END PARALLEL DO !$OMP END PARALLEL DO
endif
END_PROVIDER END_PROVIDER
! ---
BEGIN_PROVIDER [double precision, ao_kinetic_integrals, (ao_num,ao_num)] BEGIN_PROVIDER [double precision, ao_kinetic_integrals, (ao_num,ao_num)]
implicit none implicit none
BEGIN_DOC BEGIN_DOC

112
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_PROVIDER [ double precision, ao_integrals_n_e, (ao_num,ao_num)]
BEGIN_DOC BEGIN_DOC
! Nucleus-electron interaction, in the |AO| basis set. ! Nucleus-electron interaction, in the |AO| basis set.
! !
@ -6,17 +10,30 @@ BEGIN_PROVIDER [ double precision, ao_integrals_n_e, (ao_num,ao_num)]
! !
! These integrals also contain the pseudopotential integrals. ! These integrals also contain the pseudopotential integrals.
END_DOC END_DOC
implicit none implicit none
double precision :: alpha, beta, gama, delta integer :: num_A, num_B, power_A(3), power_B(3)
integer :: num_A,num_B 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 :: 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 double precision :: overlap_x,overlap_y,overlap_z,overlap,dx,NAI_pol_mult
if (read_ao_integrals_n_e) then if (read_ao_integrals_n_e) then
call ezfio_get_ao_one_e_ints_ao_integrals_n_e(ao_integrals_n_e) call ezfio_get_ao_one_e_ints_ao_integrals_n_e(ao_integrals_n_e)
print *, 'AO N-e integrals read from disk' print *, 'AO N-e integrals read from disk'
else
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
else else
ao_integrals_n_e = 0.d0 ao_integrals_n_e = 0.d0
@ -29,7 +46,7 @@ BEGIN_PROVIDER [ double precision, ao_integrals_n_e, (ao_num,ao_num)]
!$OMP PARALLEL & !$OMP PARALLEL &
!$OMP DEFAULT (NONE) & !$OMP DEFAULT (NONE) &
!$OMP PRIVATE (i,j,k,l,m,alpha,beta,A_center,B_center,C_center,power_A,power_B,& !$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 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 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) !$OMP n_pt_max_integrals,ao_integrals_n_e,nucl_num,nucl_charge)
@ -54,7 +71,7 @@ BEGIN_PROVIDER [ double precision, ao_integrals_n_e, (ao_num,ao_num)]
do m=1,ao_prim_num(i) do m=1,ao_prim_num(i)
beta = ao_expo_ordered_transp(m,i) beta = ao_expo_ordered_transp(m,i)
double precision :: c double precision :: c, c1
c = 0.d0 c = 0.d0
do k = 1, nucl_num do k = 1, nucl_num
@ -63,8 +80,16 @@ BEGIN_PROVIDER [ double precision, ao_integrals_n_e, (ao_num,ao_num)]
C_center(1:3) = nucl_coord(k,1:3) C_center(1:3) = nucl_coord(k,1:3)
c = c - Z * NAI_pol_mult(A_center,B_center, & !print *, ' '
power_A,power_B,alpha,beta,C_center,n_pt_in) !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 enddo
ao_integrals_n_e(i,j) = ao_integrals_n_e(i,j) & ao_integrals_n_e(i,j) = ao_integrals_n_e(i,j) &
@ -77,7 +102,11 @@ BEGIN_PROVIDER [ double precision, ao_integrals_n_e, (ao_num,ao_num)]
!$OMP END DO !$OMP END DO
!$OMP END PARALLEL !$OMP END PARALLEL
IF (DO_PSEUDO) THEN
endif
IF(DO_PSEUDO) THEN
ao_integrals_n_e += ao_pseudo_integrals ao_integrals_n_e += ao_pseudo_integrals
ENDIF 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` ! :math:`\langle \chi_i | -\sum_A \frac{1}{|r-R_A|} | \chi_j \rangle`
END_DOC END_DOC
implicit none implicit none
double precision :: alpha, beta, gama, delta double precision :: alpha, beta
integer :: num_A,num_B integer :: num_A,num_B
double precision :: A_center(3),B_center(3),C_center(3) double precision :: A_center(3),B_center(3),C_center(3)
integer :: power_A(3),power_B(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` ! :math:`\langle \chi_i | -\frac{1}{|r-R_A|} | \chi_j \rangle`
END_DOC END_DOC
implicit none implicit none
double precision :: alpha, beta, gama, delta double precision :: alpha, beta
integer :: i_c,num_A,num_B integer :: i_c,num_A,num_B
double precision :: A_center(3),B_center(3),C_center(3) double precision :: A_center(3),B_center(3),C_center(3)
integer :: power_A(3),power_B(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 ! 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 do i =0 ,n_pt_out,2
accu += d(i) * rint(i/2,const) accu += d(i) * rint(i/2,const)
! print *, i/2, const, d(i), rint(shiftr(i, 1), const)
enddo enddo
NAI_pol_mult = accu * coeff NAI_pol_mult = accu * coeff
end 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) 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 implicit none
@ -575,61 +607,3 @@ double precision function V_r(n,alpha)
end 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 END_PROVIDER
BEGIN_PROVIDER [ double precision, ao_pseudo_integrals_local, (ao_num,ao_num)] BEGIN_PROVIDER [ double precision, ao_pseudo_integrals_local, (ao_num,ao_num)]
use omp_lib
implicit none implicit none
BEGIN_DOC BEGIN_DOC
! Local pseudo-potential ! 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 double precision :: wall_1, wall_2, wall_0
integer :: thread_num integer :: thread_num
integer :: omp_get_thread_num
double precision :: c double precision :: c
double precision :: Z 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)] BEGIN_PROVIDER [ double precision, ao_pseudo_integrals_non_local, (ao_num,ao_num)]
use omp_lib
implicit none implicit none
BEGIN_DOC BEGIN_DOC
! Non-local pseudo-potential ! 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 :: power_A(3),power_B(3)
integer :: i,j,k,l,m integer :: i,j,k,l,m
double precision :: Vloc, Vpseudo double precision :: Vloc, Vpseudo
integer :: omp_get_thread_num
double precision :: wall_1, wall_2, wall_0 double precision :: wall_1, wall_2, wall_0
integer :: thread_num 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 interface: ezfio,provider,ocaml
default: None 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] [do_direct_integrals]
type: logical type: logical
doc: Compute integrals on the fly (very slow, only for debugging) doc: Compute integrals on the fly (very slow, only for debugging)

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 implicit none
BEGIN_DOC BEGIN_DOC
! Gets one AO bi-electronic integral from the AO map ! Gets one AO bi-electronic integral from the AO map
!
! i,j,k,l in physicist notation <ij|kl>
END_DOC END_DOC
integer, intent(in) :: i,j,k,l integer, intent(in) :: i,j,k,l
integer(key_kind) :: idx 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
! ---

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

@ -1,23 +1,42 @@
! ---
double precision function ao_two_e_integral(i,j,k,l) double precision function ao_two_e_integral(i,j,k,l)
implicit none
BEGIN_DOC BEGIN_DOC
! integral of the AO basis <ik|jl> or (ij|kl) ! integral of the AO basis <ik|jl> or (ij|kl)
! i(r1) j(r1) 1/r12 k(r2) l(r2) ! i(r1) j(r1) 1/r12 k(r2) l(r2)
END_DOC END_DOC
integer,intent(in) :: i,j,k,l implicit none
integer :: p,q,r,s
double precision :: I_center(3),J_center(3),K_center(3),L_center(3)
integer :: num_i,num_j,num_k,num_l,dim1,I_power(3),J_power(3),K_power(3),L_power(3)
double precision :: integral
include 'utils/constants.include.F' 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 :: P_new(0:max_dim,3),P_center(3),fact_p,pp
double precision :: Q_new(0:max_dim,3),Q_center(3),fact_q,qq double precision :: 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 double precision :: ao_two_e_integral_schwartz_accel
double precision :: ao_two_e_integral_cosgtos
if(use_cosgtos) then
!print *, ' use_cosgtos for ao_two_e_integral ?', use_cosgtos
ao_two_e_integral = ao_two_e_integral_cosgtos(i,j,k,l)
else
if (ao_prim_num(i) * ao_prim_num(j) * ao_prim_num(k) * ao_prim_num(l) > 1024 ) then if (ao_prim_num(i) * ao_prim_num(j) * ao_prim_num(k) * ao_prim_num(l) > 1024 ) then
ao_two_e_integral = ao_two_e_integral_schwartz_accel(i,j,k,l) ao_two_e_integral = ao_two_e_integral_schwartz_accel(i,j,k,l)
else else
dim1 = n_pt_max_integrals dim1 = n_pt_max_integrals
@ -101,8 +120,13 @@ double precision function ao_two_e_integral(i,j,k,l)
endif endif
endif endif
endif
end end
! ---
double precision function ao_two_e_integral_schwartz_accel(i,j,k,l) double precision function ao_two_e_integral_schwartz_accel(i,j,k,l)
implicit none implicit none
BEGIN_DOC BEGIN_DOC
@ -420,13 +444,16 @@ BEGIN_PROVIDER [ logical, ao_two_e_integrals_in_map ]
END_PROVIDER 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 BEGIN_DOC
! Needed to compute Schwartz inequalities ! Needed to compute Schwartz inequalities
END_DOC END_DOC
integer :: i,k implicit none
integer :: i, k
double precision :: ao_two_e_integral,cpu_1,cpu_2, wall_1, wall_2 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) ao_two_e_integral_schwartz(1,1) = ao_two_e_integral(1,1,1,1)
@ -444,6 +471,7 @@ BEGIN_PROVIDER [ double precision, ao_two_e_integral_schwartz,(ao_num,ao_num) ]
END_PROVIDER END_PROVIDER
! ---
double precision function general_primitive_integral(dim, & double precision function general_primitive_integral(dim, &
P_new,P_center,fact_p,p,p_inv,iorder_p, & P_new,P_center,fact_p,p,p_inv,iorder_p, &
@ -575,7 +603,10 @@ double precision function general_primitive_integral(dim, &
!DIR$ FORCEINLINE !DIR$ FORCEINLINE
call multiply_poly(d_poly ,n_pt_tmp ,Iz_pol,n_Iz,d1,n_pt_out) call multiply_poly(d_poly ,n_pt_tmp ,Iz_pol,n_Iz,d1,n_pt_out)
double precision :: rint_sum double precision :: rint_sum
accu = accu + rint_sum(n_pt_out,const,d1) accu = accu + rint_sum(n_pt_out,const,d1)
! 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) general_primitive_integral = fact_p * fact_q * accu *pi_5_2*p_inv*q_inv/dsqrt(p+q)
end 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 !DIR$ FORCEINLINE
call I_x1_pol_mult(a_x,d_x,B10,B01,B00,C00,D00,d,n_pt1,n_pt_in) 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 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 if(n_pt1<0)then
n_pt_out = -1 n_pt_out = -1
do i = 0,n_pt_in do i = 0,n_pt_in

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) write(*, '(A29,X,I3,X,A3,X,F16.10)') ' ECMD PBE-UEG , state ',istate,' = ',ecmd_pbe_ueg_mu_of_r(istate)
enddo 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*, ''
print*,'Using a CAS-like two-body density to define mu(r)' print*,'Using a CAS-like two-body density to define mu(r)'
print*,'This assumes that the CAS is a qualitative representation of the wave function ' print*,'This assumes that the CAS is a qualitative representation of the wave function '

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

@ -58,17 +58,3 @@ END_PROVIDER
enddo enddo
END_PROVIDER 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 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) logical function is_integer_in_string(bite,string,Nint)
use bitmasks use bitmasks
implicit none 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] [save_wf_after_selection]
type: logical type: logical
doc: If true, saves the wave function after the selection, before the diagonalization 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 interface: ezfio,ocaml,provider
default: -1 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 zmq
mpi mpi
iterations iterations
two_body_rdm
csf csf

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

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

104
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(ZMQ_PTR) :: zmq_to_qp_run_socket, zmq_socket_pull
integer, intent(in) :: N_in integer, intent(in) :: N_in
! integer, intent(inout) :: N_in
double precision, intent(in) :: relative_error, E(N_states) double precision, intent(in) :: relative_error, E(N_states)
type(pt2_type), intent(inout) :: pt2_data, pt2_data_err 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_rows_loc psi_bilinear_matrix_transp_columns
PROVIDE psi_bilinear_matrix_transp_order psi_selectors_coef_transp psi_det_sorted PROVIDE psi_bilinear_matrix_transp_order psi_selectors_coef_transp psi_det_sorted
PROVIDE psi_det_hii selection_weight pseudo_sym PROVIDE psi_det_hii selection_weight pseudo_sym
PROVIDE list_act list_inact list_core list_virt list_del seniority_max 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
if (h0_type == 'CFG') then if (h0_type == 'CFG') then
PROVIDE psi_configuration_hii det_to_configuration 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_int(6,nproc_target,'Number of threads for PT2')
call write_double(6,mem,'Memory (Gb)') 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)', '========== ======================= ===================== ===================== ===========' print '(A)', ' Samples Energy Variance Norm^2 Seconds'
!print '(A)', ' Samples Energy Variance Norm^2 Seconds' print '(A)', '========== ======================= ===================== ===================== ==========='
!print '(A)', '========== ======================= ===================== ===================== ==========='
print '(A)', '========== ==================== ================ ================ ================ ============= ==========='
print '(A)', ' Samples Energy PT2 Variance Norm^2 Convergence Seconds'
print '(A)', '========== ==================== ================ ================ ================ ============= ==========='
PROVIDE global_selection_buffer PROVIDE global_selection_buffer
@ -318,12 +315,9 @@ subroutine ZMQ_pt2(E, pt2_data, pt2_data_err, relative_error, N_in)
endif endif
!$OMP END PARALLEL !$OMP END PARALLEL
call end_parallel_job(zmq_to_qp_run_socket, zmq_socket_pull, 'pt2') 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 do k=1,N_states
pt2_overlap(pt2_stoch_istate,k) = pt2_data % overlap(k,pt2_stoch_istate) pt2_overlap(pt2_stoch_istate,k) = pt2_data % overlap(k,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 :: rss
double precision, external :: memory_of_double, memory_of_int 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. sending =.False.
rss = memory_of_int(pt2_n_tasks_max*2+N_det_generators*2) 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) ! 1/(N-1.5) : see Brugger, The American Statistician (23) 4 p. 32 (1969)
if(c > 2) then 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 = 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 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 = 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 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(:) = 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(:) pt2_data_err % overlap(:,pt2_stoch_istate) = eqta(:)
if ((time - time1 > 1.d0) .or. (n==N_det_generators)) then if ((time - time1 > 1.d0) .or. (n==N_det_generators)) then
time1 = time time1 = time
print '(I10, X, F12.6, X, G10.3, X, F10.6, X, G10.3, X, F10.6, X, G10.3, X, F10.4)', c, &
value1 = pt2_data % pt2(pt2_stoch_istate) + E pt2_data % pt2(pt2_stoch_istate) +E, &
error1 = pt2_data_err % pt2(pt2_stoch_istate) pt2_data_err % pt2(pt2_stoch_istate), &
value2 = pt2_data % pt2(pt2_stoch_istate) pt2_data % variance(pt2_stoch_istate), &
error2 = pt2_data_err % pt2(pt2_stoch_istate) pt2_data_err % variance(pt2_stoch_istate), &
value3 = pt2_data % variance(pt2_stoch_istate) pt2_data % overlap(pt2_stoch_istate,pt2_stoch_istate), &
error3 = pt2_data_err % variance(pt2_stoch_istate) pt2_data_err % overlap(pt2_stoch_istate,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 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)) )
if (stop_now .or. ( & if (stop_now .or. ( &
(do_exit .and. (dabs(pt2_data_err % pt2(pt2_stoch_istate)) / & (do_exit .and. (dabs(pt2_data_err % pt2(pt2_stoch_istate)) / &
(1.d-20 + dabs(pt2_data % pt2(pt2_stoch_istate)) ) <= relative_error))) ) then (1.d-20 + dabs(pt2_data % pt2(pt2_stoch_istate)) ) <= relative_error))) ) then
@ -906,8 +843,9 @@ END_PROVIDER
do t=1, pt2_N_teeth do t=1, pt2_N_teeth
tooth_width = tilde_cW(pt2_n_0(t+1)) - tilde_cW(pt2_n_0(t)) tooth_width = tilde_cW(pt2_n_0(t+1)) - tilde_cW(pt2_n_0(t))
if (tooth_width == 0.d0) then 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 endif
ASSERT(tooth_width > 0.d0)
do i=pt2_n_0(t)+1, pt2_n_0(t+1) do i=pt2_n_0(t)+1, pt2_n_0(t+1)
pt2_w(i) = tilde_w(i) * pt2_W_T / tooth_width pt2_w(i) = tilde_w(i) * pt2_W_T / tooth_width
end do end do

45
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) double precision, intent(in) :: energy(N_states_diag)
integer, intent(in) :: thread, iproc integer, intent(in) :: thread, iproc
if (N_det > 100000 ) then
call run_pt2_slave_large(thread,iproc,energy) call run_pt2_slave_large(thread,iproc,energy)
else ! if (N_det > nproc*(elec_alpha_num * (mo_num-elec_alpha_num))**2) then
call run_pt2_slave_small(thread,iproc,energy) ! call run_pt2_slave_large(thread,iproc,energy)
endif ! else
! call run_pt2_slave_small(thread,iproc,energy)
! endif
end end
subroutine run_pt2_slave_small(thread,iproc,energy) 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 double precision, external :: memory_of_double, memory_of_int
integer :: bsize ! Size of selection buffers integer :: bsize ! Size of selection buffers
! logical :: sending
allocate(task_id(pt2_n_tasks_max), task(pt2_n_tasks_max)) 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)) 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. buffer_ready = .False.
n_tasks = 1 n_tasks = 1
! sending = .False.
done = .False. done = .False.
do while (.not.done) do while (.not.done)
@ -116,13 +119,14 @@ subroutine run_pt2_slave_small(thread,iproc,energy)
do k=1,n_tasks do k=1,n_tasks
call pt2_alloc(pt2_data(k),N_states) call pt2_alloc(pt2_data(k),N_states)
b%cur = 0 b%cur = 0
! double precision :: time2 !double precision :: time2
! call wall_time(time2) !call wall_time(time2)
call select_connected(i_generator(k),energy,pt2_data(k),b,subset(k),pt2_F(i_generator(k))) call select_connected(i_generator(k),energy,pt2_data(k),b,subset(k),pt2_F(i_generator(k)))
! call wall_time(time1) !call wall_time(time1)
! print *, i_generator(1), time1-time2, n_tasks, pt2_F(i_generator(1)) !print *, i_generator(1), time1-time2, n_tasks, pt2_F(i_generator(1))
enddo enddo
call wall_time(time1) call wall_time(time1)
!print *, '-->', i_generator(1), time1-time0, n_tasks
integer, external :: tasks_done_to_taskserver integer, external :: tasks_done_to_taskserver
if (tasks_done_to_taskserver(zmq_to_qp_run_socket,worker_id,task_id,n_tasks) == -1) then 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) subroutine run_pt2_slave_large(thread,iproc,energy)
use selection_types use selection_types
use f77_zmq 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 implicit none
double precision, intent(in) :: energy(N_states_diag) 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 integer :: bsize ! Size of selection buffers
logical :: sending logical :: sending
double precision :: time_shift
PROVIDE global_selection_buffer global_selection_buffer_lock 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() 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. sending = .False.
done = .False. done = .False.
double precision :: time0, time1
call wall_time(time0)
time0 = time0+time_shift
do while (.not.done) do while (.not.done)
integer, external :: get_tasks_from_taskserver integer, external :: get_tasks_from_taskserver
@ -242,28 +234,25 @@ subroutine run_pt2_slave_large(thread,iproc,energy)
ASSERT (b%N == bsize) ASSERT (b%N == bsize)
endif endif
double precision :: time0, time1
call wall_time(time0)
call pt2_alloc(pt2_data,N_states) call pt2_alloc(pt2_data,N_states)
b%cur = 0 b%cur = 0
call select_connected(i_generator,energy,pt2_data,b,subset,pt2_F(i_generator)) call select_connected(i_generator,energy,pt2_data,b,subset,pt2_F(i_generator))
call wall_time(time1)
integer, external :: tasks_done_to_taskserver integer, external :: tasks_done_to_taskserver
if (tasks_done_to_taskserver(zmq_to_qp_run_socket,worker_id,task_id,n_tasks) == -1) then if (tasks_done_to_taskserver(zmq_to_qp_run_socket,worker_id,task_id,n_tasks) == -1) then
done = .true. done = .true.
endif endif
call sort_selection_buffer(b) call sort_selection_buffer(b)
call push_pt2_results_async_recv(zmq_socket_push,b%mini,sending)
call wall_time(time1)
! if (time1-time0 > 15.d0) then
call omp_set_lock(global_selection_buffer_lock) call omp_set_lock(global_selection_buffer_lock)
global_selection_buffer%mini = b%mini global_selection_buffer%mini = b%mini
call merge_selection_buffers(b,global_selection_buffer) call merge_selection_buffers(b,global_selection_buffer)
b%cur=0 b%cur=0
call omp_unset_lock(global_selection_buffer_lock) call omp_unset_lock(global_selection_buffer_lock)
call wall_time(time0) if ( iproc == 1 ) then
! 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) 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) 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 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 if (N /= buf%N) then
print *, 'N=', N print *, 'N=', N
print *, 'buf%N=', buf%N print *, 'buf%N=', buf%N
print *, 'In ', irp_here, ': N /= buf%N' print *, 'bug in ', irp_here
stop -1 stop '-1'
end if end if
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)) call select_connected(i_generator,energy,pt2_data,buf,subset,pt2_F(i_generator))
endif 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 :: l_a, nmax, idx
integer, allocatable :: indices(:), exc_degree(:), iorder(:) integer, allocatable :: indices(:), exc_degree(:), iorder(:)
double precision, parameter :: norm_thr = 1.d-16
! Removed to avoid introducing determinants already presents in the wf
!double precision, parameter :: norm_thr = 1.d-16
allocate (indices(N_det), & allocate (indices(N_det), &
exc_degree(max(N_det_alpha_unique,N_det_beta_unique))) 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) i = psi_bilinear_matrix_rows(l_a)
if (nt + exc_degree(i) <= 4) then if (nt + exc_degree(i) <= 4) then
idx = psi_det_sorted_order(psi_bilinear_matrix_order(l_a)) 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 indices(k) = idx
k=k+1 k=k+1
!endif endif
endif endif
enddo enddo
enddo enddo
@ -246,11 +242,10 @@ subroutine select_singles_and_doubles(i_generator,hole_mask,particle_mask,fock_d
idx = psi_det_sorted_order( & idx = psi_det_sorted_order( &
psi_bilinear_matrix_order( & psi_bilinear_matrix_order( &
psi_bilinear_matrix_transp_order(l_a))) 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 indices(k) = idx
k=k+1 k=k+1
!endif endif
endif endif
enddo enddo
enddo enddo
@ -258,6 +253,8 @@ subroutine select_singles_and_doubles(i_generator,hole_mask,particle_mask,fock_d
deallocate(exc_degree) deallocate(exc_degree)
nmax=k-1 nmax=k-1
call isort_noidx(indices,nmax)
! Start with 32 elements. Size will double along with the filtering. ! Start with 32 elements. Size will double along with the filtering.
allocate(preinteresting(0:32), prefullinteresting(0:32), & allocate(preinteresting(0:32), prefullinteresting(0:32), &
interesting(0:32), fullinteresting(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)), & allocate (fullminilist (N_int, 2, fullinteresting(0)), &
minilist (N_int, 2, interesting(0)) ) minilist (N_int, 2, interesting(0)) )
! if(pert_2rdm)then if(pert_2rdm)then
! allocate(coef_fullminilist_rev(N_states,fullinteresting(0))) allocate(coef_fullminilist_rev(N_states,fullinteresting(0)))
! do i=1,fullinteresting(0) do i=1,fullinteresting(0)
! do j = 1, N_states do j = 1, N_states
! coef_fullminilist_rev(j,i) = psi_coef_sorted(fullinteresting(i),j) coef_fullminilist_rev(j,i) = psi_coef_sorted(fullinteresting(i),j)
! enddo enddo
! enddo enddo
! endif endif
do i=1,fullinteresting(0) 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 enddo
do i=1,interesting(0) 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 enddo
do s2=s1,2 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) 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) call fill_buffer_double(i_generator, sp, h1, h2, bannedOrb, banned, fock_diag_tmp, E0, pt2_data, mat, buf)
! else 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)) 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 endif
end if end if
enddo enddo
if(s1 /= s2) monoBdo = .false. if(s1 /= s2) monoBdo = .false.
enddo enddo
deallocate(fullminilist,minilist) deallocate(fullminilist,minilist)
! if(pert_2rdm)then if(pert_2rdm)then
! deallocate(coef_fullminilist_rev) deallocate(coef_fullminilist_rev)
! endif endif
enddo enddo
enddo enddo
deallocate(preinteresting, prefullinteresting, interesting, fullinteresting) 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, external :: diag_H_mat_elem_fock
double precision :: E_shift double precision :: E_shift
double precision :: s_weight(N_states,N_states) double precision :: s_weight(N_states,N_states)
logical, external :: is_in_wavefunction
PROVIDE dominant_dets_of_cfgs N_dominant_dets_of_cfgs PROVIDE dominant_dets_of_cfgs N_dominant_dets_of_cfgs
do jstate=1,N_states do jstate=1,N_states
do istate=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 if (do_cycle) cycle
endif 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) Hii = diag_H_mat_elem_fock(psi_det_generators(1,1,i_generator),det,fock_diag_tmp,N_int)
w = 0d0 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) alpha_h_psi = mat(istate, p1, p2)
do k=1,N_states pt2_data % overlap(:,istate) = pt2_data % overlap(:,istate) + coef(:) * coef(istate)
pt2_data % overlap(k,istate) = pt2_data % overlap(k,istate) + coef(k) * coef(istate)
end do
pt2_data % variance(istate) = pt2_data % variance(istate) + alpha_h_psi * alpha_h_psi 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) 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 endif
end select 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 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 integer(bit_kind) :: occ(N_int,2), n
if (h0_type == 'CFG') then if (h0_type == 'CFG') then
@ -1594,7 +1556,7 @@ subroutine bitstring_to_list_in_selection( string, list, n_elements, Nint)
use bitmasks use bitmasks
implicit none implicit none
BEGIN_DOC 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 END_DOC
integer, intent(in) :: Nint integer, intent(in) :: Nint
integer(bit_kind), intent(in) :: string(Nint) integer(bit_kind), intent(in) :: string(Nint)

54
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 b%val(b%cur) = val
if(b%cur == size(b%val)) then if(b%cur == size(b%val)) then
call sort_selection_buffer(b) call sort_selection_buffer(b)
b%cur = b%cur-1
end if end if
end if end if
end subroutine end subroutine
@ -87,56 +86,43 @@ subroutine merge_selection_buffers(b1, b2)
double precision :: rss double precision :: rss
double precision, external :: memory_of_double double precision, external :: memory_of_double
sze = max(size(b1%val), size(b2%val)) sze = max(size(b1%val), size(b2%val))
! rss = memory_of_double(sze) + 2*N_int*memory_of_double(sze) rss = memory_of_double(sze) + 2*N_int*memory_of_double(sze)
! call check_mem(rss,irp_here) call check_mem(rss,irp_here)
allocate(val(sze), detmp(N_int, 2, sze)) allocate(val(sze), detmp(N_int, 2, sze))
i1=1 i1=1
i2=1 i2=1
select case (N_int)
BEGIN_TEMPLATE
case $case
do i=1,nmwen do i=1,nmwen
if ( (i1 > b1%cur).and.(i2 > b2%cur) ) then if ( (i1 > b1%cur).and.(i2 > b2%cur) ) then
exit exit
else if (i1 > b1%cur) then else if (i1 > b1%cur) then
val(i) = b2%val(i2) val(i) = b2%val(i2)
detmp(1:$N_int,1,i) = b2%det(1:$N_int,1,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) detmp(1:N_int,2,i) = b2%det(1:N_int,2,i2)
i2=i2+1 i2=i2+1
else if (i2 > b2%cur) then else if (i2 > b2%cur) then
val(i) = b1%val(i1) val(i) = b1%val(i1)
detmp(1:$N_int,1,i) = b1%det(1:$N_int,1,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) detmp(1:N_int,2,i) = b1%det(1:N_int,2,i1)
i1=i1+1 i1=i1+1
else else
if (b1%val(i1) <= b2%val(i2)) then if (b1%val(i1) <= b2%val(i2)) then
val(i) = b1%val(i1) val(i) = b1%val(i1)
detmp(1:$N_int,1,i) = b1%det(1:$N_int,1,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) detmp(1:N_int,2,i) = b1%det(1:N_int,2,i1)
i1=i1+1 i1=i1+1
else else
val(i) = b2%val(i2) val(i) = b2%val(i2)
detmp(1:$N_int,1,i) = b2%det(1:$N_int,1,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) detmp(1:N_int,2,i) = b2%det(1:N_int,2,i2)
i2=i2+1 i2=i2+1
endif endif
endif endif
enddo enddo
deallocate(b2%det, b2%val)
do i=nmwen+1,b2%N do i=nmwen+1,b2%N
val(i) = 0.d0 val(i) = 0.d0
! detmp(1:$N_int,1,i) = 0_bit_kind detmp(1:N_int,1:2,i) = 0_bit_kind
! detmp(1:$N_int,2,i) = 0_bit_kind
enddo enddo
SUBST [ case, N_int ]
(1); 1;;
(2); 2;;
(3); 3;;
(4); 4;;
default; N_int;;
END_TEMPLATE
end select
deallocate(b2%det, b2%val)
b2%det => detmp b2%det => detmp
b2%val => val b2%val => val
b2%mini = min(b2%mini,b2%val(b2%N)) b2%mini = min(b2%mini,b2%val(b2%N))
@ -158,8 +144,8 @@ subroutine sort_selection_buffer(b)
double precision :: rss double precision :: rss
double precision, external :: memory_of_double, memory_of_int 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)) rss = memory_of_int(b%cur) + 2*N_int*memory_of_double(size(b%det,3))
! call check_mem(rss,irp_here) call check_mem(rss,irp_here)
allocate(iorder(b%cur), detmp(N_int, 2, size(b%det,3))) allocate(iorder(b%cur), detmp(N_int, 2, size(b%det,3)))
do i=1,b%cur do i=1,b%cur
iorder(i) = i iorder(i) = i
@ -239,14 +225,14 @@ subroutine make_selection_buffer_s2(b)
endif endif
dup = .True. dup = .True.
do k=1,N_int do k=1,N_int
if ( (tmp_array(k,1,i) /= tmp_array(k,1,j)) .or. & if ( (tmp_array(k,1,i) /= tmp_array(k,1,j)) &
(tmp_array(k,2,i) /= tmp_array(k,2,j)) ) then .or. (tmp_array(k,2,i) /= tmp_array(k,2,j)) ) then
dup = .False. dup = .False.
exit exit
endif endif
enddo enddo
if (dup) then if (dup) then
val(i) = min(val(i), val(j)) val(i) = max(val(i), val(j))
duplicate(j) = .True. duplicate(j) = .True.
endif endif
j+=1 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) call configuration_to_dets_size(o(1,1,i),sze,elec_alpha_num,N_int)
n_d = n_d + sze n_d = n_d + sze
if (n_d > b%cur) then if (n_d > b%cur) then
! if (n_d - b%cur > b%cur - n_d + sze) then
! n_d = n_d - sze
! endif
exit exit
endif endif
enddo enddo
@ -340,11 +329,10 @@ subroutine remove_duplicates_in_selection_buffer(b)
integer(bit_kind), allocatable :: tmp_array(:,:,:) integer(bit_kind), allocatable :: tmp_array(:,:,:)
logical, allocatable :: duplicate(:) logical, allocatable :: duplicate(:)
n_d = b%cur
logical :: found_duplicates logical :: found_duplicates
double precision :: rss double precision :: rss
double precision, external :: memory_of_double double precision, external :: memory_of_double
n_d = b%cur
rss = (4*N_int+4)*memory_of_double(n_d) rss = (4*N_int+4)*memory_of_double(n_d)
call check_mem(rss,irp_here) 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 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 do k=1,N_st
element = pt2(k) !exp(dt*(pt2(k)/avg - 1.d0)) element = exp(dt*(pt2(k)/avg - 1.d0))
! element = min(2.0d0 , element) element = min(2.0d0 , element)
! element = max(0.5d0 , element) element = max(0.5d0 , element)
pt2_match_weight(k) *= element pt2_match_weight(k) *= element
enddo 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 avg = sum(variance(1:N_st)) / dble(N_st) + 1.d-32 ! Avoid future division by zero
do k=1,N_st do k=1,N_st
element = variance(k) ! exp(dt*(variance(k)/avg -1.d0)) element = exp(dt*(variance(k)/avg -1.d0))
! element = min(2.0d0 , element) element = min(2.0d0 , element)
! element = max(0.5d0 , element) element = max(0.5d0 , element)
variance_match_weight(k) *= element variance_match_weight(k) *= element
enddo enddo
@ -62,9 +62,6 @@ subroutine update_pt2_and_variance_weights(pt2_data, N_st)
variance_match_weight(:) = 1.d0 variance_match_weight(:) = 1.d0
endif 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, & threshold_davidson_pt2 = min(1.d-6, &
max(threshold_davidson, 1.e-1 * PT2_relative_error * minval(abs(pt2(1:N_states)))) ) 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) selection_weight(1:N_states) = c0_weight(1:N_states)
case (2) 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) selection_weight(1:N_states) = c0_weight(1:N_states) * pt2_match_weight(1:N_states)
print *, '# PT2 weight ', real(pt2_match_weight(:),4) 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) print *, '# var weight ', real(variance_match_weight(:),4)
case (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)) 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 *, '# PT2 weight ', real(pt2_match_weight(:),4)
print *, '# var weight ', real(variance_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) selection_weight(1:N_states) = c0_weight(1:N_states)
case (7) 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) 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 *, '# PT2 weight ', real(pt2_match_weight(:),4)
print *, '# var weight ', real(variance_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) print *, '# var weight ', real(variance_match_weight(:),4)
end select end select
selection_weight(:) = selection_weight(:)/sum(selection_weight(:))
print *, '# Total weight ', real(selection_weight(:),4) print *, '# Total weight ', real(selection_weight(:),4)
END_PROVIDER END_PROVIDER

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

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

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

@ -69,8 +69,8 @@ subroutine run_stochastic_cipsi
do while ( & do while ( &
(N_det < N_det_max) .and. & (N_det < N_det_max) .and. &
(sum(abs(pt2_data % pt2(1:N_states)) * state_average_weight(1:N_states)) > pt2_max) .and. & (maxval(abs(pt2_data % pt2(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 % variance(1:N_states))) > variance_max) .and. &
(correlation_energy_ratio <= correlation_energy_ratio_max) & (correlation_energy_ratio <= correlation_energy_ratio_max) &
) )
write(*,'(A)') '--------------------------------------------------------------------------------' 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_rows_loc psi_bilinear_matrix_transp_columns
PROVIDE psi_bilinear_matrix_transp_order selection_weight pseudo_sym 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 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') 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 else
call H_apply_cis call H_apply_cis
endif endif
print*,''
print *, 'N_det = ', N_det print *, 'N_det = ', N_det
print*,'******************************' print*,'******************************'
print *, 'Energies of the states:' print *, 'Energies of the states:'
@ -70,18 +69,16 @@ subroutine run
print *, i, CI_energy(i) print *, i, CI_energy(i)
enddo enddo
if (N_states > 1) then if (N_states > 1) then
print*,'' print*,'******************************'
print*,'******************************************************' print*,'Excitation energies '
print*,'Excitation energies (au) (eV)'
do i = 2, N_states 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 enddo
print*,''
endif endif
call ezfio_set_cis_energy(CI_energy) call ezfio_set_cis_energy(CI_energy)
psi_coef = ci_eigenvectors psi_coef = ci_eigenvectors
SOFT_TOUCH psi_coef SOFT_TOUCH psi_coef
call save_wavefunction_truncated(save_threshold) call save_wavefunction_truncated(1.d-12)
end 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

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

@ -47,37 +47,6 @@ program cisd
PROVIDE N_states PROVIDE N_states
read_wf = .False. read_wf = .False.
SOFT_TOUCH read_wf 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 call run
end end
@ -87,16 +56,20 @@ subroutine run
double precision :: cisdq(N_states), delta_e double precision :: cisdq(N_states), delta_e
double precision,external :: diag_h_mat_elem 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 psi_coef = ci_eigenvectors
call save_wavefunction_truncated(save_threshold) SOFT_TOUCH psi_coef
call save_wavefunction
call ezfio_set_cisd_energy(CI_energy) call ezfio_set_cisd_energy(CI_energy)
do i = 1,N_states do i = 1,N_states
k = maxloc(dabs(psi_coef_sorted(1:N_det,i)),dim=1) 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) 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) cisdq(i) = CI_energy(i) + delta_E * (1.d0 - psi_coef_sorted(k,i)**2)
endif
enddo enddo
print *, 'N_det = ', N_det print *, 'N_det = ', N_det
print*,'' print*,''
@ -105,16 +78,13 @@ subroutine run
do i = 1,N_states do i = 1,N_states
print *, i, CI_energy(i) print *, i, CI_energy(i)
enddo enddo
if (elec_alpha_num + elec_beta_num >= 4) then
print*,'' print*,''
print*,'******************************' print*,'******************************'
print *, 'CISD+Q Energies' print *, 'CISD+Q Energies'
do i = 1,N_states do i = 1,N_states
print *, i, cisdq(i) print *, i, cisdq(i)
enddo enddo
endif
if (N_states > 1) then if (N_states > 1) then
if (elec_alpha_num + elec_beta_num >= 4) then
print*,'' print*,''
print*,'******************************' print*,'******************************'
print*,'Excitation energies (au) (CISD+Q)' print*,'Excitation energies (au) (CISD+Q)'
@ -125,23 +95,9 @@ subroutine run
print*,'******************************' print*,'******************************'
print*,'Excitation energies (eV) (CISD+Q)' print*,'Excitation energies (eV) (CISD+Q)'
do i = 2, N_states do i = 2, N_states
print*, i ,(CI_energy(i) - CI_energy(1)) * ha_to_ev, & print*, i ,(CI_energy(i) - CI_energy(1))/0.0367502d0, &
(cisdq(i) - cisdq(1)) * ha_to_ev (cisdq(i) - cisdq(1)) / 0.0367502d0
enddo 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 endif
end end

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

@ -779,7 +779,6 @@ subroutine binary_search_cfg(cfgInp,addcfg)
end subroutine end subroutine
BEGIN_PROVIDER [ integer, psi_configuration_to_psi_det, (2,N_configuration) ] 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) ] &BEGIN_PROVIDER [ integer, psi_configuration_to_psi_det_data, (N_det) ]
implicit none implicit none
@ -868,29 +867,6 @@ end subroutine
enddo enddo
deallocate(dets, old_order) 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 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

21
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) subroutine convertWFfromDETtoCSF(N_st,psi_coef_det_in, psi_coef_cfg_out)
use cfunctions use cfunctions
use bitmasks use bitmasks
@ -38,8 +26,6 @@ subroutine convertWFfromDETtoCSF(N_st,psi_coef_det_in, psi_coef_cfg_out)
integer s, bfIcfg integer s, bfIcfg
integer countcsf integer countcsf
integer MS
MS = elec_alpha_num-elec_beta_num
countcsf = 0 countcsf = 0
phasedet = 1.0d0 phasedet = 1.0d0
do i = 1,N_configuration do i = 1,N_configuration
@ -58,17 +44,12 @@ subroutine convertWFfromDETtoCSF(N_st,psi_coef_det_in, psi_coef_cfg_out)
enddo enddo
enddo enddo
s = 0 ! s == total number of SOMOs s = 0
do k=1,N_int do k=1,N_int
if (psi_configuration(k,1,i) == 0_bit_kind) cycle if (psi_configuration(k,1,i) == 0_bit_kind) cycle
s = s + popcnt(psi_configuration(k,1,i)) s = s + popcnt(psi_configuration(k,1,i))
enddo 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)))) bfIcfg = max(1,nint((binom(s,(s+1)/2)-binom(s,((s+1)/2)+1))))
endif
! perhaps blocking with CFGs of same seniority ! perhaps blocking with CFGs of same seniority
! can be more efficient ! can be more efficient

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

@ -1,10 +1,7 @@
real*8 function logabsgamma(x) real*8 function logabsgamma(x)
implicit none implicit none
real*8, intent(in) :: x real*8, intent(in) :: x
logabsgamma = 1.d32 ! Avoid floating point exception
if (x>0.d0) then
logabsgamma = log(abs(gamma(x))) logabsgamma = log(abs(gamma(x)))
endif
end function logabsgamma end function logabsgamma
BEGIN_PROVIDER [ integer, NSOMOMax] BEGIN_PROVIDER [ integer, NSOMOMax]
@ -51,60 +48,42 @@
if(cfg_seniority_index(i+2) > ncfgpersomo) then if(cfg_seniority_index(i+2) > ncfgpersomo) then
ncfgpersomo = cfg_seniority_index(i+2) ncfgpersomo = cfg_seniority_index(i+2)
else else
! l = i+k+2 k = 0
! Loop over l with a constraint to ensure that l <= size(cfg_seniority_index,1)-1 do while(cfg_seniority_index(i+2+k) < ncfgpersomo)
! Old version commented just below k = k + 2
do l = min(size(cfg_seniority_index,1)-1, i+2), size(cfg_seniority_index,1)-1, 2 ncfgpersomo = cfg_seniority_index(i+2+k)
if (cfg_seniority_index(l) >= ncfgpersomo) then
ncfgpersomo = cfg_seniority_index(l)
endif
enddo 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
endif endif
ncfg = ncfgpersomo - ncfgprev ncfg = ncfgpersomo - ncfgprev
if(i .EQ. 0 .OR. i .EQ. 1) then
dimcsfpercfg = 1
elseif( i .EQ. 3) then
dimcsfpercfg = 2
else
if(iand(MS,1) .EQ. 0) then if(iand(MS,1) .EQ. 0) then
dimcsfpercfg = max(1,nint((binom(i,i/2)-binom(i,i/2+1)))) !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 else
dimcsfpercfg = max(1,nint((binom(i,(i+1)/2)-binom(i,(i+3)/2)))) !dimcsfpercfg = max(1,nint((binom(i,(i+1)/2)-binom(i,(i+3)/2))))
endif 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 endif
n_CSF += ncfg * dimcsfpercfg n_CSF += ncfg * dimcsfpercfg
if(cfg_seniority_index(i+2) > ncfgprev) then if(cfg_seniority_index(i+2) > ncfgprev) then
ncfgprev = cfg_seniority_index(i+2) ncfgprev = cfg_seniority_index(i+2)
else else
! l = i+k+2 k = 0
! Loop over l with a constraint to ensure that l <= size(cfg_seniority_index,1)-1 do while(cfg_seniority_index(i+2+k) < ncfgprev)
! Old version commented just below k = k + 2
do l = min(size(cfg_seniority_index,1)-1, i+2), size(cfg_seniority_index,1)-1, 2 ncfgprev = cfg_seniority_index(i+2+k)
if (cfg_seniority_index(l) >= ncfgprev) then
ncfgprev = cfg_seniority_index(l)
endif
enddo 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 endif
enddo enddo
END_PROVIDER 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 use mmap_module
implicit none implicit none
BEGIN_DOC BEGIN_DOC
@ -412,6 +412,36 @@ subroutine davidson_general_ext_rout_diag_dressed(u_in,H_jj,Dress_jj,energies,sz
FREE nthreads_davidson FREE nthreads_davidson
end 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) subroutine dressing_diag_uv(v,u,dress_diag,N_st,sze)
implicit none implicit none
BEGIN_DOC BEGIN_DOC

2
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 if (state_following) then
overlap = -1.d0 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)) overlap(k,i) = dabs(y(k,i))
enddo enddo
enddo enddo

203
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 character*(16384) :: write_buffer
integer :: iter, N_st_diag integer :: iter, N_st_diag
integer :: i, j, k, m integer :: i, j, k, l, m
integer :: iter2, itertot integer :: iter2, itertot
logical :: disk_based logical :: disk_based
integer :: shift, shift2, itermax 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 :: y(:,:), h(:,:), lambda(:)
double precision, allocatable :: residual_norm(:) double precision, allocatable :: residual_norm(:)
integer :: i_omax
double precision :: lambda_tmp double precision :: lambda_tmp
integer, allocatable :: i_omax(:)
double precision, allocatable :: U_tmp(:), overlap(:) double precision, allocatable :: U_tmp(:), overlap(:)
double precision, allocatable :: W(:,:) 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), & h(N_st_diag*itermax,N_st_diag*itermax), &
y(N_st_diag*itermax,N_st_diag*itermax), & y(N_st_diag*itermax,N_st_diag*itermax), &
lambda(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 U = 0.d0
@ -313,13 +314,16 @@ subroutine davidson_general_ext_rout_nonsym_b1space(u_in, H_jj, energies, sze, N
! end test ------------------------------------------------------------------------ ! 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 do k = 1, N_st_diag
overlap(k) = 0.d0 overlap(k) = 0.d0
do i = 1, sze do i = 1, sze
overlap(k) = overlap(k) + U(i,shift2+k) * u_in(i,1) overlap(k) = overlap(k) + U(i,shift2+k) * u_in(i,l)
enddo enddo
overlap(k) = dabs(overlap(k)) overlap(k) = dabs(overlap(k))
!print *, ' overlap =', k, overlap(k) !print *, ' overlap =', k, overlap(k)
@ -328,44 +332,24 @@ subroutine davidson_general_ext_rout_nonsym_b1space(u_in, H_jj, energies, sze, N
lambda_tmp = 0.d0 lambda_tmp = 0.d0
do k = 1, N_st_diag do k = 1, N_st_diag
if(overlap(k) .gt. lambda_tmp) then if(overlap(k) .gt. lambda_tmp) then
i_omax = k i_omax(l) = k
lambda_tmp = overlap(k) lambda_tmp = overlap(k)
endif endif
enddo enddo
deallocate(overlap) deallocate(overlap)
if( lambda_tmp .lt. 0.5d0) then
print *, ' very small overlap..' if(lambda_tmp .lt. 0.7d0) then
print*, ' max overlap = ', lambda_tmp, i_omax print *, ' very small overlap ...', l, i_omax(l)
print *, ' max overlap = ', lambda_tmp
stop stop
endif endif
! lambda_tmp = lambda(1) if(i_omax(l) .ne. l) then
! lambda(1) = lambda(i_omax) print *, ' !!! WARNONG !!!'
! lambda(i_omax) = lambda_tmp print *, ' index of state', l, i_omax(l)
! endif
! allocate( U_tmp(sze) ) enddo
! 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 ! y(:,k) = rk
! W(:,k) = H x Bk ! 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 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) U(i,shift2+k) = (lambda(k) * U(i,shift2+k) - W(i,shift2+k)) / max(H_jj(i)-lambda(k), 1.d-2)
enddo enddo
!if(k <= N_st) then if(k <= N_st) then
! residual_norm(k) = u_dot_u(U(1,shift2+k), sze) l = k
! to_print(1,k) = lambda(k) residual_norm(k) = u_dot_u(U(1,shift2+l), sze)
! to_print(2,k) = residual_norm(k) to_print(1,k) = lambda(l)
!endif to_print(2,k) = residual_norm(l)
endif
enddo enddo
!$OMP END PARALLEL DO !$OMP END PARALLEL DO
residual_norm(1) = u_dot_u(U(1,shift2+i_omax), sze) !residual_norm(1) = u_dot_u(U(1,shift2+1), sze)
to_print(1,1) = lambda(i_omax) !to_print(1,1) = lambda(1)
to_print(2,1) = residual_norm(1) !to_print(2,1) = residual_norm(1)
if( (itertot > 1) .and. (iter == 1) ) then 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) call write_time(6)
deallocate(W) deallocate(W)
deallocate(U, h, y, lambda, residual_norm) deallocate(U, h, y, lambda, residual_norm, i_omax)
FREE nthreads_davidson FREE nthreads_davidson
end subroutine davidson_general_ext_rout_nonsym_b1space 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
! ---

2
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 if (state_following) then
overlap = -1.d0 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)) overlap(k,i) = dabs(y(k,i))
enddo enddo
enddo enddo

54
src/davidson/EZFIO.cfg
View File

@ -1,72 +1,18 @@
[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] [csf_based]
type: logical type: logical
doc: If |true|, use the CSF-based algorithm doc: If |true|, use the CSF-based algorithm
default: False default: False
interface: ezfio,provider,ocaml interface: ezfio,provider,ocaml
[distributed_davidson]
type: logical
doc: If |true|, use the distributed algorithm
default: True
interface: ezfio,provider,ocaml
[only_expected_s2] [only_expected_s2]
type: logical type: logical
doc: If |true|, use filter out all vectors with bad |S^2| values doc: If |true|, use filter out all vectors with bad |S^2| values
default: True default: True
interface: ezfio,provider,ocaml 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] [without_diagonal]
type: logical type: logical
doc: If |true|, don't use denominator doc: If |true|, don't use denominator
default: False default: False
interface: ezfio,provider,ocaml interface: ezfio,provider,ocaml
[threshold_nonsym_davidson]
type: Threshold
doc: Thresholds of non-symetric Davidson's algorithm
interface: ezfio,provider,ocaml
default: 1.e-12

1
src/davidson/NEED
View File

@ -1 +1,2 @@
csf 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 endif
call set_multiple_levels_omp(.True.) call omp_set_max_active_levels(5)
!$OMP PARALLEL DEFAULT(shared) NUM_THREADS(2) PRIVATE(ithread) !$OMP PARALLEL DEFAULT(shared) NUM_THREADS(2) PRIVATE(ithread)
ithread = omp_get_thread_num() ithread = omp_get_thread_num()
@ -546,19 +546,19 @@ end
BEGIN_PROVIDER [ integer, nthreads_davidson ] !BEGIN_PROVIDER [ integer, nthreads_davidson ]
implicit none ! implicit none
BEGIN_DOC ! BEGIN_DOC
! Number of threads for Davidson ! ! Number of threads for Davidson
END_DOC ! END_DOC
nthreads_davidson = nproc ! nthreads_davidson = nproc
character*(32) :: env ! character*(32) :: env
call getenv('QP_NTHREADS_DAVIDSON',env) ! call getenv('QP_NTHREADS_DAVIDSON',env)
if (trim(env) /= '') then ! if (trim(env) /= '') then
read(env,*) nthreads_davidson ! read(env,*) nthreads_davidson
call write_int(6,nthreads_davidson,'Target number of threads for <Psi|H|Psi>') ! call write_int(6,nthreads_davidson,'Target number of threads for <Psi|H|Psi>')
endif ! endif
END_PROVIDER !END_PROVIDER
integer function zmq_put_N_states_diag(zmq_to_qp_run_socket,worker_id) 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' print *, irp_here, ': Failed in zmq_set_running'
endif endif
call set_multiple_levels_omp(.True.) call omp_set_max_active_levels(4)
!$OMP PARALLEL DEFAULT(shared) NUM_THREADS(2) PRIVATE(ithread) !$OMP PARALLEL DEFAULT(shared) NUM_THREADS(2) PRIVATE(ithread)
ithread = omp_get_thread_num() ithread = omp_get_thread_num()
if (ithread == 0 ) then 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' print *, irp_here, ': Failed in zmq_set_running'
endif endif
call set_multiple_levels_omp(.True.) call omp_set_max_active_levels(4)
!$OMP PARALLEL DEFAULT(shared) NUM_THREADS(2) PRIVATE(ithread) !$OMP PARALLEL DEFAULT(shared) NUM_THREADS(2) PRIVATE(ithread)
ithread = omp_get_thread_num() ithread = omp_get_thread_num()
if (ithread == 0 ) then 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 stop -1
endif 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 itertot = 0
if (state_following) then 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. converged = .False.
call convertWFfromDETtoCSF(N_st_diag,u_in(1,1),U_csf(1,1))
do k=N_st+1,N_st_diag do k=N_st+1,N_st_diag
do i=1,sze_csf do i=1,sze
call random_number(r1) call random_number(r1)
call random_number(r2) call random_number(r2)
r1 = dsqrt(-2.d0*dlog(r1)) r1 = dsqrt(-2.d0*dlog(r1))
r2 = dtwo_pi*r2 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 enddo
U_csf(k,k) = u_csf(k,k) + 10.d0 u_in(k,k) = u_in(k,k) + 10.d0
enddo enddo
do k=1,N_st_diag do k=1,N_st_diag
call normalize(U_csf(1,k),sze_csf) call normalize(u_in(1,k),sze)
enddo 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)) call convertWFfromCSFtoDET(N_st_diag,U_csf(1,1),U(1,1))
do while (.not.converged) 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) shift = N_st_diag*(iter-1)
shift2 = N_st_diag*iter 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> ! 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 else
call H_u_0_nstates_openmp(W,U,N_st_diag,sze) call H_u_0_nstates_openmp(W,U,N_st_diag,sze)
endif endif
! else else
! ! Already computed in update below ! Already computed in update below
! continue continue
! endif endif
if (dressing_state > 0) then 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 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, & 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)) U_csf, size(U_csf,1), y, size(y,1), 0.d0, u_in, size(u_in,1))

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

@ -14,14 +14,14 @@ BEGIN_PROVIDER [ character*(64), diag_algorithm ]
endif endif
END_PROVIDER END_PROVIDER
BEGIN_PROVIDER [ double precision, threshold_davidson_pt2 ] !BEGIN_PROVIDER [ double precision, threshold_davidson_pt2 ]
implicit none ! implicit none
BEGIN_DOC ! BEGIN_DOC
! Threshold of Davidson's algorithm, using PT2 as a guide ! ! Threshold of Davidson's algorithm, using PT2 as a guide
END_DOC ! END_DOC
threshold_davidson_pt2 = threshold_davidson ! threshold_davidson_pt2 = threshold_davidson
!
END_PROVIDER !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, allocatable :: H_jj(:)
double precision, external :: diag_H_mat_elem, diag_S_mat_elem double precision, external :: diag_H_mat_elem, diag_S_mat_elem
integer :: i,k integer :: i,k,l
ASSERT (N_st > 0) ASSERT (N_st > 0)
ASSERT (sze > 0) ASSERT (sze > 0)
ASSERT (Nint > 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 !$OMP END PARALLEL
if (dressing_state > 0) then if (dressing_state > 0) then
do k=1,N_st do k = 1, N_st
do i=1,sze
do i = 1, sze
H_jj(i) += u_in(i,k) * dressing_column_h(i,k) H_jj(i) += u_in(i,k) * dressing_column_h(i,k)
enddo enddo
!l = dressed_column_idx(k)
!H_jj(l) += u_in(l,k) * dressing_column_h(l,k)
enddo enddo
endif 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) shift = N_st_diag*(iter-1)
shift2 = N_st_diag*iter 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> ! 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) call H_S2_u_0_nstates_openmp(W(1,shift+1),S_d,U(1,shift+1),N_st_diag,sze)
endif endif
S(1:sze,shift+1:shift+N_st_diag) = real(S_d(1:sze,1:N_st_diag)) S(1:sze,shift+1:shift+N_st_diag) = real(S_d(1:sze,1:N_st_diag))
! else else
! ! Already computed in update below ! Already computed in update below
! continue continue
! endif endif
if (dressing_state > 0) then 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) ] BEGIN_PROVIDER [ double precision, CI_energy, (N_states_diag) ]
implicit none implicit none
BEGIN_DOC BEGIN_DOC
! :c:data:`n_states` lowest eigenvalues of the |CI| matrix ! :c:data:`n_states` lowest eigenvalues of the |CI| matrix
END_DOC END_DOC
PROVIDE distributed_davidson
integer :: j integer :: j
character*(8) :: st character*(8) :: st
@ -298,7 +288,6 @@ subroutine diagonalize_CI
! eigenstates of the |CI| matrix. ! eigenstates of the |CI| matrix.
END_DOC END_DOC
integer :: i,j integer :: i,j
PROVIDE distributed_davidson
do j=1,N_states do j=1,N_states
do i=1,N_det do i=1,N_det
psi_coef(i,j) = CI_eigenvectors(i,j) 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 ] !BEGIN_PROVIDER [ integer, n_states_diag ]
implicit none ! implicit none
BEGIN_DOC ! BEGIN_DOC
! Number of states to consider during the Davdison diagonalization !! Number of states to consider during the Davdison diagonalization
END_DOC ! END_DOC
!
logical :: has ! logical :: has
PROVIDE ezfio_filename ! PROVIDE ezfio_filename
if (mpi_master) then ! if (mpi_master) then
!
call ezfio_has_davidson_n_states_diag(has) ! call ezfio_has_davidson_n_states_diag(has)
if (has) then ! if (has) then
call ezfio_get_davidson_n_states_diag(n_states_diag) ! call ezfio_get_davidson_n_states_diag(n_states_diag)
else ! else
print *, 'davidson/n_states_diag not found in EZFIO file' ! print *, 'davidson/n_states_diag not found in EZFIO file'
stop 1 ! stop 1
endif ! endif
n_states_diag = max(2,N_states * N_states_diag) ! n_states_diag = max(2,N_states * N_states_diag)
endif ! endif
IRP_IF MPI_DEBUG ! IRP_IF MPI_DEBUG
print *, irp_here, mpi_rank ! print *, irp_here, mpi_rank
call MPI_BARRIER(MPI_COMM_WORLD, ierr) ! call MPI_BARRIER(MPI_COMM_WORLD, ierr)
IRP_ENDIF ! IRP_ENDIF
IRP_IF MPI ! IRP_IF MPI
include 'mpif.h' ! include 'mpif.h'
integer :: ierr ! integer :: ierr
call MPI_BCAST( n_states_diag, 1, MPI_INTEGER, 0, MPI_COMM_WORLD, ierr) ! call MPI_BCAST( n_states_diag, 1, MPI_INTEGER, 0, MPI_COMM_WORLD, ierr)
if (ierr /= MPI_SUCCESS) then ! if (ierr /= MPI_SUCCESS) then
stop 'Unable to read n_states_diag with MPI' ! stop 'Unable to read n_states_diag with MPI'
endif ! endif
IRP_ENDIF ! IRP_ENDIF
!
call write_time(6) ! call write_time(6)
if (mpi_master) then ! if (mpi_master) then
write(6, *) 'Read n_states_diag' ! write(6, *) 'Read n_states_diag'
endif ! endif
!
END_PROVIDER !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 :: doubles(:)
integer, allocatable :: singles_a(:) integer, allocatable :: singles_a(:)
integer, allocatable :: singles_b(:) 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 :: maxab, n_singles_a, n_singles_b, kcol_prev
integer*8 :: k8 integer*8 :: k8
logical :: compute_singles logical :: compute_singles
@ -253,7 +253,7 @@ compute_singles=.True.
!$OMP PRIVATE(krow, kcol, tmp_det, spindet, k_a, k_b, i, & !$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 lcol, lrow, l_a, l_b, utl, kk, u_is_sparse, &
!$OMP buffer, doubles, n_doubles, umax, & !$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 singles_a, n_singles_a, singles_b, ratio, &
!$OMP n_singles_b, k8, last_found,left,right,right_max) !$OMP n_singles_b, k8, last_found,left,right,right_max)
@ -264,7 +264,7 @@ compute_singles=.True.
singles_a(maxab), & singles_a(maxab), &
singles_b(maxab), & singles_b(maxab), &
doubles(maxab), & doubles(maxab), &
idx(maxab), buffer_lrow(maxab), utl(N_st,block_size)) idx(maxab), utl(N_st,block_size))
kcol_prev=-1 kcol_prev=-1
@ -332,20 +332,18 @@ compute_singles=.True.
l_a = psi_bilinear_matrix_columns_loc(lcol) l_a = psi_bilinear_matrix_columns_loc(lcol)
ASSERT (l_a <= N_det) 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) do j=1,psi_bilinear_matrix_columns_loc(lcol+1) - psi_bilinear_matrix_columns_loc(lcol)
lrow = psi_bilinear_matrix_rows(l_a) lrow = psi_bilinear_matrix_rows(l_a)
ASSERT (lrow <= N_det_alpha_unique) 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) ASSERT (l_a <= N_det)
idx(j) = l_a idx(j) = l_a
l_a = l_a+1 l_a = l_a+1
enddo 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 j = j-1
call get_all_spin_singles_$N_int( & call get_all_spin_singles_$N_int( &
@ -791,7 +789,7 @@ compute_singles=.True.
end do end do
!$OMP 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 !$OMP END PARALLEL
end end

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

@ -12,7 +12,7 @@ BEGIN_PROVIDER [ double precision, CI_energy_dressed, (N_states_diag) ]
enddo enddo
do j=1,min(N_det,N_states) do j=1,min(N_det,N_states)
write(st,'(I4)') j 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)) call write_double(6,CI_eigenvectors_s2_dressed(j),'S^2 of state '//trim(st))
enddo enddo
@ -38,8 +38,6 @@ END_PROVIDER
double precision, allocatable :: s2_eigvalues(:) double precision, allocatable :: s2_eigvalues(:)
double precision, allocatable :: e_array(:) double precision, allocatable :: e_array(:)
integer, allocatable :: iorder(:) integer, allocatable :: iorder(:)
logical :: converged
logical :: do_csf
PROVIDE threshold_davidson nthreads_davidson PROVIDE threshold_davidson nthreads_davidson
! Guess values for the "N_states" states of the CI_eigenvectors_dressed ! Guess values for the "N_states" states of the CI_eigenvectors_dressed
@ -55,8 +53,6 @@ END_PROVIDER
enddo enddo
enddo enddo
do_csf = s2_eig .and. only_expected_s2 .and. csf_based
if (diag_algorithm == "Davidson") then if (diag_algorithm == "Davidson") then
do j=1,min(N_states,N_det) do j=1,min(N_states,N_det)
@ -64,78 +60,14 @@ END_PROVIDER
CI_eigenvectors_dressed(i,j) = psi_coef(i,j) CI_eigenvectors_dressed(i,j) = psi_coef(i,j)
enddo enddo
enddo enddo
logical :: converged
converged = .False. 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)
else
call davidson_diag_HS2(psi_det,CI_eigenvectors_dressed, CI_eigenvectors_s2_dressed,& call davidson_diag_HS2(psi_det,CI_eigenvectors_dressed, CI_eigenvectors_s2_dressed,&
size(CI_eigenvectors_dressed,1), CI_electronic_energy_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) N_det,min(N_det,N_states),min(N_det,N_states_diag),N_int,1,converged)
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 else if (diag_algorithm == "Lapack") then
print *, 'Diagonalization of H using Lapack'
allocate (eigenvectors(size(H_matrix_dressed,1),N_det)) allocate (eigenvectors(size(H_matrix_dressed,1),N_det))
allocate (eigenvalues(N_det)) allocate (eigenvalues(N_det))

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_h, (N_det,N_states) ]
&BEGIN_PROVIDER [ double precision, dressing_column_s, (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 implicit none
BEGIN_DOC BEGIN_DOC
! Null dressing vectors ! Null dressing vectors
END_DOC END_DOC
dressing_column_h(:,:) = 0.d0 dressing_column_h(:,:) = 0.d0
dressing_column_s(:,:) = 0.d0 dressing_column_s(:,:) = 0.d0
dressing_delta (:,:) = 0.d0
END_PROVIDER END_PROVIDER

7
src/determinants/EZFIO.cfg
View File

@ -42,7 +42,7 @@ default: 2
[weight_selection] [weight_selection]
type: integer 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 interface: ezfio,provider,ocaml
default: 1 default: 1
@ -136,8 +136,3 @@ doc: If |true|, discard any Slater determinants with an interaction smaller than
interface: ezfio,provider,ocaml interface: ezfio,provider,ocaml
default: False 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) iorb = list_virt(i)
do j = 1, n_core_inact_act_orb do j = 1, n_core_inact_act_orb
jorb = list_core_inact_act(j) 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
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) 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 soft_touch mo_occ
end 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 subroutine save_natural_mos
implicit none implicit none
BEGIN_DOC BEGIN_DOC
@ -368,12 +299,12 @@ BEGIN_PROVIDER [ double precision, c0_weight, (N_states) ]
c = maxval(psi_coef(:,i) * psi_coef(:,i)) c = maxval(psi_coef(:,i) * psi_coef(:,i))
c0_weight(i) = 1.d0/(c+1.d-20) c0_weight(i) = 1.d0/(c+1.d-20)
enddo enddo
c = 1.d0/sum(c0_weight(:)) c = 1.d0/minval(c0_weight(:))
do i=1,N_states do i=1,N_states
c0_weight(i) = c0_weight(i) * c c0_weight(i) = c0_weight(i) * c
enddo enddo
else else
c0_weight(:) = 1.d0 c0_weight = 1.d0
endif endif
END_PROVIDER END_PROVIDER
@ -390,7 +321,7 @@ BEGIN_PROVIDER [ double precision, state_average_weight, (N_states) ]
if (weight_one_e_dm == 0) then if (weight_one_e_dm == 0) then
state_average_weight(:) = c0_weight(:) state_average_weight(:) = c0_weight(:)
else if (weight_one_e_dm == 1) then else if (weight_one_e_dm == 1) then
state_average_weight(:) = 1.d0/N_states state_average_weight(:) = 1./N_states
else else
call ezfio_has_determinants_state_average_weight(exists) call ezfio_has_determinants_state_average_weight(exists)
if (exists) then if (exists) then
@ -453,14 +384,6 @@ END_PROVIDER
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) subroutine get_occupation_from_dets(istate,occupation)
implicit none implicit none

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

@ -77,15 +77,12 @@ BEGIN_PROVIDER [ integer, psi_det_size ]
END_DOC END_DOC
PROVIDE ezfio_filename PROVIDE ezfio_filename
logical :: exists logical :: exists
psi_det_size = N_states
PROVIDE mpi_master
if (read_wf) then
if (mpi_master) then if (mpi_master) then
call ezfio_has_determinants_n_det(exists) call ezfio_has_determinants_n_det(exists)
if (exists) then if (exists) then
call ezfio_get_determinants_n_det(psi_det_size) call ezfio_get_determinants_n_det(psi_det_size)
else else
psi_det_size = N_states psi_det_size = 1
endif endif
call write_int(6,psi_det_size,'Dimension of the psi arrays') call write_int(6,psi_det_size,'Dimension of the psi arrays')
endif endif
@ -101,7 +98,7 @@ BEGIN_PROVIDER [ integer, psi_det_size ]
stop 'Unable to read psi_det_size with MPI' stop 'Unable to read psi_det_size with MPI'
endif endif
IRP_ENDIF IRP_ENDIF
endif
END_PROVIDER END_PROVIDER
@ -174,22 +171,24 @@ BEGIN_PROVIDER [ integer(bit_kind), psi_det, (N_int,2,psi_det_size) ]
END_PROVIDER END_PROVIDER
! ---
BEGIN_PROVIDER [ double precision, psi_coef, (psi_det_size,N_states) ] BEGIN_PROVIDER [ double precision, psi_coef, (psi_det_size,N_states) ]
implicit none
BEGIN_DOC BEGIN_DOC
! The wave function coefficients. Initialized with Hartree-Fock if the |EZFIO| file ! The wave function coefficients. Initialized with Hartree-Fock if the |EZFIO| file
! is empty. ! is empty.
END_DOC END_DOC
implicit none
integer :: i,k, N_int2 integer :: i,k, N_int2
logical :: exists logical :: exists
character*(64) :: label character*(64) :: label
PROVIDE read_wf N_det mo_label ezfio_filename PROVIDE read_wf N_det mo_label ezfio_filename
psi_coef = 0.d0 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 psi_coef(i,i) = 1.d0
enddo enddo
@ -233,10 +232,10 @@ BEGIN_PROVIDER [ double precision, psi_coef, (psi_det_size,N_states) ]
endif endif
IRP_ENDIF IRP_ENDIF
END_PROVIDER END_PROVIDER
! ---
BEGIN_PROVIDER [ double precision, psi_average_norm_contrib, (psi_det_size) ] BEGIN_PROVIDER [ double precision, psi_average_norm_contrib, (psi_det_size) ]
implicit none implicit none
BEGIN_DOC BEGIN_DOC
@ -543,7 +542,7 @@ subroutine save_wavefunction_general(ndet,nstates,psidet,dim_psicoef,psicoef)
integer :: i,j,k, ndet_qp_edit integer :: i,j,k, ndet_qp_edit
if (mpi_master) then 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_N_int(N_int)
call ezfio_set_determinants_bit_kind(bit_kind) call ezfio_set_determinants_bit_kind(bit_kind)
@ -653,9 +652,6 @@ subroutine save_wavefunction_general_unormalized(ndet,nstates,psidet,dim_psicoef
end end
subroutine save_wavefunction_specified(ndet,nstates,psidet,psicoef,ndetsave,index_det_save) subroutine save_wavefunction_specified(ndet,nstates,psidet,psicoef,ndetsave,index_det_save)
implicit none implicit none
BEGIN_DOC BEGIN_DOC

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

@ -9,7 +9,7 @@
double precision :: weight, r(3) double precision :: weight, r(3)
double precision :: cpu0,cpu1,nuclei_part_z,nuclei_part_y,nuclei_part_x 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 z_dipole_moment = 0.d0
y_dipole_moment = 0.d0 y_dipole_moment = 0.d0
x_dipole_moment = 0.d0 x_dipole_moment = 0.d0
@ -26,10 +26,10 @@
enddo enddo
enddo enddo
! print*,'electron part for z_dipole = ',z_dipole_moment print*,'electron part for z_dipole = ',z_dipole_moment
! print*,'electron part for y_dipole = ',y_dipole_moment print*,'electron part for y_dipole = ',y_dipole_moment
! print*,'electron part for x_dipole = ',x_dipole_moment print*,'electron part for x_dipole = ',x_dipole_moment
!
nuclei_part_z = 0.d0 nuclei_part_z = 0.d0
nuclei_part_y = 0.d0 nuclei_part_y = 0.d0
nuclei_part_x = 0.d0 nuclei_part_x = 0.d0
@ -38,43 +38,28 @@
nuclei_part_y += nucl_charge(i) * nucl_coord(i,2) nuclei_part_y += nucl_charge(i) * nucl_coord(i,2)
nuclei_part_x += nucl_charge(i) * nucl_coord(i,1) nuclei_part_x += nucl_charge(i) * nucl_coord(i,1)
enddo enddo
! print*,'nuclei part for z_dipole = ',nuclei_part_z print*,'nuclei part for z_dipole = ',nuclei_part_z
! print*,'nuclei part for y_dipole = ',nuclei_part_y print*,'nuclei part for y_dipole = ',nuclei_part_y
! print*,'nuclei part for x_dipole = ',nuclei_part_x print*,'nuclei part for x_dipole = ',nuclei_part_x
!
do istate = 1, N_states do istate = 1, N_states
z_dipole_moment(istate) += nuclei_part_z z_dipole_moment(istate) += nuclei_part_z
y_dipole_moment(istate) += nuclei_part_y y_dipole_moment(istate) += nuclei_part_y
x_dipole_moment(istate) += nuclei_part_x x_dipole_moment(istate) += nuclei_part_x
enddo enddo
! call cpu_time(cpu1) call cpu_time(cpu1)
! print*,'Time to provide the dipole moment :',cpu1-cpu0 print*,'Time to provide the dipole moment :',cpu1-cpu0
END_PROVIDER END_PROVIDER
subroutine print_dipole_moments subroutine print_z_dipole_moment_only
implicit none implicit none
integer :: i
print*, '' print*, ''
print*, '' print*, ''
print*, '****************************************' print*, '****************************************'
write(*,'(A10)',advance='no') ' State : ' print*, 'z_dipole_moment = ',z_dipole_moment
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*, '****************************************' print*, '****************************************'
end 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) ASSERT (sum(popcnt(H_apply_buffer(iproc)%det(:,2,i))) == elec_beta_num)
enddo enddo
do i=1,n_selected 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(:,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) ASSERT (sum(popcnt(H_apply_buffer(iproc)%det(:,2,i+H_apply_buffer(iproc)%N_det))) == elec_beta_num)
enddo enddo

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

@ -103,17 +103,13 @@ BEGIN_PROVIDER [ double precision, expected_s2]
END_PROVIDER END_PROVIDER
BEGIN_PROVIDER [ double precision, s2_values, (N_states) ] BEGIN_PROVIDER [ double precision, s2_values, (N_states) ]
&BEGIN_PROVIDER [ double precision, s_values, (N_states) ]
implicit none implicit none
BEGIN_DOC BEGIN_DOC
! array of the averaged values of the S^2 operator on the various states ! array of the averaged values of the S^2 operator on the various states
END_DOC END_DOC
integer :: i integer :: i
call u_0_S2_u_0(s2_values,psi_coef,n_det,psi_det,N_int,N_states,psi_det_size) 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 END_PROVIDER

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

@ -438,7 +438,7 @@ subroutine bitstring_to_list_ab( string, list, n_elements, Nint)
use bitmasks use bitmasks
implicit none implicit none
BEGIN_DOC 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. ! For alpha/beta determinants.
END_DOC END_DOC
integer, intent(in) :: Nint integer, intent(in) :: Nint
@ -472,35 +472,6 @@ subroutine bitstring_to_list_ab( string, list, n_elements, Nint)
end 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) subroutine i_H_j_s2(key_i,key_j,Nint,hij,s2)
use bitmasks use bitmasks
@ -624,7 +595,6 @@ subroutine i_H_j(key_i,key_j,Nint,hij)
double precision :: diag_H_mat_elem, phase double precision :: diag_H_mat_elem, phase
integer :: n_occ_ab(2) integer :: n_occ_ab(2)
PROVIDE mo_two_e_integrals_in_map mo_integrals_map big_array_exchange_integrals PROVIDE mo_two_e_integrals_in_map mo_integrals_map big_array_exchange_integrals
PROVIDE ao_one_e_integrals mo_one_e_integrals
ASSERT (Nint > 0) ASSERT (Nint > 0)
ASSERT (Nint == N_int) ASSERT (Nint == N_int)
@ -682,6 +652,7 @@ subroutine i_H_j(key_i,key_j,Nint,hij)
case (1) case (1)
call get_single_excitation(key_i,key_j,exc,phase,Nint) call get_single_excitation(key_i,key_j,exc,phase,Nint)
!DIR$ FORCEINLINE !DIR$ FORCEINLINE
call bitstring_to_list_ab(key_i, occ, n_occ_ab, Nint)
if (exc(0,1,1) == 1) then if (exc(0,1,1) == 1) then
! Single alpha ! Single alpha
m = exc(1,1,1) m = exc(1,1,1)
@ -700,6 +671,10 @@ subroutine i_H_j(key_i,key_j,Nint,hij)
end select end select
end end
subroutine i_H_j_verbose(key_i,key_j,Nint,hij,hmono,hdouble,phase) subroutine i_H_j_verbose(key_i,key_j,Nint,hij,hmono,hdouble,phase)
use bitmasks use bitmasks
implicit none implicit none
@ -1034,6 +1009,7 @@ subroutine i_H_psi(key,keys,coef,Nint,Ndet,Ndet_max,Nstate,i_H_psi_array)
end end
subroutine i_H_psi_minilist(key,keys,idx_key,N_minilist,coef,Nint,Ndet,Ndet_max,Nstate,i_H_psi_array) subroutine i_H_psi_minilist(key,keys,idx_key,N_minilist,coef,Nint,Ndet,Ndet_max,Nstate,i_H_psi_array)
use bitmasks use bitmasks
implicit none 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 double precision :: get_two_e_integral
integer :: m,n,p,q integer :: m,n,p,q
integer :: i,j,k integer :: i,j,k
integer :: occ(Nint*bit_kind_size,2)
double precision :: diag_H_mat_elem, phase,phase_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 PROVIDE mo_two_e_integrals_in_map mo_integrals_map big_array_exchange_integrals ref_bitmask_two_e_energy
ASSERT (Nint > 0) ASSERT (Nint > 0)
@ -340,6 +342,7 @@ subroutine i_H_j_two_e(key_i,key_j,Nint,hij)
case (1) case (1)
call get_single_excitation(key_i,key_j,exc,phase,Nint) call get_single_excitation(key_i,key_j,exc,phase,Nint)
!DIR$ FORCEINLINE !DIR$ FORCEINLINE
call bitstring_to_list_ab(key_i, occ, n_occ_ab, Nint)
if (exc(0,1,1) == 1) then if (exc(0,1,1) == 1) then
! Mono alpha ! Mono alpha
m = exc(1,1,1) m = exc(1,1,1)

3
src/determinants/spindeterminants.ezfio_config
View File

@ -10,7 +10,10 @@ spindeterminants
psi_coef_matrix_rows integer (spindeterminants_n_det) psi_coef_matrix_rows integer (spindeterminants_n_det)
psi_coef_matrix_columns 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_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_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_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) 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 enddo
!$OMP ENDDO !$OMP ENDDO
!$OMP END PARALLEL !$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_rows,psi_bilinear_matrix_transp_order,N_det)
call iset_order(psi_bilinear_matrix_transp_columns,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) !$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 END_DOC
integer :: i,j,k integer :: i,j,k
double precision :: hij 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) call i_H_j(psi_det(1,1,1),psi_det(1,1,1),N_int,hij)
print*,'Providing the H_matrix_all_dets ...' 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) !$OMP SHARED (N_det, psi_det, N_int,H_matrix_all_dets)
do i =1,N_det do i =1,N_det
do j = i, N_det do j = i, N_det
@ -30,15 +29,16 @@ BEGIN_PROVIDER [ double precision, H_matrix_diag_all_dets,(N_det) ]
END_DOC END_DOC
integer :: i integer :: i
double precision :: hij double precision :: hij
integer :: degree(N_det)
call i_H_j(psi_det(1,1,1),psi_det(1,1,1),N_int,hij) 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) !$OMP SHARED (N_det, psi_det, N_int,H_matrix_diag_all_dets)
do i =1,N_det do i =1,N_det
call i_H_j(psi_det(1,1,i),psi_det(1,1,i),N_int,hij) call i_H_j(psi_det(1,1,i),psi_det(1,1,i),N_int,hij)
H_matrix_diag_all_dets(i) = hij H_matrix_diag_all_dets(i) = hij
enddo enddo
!$OMP END PARALLEL DO !$OMP END PARALLEL DO
END_PROVIDER END_PROVIDER
@ -50,9 +50,8 @@ BEGIN_PROVIDER [ double precision, S2_matrix_all_dets,(N_det,N_det) ]
END_DOC END_DOC
integer :: i,j,k integer :: i,j,k
double precision :: sij 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) 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) !$OMP SHARED (N_det, psi_det, N_int,S2_matrix_all_dets)
do i =1,N_det do i =1,N_det
do j = i, N_det do j = i, N_det
@ -63,4 +62,3 @@ BEGIN_PROVIDER [ double precision, S2_matrix_all_dets,(N_det,N_det) ]
enddo enddo
!$OMP END PARALLEL DO !$OMP END PARALLEL DO
END_PROVIDER END_PROVIDER

1
src/dft_one_e/NEED
View File

@ -6,4 +6,3 @@ ao_one_e_ints
ao_two_e_ints ao_two_e_ints
mo_two_e_erf_ints mo_two_e_erf_ints
ao_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 mu_erf_dft = mu_erf
END_PROVIDER 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 rs = (3d0 / (4d0*pi*rho))**(1d0/3d0) ! JT: serious bug fixed 20/03/19
x = -d2*rs x = -d2*rs
if(dabs(x).lt.50.d0)then 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- 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)
else else
g0_UEG_mu_inf= 0.d0 g0_UEG_mu_inf= 0.d0
endif endif
else else
g0_UEG_mu_inf= 0.d0 g0_UEG_mu_inf= 0.d0
endif endif
g0_UEG_mu_inf = max(g0_UEG_mu_inf,1.d-14)
end end

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

@ -91,19 +91,7 @@
enddo enddo
END_PROVIDER END_PROVIDER
BEGIN_PROVIDER [double precision, aos_lapl_in_r_array_transp, (ao_num, n_points_final_grid,3)] BEGIN_PROVIDER[double precision, aos_lapl_in_r_array, (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)]
implicit none implicit none
BEGIN_DOC 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 ! 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 END_DOC
integer :: i,j,m integer :: i,j,m
double precision :: aos_array(ao_num), r(3) double precision :: aos_array(ao_num), r(3)
double precision :: aos_grad_array(3,ao_num) double precision :: aos_grad_array(ao_num,3)
double precision :: aos_lapl_array(3,ao_num) double precision :: aos_lapl_array(ao_num,3)
!$OMP PARALLEL DO & !$OMP PARALLEL DO &
!$OMP DEFAULT (NONE) & !$OMP DEFAULT (NONE) &
!$OMP PRIVATE (i,r,aos_array,aos_grad_array,aos_lapl_array,j,m) & !$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) !$OMP SHARED(aos_lapl_in_r_array,n_points_final_grid,ao_num,final_grid_points)
do m = 1, 3
do i = 1, n_points_final_grid do i = 1, n_points_final_grid
r(1) = final_grid_points(1,i) r(1) = final_grid_points(1,i)
r(2) = final_grid_points(2,i) r(2) = final_grid_points(2,i)
r(3) = final_grid_points(3,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) 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 j = 1, ao_num
do m = 1, 3 aos_lapl_in_r_array(j,i,m) = aos_lapl_array(j,m)
aos_lapl_in_r_array(m,j,i) = aos_lapl_array(m,j)
enddo enddo
enddo 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 integer :: m
mos_lapl_in_r_array = 0.d0 mos_lapl_in_r_array = 0.d0
do m=1,3 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 enddo
END_PROVIDER 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 use bitmasks
implicit none implicit none
BEGIN_DOC 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 END_DOC
integer, intent(in) :: Nint integer, intent(in) :: Nint
integer(bit_kind), intent(in) :: string(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 provide psi_energy
ending = dress_N_cp+1 ending = dress_N_cp+1
ntask_tbd = 0 ntask_tbd = 0
call set_multiple_levels_omp(.True.) call omp_set_max_active_levels(8)
!$OMP PARALLEL DEFAULT(SHARED) & !$OMP PARALLEL DEFAULT(SHARED) &
!$OMP PRIVATE(interesting, breve_delta_m, task_id) & !$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) zmq_socket_push = new_zmq_push_socket(thread)
integer, external :: connect_to_taskserver integer, external :: connect_to_taskserver
!$OMP CRITICAL !$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 if (connect_to_taskserver(zmq_to_qp_run_socket,worker_id,thread) == -1) then
print *, irp_here, ': Unable to connect to task server' print *, irp_here, ': Unable to connect to task server'
stop -1 stop -1
@ -296,7 +296,7 @@ subroutine run_dress_slave(thread,iproce,energy)
!$OMP END CRITICAL !$OMP END CRITICAL
!$OMP END PARALLEL !$OMP END PARALLEL
call set_multiple_levels_omp(.False.) call omp_set_max_active_levels(1)
! do i=0,dress_N_cp+1 ! do i=0,dress_N_cp+1
! call omp_destroy_lock(lck_sto(i)) ! call omp_destroy_lock(lck_sto(i))
! end do ! end do

2
src/ezfio_files/output.irp.f
View File

@ -25,7 +25,7 @@ subroutine write_time(iunit)
ct = ct - output_cpu_time_0 ct = ct - output_cpu_time_0
call wall_time(wt) call wall_time(wt)
wt = wt - output_wall_time_0 wt = wt - output_wall_time_0
write(6,'(A,F14.2,A,F14.2,A)') & write(6,'(A,F14.6,A,F14.6,A)') &
'.. >>>>> [ WALL TIME: ', wt, ' s ] [ CPU TIME: ', ct, ' s ] <<<<< ..' '.. >>>>> [ WALL TIME: ', wt, ' s ] [ CPU TIME: ', ct, ' s ] <<<<< ..'
write(6,*) write(6,*)
end end

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