diff --git a/external/Python/docopt.py b/external/Python/docopt.py new file mode 100644 index 00000000..7b927e2f --- /dev/null +++ b/external/Python/docopt.py @@ -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, , 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 "", and values are the + parsed values of those elements. + + Example + ------- + >>> from docopt import docopt + >>> doc = ''' + Usage: + my_program tcp [--timeout=] + my_program serial [--baud=] [--timeout=] + my_program (-h | --help | --version) + + Options: + -h, --help Show this screen and exit. + --baud= Baudrate [default: 9600] + ''' + >>> argv = ['tcp', '127.0.0.1', '80', '--timeout', '30'] + >>> docopt(doc, argv) + {'--baud': '9600', + '--help': False, + '--timeout': '30', + '--version': False, + '': '127.0.0.1', + '': '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() diff --git a/include/f77_zmq.h b/include/f77_zmq.h new file mode 100644 index 00000000..b19bb707 --- /dev/null +++ b/include/f77_zmq.h @@ -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 diff --git a/ocaml/Command_line.ml b/ocaml/Command_line.ml index 602315c6..1dd57892 100644 --- a/ocaml/Command_line.ml +++ b/ocaml/Command_line.ml @@ -1,5 +1,3 @@ -exception Error of string - type short_opt = char type long_opt = string type optional = Mandatory | Optional @@ -183,16 +181,15 @@ let set_specs specs_in = Getopt.parse_cmdline cmd_specs (fun x -> anon_args := !anon_args @ [x]); if show_help () then - help () - else - (* Check that all mandatory arguments are set *) - List.filter (fun x -> x.short <> ' ' && x.opt = Mandatory) !specs - |> List.iter (fun x -> - match get x.long with - | Some _ -> () - | None -> raise (Error ("--"^x.long^" option is missing.")) - ) + (help () ; exit 0); + (* Check that all mandatory arguments are set *) + List.filter (fun x -> x.short <> ' ' && x.opt = Mandatory) !specs + |> List.iter (fun x -> + match get x.long with + | Some _ -> () + | None -> failwith ("Error: --"^x.long^" option is missing.") + ) ;; diff --git a/ocaml/Command_line.mli b/ocaml/Command_line.mli index 5ad4ee08..9f6e7022 100644 --- a/ocaml/Command_line.mli +++ b/ocaml/Command_line.mli @@ -59,8 +59,6 @@ let () = *) -exception Error of string - type short_opt = char type long_opt = string diff --git a/ocaml/Input_ao_two_e_eff_pot.ml b/ocaml/Input_ao_two_e_eff_pot.ml new file mode 100644 index 00000000..e4e2c059 --- /dev/null +++ b/ocaml/Input_ao_two_e_eff_pot.ml @@ -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 \ No newline at end of file diff --git a/ocaml/Input_bi_ortho_mos.ml b/ocaml/Input_bi_ortho_mos.ml new file mode 100644 index 00000000..5523a589 --- /dev/null +++ b/ocaml/Input_bi_ortho_mos.ml @@ -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 \ No newline at end of file diff --git a/ocaml/Input_cassd.ml b/ocaml/Input_cassd.ml new file mode 100644 index 00000000..03416f42 --- /dev/null +++ b/ocaml/Input_cassd.ml @@ -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 \ No newline at end of file diff --git a/ocaml/Input_cipsi_deb.ml b/ocaml/Input_cipsi_deb.ml new file mode 100644 index 00000000..9849b0e2 --- /dev/null +++ b/ocaml/Input_cipsi_deb.ml @@ -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 \ No newline at end of file diff --git a/ocaml/Input_tc_h_clean.ml b/ocaml/Input_tc_h_clean.ml new file mode 100644 index 00000000..2fd145fa --- /dev/null +++ b/ocaml/Input_tc_h_clean.ml @@ -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 \ No newline at end of file diff --git a/ocaml/Input_tc_scf.ml b/ocaml/Input_tc_scf.ml new file mode 100644 index 00000000..2a709716 --- /dev/null +++ b/ocaml/Input_tc_scf.ml @@ -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 \ No newline at end of file diff --git a/ocaml/Molecule.ml b/ocaml/Molecule.ml index 603244c8..9b01ac3a 100644 --- a/ocaml/Molecule.ml +++ b/ocaml/Molecule.ml @@ -101,7 +101,7 @@ let to_string_general ~f m = |> String.concat "\n" let to_string = - to_string_general ~f:(fun x -> Atom.to_string ~units:Units.Angstrom x) + to_string_general ~f:(fun x -> Atom.to_string Units.Angstrom x) let to_xyz = to_string_general ~f:Atom.to_xyz @@ -113,7 +113,7 @@ let of_xyz_string s = let l = String_ext.split s ~on:'\n' |> List.filter (fun x -> x <> "") - |> list_map (fun x -> Atom.of_string ~units x) + |> list_map (fun x -> Atom.of_string units x) in let ne = ( get_charge { nuclei=l ; diff --git a/ocaml/Qputils.ml b/ocaml/Qputils.ml index 752a65a0..270e069f 100644 --- a/ocaml/Qputils.ml +++ b/ocaml/Qputils.ml @@ -56,7 +56,3 @@ let string_of_string s = s let list_map f l = List.rev_map f l |> List.rev - -let socket_convert socket = - ((Obj.magic (Obj.repr socket)) : [ `Xsub ] Zmq.Socket.t ) - diff --git a/ocaml/qp_create_ezfio.ml b/ocaml/qp_create_ezfio.ml index 4583b118..a4865e2b 100644 --- a/ocaml/qp_create_ezfio.ml +++ b/ocaml/qp_create_ezfio.ml @@ -91,7 +91,7 @@ let run ?o b au c d m p cart xyz_file = | Element e -> Element.to_string e | Int_elem (i,e) -> Printf.sprintf "%d,%s" (Nucl_number.to_int i) (Element.to_string e) in - Hashtbl.find basis_table key + Hashtbl.find basis_table key in let temp_filename = @@ -132,7 +132,7 @@ let run ?o b au c d m p cart xyz_file = Element.to_string elem.Atom.element in Hashtbl.add basis_table key new_channel - ) nuclei + ) nuclei end | Some (key, basis) -> (*Aux basis *) begin @@ -277,16 +277,6 @@ let run ?o b au c d m p cart xyz_file = ) nuclei in - let z_core = - List.map (fun x -> - Positive_int.to_int x.Pseudo.n_elec - |> float_of_int - ) pseudo - in - let nucl_num = (List.length z_core) in - Ezfio.set_pseudo_nucl_charge_remove (Ezfio.ezfio_array_of_list - ~rank:1 ~dim:[| nucl_num |] ~data:z_core); - let molecule = let n_elec_to_remove = List.fold_left (fun accu x -> @@ -303,13 +293,13 @@ let run ?o b au c d m p cart xyz_file = Molecule.nuclei = let charges = list_map (fun x -> Positive_int.to_int x.Pseudo.n_elec - |> Float.of_int) pseudo + |> Float.of_int) pseudo |> Array.of_list in List.mapi (fun i x -> { x with Atom.charge = (Charge.to_float x.Atom.charge) -. charges.(i) |> Charge.of_float } - ) molecule.Molecule.nuclei + ) molecule.Molecule.nuclei } in let nuclei = @@ -366,11 +356,11 @@ let run ?o b au c d m p cart xyz_file = in if (x > accu) then x else accu - ) 0 x.Pseudo.non_local + ) 0 x.Pseudo.non_local in if (x > accu) then x else accu - ) 0 pseudo + ) 0 pseudo in let kmax = @@ -378,10 +368,10 @@ let run ?o b au c d m p cart xyz_file = list_map (fun x -> List.filter (fun (y,_) -> (Positive_int.to_int y.Pseudo.GaussianPrimitive_non_local.proj) = i) - x.Pseudo.non_local - |> List.length ) pseudo + x.Pseudo.non_local + |> List.length ) pseudo |> List.fold_left (fun accu x -> - if accu > x then accu else x) 0 + if accu > x then accu else x) 0 ) |> Array.fold_left (fun accu i -> if i > accu then i else accu) 0 @@ -406,11 +396,11 @@ let run ?o b au c d m p cart xyz_file = in tmp_array_dz_k.(i).(j) <- y; tmp_array_n_k.(i).(j) <- z; - ) x.Pseudo.local + ) x.Pseudo.local ) pseudo ; let concat_2d tmp_array = let data = - Array.map Array.to_list tmp_array + Array.map Array.to_list tmp_array |> Array.to_list |> List.concat in @@ -448,14 +438,14 @@ let run ?o b au c d m p cart xyz_file = tmp_array_dz_kl.(k).(i).(j) <- y; tmp_array_n_kl.(k).(i).(j) <- z; last_idx.(k) <- i+1; - ) x.Pseudo.non_local + ) x.Pseudo.non_local ) pseudo ; let concat_3d tmp_array = let data = Array.map (fun x -> Array.map Array.to_list x |> Array.to_list - |> List.concat) tmp_array + |> List.concat) tmp_array |> Array.to_list |> List.concat in @@ -523,8 +513,8 @@ let run ?o b au c d m p cart xyz_file = Ezfio.set_ao_basis_ao_num ao_num; Ezfio.set_ao_basis_ao_basis b; Ezfio.set_basis_basis b; - let ao_prim_num = list_map (fun (_,g,_) -> List.length g.Gto.lc) long_basis - and ao_nucl = list_map (fun (_,_,n) -> Nucl_number.to_int n) long_basis + let ao_prim_num = list_map (fun (_,g,_) -> List.length g.Gto.lc) long_basis + and ao_nucl = list_map (fun (_,_,n) -> Nucl_number.to_int n) long_basis and ao_power= let l = list_map (fun (x,_,_) -> x) long_basis in (list_map (fun t -> Positive_int.to_int Angmom.Xyz.(t.x)) l)@ @@ -536,7 +526,7 @@ let run ?o b au c d m p cart xyz_file = else s) 0 ao_prim_num in let gtos = - list_map (fun (_,x,_) -> x) long_basis + list_map (fun (_,x,_) -> x) long_basis in let create_expo_coef ec = @@ -544,10 +534,10 @@ let run ?o b au c d m p cart xyz_file = begin match ec with | `Coefs -> list_map (fun x-> list_map (fun (_,coef) -> - AO_coef.to_float coef) x.Gto.lc) gtos + AO_coef.to_float coef) x.Gto.lc) gtos | `Expos -> list_map (fun x-> list_map (fun (prim,_) -> AO_expo.to_float - prim.GaussianPrimitive.expo) x.Gto.lc) gtos + prim.GaussianPrimitive.expo) x.Gto.lc) gtos end in let rec get_n n accu = function @@ -577,7 +567,7 @@ let run ?o b au c d m p cart xyz_file = list_map ( fun (g,_) -> g.Gto.lc ) basis in let ang_mom = - list_map (fun (l : (GaussianPrimitive.t * Qptypes.AO_coef.t) list) -> + list_map (fun (l : (GaussianPrimitive.t * Qptypes.AO_coef.t) list) -> let x, _ = List.hd l in Angmom.to_l x.GaussianPrimitive.sym |> Qptypes.Positive_int.to_int ) lc @@ -587,7 +577,7 @@ let run ?o b au c d m p cart xyz_file = |> List.concat in let coef = - list_map (fun l -> + list_map (fun l -> list_map (fun (_,x) -> Qptypes.AO_coef.to_float x) l ) lc |> List.concat @@ -595,16 +585,12 @@ let run ?o b au c d m p cart xyz_file = let shell_prim_num = list_map List.length lc in - let shell_idx = - let rec make_list n accu = function - | 0 -> accu - | i -> make_list n (n :: accu) (i-1) - in + let shell_prim_idx = let rec aux count accu = function | [] -> List.rev accu | l::rest -> - let new_l = make_list count accu (List.length l) in - aux (count+1) new_l rest + let newcount = count+(List.length l) in + aux newcount (count::accu) rest in aux 1 [] lc in @@ -616,18 +602,26 @@ let run ?o b au c d m p cart xyz_file = ~rank:1 ~dim:[| shell_num |] ~data:shell_prim_num); Ezfio.set_basis_shell_ang_mom (Ezfio.ezfio_array_of_list ~rank:1 ~dim:[| shell_num |] ~data:ang_mom ) ; - Ezfio.set_basis_shell_index (Ezfio.ezfio_array_of_list - ~rank:1 ~dim:[| prim_num |] ~data:shell_idx) ; + Ezfio.set_basis_shell_prim_index (Ezfio.ezfio_array_of_list + ~rank:1 ~dim:[| shell_num |] ~data:shell_prim_idx) ; Ezfio.set_basis_basis_nucleus_index (Ezfio.ezfio_array_of_list - ~rank:1 ~dim:[| shell_num |] - ~data:( list_map (fun (_,n) -> Nucl_number.to_int n) basis) - ) ; + ~rank:1 ~dim:[| nucl_num |] + ~data:( + list_map (fun (_,n) -> Nucl_number.to_int n) basis + |> List.fold_left (fun accu i -> + match accu with + | [] -> [] + | (h,j) :: rest -> if j == i then ((h+1,j)::rest) else ((h+1,i)::(h+1,j)::rest) + ) [(0,0)] + |> List.rev + |> List.map fst + )) ; Ezfio.set_basis_nucleus_shell_num(Ezfio.ezfio_array_of_list ~rank:1 ~dim:[| nucl_num |] ~data:( list_map (fun (_,n) -> Nucl_number.to_int n) basis - |> List.fold_left (fun accu i -> - match accu with + |> List.fold_left (fun accu i -> + match accu with | [] -> [(1,i)] | (h,j) :: rest -> if j == i then ((h+1,j)::rest) else ((1,i)::(h,j)::rest) ) [] @@ -677,7 +671,6 @@ let run ?o b au c d m p cart xyz_file = let () = - try ( let open Command_line in begin @@ -724,7 +717,7 @@ If a file with the same name as the basis set exists, this file will be read. O anonymous "FILE" Mandatory "Input file in xyz format or z-matrix."; ] - |> set_specs + |> set_specs end; @@ -735,7 +728,7 @@ If a file with the same name as the basis set exists, this file will be read. O let basis = match Command_line.get "basis" with - | None -> "" + | None -> assert false | Some x -> x in @@ -748,7 +741,7 @@ If a file with the same name as the basis set exists, this file will be read. O | None -> 0 | Some x -> ( if x.[0] = 'm' then ~- (int_of_string (String.sub x 1 (String.length x - 1))) - else + else int_of_string x ) in @@ -774,14 +767,10 @@ If a file with the same name as the basis set exists, this file will be read. O let xyz_filename = match Command_line.anon_args () with - | [] -> failwith "input file is missing" - | x::_ -> x + | [x] -> x + | _ -> (Command_line.help () ; failwith "input file is missing") in run ?o:output basis au charge dummy multiplicity pseudo cart xyz_filename - ) - with - | Failure txt -> Printf.eprintf "Fatal error: %s\n%!" txt - | Command_line.Error txt -> Printf.eprintf "Command line error: %s\n%!" txt diff --git a/ocaml/qp_run.ml b/ocaml/qp_run.ml index dfbab167..d096b15b 100644 --- a/ocaml/qp_run.ml +++ b/ocaml/qp_run.ml @@ -110,7 +110,7 @@ let run slave ?prefix exe ezfio_file = let task_thread = let thread = Thread.create ( fun () -> - TaskServer.run ~port:port_number ) + TaskServer.run port_number ) in thread (); in diff --git a/ocaml/qp_tunnel.ml b/ocaml/qp_tunnel.ml index 6885db73..84e50eb5 100644 --- a/ocaml/qp_tunnel.ml +++ b/ocaml/qp_tunnel.ml @@ -2,7 +2,7 @@ open Qputils open Qptypes type ezfio_or_address = EZFIO of string | ADDRESS of string -type req_or_sub = REQ | SUB +type req_or_sub = REQ | SUB let localport = 42379 @@ -29,7 +29,7 @@ let () = end; let arg = - let x = + let x = match Command_line.anon_args () with | [x] -> x | _ -> begin @@ -44,7 +44,7 @@ let () = in - let localhost = + let localhost = Lazy.force TaskServer.ip_address in @@ -52,28 +52,28 @@ let () = let long_address = match arg with | ADDRESS x -> x - | EZFIO x -> - let ic = + | EZFIO x -> + let ic = Filename.concat (Qpackage.ezfio_work x) "qp_run_address" |> open_in in - let result = + let result = input_line ic |> String.trim in close_in ic; result in - + let protocol, address, port = match String.split_on_char ':' long_address with | t :: a :: p :: [] -> t, a, int_of_string p - | _ -> failwith @@ + | _ -> failwith @@ Printf.sprintf "%s : Malformed address" long_address in - let zmq_context = + let zmq_context = Zmq.Context.create () in @@ -105,10 +105,10 @@ let () = let create_socket sock_type bind_or_connect addr = - let socket = + let socket = Zmq.Socket.create zmq_context sock_type in - let () = + let () = try bind_or_connect socket addr with @@ -131,64 +131,37 @@ let () = Sys.set_signal Sys.sigint handler; - let new_thread_req addr_in addr_out = + let new_thread req_or_sub addr_in addr_out = let socket_in, socket_out = + match req_or_sub with + | REQ -> create_socket Zmq.Socket.router Zmq.Socket.bind addr_in, create_socket Zmq.Socket.dealer Zmq.Socket.connect addr_out - in - - - let action_in = - fun () -> Zmq.Socket.recv_all socket_in |> Zmq.Socket.send_all socket_out - in - - let action_out = - fun () -> Zmq.Socket.recv_all socket_out |> Zmq.Socket.send_all socket_in - in - - let pollitem = - Zmq.Poll.mask_of - [| (socket_convert socket_in, Zmq.Poll.In) ; (socket_convert socket_out, Zmq.Poll.In) |] - in - - while !run_status do - - let polling = - Zmq.Poll.poll ~timeout:1000 pollitem - in - - match polling with - | [| Some Zmq.Poll.In ; Some Zmq.Poll.In |] -> ( action_out () ; action_in () ) - | [| _ ; Some Zmq.Poll.In |] -> action_out () - | [| Some Zmq.Poll.In ; _ |] -> action_in () - | _ -> () - done; - - Zmq.Socket.close socket_in; - Zmq.Socket.close socket_out; - in - - let new_thread_sub addr_in addr_out = - let socket_in, socket_out = + | SUB -> create_socket Zmq.Socket.sub Zmq.Socket.connect addr_in, create_socket Zmq.Socket.pub Zmq.Socket.bind addr_out in - Zmq.Socket.subscribe socket_in ""; + if req_or_sub = SUB then + Zmq.Socket.subscribe socket_in ""; - let action_in = - fun () -> Zmq.Socket.recv_all socket_in |> Zmq.Socket.send_all socket_out + let action_in = + match req_or_sub with + | REQ -> (fun () -> Zmq.Socket.recv_all socket_in |> Zmq.Socket.send_all socket_out) + | SUB -> (fun () -> Zmq.Socket.recv_all socket_in |> Zmq.Socket.send_all socket_out) in - let action_out = - fun () -> () + let action_out = + match req_or_sub with + | REQ -> (fun () -> Zmq.Socket.recv_all socket_out |> Zmq.Socket.send_all socket_in ) + | SUB -> (fun () -> () ) in let pollitem = Zmq.Poll.mask_of - [| (socket_convert socket_in, Zmq.Poll.In) ; (socket_convert socket_out, Zmq.Poll.In) |] + [| (socket_in, Zmq.Poll.In) ; (socket_out, Zmq.Poll.In) |] in @@ -200,8 +173,8 @@ let () = match polling with | [| Some Zmq.Poll.In ; Some Zmq.Poll.In |] -> ( action_out () ; action_in () ) - | [| _ ; Some Zmq.Poll.In |] -> action_out () - | [| Some Zmq.Poll.In ; _ |] -> action_in () + | [| _ ; Some Zmq.Poll.In |] -> action_out () + | [| Some Zmq.Poll.In ; _ |] -> action_in () | _ -> () done; @@ -220,8 +193,8 @@ let () = Printf.sprintf "tcp://*:%d" localport in - let f () = - new_thread_req addr_in addr_out + let f () = + new_thread REQ addr_in addr_out in (Thread.create f) () @@ -238,8 +211,8 @@ let () = Printf.sprintf "tcp://*:%d" (localport+2) in - let f () = - new_thread_req addr_in addr_out + let f () = + new_thread REQ addr_in addr_out in (Thread.create f) () in @@ -254,8 +227,8 @@ let () = Printf.sprintf "tcp://*:%d" (localport+1) in - let f () = - new_thread_sub addr_in addr_out + let f () = + new_thread SUB addr_in addr_out in (Thread.create f) () in @@ -263,7 +236,7 @@ let () = let input_thread = - let f () = + let f () = let addr_out = match arg with | EZFIO _ -> None @@ -275,22 +248,22 @@ let () = Printf.sprintf "tcp://*:%d" (localport+9) in - let socket_in = + let socket_in = create_socket Zmq.Socket.rep Zmq.Socket.bind addr_in in let socket_out = - match addr_out with + match addr_out with | Some addr_out -> Some ( create_socket Zmq.Socket.req Zmq.Socket.connect addr_out) | None -> None in - let temp_file = + let temp_file = Filename.temp_file "qp_tunnel" ".tar.gz" in - let get_ezfio_filename () = + let get_ezfio_filename () = match arg with | EZFIO x -> x | ADDRESS _ -> @@ -304,9 +277,9 @@ let () = end in - let get_input () = + let get_input () = match arg with - | EZFIO x -> + | EZFIO x -> begin Printf.sprintf "tar --exclude=\"*.gz.*\" -zcf %s %s" temp_file x |> Sys.command |> ignore; @@ -318,11 +291,11 @@ let () = in ignore @@ Unix.lseek fd 0 Unix.SEEK_SET ; let bstr = - Unix.map_file fd Bigarray.char + Unix.map_file fd Bigarray.char Bigarray.c_layout false [| len |] |> Bigarray.array1_of_genarray in - let result = + let result = String.init len (fun i -> bstr.{i}) ; in Unix.close fd; @@ -340,7 +313,7 @@ let () = end in - let () = + let () = match socket_out with | None -> () | Some socket_out -> @@ -356,7 +329,7 @@ let () = | ADDRESS _ -> begin Printf.printf "Getting input... %!"; - let ezfio_filename = + let ezfio_filename = get_ezfio_filename () in Printf.printf "%s%!" ezfio_filename; @@ -370,7 +343,7 @@ let () = |> Sys.command |> ignore ; let oc = Filename.concat (Qpackage.ezfio_work ezfio_filename) "qp_run_address" - |> open_out + |> open_out in Printf.fprintf oc "tcp://%s:%d\n" localhost localport; close_out oc; @@ -386,9 +359,9 @@ let () = let action () = match Zmq.Socket.recv socket_in with | "get_input" -> get_input () - |> Zmq.Socket.send socket_in + |> Zmq.Socket.send socket_in | "get_ezfio_filename" -> get_ezfio_filename () - |> Zmq.Socket.send socket_in + |> Zmq.Socket.send socket_in | "test" -> Zmq.Socket.send socket_in "OK" | x -> Printf.sprintf "Message '%s' not understood" x |> Zmq.Socket.send socket_in @@ -399,7 +372,7 @@ On remote hosts, create ssh tunnel using: ssh -L %d:%s:%d -L %d:%s:%d -L %d:%s:%d -L %d:%s:%d %s & Or from this host connect to clients using: ssh -R %d:localhost:%d -R %d:localhost:%d -R %d:localhost:%d -R %d:localhost:%d & -%!" +%!" (port ) localhost (localport ) (port+1) localhost (localport+1) (port+2) localhost (localport+2) @@ -419,12 +392,12 @@ Or from this host connect to clients using: match polling.(0) with | Some Zmq.Poll.In -> action () | None -> () - | Some Zmq.Poll.In_out + | Some Zmq.Poll.In_out | Some Zmq.Poll.Out -> () done; - let () = + let () = match socket_out with | Some socket_out -> Zmq.Socket.close socket_out | None -> () @@ -442,7 +415,7 @@ Or from this host connect to clients using: Thread.join ocaml_thread; Zmq.Context.terminate zmq_context; Printf.printf "qp_tunnel exited properly.\n" - + diff --git a/src/ao_basis/EZFIO.cfg b/src/ao_basis/EZFIO.cfg index 51d726da..b4b4b1d9 100644 --- a/src/ao_basis/EZFIO.cfg +++ b/src/ao_basis/EZFIO.cfg @@ -17,7 +17,7 @@ interface: ezfio, provider [ao_prim_num_max] type: integer doc: Maximum number of primitives -default: =maxval(ao_basis.ao_prim_num) +#default: =maxval(ao_basis.ao_prim_num) interface: ezfio [ao_nucl] diff --git a/src/ao_basis/aos.irp.f b/src/ao_basis/aos.irp.f index 1cbd3976..553543b9 100644 --- a/src/ao_basis/aos.irp.f +++ b/src/ao_basis/aos.irp.f @@ -1,11 +1,20 @@ + +! --- + BEGIN_PROVIDER [ integer, ao_prim_num_max ] - implicit none + BEGIN_DOC ! Max number of primitives. END_DOC - ao_prim_num_max = maxval(ao_prim_num) + + implicit none + ao_prim_num_max = maxval(ao_prim_num) + call ezfio_set_ao_basis_ao_prim_num_max(ao_prim_num_max) + END_PROVIDER +! --- + BEGIN_PROVIDER [ integer, ao_shell, (ao_num) ] implicit none BEGIN_DOC @@ -21,21 +30,6 @@ BEGIN_PROVIDER [ integer, ao_shell, (ao_num) ] enddo enddo -END_PROVIDER - -BEGIN_PROVIDER [ integer, ao_first_of_shell, (shell_num) ] - implicit none - BEGIN_DOC - ! Index of the shell to which the AO corresponds - END_DOC - integer :: i, j, k, n - k=1 - do i=1,shell_num - ao_first_of_shell(i) = k - n = shell_ang_mom(i)+1 - k = k+(n*(n+1))/2 - enddo - END_PROVIDER BEGIN_PROVIDER [ double precision, ao_coef_normalized, (ao_num,ao_prim_num_max) ] diff --git a/src/ao_basis/aos_in_r.irp.f b/src/ao_basis/aos_in_r.irp.f index 902827eb..7fcb980a 100644 --- a/src/ao_basis/aos_in_r.irp.f +++ b/src/ao_basis/aos_in_r.irp.f @@ -12,21 +12,21 @@ double precision function ao_value(i,r) integer :: power_ao(3) double precision :: accu,dx,dy,dz,r2 num_ao = ao_nucl(i) -! power_ao(1:3)= ao_power(i,1:3) -! center_ao(1:3) = nucl_coord(num_ao,1:3) -! dx = (r(1) - center_ao(1)) -! dy = (r(2) - center_ao(2)) -! dz = (r(3) - center_ao(3)) -! r2 = dx*dx + dy*dy + dz*dz -! dx = dx**power_ao(1) -! dy = dy**power_ao(2) -! dz = dz**power_ao(3) + power_ao(1:3)= ao_power(i,1:3) + center_ao(1:3) = nucl_coord(num_ao,1:3) + dx = (r(1) - center_ao(1)) + dy = (r(2) - center_ao(2)) + dz = (r(3) - center_ao(3)) + r2 = dx*dx + dy*dy + dz*dz + dx = dx**power_ao(1) + dy = dy**power_ao(2) + dz = dz**power_ao(3) accu = 0.d0 -! do m=1,ao_prim_num(i) -! beta = ao_expo_ordered_transp(m,i) -! accu += ao_coef_normalized_ordered_transp(m,i) * dexp(-beta*r2) -! enddo + do m=1,ao_prim_num(i) + beta = ao_expo_ordered_transp(m,i) + accu += ao_coef_normalized_ordered_transp(m,i) * dexp(-beta*r2) + enddo ao_value = accu * dx * dy * dz end diff --git a/src/ao_basis/spherical_to_cartesian.irp.f b/src/ao_basis/spherical_to_cartesian.irp.f index 336161f8..33a3bc89 100644 --- a/src/ao_basis/spherical_to_cartesian.irp.f +++ b/src/ao_basis/spherical_to_cartesian.irp.f @@ -1,7 +1,7 @@ ! Spherical to cartesian transformation matrix obtained with ! Horton (http://theochem.github.com/horton/, 2015) -! First index is the index of the cartesian AO, obtained by ao_power_index +! First index is the index of the carteisan AO, obtained by ao_power_index ! Second index is the index of the spherical AO BEGIN_PROVIDER [ double precision, cart_to_sphe_0, (1,1) ] diff --git a/src/ao_one_e_ints/NEED b/src/ao_one_e_ints/NEED index 61d23b1e..b9caaf5d 100644 --- a/src/ao_one_e_ints/NEED +++ b/src/ao_one_e_ints/NEED @@ -1,2 +1,3 @@ ao_basis pseudo +cosgtos_ao_int diff --git a/src/ao_one_e_ints/ao_overlap.irp.f b/src/ao_one_e_ints/ao_overlap.irp.f index d9061d67..86fa7cd4 100644 --- a/src/ao_one_e_ints/ao_overlap.irp.f +++ b/src/ao_one_e_ints/ao_overlap.irp.f @@ -1,75 +1,99 @@ - BEGIN_PROVIDER [ double precision, ao_overlap,(ao_num,ao_num) ] -&BEGIN_PROVIDER [ double precision, ao_overlap_x,(ao_num,ao_num) ] -&BEGIN_PROVIDER [ double precision, ao_overlap_y,(ao_num,ao_num) ] -&BEGIN_PROVIDER [ double precision, ao_overlap_z,(ao_num,ao_num) ] - implicit none + +! --- + + BEGIN_PROVIDER [ double precision, ao_overlap , (ao_num, ao_num) ] +&BEGIN_PROVIDER [ double precision, ao_overlap_x, (ao_num, ao_num) ] +&BEGIN_PROVIDER [ double precision, ao_overlap_y, (ao_num, ao_num) ] +&BEGIN_PROVIDER [ double precision, ao_overlap_z, (ao_num, ao_num) ] + BEGIN_DOC -! Overlap between atomic basis functions: -! -! :math:`\int \chi_i(r) \chi_j(r) dr` + ! Overlap between atomic basis functions: + ! + ! :math:`\int \chi_i(r) \chi_j(r) dr` END_DOC - integer :: i,j,n,l - double precision :: f - integer :: dim1 + + implicit none + integer :: i, j, n, l, dim1, power_A(3), power_B(3) double precision :: overlap, overlap_x, overlap_y, overlap_z double precision :: alpha, beta, c double precision :: A_center(3), B_center(3) - integer :: power_A(3), power_B(3) - ao_overlap = 0.d0 + + ao_overlap = 0.d0 ao_overlap_x = 0.d0 ao_overlap_y = 0.d0 ao_overlap_z = 0.d0 - if (read_ao_integrals_overlap) then - call ezfio_get_ao_one_e_ints_ao_integrals_overlap(ao_overlap(1:ao_num, 1:ao_num)) - print *, 'AO overlap integrals read from disk' + + if(read_ao_integrals_overlap) then + + call ezfio_get_ao_one_e_ints_ao_integrals_overlap(ao_overlap(1:ao_num, 1:ao_num)) + print *, 'AO overlap integrals read from disk' + else - dim1=100 - !$OMP PARALLEL DO SCHEDULE(GUIDED) & - !$OMP DEFAULT(NONE) & - !$OMP PRIVATE(A_center,B_center,power_A,power_B,& - !$OMP overlap_x,overlap_y, overlap_z, overlap, & - !$OMP alpha, beta,i,j,c) & - !$OMP SHARED(nucl_coord,ao_power,ao_prim_num, & - !$OMP ao_overlap_x,ao_overlap_y,ao_overlap_z,ao_overlap,ao_num,ao_coef_normalized_ordered_transp,ao_nucl, & - !$OMP ao_expo_ordered_transp,dim1) - do j=1,ao_num - A_center(1) = nucl_coord( ao_nucl(j), 1 ) - A_center(2) = nucl_coord( ao_nucl(j), 2 ) - A_center(3) = nucl_coord( ao_nucl(j), 3 ) - power_A(1) = ao_power( j, 1 ) - power_A(2) = ao_power( j, 2 ) - power_A(3) = ao_power( j, 3 ) - do i= 1,ao_num - B_center(1) = nucl_coord( ao_nucl(i), 1 ) - B_center(2) = nucl_coord( ao_nucl(i), 2 ) - B_center(3) = nucl_coord( ao_nucl(i), 3 ) - power_B(1) = ao_power( i, 1 ) - power_B(2) = ao_power( i, 2 ) - power_B(3) = ao_power( i, 3 ) - do n = 1,ao_prim_num(j) - alpha = ao_expo_ordered_transp(n,j) - do l = 1, ao_prim_num(i) - beta = ao_expo_ordered_transp(l,i) - call overlap_gaussian_xyz(A_center,B_center,alpha,beta,power_A,power_B,overlap_x,overlap_y,overlap_z,overlap,dim1) - c = ao_coef_normalized_ordered_transp(n,j) * ao_coef_normalized_ordered_transp(l,i) - ao_overlap(i,j) += c * overlap - if(isnan(ao_overlap(i,j)))then - print*,'i,j',i,j - print*,'l,n',l,n - print*,'c,overlap',c,overlap - print*,overlap_x,overlap_y,overlap_z - stop - endif - ao_overlap_x(i,j) += c * overlap_x - ao_overlap_y(i,j) += c * overlap_y - ao_overlap_z(i,j) += c * overlap_z + if(use_cosgtos) then + !print*, ' use_cosgtos for ao_overlap ?', use_cosgtos + + do j = 1, ao_num + do i = 1, ao_num + ao_overlap (i,j) = ao_overlap_cosgtos (i,j) + ao_overlap_x(i,j) = ao_overlap_cosgtos_x(i,j) + ao_overlap_y(i,j) = ao_overlap_cosgtos_y(i,j) + ao_overlap_z(i,j) = ao_overlap_cosgtos_z(i,j) + enddo + enddo + + else + + dim1=100 + !$OMP PARALLEL DO SCHEDULE(GUIDED) & + !$OMP DEFAULT(NONE) & + !$OMP PRIVATE(A_center,B_center,power_A,power_B,& + !$OMP overlap_x,overlap_y, overlap_z, overlap, & + !$OMP alpha, beta,i,j,c) & + !$OMP SHARED(nucl_coord,ao_power,ao_prim_num, & + !$OMP ao_overlap_x,ao_overlap_y,ao_overlap_z,ao_overlap,ao_num,ao_coef_normalized_ordered_transp,ao_nucl, & + !$OMP ao_expo_ordered_transp,dim1) + do j=1,ao_num + A_center(1) = nucl_coord( ao_nucl(j), 1 ) + A_center(2) = nucl_coord( ao_nucl(j), 2 ) + A_center(3) = nucl_coord( ao_nucl(j), 3 ) + power_A(1) = ao_power( j, 1 ) + power_A(2) = ao_power( j, 2 ) + power_A(3) = ao_power( j, 3 ) + do i= 1,ao_num + B_center(1) = nucl_coord( ao_nucl(i), 1 ) + B_center(2) = nucl_coord( ao_nucl(i), 2 ) + B_center(3) = nucl_coord( ao_nucl(i), 3 ) + power_B(1) = ao_power( i, 1 ) + power_B(2) = ao_power( i, 2 ) + power_B(3) = ao_power( i, 3 ) + do n = 1,ao_prim_num(j) + alpha = ao_expo_ordered_transp(n,j) + do l = 1, ao_prim_num(i) + beta = ao_expo_ordered_transp(l,i) + call overlap_gaussian_xyz(A_center,B_center,alpha,beta,power_A,power_B,overlap_x,overlap_y,overlap_z,overlap,dim1) + c = ao_coef_normalized_ordered_transp(n,j) * ao_coef_normalized_ordered_transp(l,i) + ao_overlap(i,j) += c * overlap + if(isnan(ao_overlap(i,j)))then + print*,'i,j',i,j + print*,'l,n',l,n + print*,'c,overlap',c,overlap + print*,overlap_x,overlap_y,overlap_z + stop + endif + ao_overlap_x(i,j) += c * overlap_x + ao_overlap_y(i,j) += c * overlap_y + ao_overlap_z(i,j) += c * overlap_z + enddo + enddo enddo enddo - enddo - enddo - !$OMP END PARALLEL DO + !$OMP END PARALLEL DO + + endif + endif + if (write_ao_integrals_overlap) then call ezfio_set_ao_one_e_ints_ao_integrals_overlap(ao_overlap(1:ao_num, 1:ao_num)) print *, 'AO overlap integrals written to disk' @@ -77,6 +101,8 @@ END_PROVIDER +! --- + BEGIN_PROVIDER [ double precision, ao_overlap_imag, (ao_num, ao_num) ] implicit none BEGIN_DOC @@ -85,6 +111,8 @@ BEGIN_PROVIDER [ double precision, ao_overlap_imag, (ao_num, ao_num) ] ao_overlap_imag = 0.d0 END_PROVIDER +! --- + BEGIN_PROVIDER [ complex*16, ao_overlap_complex, (ao_num, ao_num) ] implicit none BEGIN_DOC @@ -98,37 +126,39 @@ BEGIN_PROVIDER [ complex*16, ao_overlap_complex, (ao_num, ao_num) ] enddo END_PROVIDER +! --- +BEGIN_PROVIDER [ double precision, ao_overlap_abs, (ao_num, ao_num) ] - -BEGIN_PROVIDER [ double precision, ao_overlap_abs,(ao_num,ao_num) ] - implicit none BEGIN_DOC -! Overlap between absolute values of atomic basis functions: -! -! :math:`\int |\chi_i(r)| |\chi_j(r)| dr` + ! Overlap between absolute values of atomic basis functions: + ! + ! :math:`\int |\chi_i(r)| |\chi_j(r)| dr` END_DOC - integer :: i,j,n,l - double precision :: f - integer :: dim1 - double precision :: overlap, overlap_x, overlap_y, overlap_z + + implicit none + integer :: i, j, n, l, dim1, power_A(3), power_B(3) + double precision :: overlap_x, overlap_y, overlap_z double precision :: alpha, beta double precision :: A_center(3), B_center(3) - integer :: power_A(3), power_B(3) double precision :: lower_exp_val, dx - if (is_periodic) then - do j=1,ao_num - do i= 1,ao_num - ao_overlap_abs(i,j)= cdabs(ao_overlap_complex(i,j)) + + if(is_periodic) then + + do j = 1, ao_num + do i = 1, ao_num + ao_overlap_abs(i,j) = cdabs(ao_overlap_complex(i,j)) enddo enddo + else + dim1=100 lower_exp_val = 40.d0 !$OMP PARALLEL DO SCHEDULE(GUIDED) & !$OMP DEFAULT(NONE) & !$OMP PRIVATE(A_center,B_center,power_A,power_B, & - !$OMP overlap_x,overlap_y, overlap_z, overlap, & + !$OMP overlap_x,overlap_y, overlap_z, & !$OMP alpha, beta,i,j,dx) & !$OMP SHARED(nucl_coord,ao_power,ao_prim_num, & !$OMP ao_overlap_abs,ao_num,ao_coef_normalized_ordered_transp,ao_nucl,& @@ -161,9 +191,13 @@ BEGIN_PROVIDER [ double precision, ao_overlap_abs,(ao_num,ao_num) ] enddo enddo !$OMP END PARALLEL DO + endif + END_PROVIDER +! --- + BEGIN_PROVIDER [ double precision, S_inv,(ao_num,ao_num) ] implicit none BEGIN_DOC diff --git a/src/ao_one_e_ints/kin_ao_ints.irp.f b/src/ao_one_e_ints/kin_ao_ints.irp.f index 4f117deb..a5ee0670 100644 --- a/src/ao_one_e_ints/kin_ao_ints.irp.f +++ b/src/ao_one_e_ints/kin_ao_ints.irp.f @@ -1,7 +1,10 @@ - BEGIN_PROVIDER [ double precision, ao_deriv2_x,(ao_num,ao_num) ] -&BEGIN_PROVIDER [ double precision, ao_deriv2_y,(ao_num,ao_num) ] -&BEGIN_PROVIDER [ double precision, ao_deriv2_z,(ao_num,ao_num) ] - implicit none + +! --- + + BEGIN_PROVIDER [ double precision, ao_deriv2_x, (ao_num, ao_num) ] +&BEGIN_PROVIDER [ double precision, ao_deriv2_y, (ao_num, ao_num) ] +&BEGIN_PROVIDER [ double precision, ao_deriv2_z, (ao_num, ao_num) ] + BEGIN_DOC ! Second derivative matrix elements in the |AO| basis. ! @@ -11,114 +14,131 @@ ! \langle \chi_i(x,y,z) | \frac{\partial^2}{\partial x^2} |\chi_j (x,y,z) \rangle ! END_DOC - integer :: i,j,n,l - double precision :: f - integer :: dim1 + + implicit none + integer :: i, j, n, l, dim1, power_A(3), power_B(3) double precision :: overlap, overlap_y, overlap_z double precision :: overlap_x0, overlap_y0, overlap_z0 double precision :: alpha, beta, c double precision :: A_center(3), B_center(3) - integer :: power_A(3), power_B(3) double precision :: d_a_2,d_2 - dim1=100 - ! -- Dummy call to provide everything - A_center(:) = 0.d0 - B_center(:) = 1.d0 - alpha = 1.d0 - beta = .1d0 - power_A = 1 - power_B = 0 - call overlap_gaussian_xyz(A_center,B_center,alpha,beta,power_A,power_B,overlap_y,d_a_2,overlap_z,overlap,dim1) - ! -- + if(use_cosgtos) then + !print*, 'use_cosgtos for ao_kinetic_integrals ?', use_cosgtos - !$OMP PARALLEL DO SCHEDULE(GUIDED) & - !$OMP DEFAULT(NONE) & - !$OMP PRIVATE(A_center,B_center,power_A,power_B,& - !$OMP overlap_y, overlap_z, overlap, & - !$OMP alpha, beta,i,j,c,d_a_2,d_2,deriv_tmp, & - !$OMP overlap_x0,overlap_y0,overlap_z0) & - !$OMP SHARED(nucl_coord,ao_power,ao_prim_num, & - !$OMP ao_deriv2_x,ao_deriv2_y,ao_deriv2_z,ao_num,ao_coef_normalized_ordered_transp,ao_nucl, & - !$OMP ao_expo_ordered_transp,dim1) - do j=1,ao_num - A_center(1) = nucl_coord( ao_nucl(j), 1 ) - A_center(2) = nucl_coord( ao_nucl(j), 2 ) - A_center(3) = nucl_coord( ao_nucl(j), 3 ) - power_A(1) = ao_power( j, 1 ) - power_A(2) = ao_power( j, 2 ) - power_A(3) = ao_power( j, 3 ) - do i= 1,ao_num - ao_deriv2_x(i,j)= 0.d0 - ao_deriv2_y(i,j)= 0.d0 - ao_deriv2_z(i,j)= 0.d0 - B_center(1) = nucl_coord( ao_nucl(i), 1 ) - B_center(2) = nucl_coord( ao_nucl(i), 2 ) - B_center(3) = nucl_coord( ao_nucl(i), 3 ) - power_B(1) = ao_power( i, 1 ) - power_B(2) = ao_power( i, 2 ) - power_B(3) = ao_power( i, 3 ) - do n = 1,ao_prim_num(j) - alpha = ao_expo_ordered_transp(n,j) - do l = 1, ao_prim_num(i) - beta = ao_expo_ordered_transp(l,i) - call overlap_gaussian_xyz(A_center,B_center,alpha,beta,power_A,power_B,overlap_x0,overlap_y0,overlap_z0,overlap,dim1) - c = ao_coef_normalized_ordered_transp(n,j) * ao_coef_normalized_ordered_transp(l,i) + do j = 1, ao_num + do i = 1, ao_num + ao_deriv2_x(i,j) = ao_deriv2_cosgtos_x(i,j) + ao_deriv2_y(i,j) = ao_deriv2_cosgtos_y(i,j) + ao_deriv2_z(i,j) = ao_deriv2_cosgtos_z(i,j) + enddo + enddo - power_A(1) = power_A(1)-2 - if (power_A(1)>-1) then - call overlap_gaussian_xyz(A_center,B_center,alpha,beta,power_A,power_B,d_a_2,overlap_y,overlap_z,overlap,dim1) - else - d_a_2 = 0.d0 - endif - power_A(1) = power_A(1)+4 - call overlap_gaussian_xyz(A_center,B_center,alpha,beta,power_A,power_B,d_2,overlap_y,overlap_z,overlap,dim1) - power_A(1) = power_A(1)-2 + else - double precision :: deriv_tmp - deriv_tmp = (-2.d0 * alpha * (2.d0 * power_A(1) +1.d0) * overlap_x0 & - +power_A(1) * (power_A(1)-1.d0) * d_a_2 & - +4.d0 * alpha * alpha * d_2 )*overlap_y0*overlap_z0 + dim1=100 - ao_deriv2_x(i,j) += c*deriv_tmp - power_A(2) = power_A(2)-2 - if (power_A(2)>-1) then - call overlap_gaussian_xyz(A_center,B_center,alpha,beta,power_A,power_B,overlap_y,d_a_2,overlap_z,overlap,dim1) - else - d_a_2 = 0.d0 - endif - power_A(2) = power_A(2)+4 - call overlap_gaussian_xyz(A_center,B_center,alpha,beta,power_A,power_B,overlap_y,d_2,overlap_z,overlap,dim1) - power_A(2) = power_A(2)-2 + ! -- Dummy call to provide everything + A_center(:) = 0.d0 + B_center(:) = 1.d0 + alpha = 1.d0 + beta = .1d0 + power_A = 1 + power_B = 0 + call overlap_gaussian_xyz(A_center,B_center,alpha,beta,power_A,power_B,overlap_y,d_a_2,overlap_z,overlap,dim1) + ! -- - deriv_tmp = (-2.d0 * alpha * (2.d0 * power_A(2) +1.d0 ) * overlap_y0 & - +power_A(2) * (power_A(2)-1.d0) * d_a_2 & - +4.d0 * alpha * alpha * d_2 )*overlap_x0*overlap_z0 - ao_deriv2_y(i,j) += c*deriv_tmp + !$OMP PARALLEL DO SCHEDULE(GUIDED) & + !$OMP DEFAULT(NONE) & + !$OMP PRIVATE(A_center,B_center,power_A,power_B,& + !$OMP overlap_y, overlap_z, overlap, & + !$OMP alpha, beta,i,j,c,d_a_2,d_2,deriv_tmp, & + !$OMP overlap_x0,overlap_y0,overlap_z0) & + !$OMP SHARED(nucl_coord,ao_power,ao_prim_num, & + !$OMP ao_deriv2_x,ao_deriv2_y,ao_deriv2_z,ao_num,ao_coef_normalized_ordered_transp,ao_nucl, & + !$OMP ao_expo_ordered_transp,dim1) + do j=1,ao_num + A_center(1) = nucl_coord( ao_nucl(j), 1 ) + A_center(2) = nucl_coord( ao_nucl(j), 2 ) + A_center(3) = nucl_coord( ao_nucl(j), 3 ) + power_A(1) = ao_power( j, 1 ) + power_A(2) = ao_power( j, 2 ) + power_A(3) = ao_power( j, 3 ) + do i= 1,ao_num + ao_deriv2_x(i,j)= 0.d0 + ao_deriv2_y(i,j)= 0.d0 + ao_deriv2_z(i,j)= 0.d0 + B_center(1) = nucl_coord( ao_nucl(i), 1 ) + B_center(2) = nucl_coord( ao_nucl(i), 2 ) + B_center(3) = nucl_coord( ao_nucl(i), 3 ) + power_B(1) = ao_power( i, 1 ) + power_B(2) = ao_power( i, 2 ) + power_B(3) = ao_power( i, 3 ) + do n = 1,ao_prim_num(j) + alpha = ao_expo_ordered_transp(n,j) + do l = 1, ao_prim_num(i) + beta = ao_expo_ordered_transp(l,i) + call overlap_gaussian_xyz(A_center,B_center,alpha,beta,power_A,power_B,overlap_x0,overlap_y0,overlap_z0,overlap,dim1) + c = ao_coef_normalized_ordered_transp(n,j) * ao_coef_normalized_ordered_transp(l,i) - power_A(3) = power_A(3)-2 - if (power_A(3)>-1) then - call overlap_gaussian_xyz(A_center,B_center,alpha,beta,power_A,power_B,overlap_y,overlap_z,d_a_2,overlap,dim1) - else - d_a_2 = 0.d0 - endif - power_A(3) = power_A(3)+4 - call overlap_gaussian_xyz(A_center,B_center,alpha,beta,power_A,power_B,overlap_y,overlap_z,d_2,overlap,dim1) - power_A(3) = power_A(3)-2 + power_A(1) = power_A(1)-2 + if (power_A(1)>-1) then + call overlap_gaussian_xyz(A_center,B_center,alpha,beta,power_A,power_B,d_a_2,overlap_y,overlap_z,overlap,dim1) + else + d_a_2 = 0.d0 + endif + power_A(1) = power_A(1)+4 + call overlap_gaussian_xyz(A_center,B_center,alpha,beta,power_A,power_B,d_2,overlap_y,overlap_z,overlap,dim1) + power_A(1) = power_A(1)-2 - deriv_tmp = (-2.d0 * alpha * (2.d0 * power_A(3) +1.d0 ) * overlap_z0 & - +power_A(3) * (power_A(3)-1.d0) * d_a_2 & - +4.d0 * alpha * alpha * d_2 )*overlap_x0*overlap_y0 - ao_deriv2_z(i,j) += c*deriv_tmp + double precision :: deriv_tmp + deriv_tmp = (-2.d0 * alpha * (2.d0 * power_A(1) +1.d0) * overlap_x0 & + +power_A(1) * (power_A(1)-1.d0) * d_a_2 & + +4.d0 * alpha * alpha * d_2 )*overlap_y0*overlap_z0 + ao_deriv2_x(i,j) += c*deriv_tmp + power_A(2) = power_A(2)-2 + if (power_A(2)>-1) then + call overlap_gaussian_xyz(A_center,B_center,alpha,beta,power_A,power_B,overlap_y,d_a_2,overlap_z,overlap,dim1) + else + d_a_2 = 0.d0 + endif + power_A(2) = power_A(2)+4 + call overlap_gaussian_xyz(A_center,B_center,alpha,beta,power_A,power_B,overlap_y,d_2,overlap_z,overlap,dim1) + power_A(2) = power_A(2)-2 + + deriv_tmp = (-2.d0 * alpha * (2.d0 * power_A(2) +1.d0 ) * overlap_y0 & + +power_A(2) * (power_A(2)-1.d0) * d_a_2 & + +4.d0 * alpha * alpha * d_2 )*overlap_x0*overlap_z0 + ao_deriv2_y(i,j) += c*deriv_tmp + + power_A(3) = power_A(3)-2 + if (power_A(3)>-1) then + call overlap_gaussian_xyz(A_center,B_center,alpha,beta,power_A,power_B,overlap_y,overlap_z,d_a_2,overlap,dim1) + else + d_a_2 = 0.d0 + endif + power_A(3) = power_A(3)+4 + call overlap_gaussian_xyz(A_center,B_center,alpha,beta,power_A,power_B,overlap_y,overlap_z,d_2,overlap,dim1) + power_A(3) = power_A(3)-2 + + deriv_tmp = (-2.d0 * alpha * (2.d0 * power_A(3) +1.d0 ) * overlap_z0 & + +power_A(3) * (power_A(3)-1.d0) * d_a_2 & + +4.d0 * alpha * alpha * d_2 )*overlap_x0*overlap_y0 + ao_deriv2_z(i,j) += c*deriv_tmp + + enddo + enddo enddo enddo - enddo - enddo - !$OMP END PARALLEL DO + !$OMP END PARALLEL DO + + endif END_PROVIDER +! --- + BEGIN_PROVIDER [double precision, ao_kinetic_integrals, (ao_num,ao_num)] implicit none BEGIN_DOC diff --git a/src/ao_one_e_ints/pot_ao_ints.irp.f b/src/ao_one_e_ints/pot_ao_ints.irp.f index 4108ce71..2b6a4d05 100644 --- a/src/ao_one_e_ints/pot_ao_ints.irp.f +++ b/src/ao_one_e_ints/pot_ao_ints.irp.f @@ -1,4 +1,8 @@ + +! --- + BEGIN_PROVIDER [ double precision, ao_integrals_n_e, (ao_num,ao_num)] + BEGIN_DOC ! Nucleus-electron interaction, in the |AO| basis set. ! @@ -6,78 +10,103 @@ BEGIN_PROVIDER [ double precision, ao_integrals_n_e, (ao_num,ao_num)] ! ! These integrals also contain the pseudopotential integrals. END_DOC + implicit none - double precision :: alpha, beta, gama, delta - integer :: num_A,num_B - double precision :: A_center(3),B_center(3),C_center(3) - integer :: power_A(3),power_B(3) - integer :: i,j,k,l,n_pt_in,m - double precision :: overlap_x,overlap_y,overlap_z,overlap,dx,NAI_pol_mult + integer :: num_A, num_B, power_A(3), power_B(3) + integer :: i, j, k, l, n_pt_in, m + double precision :: alpha, beta + double precision :: A_center(3),B_center(3),C_center(3) + double precision :: overlap_x,overlap_y,overlap_z,overlap,dx,NAI_pol_mult if (read_ao_integrals_n_e) then + call ezfio_get_ao_one_e_ints_ao_integrals_n_e(ao_integrals_n_e) print *, 'AO N-e integrals read from disk' + else - ao_integrals_n_e = 0.d0 + if(use_cosgtos) then + !print *, " use_cosgtos for ao_integrals_n_e ?", use_cosgtos - ! _ - ! /| / |_) - ! | / | \ - ! + do j = 1, ao_num + do i = 1, ao_num + ao_integrals_n_e(i,j) = ao_integrals_n_e_cosgtos(i,j) + enddo + enddo - !$OMP PARALLEL & - !$OMP DEFAULT (NONE) & - !$OMP PRIVATE (i,j,k,l,m,alpha,beta,A_center,B_center,C_center,power_A,power_B,& - !$OMP num_A,num_B,Z,c,n_pt_in) & - !$OMP SHARED (ao_num,ao_prim_num,ao_expo_ordered_transp,ao_power,ao_nucl,nucl_coord,ao_coef_normalized_ordered_transp,& - !$OMP n_pt_max_integrals,ao_integrals_n_e,nucl_num,nucl_charge) + else - n_pt_in = n_pt_max_integrals + ao_integrals_n_e = 0.d0 - !$OMP DO SCHEDULE (dynamic) + ! _ + ! /| / |_) + ! | / | \ + ! - do j = 1, ao_num - num_A = ao_nucl(j) - power_A(1:3)= ao_power(j,1:3) - A_center(1:3) = nucl_coord(num_A,1:3) + !$OMP PARALLEL & + !$OMP DEFAULT (NONE) & + !$OMP PRIVATE (i,j,k,l,m,alpha,beta,A_center,B_center,C_center,power_A,power_B,& + !$OMP num_A,num_B,Z,c,c1,n_pt_in) & + !$OMP SHARED (ao_num,ao_prim_num,ao_expo_ordered_transp,ao_power,ao_nucl,nucl_coord,ao_coef_normalized_ordered_transp,& + !$OMP n_pt_max_integrals,ao_integrals_n_e,nucl_num,nucl_charge) - do i = 1, ao_num + n_pt_in = n_pt_max_integrals - num_B = ao_nucl(i) - power_B(1:3)= ao_power(i,1:3) - B_center(1:3) = nucl_coord(num_B,1:3) + !$OMP DO SCHEDULE (dynamic) - do l=1,ao_prim_num(j) - alpha = ao_expo_ordered_transp(l,j) + do j = 1, ao_num + num_A = ao_nucl(j) + power_A(1:3)= ao_power(j,1:3) + A_center(1:3) = nucl_coord(num_A,1:3) - do m=1,ao_prim_num(i) - beta = ao_expo_ordered_transp(m,i) + do i = 1, ao_num - double precision :: c - c = 0.d0 + num_B = ao_nucl(i) + power_B(1:3)= ao_power(i,1:3) + B_center(1:3) = nucl_coord(num_B,1:3) - do k = 1, nucl_num - double precision :: Z - Z = nucl_charge(k) + do l=1,ao_prim_num(j) + alpha = ao_expo_ordered_transp(l,j) - C_center(1:3) = nucl_coord(k,1:3) + do m=1,ao_prim_num(i) + beta = ao_expo_ordered_transp(m,i) - c = c - Z * NAI_pol_mult(A_center,B_center, & - power_A,power_B,alpha,beta,C_center,n_pt_in) + double precision :: c, c1 + c = 0.d0 + do k = 1, nucl_num + double precision :: Z + Z = nucl_charge(k) + + C_center(1:3) = nucl_coord(k,1:3) + + !print *, ' ' + !print *, A_center, B_center, C_center, power_A, power_B + !print *, alpha, beta + + c1 = NAI_pol_mult( A_center, B_center, power_A, power_B & + , alpha, beta, C_center, n_pt_in ) + + !print *, ' c1 = ', c1 + + c = c - Z * c1 + + enddo + ao_integrals_n_e(i,j) = ao_integrals_n_e(i,j) & + + ao_coef_normalized_ordered_transp(l,j) & + * ao_coef_normalized_ordered_transp(m,i) * c enddo - ao_integrals_n_e(i,j) = ao_integrals_n_e(i,j) & - + ao_coef_normalized_ordered_transp(l,j) & - * ao_coef_normalized_ordered_transp(m,i) * c enddo enddo enddo - enddo !$OMP END DO !$OMP END PARALLEL - IF (DO_PSEUDO) THEN + + endif + + + IF(DO_PSEUDO) THEN ao_integrals_n_e += ao_pseudo_integrals ENDIF @@ -98,7 +127,7 @@ BEGIN_PROVIDER [ double precision, ao_integrals_n_e_imag, (ao_num,ao_num)] ! :math:`\langle \chi_i | -\sum_A \frac{1}{|r-R_A|} | \chi_j \rangle` END_DOC implicit none - double precision :: alpha, beta, gama, delta + double precision :: alpha, beta integer :: num_A,num_B double precision :: A_center(3),B_center(3),C_center(3) integer :: power_A(3),power_B(3) @@ -121,7 +150,7 @@ BEGIN_PROVIDER [ double precision, ao_integrals_n_e_per_atom, (ao_num,ao_num,nuc ! :math:`\langle \chi_i | -\frac{1}{|r-R_A|} | \chi_j \rangle` END_DOC implicit none - double precision :: alpha, beta, gama, delta + double precision :: alpha, beta integer :: i_c,num_A,num_B double precision :: A_center(3),B_center(3),C_center(3) integer :: power_A(3),power_B(3) @@ -259,11 +288,14 @@ double precision function NAI_pol_mult(A_center,B_center,power_A,power_B,alpha,b ! sum of integrals of type : int {t,[0,1]} exp-(rho.(P-Q)^2 * t^2) * t^i do i =0 ,n_pt_out,2 accu += d(i) * rint(i/2,const) + +! print *, i/2, const, d(i), rint(shiftr(i, 1), const) enddo NAI_pol_mult = accu * coeff end +! --- subroutine give_polynomial_mult_center_one_e(A_center,B_center,alpha,beta,power_A,power_B,C_center,n_pt_in,d,n_pt_out) implicit none @@ -575,61 +607,3 @@ double precision function V_r(n,alpha) end -double precision function V_phi(n,m) - implicit none - BEGIN_DOC - ! Computes the angular $\phi$ part of the nuclear attraction integral: - ! - ! $\int_{0}^{2 \pi} \cos(\phi)^n \sin(\phi)^m d\phi$. - END_DOC - integer :: n,m, i - double precision :: prod, Wallis - prod = 1.d0 - do i = 0,shiftr(n,1)-1 - prod = prod/ (1.d0 + dfloat(m+1)/dfloat(n-i-i-1)) - enddo - V_phi = 4.d0 * prod * Wallis(m) -end - - -double precision function V_theta(n,m) - implicit none - BEGIN_DOC - ! Computes the angular $\theta$ part of the nuclear attraction integral: - ! - ! $\int_{0}^{\pi} \cos(\theta)^n \sin(\theta)^m d\theta$ - END_DOC - integer :: n,m,i - double precision :: Wallis, prod - include 'utils/constants.include.F' - V_theta = 0.d0 - prod = 1.d0 - do i = 0,shiftr(n,1)-1 - prod = prod / (1.d0 + dfloat(m+1)/dfloat(n-i-i-1)) - enddo - V_theta = (prod+prod) * Wallis(m) -end - - -double precision function Wallis(n) - implicit none - BEGIN_DOC - ! Wallis integral: - ! - ! $\int_{0}^{\pi} \cos(\theta)^n d\theta$. - END_DOC - double precision :: fact - integer :: n,p - include 'utils/constants.include.F' - if(iand(n,1).eq.0)then - Wallis = fact(shiftr(n,1)) - Wallis = pi * fact(n) / (dble(ibset(0_8,n)) * (Wallis+Wallis)*Wallis) - else - p = shiftr(n,1) - Wallis = fact(p) - Wallis = dble(ibset(0_8,p+p)) * Wallis*Wallis / fact(p+p+1) - endif - -end - - diff --git a/src/ao_one_e_ints/pot_ao_pseudo_ints.irp.f b/src/ao_one_e_ints/pot_ao_pseudo_ints.irp.f index e75ca056..24f43311 100644 --- a/src/ao_one_e_ints/pot_ao_pseudo_ints.irp.f +++ b/src/ao_one_e_ints/pot_ao_pseudo_ints.irp.f @@ -28,7 +28,6 @@ BEGIN_PROVIDER [ double precision, ao_pseudo_integrals, (ao_num,ao_num)] END_PROVIDER BEGIN_PROVIDER [ double precision, ao_pseudo_integrals_local, (ao_num,ao_num)] - use omp_lib implicit none BEGIN_DOC ! Local pseudo-potential @@ -43,6 +42,7 @@ BEGIN_PROVIDER [ double precision, ao_pseudo_integrals_local, (ao_num,ao_num)] double precision :: wall_1, wall_2, wall_0 integer :: thread_num + integer :: omp_get_thread_num double precision :: c double precision :: Z @@ -158,7 +158,6 @@ BEGIN_PROVIDER [ double precision, ao_pseudo_integrals_local, (ao_num,ao_num)] BEGIN_PROVIDER [ double precision, ao_pseudo_integrals_non_local, (ao_num,ao_num)] - use omp_lib implicit none BEGIN_DOC ! Non-local pseudo-potential @@ -170,6 +169,7 @@ BEGIN_PROVIDER [ double precision, ao_pseudo_integrals_local, (ao_num,ao_num)] integer :: power_A(3),power_B(3) integer :: i,j,k,l,m double precision :: Vloc, Vpseudo + integer :: omp_get_thread_num double precision :: wall_1, wall_2, wall_0 integer :: thread_num diff --git a/src/ao_two_e_ints/EZFIO.cfg b/src/ao_two_e_ints/EZFIO.cfg index b18c65d1..dfceddb5 100644 --- a/src/ao_two_e_ints/EZFIO.cfg +++ b/src/ao_two_e_ints/EZFIO.cfg @@ -4,13 +4,6 @@ doc: Read/Write |AO| integrals from/to disk [ Write | Read | None ] interface: ezfio,provider,ocaml default: None -[ao_integrals_threshold] -type: Threshold -doc: If | (pq|rs) | < `ao_integrals_threshold` then (pq|rs) is zero -interface: ezfio,provider,ocaml -default: 1.e-15 -ezfio_name: threshold_ao - [do_direct_integrals] type: logical doc: Compute integrals on the fly (very slow, only for debugging) diff --git a/src/ao_two_e_ints/gauss_legendre.irp.f b/src/ao_two_e_ints/gauss_legendre.irp.f deleted file mode 100644 index 4bdadb6e..00000000 --- a/src/ao_two_e_ints/gauss_legendre.irp.f +++ /dev/null @@ -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 - diff --git a/src/ao_two_e_ints/map_integrals.irp.f b/src/ao_two_e_ints/map_integrals.irp.f index c3b206e1..55b2d5e2 100644 --- a/src/ao_two_e_ints/map_integrals.irp.f +++ b/src/ao_two_e_ints/map_integrals.irp.f @@ -327,8 +327,6 @@ double precision function get_ao_two_e_integral(i,j,k,l,map) result(result) implicit none BEGIN_DOC ! Gets one AO bi-electronic integral from the AO map - ! - ! i,j,k,l in physicist notation END_DOC integer, intent(in) :: i,j,k,l integer(key_kind) :: idx diff --git a/src/ao_two_e_ints/test_cosgtos_1e.irp.f b/src/ao_two_e_ints/test_cosgtos_1e.irp.f new file mode 100644 index 00000000..9c1a7215 --- /dev/null +++ b/src/ao_two_e_ints/test_cosgtos_1e.irp.f @@ -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 + +! --- diff --git a/src/ao_two_e_ints/test_cosgtos_2e.irp.f b/src/ao_two_e_ints/test_cosgtos_2e.irp.f new file mode 100644 index 00000000..de991dd1 --- /dev/null +++ b/src/ao_two_e_ints/test_cosgtos_2e.irp.f @@ -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 + +! --- + + diff --git a/src/ao_two_e_ints/two_e_integrals.irp.f b/src/ao_two_e_ints/two_e_integrals.irp.f index 8032bd92..e60e6eeb 100644 --- a/src/ao_two_e_ints/two_e_integrals.irp.f +++ b/src/ao_two_e_ints/two_e_integrals.irp.f @@ -1,108 +1,132 @@ + +! --- + double precision function ao_two_e_integral(i,j,k,l) - implicit none + BEGIN_DOC ! integral of the AO basis or (ij|kl) ! i(r1) j(r1) 1/r12 k(r2) l(r2) END_DOC - integer,intent(in) :: i,j,k,l - integer :: p,q,r,s - double precision :: I_center(3),J_center(3),K_center(3),L_center(3) - integer :: num_i,num_j,num_k,num_l,dim1,I_power(3),J_power(3),K_power(3),L_power(3) - double precision :: integral + implicit none include 'utils/constants.include.F' + + integer, intent(in) :: i, j, k, l + + integer :: p, q, r, s + integer :: num_i,num_j,num_k,num_l,dim1,I_power(3),J_power(3),K_power(3),L_power(3) + integer :: iorder_p(3), iorder_q(3) + double precision :: I_center(3), J_center(3), K_center(3), L_center(3) + double precision :: integral double precision :: P_new(0:max_dim,3),P_center(3),fact_p,pp double precision :: Q_new(0:max_dim,3),Q_center(3),fact_q,qq - integer :: iorder_p(3), iorder_q(3) + double precision :: ao_two_e_integral_schwartz_accel - if (ao_prim_num(i) * ao_prim_num(j) * ao_prim_num(k) * ao_prim_num(l) > 1024 ) then - ao_two_e_integral = ao_two_e_integral_schwartz_accel(i,j,k,l) - else + double precision :: ao_two_e_integral_cosgtos - dim1 = n_pt_max_integrals - num_i = ao_nucl(i) - num_j = ao_nucl(j) - num_k = ao_nucl(k) - num_l = ao_nucl(l) - ao_two_e_integral = 0.d0 + if(use_cosgtos) then + !print *, ' use_cosgtos for ao_two_e_integral ?', use_cosgtos - if (num_i /= num_j .or. num_k /= num_l .or. num_j /= num_k)then - do p = 1, 3 - I_power(p) = ao_power(i,p) - J_power(p) = ao_power(j,p) - K_power(p) = ao_power(k,p) - L_power(p) = ao_power(l,p) - I_center(p) = nucl_coord(num_i,p) - J_center(p) = nucl_coord(num_j,p) - K_center(p) = nucl_coord(num_k,p) - L_center(p) = nucl_coord(num_l,p) - enddo + ao_two_e_integral = ao_two_e_integral_cosgtos(i,j,k,l) - double precision :: coef1, coef2, coef3, coef4 - double precision :: p_inv,q_inv - double precision :: general_primitive_integral + else - do p = 1, ao_prim_num(i) - coef1 = ao_coef_normalized_ordered_transp(p,i) - do q = 1, ao_prim_num(j) - coef2 = coef1*ao_coef_normalized_ordered_transp(q,j) - call give_explicit_poly_and_gaussian(P_new,P_center,pp,fact_p,iorder_p,& - ao_expo_ordered_transp(p,i),ao_expo_ordered_transp(q,j), & - I_power,J_power,I_center,J_center,dim1) - p_inv = 1.d0/pp - do r = 1, ao_prim_num(k) - coef3 = coef2*ao_coef_normalized_ordered_transp(r,k) - do s = 1, ao_prim_num(l) - coef4 = coef3*ao_coef_normalized_ordered_transp(s,l) - call give_explicit_poly_and_gaussian(Q_new,Q_center,qq,fact_q,iorder_q,& - ao_expo_ordered_transp(r,k),ao_expo_ordered_transp(s,l), & - K_power,L_power,K_center,L_center,dim1) - q_inv = 1.d0/qq - integral = general_primitive_integral(dim1, & - P_new,P_center,fact_p,pp,p_inv,iorder_p, & - Q_new,Q_center,fact_q,qq,q_inv,iorder_q) - ao_two_e_integral = ao_two_e_integral + coef4 * integral - enddo ! s - enddo ! r - enddo ! q - enddo ! p + if (ao_prim_num(i) * ao_prim_num(j) * ao_prim_num(k) * ao_prim_num(l) > 1024 ) then + + ao_two_e_integral = ao_two_e_integral_schwartz_accel(i,j,k,l) else - do p = 1, 3 - I_power(p) = ao_power(i,p) - J_power(p) = ao_power(j,p) - K_power(p) = ao_power(k,p) - L_power(p) = ao_power(l,p) - enddo - double precision :: ERI + dim1 = n_pt_max_integrals - do p = 1, ao_prim_num(i) - coef1 = ao_coef_normalized_ordered_transp(p,i) - do q = 1, ao_prim_num(j) - coef2 = coef1*ao_coef_normalized_ordered_transp(q,j) - do r = 1, ao_prim_num(k) - coef3 = coef2*ao_coef_normalized_ordered_transp(r,k) - do s = 1, ao_prim_num(l) - coef4 = coef3*ao_coef_normalized_ordered_transp(s,l) - integral = ERI( & - ao_expo_ordered_transp(p,i),ao_expo_ordered_transp(q,j),ao_expo_ordered_transp(r,k),ao_expo_ordered_transp(s,l),& - I_power(1),J_power(1),K_power(1),L_power(1), & - I_power(2),J_power(2),K_power(2),L_power(2), & - I_power(3),J_power(3),K_power(3),L_power(3)) - ao_two_e_integral = ao_two_e_integral + coef4 * integral - enddo ! s - enddo ! r - enddo ! q - enddo ! p + num_i = ao_nucl(i) + num_j = ao_nucl(j) + num_k = ao_nucl(k) + num_l = ao_nucl(l) + ao_two_e_integral = 0.d0 + + if (num_i /= num_j .or. num_k /= num_l .or. num_j /= num_k)then + do p = 1, 3 + I_power(p) = ao_power(i,p) + J_power(p) = ao_power(j,p) + K_power(p) = ao_power(k,p) + L_power(p) = ao_power(l,p) + I_center(p) = nucl_coord(num_i,p) + J_center(p) = nucl_coord(num_j,p) + K_center(p) = nucl_coord(num_k,p) + L_center(p) = nucl_coord(num_l,p) + enddo + + double precision :: coef1, coef2, coef3, coef4 + double precision :: p_inv,q_inv + double precision :: general_primitive_integral + + do p = 1, ao_prim_num(i) + coef1 = ao_coef_normalized_ordered_transp(p,i) + do q = 1, ao_prim_num(j) + coef2 = coef1*ao_coef_normalized_ordered_transp(q,j) + call give_explicit_poly_and_gaussian(P_new,P_center,pp,fact_p,iorder_p,& + ao_expo_ordered_transp(p,i),ao_expo_ordered_transp(q,j), & + I_power,J_power,I_center,J_center,dim1) + p_inv = 1.d0/pp + do r = 1, ao_prim_num(k) + coef3 = coef2*ao_coef_normalized_ordered_transp(r,k) + do s = 1, ao_prim_num(l) + coef4 = coef3*ao_coef_normalized_ordered_transp(s,l) + call give_explicit_poly_and_gaussian(Q_new,Q_center,qq,fact_q,iorder_q,& + ao_expo_ordered_transp(r,k),ao_expo_ordered_transp(s,l), & + K_power,L_power,K_center,L_center,dim1) + q_inv = 1.d0/qq + integral = general_primitive_integral(dim1, & + P_new,P_center,fact_p,pp,p_inv,iorder_p, & + Q_new,Q_center,fact_q,qq,q_inv,iorder_q) + ao_two_e_integral = ao_two_e_integral + coef4 * integral + enddo ! s + enddo ! r + enddo ! q + enddo ! p + + else + + do p = 1, 3 + I_power(p) = ao_power(i,p) + J_power(p) = ao_power(j,p) + K_power(p) = ao_power(k,p) + L_power(p) = ao_power(l,p) + enddo + double precision :: ERI + + do p = 1, ao_prim_num(i) + coef1 = ao_coef_normalized_ordered_transp(p,i) + do q = 1, ao_prim_num(j) + coef2 = coef1*ao_coef_normalized_ordered_transp(q,j) + do r = 1, ao_prim_num(k) + coef3 = coef2*ao_coef_normalized_ordered_transp(r,k) + do s = 1, ao_prim_num(l) + coef4 = coef3*ao_coef_normalized_ordered_transp(s,l) + integral = ERI( & + ao_expo_ordered_transp(p,i),ao_expo_ordered_transp(q,j),ao_expo_ordered_transp(r,k),ao_expo_ordered_transp(s,l),& + I_power(1),J_power(1),K_power(1),L_power(1), & + I_power(2),J_power(2),K_power(2),L_power(2), & + I_power(3),J_power(3),K_power(3),L_power(3)) + ao_two_e_integral = ao_two_e_integral + coef4 * integral + enddo ! s + enddo ! r + enddo ! q + enddo ! p + + endif endif endif + end +! --- + double precision function ao_two_e_integral_schwartz_accel(i,j,k,l) implicit none BEGIN_DOC @@ -575,7 +599,10 @@ double precision function general_primitive_integral(dim, & !DIR$ FORCEINLINE call multiply_poly(d_poly ,n_pt_tmp ,Iz_pol,n_Iz,d1,n_pt_out) double precision :: rint_sum + accu = accu + rint_sum(n_pt_out,const,d1) +! print *, n_pt_out, d1(0:n_pt_out) +! print *, accu general_primitive_integral = fact_p * fact_q * accu *pi_5_2*p_inv*q_inv/dsqrt(p+q) end @@ -840,6 +867,15 @@ subroutine give_polynom_mult_center_x(P_center,Q_center,a_x,d_x,p,q,n_pt_in,pq_i !DIR$ FORCEINLINE call I_x1_pol_mult(a_x,d_x,B10,B01,B00,C00,D00,d,n_pt1,n_pt_in) n_pt_out = n_pt1 + +! print *, ' ' +! print *, a_x, d_x +! print *, B10, B01, B00, C00, D00 +! print *, n_pt1, d(0:n_pt1) +! print *, ' ' + + + if(n_pt1<0)then n_pt_out = -1 do i = 0,n_pt_in diff --git a/src/basis/EZFIO.cfg b/src/basis/EZFIO.cfg index a6864418..7f2ede4c 100644 --- a/src/basis/EZFIO.cfg +++ b/src/basis/EZFIO.cfg @@ -37,16 +37,16 @@ doc: Number of primitives in a shell size: (basis.shell_num) interface: ezfio, provider -[shell_index] +[shell_prim_index] type: integer -doc: Index of the shell for each primitive -size: (basis.prim_num) +doc: Max number of primitives in a shell +size: (basis.shell_num) interface: ezfio, provider [basis_nucleus_index] type: integer -doc: Nucleus on which the shell is centered -size: (basis.shell_num) +doc: Index of the nucleus on which the shell is centered +size: (nuclei.nucl_num) interface: ezfio, provider [prim_normalization_factor] diff --git a/src/basis/basis.irp.f b/src/basis/basis.irp.f index b750d75a..6a406e28 100644 --- a/src/basis/basis.irp.f +++ b/src/basis/basis.irp.f @@ -30,10 +30,8 @@ BEGIN_PROVIDER [ double precision, shell_normalization_factor , (shell_num) ] powA(3) = 0 norm = 0.d0 - do k=1, prim_num - if (shell_index(k) /= i) cycle - do j=1, prim_num - if (shell_index(j) /= i) cycle + do k=shell_prim_index(i),shell_prim_index(i)+shell_prim_num(i)-1 + do j=shell_prim_index(i),shell_prim_index(i)+shell_prim_num(i)-1 call overlap_gaussian_xyz(C_A,C_A,prim_expo(j),prim_expo(k), & powA,powA,overlap_x,overlap_y,overlap_z,c,nz) norm = norm+c*prim_coef(j)*prim_coef(k) * prim_normalization_factor(j) * prim_normalization_factor(k) @@ -93,8 +91,7 @@ BEGIN_PROVIDER [ double precision, prim_normalization_factor , (prim_num) ] powA(2) = 0 powA(3) = 0 - do k=1, prim_num - if (shell_index(k) /= i) cycle + do k=shell_prim_index(i),shell_prim_index(i)+shell_prim_num(i)-1 call overlap_gaussian_xyz(C_A,C_A,prim_expo(k),prim_expo(k), & powA,powA,overlap_x,overlap_y,overlap_z,norm,nz) prim_normalization_factor(k) = 1.d0/dsqrt(norm) diff --git a/src/basis_correction/print_routine.irp.f b/src/basis_correction/print_routine.irp.f index 67c5c6c2..05fbbf60 100644 --- a/src/basis_correction/print_routine.irp.f +++ b/src/basis_correction/print_routine.irp.f @@ -38,7 +38,7 @@ subroutine print_basis_correction write(*, '(A29,X,I3,X,A3,X,F16.10)') ' ECMD PBE-UEG , state ',istate,' = ',ecmd_pbe_ueg_mu_of_r(istate) enddo - else if(mu_of_r_potential.EQ."cas_ful".or.mu_of_r_potential.EQ."cas_truncated".or.mu_of_r_potential.EQ."pure_act")then + else if(mu_of_r_potential.EQ."cas_ful")then print*, '' print*,'Using a CAS-like two-body density to define mu(r)' print*,'This assumes that the CAS is a qualitative representation of the wave function ' diff --git a/src/becke_numerical_grid/grid_becke_vector.irp.f b/src/becke_numerical_grid/grid_becke_vector.irp.f index 343bd054..a72200f7 100644 --- a/src/becke_numerical_grid/grid_becke_vector.irp.f +++ b/src/becke_numerical_grid/grid_becke_vector.irp.f @@ -58,17 +58,3 @@ END_PROVIDER enddo END_PROVIDER - -BEGIN_PROVIDER [double precision, final_grid_points_transp, (n_points_final_grid,3)] - implicit none - BEGIN_DOC -! Transposed final_grid_points - END_DOC - - integer :: i,j - do j=1,3 - do i=1,n_points_final_grid - final_grid_points_transp(i,j) = final_grid_points(j,i) - enddo - enddo -END_PROVIDER diff --git a/src/bitmask/bitmasks_routines.irp.f b/src/bitmask/bitmasks_routines.irp.f index 9c6f4f0c..c34d54dc 100644 --- a/src/bitmask/bitmasks_routines.irp.f +++ b/src/bitmask/bitmasks_routines.irp.f @@ -268,21 +268,6 @@ subroutine print_spindet(string,Nint) end -subroutine print_det_one_dimension(string,Nint) - use bitmasks - implicit none - BEGIN_DOC - ! Subroutine to print the content of a determinant using the '+-' notation - END_DOC - integer, intent(in) :: Nint - integer(bit_kind), intent(in) :: string(Nint) - character*(2048) :: output(1) - - call bitstring_to_str( output(1), string, Nint ) - print *, trim(output(1)) - -end - logical function is_integer_in_string(bite,string,Nint) use bitmasks implicit none diff --git a/src/cipsi/EZFIO.cfg b/src/cipsi/EZFIO.cfg index e01359c5..19b45ac1 100644 --- a/src/cipsi/EZFIO.cfg +++ b/src/cipsi/EZFIO.cfg @@ -1,3 +1,9 @@ +[pert_2rdm] +type: logical +doc: If true, computes the one- and two-body rdms with perturbation theory +interface: ezfio,provider,ocaml +default: False + [save_wf_after_selection] type: logical doc: If true, saves the wave function after the selection, before the diagonalization @@ -34,9 +40,3 @@ doc: Maximum number of excitation for beta determinants with respect to the Hart interface: ezfio,ocaml,provider default: -1 -[twice_hierarchy_max] -type: integer -doc: Twice the maximum hierarchy parameter (excitation degree plus half the seniority number). Using -1 selects all determinants -interface: ezfio,ocaml,provider -default: -1 - diff --git a/src/cipsi/NEED b/src/cipsi/NEED index 85d01f79..bfbc559a 100644 --- a/src/cipsi/NEED +++ b/src/cipsi/NEED @@ -2,4 +2,5 @@ perturbation zmq mpi iterations +two_body_rdm csf diff --git a/src/cipsi/cipsi.irp.f b/src/cipsi/cipsi.irp.f index da77a527..6e715531 100644 --- a/src/cipsi/cipsi.irp.f +++ b/src/cipsi/cipsi.irp.f @@ -70,8 +70,8 @@ subroutine run_cipsi do while ( & (N_det < N_det_max) .and. & - (sum(abs(pt2_data % pt2(1:N_states)) * state_average_weight(1:N_states)) > pt2_max) .and. & - (sum(abs(pt2_data % variance(1:N_states)) * state_average_weight(1:N_states)) > variance_max) .and. & + (maxval(abs(pt2_data % pt2(1:N_states))) > pt2_max) .and. & + (maxval(abs(pt2_data % variance(1:N_states))) > variance_max) .and. & (correlation_energy_ratio <= correlation_energy_ratio_max) & ) write(*,'(A)') '--------------------------------------------------------------------------------' diff --git a/src/cipsi/pert_rdm_providers.irp.f b/src/cipsi/pert_rdm_providers.irp.f new file mode 100644 index 00000000..eca8decc --- /dev/null +++ b/src/cipsi/pert_rdm_providers.irp.f @@ -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 + + diff --git a/src/cipsi/pt2_stoch_routines.irp.f b/src/cipsi/pt2_stoch_routines.irp.f index 1328e7a0..b366a268 100644 --- a/src/cipsi/pt2_stoch_routines.irp.f +++ b/src/cipsi/pt2_stoch_routines.irp.f @@ -117,6 +117,7 @@ subroutine ZMQ_pt2(E, pt2_data, pt2_data_err, relative_error, N_in) integer(ZMQ_PTR) :: zmq_to_qp_run_socket, zmq_socket_pull integer, intent(in) :: N_in +! integer, intent(inout) :: N_in double precision, intent(in) :: relative_error, E(N_states) type(pt2_type), intent(inout) :: pt2_data, pt2_data_err ! @@ -131,8 +132,8 @@ subroutine ZMQ_pt2(E, pt2_data, pt2_data_err, relative_error, N_in) PROVIDE psi_bilinear_matrix_transp_rows_loc psi_bilinear_matrix_transp_columns PROVIDE psi_bilinear_matrix_transp_order psi_selectors_coef_transp psi_det_sorted PROVIDE psi_det_hii selection_weight pseudo_sym - PROVIDE list_act list_inact list_core list_virt list_del seniority_max - PROVIDE excitation_beta_max excitation_alpha_max excitation_max + PROVIDE n_act_orb n_inact_orb n_core_orb n_virt_orb n_del_orb seniority_max + PROVIDE pert_2rdm excitation_beta_max excitation_alpha_max excitation_max if (h0_type == 'CFG') then PROVIDE psi_configuration_hii det_to_configuration @@ -287,16 +288,12 @@ subroutine ZMQ_pt2(E, pt2_data, pt2_data_err, relative_error, N_in) call write_int(6,nproc_target,'Number of threads for PT2') call write_double(6,mem,'Memory (Gb)') - call set_multiple_levels_omp(.False.) + call omp_set_max_active_levels(1) - ! old - !print '(A)', '========== ======================= ===================== ===================== ===========' - !print '(A)', ' Samples Energy Variance Norm^2 Seconds' - !print '(A)', '========== ======================= ===================== ===================== ===========' - print '(A)', '========== ==================== ================ ================ ================ ============= ===========' - print '(A)', ' Samples Energy PT2 Variance Norm^2 Convergence Seconds' - print '(A)', '========== ==================== ================ ================ ================ ============= ===========' + print '(A)', '========== ======================= ===================== ===================== ===========' + print '(A)', ' Samples Energy Variance Norm^2 Seconds' + print '(A)', '========== ======================= ===================== ===================== ===========' PROVIDE global_selection_buffer @@ -318,17 +315,14 @@ subroutine ZMQ_pt2(E, pt2_data, pt2_data_err, relative_error, N_in) endif !$OMP END PARALLEL call end_parallel_job(zmq_to_qp_run_socket, zmq_socket_pull, 'pt2') - call set_multiple_levels_omp(.True.) + call omp_set_max_active_levels(8) - ! old - !print '(A)', '========== ======================= ===================== ===================== ===========' - print '(A)', '========== ==================== ================ ================ ================ ============= ===========' + print '(A)', '========== ======================= ===================== ===================== ===========' - - do k=1,N_states - pt2_overlap(pt2_stoch_istate,k) = pt2_data % overlap(k,pt2_stoch_istate) - enddo - SOFT_TOUCH pt2_overlap + do k=1,N_states + pt2_overlap(pt2_stoch_istate,k) = pt2_data % overlap(k,pt2_stoch_istate) + enddo + SOFT_TOUCH pt2_overlap enddo FREE pt2_stoch_istate @@ -421,17 +415,6 @@ subroutine pt2_collector(zmq_socket_pull, E, relative_error, pt2_data, pt2_data_ double precision :: rss double precision, external :: memory_of_double, memory_of_int - character(len=20) :: format_str1, str_error1, format_str2, str_error2 - character(len=20) :: format_str3, str_error3, format_str4, str_error4 - character(len=20) :: format_value1, format_value2, format_value3, format_value4 - character(len=20) :: str_value1, str_value2, str_value3, str_value4 - character(len=20) :: str_conv - double precision :: value1, value2, value3, value4 - double precision :: error1, error2, error3, error4 - integer :: size1,size2,size3,size4 - - double precision :: conv_crit - sending =.False. rss = memory_of_int(pt2_n_tasks_max*2+N_det_generators*2) @@ -541,74 +524,28 @@ subroutine pt2_collector(zmq_socket_pull, E, relative_error, pt2_data, pt2_data_ ! 1/(N-1.5) : see Brugger, The American Statistician (23) 4 p. 32 (1969) if(c > 2) then eqt = dabs((pt2_data_S2(t) % pt2(pt2_stoch_istate) / c) - (pt2_data_S(t) % pt2(pt2_stoch_istate)/c)**2) ! dabs for numerical stability - eqt = dsqrt(eqt / (dble(c) - 1.5d0)) + eqt = sqrt(eqt / (dble(c) - 1.5d0)) pt2_data_err % pt2(pt2_stoch_istate) = eqt eqt = dabs((pt2_data_S2(t) % variance(pt2_stoch_istate) / c) - (pt2_data_S(t) % variance(pt2_stoch_istate)/c)**2) ! dabs for numerical stability - eqt = dsqrt(eqt / (dble(c) - 1.5d0)) + eqt = sqrt(eqt / (dble(c) - 1.5d0)) pt2_data_err % variance(pt2_stoch_istate) = eqt eqta(:) = dabs((pt2_data_S2(t) % overlap(:,pt2_stoch_istate) / c) - (pt2_data_S(t) % overlap(:,pt2_stoch_istate)/c)**2) ! dabs for numerical stability - eqta(:) = dsqrt(eqta(:) / (dble(c) - 1.5d0)) + eqta(:) = sqrt(eqta(:) / (dble(c) - 1.5d0)) pt2_data_err % overlap(:,pt2_stoch_istate) = eqta(:) if ((time - time1 > 1.d0) .or. (n==N_det_generators)) then time1 = time - - value1 = pt2_data % pt2(pt2_stoch_istate) + E - error1 = pt2_data_err % pt2(pt2_stoch_istate) - value2 = pt2_data % pt2(pt2_stoch_istate) - error2 = pt2_data_err % pt2(pt2_stoch_istate) - value3 = pt2_data % variance(pt2_stoch_istate) - error3 = pt2_data_err % variance(pt2_stoch_istate) - value4 = pt2_data % overlap(pt2_stoch_istate,pt2_stoch_istate) - error4 = pt2_data_err % overlap(pt2_stoch_istate,pt2_stoch_istate) - - ! Max size of the values (FX.Y) with X=size - size1 = 15 - size2 = 12 - size3 = 12 - size4 = 12 - - ! To generate the format: number(error) - call format_w_error(value1,error1,size1,8,format_value1,str_error1) - call format_w_error(value2,error2,size2,8,format_value2,str_error2) - call format_w_error(value3,error3,size3,8,format_value3,str_error3) - call format_w_error(value4,error4,size4,8,format_value4,str_error4) - - ! value > string with the right format - write(str_value1,'('//format_value1//')') value1 - write(str_value2,'('//format_value2//')') value2 - write(str_value3,'('//format_value3//')') value3 - write(str_value4,'('//format_value4//')') value4 - - ! Convergence criterion - conv_crit = dabs(pt2_data_err % pt2(pt2_stoch_istate)) / & - (1.d-20 + dabs(pt2_data % pt2(pt2_stoch_istate)) ) - write(str_conv,'(G10.3)') conv_crit - - write(*,'(I10,X,X,A20,X,A16,X,A16,X,A16,X,A12,X,F10.1)') c,& - adjustl(adjustr(str_value1)//'('//str_error1(1:1)//')'),& - adjustl(adjustr(str_value2)//'('//str_error2(1:1)//')'),& - adjustl(adjustr(str_value3)//'('//str_error3(1:1)//')'),& - adjustl(adjustr(str_value4)//'('//str_error4(1:1)//')'),& - adjustl(str_conv),& - time-time0 - - ! Old print - !print '(I10, X, F12.6, X, G10.3, X, F10.6, X, G10.3, X, F10.6, X, G10.3, X, F10.1,1pE16.6,1pE16.6)', c, & - ! pt2_data % pt2(pt2_stoch_istate) +E, & - ! pt2_data_err % pt2(pt2_stoch_istate), & - ! pt2_data % variance(pt2_stoch_istate), & - ! pt2_data_err % variance(pt2_stoch_istate), & - ! pt2_data % overlap(pt2_stoch_istate,pt2_stoch_istate), & - ! pt2_data_err % overlap(pt2_stoch_istate,pt2_stoch_istate), & - ! time-time0, & - ! pt2_data % pt2(pt2_stoch_istate), & - ! dabs(pt2_data_err % pt2(pt2_stoch_istate)) / & - ! (1.d-20 + dabs(pt2_data % pt2(pt2_stoch_istate)) ) - + print '(I10, X, F12.6, X, G10.3, X, F10.6, X, G10.3, X, F10.6, X, G10.3, X, F10.4)', c, & + pt2_data % pt2(pt2_stoch_istate) +E, & + pt2_data_err % pt2(pt2_stoch_istate), & + pt2_data % variance(pt2_stoch_istate), & + pt2_data_err % variance(pt2_stoch_istate), & + pt2_data % overlap(pt2_stoch_istate,pt2_stoch_istate), & + pt2_data_err % overlap(pt2_stoch_istate,pt2_stoch_istate), & + time-time0 if (stop_now .or. ( & (do_exit .and. (dabs(pt2_data_err % pt2(pt2_stoch_istate)) / & (1.d-20 + dabs(pt2_data % pt2(pt2_stoch_istate)) ) <= relative_error))) ) then @@ -639,11 +576,11 @@ subroutine pt2_collector(zmq_socket_pull, E, relative_error, pt2_data, pt2_data_ endif do i=1,n_tasks if(index(i).gt.size(pt2_data_I,1).or.index(i).lt.1)then - print*,'PB !!!' - print*,'If you see this, send a bug report with the following content' - print*,irp_here - print*,'i,index(i),size(pt2_data_I,1) = ',i,index(i),size(pt2_data_I,1) - stop -1 + print*,'PB !!!' + print*,'If you see this, send a bug report with the following content' + print*,irp_here + print*,'i,index(i),size(pt2_data_I,1) = ',i,index(i),size(pt2_data_I,1) + stop -1 endif call pt2_add(pt2_data_I(index(i)),1.d0,pt2_data_task(i)) f(index(i)) -= 1 @@ -906,8 +843,9 @@ END_PROVIDER do t=1, pt2_N_teeth tooth_width = tilde_cW(pt2_n_0(t+1)) - tilde_cW(pt2_n_0(t)) if (tooth_width == 0.d0) then - tooth_width = max(1.d-15,sum(tilde_w(pt2_n_0(t):pt2_n_0(t+1)))) + tooth_width = sum(tilde_w(pt2_n_0(t):pt2_n_0(t+1))) endif + ASSERT(tooth_width > 0.d0) do i=pt2_n_0(t)+1, pt2_n_0(t+1) pt2_w(i) = tilde_w(i) * pt2_W_T / tooth_width end do diff --git a/src/cipsi/run_pt2_slave.irp.f b/src/cipsi/run_pt2_slave.irp.f index 30fc7ce0..a72d3dbb 100644 --- a/src/cipsi/run_pt2_slave.irp.f +++ b/src/cipsi/run_pt2_slave.irp.f @@ -31,11 +31,12 @@ subroutine run_pt2_slave(thread,iproc,energy) double precision, intent(in) :: energy(N_states_diag) integer, intent(in) :: thread, iproc - if (N_det > 100000 ) then - call run_pt2_slave_large(thread,iproc,energy) - else - call run_pt2_slave_small(thread,iproc,energy) - endif + call run_pt2_slave_large(thread,iproc,energy) +! if (N_det > nproc*(elec_alpha_num * (mo_num-elec_alpha_num))**2) then +! call run_pt2_slave_large(thread,iproc,energy) +! else +! call run_pt2_slave_small(thread,iproc,energy) +! endif end subroutine run_pt2_slave_small(thread,iproc,energy) @@ -66,6 +67,7 @@ subroutine run_pt2_slave_small(thread,iproc,energy) double precision, external :: memory_of_double, memory_of_int integer :: bsize ! Size of selection buffers +! logical :: sending allocate(task_id(pt2_n_tasks_max), task(pt2_n_tasks_max)) allocate(pt2_data(pt2_n_tasks_max), i_generator(pt2_n_tasks_max), subset(pt2_n_tasks_max)) @@ -83,6 +85,7 @@ subroutine run_pt2_slave_small(thread,iproc,energy) buffer_ready = .False. n_tasks = 1 +! sending = .False. done = .False. do while (.not.done) @@ -116,13 +119,14 @@ subroutine run_pt2_slave_small(thread,iproc,energy) do k=1,n_tasks call pt2_alloc(pt2_data(k),N_states) b%cur = 0 -! double precision :: time2 -! call wall_time(time2) +!double precision :: time2 +!call wall_time(time2) call select_connected(i_generator(k),energy,pt2_data(k),b,subset(k),pt2_F(i_generator(k))) -! call wall_time(time1) -! print *, i_generator(1), time1-time2, n_tasks, pt2_F(i_generator(1)) +!call wall_time(time1) +!print *, i_generator(1), time1-time2, n_tasks, pt2_F(i_generator(1)) enddo call wall_time(time1) +!print *, '-->', i_generator(1), time1-time0, n_tasks integer, external :: tasks_done_to_taskserver if (tasks_done_to_taskserver(zmq_to_qp_run_socket,worker_id,task_id,n_tasks) == -1) then @@ -160,11 +164,6 @@ end subroutine subroutine run_pt2_slave_large(thread,iproc,energy) use selection_types use f77_zmq - BEGIN_DOC -! This subroutine can miss important determinants when the PT2 is completely -! computed. It should be called only for large workloads where the PT2 is -! interrupted before the end - END_DOC implicit none double precision, intent(in) :: energy(N_states_diag) @@ -190,12 +189,8 @@ subroutine run_pt2_slave_large(thread,iproc,energy) integer :: bsize ! Size of selection buffers logical :: sending - double precision :: time_shift - PROVIDE global_selection_buffer global_selection_buffer_lock - call random_number(time_shift) - time_shift = time_shift*15.d0 zmq_to_qp_run_socket = new_zmq_to_qp_run_socket() @@ -213,9 +208,6 @@ subroutine run_pt2_slave_large(thread,iproc,energy) sending = .False. done = .False. - double precision :: time0, time1 - call wall_time(time0) - time0 = time0+time_shift do while (.not.done) integer, external :: get_tasks_from_taskserver @@ -242,28 +234,25 @@ subroutine run_pt2_slave_large(thread,iproc,energy) ASSERT (b%N == bsize) endif + double precision :: time0, time1 + call wall_time(time0) call pt2_alloc(pt2_data,N_states) b%cur = 0 call select_connected(i_generator,energy,pt2_data,b,subset,pt2_F(i_generator)) + call wall_time(time1) integer, external :: tasks_done_to_taskserver if (tasks_done_to_taskserver(zmq_to_qp_run_socket,worker_id,task_id,n_tasks) == -1) then done = .true. endif call sort_selection_buffer(b) - - call wall_time(time1) -! if (time1-time0 > 15.d0) then - call omp_set_lock(global_selection_buffer_lock) - global_selection_buffer%mini = b%mini - call merge_selection_buffers(b,global_selection_buffer) - b%cur=0 - call omp_unset_lock(global_selection_buffer_lock) - call wall_time(time0) -! endif - call push_pt2_results_async_recv(zmq_socket_push,b%mini,sending) - if ( iproc == 1 .or. i_generator < 100 .or. done) then + call omp_set_lock(global_selection_buffer_lock) + global_selection_buffer%mini = b%mini + call merge_selection_buffers(b,global_selection_buffer) + b%cur=0 + call omp_unset_lock(global_selection_buffer_lock) + if ( iproc == 1 ) then call omp_set_lock(global_selection_buffer_lock) call push_pt2_results_async_send(zmq_socket_push, (/i_generator/), (/pt2_data/), global_selection_buffer, (/task_id/), 1,sending) global_selection_buffer%cur = 0 diff --git a/src/cipsi/run_selection_slave.irp.f b/src/cipsi/run_selection_slave.irp.f index de7c209c..91bd3a38 100644 --- a/src/cipsi/run_selection_slave.irp.f +++ b/src/cipsi/run_selection_slave.irp.f @@ -61,14 +61,10 @@ subroutine run_selection_slave(thread,iproc,energy) if (N /= buf%N) then print *, 'N=', N print *, 'buf%N=', buf%N - print *, 'In ', irp_here, ': N /= buf%N' - stop -1 + print *, 'bug in ', irp_here + stop '-1' end if end if - if (i_generator > N_det_generators) then - print *, 'In ', irp_here, ': i_generator > N_det_generators' - stop -1 - endif call select_connected(i_generator,energy,pt2_data,buf,subset,pt2_F(i_generator)) endif diff --git a/src/cipsi/selection.irp.f b/src/cipsi/selection.irp.f index ec60c606..eda9642c 100644 --- a/src/cipsi/selection.irp.f +++ b/src/cipsi/selection.irp.f @@ -195,10 +195,7 @@ subroutine select_singles_and_doubles(i_generator,hole_mask,particle_mask,fock_d integer :: l_a, nmax, idx integer, allocatable :: indices(:), exc_degree(:), iorder(:) - - ! Removed to avoid introducing determinants already presents in the wf - !double precision, parameter :: norm_thr = 1.d-16 - + double precision, parameter :: norm_thr = 1.d-16 allocate (indices(N_det), & exc_degree(max(N_det_alpha_unique,N_det_beta_unique))) @@ -218,11 +215,10 @@ subroutine select_singles_and_doubles(i_generator,hole_mask,particle_mask,fock_d i = psi_bilinear_matrix_rows(l_a) if (nt + exc_degree(i) <= 4) then idx = psi_det_sorted_order(psi_bilinear_matrix_order(l_a)) - ! Removed to avoid introducing determinants already presents in the wf - !if (psi_average_norm_contrib_sorted(idx) > norm_thr) then + if (psi_average_norm_contrib_sorted(idx) > norm_thr) then indices(k) = idx k=k+1 - !endif + endif endif enddo enddo @@ -246,11 +242,10 @@ subroutine select_singles_and_doubles(i_generator,hole_mask,particle_mask,fock_d idx = psi_det_sorted_order( & psi_bilinear_matrix_order( & psi_bilinear_matrix_transp_order(l_a))) - ! Removed to avoid introducing determinants already presents in the wf - !if (psi_average_norm_contrib_sorted(idx) > norm_thr) then + if (psi_average_norm_contrib_sorted(idx) > norm_thr) then indices(k) = idx k=k+1 - !endif + endif endif enddo enddo @@ -258,6 +253,8 @@ subroutine select_singles_and_doubles(i_generator,hole_mask,particle_mask,fock_d deallocate(exc_degree) nmax=k-1 + call isort_noidx(indices,nmax) + ! Start with 32 elements. Size will double along with the filtering. allocate(preinteresting(0:32), prefullinteresting(0:32), & interesting(0:32), fullinteresting(0:32)) @@ -467,21 +464,27 @@ subroutine select_singles_and_doubles(i_generator,hole_mask,particle_mask,fock_d allocate (fullminilist (N_int, 2, fullinteresting(0)), & minilist (N_int, 2, interesting(0)) ) -! if(pert_2rdm)then -! allocate(coef_fullminilist_rev(N_states,fullinteresting(0))) -! do i=1,fullinteresting(0) -! do j = 1, N_states -! coef_fullminilist_rev(j,i) = psi_coef_sorted(fullinteresting(i),j) -! enddo -! enddo -! endif + if(pert_2rdm)then + allocate(coef_fullminilist_rev(N_states,fullinteresting(0))) + do i=1,fullinteresting(0) + do j = 1, N_states + coef_fullminilist_rev(j,i) = psi_coef_sorted(fullinteresting(i),j) + enddo + enddo + endif do i=1,fullinteresting(0) - fullminilist(:,:,i) = psi_det_sorted(:,:,fullinteresting(i)) + do k=1,N_int + fullminilist(k,1,i) = psi_det_sorted(k,1,fullinteresting(i)) + fullminilist(k,2,i) = psi_det_sorted(k,2,fullinteresting(i)) + enddo enddo do i=1,interesting(0) - minilist(:,:,i) = psi_det_sorted(:,:,interesting(i)) + do k=1,N_int + minilist(k,1,i) = psi_det_sorted(k,1,interesting(i)) + minilist(k,2,i) = psi_det_sorted(k,2,interesting(i)) + enddo enddo do s2=s1,2 @@ -528,19 +531,19 @@ subroutine select_singles_and_doubles(i_generator,hole_mask,particle_mask,fock_d call splash_pq(mask, sp, minilist, i_generator, interesting(0), bannedOrb, banned, mat, interesting) -! if(.not.pert_2rdm)then + if(.not.pert_2rdm)then call fill_buffer_double(i_generator, sp, h1, h2, bannedOrb, banned, fock_diag_tmp, E0, pt2_data, mat, buf) -! else -! call fill_buffer_double_rdm(i_generator, sp, h1, h2, bannedOrb, banned, fock_diag_tmp, E0, pt2_data, mat, buf,fullminilist, coef_fullminilist_rev, fullinteresting(0)) -! endif + else + call fill_buffer_double_rdm(i_generator, sp, h1, h2, bannedOrb, banned, fock_diag_tmp, E0, pt2_data, mat, buf,fullminilist, coef_fullminilist_rev, fullinteresting(0)) + endif end if enddo if(s1 /= s2) monoBdo = .false. enddo deallocate(fullminilist,minilist) -! if(pert_2rdm)then -! deallocate(coef_fullminilist_rev) -! endif + if(pert_2rdm)then + deallocate(coef_fullminilist_rev) + endif enddo enddo deallocate(preinteresting, prefullinteresting, interesting, fullinteresting) @@ -569,7 +572,6 @@ subroutine fill_buffer_double(i_generator, sp, h1, h2, bannedOrb, banned, fock_d double precision, external :: diag_H_mat_elem_fock double precision :: E_shift double precision :: s_weight(N_states,N_states) - logical, external :: is_in_wavefunction PROVIDE dominant_dets_of_cfgs N_dominant_dets_of_cfgs do jstate=1,N_states do istate=1,N_states @@ -711,25 +713,6 @@ subroutine fill_buffer_double(i_generator, sp, h1, h2, bannedOrb, banned, fock_d if (do_cycle) cycle endif - if (twice_hierarchy_max >= 0) then - s = 0 - do k=1,N_int - s = s + popcnt(ieor(det(k,1),det(k,2))) - enddo - if ( mod(s,2)>0 ) stop 'For now, hierarchy CI is defined only for an even number of electrons' - if (excitation_ref == 1) then - call get_excitation_degree(HF_bitmask,det(1,1),degree,N_int) - else if (excitation_ref == 2) then - stop 'For now, hierarchy CI is defined only for a single reference determinant' -! do k=1,N_dominant_dets_of_cfgs -! call get_excitation_degree(dominant_dets_of_cfgs(1,1,k),det(1,1),degree,N_int) -! enddo - endif - integer :: twice_hierarchy - twice_hierarchy = degree + s/2 - if (twice_hierarchy > twice_hierarchy_max) cycle - endif - Hii = diag_H_mat_elem_fock(psi_det_generators(1,1,i_generator),det,fock_diag_tmp,N_int) w = 0d0 @@ -800,9 +783,7 @@ subroutine fill_buffer_double(i_generator, sp, h1, h2, bannedOrb, banned, fock_d alpha_h_psi = mat(istate, p1, p2) - do k=1,N_states - pt2_data % overlap(k,istate) = pt2_data % overlap(k,istate) + coef(k) * coef(istate) - end do + pt2_data % overlap(:,istate) = pt2_data % overlap(:,istate) + coef(:) * coef(istate) pt2_data % variance(istate) = pt2_data % variance(istate) + alpha_h_psi * alpha_h_psi pt2_data % pt2(istate) = pt2_data % pt2(istate) + e_pert(istate) @@ -853,27 +834,8 @@ subroutine fill_buffer_double(i_generator, sp, h1, h2, bannedOrb, banned, fock_d endif end select - - ! To force the inclusion of determinants with a positive pt2 contribution - if (e_pert(istate) > 1d-8) then - w = -huge(1.0) - endif - end do -!!!BEGIN_DEBUG -! ! To check if the pt2 is taking determinants already in the wf -! if (is_in_wavefunction(det(N_int,1),N_int)) then -! print*, 'A determinant contributing to the pt2 is already in' -! print*, 'the wave function:' -! call print_det(det(N_int,1),N_int) -! print*,'contribution to the pt2 for the states:', e_pert(:) -! print*,'error in the filtering in' -! print*, 'cipsi/selection.irp.f sub: selecte_singles_and_doubles' -! print*, 'abort' -! call abort -! endif -!!!END_DEBUG integer(bit_kind) :: occ(N_int,2), n if (h0_type == 'CFG') then @@ -1594,7 +1556,7 @@ subroutine bitstring_to_list_in_selection( string, list, n_elements, Nint) use bitmasks implicit none BEGIN_DOC - ! Gives the indices(+1) of the bits set to 1 in the bit string + ! Gives the inidices(+1) of the bits set to 1 in the bit string END_DOC integer, intent(in) :: Nint integer(bit_kind), intent(in) :: string(Nint) diff --git a/src/cipsi/selection_buffer.irp.f b/src/cipsi/selection_buffer.irp.f index 1f743e0e..10132086 100644 --- a/src/cipsi/selection_buffer.irp.f +++ b/src/cipsi/selection_buffer.irp.f @@ -60,7 +60,6 @@ subroutine add_to_selection_buffer(b, det, val) b%val(b%cur) = val if(b%cur == size(b%val)) then call sort_selection_buffer(b) - b%cur = b%cur-1 end if end if end subroutine @@ -87,56 +86,43 @@ subroutine merge_selection_buffers(b1, b2) double precision :: rss double precision, external :: memory_of_double sze = max(size(b1%val), size(b2%val)) -! rss = memory_of_double(sze) + 2*N_int*memory_of_double(sze) -! call check_mem(rss,irp_here) + rss = memory_of_double(sze) + 2*N_int*memory_of_double(sze) + call check_mem(rss,irp_here) allocate(val(sze), detmp(N_int, 2, sze)) i1=1 i2=1 - - select case (N_int) -BEGIN_TEMPLATE - case $case - do i=1,nmwen - if ( (i1 > b1%cur).and.(i2 > b2%cur) ) then - exit - else if (i1 > b1%cur) then - val(i) = b2%val(i2) - detmp(1:$N_int,1,i) = b2%det(1:$N_int,1,i2) - detmp(1:$N_int,2,i) = b2%det(1:$N_int,2,i2) - i2=i2+1 - else if (i2 > b2%cur) then - val(i) = b1%val(i1) - detmp(1:$N_int,1,i) = b1%det(1:$N_int,1,i1) - detmp(1:$N_int,2,i) = b1%det(1:$N_int,2,i1) - i1=i1+1 + do i=1,nmwen + if ( (i1 > b1%cur).and.(i2 > b2%cur) ) then + exit + else if (i1 > b1%cur) then + val(i) = b2%val(i2) + detmp(1:N_int,1,i) = b2%det(1:N_int,1,i2) + detmp(1:N_int,2,i) = b2%det(1:N_int,2,i2) + i2=i2+1 + else if (i2 > b2%cur) then + val(i) = b1%val(i1) + detmp(1:N_int,1,i) = b1%det(1:N_int,1,i1) + detmp(1:N_int,2,i) = b1%det(1:N_int,2,i1) + i1=i1+1 + else + if (b1%val(i1) <= b2%val(i2)) then + val(i) = b1%val(i1) + detmp(1:N_int,1,i) = b1%det(1:N_int,1,i1) + detmp(1:N_int,2,i) = b1%det(1:N_int,2,i1) + i1=i1+1 else - if (b1%val(i1) <= b2%val(i2)) then - val(i) = b1%val(i1) - detmp(1:$N_int,1,i) = b1%det(1:$N_int,1,i1) - detmp(1:$N_int,2,i) = b1%det(1:$N_int,2,i1) - i1=i1+1 - else - val(i) = b2%val(i2) - detmp(1:$N_int,1,i) = b2%det(1:$N_int,1,i2) - detmp(1:$N_int,2,i) = b2%det(1:$N_int,2,i2) - i2=i2+1 - endif + val(i) = b2%val(i2) + detmp(1:N_int,1,i) = b2%det(1:N_int,1,i2) + detmp(1:N_int,2,i) = b2%det(1:N_int,2,i2) + i2=i2+1 endif - enddo - do i=nmwen+1,b2%N - val(i) = 0.d0 -! detmp(1:$N_int,1,i) = 0_bit_kind -! detmp(1:$N_int,2,i) = 0_bit_kind - enddo -SUBST [ case, N_int ] -(1); 1;; -(2); 2;; -(3); 3;; -(4); 4;; -default; N_int;; -END_TEMPLATE - end select + endif + enddo deallocate(b2%det, b2%val) + do i=nmwen+1,b2%N + val(i) = 0.d0 + detmp(1:N_int,1:2,i) = 0_bit_kind + enddo b2%det => detmp b2%val => val b2%mini = min(b2%mini,b2%val(b2%N)) @@ -158,8 +144,8 @@ subroutine sort_selection_buffer(b) double precision :: rss double precision, external :: memory_of_double, memory_of_int -! rss = memory_of_int(b%cur) + 2*N_int*memory_of_double(size(b%det,3)) -! call check_mem(rss,irp_here) + rss = memory_of_int(b%cur) + 2*N_int*memory_of_double(size(b%det,3)) + call check_mem(rss,irp_here) allocate(iorder(b%cur), detmp(N_int, 2, size(b%det,3))) do i=1,b%cur iorder(i) = i @@ -239,14 +225,14 @@ subroutine make_selection_buffer_s2(b) endif dup = .True. do k=1,N_int - if ( (tmp_array(k,1,i) /= tmp_array(k,1,j)) .or. & - (tmp_array(k,2,i) /= tmp_array(k,2,j)) ) then + if ( (tmp_array(k,1,i) /= tmp_array(k,1,j)) & + .or. (tmp_array(k,2,i) /= tmp_array(k,2,j)) ) then dup = .False. exit endif enddo if (dup) then - val(i) = min(val(i), val(j)) + val(i) = max(val(i), val(j)) duplicate(j) = .True. endif j+=1 @@ -296,6 +282,9 @@ subroutine make_selection_buffer_s2(b) call configuration_to_dets_size(o(1,1,i),sze,elec_alpha_num,N_int) n_d = n_d + sze if (n_d > b%cur) then +! if (n_d - b%cur > b%cur - n_d + sze) then +! n_d = n_d - sze +! endif exit endif enddo @@ -340,11 +329,10 @@ subroutine remove_duplicates_in_selection_buffer(b) integer(bit_kind), allocatable :: tmp_array(:,:,:) logical, allocatable :: duplicate(:) + n_d = b%cur logical :: found_duplicates double precision :: rss double precision, external :: memory_of_double - - n_d = b%cur rss = (4*N_int+4)*memory_of_double(n_d) call check_mem(rss,irp_here) diff --git a/src/cipsi/selection_weight.irp.f b/src/cipsi/selection_weight.irp.f index 756c65a1..3c09e59a 100644 --- a/src/cipsi/selection_weight.irp.f +++ b/src/cipsi/selection_weight.irp.f @@ -38,11 +38,11 @@ subroutine update_pt2_and_variance_weights(pt2_data, N_st) avg = sum(pt2(1:N_st)) / dble(N_st) + 1.d-32 ! Avoid future division by zero - dt = 4.d0 !* selection_factor + dt = 8.d0 !* selection_factor do k=1,N_st - element = pt2(k) !exp(dt*(pt2(k)/avg - 1.d0)) -! element = min(2.0d0 , element) -! element = max(0.5d0 , element) + element = exp(dt*(pt2(k)/avg - 1.d0)) + element = min(2.0d0 , element) + element = max(0.5d0 , element) pt2_match_weight(k) *= element enddo @@ -50,9 +50,9 @@ subroutine update_pt2_and_variance_weights(pt2_data, N_st) avg = sum(variance(1:N_st)) / dble(N_st) + 1.d-32 ! Avoid future division by zero do k=1,N_st - element = variance(k) ! exp(dt*(variance(k)/avg -1.d0)) -! element = min(2.0d0 , element) -! element = max(0.5d0 , element) + element = exp(dt*(variance(k)/avg -1.d0)) + element = min(2.0d0 , element) + element = max(0.5d0 , element) variance_match_weight(k) *= element enddo @@ -62,9 +62,6 @@ subroutine update_pt2_and_variance_weights(pt2_data, N_st) variance_match_weight(:) = 1.d0 endif - pt2_match_weight(:) = pt2_match_weight(:)/sum(pt2_match_weight(:)) - variance_match_weight(:) = variance_match_weight(:)/sum(variance_match_weight(:)) - threshold_davidson_pt2 = min(1.d-6, & max(threshold_davidson, 1.e-1 * PT2_relative_error * minval(abs(pt2(1:N_states)))) ) @@ -90,7 +87,7 @@ BEGIN_PROVIDER [ double precision, selection_weight, (N_states) ] selection_weight(1:N_states) = c0_weight(1:N_states) case (2) - print *, 'Using PT2-matching weight in selection' + print *, 'Using pt2-matching weight in selection' selection_weight(1:N_states) = c0_weight(1:N_states) * pt2_match_weight(1:N_states) print *, '# PT2 weight ', real(pt2_match_weight(:),4) @@ -100,7 +97,7 @@ BEGIN_PROVIDER [ double precision, selection_weight, (N_states) ] print *, '# var weight ', real(variance_match_weight(:),4) case (4) - print *, 'Using variance- and PT2-matching weights in selection' + print *, 'Using variance- and pt2-matching weights in selection' selection_weight(1:N_states) = c0_weight(1:N_states) * sqrt(variance_match_weight(1:N_states) * pt2_match_weight(1:N_states)) print *, '# PT2 weight ', real(pt2_match_weight(:),4) print *, '# var weight ', real(variance_match_weight(:),4) @@ -115,7 +112,7 @@ BEGIN_PROVIDER [ double precision, selection_weight, (N_states) ] selection_weight(1:N_states) = c0_weight(1:N_states) case (7) - print *, 'Input weights multiplied by variance- and PT2-matching' + print *, 'Input weights multiplied by variance- and pt2-matching' selection_weight(1:N_states) = c0_weight(1:N_states) * sqrt(variance_match_weight(1:N_states) * pt2_match_weight(1:N_states)) * state_average_weight(1:N_states) print *, '# PT2 weight ', real(pt2_match_weight(:),4) print *, '# var weight ', real(variance_match_weight(:),4) @@ -131,7 +128,6 @@ BEGIN_PROVIDER [ double precision, selection_weight, (N_states) ] print *, '# var weight ', real(variance_match_weight(:),4) end select - selection_weight(:) = selection_weight(:)/sum(selection_weight(:)) print *, '# Total weight ', real(selection_weight(:),4) END_PROVIDER diff --git a/src/cipsi/slave_cipsi.irp.f b/src/cipsi/slave_cipsi.irp.f index f96aaa6a..510c667b 100644 --- a/src/cipsi/slave_cipsi.irp.f +++ b/src/cipsi/slave_cipsi.irp.f @@ -4,7 +4,7 @@ subroutine run_slave_cipsi ! Helper program for distributed parallelism END_DOC - call set_multiple_levels_omp(.False.) + call omp_set_max_active_levels(1) distributed_davidson = .False. read_wf = .False. SOFT_TOUCH read_wf distributed_davidson @@ -171,9 +171,9 @@ subroutine run_slave_main call write_double(6,(t1-t0),'Broadcast time') !--- - call set_multiple_levels_omp(.True.) + call omp_set_max_active_levels(8) call davidson_slave_tcp(0) - call set_multiple_levels_omp(.False.) + call omp_set_max_active_levels(1) print *, mpi_rank, ': Davidson done' !--- @@ -311,7 +311,7 @@ subroutine run_slave_main if (mpi_master) then print *, 'Running PT2' endif - !$OMP PARALLEL PRIVATE(i) NUM_THREADS(nproc_target) + !$OMP PARALLEL PRIVATE(i) NUM_THREADS(nproc_target+1) i = omp_get_thread_num() call run_pt2_slave(0,i,pt2_e0_denominator) !$OMP END PARALLEL diff --git a/src/cipsi/stochastic_cipsi.irp.f b/src/cipsi/stochastic_cipsi.irp.f index 5fc9db0f..781fcda6 100644 --- a/src/cipsi/stochastic_cipsi.irp.f +++ b/src/cipsi/stochastic_cipsi.irp.f @@ -69,8 +69,8 @@ subroutine run_stochastic_cipsi do while ( & (N_det < N_det_max) .and. & - (sum(abs(pt2_data % pt2(1:N_states)) * state_average_weight(1:N_states)) > pt2_max) .and. & - (sum(abs(pt2_data % variance(1:N_states)) * state_average_weight(1:N_states)) > variance_max) .and. & + (maxval(abs(pt2_data % pt2(1:N_states))) > pt2_max) .and. & + (maxval(abs(pt2_data % variance(1:N_states))) > variance_max) .and. & (correlation_energy_ratio <= correlation_energy_ratio_max) & ) write(*,'(A)') '--------------------------------------------------------------------------------' diff --git a/src/cipsi/update_2rdm.irp.f b/src/cipsi/update_2rdm.irp.f new file mode 100644 index 00000000..260c48fd --- /dev/null +++ b/src/cipsi/update_2rdm.irp.f @@ -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 + + diff --git a/src/cipsi/zmq_selection.irp.f b/src/cipsi/zmq_selection.irp.f index 1bfe87c0..58630709 100644 --- a/src/cipsi/zmq_selection.irp.f +++ b/src/cipsi/zmq_selection.irp.f @@ -22,7 +22,7 @@ subroutine ZMQ_selection(N_in, pt2_data) PROVIDE psi_bilinear_matrix_transp_rows_loc psi_bilinear_matrix_transp_columns PROVIDE psi_bilinear_matrix_transp_order selection_weight pseudo_sym PROVIDE n_act_orb n_inact_orb n_core_orb n_virt_orb n_del_orb seniority_max - PROVIDE excitation_beta_max excitation_alpha_max excitation_max + PROVIDE pert_2rdm excitation_beta_max excitation_alpha_max excitation_max call new_parallel_job(zmq_to_qp_run_socket,zmq_socket_pull,'selection') diff --git a/src/cis/cis.irp.f b/src/cis/cis.irp.f index 2b16a5f7..acec29c2 100644 --- a/src/cis/cis.irp.f +++ b/src/cis/cis.irp.f @@ -62,7 +62,6 @@ subroutine run else call H_apply_cis endif - print*,'' print *, 'N_det = ', N_det print*,'******************************' print *, 'Energies of the states:' @@ -70,18 +69,16 @@ subroutine run print *, i, CI_energy(i) enddo if (N_states > 1) then - print*,'' - print*,'******************************************************' - print*,'Excitation energies (au) (eV)' + print*,'******************************' + print*,'Excitation energies ' do i = 2, N_states - print*, i ,CI_energy(i) - CI_energy(1), (CI_energy(i) - CI_energy(1)) * ha_to_ev + print*, i ,CI_energy(i) - CI_energy(1) enddo - print*,'' endif call ezfio_set_cis_energy(CI_energy) psi_coef = ci_eigenvectors SOFT_TOUCH psi_coef - call save_wavefunction_truncated(save_threshold) + call save_wavefunction_truncated(1.d-12) end diff --git a/src/cis_read/EZFIO.cfg b/src/cis_read/EZFIO.cfg deleted file mode 100644 index 955d1bef..00000000 --- a/src/cis_read/EZFIO.cfg +++ /dev/null @@ -1,7 +0,0 @@ -[energy] -type: double precision -doc: Variational |CIS| energy -interface: ezfio -size: (determinants.n_states) - - diff --git a/src/cis_read/NEED b/src/cis_read/NEED deleted file mode 100644 index 42992ac6..00000000 --- a/src/cis_read/NEED +++ /dev/null @@ -1,3 +0,0 @@ -selectors_full -generators_full -davidson_undressed diff --git a/src/cis_read/README.rst b/src/cis_read/README.rst deleted file mode 100644 index 31648636..00000000 --- a/src/cis_read/README.rst +++ /dev/null @@ -1,5 +0,0 @@ -=== -cis_read -=== - -Reads the input WF and performs all singles on top of it. diff --git a/src/cis_read/cis_read.irp.f b/src/cis_read/cis_read.irp.f deleted file mode 100644 index 055b5e15..00000000 --- a/src/cis_read/cis_read.irp.f +++ /dev/null @@ -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 diff --git a/src/cis_read/h_apply.irp.f b/src/cis_read/h_apply.irp.f deleted file mode 100644 index 14389bed..00000000 --- a/src/cis_read/h_apply.irp.f +++ /dev/null @@ -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 - diff --git a/src/cisd/cisd.irp.f b/src/cisd/cisd.irp.f index 3e1e8d97..6c55e2ff 100644 --- a/src/cisd/cisd.irp.f +++ b/src/cisd/cisd.irp.f @@ -47,37 +47,6 @@ program cisd PROVIDE N_states read_wf = .False. SOFT_TOUCH read_wf - - integer :: i,k - - if(pseudo_sym)then - call H_apply_cisd_sym - else - call H_apply_cisd - endif - double precision :: r1, r2 - double precision, allocatable :: U_csf(:,:) - - allocate(U_csf(N_csf,N_states)) - U_csf = 0.d0 - U_csf(1,1) = 1.d0 - do k=2,N_states - do i=1,N_csf - call random_number(r1) - call random_number(r2) - r1 = dsqrt(-2.d0*dlog(r1)) - r2 = dacos(-1.d0)*2.d0*r2 - U_csf(i,k) = r1*dcos(r2) - enddo - U_csf(k,k) = U_csf(k,k) +100.d0 - enddo - do k=1,N_states - call normalize(U_csf(1,k),N_csf) - enddo - call convertWFfromCSFtoDET(N_states,U_csf(1,1),psi_coef(1,1)) - deallocate(U_csf) - SOFT_TOUCH psi_coef - call run end @@ -87,16 +56,20 @@ subroutine run double precision :: cisdq(N_states), delta_e double precision,external :: diag_h_mat_elem + if(pseudo_sym)then + call H_apply_cisd_sym + else + call H_apply_cisd + endif psi_coef = ci_eigenvectors - call save_wavefunction_truncated(save_threshold) + SOFT_TOUCH psi_coef + call save_wavefunction call ezfio_set_cisd_energy(CI_energy) do i = 1,N_states k = maxloc(dabs(psi_coef_sorted(1:N_det,i)),dim=1) delta_E = CI_electronic_energy(i) - diag_h_mat_elem(psi_det_sorted(1,1,k),N_int) - if (elec_alpha_num + elec_beta_num >= 4) then - cisdq(i) = CI_energy(i) + delta_E * (1.d0 - psi_coef_sorted(k,i)**2) - endif + cisdq(i) = CI_energy(i) + delta_E * (1.d0 - psi_coef_sorted(k,i)**2) enddo print *, 'N_det = ', N_det print*,'' @@ -105,43 +78,26 @@ subroutine run do i = 1,N_states print *, i, CI_energy(i) enddo - if (elec_alpha_num + elec_beta_num >= 4) then + print*,'' + print*,'******************************' + print *, 'CISD+Q Energies' + do i = 1,N_states + print *, i, cisdq(i) + enddo + if (N_states > 1) then print*,'' print*,'******************************' - print *, 'CISD+Q Energies' - do i = 1,N_states - print *, i, cisdq(i) + print*,'Excitation energies (au) (CISD+Q)' + do i = 2, N_states + print*, i ,CI_energy(i) - CI_energy(1), cisdq(i) - cisdq(1) + enddo + print*,'' + print*,'******************************' + print*,'Excitation energies (eV) (CISD+Q)' + do i = 2, N_states + print*, i ,(CI_energy(i) - CI_energy(1))/0.0367502d0, & + (cisdq(i) - cisdq(1)) / 0.0367502d0 enddo - endif - if (N_states > 1) then - if (elec_alpha_num + elec_beta_num >= 4) then - print*,'' - print*,'******************************' - print*,'Excitation energies (au) (CISD+Q)' - do i = 2, N_states - print*, i ,CI_energy(i) - CI_energy(1), cisdq(i) - cisdq(1) - enddo - print*,'' - print*,'******************************' - print*,'Excitation energies (eV) (CISD+Q)' - do i = 2, N_states - print*, i ,(CI_energy(i) - CI_energy(1)) * ha_to_ev, & - (cisdq(i) - cisdq(1)) * ha_to_ev - enddo - else - print*,'' - print*,'******************************' - print*,'Excitation energies (au) (CISD)' - do i = 2, N_states - print*, i ,CI_energy(i) - CI_energy(1) - enddo - print*,'' - print*,'******************************' - print*,'Excitation energies (eV) (CISD)' - do i = 2, N_states - print*, i ,(CI_energy(i) - CI_energy(1)) * ha_to_ev - enddo - endif endif end diff --git a/src/csf/configurations.irp.f b/src/csf/configurations.irp.f index ce5d48ab..8e2a513c 100644 --- a/src/csf/configurations.irp.f +++ b/src/csf/configurations.irp.f @@ -779,7 +779,6 @@ subroutine binary_search_cfg(cfgInp,addcfg) end subroutine BEGIN_PROVIDER [ integer, psi_configuration_to_psi_det, (2,N_configuration) ] -&BEGIN_PROVIDER [ integer, psi_configuration_n_det, (N_configuration) ] &BEGIN_PROVIDER [ integer, psi_configuration_to_psi_det_data, (N_det) ] implicit none @@ -868,29 +867,6 @@ end subroutine enddo deallocate(dets, old_order) - integer :: ndet_conf - do i = 1, N_configuration - ndet_conf = psi_configuration_to_psi_det(2,i) - psi_configuration_to_psi_det(1,i) + 1 - psi_configuration_n_det(i) = ndet_conf - enddo END_PROVIDER - -BEGIN_PROVIDER [ integer, n_elec_alpha_for_psi_configuration, (N_configuration)] - implicit none - integer :: i,j,k,l - integer(bit_kind) :: det_tmp(N_int,2),det_alpha(N_int) - n_elec_alpha_for_psi_configuration = 0 - do i = 1, N_configuration - j = psi_configuration_to_psi_det(2,i) - det_tmp(:,:) = psi_det(:,:,j) - k = 0 - do l = 1, N_int - det_alpha(N_int) = iand(det_tmp(l,1),psi_configuration(l,1,i)) - k += popcnt(det_alpha(l)) - enddo - n_elec_alpha_for_psi_configuration(i) = k - enddo - -END_PROVIDER diff --git a/src/csf/conversion.irp.f b/src/csf/conversion.irp.f index 75f6e539..fecc6123 100644 --- a/src/csf/conversion.irp.f +++ b/src/csf/conversion.irp.f @@ -1,15 +1,3 @@ -BEGIN_PROVIDER [ double precision, psi_csf_coef, (N_csf, N_states) ] - implicit none - BEGIN_DOC - ! Wafe function in CSF basis - END_DOC - - double precision, allocatable :: buffer(:,:) - allocate ( buffer(N_det, N_states) ) - buffer(1:N_det, 1:N_states) = psi_coef(1:N_det, 1:N_states) - call convertWFfromDETtoCSF(N_states, buffer, psi_csf_coef) -END_PROVIDER - subroutine convertWFfromDETtoCSF(N_st,psi_coef_det_in, psi_coef_cfg_out) use cfunctions use bitmasks @@ -38,8 +26,6 @@ subroutine convertWFfromDETtoCSF(N_st,psi_coef_det_in, psi_coef_cfg_out) integer s, bfIcfg integer countcsf - integer MS - MS = elec_alpha_num-elec_beta_num countcsf = 0 phasedet = 1.0d0 do i = 1,N_configuration @@ -58,17 +44,12 @@ subroutine convertWFfromDETtoCSF(N_st,psi_coef_det_in, psi_coef_cfg_out) enddo enddo - s = 0 ! s == total number of SOMOs + s = 0 do k=1,N_int if (psi_configuration(k,1,i) == 0_bit_kind) cycle s = s + popcnt(psi_configuration(k,1,i)) enddo - - if(iand(s,1) .EQ. 0) then - bfIcfg = max(1,nint((binom(s,s/2)-binom(s,(s/2)+1)))) - else - bfIcfg = max(1,nint((binom(s,(s+1)/2)-binom(s,((s+1)/2)+1)))) - endif + bfIcfg = max(1,nint((binom(s,(s+1)/2)-binom(s,((s+1)/2)+1)))) ! perhaps blocking with CFGs of same seniority ! can be more efficient diff --git a/src/csf/sigma_vector.irp.f b/src/csf/sigma_vector.irp.f index 5aaba9a3..85ed5f84 100644 --- a/src/csf/sigma_vector.irp.f +++ b/src/csf/sigma_vector.irp.f @@ -1,12 +1,9 @@ real*8 function logabsgamma(x) implicit none real*8, intent(in) :: x - logabsgamma = 1.d32 ! Avoid floating point exception - if (x>0.d0) then - logabsgamma = log(abs(gamma(x))) - endif + logabsgamma = log(abs(gamma(x))) end function logabsgamma - + BEGIN_PROVIDER [ integer, NSOMOMax] &BEGIN_PROVIDER [ integer, NCSFMax] &BEGIN_PROVIDER [ integer*8, NMO] @@ -51,60 +48,42 @@ if(cfg_seniority_index(i+2) > ncfgpersomo) then ncfgpersomo = cfg_seniority_index(i+2) else - ! l = i+k+2 - ! Loop over l with a constraint to ensure that l <= size(cfg_seniority_index,1)-1 - ! Old version commented just below - do l = min(size(cfg_seniority_index,1)-1, i+2), size(cfg_seniority_index,1)-1, 2 - if (cfg_seniority_index(l) >= ncfgpersomo) then - ncfgpersomo = cfg_seniority_index(l) - endif + k = 0 + do while(cfg_seniority_index(i+2+k) < ncfgpersomo) + k = k + 2 + ncfgpersomo = cfg_seniority_index(i+2+k) enddo - !k = 0 - !if ((i+2+k) < size(cfg_seniority_index,1)) then - ! do while(cfg_seniority_index(i+2+k) < ncfgpersomo) - ! k = k + 2 - ! if ((i+2+k) >= size(cfg_seniority_index,1)) then - ! exit - ! endif - ! ncfgpersomo = cfg_seniority_index(i+2+k) - ! enddo - !endif endif endif ncfg = ncfgpersomo - ncfgprev - if(i .EQ. 0 .OR. i .EQ. 1) then - dimcsfpercfg = 1 - elseif( i .EQ. 3) then - dimcsfpercfg = 2 + if(iand(MS,1) .EQ. 0) then + !dimcsfpercfg = max(1,nint((binom(i,i/2)-binom(i,i/2+1)))) + binom1 = dexp(logabsgamma(1.0d0*(i+1)) & + - logabsgamma(1.0d0*((i/2)+1)) & + - logabsgamma(1.0d0*(i-((i/2))+1))); + binom2 = dexp(logabsgamma(1.0d0*(i+1)) & + - logabsgamma(1.0d0*(((i/2)+1)+1)) & + - logabsgamma(1.0d0*(i-((i/2)+1)+1))); + dimcsfpercfg = max(1,nint(binom1 - binom2)) else - if(iand(MS,1) .EQ. 0) then - dimcsfpercfg = max(1,nint((binom(i,i/2)-binom(i,i/2+1)))) - else - dimcsfpercfg = max(1,nint((binom(i,(i+1)/2)-binom(i,(i+3)/2)))) - endif + !dimcsfpercfg = max(1,nint((binom(i,(i+1)/2)-binom(i,(i+3)/2)))) + binom1 = dexp(logabsgamma(1.0d0*(i+1)) & + - logabsgamma(1.0d0*(((i+1)/2)+1)) & + - logabsgamma(1.0d0*(i-(((i+1)/2))+1))); + binom2 = dexp(logabsgamma(1.0d0*(i+1)) & + - logabsgamma(1.0d0*((((i+3)/2)+1)+1)) & + - logabsgamma(1.0d0*(i-(((i+3)/2)+1)+1))); + dimcsfpercfg = max(1,nint(binom1 - binom2)) endif n_CSF += ncfg * dimcsfpercfg if(cfg_seniority_index(i+2) > ncfgprev) then ncfgprev = cfg_seniority_index(i+2) else - ! l = i+k+2 - ! Loop over l with a constraint to ensure that l <= size(cfg_seniority_index,1)-1 - ! Old version commented just below - do l = min(size(cfg_seniority_index,1)-1, i+2), size(cfg_seniority_index,1)-1, 2 - if (cfg_seniority_index(l) >= ncfgprev) then - ncfgprev = cfg_seniority_index(l) - endif + k = 0 + do while(cfg_seniority_index(i+2+k) < ncfgprev) + k = k + 2 + ncfgprev = cfg_seniority_index(i+2+k) enddo - !k = 0 - !if ((i+2+k) < size(cfg_seniority_index,1)) then - ! do while(cfg_seniority_index(i+2+k) < ncfgprev) - ! k = k + 2 - ! if ((i+2+k) >= size(cfg_seniority_index,1)) then - ! exit - ! endif - ! ncfgprev = cfg_seniority_index(i+2+k) - ! enddo - !endif endif enddo END_PROVIDER diff --git a/src/dav_general_mat/dav_diag_dressed_ext_rout.irp.f b/src/dav_general_mat/dav_diag_dressed_ext_rout.irp.f index 243e9995..2f3d7f80 100644 --- a/src/dav_general_mat/dav_diag_dressed_ext_rout.irp.f +++ b/src/dav_general_mat/dav_diag_dressed_ext_rout.irp.f @@ -1,5 +1,5 @@ -subroutine davidson_general_ext_rout_diag_dressed(u_in,H_jj,Dress_jj,energies,sze,N_st,N_st_diag_in,converged,hcalc) +subroutine davidson_general_ext_rout(u_in,H_jj,Dress_jj,energies,sze,N_st,N_st_diag_in,converged,hcalc) use mmap_module implicit none BEGIN_DOC @@ -412,6 +412,36 @@ subroutine davidson_general_ext_rout_diag_dressed(u_in,H_jj,Dress_jj,energies,sz FREE nthreads_davidson end +subroutine hcalc_template(v,u,N_st,sze) + use bitmasks + implicit none + BEGIN_DOC + ! Template of routine for the application of H + ! + ! Here, it is done with the Hamiltonian matrix + ! + ! on the set of determinants of psi_det + ! + ! Computes $v = H | u \rangle$ + ! + END_DOC + integer, intent(in) :: N_st,sze + double precision, intent(in) :: u(sze,N_st) + double precision, intent(inout) :: v(sze,N_st) + integer :: i,j,istate + v = 0.d0 + do istate = 1, N_st + do i = 1, sze + do j = 1, sze + v(i,istate) += H_matrix_all_dets(j,i) * u(j,istate) + enddo + enddo + do i = 1, sze + v(i,istate) += u(i,istate) * nuclear_repulsion + enddo + enddo +end + subroutine dressing_diag_uv(v,u,dress_diag,N_st,sze) implicit none BEGIN_DOC diff --git a/src/dav_general_mat/dav_ext_rout.irp.f b/src/dav_general_mat/dav_ext_rout.irp.f index 868d928b..aee4ba09 100644 --- a/src/dav_general_mat/dav_ext_rout.irp.f +++ b/src/dav_general_mat/dav_ext_rout.irp.f @@ -247,8 +247,8 @@ subroutine davidson_general_ext_rout(u_in,H_jj,energies,sze,N_st,N_st_diag_in,co if (state_following) then overlap = -1.d0 - do k=1,shift2 - do i=1,shift2 + do i=1,shift2 + do k=1,shift2 overlap(k,i) = dabs(y(k,i)) enddo enddo diff --git a/src/dav_general_mat/dav_ext_rout_nonsym_B1space.irp.f b/src/dav_general_mat/dav_ext_rout_nonsym_B1space.irp.f new file mode 100644 index 00000000..c5127861 --- /dev/null +++ b/src/dav_general_mat/dav_ext_rout_nonsym_B1space.irp.f @@ -0,0 +1,608 @@ + +! --- + +subroutine davidson_general_ext_rout_nonsym_b1space(u_in, H_jj, energies, sze, N_st, N_st_diag_in, converged, hcalc) + + use mmap_module + + BEGIN_DOC + ! Generic modified-Davidson diagonalization + ! + ! H_jj : specific diagonal H matrix elements to diagonalize de Davidson + ! + ! u_in : guess coefficients on the various states. Overwritten on exit by right eigenvectors + ! + ! sze : Number of determinants + ! + ! N_st : Number of eigenstates + ! + ! N_st_diag_in : Number of states in which H is diagonalized. Assumed > N_st + ! + ! Initial guess vectors are not necessarily orthonormal + ! + ! hcalc subroutine to compute W = H U (see routine hcalc_template for template of input/output) + END_DOC + + implicit none + + integer, intent(in) :: sze, N_st, N_st_diag_in + double precision, intent(in) :: H_jj(sze) + logical, intent(inout) :: converged + double precision, intent(inout) :: u_in(sze,N_st_diag_in) + double precision, intent(out) :: energies(N_st) + external hcalc + + character*(16384) :: write_buffer + integer :: iter, N_st_diag + integer :: i, j, k, m + integer :: iter2, itertot + logical :: disk_based + integer :: shift, shift2, itermax + integer :: nproc_target + integer :: order(N_st_diag_in) + double precision :: to_print(2,N_st) + double precision :: r1, r2, alpha + double precision :: cpu, wall + double precision :: cmax + double precision :: energy_shift(N_st_diag_in*davidson_sze_max) + double precision, allocatable :: U(:,:) + double precision, allocatable :: y(:,:), h(:,:), lambda(:) + double precision, allocatable :: residual_norm(:) + + integer :: i_omax + double precision :: lambda_tmp + double precision, allocatable :: U_tmp(:), overlap(:) + + double precision, allocatable :: W(:,:) + !double precision, pointer :: W(:,:) + double precision, external :: u_dot_v, u_dot_u + + + include 'constants.include.F' + + 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 + + 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 + double precision :: rss + integer :: maxab + maxab = sze + + m=1 + disk_based = .False. + call resident_memory(rss) + do + r1 = 8.d0 * &! bytes + ( dble(sze)*(N_st_diag*itermax) &! U + + 1.d0*dble(sze*m)*(N_st_diag*itermax) &! W + + 2.d0*(N_st_diag*itermax)**2 &! h,y + + 2.d0*(N_st_diag*itermax) &! s2,lambda + + 1.d0*(N_st_diag) &! residual_norm + ! In H_S2_u_0_nstates_zmq + + 3.d0*(N_st_diag*N_det) &! u_t, v_t, s_t on collector + + 3.d0*(N_st_diag*N_det) &! u_t, v_t, s_t on slave + + 0.5d0*maxab &! idx0 in H_S2_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 basis functions') + 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) + + ! --- + + + allocate( W(sze,N_st_diag*itermax) ) + + 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), & + lambda(N_st_diag*itermax), & + residual_norm(N_st_diag) & + ) + + U = 0.d0 + h = 0.d0 + y = 0.d0 + lambda = 0.d0 + residual_norm = 0.d0 + + + ASSERT (N_st > 0) + ASSERT (N_st_diag >= N_st) + ASSERT (sze > 0) + + ! Davidson iterations + ! =================== + + converged = .False. + + ! Initialize from N_st to N_st_diag with gaussian random numbers + ! to be sure to have overlap with any eigenvectors + do k = N_st+1, N_st_diag + u_in(k,k) = 10.d0 + 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) + enddo + enddo + ! Normalize all states + do k = 1, N_st_diag + call normalize(u_in(1,k), sze) + enddo + + ! Copy from the guess input "u_in" to the working vectors "U" + do k = 1, N_st_diag + do i = 1, sze + U(i,k) = u_in(i,k) + enddo + enddo + + ! --- + + itertot = 0 + + 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) + + ! W = H U + call hcalc(W(1,shift+1), U(1,shift+1), N_st_diag, sze) + + else + + ! Already computed in update below + continue + endif + + ! Compute h_kl = = + ! ------------------------------------------- + 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 y = lambda y + ! --------------------------- + call diag_nonsym_right(shift2, h(1,1), size(h, 1), y(1,1), size(y, 1), lambda(1), size(lambda, 1)) + + + ! Express eigenvectors of h in the determinant basis: + ! --------------------------------------------------- + + ! y(:,k) = rk + ! U(:,k) = Bk + ! U(:,shift2+k) = Rk = Bk x rk + 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 + + ! --- + ! select the max overlap + + ! + ! start test ------------------------------------------------------------------------ + ! + !double precision, allocatable :: Utest(:,:), Otest(:) + !allocate( Utest(sze,shift2), Otest(shift2) ) + + !call dgemm( 'N', 'N', sze, shift2, shift2, 1.d0 & + ! , U, size(U, 1), y, size(y, 1), 0.d0, Utest(1,1), size(Utest, 1) ) + !do k = 1, shift2 + ! call normalize(Utest(1,k), sze) + !enddo + !do j = 1, sze + ! write(455, '(100(1X, F16.10))') (Utest(j,k), k=1,shift2) + !enddo + + !do k = 1, shift2 + ! Otest(k) = 0.d0 + ! do i = 1, sze + ! Otest(k) += Utest(i,k) * u_in(i,1) + ! enddo + ! Otest(k) = dabs(Otest(k)) + ! print *, ' Otest =', k, Otest(k), lambda(k) + !enddo + + !deallocate(Utest, Otest) + ! + ! end test ------------------------------------------------------------------------ + ! + + + allocate( overlap(N_st_diag) ) + + do k = 1, N_st_diag + overlap(k) = 0.d0 + do i = 1, sze + overlap(k) = overlap(k) + U(i,shift2+k) * u_in(i,1) + enddo + overlap(k) = dabs(overlap(k)) + !print *, ' overlap =', k, overlap(k) + enddo + + lambda_tmp = 0.d0 + do k = 1, N_st_diag + if(overlap(k) .gt. lambda_tmp) then + i_omax = k + lambda_tmp = overlap(k) + endif + enddo + deallocate(overlap) + if( lambda_tmp .lt. 0.8d0) then + print *, ' very small overlap..' + print*, ' max overlap = ', lambda_tmp, i_omax + stop + endif + +! lambda_tmp = lambda(1) +! lambda(1) = lambda(i_omax) +! lambda(i_omax) = lambda_tmp +! +! allocate( U_tmp(sze) ) +! do i = 1, sze +! U_tmp(i) = U(i,shift2+1) +! U(i,shift2+1) = U(i,shift2+i_omax) +! U(i,shift2+i_omax) = U_tmp(i) +! enddo +! deallocate(U_tmp) +! +! allocate( U_tmp(N_st_diag*itermax) ) +! do i = 1, shift2 +! U_tmp(i) = y(i,1) +! y(i,1) = y(i,i_omax) +! y(i,i_omax) = U_tmp(i) +! enddo +! deallocate(U_tmp) + + ! --- + + !do k = 1, N_st_diag + ! call normalize(U(1,shift2+k), sze) + !enddo + + ! --- + + ! y(:,k) = rk + ! W(:,k) = H x Bk + ! W(:,shift2+k) = H x Bk x rk + ! = Wk + 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) + ! to_print(2,k) = residual_norm(k) + !endif + enddo + !$OMP END PARALLEL DO + residual_norm(1) = u_dot_u(U(1,shift2+i_omax), sze) + to_print(1,1) = lambda(i_omax) + to_print(2,1) = residual_norm(1) + + + if( (itertot > 1) .and. (iter == 1) ) then + !don't print + continue + else + write(*, '(1X, I3, 1X, 100(1X, F16.10, 1X, F16.10, 1X, F16.10))') iter-1, to_print(1:2,1:N_st) + endif + + ! Check convergence + if(iter > 1) then + converged = dabs(maxval(residual_norm(1:N_st))) < threshold_nonsym_davidson + endif + + do k = 1, N_st + if(residual_norm(k) > 1.e8) 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 ! loop over iter + + + ! 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 + + call ortho_qr(U, size(U, 1), sze, N_st_diag) + call ortho_qr(U, size(U, 1), sze, N_st_diag) + do j = 1, N_st_diag + k = 1 + do while( (k < sze) .and. (U(k,j) == 0.d0) ) + k = k+1 + enddo + if(U(k,j) * u_in(k,j) < 0.d0) then + do i = 1, sze + W(i,j) = -W(i,j) + enddo + endif + enddo + + enddo ! loop over while + + ! --- + + do k = 1, N_st + 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) + + deallocate(W) + deallocate(U, h, y, lambda, residual_norm) + + FREE nthreads_davidson + +end subroutine davidson_general_ext_rout_nonsym_b1space + +! --- + +subroutine diag_nonsym_right(n, A, A_ldim, V, V_ldim, energy, E_ldim) + + implicit none + + integer, intent(in) :: n, A_ldim, V_ldim, E_ldim + double precision, intent(in) :: A(A_ldim,n) + double precision, intent(out) :: energy(E_ldim), V(V_ldim,n) + + character*1 :: JOBVL, JOBVR, BALANC, SENSE + integer :: i, j + integer :: ILO, IHI, lda, ldvl, ldvr, LWORK, INFO + double precision :: ABNRM + integer, allocatable :: iorder(:), IWORK(:) + double precision, allocatable :: WORK(:), SCALE_array(:), RCONDE(:), RCONDV(:) + double precision, allocatable :: Atmp(:,:), WR(:), WI(:), VL(:,:), VR(:,:), Vtmp(:) + double precision, allocatable :: energy_loc(:), V_loc(:,:) + + allocate( Atmp(n,n), WR(n), WI(n), VL(1,1), VR(n,n) ) + do i = 1, n + do j = 1, n + Atmp(j,i) = A(j,i) + enddo + enddo + + JOBVL = "N" ! computes the left eigenvectors + JOBVR = "V" ! computes the right eigenvectors + BALANC = "B" ! Diagonal scaling and Permutation for optimization + SENSE = "V" ! Determines which reciprocal condition numbers are computed + lda = n + ldvr = n + ldvl = 1 + + allocate( WORK(1), SCALE_array(n), RCONDE(n), RCONDV(n), IWORK(2*n-2) ) + + LWORK = -1 ! to ask for the optimal size of WORK + call dgeevx( BALANC, JOBVL, JOBVR, SENSE & ! CHARACTERS + , n, Atmp, lda & ! MATRIX TO DIAGONALIZE + , WR, WI & ! REAL AND IMAGINARY PART OF EIGENVALUES + , VL, ldvl, VR, ldvr & ! LEFT AND RIGHT EIGENVECTORS + , ILO, IHI, SCALE_array, ABNRM, RCONDE, RCONDV & ! OUTPUTS OF OPTIMIZATION + , WORK, LWORK, IWORK, INFO ) + + if(INFO .ne. 0) then + print*, '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*, '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 + +! --- + diff --git a/src/dav_general_mat/dav_general.irp.f b/src/dav_general_mat/dav_general.irp.f index aa4a2eb3..39cb68bb 100644 --- a/src/dav_general_mat/dav_general.irp.f +++ b/src/dav_general_mat/dav_general.irp.f @@ -258,8 +258,8 @@ subroutine davidson_general(u_in,H_jj,energies,dim_in,sze,N_st,N_st_diag_in,conv if (state_following) then overlap = -1.d0 - do k=1,shift2 - do i=1,shift2 + do i=1,shift2 + do k=1,shift2 overlap(k,i) = dabs(y(k,i)) enddo enddo diff --git a/src/davidson/EZFIO.cfg b/src/davidson/EZFIO.cfg index 92c41b4c..de814b94 100644 --- a/src/davidson/EZFIO.cfg +++ b/src/davidson/EZFIO.cfg @@ -4,6 +4,12 @@ doc: Thresholds of Davidson's algorithm if threshold_davidson_from_pt2 is false. interface: ezfio,provider,ocaml default: 1.e-10 +[threshold_nonsym_davidson] +type: Threshold +doc: Thresholds of non-symetric Davidson's algorithm +interface: ezfio,provider,ocaml +default: 1.e-5 + [threshold_davidson_from_pt2] type: logical doc: Thresholds of Davidson's algorithm is set to E(rPT2)*threshold_davidson_from_pt2 diff --git a/src/davidson/davidson_parallel.irp.f b/src/davidson/davidson_parallel.irp.f index e627dfc9..8fd023da 100644 --- a/src/davidson/davidson_parallel.irp.f +++ b/src/davidson/davidson_parallel.irp.f @@ -508,7 +508,7 @@ subroutine H_S2_u_0_nstates_zmq(v_0,s_0,u_0,N_st,sze) endif - call set_multiple_levels_omp(.True.) + call omp_set_max_active_levels(5) !$OMP PARALLEL DEFAULT(shared) NUM_THREADS(2) PRIVATE(ithread) ithread = omp_get_thread_num() diff --git a/src/davidson/davidson_parallel_csf.irp.f b/src/davidson/davidson_parallel_csf.irp.f index d8e9bffa..fe651b1d 100644 --- a/src/davidson/davidson_parallel_csf.irp.f +++ b/src/davidson/davidson_parallel_csf.irp.f @@ -464,8 +464,7 @@ subroutine H_u_0_nstates_zmq(v_0,u_0,N_st,sze) print *, irp_here, ': Failed in zmq_set_running' endif - call set_multiple_levels_omp(.True.) - + call omp_set_max_active_levels(4) !$OMP PARALLEL DEFAULT(shared) NUM_THREADS(2) PRIVATE(ithread) ithread = omp_get_thread_num() if (ithread == 0 ) then diff --git a/src/davidson/davidson_parallel_nos2.irp.f b/src/davidson/davidson_parallel_nos2.irp.f index 597b001f..84cbe3af 100644 --- a/src/davidson/davidson_parallel_nos2.irp.f +++ b/src/davidson/davidson_parallel_nos2.irp.f @@ -464,8 +464,7 @@ subroutine H_u_0_nstates_zmq(v_0,u_0,N_st,sze) print *, irp_here, ': Failed in zmq_set_running' endif - call set_multiple_levels_omp(.True.) - + call omp_set_max_active_levels(4) !$OMP PARALLEL DEFAULT(shared) NUM_THREADS(2) PRIVATE(ithread) ithread = omp_get_thread_num() if (ithread == 0 ) then diff --git a/src/davidson/diagonalization_hcsf_dressed.irp.f b/src/davidson/diagonalization_hcsf_dressed.irp.f index 7aaaa842..b6f438a0 100644 --- a/src/davidson/diagonalization_hcsf_dressed.irp.f +++ b/src/davidson/diagonalization_hcsf_dressed.irp.f @@ -124,7 +124,7 @@ subroutine davidson_diag_csf_hjj(dets_in,u_in,H_jj,energies,dim_in,sze,sze_csf,N stop -1 endif - itermax = max(2,min(davidson_sze_max, sze_csf/N_st_diag))+1 + itermax = max(2,min(davidson_sze_max, sze/N_st_diag))+1 itertot = 0 if (state_following) then @@ -263,20 +263,29 @@ subroutine davidson_diag_csf_hjj(dets_in,u_in,H_jj,energies,dim_in,sze,sze_csf,N ! =================== converged = .False. - call convertWFfromDETtoCSF(N_st_diag,u_in(1,1),U_csf(1,1)) + do k=N_st+1,N_st_diag - do i=1,sze_csf + do i=1,sze call random_number(r1) call random_number(r2) r1 = dsqrt(-2.d0*dlog(r1)) r2 = dtwo_pi*r2 - U_csf(i,k) = r1*dcos(r2) * u_csf(i,k-N_st) + u_in(i,k) = r1*dcos(r2) * u_in(i,k-N_st) enddo - U_csf(k,k) = u_csf(k,k) + 10.d0 + u_in(k,k) = u_in(k,k) + 10.d0 enddo do k=1,N_st_diag - call normalize(U_csf(1,k),sze_csf) + call normalize(u_in(1,k),sze) enddo + + do k=1,N_st_diag + do i=1,sze + U(i,k) = u_in(i,k) + enddo + enddo + + ! Make random verctors eigenstates of S2 + call convertWFfromDETtoCSF(N_st_diag,U(1,1),U_csf(1,1)) call convertWFfromCSFtoDET(N_st_diag,U_csf(1,1),U(1,1)) do while (.not.converged) @@ -290,7 +299,7 @@ subroutine davidson_diag_csf_hjj(dets_in,u_in,H_jj,energies,dim_in,sze,sze_csf,N shift = N_st_diag*(iter-1) shift2 = N_st_diag*iter -! if ((iter > 1).or.(itertot == 1)) then + if ((iter > 1).or.(itertot == 1)) then ! Compute |W_k> = \sum_i |i> ! ----------------------------------- @@ -300,10 +309,10 @@ subroutine davidson_diag_csf_hjj(dets_in,u_in,H_jj,energies,dim_in,sze,sze_csf,N else call H_u_0_nstates_openmp(W,U,N_st_diag,sze) endif -! else -! ! Already computed in update below -! continue -! endif + else + ! Already computed in update below + continue + endif if (dressing_state > 0) then @@ -499,8 +508,17 @@ subroutine davidson_diag_csf_hjj(dets_in,u_in,H_jj,energies,dim_in,sze,sze_csf,N enddo - ! Re-contract U - ! ------------- + ! Re-contract U and update W + ! -------------------------------- + + call dgemm('N','N', sze_csf, N_st_diag, shift2, 1.d0, & + W_csf, size(W_csf,1), y, size(y,1), 0.d0, u_in, size(u_in,1)) + do k=1,N_st_diag + do i=1,sze_csf + W_csf(i,k) = u_in(i,k) + enddo + enddo + call convertWFfromCSFtoDET(N_st_diag,W_csf,W) call dgemm('N','N', sze_csf, N_st_diag, shift2, 1.d0, & U_csf, size(U_csf,1), y, size(y,1), 0.d0, u_in, size(u_in,1)) diff --git a/src/davidson/diagonalization_hs2_dressed.irp.f b/src/davidson/diagonalization_hs2_dressed.irp.f index d37b7386..1a27a75e 100644 --- a/src/davidson/diagonalization_hs2_dressed.irp.f +++ b/src/davidson/diagonalization_hs2_dressed.irp.f @@ -349,7 +349,7 @@ subroutine davidson_diag_hjj_sjj(dets_in,u_in,H_jj,s2_out,energies,dim_in,sze,N_ shift = N_st_diag*(iter-1) shift2 = N_st_diag*iter -! if ((iter > 1).or.(itertot == 1)) then + if ((iter > 1).or.(itertot == 1)) then ! Compute |W_k> = \sum_i |i> ! ----------------------------------- @@ -359,10 +359,10 @@ subroutine davidson_diag_hjj_sjj(dets_in,u_in,H_jj,s2_out,energies,dim_in,sze,N_ call H_S2_u_0_nstates_openmp(W(1,shift+1),S_d,U(1,shift+1),N_st_diag,sze) endif S(1:sze,shift+1:shift+N_st_diag) = real(S_d(1:sze,1:N_st_diag)) -! else -! ! Already computed in update below -! continue -! endif + else + ! Already computed in update below + continue + endif if (dressing_state > 0) then diff --git a/src/davidson/diagonalize_ci.irp.f b/src/davidson/diagonalize_ci.irp.f index 6930cc07..fb991b65 100644 --- a/src/davidson/diagonalize_ci.irp.f +++ b/src/davidson/diagonalize_ci.irp.f @@ -1,19 +1,9 @@ -BEGIN_PROVIDER [ character*(3), sigma_vector_algorithm ] - implicit none - BEGIN_DOC - ! If 'det', use in Davidson - ! - ! If 'cfg', use in Davidson - END_DOC - sigma_vector_algorithm = 'det' -END_PROVIDER BEGIN_PROVIDER [ double precision, CI_energy, (N_states_diag) ] implicit none BEGIN_DOC ! :c:data:`n_states` lowest eigenvalues of the |CI| matrix END_DOC - PROVIDE distributed_davidson integer :: j character*(8) :: st @@ -71,18 +61,9 @@ END_PROVIDER if (diag_algorithm == "Davidson") then if (do_csf) then - if (sigma_vector_algorithm == 'det') then - call davidson_diag_H_csf(psi_det,CI_eigenvectors, & - size(CI_eigenvectors,1),CI_electronic_energy, & - N_det,N_csf,min(N_det,N_states),min(N_det,N_states_diag),N_int,0,converged) -! else if (sigma_vector_algorithm == 'cfg') then -! call davidson_diag_H_csf(psi_det,CI_eigenvectors, & -! size(CI_eigenvectors,1),CI_electronic_energy, & -! N_det,N_csf,min(N_det,N_states),min(N_det,N_states_diag),N_int,0,converged) -! else -! print *, irp_here -! stop 'bug' - endif + call davidson_diag_H_csf(psi_det,CI_eigenvectors, & + size(CI_eigenvectors,1),CI_electronic_energy, & + N_det,N_csf,min(N_det,N_states),min(N_det,N_states_diag),N_int,0,converged) else call davidson_diag_HS2(psi_det,CI_eigenvectors, CI_s2, & size(CI_eigenvectors,1),CI_electronic_energy, & @@ -266,7 +247,6 @@ subroutine diagonalize_CI ! eigenstates of the |CI| matrix. END_DOC integer :: i,j - PROVIDE distributed_davidson do j=1,N_states do i=1,N_det psi_coef(i,j) = CI_eigenvectors(i,j) diff --git a/src/two_body_rdm/print_e_components.irp.f b/src/davidson/print_e_components.irp.f similarity index 100% rename from src/two_body_rdm/print_e_components.irp.f rename to src/davidson/print_e_components.irp.f diff --git a/src/davidson/u0_hs2_u0.irp.f b/src/davidson/u0_hs2_u0.irp.f index 38fb56bd..8f7bf06b 100644 --- a/src/davidson/u0_hs2_u0.irp.f +++ b/src/davidson/u0_hs2_u0.irp.f @@ -203,7 +203,7 @@ subroutine H_S2_u_0_nstates_openmp_work_$N_int(v_t,s_t,u_t,N_st,sze,istart,iend, integer, allocatable :: doubles(:) integer, allocatable :: singles_a(:) integer, allocatable :: singles_b(:) - integer, allocatable :: idx(:), buffer_lrow(:), idx0(:) + integer, allocatable :: idx(:), idx0(:) integer :: maxab, n_singles_a, n_singles_b, kcol_prev integer*8 :: k8 logical :: compute_singles @@ -253,7 +253,7 @@ compute_singles=.True. !$OMP PRIVATE(krow, kcol, tmp_det, spindet, k_a, k_b, i, & !$OMP lcol, lrow, l_a, l_b, utl, kk, u_is_sparse, & !$OMP buffer, doubles, n_doubles, umax, & - !$OMP tmp_det2, hij, sij, idx, buffer_lrow, l, kcol_prev, & + !$OMP tmp_det2, hij, sij, idx, l, kcol_prev, & !$OMP singles_a, n_singles_a, singles_b, ratio, & !$OMP n_singles_b, k8, last_found,left,right,right_max) @@ -264,7 +264,7 @@ compute_singles=.True. singles_a(maxab), & singles_b(maxab), & doubles(maxab), & - idx(maxab), buffer_lrow(maxab), utl(N_st,block_size)) + idx(maxab), utl(N_st,block_size)) kcol_prev=-1 @@ -332,20 +332,18 @@ compute_singles=.True. l_a = psi_bilinear_matrix_columns_loc(lcol) ASSERT (l_a <= N_det) + !DIR$ UNROLL(8) + !DIR$ LOOP COUNT avg(50000) do j=1,psi_bilinear_matrix_columns_loc(lcol+1) - psi_bilinear_matrix_columns_loc(lcol) lrow = psi_bilinear_matrix_rows(l_a) ASSERT (lrow <= N_det_alpha_unique) - buffer_lrow(j) = lrow + buffer(1:$N_int,j) = psi_det_alpha_unique(1:$N_int, lrow) ! hot spot ASSERT (l_a <= N_det) idx(j) = l_a l_a = l_a+1 enddo - - do j=1,psi_bilinear_matrix_columns_loc(lcol+1) - psi_bilinear_matrix_columns_loc(lcol) - buffer(1:$N_int,j) = psi_det_alpha_unique(1:$N_int, buffer_lrow(j)) ! hot spot - enddo j = j-1 call get_all_spin_singles_$N_int( & @@ -791,7 +789,7 @@ compute_singles=.True. end do !$OMP END DO - deallocate(buffer, singles_a, singles_b, doubles, idx, buffer_lrow, utl) + deallocate(buffer, singles_a, singles_b, doubles, idx, utl) !$OMP END PARALLEL end diff --git a/src/davidson_dressed/diagonalize_ci.irp.f b/src/davidson_dressed/diagonalize_ci.irp.f index b58ce9c0..7619532a 100644 --- a/src/davidson_dressed/diagonalize_ci.irp.f +++ b/src/davidson_dressed/diagonalize_ci.irp.f @@ -12,7 +12,7 @@ BEGIN_PROVIDER [ double precision, CI_energy_dressed, (N_states_diag) ] enddo do j=1,min(N_det,N_states) write(st,'(I4)') j - call write_double(6,CI_energy_dressed(j),'Energy dressed of state '//trim(st)) + call write_double(6,CI_energy_dressed(j),'Energy of state '//trim(st)) call write_double(6,CI_eigenvectors_s2_dressed(j),'S^2 of state '//trim(st)) enddo @@ -21,201 +21,133 @@ END_PROVIDER BEGIN_PROVIDER [ double precision, CI_electronic_energy_dressed, (N_states_diag) ] &BEGIN_PROVIDER [ double precision, CI_eigenvectors_dressed, (N_det,N_states_diag) ] &BEGIN_PROVIDER [ double precision, CI_eigenvectors_s2_dressed, (N_states_diag) ] - BEGIN_DOC - ! Eigenvectors/values of the CI matrix - END_DOC - implicit none - double precision :: ovrlp,u_dot_v - integer :: i_good_state - integer, allocatable :: index_good_state_array(:) - logical, allocatable :: good_state_array(:) - double precision, allocatable :: s2_values_tmp(:) - integer :: i_other_state - double precision, allocatable :: eigenvectors(:,:), eigenvectors_s2(:,:), eigenvalues(:) - integer :: i_state - double precision :: e_0 - integer :: i,j,k,mrcc_state - double precision, allocatable :: s2_eigvalues(:) - double precision, allocatable :: e_array(:) - integer, allocatable :: iorder(:) - logical :: converged - logical :: do_csf - - PROVIDE threshold_davidson nthreads_davidson - ! Guess values for the "N_states" states of the CI_eigenvectors_dressed - do j=1,min(N_states,N_det) - do i=1,N_det - CI_eigenvectors_dressed(i,j) = psi_coef(i,j) - enddo - enddo - - do j=min(N_states,N_det)+1,N_states_diag - do i=1,N_det - CI_eigenvectors_dressed(i,j) = 0.d0 - enddo - enddo - - do_csf = s2_eig .and. only_expected_s2 .and. csf_based - - if (diag_algorithm == "Davidson") then - - do j=1,min(N_states,N_det) - do i=1,N_det - CI_eigenvectors_dressed(i,j) = psi_coef(i,j) + BEGIN_DOC + ! Eigenvectors/values of the CI matrix + END_DOC + implicit none + double precision :: ovrlp,u_dot_v + integer :: i_good_state + integer, allocatable :: index_good_state_array(:) + logical, allocatable :: good_state_array(:) + double precision, allocatable :: s2_values_tmp(:) + integer :: i_other_state + double precision, allocatable :: eigenvectors(:,:), eigenvectors_s2(:,:), eigenvalues(:) + integer :: i_state + double precision :: e_0 + integer :: i,j,k,mrcc_state + double precision, allocatable :: s2_eigvalues(:) + double precision, allocatable :: e_array(:) + integer, allocatable :: iorder(:) + + PROVIDE threshold_davidson nthreads_davidson + ! Guess values for the "N_states" states of the CI_eigenvectors_dressed + do j=1,min(N_states,N_det) + do i=1,N_det + CI_eigenvectors_dressed(i,j) = psi_coef(i,j) + enddo + enddo + + do j=min(N_states,N_det)+1,N_states_diag + do i=1,N_det + CI_eigenvectors_dressed(i,j) = 0.d0 + enddo + enddo + + if (diag_algorithm == "Davidson") then + + do j=1,min(N_states,N_det) + do i=1,N_det + CI_eigenvectors_dressed(i,j) = psi_coef(i,j) + enddo + enddo + logical :: converged + converged = .False. + call davidson_diag_HS2(psi_det,CI_eigenvectors_dressed, CI_eigenvectors_s2_dressed,& + size(CI_eigenvectors_dressed,1), CI_electronic_energy_dressed,& + N_det,min(N_det,N_states),min(N_det,N_states_diag),N_int,1,converged) + + else if (diag_algorithm == "Lapack") then + + allocate (eigenvectors(size(H_matrix_dressed,1),N_det)) + allocate (eigenvalues(N_det)) + + call lapack_diag(eigenvalues,eigenvectors, & + H_matrix_dressed,size(H_matrix_dressed,1),N_det) + CI_electronic_energy_dressed(:) = 0.d0 + if (s2_eig) then + i_state = 0 + allocate (s2_eigvalues(N_det)) + allocate(index_good_state_array(N_det),good_state_array(N_det)) + good_state_array = .False. + + call u_0_S2_u_0(s2_eigvalues,eigenvectors,N_det,psi_det,N_int,& + N_det,size(eigenvectors,1)) + do j=1,N_det + ! Select at least n_states states with S^2 values closed to "expected_s2" + if(dabs(s2_eigvalues(j)-expected_s2).le.0.5d0)then + i_state +=1 + index_good_state_array(i_state) = j + good_state_array(j) = .True. + endif + if(i_state.eq.N_states) then + exit + endif enddo - enddo - converged = .False. - if (do_csf) then - call davidson_diag_H_csf(psi_det,CI_eigenvectors_dressed, & - size(CI_eigenvectors_dressed,1),CI_electronic_energy_dressed, & - N_det,N_csf,min(N_det,N_states),min(N_det,N_states_diag),N_int,1,converged) + if(i_state .ne.0)then + ! Fill the first "i_state" states that have a correct S^2 value + do j = 1, i_state + do i=1,N_det + CI_eigenvectors_dressed(i,j) = eigenvectors(i,index_good_state_array(j)) + enddo + CI_electronic_energy_dressed(j) = eigenvalues(index_good_state_array(j)) + CI_eigenvectors_s2_dressed(j) = s2_eigvalues(index_good_state_array(j)) + enddo + i_other_state = 0 + do j = 1, N_det + if(good_state_array(j))cycle + i_other_state +=1 + if(i_state+i_other_state.gt.n_states_diag)then + exit + endif + do i=1,N_det + CI_eigenvectors_dressed(i,i_state+i_other_state) = eigenvectors(i,j) + enddo + CI_electronic_energy_dressed(i_state+i_other_state) = eigenvalues(j) + CI_eigenvectors_s2_dressed(i_state+i_other_state) = s2_eigvalues(i_state+i_other_state) + enddo + else + print*,'' + print*,'!!!!!!!! WARNING !!!!!!!!!' + print*,' Within the ',N_det,'determinants selected' + print*,' and the ',N_states_diag,'states requested' + print*,' We did not find any state with S^2 values close to ',expected_s2 + print*,' We will then set the first N_states eigenvectors of the H matrix' + print*,' as the CI_eigenvectors_dressed' + print*,' You should consider more states and maybe ask for s2_eig to be .True. or just enlarge the CI space' + print*,'' + do j=1,min(N_states_diag,N_det) + do i=1,N_det + CI_eigenvectors_dressed(i,j) = eigenvectors(i,j) + enddo + CI_electronic_energy_dressed(j) = eigenvalues(j) + CI_eigenvectors_s2_dressed(j) = s2_eigvalues(j) + enddo + endif + deallocate(index_good_state_array,good_state_array) + deallocate(s2_eigvalues) else - call davidson_diag_HS2(psi_det,CI_eigenvectors_dressed, CI_eigenvectors_s2_dressed,& - size(CI_eigenvectors_dressed,1), CI_electronic_energy_dressed,& - N_det,min(N_det,N_states),min(N_det,N_states_diag),N_int,1,converged) + call u_0_S2_u_0(CI_eigenvectors_s2_dressed,eigenvectors,N_det,psi_det,N_int,& + min(N_det,N_states_diag),size(eigenvectors,1)) + ! Select the "N_states_diag" states of lowest energy + do j=1,min(N_det,N_states_diag) + do i=1,N_det + CI_eigenvectors_dressed(i,j) = eigenvectors(i,j) + enddo + CI_electronic_energy_dressed(j) = eigenvalues(j) + enddo endif - - integer :: N_states_diag_save - N_states_diag_save = N_states_diag - do while (.not.converged) - double precision, allocatable :: CI_electronic_energy_tmp (:) - double precision, allocatable :: CI_eigenvectors_tmp (:,:) - double precision, allocatable :: CI_s2_tmp (:) - - N_states_diag *= 2 - TOUCH N_states_diag - - if (do_csf) then - - allocate (CI_electronic_energy_tmp (N_states_diag) ) - allocate (CI_eigenvectors_tmp (N_det,N_states_diag) ) - - CI_electronic_energy_tmp(1:N_states_diag_save) = CI_electronic_energy_dressed(1:N_states_diag_save) - CI_eigenvectors_tmp(1:N_det,1:N_states_diag_save) = CI_eigenvectors_dressed(1:N_det,1:N_states_diag_save) - - call davidson_diag_H_csf(psi_det,CI_eigenvectors_tmp, & - size(CI_eigenvectors_tmp,1),CI_electronic_energy_tmp, & - N_det,N_csf,min(N_det,N_states),min(N_det,N_states_diag),N_int,1,converged) - - CI_electronic_energy_dressed(1:N_states_diag_save) = CI_electronic_energy_tmp(1:N_states_diag_save) - CI_eigenvectors_dressed(1:N_det,1:N_states_diag_save) = CI_eigenvectors_tmp(1:N_det,1:N_states_diag_save) - - deallocate (CI_electronic_energy_tmp) - deallocate (CI_eigenvectors_tmp) - - else - - allocate (CI_electronic_energy_tmp (N_states_diag) ) - allocate (CI_eigenvectors_tmp (N_det,N_states_diag) ) - allocate (CI_s2_tmp (N_states_diag) ) - - CI_electronic_energy_tmp(1:N_states_diag_save) = CI_electronic_energy_dressed(1:N_states_diag_save) - CI_eigenvectors_tmp(1:N_det,1:N_states_diag_save) = CI_eigenvectors_dressed(1:N_det,1:N_states_diag_save) - CI_s2_tmp(1:N_states_diag_save) = CI_eigenvectors_s2_dressed(1:N_states_diag_save) - - call davidson_diag_HS2(psi_det,CI_eigenvectors_tmp, CI_s2_tmp, & - size(CI_eigenvectors_tmp,1),CI_electronic_energy_tmp, & - N_det,min(N_det,N_states),min(N_det,N_states_diag),N_int,1,converged) - - CI_electronic_energy_dressed(1:N_states_diag_save) = CI_electronic_energy_tmp(1:N_states_diag_save) - CI_eigenvectors_dressed(1:N_det,1:N_states_diag_save) = CI_eigenvectors_tmp(1:N_det,1:N_states_diag_save) - CI_eigenvectors_s2_dressed(1:N_states_diag_save) = CI_s2_tmp(1:N_states_diag_save) - - deallocate (CI_electronic_energy_tmp) - deallocate (CI_eigenvectors_tmp) - deallocate (CI_s2_tmp) - - endif - - enddo - if (N_states_diag > N_states_diag_save) then - N_states_diag = N_states_diag_save - TOUCH N_states_diag - endif - - else if (diag_algorithm == "Lapack") then - - print *, 'Diagonalization of H using Lapack' - allocate (eigenvectors(size(H_matrix_dressed,1),N_det)) - allocate (eigenvalues(N_det)) - - call lapack_diag(eigenvalues,eigenvectors, & - H_matrix_dressed,size(H_matrix_dressed,1),N_det) - CI_electronic_energy_dressed(:) = 0.d0 - if (s2_eig) then - i_state = 0 - allocate (s2_eigvalues(N_det)) - allocate(index_good_state_array(N_det),good_state_array(N_det)) - good_state_array = .False. - - call u_0_S2_u_0(s2_eigvalues,eigenvectors,N_det,psi_det,N_int,& - N_det,size(eigenvectors,1)) - do j=1,N_det - ! Select at least n_states states with S^2 values closed to "expected_s2" - if(dabs(s2_eigvalues(j)-expected_s2).le.0.5d0)then - i_state +=1 - index_good_state_array(i_state) = j - good_state_array(j) = .True. - endif - if(i_state.eq.N_states) then - exit - endif - enddo - if(i_state .ne.0)then - ! Fill the first "i_state" states that have a correct S^2 value - do j = 1, i_state - do i=1,N_det - CI_eigenvectors_dressed(i,j) = eigenvectors(i,index_good_state_array(j)) - enddo - CI_electronic_energy_dressed(j) = eigenvalues(index_good_state_array(j)) - CI_eigenvectors_s2_dressed(j) = s2_eigvalues(index_good_state_array(j)) - enddo - i_other_state = 0 - do j = 1, N_det - if(good_state_array(j))cycle - i_other_state +=1 - if(i_state+i_other_state.gt.n_states_diag)then - exit - endif - do i=1,N_det - CI_eigenvectors_dressed(i,i_state+i_other_state) = eigenvectors(i,j) - enddo - CI_electronic_energy_dressed(i_state+i_other_state) = eigenvalues(j) - CI_eigenvectors_s2_dressed(i_state+i_other_state) = s2_eigvalues(i_state+i_other_state) - enddo - else - print*,'' - print*,'!!!!!!!! WARNING !!!!!!!!!' - print*,' Within the ',N_det,'determinants selected' - print*,' and the ',N_states_diag,'states requested' - print*,' We did not find any state with S^2 values close to ',expected_s2 - print*,' We will then set the first N_states eigenvectors of the H matrix' - print*,' as the CI_eigenvectors_dressed' - print*,' You should consider more states and maybe ask for s2_eig to be .True. or just enlarge the CI space' - print*,'' - do j=1,min(N_states_diag,N_det) - do i=1,N_det - CI_eigenvectors_dressed(i,j) = eigenvectors(i,j) - enddo - CI_electronic_energy_dressed(j) = eigenvalues(j) - CI_eigenvectors_s2_dressed(j) = s2_eigvalues(j) - enddo - endif - deallocate(index_good_state_array,good_state_array) - deallocate(s2_eigvalues) - else - call u_0_S2_u_0(CI_eigenvectors_s2_dressed,eigenvectors,N_det,psi_det,N_int,& - min(N_det,N_states_diag),size(eigenvectors,1)) - ! Select the "N_states_diag" states of lowest energy - do j=1,min(N_det,N_states_diag) - do i=1,N_det - CI_eigenvectors_dressed(i,j) = eigenvectors(i,j) - enddo - CI_electronic_energy_dressed(j) = eigenvalues(j) - enddo - endif - deallocate(eigenvectors,eigenvalues) - endif + deallocate(eigenvectors,eigenvalues) + endif END_PROVIDER diff --git a/src/determinants/EZFIO.cfg b/src/determinants/EZFIO.cfg index 9eefa66c..662c6fbb 100644 --- a/src/determinants/EZFIO.cfg +++ b/src/determinants/EZFIO.cfg @@ -42,13 +42,13 @@ default: 2 [weight_selection] type: integer -doc: Weight used in the selection. 0: input state-average weight, 1: 1./(c_0^2), 2: PT2 matching, 3: variance matching, 4: variance and PT2 matching, 5: variance minimization and matching, 6: CI coefficients 7: input state-average multiplied by variance and PT2 matching 8: input state-average multiplied by PT2 matching 9: input state-average multiplied by variance matching +doc: Weight used in the selection. 0: input state-average weight, 1: 1./(c_0^2), 2: rPT2 matching, 3: variance matching, 4: variance and rPT2 matching, 5: variance minimization and matching, 6: CI coefficients 7: input state-average multiplied by variance and rPT2 matching 8: input state-average multiplied by rPT2 matching 9: input state-average multiplied by variance matching interface: ezfio,provider,ocaml default: 1 [threshold_generators] type: Threshold -doc: Thresholds on generators (fraction of the square of the norm) +doc: Thresholds on generators (fraction of the square of the norm) interface: ezfio,provider,ocaml default: 0.999 @@ -80,7 +80,7 @@ type: integer [psi_coef] interface: ezfio doc: Coefficients of the wave function -type: double precision +type: double precision size: (determinants.n_det,determinants.n_states) [psi_det] @@ -92,7 +92,7 @@ size: (determinants.n_int*determinants.bit_kind/8,2,determinants.n_det) [psi_coef_qp_edit] interface: ezfio doc: Coefficients of the wave function -type: double precision +type: double precision size: (determinants.n_det_qp_edit,determinants.n_states) [psi_det_qp_edit] @@ -126,18 +126,13 @@ default: 1. [thresh_sym] type: Threshold -doc: Thresholds to check if a determinant is connected with HF +doc: Thresholds to check if a determinant is connected with HF interface: ezfio,provider,ocaml default: 1.e-15 [pseudo_sym] type: logical -doc: If |true|, discard any Slater determinants with an interaction smaller than thresh_sym with HF. +doc: If |true|, discard any Slater determinants with an interaction smaller than thresh_sym with HF. interface: ezfio,provider,ocaml default: False -[save_threshold] -type: Threshold -doc: Cut-off to apply to the CI coefficients when the wave function is stored -interface: ezfio,provider,ocaml -default: 1.e-14 diff --git a/src/determinants/density_matrix.irp.f b/src/determinants/density_matrix.irp.f index 1a1d92b5..7c4a7fec 100644 --- a/src/determinants/density_matrix.irp.f +++ b/src/determinants/density_matrix.irp.f @@ -262,86 +262,17 @@ subroutine set_natural_mos iorb = list_virt(i) do j = 1, n_core_inact_act_orb jorb = list_core_inact_act(j) + if(one_e_dm_mo(iorb,jorb).ne. 0.d0)then + print*,'AHAHAH' + print*,iorb,jorb,one_e_dm_mo(iorb,jorb) + stop + endif enddo enddo call mo_as_svd_vectors_of_mo_matrix_eig(one_e_dm_mo,size(one_e_dm_mo,1),mo_num,mo_num,mo_occ,label) soft_touch mo_occ + end - - -subroutine save_natural_mos_canon_label - implicit none - BEGIN_DOC - ! Save natural orbitals, obtained by diagonalization of the one-body density matrix in - ! the |MO| basis - END_DOC - call set_natural_mos_canon_label - call nullify_small_elements(ao_num,mo_num,mo_coef,size(mo_coef,1),1.d-10) - call orthonormalize_mos - call save_mos -end - -subroutine set_natural_mos_canon_label - implicit none - BEGIN_DOC - ! Set natural orbitals, obtained by diagonalization of the one-body density matrix - ! in the |MO| basis - END_DOC - character*(64) :: label - double precision, allocatable :: tmp(:,:) - - label = "Canonical" - integer :: i,j,iorb,jorb - do i = 1, n_virt_orb - iorb = list_virt(i) - do j = 1, n_core_inact_act_orb - jorb = list_core_inact_act(j) - enddo - enddo - call mo_as_svd_vectors_of_mo_matrix_eig(one_e_dm_mo,size(one_e_dm_mo,1),mo_num,mo_num,mo_occ,label) - soft_touch mo_occ -end - - - - - -subroutine set_natorb_no_ov_rot - implicit none - BEGIN_DOC - ! Set natural orbitals, obtained by diagonalization of the one-body density matrix - ! in the |MO| basis - END_DOC - character*(64) :: label - double precision, allocatable :: tmp(:,:) - allocate(tmp(mo_num, mo_num)) - label = "Natural" - tmp = one_e_dm_mo - integer :: i,j,iorb,jorb - do i = 1, n_virt_orb - iorb = list_virt(i) - do j = 1, n_core_inact_act_orb - jorb = list_core_inact_act(j) - tmp(iorb, jorb) = 0.d0 - tmp(jorb, iorb) = 0.d0 - enddo - enddo - call mo_as_svd_vectors_of_mo_matrix_eig(tmp,size(tmp,1),mo_num,mo_num,mo_occ,label) - soft_touch mo_occ -end - -subroutine save_natural_mos_no_ov_rot - implicit none - BEGIN_DOC - ! Save natural orbitals, obtained by diagonalization of the one-body density matrix in - ! the |MO| basis - END_DOC - call set_natorb_no_ov_rot - call nullify_small_elements(ao_num,mo_num,mo_coef,size(mo_coef,1),1.d-10) - call orthonormalize_mos - call save_mos -end - subroutine save_natural_mos implicit none BEGIN_DOC @@ -368,12 +299,12 @@ BEGIN_PROVIDER [ double precision, c0_weight, (N_states) ] c = maxval(psi_coef(:,i) * psi_coef(:,i)) c0_weight(i) = 1.d0/(c+1.d-20) enddo - c = 1.d0/sum(c0_weight(:)) + c = 1.d0/minval(c0_weight(:)) do i=1,N_states c0_weight(i) = c0_weight(i) * c enddo else - c0_weight(:) = 1.d0 + c0_weight = 1.d0 endif END_PROVIDER @@ -390,7 +321,7 @@ BEGIN_PROVIDER [ double precision, state_average_weight, (N_states) ] if (weight_one_e_dm == 0) then state_average_weight(:) = c0_weight(:) else if (weight_one_e_dm == 1) then - state_average_weight(:) = 1.d0/N_states + state_average_weight(:) = 1./N_states else call ezfio_has_determinants_state_average_weight(exists) if (exists) then @@ -453,14 +384,6 @@ END_PROVIDER END_PROVIDER -BEGIN_PROVIDER [ double precision, one_e_dm_ao, (ao_num, ao_num)] - implicit none - BEGIN_DOC - ! one_e_dm_ao = one_e_dm_ao_alpha + one_e_dm_ao_beta - END_DOC - one_e_dm_ao = one_e_dm_ao_alpha + one_e_dm_ao_beta -END_PROVIDER - subroutine get_occupation_from_dets(istate,occupation) implicit none diff --git a/src/determinants/determinants.irp.f b/src/determinants/determinants.irp.f index e1c14bfe..5b12a6d9 100644 --- a/src/determinants/determinants.irp.f +++ b/src/determinants/determinants.irp.f @@ -77,31 +77,28 @@ BEGIN_PROVIDER [ integer, psi_det_size ] END_DOC PROVIDE ezfio_filename logical :: exists - psi_det_size = N_states - PROVIDE mpi_master - if (read_wf) then - if (mpi_master) then - call ezfio_has_determinants_n_det(exists) - if (exists) then - call ezfio_get_determinants_n_det(psi_det_size) - else - psi_det_size = N_states - endif - call write_int(6,psi_det_size,'Dimension of the psi arrays') + if (mpi_master) then + call ezfio_has_determinants_n_det(exists) + if (exists) then + call ezfio_get_determinants_n_det(psi_det_size) + else + psi_det_size = 1 endif - IRP_IF MPI_DEBUG - print *, irp_here, mpi_rank - call MPI_BARRIER(MPI_COMM_WORLD, ierr) - IRP_ENDIF - IRP_IF MPI - include 'mpif.h' - integer :: ierr - call MPI_BCAST( psi_det_size, 1, MPI_INTEGER, 0, MPI_COMM_WORLD, ierr) - if (ierr /= MPI_SUCCESS) then - stop 'Unable to read psi_det_size with MPI' - endif - IRP_ENDIF + call write_int(6,psi_det_size,'Dimension of the psi arrays') endif + IRP_IF MPI_DEBUG + print *, irp_here, mpi_rank + call MPI_BARRIER(MPI_COMM_WORLD, ierr) + IRP_ENDIF + IRP_IF MPI + include 'mpif.h' + integer :: ierr + call MPI_BCAST( psi_det_size, 1, MPI_INTEGER, 0, MPI_COMM_WORLD, ierr) + if (ierr /= MPI_SUCCESS) then + stop 'Unable to read psi_det_size with MPI' + endif + IRP_ENDIF + END_PROVIDER @@ -542,7 +539,7 @@ subroutine save_wavefunction_general(ndet,nstates,psidet,dim_psicoef,psicoef) integer :: i,j,k, ndet_qp_edit if (mpi_master) then - ndet_qp_edit = min(ndet,10000) + ndet_qp_edit = min(ndet,N_det_qp_edit) call ezfio_set_determinants_N_int(N_int) call ezfio_set_determinants_bit_kind(bit_kind) @@ -590,6 +587,71 @@ subroutine save_wavefunction_general(ndet,nstates,psidet,dim_psicoef,psicoef) end +subroutine save_wavefunction_general_unormalized(ndet,nstates,psidet,dim_psicoef,psicoef) + implicit none + BEGIN_DOC + ! Save the wave function into the |EZFIO| file + END_DOC + use bitmasks + include 'constants.include.F' + integer, intent(in) :: ndet,nstates,dim_psicoef + integer(bit_kind), intent(in) :: psidet(N_int,2,ndet) + double precision, intent(in) :: psicoef(dim_psicoef,nstates) + integer*8, allocatable :: psi_det_save(:,:,:) + double precision, allocatable :: psi_coef_save(:,:) + + double precision :: accu_norm + integer :: i,j,k, ndet_qp_edit + + if (mpi_master) then + ndet_qp_edit = min(ndet,N_det_qp_edit) + + call ezfio_set_determinants_N_int(N_int) + call ezfio_set_determinants_bit_kind(bit_kind) + call ezfio_set_determinants_N_det(ndet) + call ezfio_set_determinants_N_det_qp_edit(ndet_qp_edit) + call ezfio_set_determinants_n_states(nstates) + call ezfio_set_determinants_mo_label(mo_label) + + allocate (psi_det_save(N_int,2,ndet)) + do i=1,ndet + do j=1,2 + do k=1,N_int + psi_det_save(k,j,i) = transfer(psidet(k,j,i),1_8) + enddo + enddo + enddo + call ezfio_set_determinants_psi_det(psi_det_save) + call ezfio_set_determinants_psi_det_qp_edit(psi_det_save) + deallocate (psi_det_save) + + allocate (psi_coef_save(ndet,nstates)) + do k=1,nstates + do i=1,ndet + psi_coef_save(i,k) = psicoef(i,k) + enddo + enddo + + call ezfio_set_determinants_psi_coef(psi_coef_save) + deallocate (psi_coef_save) + + allocate (psi_coef_save(ndet_qp_edit,nstates)) + do k=1,nstates + do i=1,ndet_qp_edit + psi_coef_save(i,k) = psicoef(i,k) + enddo + enddo + + call ezfio_set_determinants_psi_coef_qp_edit(psi_coef_save) + deallocate (psi_coef_save) + + call write_int(6,ndet,'Saved determinants') + endif +end + + + + subroutine save_wavefunction_specified(ndet,nstates,psidet,psicoef,ndetsave,index_det_save) implicit none diff --git a/src/determinants/dipole_moments.irp.f b/src/determinants/dipole_moments.irp.f index b411dda4..8a5f1a2d 100644 --- a/src/determinants/dipole_moments.irp.f +++ b/src/determinants/dipole_moments.irp.f @@ -9,7 +9,7 @@ double precision :: weight, r(3) double precision :: cpu0,cpu1,nuclei_part_z,nuclei_part_y,nuclei_part_x -! call cpu_time(cpu0) + call cpu_time(cpu0) z_dipole_moment = 0.d0 y_dipole_moment = 0.d0 x_dipole_moment = 0.d0 @@ -26,10 +26,10 @@ enddo enddo -! print*,'electron part for z_dipole = ',z_dipole_moment -! print*,'electron part for y_dipole = ',y_dipole_moment -! print*,'electron part for x_dipole = ',x_dipole_moment -! + print*,'electron part for z_dipole = ',z_dipole_moment + print*,'electron part for y_dipole = ',y_dipole_moment + print*,'electron part for x_dipole = ',x_dipole_moment + nuclei_part_z = 0.d0 nuclei_part_y = 0.d0 nuclei_part_x = 0.d0 @@ -38,43 +38,28 @@ nuclei_part_y += nucl_charge(i) * nucl_coord(i,2) nuclei_part_x += nucl_charge(i) * nucl_coord(i,1) enddo -! print*,'nuclei part for z_dipole = ',nuclei_part_z -! print*,'nuclei part for y_dipole = ',nuclei_part_y -! print*,'nuclei part for x_dipole = ',nuclei_part_x -! + print*,'nuclei part for z_dipole = ',nuclei_part_z + print*,'nuclei part for y_dipole = ',nuclei_part_y + print*,'nuclei part for x_dipole = ',nuclei_part_x + do istate = 1, N_states z_dipole_moment(istate) += nuclei_part_z y_dipole_moment(istate) += nuclei_part_y x_dipole_moment(istate) += nuclei_part_x enddo -! call cpu_time(cpu1) -! print*,'Time to provide the dipole moment :',cpu1-cpu0 + call cpu_time(cpu1) + print*,'Time to provide the dipole moment :',cpu1-cpu0 END_PROVIDER - subroutine print_dipole_moments + subroutine print_z_dipole_moment_only implicit none - integer :: i print*, '' print*, '' print*, '****************************************' - write(*,'(A10)',advance='no') ' State : ' - do i = 1,N_states - write(*,'(i16)',advance='no') i - end do - write(*,*) '' - write(*,'(A23,100(1pE16.8))') 'x_dipole_moment (au) = ',x_dipole_moment - write(*,'(A23,100(1pE16.8))') 'y_dipole_moment (au) = ',y_dipole_moment - write(*,'(A23,100(1pE16.8))') 'z_dipole_moment (au) = ',z_dipole_moment - write(*,*) '' - write(*,'(A23,100(1pE16.8))') 'x_dipole_moment (D) = ',x_dipole_moment * au_to_D - write(*,'(A23,100(1pE16.8))') 'y_dipole_moment (D) = ',y_dipole_moment * au_to_D - write(*,'(A23,100(1pE16.8))') 'z_dipole_moment (D) = ',z_dipole_moment * au_to_D - !print*, 'x_dipole_moment = ',x_dipole_moment - !print*, 'y_dipole_moment = ',y_dipole_moment - !print*, 'z_dipole_moment = ',z_dipole_moment + print*, 'z_dipole_moment = ',z_dipole_moment print*, '****************************************' end diff --git a/src/determinants/h_apply.irp.f b/src/determinants/h_apply.irp.f index d01ad1c7..98fafb4a 100644 --- a/src/determinants/h_apply.irp.f +++ b/src/determinants/h_apply.irp.f @@ -322,7 +322,10 @@ subroutine fill_H_apply_buffer_no_selection(n_selected,det_buffer,Nint,iproc) ASSERT (sum(popcnt(H_apply_buffer(iproc)%det(:,2,i))) == elec_beta_num) enddo do i=1,n_selected - H_apply_buffer(iproc)%det(:,:,i+H_apply_buffer(iproc)%N_det) = det_buffer(:,:,i) + do j=1,N_int + H_apply_buffer(iproc)%det(j,1,i+H_apply_buffer(iproc)%N_det) = det_buffer(j,1,i) + H_apply_buffer(iproc)%det(j,2,i+H_apply_buffer(iproc)%N_det) = det_buffer(j,2,i) + enddo ASSERT (sum(popcnt(H_apply_buffer(iproc)%det(:,1,i+H_apply_buffer(iproc)%N_det)) )== elec_alpha_num) ASSERT (sum(popcnt(H_apply_buffer(iproc)%det(:,2,i+H_apply_buffer(iproc)%N_det))) == elec_beta_num) enddo diff --git a/src/determinants/s2.irp.f b/src/determinants/s2.irp.f index 2c1a8757..d73b2dbf 100644 --- a/src/determinants/s2.irp.f +++ b/src/determinants/s2.irp.f @@ -103,17 +103,13 @@ BEGIN_PROVIDER [ double precision, expected_s2] END_PROVIDER - BEGIN_PROVIDER [ double precision, s2_values, (N_states) ] -&BEGIN_PROVIDER [ double precision, s_values, (N_states) ] +BEGIN_PROVIDER [ double precision, s2_values, (N_states) ] implicit none BEGIN_DOC ! array of the averaged values of the S^2 operator on the various states END_DOC integer :: i call u_0_S2_u_0(s2_values,psi_coef,n_det,psi_det,N_int,N_states,psi_det_size) - do i = 1, N_states - s_values(i) = 0.5d0 *(-1.d0 + dsqrt(1.d0 + 4 * s2_values(i))) - enddo END_PROVIDER diff --git a/src/determinants/slater_rules.irp.f b/src/determinants/slater_rules.irp.f index 897607a9..04cf861f 100644 --- a/src/determinants/slater_rules.irp.f +++ b/src/determinants/slater_rules.irp.f @@ -438,7 +438,7 @@ subroutine bitstring_to_list_ab( string, list, n_elements, Nint) use bitmasks implicit none BEGIN_DOC - ! Gives the indices(+1) of the bits set to 1 in the bit string + ! Gives the inidices(+1) of the bits set to 1 in the bit string ! For alpha/beta determinants. END_DOC integer, intent(in) :: Nint @@ -472,35 +472,6 @@ subroutine bitstring_to_list_ab( string, list, n_elements, Nint) end -!subroutine bitstring_to_list( string, list, n_elements, Nint) -! use bitmasks -! implicit none -! BEGIN_DOC -! ! Gives the indices(+1) of the bits set to 1 in the bit string -! END_DOC -! integer, intent(in) :: Nint -! integer(bit_kind), intent(in) :: string(Nint) -! integer, intent(out) :: list(Nint*bit_kind_size) -! integer, intent(out) :: n_elements -! -! integer :: i, j, ishift -! integer(bit_kind) :: l -! -! n_elements = 0 -! ishift = 1 -! do i=1,Nint -! l = string(i) -! do while (l /= 0_bit_kind) -! j = trailz(l) -! n_elements = n_elements + 1 -! l = ibclr(l,j) -! list(n_elements) = ishift+j -! enddo -! ishift = ishift + bit_kind_size -! enddo -! -!end - subroutine i_H_j_s2(key_i,key_j,Nint,hij,s2) use bitmasks @@ -623,8 +594,7 @@ subroutine i_H_j(key_i,key_j,Nint,hij) integer :: occ(Nint*bit_kind_size,2) double precision :: diag_H_mat_elem, phase integer :: n_occ_ab(2) - PROVIDE mo_two_e_integrals_in_map mo_integrals_map big_array_exchange_integrals - PROVIDE ao_one_e_integrals mo_one_e_integrals + PROVIDE mo_two_e_integrals_in_map mo_integrals_map big_array_exchange_integrals ASSERT (Nint > 0) ASSERT (Nint == N_int) @@ -682,6 +652,7 @@ subroutine i_H_j(key_i,key_j,Nint,hij) case (1) call get_single_excitation(key_i,key_j,exc,phase,Nint) !DIR$ FORCEINLINE + call bitstring_to_list_ab(key_i, occ, n_occ_ab, Nint) if (exc(0,1,1) == 1) then ! Single alpha m = exc(1,1,1) @@ -700,6 +671,10 @@ subroutine i_H_j(key_i,key_j,Nint,hij) end select end + + + + subroutine i_H_j_verbose(key_i,key_j,Nint,hij,hmono,hdouble,phase) use bitmasks implicit none @@ -1034,6 +1009,7 @@ subroutine i_H_psi(key,keys,coef,Nint,Ndet,Ndet_max,Nstate,i_H_psi_array) end + subroutine i_H_psi_minilist(key,keys,idx_key,N_minilist,coef,Nint,Ndet,Ndet_max,Nstate,i_H_psi_array) use bitmasks implicit none diff --git a/src/determinants/slater_rules_wee_mono.irp.f b/src/determinants/slater_rules_wee_mono.irp.f index 7c2ad148..4c1c9330 100644 --- a/src/determinants/slater_rules_wee_mono.irp.f +++ b/src/determinants/slater_rules_wee_mono.irp.f @@ -282,7 +282,9 @@ subroutine i_H_j_two_e(key_i,key_j,Nint,hij) double precision :: get_two_e_integral integer :: m,n,p,q integer :: i,j,k + integer :: occ(Nint*bit_kind_size,2) double precision :: diag_H_mat_elem, phase,phase_2 + integer :: n_occ_ab(2) PROVIDE mo_two_e_integrals_in_map mo_integrals_map big_array_exchange_integrals ref_bitmask_two_e_energy ASSERT (Nint > 0) @@ -340,6 +342,7 @@ subroutine i_H_j_two_e(key_i,key_j,Nint,hij) case (1) call get_single_excitation(key_i,key_j,exc,phase,Nint) !DIR$ FORCEINLINE + call bitstring_to_list_ab(key_i, occ, n_occ_ab, Nint) if (exc(0,1,1) == 1) then ! Mono alpha m = exc(1,1,1) diff --git a/src/determinants/spindeterminants.ezfio_config b/src/determinants/spindeterminants.ezfio_config index 39ccb82b..dd4c9b0c 100644 --- a/src/determinants/spindeterminants.ezfio_config +++ b/src/determinants/spindeterminants.ezfio_config @@ -11,6 +11,8 @@ spindeterminants psi_coef_matrix_columns integer (spindeterminants_n_det) psi_coef_matrix_values double precision (spindeterminants_n_det,spindeterminants_n_states) n_svd_coefs integer + n_svd_alpha integer + n_svd_beta integer psi_svd_alpha double precision (spindeterminants_n_det_alpha,spindeterminants_n_svd_coefs,spindeterminants_n_states) psi_svd_beta double precision (spindeterminants_n_det_beta,spindeterminants_n_svd_coefs,spindeterminants_n_states) psi_svd_coefs double precision (spindeterminants_n_svd_coefs,spindeterminants_n_states) diff --git a/src/determinants/spindeterminants.irp.f b/src/determinants/spindeterminants.irp.f index dd55e112..dea4a566 100644 --- a/src/determinants/spindeterminants.irp.f +++ b/src/determinants/spindeterminants.irp.f @@ -585,7 +585,7 @@ END_PROVIDER enddo !$OMP ENDDO !$OMP END PARALLEL - call i8sort(to_sort, psi_bilinear_matrix_transp_order, N_det) + call i8radix_sort(to_sort, psi_bilinear_matrix_transp_order, N_det,-1) call iset_order(psi_bilinear_matrix_transp_rows,psi_bilinear_matrix_transp_order,N_det) call iset_order(psi_bilinear_matrix_transp_columns,psi_bilinear_matrix_transp_order,N_det) !$OMP PARALLEL DO DEFAULT(SHARED) PRIVATE(l) diff --git a/src/determinants/utils.irp.f b/src/determinants/utils.irp.f index 7b75d985..957e74d5 100644 --- a/src/determinants/utils.irp.f +++ b/src/determinants/utils.irp.f @@ -6,10 +6,9 @@ BEGIN_PROVIDER [ double precision, H_matrix_all_dets,(N_det,N_det) ] END_DOC integer :: i,j,k double precision :: hij - integer :: degree(N_det),idx(0:N_det) call i_H_j(psi_det(1,1,1),psi_det(1,1,1),N_int,hij) print*,'Providing the H_matrix_all_dets ...' - !$OMP PARALLEL DO SCHEDULE(GUIDED) DEFAULT(NONE) PRIVATE(i,j,hij,degree,idx,k) & + !$OMP PARALLEL DO SCHEDULE(GUIDED) DEFAULT(NONE) PRIVATE(i,j,hij,k) & !$OMP SHARED (N_det, psi_det, N_int,H_matrix_all_dets) do i =1,N_det do j = i, N_det @@ -30,15 +29,16 @@ BEGIN_PROVIDER [ double precision, H_matrix_diag_all_dets,(N_det) ] END_DOC integer :: i double precision :: hij - integer :: degree(N_det) + call i_H_j(psi_det(1,1,1),psi_det(1,1,1),N_int,hij) - !$OMP PARALLEL DO SCHEDULE(GUIDED) DEFAULT(NONE) PRIVATE(i,hij,degree) & + !$OMP PARALLEL DO SCHEDULE(GUIDED) DEFAULT(NONE) PRIVATE(i,hij) & !$OMP SHARED (N_det, psi_det, N_int,H_matrix_diag_all_dets) do i =1,N_det call i_H_j(psi_det(1,1,i),psi_det(1,1,i),N_int,hij) H_matrix_diag_all_dets(i) = hij enddo !$OMP END PARALLEL DO + END_PROVIDER @@ -50,9 +50,8 @@ BEGIN_PROVIDER [ double precision, S2_matrix_all_dets,(N_det,N_det) ] END_DOC integer :: i,j,k double precision :: sij - integer :: degree(N_det),idx(0:N_det) call get_s2(psi_det(1,1,1),psi_det(1,1,1),N_int,sij) - !$OMP PARALLEL DO SCHEDULE(GUIDED) DEFAULT(NONE) PRIVATE(i,j,sij,degree,idx,k) & + !$OMP PARALLEL DO SCHEDULE(GUIDED) DEFAULT(NONE) PRIVATE(i,j,sij,k) & !$OMP SHARED (N_det, psi_det, N_int,S2_matrix_all_dets) do i =1,N_det do j = i, N_det @@ -63,4 +62,3 @@ BEGIN_PROVIDER [ double precision, S2_matrix_all_dets,(N_det,N_det) ] enddo !$OMP END PARALLEL DO END_PROVIDER - diff --git a/src/dft_one_e/NEED b/src/dft_one_e/NEED index 615ee97e..3a942f28 100644 --- a/src/dft_one_e/NEED +++ b/src/dft_one_e/NEED @@ -6,4 +6,3 @@ ao_one_e_ints ao_two_e_ints mo_two_e_erf_ints ao_two_e_erf_ints -mu_of_r diff --git a/src/dft_one_e/mu_erf_dft.irp.f b/src/dft_one_e/mu_erf_dft.irp.f index 0b870564..53effcb6 100644 --- a/src/dft_one_e/mu_erf_dft.irp.f +++ b/src/dft_one_e/mu_erf_dft.irp.f @@ -8,73 +8,3 @@ BEGIN_PROVIDER [double precision, mu_erf_dft] mu_erf_dft = mu_erf END_PROVIDER - -BEGIN_PROVIDER [double precision, mu_of_r_dft, (n_points_final_grid)] - implicit none - integer :: i - if(mu_dft_type == "Read")then - call ezfio_get_mu_of_r_mu_of_r_disk(mu_of_r_dft) - else - do i = 1, n_points_final_grid - if(mu_dft_type == "cst")then - mu_of_r_dft(i) = mu_erf_dft - else if(mu_dft_type == "hf")then - mu_of_r_dft(i) = mu_of_r_hf(i) - else if(mu_dft_type == "rsc")then - mu_of_r_dft(i) = mu_rsc_of_r(i) - else if(mu_dft_type == "grad_rho")then - mu_of_r_dft(i) = mu_grad_rho(i) - else - print*,'mu_dft_type is not of good type = ',mu_dft_type - print*,'it must be of type Read, cst, hf, rsc' - print*,'Stopping ...' - stop - endif - enddo - endif -END_PROVIDER - -BEGIN_PROVIDER [double precision, mu_rsc_of_r, (n_points_final_grid)] - implicit none - integer :: i - double precision :: mu_rs_c,rho,r(3), dm_a, dm_b - do i = 1, n_points_final_grid - r(1) = final_grid_points(1,i) - r(2) = final_grid_points(2,i) - r(3) = final_grid_points(3,i) - call dm_dft_alpha_beta_at_r(r,dm_a,dm_b) - rho = dm_a + dm_b - mu_rsc_of_r(i) = mu_rs_c(rho) - enddo -END_PROVIDER - -BEGIN_PROVIDER [double precision, mu_grad_rho, (n_points_final_grid)] - implicit none - integer :: i - double precision :: mu_grad_rho_func, r(3) - do i = 1, n_points_final_grid - r(1) = final_grid_points(1,i) - r(2) = final_grid_points(2,i) - r(3) = final_grid_points(3,i) - mu_grad_rho(i) = mu_grad_rho_func(r) - enddo -END_PROVIDER - - -BEGIN_PROVIDER [double precision, mu_of_r_dft_average] - implicit none - integer :: i - double precision :: mu_rs_c,rho,r(3), dm_a, dm_b - mu_of_r_dft_average = 0.d0 - do i = 1, n_points_final_grid - r(1) = final_grid_points(1,i) - r(2) = final_grid_points(2,i) - r(3) = final_grid_points(3,i) - call dm_dft_alpha_beta_at_r(r,dm_a,dm_b) - rho = dm_a + dm_b - if(mu_of_r_dft(i).gt.1.d+3)cycle - mu_of_r_dft_average += rho * mu_of_r_dft(i) * final_weight_at_r_vector(i) - enddo - mu_of_r_dft_average = mu_of_r_dft_average / dble(elec_alpha_num + elec_beta_num) - print*,'mu_of_r_dft_average = ',mu_of_r_dft_average -END_PROVIDER diff --git a/src/dft_utils_func/mu_of_r_dft.irp.f b/src/dft_utils_func/mu_of_r_dft.irp.f deleted file mode 100644 index 0e9a0f1b..00000000 --- a/src/dft_utils_func/mu_of_r_dft.irp.f +++ /dev/null @@ -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 diff --git a/src/dft_utils_func/mu_rsc.irp.f b/src/dft_utils_func/mu_rsc.irp.f new file mode 100644 index 00000000..cda444d4 --- /dev/null +++ b/src/dft_utils_func/mu_rsc.irp.f @@ -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 + diff --git a/src/dft_utils_func/on_top_from_ueg.irp.f b/src/dft_utils_func/on_top_from_ueg.irp.f index 5b964a03..717081a7 100644 --- a/src/dft_utils_func/on_top_from_ueg.irp.f +++ b/src/dft_utils_func/on_top_from_ueg.irp.f @@ -37,15 +37,13 @@ double precision function g0_UEG_mu_inf(rho_a,rho_b) rs = (3d0 / (4d0*pi*rho))**(1d0/3d0) ! JT: serious bug fixed 20/03/19 x = -d2*rs if(dabs(x).lt.50.d0)then -! g0_UEG_mu_inf= 0.5d0 * (1d0- B*rs + C*rs**2 + D*rs**3 + E*rs**4)*dexp(x) - g0_UEG_mu_inf= 0.5d0 * (1d0+ rs* (-B + rs*(C + rs*(D + rs*E))))*dexp(x) + g0_UEG_mu_inf= 0.5d0 * (1d0- B*rs + C*rs**2 + D*rs**3 + E*rs**4)*dexp(x) else g0_UEG_mu_inf= 0.d0 endif else g0_UEG_mu_inf= 0.d0 endif - g0_UEG_mu_inf = max(g0_UEG_mu_inf,1.d-14) end diff --git a/src/dft_utils_in_r/ao_in_r.irp.f b/src/dft_utils_in_r/ao_in_r.irp.f index 38478d21..6fa6a4c7 100644 --- a/src/dft_utils_in_r/ao_in_r.irp.f +++ b/src/dft_utils_in_r/ao_in_r.irp.f @@ -91,19 +91,7 @@ enddo END_PROVIDER - BEGIN_PROVIDER [double precision, aos_lapl_in_r_array_transp, (ao_num, n_points_final_grid,3)] - implicit none - integer :: i,j,m - do i = 1, n_points_final_grid - do j = 1, ao_num - do m = 1, 3 - aos_lapl_in_r_array_transp(j,i,m) = aos_lapl_in_r_array(m,j,i) - enddo - enddo - enddo - END_PROVIDER - - BEGIN_PROVIDER [double precision, aos_lapl_in_r_array, (3,ao_num,n_points_final_grid)] + BEGIN_PROVIDER[double precision, aos_lapl_in_r_array, (ao_num,n_points_final_grid,3)] implicit none BEGIN_DOC ! aos_lapl_in_r_array(i,j,k) = value of the kth component of the laplacian of jth ao on the ith grid point @@ -112,20 +100,20 @@ END_DOC integer :: i,j,m double precision :: aos_array(ao_num), r(3) - double precision :: aos_grad_array(3,ao_num) - double precision :: aos_lapl_array(3,ao_num) + double precision :: aos_grad_array(ao_num,3) + double precision :: aos_lapl_array(ao_num,3) !$OMP PARALLEL DO & !$OMP DEFAULT (NONE) & !$OMP PRIVATE (i,r,aos_array,aos_grad_array,aos_lapl_array,j,m) & !$OMP SHARED(aos_lapl_in_r_array,n_points_final_grid,ao_num,final_grid_points) - do i = 1, n_points_final_grid - r(1) = final_grid_points(1,i) - r(2) = final_grid_points(2,i) - r(3) = final_grid_points(3,i) - call give_all_aos_and_grad_and_lapl_at_r(r,aos_array,aos_grad_array,aos_lapl_array) - do j = 1, ao_num - do m = 1, 3 - aos_lapl_in_r_array(m,j,i) = aos_lapl_array(m,j) + do m = 1, 3 + do i = 1, n_points_final_grid + r(1) = final_grid_points(1,i) + r(2) = final_grid_points(2,i) + r(3) = final_grid_points(3,i) + call give_all_aos_and_grad_and_lapl_at_r(r,aos_array,aos_grad_array,aos_lapl_array) + do j = 1, ao_num + aos_lapl_in_r_array(j,i,m) = aos_lapl_array(j,m) enddo enddo enddo diff --git a/src/dft_utils_in_r/ints_grad.irp.f b/src/dft_utils_in_r/ints_grad.irp.f deleted file mode 100644 index 239fe554..00000000 --- a/src/dft_utils_in_r/ints_grad.irp.f +++ /dev/null @@ -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) = - 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) = - 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 diff --git a/src/dft_utils_in_r/mo_in_r.irp.f b/src/dft_utils_in_r/mo_in_r.irp.f index 192cb25a..0a8b4d52 100644 --- a/src/dft_utils_in_r/mo_in_r.irp.f +++ b/src/dft_utils_in_r/mo_in_r.irp.f @@ -138,7 +138,7 @@ integer :: m mos_lapl_in_r_array = 0.d0 do m=1,3 - call dgemm('N','N',mo_num,n_points_final_grid,ao_num,1.d0,mo_coef_transp,mo_num,aos_lapl_in_r_array_transp(1,1,m),ao_num,0.d0,mos_lapl_in_r_array(1,1,m),mo_num) + call dgemm('N','N',mo_num,n_points_final_grid,ao_num,1.d0,mo_coef_transp,mo_num,aos_lapl_in_r_array(1,1,m),ao_num,0.d0,mos_lapl_in_r_array(1,1,m),mo_num) enddo END_PROVIDER diff --git a/src/dressing/alpha_factory.irp.f b/src/dressing/alpha_factory.irp.f index c7adffe3..5eeeb1a6 100644 --- a/src/dressing/alpha_factory.irp.f +++ b/src/dressing/alpha_factory.irp.f @@ -1179,7 +1179,7 @@ subroutine bitstring_to_list_in_selection( string, list, n_elements, Nint) use bitmasks implicit none BEGIN_DOC - ! Gives the indices(+1) of the bits set to 1 in the bit string + ! Gives the inidices(+1) of the bits set to 1 in the bit string END_DOC integer, intent(in) :: Nint integer(bit_kind), intent(in) :: string(Nint) diff --git a/src/dressing/run_dress_slave.irp.f b/src/dressing/run_dress_slave.irp.f index 08b654c9..a33fb1dd 100644 --- a/src/dressing/run_dress_slave.irp.f +++ b/src/dressing/run_dress_slave.irp.f @@ -72,7 +72,7 @@ subroutine run_dress_slave(thread,iproce,energy) provide psi_energy ending = dress_N_cp+1 ntask_tbd = 0 - call set_multiple_levels_omp(.True.) + call omp_set_max_active_levels(8) !$OMP PARALLEL DEFAULT(SHARED) & !$OMP PRIVATE(interesting, breve_delta_m, task_id) & @@ -84,7 +84,7 @@ subroutine run_dress_slave(thread,iproce,energy) zmq_socket_push = new_zmq_push_socket(thread) integer, external :: connect_to_taskserver !$OMP CRITICAL - call set_multiple_levels_omp(.False.) + call omp_set_max_active_levels(1) if (connect_to_taskserver(zmq_to_qp_run_socket,worker_id,thread) == -1) then print *, irp_here, ': Unable to connect to task server' stop -1 @@ -296,7 +296,7 @@ subroutine run_dress_slave(thread,iproce,energy) !$OMP END CRITICAL !$OMP END PARALLEL - call set_multiple_levels_omp(.False.) + call omp_set_max_active_levels(1) ! do i=0,dress_N_cp+1 ! call omp_destroy_lock(lck_sto(i)) ! end do diff --git a/src/ezfio_files/output.irp.f b/src/ezfio_files/output.irp.f index 7b2663a0..48512f92 100644 --- a/src/ezfio_files/output.irp.f +++ b/src/ezfio_files/output.irp.f @@ -25,7 +25,7 @@ subroutine write_time(iunit) ct = ct - output_cpu_time_0 call wall_time(wt) 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 ] <<<<< ..' write(6,*) end diff --git a/src/functionals/sr_lda.irp.f b/src/functionals/sr_lda.irp.f index bd062a02..965a744c 100644 --- a/src/functionals/sr_lda.irp.f +++ b/src/functionals/sr_lda.irp.f @@ -21,9 +21,7 @@ weight = final_weight_at_r_vector(i) rhoa(istate) = one_e_dm_and_grad_alpha_in_r(4,i,istate) rhob(istate) = one_e_dm_and_grad_beta_in_r(4,i,istate) - double precision :: mu_local - mu_local = mu_of_r_dft(i) - call ex_lda_sr(mu_local,rhoa(istate),rhob(istate),e_x,vx_a,vx_b) + call ex_lda_sr(mu_erf_dft,rhoa(istate),rhob(istate),e_x,vx_a,vx_b) energy_x_sr_lda(istate) += weight * e_x enddo enddo @@ -50,9 +48,7 @@ weight = final_weight_at_r_vector(i) rhoa(istate) = one_e_dm_and_grad_alpha_in_r(4,i,istate) rhob(istate) = one_e_dm_and_grad_beta_in_r(4,i,istate) - double precision :: mu_local - mu_local = mu_of_r_dft(i) - call ec_lda_sr(mu_local,rhoa(istate),rhob(istate),e_c,vc_a,vc_b) + call ec_lda_sr(mu_erf_dft,rhoa(istate),rhob(istate),e_c,vc_a,vc_b) energy_c_sr_lda(istate) += weight * e_c enddo enddo @@ -126,10 +122,8 @@ END_PROVIDER weight = final_weight_at_r_vector(i) rhoa(istate) = one_e_dm_and_grad_alpha_in_r(4,i,istate) rhob(istate) = one_e_dm_and_grad_beta_in_r(4,i,istate) - double precision :: mu_local - mu_local = mu_of_r_dft(i) - call ec_lda_sr(mu_local,rhoa(istate),rhob(istate),e_c,sr_vc_a,sr_vc_b) - call ex_lda_sr(mu_local,rhoa(istate),rhob(istate),e_x,sr_vx_a,sr_vx_b) + call ec_lda_sr(mu_erf_dft,rhoa(istate),rhob(istate),e_c,sr_vc_a,sr_vc_b) + call ex_lda_sr(mu_erf_dft,rhoa(istate),rhob(istate),e_x,sr_vx_a,sr_vx_b) do j =1, ao_num aos_sr_vc_alpha_lda_w(j,i,istate) = sr_vc_a * aos_in_r_array(j,i)*weight aos_sr_vc_beta_lda_w(j,i,istate) = sr_vc_b * aos_in_r_array(j,i)*weight @@ -153,6 +147,8 @@ END_PROVIDER double precision :: mu,weight double precision :: e_c,sr_vc_a,sr_vc_b,e_x,sr_vx_a,sr_vx_b double precision, allocatable :: rhoa(:),rhob(:) + double precision :: mu_local + mu_local = mu_erf_dft allocate(rhoa(N_states), rhob(N_states)) do istate = 1, N_states do i = 1, n_points_final_grid @@ -162,8 +158,6 @@ END_PROVIDER weight = final_weight_at_r_vector(i) rhoa(istate) = one_e_dm_and_grad_alpha_in_r(4,i,istate) rhob(istate) = one_e_dm_and_grad_beta_in_r(4,i,istate) - double precision :: mu_local - mu_local = mu_of_r_dft(i) call ec_lda_sr(mu_local,rhoa(istate),rhob(istate),e_c,sr_vc_a,sr_vc_b) call ex_lda_sr(mu_local,rhoa(istate),rhob(istate),e_x,sr_vx_a,sr_vx_b) do j =1, ao_num diff --git a/src/functionals/sr_pbe.irp.f b/src/functionals/sr_pbe.irp.f index 7053cfb6..93c51067 100644 --- a/src/functionals/sr_pbe.irp.f +++ b/src/functionals/sr_pbe.irp.f @@ -35,11 +35,9 @@ grad_rho_b_2 += grad_rho_b(m) * grad_rho_b(m) grad_rho_a_b += grad_rho_a(m) * grad_rho_b(m) enddo - - double precision :: mu_local - mu_local = mu_of_r_dft(i) + ! inputs - call GGA_sr_type_functionals(mu_local,rho_a,rho_b,grad_rho_a_2,grad_rho_b_2,grad_rho_a_b, & ! outputs exchange + call GGA_sr_type_functionals(mu_erf_dft,rho_a,rho_b,grad_rho_a_2,grad_rho_b_2,grad_rho_a_b, & ! outputs exchange ex,vx_rho_a,vx_rho_b,vx_grad_rho_a_2,vx_grad_rho_b_2,vx_grad_rho_a_b, & ! outputs correlation ec,vc_rho_a,vc_rho_b,vc_grad_rho_a_2,vc_grad_rho_b_2,vc_grad_rho_a_b ) energy_x_sr_pbe(istate) += ex * weight @@ -137,10 +135,8 @@ END_PROVIDER grad_rho_a_b += grad_rho_a(m) * grad_rho_b(m) enddo - double precision :: mu_local - mu_local = mu_of_r_dft(i) ! inputs - call GGA_sr_type_functionals(mu_local,rho_a,rho_b,grad_rho_a_2,grad_rho_b_2,grad_rho_a_b, & ! outputs exchange + call GGA_sr_type_functionals(mu_erf_dft,rho_a,rho_b,grad_rho_a_2,grad_rho_b_2,grad_rho_a_b, & ! outputs exchange ex,vx_rho_a,vx_rho_b,vx_grad_rho_a_2,vx_grad_rho_b_2,vx_grad_rho_a_b, & ! outputs correlation ec,vc_rho_a,vc_rho_b,vc_grad_rho_a_2,vc_grad_rho_b_2,vc_grad_rho_a_b ) vx_rho_a *= weight @@ -296,10 +292,8 @@ END_PROVIDER grad_rho_a_b += grad_rho_a(m) * grad_rho_b(m) enddo - double precision :: mu_local - mu_local = mu_of_r_dft(i) ! inputs - call GGA_sr_type_functionals(mu_local,rho_a,rho_b,grad_rho_a_2,grad_rho_b_2,grad_rho_a_b, & ! outputs exchange + call GGA_sr_type_functionals(mu_erf_dft,rho_a,rho_b,grad_rho_a_2,grad_rho_b_2,grad_rho_a_b, & ! outputs exchange ex,vx_rho_a,vx_rho_b,vx_grad_rho_a_2,vx_grad_rho_b_2,vx_grad_rho_a_b, & ! outputs correlation ec,vc_rho_a,vc_rho_b,vc_grad_rho_a_2,vc_grad_rho_b_2,vc_grad_rho_a_b ) vx_rho_a *= weight diff --git a/src/iterations/print_extrapolation.irp.f b/src/iterations/print_extrapolation.irp.f index 7c6dbb9b..cb46fb67 100644 --- a/src/iterations/print_extrapolation.irp.f +++ b/src/iterations/print_extrapolation.irp.f @@ -35,13 +35,12 @@ subroutine print_extrapolated_energy do k=2,min(N_iter,8) write(*,'(F11.4,X,3(X,F18.8))') pt2_iterations(i,N_iter+1-k), extrapolated_energy(k,i), & extrapolated_energy(k,i) - extrapolated_energy(k,1), & - (extrapolated_energy(k,i) - extrapolated_energy(k,1) ) * ha_to_ev + (extrapolated_energy(k,i) - extrapolated_energy(k,1) ) * 27.211396641308d0 enddo write(*,*) '=========== ', '=================== ', '=================== ', '===================' enddo print *, '' - call ezfio_set_fci_energy_extrapolated(extrapolated_energy(min(N_iter,3),1:N_states)) end subroutine diff --git a/src/iterations/print_summary.irp.f b/src/iterations/print_summary.irp.f index a0db3534..641ee209 100644 --- a/src/iterations/print_summary.irp.f +++ b/src/iterations/print_summary.irp.f @@ -36,7 +36,7 @@ subroutine print_summary(e_,pt2_data,pt2_data_err,n_det_,n_configuration_,n_st,s write(*,fmt) '# E ', e_(1:N_states_p) if (N_states_p > 1) then write(*,fmt) '# Excit. (au)', e_(1:N_states_p)-e_(1) - write(*,fmt) '# Excit. (eV)', (e_(1:N_states_p)-e_(1))*ha_to_ev + write(*,fmt) '# Excit. (eV)', (e_(1:N_states_p)-e_(1))*27.211396641308d0 endif write(fmt,*) '(A13,', 2*N_states_p, '(1X,F14.8))' write(*,fmt) '# PT2 '//pt2_string, (pt2_data % pt2(k), pt2_data_err % pt2(k), k=1,N_states_p) @@ -47,8 +47,8 @@ subroutine print_summary(e_,pt2_data,pt2_data_err,n_det_,n_configuration_,n_st,s if (N_states_p > 1) then write(*,fmt) '# Excit. (au)', ( (e_(k)+pt2_data % pt2(k)-e_(1)-pt2_data % pt2(1)), & dsqrt(pt2_data_err % pt2(k)*pt2_data_err % pt2(k)+pt2_data_err % pt2(1)*pt2_data_err % pt2(1)), k=1,N_states_p) - write(*,fmt) '# Excit. (eV)', ( (e_(k)+pt2_data % pt2(k)-e_(1)-pt2_data % pt2(1))*ha_to_ev, & - dsqrt(pt2_data_err % pt2(k)*pt2_data_err % pt2(k)+pt2_data_err % pt2(1)*pt2_data_err % pt2(1))*ha_to_ev, k=1,N_states_p) + write(*,fmt) '# Excit. (eV)', ( (e_(k)+pt2_data % pt2(k)-e_(1)-pt2_data % pt2(1))*27.211396641308d0, & + dsqrt(pt2_data_err % pt2(k)*pt2_data_err % pt2(k)+pt2_data_err % pt2(1)*pt2_data_err % pt2(1))*27.211396641308d0, k=1,N_states_p) endif write(fmt,*) '(''# ============'',', N_states_p, '(1X,''=============================''))' write(*,fmt) @@ -82,23 +82,23 @@ subroutine print_summary(e_,pt2_data,pt2_data_err,n_det_,n_configuration_,n_st,s print *, 'Variational Energy difference (au | eV)' do i=2, N_states_p print*,'Delta E = ', (e_(i) - e_(1)), & - (e_(i) - e_(1)) * ha_to_ev + (e_(i) - e_(1)) * 27.211396641308d0 enddo print *, '-----' print*, 'Variational + perturbative Energy difference (au | eV)' do i=2, N_states_p print*,'Delta E = ', (e_(i)+ pt2_data % pt2(i) - (e_(1) + pt2_data % pt2(1))), & - (e_(i)+ pt2_data % pt2(i) - (e_(1) + pt2_data % pt2(1))) * ha_to_ev + (e_(i)+ pt2_data % pt2(i) - (e_(1) + pt2_data % pt2(1))) * 27.211396641308d0 enddo print *, '-----' print*, 'Variational + renormalized perturbative Energy difference (au | eV)' do i=2, N_states_p print*,'Delta E = ', (e_(i)+ pt2_data % rpt2(i) - (e_(1) + pt2_data % rpt2(1))), & - (e_(i)+ pt2_data % rpt2(i) - (e_(1) + pt2_data % rpt2(1))) * ha_to_ev + (e_(i)+ pt2_data % rpt2(i) - (e_(1) + pt2_data % rpt2(1))) * 27.211396641308d0 enddo endif -! call print_energy_components() + call print_energy_components() end subroutine diff --git a/src/kohn_sham_rs/rs_ks_scf.irp.f b/src/kohn_sham_rs/rs_ks_scf.irp.f index 84b85136..5d23544e 100644 --- a/src/kohn_sham_rs/rs_ks_scf.irp.f +++ b/src/kohn_sham_rs/rs_ks_scf.irp.f @@ -17,7 +17,7 @@ program rs_ks_scf print*, '**************************' print*, 'mu_erf_dft = ',mu_erf_dft print*, '**************************' -! call check_coherence_functional + call check_coherence_functional call create_guess call orthonormalize_mos call run diff --git a/src/mo_basis/mos_in_r.irp.f b/src/mo_basis/mos_in_r.irp.f index e5d3b243..ee2795d0 100644 --- a/src/mo_basis/mos_in_r.irp.f +++ b/src/mo_basis/mos_in_r.irp.f @@ -1,9 +1,6 @@ subroutine give_all_mos_at_r(r,mos_array) implicit none - BEGIN_DOC -! mos_array(i) = ith MO function evaluated at "r" - END_DOC double precision, intent(in) :: r(3) double precision, intent(out) :: mos_array(mo_num) double precision :: aos_array(ao_num) diff --git a/src/mo_guess/h_core_guess_routine.irp.f b/src/mo_guess/h_core_guess_routine.irp.f index fcbdde49..cbf23a9a 100644 --- a/src/mo_guess/h_core_guess_routine.irp.f +++ b/src/mo_guess/h_core_guess_routine.irp.f @@ -7,7 +7,7 @@ subroutine hcore_guess label = 'Guess' call mo_as_eigvectors_of_mo_matrix(mo_one_e_integrals, & size(mo_one_e_integrals,1), & - size(mo_one_e_integrals,2),label,1,.true.) + size(mo_one_e_integrals,2),label,1,.false.) call nullify_small_elements(ao_num, mo_num, mo_coef, size(mo_coef,1), 1.d-12 ) call save_mos TOUCH mo_coef mo_label diff --git a/src/mo_two_e_erf_ints/map_integrals_erf.irp.f b/src/mo_two_e_erf_ints/map_integrals_erf.irp.f index 3405ec2b..73050ec5 100644 --- a/src/mo_two_e_erf_ints/map_integrals_erf.irp.f +++ b/src/mo_two_e_erf_ints/map_integrals_erf.irp.f @@ -235,11 +235,11 @@ subroutine get_mo_two_e_integrals_erf_ij(k,l,sze,out_array,map) logical :: integral_is_in_map if (key_kind == 8) then - call i8sort(hash,iorder,kk) + call i8radix_sort(hash,iorder,kk,-1) else if (key_kind == 4) then - call isort(hash,iorder,kk) + call iradix_sort(hash,iorder,kk,-1) else if (key_kind == 2) then - call i2sort(hash,iorder,kk) + call i2radix_sort(hash,iorder,kk,-1) endif call map_get_many(mo_integrals_erf_map, hash, tmp_val, kk) @@ -290,11 +290,11 @@ subroutine get_mo_two_e_integrals_erf_i1j1(k,l,sze,out_array,map) logical :: integral_is_in_map if (key_kind == 8) then - call i8sort(hash,iorder,kk) + call i8radix_sort(hash,iorder,kk,-1) else if (key_kind == 4) then - call isort(hash,iorder,kk) + call iradix_sort(hash,iorder,kk,-1) else if (key_kind == 2) then - call i2sort(hash,iorder,kk) + call i2radix_sort(hash,iorder,kk,-1) endif call map_get_many(mo_integrals_erf_map, hash, tmp_val, kk) diff --git a/src/mo_two_e_ints/core_quantities.irp.f b/src/mo_two_e_ints/core_quantities.irp.f index b764a1a6..3642365e 100644 --- a/src/mo_two_e_ints/core_quantities.irp.f +++ b/src/mo_two_e_ints/core_quantities.irp.f @@ -53,7 +53,7 @@ BEGIN_PROVIDER [ double precision, h_core_ri, (mo_num, mo_num) ] enddo do k=1,mo_num do i=1,mo_num - h_core_ri(i,j) = h_core_ri(i,j) - 0.5 * big_array_exchange_integrals(k,i,j) + h_core_ri(i,j) = h_core_ri(i,j) - 0.5d0 * big_array_exchange_integrals(k,i,j) enddo enddo enddo diff --git a/src/mo_two_e_ints/map_integrals.irp.f b/src/mo_two_e_ints/map_integrals.irp.f index 272916e3..9f73d518 100644 --- a/src/mo_two_e_ints/map_integrals.irp.f +++ b/src/mo_two_e_ints/map_integrals.irp.f @@ -302,21 +302,21 @@ end integer(key_kind) :: idx double precision :: tmp -!icount = 1 ! Avoid division by zero -!do j=1,mo_num -! do i=1,j-1 -! call two_e_integrals_index(i,j,j,i,idx) -! !DIR$ FORCEINLINE -! call map_get(mo_integrals_map,idx,tmp) -! banned_excitation(i,j) = dabs(tmp) < 1.d-14 -! banned_excitation(j,i) = banned_excitation(i,j) -! if (banned_excitation(i,j)) icount = icount+2 -! enddo -!enddo -!use_banned_excitation = (mo_num*mo_num) / icount <= 100 !1% -!if (use_banned_excitation) then -! print *, 'Using sparsity of exchange integrals' -!endif + icount = 1 ! Avoid division by zero + do j=1,mo_num + do i=1,j-1 + call two_e_integrals_index(i,j,j,i,idx) + !DIR$ FORCEINLINE + call map_get(mo_integrals_map,idx,tmp) + banned_excitation(i,j) = dabs(tmp) < 1.d-14 + banned_excitation(j,i) = banned_excitation(i,j) + if (banned_excitation(i,j)) icount = icount+2 + enddo + enddo + use_banned_excitation = (mo_num*mo_num) / icount <= 100 !1% + if (use_banned_excitation) then + print *, 'Using sparsity of exchange integrals' + endif END_PROVIDER diff --git a/src/mo_two_e_ints/mo_bi_integrals.irp.f b/src/mo_two_e_ints/mo_bi_integrals.irp.f index 6f4c5c17..d58932ce 100644 --- a/src/mo_two_e_ints/mo_bi_integrals.irp.f +++ b/src/mo_two_e_ints/mo_bi_integrals.irp.f @@ -53,11 +53,7 @@ BEGIN_PROVIDER [ logical, mo_two_e_integrals_in_map ] ! call four_idx_novvvv call four_idx_novvvv_old else - if (32.d-9*dble(ao_num)**4 < dble(qp_max_mem)) then - call four_idx_dgemm - else - call add_integrals_to_map(full_ijkl_bitmask_4) - endif + call add_integrals_to_map(full_ijkl_bitmask_4) endif call wall_time(wall_2) @@ -81,94 +77,6 @@ BEGIN_PROVIDER [ logical, mo_two_e_integrals_in_map ] END_PROVIDER -subroutine four_idx_dgemm - implicit none - integer :: p,q,r,s,i,j,k,l - double precision, allocatable :: a1(:,:,:,:) - double precision, allocatable :: a2(:,:,:,:) - - allocate (a1(ao_num,ao_num,ao_num,ao_num)) - - print *, 'Getting AOs' - !$OMP PARALLEL DO DEFAULT(SHARED) PRIVATE(q,r,s) - do s=1,ao_num - do r=1,ao_num - do q=1,ao_num - call get_ao_two_e_integrals(q,r,s,ao_num,a1(1,q,r,s)) - enddo - enddo - enddo - !$OMP END PARALLEL DO - - print *, '1st transformation' - ! 1st transformation - allocate (a2(ao_num,ao_num,ao_num,mo_num)) - call dgemm('T','N', (ao_num*ao_num*ao_num), mo_num, ao_num, 1.d0, a1, ao_num, mo_coef, ao_num, 0.d0, a2, (ao_num*ao_num*ao_num)) - - ! 2nd transformation - print *, '2nd transformation' - deallocate (a1) - allocate (a1(ao_num,ao_num,mo_num,mo_num)) - call dgemm('T','N', (ao_num*ao_num*mo_num), mo_num, ao_num, 1.d0, a2, ao_num, mo_coef, ao_num, 0.d0, a1, (ao_num*ao_num*mo_num)) - - ! 3rd transformation - print *, '3rd transformation' - deallocate (a2) - allocate (a2(ao_num,mo_num,mo_num,mo_num)) - call dgemm('T','N', (ao_num*mo_num*mo_num), mo_num, ao_num, 1.d0, a1, ao_num, mo_coef, ao_num, 0.d0, a2, (ao_num*mo_num*mo_num)) - - ! 4th transformation - print *, '4th transformation' - deallocate (a1) - allocate (a1(mo_num,mo_num,mo_num,mo_num)) - call dgemm('T','N', (mo_num*mo_num*mo_num), mo_num, ao_num, 1.d0, a2, ao_num, mo_coef, ao_num, 0.d0, a1, (mo_num*mo_num*mo_num)) - - deallocate (a2) - - integer :: n_integrals, size_buffer - integer(key_kind) , allocatable :: buffer_i(:) - real(integral_kind), allocatable :: buffer_value(:) - size_buffer = min(ao_num*ao_num*ao_num,16000000) - - !$OMP PARALLEL DEFAULT(SHARED) PRIVATE(i,j,k,l,buffer_value,buffer_i,n_integrals) - allocate ( buffer_i(size_buffer), buffer_value(size_buffer) ) - - n_integrals = 0 - !$OMP DO - do l=1,mo_num - do k=1,mo_num - do j=1,l - do i=1,k - if (abs(a1(i,j,k,l)) < mo_integrals_threshold) then - cycle - endif - n_integrals += 1 - buffer_value(n_integrals) = a1(i,j,k,l) - !DIR$ FORCEINLINE - call mo_two_e_integrals_index(i,j,k,l,buffer_i(n_integrals)) - if (n_integrals == size_buffer) then - call map_append(mo_integrals_map, buffer_i, buffer_value, n_integrals) - n_integrals = 0 - endif - enddo - enddo - enddo - enddo - !$OMP END DO - - call map_append(mo_integrals_map, buffer_i, buffer_value, n_integrals) - - deallocate(buffer_i, buffer_value) - !$OMP END PARALLEL - - deallocate (a1) - - call map_unique(mo_integrals_map) - - integer*8 :: get_mo_map_size, mo_map_size - mo_map_size = get_mo_map_size() - -end subroutine subroutine add_integrals_to_map(mask_ijkl) use bitmasks diff --git a/src/mu_of_r/basis_def.irp.f b/src/mu_of_r/basis_def.irp.f index fff9f581..4da27cb0 100644 --- a/src/mu_of_r/basis_def.irp.f +++ b/src/mu_of_r/basis_def.irp.f @@ -76,11 +76,7 @@ BEGIN_PROVIDER [integer, n_basis_orb] ! ! It corresponds to all MOs except those defined as "deleted" END_DOC - if(mu_of_r_potential == "pure_act")then - n_basis_orb = n_act_orb - else - n_basis_orb = n_all_but_del_orb - endif + n_basis_orb = n_all_but_del_orb END_PROVIDER BEGIN_PROVIDER [integer, list_basis, (n_basis_orb)] @@ -93,15 +89,9 @@ BEGIN_PROVIDER [integer, list_basis, (n_basis_orb)] ! It corresponds to all MOs except those defined as "deleted" END_DOC integer :: i - if(mu_of_r_potential == "pure_act")then - do i = 1, n_act_orb - list_basis(i) = list_act(i) - enddo - else - do i = 1, n_all_but_del_orb - list_basis(i) = list_all_but_del_orb(i) - enddo - endif + do i = 1, n_all_but_del_orb + list_basis(i) = list_all_but_del_orb(i) + enddo END_PROVIDER BEGIN_PROVIDER [double precision, basis_mos_in_r_array, (n_basis_orb,n_points_final_grid)] diff --git a/src/mu_of_r/mu_of_r_conditions.irp.f b/src/mu_of_r/mu_of_r_conditions.irp.f index 5c41acdc..148c65b3 100644 --- a/src/mu_of_r/mu_of_r_conditions.irp.f +++ b/src/mu_of_r/mu_of_r_conditions.irp.f @@ -26,7 +26,7 @@ do ipoint = 1, n_points_final_grid if(mu_of_r_potential.EQ."hf")then mu_of_r_prov(ipoint,istate) = mu_of_r_hf(ipoint) - else if(mu_of_r_potential.EQ."cas_ful".or.mu_of_r_potential.EQ."cas_truncated".or.mu_of_r_potential.EQ."pure_act")then + else if(mu_of_r_potential.EQ."cas_ful".or.mu_of_r_potential.EQ."cas_truncated")then mu_of_r_prov(ipoint,istate) = mu_of_r_psi_cas(ipoint,istate) else print*,'you requested the following mu_of_r_potential' diff --git a/src/scf_utils/scf_density_matrix_ao.irp.f b/src/scf_utils/scf_density_matrix_ao.irp.f index 55fa8e7c..639855b3 100644 --- a/src/scf_utils/scf_density_matrix_ao.irp.f +++ b/src/scf_utils/scf_density_matrix_ao.irp.f @@ -9,6 +9,17 @@ BEGIN_PROVIDER [double precision, SCF_density_matrix_ao_alpha, (ao_num,ao_num) ] mo_coef, size(mo_coef,1), 0.d0, & SCF_density_matrix_ao_alpha, size(SCF_density_matrix_ao_alpha,1)) +! integer :: i, j +! double precision :: trace_density +! trace_density = 0.d0 +! do i = 1, ao_num !elec_alpha_num +! do j = 1, ao_num !elec_alpha_num +! trace_density = trace_density & +! + SCF_density_matrix_ao_alpha(j,i) * ao_overlap(j,i) +! enddo +! enddo +! print *, ' trace of SCF_density_matrix_ao_alpha =', trace_density + END_PROVIDER BEGIN_PROVIDER [ double precision, SCF_density_matrix_ao_beta, (ao_num,ao_num) ] diff --git a/src/tools/NEED b/src/tools/NEED index 0f4e17b0..c07c9109 100644 --- a/src/tools/NEED +++ b/src/tools/NEED @@ -2,4 +2,3 @@ fci mo_two_e_erf_ints aux_quantities hartree_fock -two_body_rdm diff --git a/src/tools/molden.irp.f b/src/tools/molden.irp.f index 830a141e..417b25ad 100644 --- a/src/tools/molden.irp.f +++ b/src/tools/molden.irp.f @@ -52,8 +52,8 @@ program molden l += 1 if (l > ao_num) exit enddo + write(i_unit_output,*)'' enddo - write(i_unit_output,*)'' enddo diff --git a/src/tools/print_dipole.irp.f b/src/tools/print_dipole.irp.f index 8db9aa09..8351308e 100644 --- a/src/tools/print_dipole.irp.f +++ b/src/tools/print_dipole.irp.f @@ -1,7 +1,5 @@ program print_dipole implicit none - read_wf = .True. - TOUCH read_wf - call print_dipole_moments + call print_z_dipole_moment_only end diff --git a/src/tools/print_wf.irp.f b/src/tools/print_wf.irp.f index 64eb1a1f..7e51caaf 100644 --- a/src/tools/print_wf.irp.f +++ b/src/tools/print_wf.irp.f @@ -32,9 +32,8 @@ subroutine routine double precision :: norm_mono_a,norm_mono_b double precision :: norm_mono_a_2,norm_mono_b_2 double precision :: norm_mono_a_pert_2,norm_mono_b_pert_2 - double precision :: norm_mono_a_pert,norm_mono_b_pert,norm_double_1 + double precision :: norm_mono_a_pert,norm_mono_b_pert double precision :: delta_e,coef_2_2 - norm_mono_a = 0.d0 norm_mono_b = 0.d0 norm_mono_a_2 = 0.d0 @@ -43,7 +42,6 @@ subroutine routine norm_mono_b_pert = 0.d0 norm_mono_a_pert_2 = 0.d0 norm_mono_b_pert_2 = 0.d0 - norm_double_1 = 0.d0 do i = 1, min(N_det_print_wf,N_det) print*,'' print*,'i = ',i @@ -95,7 +93,6 @@ subroutine routine print*,'h1,p1 = ',h1,p1 print*,'s2',s2 print*,'h2,p2 = ',h2,p2 - norm_double_1 += dabs(psi_coef_sorted(i,1)/psi_coef_sorted(1,1)) endif print*,' = ',hij @@ -112,7 +109,6 @@ subroutine routine print*,'' print*,'L1 norm of mono alpha = ',norm_mono_a print*,'L1 norm of mono beta = ',norm_mono_b - print*,'L1 norm of double exc = ',norm_double_1 print*, '---' print*,'L2 norm of mono alpha = ',norm_mono_a_2 print*,'L2 norm of mono beta = ',norm_mono_b_2 diff --git a/src/tools/save_natorb_no_ov_rot.irp.f b/src/tools/save_natorb_no_ov_rot.irp.f deleted file mode 100644 index e5b69fbf..00000000 --- a/src/tools/save_natorb_no_ov_rot.irp.f +++ /dev/null @@ -1,25 +0,0 @@ -program save_natorb - implicit none - BEGIN_DOC -! Save natural |MOs| into the |EZFIO|. -! -! This program reads the wave function stored in the |EZFIO| directory, -! extracts the corresponding natural orbitals and setd them as the new -! |MOs|. -! -! If this is a multi-state calculation, the density matrix that produces -! the natural orbitals is obtained from an average of the density -! matrices of each state with the corresponding -! :option:`determinants state_average_weight` - END_DOC - read_wf = .True. - touch read_wf - call save_natural_mos_no_ov_rot - call save_ref_determinant - call ezfio_set_mo_two_e_ints_io_mo_two_e_integrals('None') - call ezfio_set_mo_one_e_ints_io_mo_one_e_integrals('None') - call ezfio_set_mo_one_e_ints_io_mo_integrals_kinetic('None') - call ezfio_set_mo_one_e_ints_io_mo_integrals_n_e('None') - call ezfio_set_mo_one_e_ints_io_mo_integrals_pseudo('None') -end - diff --git a/src/tools/save_natorb_no_ref.irp.f b/src/tools/save_natorb_no_ref.irp.f deleted file mode 100644 index 9d253fa0..00000000 --- a/src/tools/save_natorb_no_ref.irp.f +++ /dev/null @@ -1,24 +0,0 @@ -program save_natorb - implicit none - BEGIN_DOC -! Save natural |MOs| into the |EZFIO|. -! -! This program reads the wave function stored in the |EZFIO| directory, -! extracts the corresponding natural orbitals and setd them as the new -! |MOs|. -! -! If this is a multi-state calculation, the density matrix that produces -! the natural orbitals is obtained from an average of the density -! matrices of each state with the corresponding -! :option:`determinants state_average_weight` - END_DOC - read_wf = .True. - touch read_wf - call save_natural_mos_canon_label - call ezfio_set_mo_two_e_ints_io_mo_two_e_integrals('None') - call ezfio_set_mo_one_e_ints_io_mo_one_e_integrals('None') - call ezfio_set_mo_one_e_ints_io_mo_integrals_kinetic('None') - call ezfio_set_mo_one_e_ints_io_mo_integrals_n_e('None') - call ezfio_set_mo_one_e_ints_io_mo_integrals_pseudo('None') -end - diff --git a/src/tools/truncate_wf.irp.f b/src/tools/truncate_wf.irp.f deleted file mode 100644 index 64c15bf7..00000000 --- a/src/tools/truncate_wf.irp.f +++ /dev/null @@ -1,110 +0,0 @@ -program truncate_wf - implicit none - BEGIN_DOC -! Truncate the wave function - END_DOC - read_wf = .True. - if (s2_eig) then - call routine_s2 - else - call routine - endif -end - -subroutine routine - implicit none - integer :: ndet_max - print*, 'Max number of determinants ?' - read(5,*) ndet_max - integer(bit_kind), allocatable :: psi_det_tmp(:,:,:) - double precision, allocatable :: psi_coef_tmp(:,:) - allocate(psi_det_tmp(N_int,2,ndet_max),psi_coef_tmp(ndet_max, N_states)) - - integer :: i,j - double precision :: accu(N_states) - accu = 0.d0 - do i = 1, ndet_max - do j = 1, N_int - psi_det_tmp(j,1,i) = psi_det_sorted(j,1,i) - psi_det_tmp(j,2,i) = psi_det_sorted(j,2,i) - enddo - do j = 1, N_states - psi_coef_tmp(i,j) = psi_coef_sorted(i,j) - accu(j) += psi_coef_tmp(i,j) **2 - enddo - enddo - do j = 1, N_states - accu(j) = 1.d0/dsqrt(accu(j)) - enddo - do j = 1, N_states - do i = 1, ndet_max - psi_coef_tmp(i,j) = psi_coef_tmp(i,j) * accu(j) - enddo - enddo - - call save_wavefunction_general(ndet_max,N_states,psi_det_tmp,size(psi_coef_tmp,1),psi_coef_tmp) - -end - -subroutine routine_s2 - implicit none - integer :: ndet_max - double precision :: wmin - integer(bit_kind), allocatable :: psi_det_tmp(:,:,:) - double precision, allocatable :: psi_coef_tmp(:,:) - integer :: i,j,k - double precision :: accu(N_states) - integer :: weights(0:16), ix - double precision :: x - - weights(:) = 0 - do i=1,N_det - x = -dlog(1.d-32+sum(weight_configuration(det_to_configuration(i),:)))/dlog(10.d0) - ix = min(int(x), 16) - weights(ix) += 1 - enddo - - print *, 'Histogram of the weights of the CFG' - do i=0,15 - print *, ' 10^{-', i, '} ', weights(i) - end do - print *, '< 10^{-', 15, '} ', weights(16) - - - print*, 'Min weight of the configuration?' - read(5,*) wmin - - ndet_max = 0 - do i=1,N_det - if (maxval(weight_configuration( det_to_configuration(i),:)) < wmin) cycle - ndet_max = ndet_max+1 - enddo - - allocate(psi_det_tmp(N_int,2,ndet_max),psi_coef_tmp(ndet_max, N_states)) - - accu = 0.d0 - k=0 - do i = 1, N_det - if (maxval(weight_configuration( det_to_configuration(i),:)) < wmin) cycle - k = k+1 - do j = 1, N_int - psi_det_tmp(j,1,k) = psi_det(j,1,i) - psi_det_tmp(j,2,k) = psi_det(j,2,i) - enddo - do j = 1, N_states - psi_coef_tmp(k,j) = psi_coef(i,j) - accu(j) += psi_coef_tmp(k,j)**2 - enddo - enddo - do j = 1, N_states - accu(j) = 1.d0/dsqrt(accu(j)) - enddo - do j = 1, N_states - do i = 1, ndet_max - psi_coef_tmp(i,j) = psi_coef_tmp(i,j) * accu(j) - enddo - enddo - - call save_wavefunction_general(ndet_max,N_states,psi_det_tmp,size(psi_coef_tmp,1),psi_coef_tmp) - -end diff --git a/src/two_body_rdm/two_e_dm_mo.irp.f b/src/two_body_rdm/two_e_dm_mo.irp.f index a4dea15f..4dadd2e6 100644 --- a/src/two_body_rdm/two_e_dm_mo.irp.f +++ b/src/two_body_rdm/two_e_dm_mo.irp.f @@ -1,8 +1,9 @@ BEGIN_PROVIDER [double precision, two_e_dm_mo, (mo_num,mo_num,mo_num,mo_num)] implicit none BEGIN_DOC - ! \sum_{\sigma \sigma'} - ! + ! two_e_dm_bb_mo(i,j,k,l,istate) = STATE SPECIFIC physicist notation for 2RDM of beta/beta electrons + ! + ! ! ! where the indices (i,j,k,l) belong to all MOs. ! @@ -11,7 +12,7 @@ BEGIN_PROVIDER [double precision, two_e_dm_mo, (mo_num,mo_num,mo_num,mo_num)] ! !!!!! WARNING !!!!! IF "no_core_density" then all elements involving at least one CORE MO are set to zero ! The state-averaged two-electron energy : ! - ! \sum_{i,j,k,l = 1, mo_num} two_e_dm_mo(i,j,k,l) * < kk ll | ii jj > + ! \sum_{i,j,k,l = 1, mo_num} two_e_dm_mo(i,j,k,l) * < ii jj | kk ll > END_DOC two_e_dm_mo = 0.d0 integer :: i,j,k,l,iorb,jorb,korb,lorb,istate diff --git a/src/two_rdm_routines/davidson_like_state_av_2rdm.irp.f b/src/two_rdm_routines/davidson_like_state_av_2rdm.irp.f index 26ed5ae6..eb247dea 100644 --- a/src/two_rdm_routines/davidson_like_state_av_2rdm.irp.f +++ b/src/two_rdm_routines/davidson_like_state_av_2rdm.irp.f @@ -529,14 +529,10 @@ subroutine orb_range_2_rdm_state_av_openmp_work_$N_int(big_array,dim1,norb,list_ c_average += c_1(l) * c_1(l) * state_weights(l) enddo - if (nkeys > 0) then - call update_keys_values(keys,values,nkeys,dim1,big_array,lock_2rdm) - endif + call update_keys_values(keys,values,nkeys,dim1,big_array,lock_2rdm) nkeys = 0 call orb_range_diag_to_all_2_rdm_dm_buffer(tmp_det,c_average,orb_bitmask,list_orb_reverse,ispin,sze_buff,nkeys,keys,values) - if (nkeys > 0) then - call update_keys_values(keys,values,nkeys,dim1,big_array,lock_2rdm) - endif + call update_keys_values(keys,values,nkeys,dim1,big_array,lock_2rdm) nkeys = 0 end do diff --git a/src/utils/EZFIO.cfg b/src/utils/EZFIO.cfg index 7d367f0c..9e9a62f1 100644 --- a/src/utils/EZFIO.cfg +++ b/src/utils/EZFIO.cfg @@ -3,3 +3,4 @@ type: logical doc: If true, try to find symmetry in the MO coefficient matrices interface: ezfio,provider,ocaml default: False + diff --git a/src/utils/cgtos_one_e.irp.f b/src/utils/cgtos_one_e.irp.f new file mode 100644 index 00000000..43ca8224 --- /dev/null +++ b/src/utils/cgtos_one_e.irp.f @@ -0,0 +1,120 @@ + +! --- + +complex*16 function overlap_cgaussian_x(A_center, B_center, alpha, beta, power_A, power_B, dim) + + BEGIN_DOC + ! + ! \int_{-infty}^{+infty} (x-A_x)^ax (x-B_x)^bx exp(-alpha (x-A_x)^2) exp(- beta(x-B_X)^2) dx + ! with complex arguments + ! + END_DOC + + implicit none + include 'constants.include.F' + + integer, intent(in) :: dim, power_A, power_B + complex*16, intent(in) :: A_center, B_center, alpha, beta + + integer :: i, iorder_p + double precision :: fact_p_mod + complex*16 :: P_new(0:max_dim), P_center, fact_p, p, inv_sq_p + + complex*16 :: Fc_integral + + + call give_explicit_cpoly_and_cgaussian_x( P_new, P_center, p, fact_p, iorder_p & + , alpha, beta, power_A, power_B, A_center, B_center, dim) + + fact_p_mod = dsqrt(real(fact_p)*real(fact_p) + aimag(fact_p)*aimag(fact_p)) + if(fact_p_mod .lt. 1.d-14) then + overlap_cgaussian_x = (0.d0, 0.d0) + return + endif + + + inv_sq_p = (1.d0, 0.d0) / zsqrt(p) + + overlap_cgaussian_x = (0.d0, 0.d0) + do i = 0, iorder_p + overlap_cgaussian_x += P_new(i) * Fc_integral(i, inv_sq_p) + enddo + + overlap_cgaussian_x *= fact_p + +end function overlap_cgaussian_x + +! --- + +subroutine overlap_cgaussian_xyz( A_center, B_center, alpha, beta, power_A, power_B & + , overlap_x, overlap_y, overlap_z, overlap, dim ) + + BEGIN_DOC + ! + ! S_x = \int (x-A_x)^{a_x} exp(-\alpha(x-A_x)^2) (x-B_x)^{b_x} exp(-beta(x-B_x)^2) dx + ! S = S_x S_y S_z + ! for complex arguments + ! + END_DOC + + implicit none + include 'constants.include.F' + + integer, intent(in) :: dim, power_A(3), power_B(3) + complex*16, intent(in) :: A_center(3), B_center(3), alpha, beta + complex*16, intent(out) :: overlap_x, overlap_y, overlap_z, overlap + + integer :: i, nmax, iorder_p(3) + double precision :: fact_p_mod + complex*16 :: P_new(0:max_dim,3), P_center(3), fact_p, p, inv_sq_p + complex*16 :: F_integral_tab(0:max_dim) + + complex*16 :: Fc_integral + + call give_explicit_cpoly_and_cgaussian(P_new, P_center, p, fact_p, iorder_p, alpha, beta, power_A, power_B, A_center, B_center, dim) + + fact_p_mod = dsqrt(real(fact_p)*real(fact_p) + aimag(fact_p)*aimag(fact_p)) + if(fact_p_mod .lt. 1.d-14) then + overlap_x = (1.d-10, 0.d0) + overlap_y = (1.d-10, 0.d0) + overlap_z = (1.d-10, 0.d0) + overlap = (1.d-10, 0.d0) + return + endif + + nmax = maxval(iorder_p) + + inv_sq_p = (1.d0, 0.d0) / zsqrt(p) + do i = 0, nmax + F_integral_tab(i) = Fc_integral(i, inv_sq_p) + enddo + + overlap_x = P_new(0,1) * F_integral_tab(0) + overlap_y = P_new(0,2) * F_integral_tab(0) + overlap_z = P_new(0,3) * F_integral_tab(0) + + do i = 1, iorder_p(1) + overlap_x = overlap_x + P_new(i,1) * F_integral_tab(i) + enddo + call cgaussian_product_x(alpha, A_center(1), beta, B_center(1), fact_p, p, P_center(1)) + overlap_x *= fact_p + + do i = 1, iorder_p(2) + overlap_y = overlap_y + P_new(i,2) * F_integral_tab(i) + enddo + call cgaussian_product_x(alpha, A_center(2), beta, B_center(2), fact_p, p, P_center(2)) + overlap_y *= fact_p + + do i = 1, iorder_p(3) + overlap_z = overlap_z + P_new(i,3) * F_integral_tab(i) + enddo + call cgaussian_product_x(alpha, A_center(3), beta, B_center(3), fact_p, p, P_center(3)) + overlap_z *= fact_p + + overlap = overlap_x * overlap_y * overlap_z + +end subroutine overlap_cgaussian_xyz + +! --- + + diff --git a/src/utils/cgtos_utils.irp.f b/src/utils/cgtos_utils.irp.f new file mode 100644 index 00000000..a820d5f2 --- /dev/null +++ b/src/utils/cgtos_utils.irp.f @@ -0,0 +1,780 @@ + +! --- + +subroutine give_explicit_cpoly_and_cgaussian_x(P_new, P_center, p, fact_k, iorder, alpha, beta, a, b, A_center, B_center, dim) + + BEGIN_DOC + ! Transform the product of + ! (x-x_A)^a (x-x_B)^b exp(-(r-A)^2 alpha) exp(-(r-B)^2 beta) + ! into + ! fact_k \sum_{i=0}^{iorder} (x-x_P)^i exp(-p(r-P)^2) + END_DOC + + implicit none + include 'constants.include.F' + + integer, intent(in) :: dim + integer, intent(in) :: a, b + complex*16, intent(in) :: alpha, beta, A_center, B_center + integer, intent(out) :: iorder + complex*16, intent(out) :: p, P_center, fact_k + complex*16, intent(out) :: P_new(0:max_dim) + + integer :: n_new, i, j + double precision :: tmp_mod + complex*16 :: P_a(0:max_dim), P_b(0:max_dim) + complex*16 :: p_inv, ab, d_AB, tmp + + !DIR$ ATTRIBUTES ALIGN : $IRP_ALIGN :: P_a, P_b + + P_new = (0.d0, 0.d0) + + ! new exponent + p = alpha + beta + + ! new center + p_inv = (1.d0, 0.d0) / p + ab = alpha * beta + P_center = (alpha * A_center + beta * B_center) * p_inv + + ! get the factor + d_AB = (A_center - B_center) * (A_center - B_center) + tmp = ab * p_inv * d_AB + tmp_mod = dsqrt(REAL(tmp)*REAL(tmp) + AIMAG(tmp)*AIMAG(tmp)) + if(tmp_mod .lt. 50.d0) then + fact_k = zexp(-tmp) + else + fact_k = (0.d0, 0.d0) + endif + + ! Recenter the polynomials P_a and P_b on P_center + !DIR$ FORCEINLINE + call recentered_cpoly2(P_a(0), A_center, P_center, a, P_b(0), B_center, P_center, b) + n_new = 0 + + !DIR$ FORCEINLINE + call multiply_cpoly(P_a(0), a, P_b(0), b, P_new(0), n_new) + iorder = a + b + +end subroutine give_explicit_cpoly_and_cgaussian_x + +! --- + +subroutine give_explicit_cpoly_and_cgaussian(P_new, P_center, p, fact_k, iorder, alpha, beta, a, b, A_center, B_center, dim) + + BEGIN_DOC + ! Transforms the product of + ! (x-x_A)^a(1) (x-x_B)^b(1) (y-y_A)^a(2) (y-y_B)^b(2) (z-z_A)^a(3) (z-z_B)^b(3) exp(-(r-A)^2 alpha) exp(-(r-B)^2 beta) + ! into + ! fact_k * [ sum (l_x = 0,i_order(1)) P_new(l_x,1) * (x-P_center(1))^l_x ] exp (- p (x-P_center(1))^2 ) + ! * [ sum (l_y = 0,i_order(2)) P_new(l_y,2) * (y-P_center(2))^l_y ] exp (- p (y-P_center(2))^2 ) + ! * [ sum (l_z = 0,i_order(3)) P_new(l_z,3) * (z-P_center(3))^l_z ] exp (- p (z-P_center(3))^2 ) + ! + ! WARNING ::: IF fact_k is too smal then: + ! returns a "s" function centered in zero + ! with an inifinite exponent and a zero polynom coef + END_DOC + + implicit none + include 'constants.include.F' + + integer, intent(in) :: dim, a(3), b(3) + complex*16, intent(in) :: alpha, beta, A_center(3), B_center(3) + integer, intent(out) :: iorder(3) + complex*16, intent(out) :: p, P_center(3), fact_k, P_new(0:max_dim,3) + + integer :: n_new, i, j + double precision :: tmp_mod + complex*16 :: P_a(0:max_dim,3), P_b(0:max_dim,3) + !DIR$ ATTRIBUTES ALIGN : $IRP_ALIGN :: P_a, P_b + + iorder(1) = 0 + iorder(2) = 0 + iorder(3) = 0 + + P_new(0,1) = (0.d0, 0.d0) + P_new(0,2) = (0.d0, 0.d0) + P_new(0,3) = (0.d0, 0.d0) + + !DIR$ FORCEINLINE + call cgaussian_product(alpha, A_center, beta, B_center, fact_k, p, P_center) + + ! IF fact_k is too smal then: returns a "s" function centered in zero + ! with an inifinite exponent and a zero polynom coef + tmp_mod = dsqrt(REAL(fact_k)*REAL(fact_k) + AIMAG(fact_k)*AIMAG(fact_k)) + if(tmp_mod < 1d-14) then + iorder = 0 + p = (1.d+14, 0.d0) + fact_k = (0.d0 , 0.d0) + P_new(0:max_dim,1:3) = (0.d0 , 0.d0) + P_center(1:3) = (0.d0 , 0.d0) + return + endif + + !DIR$ FORCEINLINE + call recentered_cpoly2(P_a(0,1), A_center(1), P_center(1), a(1), P_b(0,1), B_center(1), P_center(1), b(1)) + iorder(1) = a(1) + b(1) + do i = 0, iorder(1) + P_new(i,1) = 0.d0 + enddo + n_new = 0 + !DIR$ FORCEINLINE + call multiply_cpoly(P_a(0,1), a(1), P_b(0,1), b(1), P_new(0,1), n_new) + + !DIR$ FORCEINLINE + call recentered_cpoly2(P_a(0,2), A_center(2), P_center(2), a(2), P_b(0,2), B_center(2), P_center(2), b(2)) + iorder(2) = a(2) + b(2) + do i = 0, iorder(2) + P_new(i,2) = 0.d0 + enddo + n_new = 0 + !DIR$ FORCEINLINE + call multiply_cpoly(P_a(0,2), a(2), P_b(0,2), b(2), P_new(0,2), n_new) + + !DIR$ FORCEINLINE + call recentered_cpoly2(P_a(0,3), A_center(3), P_center(3), a(3), P_b(0,3), B_center(3), P_center(3), b(3)) + iorder(3) = a(3) + b(3) + do i = 0, iorder(3) + P_new(i,3) = 0.d0 + enddo + n_new = 0 + !DIR$ FORCEINLINE + call multiply_cpoly(P_a(0,3), a(3), P_b(0,3), b(3), P_new(0,3), n_new) + +end subroutine give_explicit_cpoly_and_cgaussian + +! --- + +!subroutine give_explicit_poly_and_gaussian_double(P_new,P_center,p,fact_k,iorder,alpha,beta,gama,a,b,A_center,B_center,Nucl_center,dim) +! BEGIN_DOC +! ! Transforms the product of +! ! (x-x_A)^a(1) (x-x_B)^b(1) (x-x_A)^a(2) (y-y_B)^b(2) (z-z_A)^a(3) (z-z_B)^b(3) +! ! exp(-(r-A)^2 alpha) exp(-(r-B)^2 beta) exp(-(r-Nucl_center)^2 gama +! ! +! ! into +! ! fact_k * [ sum (l_x = 0,i_order(1)) P_new(l_x,1) * (x-P_center(1))^l_x ] exp (- p (x-P_center(1))^2 ) +! ! * [ sum (l_y = 0,i_order(2)) P_new(l_y,2) * (y-P_center(2))^l_y ] exp (- p (y-P_center(2))^2 ) +! ! * [ sum (l_z = 0,i_order(3)) P_new(l_z,3) * (z-P_center(3))^l_z ] exp (- p (z-P_center(3))^2 ) +! END_DOC +! implicit none +! include 'constants.include.F' +! integer, intent(in) :: dim +! integer, intent(in) :: a(3),b(3) ! powers : (x-xa)**a_x = (x-A(1))**a(1) +! double precision, intent(in) :: alpha, beta, gama ! exponents +! double precision, intent(in) :: A_center(3) ! A center +! double precision, intent(in) :: B_center (3) ! B center +! double precision, intent(in) :: Nucl_center(3) ! B center +! double precision, intent(out) :: P_center(3) ! new center +! double precision, intent(out) :: p ! new exponent +! double precision, intent(out) :: fact_k ! constant factor +! double precision, intent(out) :: P_new(0:max_dim,3)! polynomial +! integer , intent(out) :: iorder(3) ! i_order(i) = order of the polynomials +! +! double precision :: P_center_tmp(3) ! new center +! double precision :: p_tmp ! new exponent +! double precision :: fact_k_tmp,fact_k_bis ! constant factor +! double precision :: P_new_tmp(0:max_dim,3)! polynomial +! integer :: i,j +! double precision :: binom_func +! +! ! First you transform the two primitives into a sum of primitive with the same center P_center_tmp and gaussian exponent p_tmp +! call give_explicit_cpoly_and_cgaussian(P_new_tmp,P_center_tmp,p_tmp,fact_k_tmp,iorder,alpha,beta,a,b,A_center,B_center,dim) +! ! Then you create the new gaussian from the product of the new one per the Nuclei one +! call cgaussian_product(p_tmp,P_center_tmp,gama,Nucl_center,fact_k_bis,p,P_center) +! fact_k = fact_k_bis * fact_k_tmp +! +! ! Then you build the coefficient of the new polynom +! do i = 0, iorder(1) +! P_new(i,1) = 0.d0 +! do j = i,iorder(1) +! P_new(i,1) = P_new(i,1) + P_new_tmp(j,1) * binom_func(j,j-i) * (P_center(1) - P_center_tmp(1))**(j-i) +! enddo +! enddo +! do i = 0, iorder(2) +! P_new(i,2) = 0.d0 +! do j = i,iorder(2) +! P_new(i,2) = P_new(i,2) + P_new_tmp(j,2) * binom_func(j,j-i) * (P_center(2) - P_center_tmp(2))**(j-i) +! enddo +! enddo +! do i = 0, iorder(3) +! P_new(i,3) = 0.d0 +! do j = i,iorder(3) +! P_new(i,3) = P_new(i,3) + P_new_tmp(j,3) * binom_func(j,j-i) * (P_center(3) - P_center_tmp(3))**(j-i) +! enddo +! enddo +! +!end + +! --- + +subroutine cgaussian_product(a, xa, b, xb, k, p, xp) + + BEGIN_DOC + ! complex Gaussian product + ! e^{-a (r-r_A)^2} e^{-b (r-r_B)^2} = k e^{-p (r-r_P)^2} + END_DOC + + implicit none + complex*16, intent(in) :: a, b, xa(3), xb(3) + complex*16, intent(out) :: p, k, xp(3) + + double precision :: tmp_mod + complex*16 :: p_inv, xab(3), ab + + !DIR$ ATTRIBUTES ALIGN : $IRP_ALIGN :: xab + + ASSERT (REAL(a) > 0.) + ASSERT (REAL(b) > 0.) + + ! new exponent + p = a + b + + xab(1) = xa(1) - xb(1) + xab(2) = xa(2) - xb(2) + xab(3) = xa(3) - xb(3) + + p_inv = (1.d0, 0.d0) / p + ab = a * b * p_inv + + k = ab * (xab(1)*xab(1) + xab(2)*xab(2) + xab(3)*xab(3)) + tmp_mod = dsqrt(REAL(k)*REAL(k) + AIMAG(k)*AIMAG(k)) + if(tmp_mod .gt. 40.d0) then + k = (0.d0, 0.d0) + xp(1:3) = (0.d0, 0.d0) + return + endif + + k = zexp(-k) + xp(1) = ( a * xa(1) + b * xb(1) ) * p_inv + xp(2) = ( a * xa(2) + b * xb(2) ) * p_inv + xp(3) = ( a * xa(3) + b * xb(3) ) * p_inv + +end subroutine cgaussian_product + +! --- + +subroutine cgaussian_product_x(a, xa, b, xb, k, p, xp) + + BEGIN_DOC + ! complex Gaussian product in 1D. + ! e^{-a (x-x_A)^2} e^{-b (x-x_B)^2} = K e^{-p (x-x_P)^2} + END_DOC + + implicit none + complex*16, intent(in) :: a, b, xa, xb + complex*16, intent(out) :: p, k, xp + + double precision :: tmp_mod + complex*16 :: p_inv + complex*16 :: xab, ab + + ASSERT (REAL(a) > 0.) + ASSERT (REAL(b) > 0.) + + ! new center + p = a + b + + xab = xa - xb + + p_inv = (1.d0, 0.d0) / p + ab = a * b * p_inv + + k = ab * xab*xab + tmp_mod = dsqrt(REAL(k)*REAL(k) + AIMAG(k)*AIMAG(k)) + if(tmp_mod > 40.d0) then + k = (0.d0, 0.d0) + xp = (0.d0, 0.d0) + return + endif + + k = zexp(-k) + xp = (a*xa + b*xb) * p_inv + +end subroutine cgaussian_product_x + +! --- + +subroutine multiply_cpoly(b, nb, c, nc, d, nd) + + BEGIN_DOC + ! Multiply two complex polynomials + ! D(t) += B(t) * C(t) + END_DOC + + implicit none + + integer, intent(in) :: nb, nc + complex*16, intent(in) :: b(0:nb), c(0:nc) + complex*16, intent(inout) :: d(0:nb+nc) + integer, intent(out) :: nd + + integer :: ndtmp, ib, ic + double precision :: tmp_mod + complex*16 :: tmp + + if(ior(nc, nb) >= 0) then ! True if nc>=0 and nb>=0 + continue + else + return + endif + + ndtmp = nb + nc + + do ic = 0, nc + d(ic) = d(ic) + c(ic) * b(0) + enddo + + do ib = 1, nb + d(ib) = d(ib) + c(0) * b(ib) + do ic = 1, nc + d(ib+ic) = d(ib+ic) + c(ic) * b(ib) + enddo + enddo + + do nd = ndtmp, 0, -1 + tmp = d(nd) + tmp_mod = dsqrt(REAL(tmp)*REAL(tmp) + AIMAG(tmp)*AIMAG(tmp)) + if(tmp_mod .lt. 1.d-15) cycle + exit + enddo + +end subroutine multiply_cpoly + +! --- + +subroutine add_cpoly(b, nb, c, nc, d, nd) + + BEGIN_DOC + ! Add two complex polynomials + ! D(t) += B(t) + C(t) + END_DOC + + implicit none + complex*16, intent(in) :: b(0:nb), c(0:nc) + integer, intent(inout) :: nb, nc + integer, intent(out) :: nd + complex*16, intent(out) :: d(0:nb+nc) + + integer :: ib + double precision :: tmp_mod + complex*16 :: tmp + + nd = nb + nc + do ib = 0, max(nb, nc) + d(ib) = d(ib) + c(ib) + b(ib) + enddo + + tmp = d(nd) + tmp_mod = dsqrt(REAL(tmp)*REAL(tmp) + AIMAG(tmp)*AIMAG(tmp)) + do while( (tmp_mod .lt. 1.d-15) .and. (nd >= 0) ) + nd -= 1 + tmp = d(nd) + tmp_mod = dsqrt(REAL(tmp)*REAL(tmp) + AIMAG(tmp)*AIMAG(tmp)) + if(nd < 0) exit + enddo + +end subroutine add_cpoly + +! --- + +subroutine add_cpoly_multiply(b, nb, cst, d, nd) + + BEGIN_DOC + ! Add a complex polynomial multiplied by a complex constant + ! D(t) += cst * B(t) + END_DOC + + implicit none + + integer, intent(in) :: nb + complex*16, intent(in) :: b(0:nb), cst + integer, intent(inout) :: nd + complex*16, intent(inout) :: d(0:max(nb, nd)) + + integer :: ib + double precision :: tmp_mod + complex*16 :: tmp + + nd = max(nd, nb) + if(nd /= -1) then + + do ib = 0, nb + d(ib) = d(ib) + cst * b(ib) + enddo + + tmp = d(nd) + tmp_mod = dsqrt(REAL(tmp)*REAL(tmp) + AIMAG(tmp)*AIMAG(tmp)) + do while(tmp_mod .lt. 1.d-15) + nd -= 1 + if(nd < 0) exit + tmp = d(nd) + tmp_mod = dsqrt(REAL(tmp)*REAL(tmp) + AIMAG(tmp)*AIMAG(tmp)) + enddo + + endif + +end subroutine add_cpoly_multiply + +! --- + +subroutine recentered_cpoly2(P_A, x_A, x_P, a, P_B, x_B, x_Q, b) + + BEGIN_DOC + ! + ! write two complex polynomials (x-x_A)^a (x-x_B)^b + ! as P_A(x-x_P) and P_B(x-x_Q) + ! + END_DOC + + implicit none + + integer, intent(in) :: a, b + complex*16, intent(in) :: x_A, x_P, x_B, x_Q + complex*16, intent(out) :: P_A(0:a), P_B(0:b) + + integer :: i, minab, maxab + complex*16 :: pows_a(-2:a+b+4), pows_b(-2:a+b+4) + + double precision :: binom_func + + if((a<0) .or. (b<0)) return + + maxab = max(a, b) + minab = max(min(a, b), 0) + + pows_a(0) = (1.d0, 0.d0) + pows_a(1) = x_P - x_A + + pows_b(0) = (1.d0, 0.d0) + pows_b(1) = x_Q - x_B + + do i = 2, maxab + pows_a(i) = pows_a(i-1) * pows_a(1) + pows_b(i) = pows_b(i-1) * pows_b(1) + enddo + + P_A(0) = pows_a(a) + P_B(0) = pows_b(b) + + do i = 1, min(minab, 20) + P_A(i) = binom_transp(a-i,a) * pows_a(a-i) + P_B(i) = binom_transp(b-i,b) * pows_b(b-i) + enddo + + do i = minab+1, min(a, 20) + P_A(i) = binom_transp(a-i,a) * pows_a(a-i) + enddo + do i = minab+1, min(b, 20) + P_B(i) = binom_transp(b-i,b) * pows_b(b-i) + enddo + + do i = 101, a + P_A(i) = binom_func(a,a-i) * pows_a(a-i) + enddo + do i = 101, b + P_B(i) = binom_func(b,b-i) * pows_b(b-i) + enddo + +end subroutine recentered_cpoly2 + +! --- + +complex*16 function Fc_integral(n, inv_sq_p) + + BEGIN_DOC + ! function that calculates the following integral + ! \int_{\-infty}^{+\infty} x^n \exp(-p x^2) dx + ! for complex valued p + END_DOC + + implicit none + include 'constants.include.F' + + integer, intent(in) :: n + complex*16, intent(in) :: inv_sq_p + + ! (n)! + double precision :: fact + + if(n < 0) then + Fc_integral = (0.d0, 0.d0) + return + endif + + ! odd n + if(iand(n, 1) .ne. 0) then + Fc_integral = (0.d0, 0.d0) + return + endif + + if(n == 0) then + Fc_integral = sqpi * inv_sq_p + return + endif + + Fc_integral = sqpi * 0.5d0**n * inv_sq_p**dble(n+1) * fact(n) / fact(shiftr(n, 1)) + +end function Fc_integral + +! --- + +complex*16 function crint(n, rho) + + implicit none + include 'constants.include.F' + + integer, intent(in) :: n + complex*16, intent(in) :: rho + + integer :: i, mmax + double precision :: rho_mod, rho_re, rho_im + double precision :: sq_rho_re, sq_rho_im + double precision :: n_tmp + complex*16 :: sq_rho, rho_inv, rho_exp + + complex*16 :: crint_smallz, cpx_erf + + rho_re = REAL (rho) + rho_im = AIMAG(rho) + rho_mod = dsqrt(rho_re*rho_re + rho_im*rho_im) + + if(rho_mod < 10.d0) then + ! small z + + if(rho_mod .lt. 1.d-10) then + crint = 1.d0 / dble(n + n + 1) + else + crint = crint_smallz(n, rho) + endif + + else + ! large z + + if(rho_mod .gt. 40.d0) then + + n_tmp = dble(n) + 0.5d0 + crint = 0.5d0 * gamma(n_tmp) / (rho**n_tmp) + + else + + ! get \sqrt(rho) + sq_rho_re = sq_op5 * dsqrt(rho_re + rho_mod) + sq_rho_im = 0.5d0 * rho_im / sq_rho_re + sq_rho = sq_rho_re + (0.d0, 1.d0) * sq_rho_im + + rho_exp = 0.5d0 * zexp(-rho) + rho_inv = (1.d0, 0.d0) / rho + + crint = 0.5d0 * sqpi * cpx_erf(sq_rho_re, sq_rho_im) / sq_rho + mmax = n + if(mmax .gt. 0) then + do i = 0, mmax-1 + crint = ((dble(i) + 0.5d0) * crint - rho_exp) * rho_inv + enddo + endif + + ! *** + + endif + + endif + +! print *, n, real(rho), real(crint) + +end function crint + +! --- + +complex*16 function crint_sum(n_pt_out, rho, d1) + + implicit none + include 'constants.include.F' + + integer, intent(in) :: n_pt_out + complex*16, intent(in) :: rho, d1(0:n_pt_out) + + integer :: n, i, mmax + double precision :: rho_mod, rho_re, rho_im + double precision :: sq_rho_re, sq_rho_im + complex*16 :: sq_rho, F0 + complex*16 :: rho_tmp, rho_inv, rho_exp + complex*16, allocatable :: Fm(:) + + complex*16 :: crint_smallz, cpx_erf + + rho_re = REAL (rho) + rho_im = AIMAG(rho) + rho_mod = dsqrt(rho_re*rho_re + rho_im*rho_im) + + if(rho_mod < 10.d0) then + ! small z + + if(rho_mod .lt. 1.d-10) then + +! print *, ' 111' +! print *, ' rho = ', rho + + crint_sum = d1(0) +! print *, 0, 1 + + do i = 2, n_pt_out, 2 + + n = shiftr(i, 1) + crint_sum = crint_sum + d1(i) / dble(n+n+1) + +! print *, n, 1.d0 / dble(n+n+1) + enddo + + ! *** + + else + +! print *, ' 222' +! print *, ' rho = ', real(rho) +! if(abs(aimag(rho)) .gt. 1d-15) then +! print *, ' complex rho', rho +! stop +! endif + + crint_sum = d1(0) * crint_smallz(0, rho) + +! print *, 0, real(d1(0)), real(crint_smallz(0, rho)) +! if(abs(aimag(d1(0))) .gt. 1d-15) then +! print *, ' complex d1(0)', d1(0) +! stop +! endif + + do i = 2, n_pt_out, 2 + n = shiftr(i, 1) + crint_sum = crint_sum + d1(i) * crint_smallz(n, rho) + +! print *, n, real(d1(i)), real(crint_smallz(n, rho)) +! if(abs(aimag(d1(i))) .gt. 1d-15) then +! print *, ' complex d1(i)', i, d1(i) +! stop +! endif + + enddo + +! print *, 'sum = ', real(crint_sum) +! if(abs(aimag(crint_sum)) .gt. 1d-15) then +! print *, ' complex crint_sum', crint_sum +! stop +! endif + + ! *** + + endif + + else + ! large z + + if(rho_mod .gt. 40.d0) then + +! print *, ' 333' +! print *, ' rho = ', rho + + rho_inv = (1.d0, 0.d0) / rho + rho_tmp = 0.5d0 * sqpi * zsqrt(rho_inv) + crint_sum = rho_tmp * d1(0) +! print *, 0, rho_tmp + + do i = 2, n_pt_out, 2 + n = shiftr(i, 1) + rho_tmp = rho_tmp * (dble(n) + 0.5d0) * rho_inv + crint_sum = crint_sum + rho_tmp * d1(i) +! print *, n, rho_tmp + enddo + + ! *** + + else + +! print *, ' 444' +! print *, ' rho = ', rho + + ! get \sqrt(rho) + sq_rho_re = sq_op5 * dsqrt(rho_re + rho_mod) + sq_rho_im = 0.5d0 * rho_im / sq_rho_re + sq_rho = sq_rho_re + (0.d0, 1.d0) * sq_rho_im + !sq_rho = zsqrt(rho) + + + F0 = 0.5d0 * sqpi * cpx_erf(sq_rho_re, sq_rho_im) / sq_rho + crint_sum = F0 * d1(0) +! print *, 0, F0 + + rho_exp = 0.5d0 * zexp(-rho) + rho_inv = (1.d0, 0.d0) / rho + + mmax = shiftr(n_pt_out, 1) + if(mmax .gt. 0) then + + allocate( Fm(mmax) ) + Fm(1:mmax) = (0.d0, 0.d0) + + do n = 0, mmax-1 + F0 = ((dble(n) + 0.5d0) * F0 - rho_exp) * rho_inv + Fm(n+1) = F0 +! print *, n, F0 + enddo + + do i = 2, n_pt_out, 2 + n = shiftr(i, 1) + crint_sum = crint_sum + Fm(n) * d1(i) + enddo + deallocate(Fm) + endif + + ! *** + + endif + + endif + +end function crint_sum + +! --- + +complex*16 function crint_smallz(n, rho) + + BEGIN_DOC + ! Standard version of rint + END_DOC + + implicit none + integer, intent(in) :: n + complex*16, intent(in) :: rho + + integer, parameter :: kmax = 40 + double precision, parameter :: eps = 1.d-13 + + integer :: k + double precision :: delta_mod + complex*16 :: rho_k, ct, delta_k + + ct = 0.5d0 * zexp(-rho) * gamma(dble(n) + 0.5d0) + rho_k = (1.d0, 0.d0) + crint_smallz = ct * rho_k / gamma(dble(n) + 1.5d0) + + do k = 1, kmax + + rho_k = rho_k * rho + delta_k = ct * rho_k / gamma(dble(n+k) + 1.5d0) + crint_smallz = crint_smallz + delta_k + + delta_mod = dsqrt(REAL(delta_k)*REAL(delta_k) + AIMAG(delta_k)*AIMAG(delta_k)) + if(delta_mod .lt. eps) return + enddo + + if(delta_mod > eps) then + write(*,*) ' pb in crint_smallz !' + write(*,*) ' n, rho = ', n, rho + write(*,*) ' delta_mod = ', delta_mod + stop 1 + endif + +end function crint_smallz + +! --- + diff --git a/src/utils/constants.include.F b/src/utils/constants.include.F index 297a839e..a96fabe6 100644 --- a/src/utils/constants.include.F +++ b/src/utils/constants.include.F @@ -16,4 +16,5 @@ double precision, parameter :: c_2_4_3 = 2.5198420997897464d0 double precision, parameter :: cst_lda = -0.93052573634909996d0 double precision, parameter :: c_4_3 = 1.3333333333333333d0 double precision, parameter :: c_1_3 = 0.3333333333333333d0 - +double precision, parameter :: sq_op5 = dsqrt(0.5d0) +double precision, parameter :: dlog_2pi = dlog(2.d0*dacos(-1.d0)) diff --git a/src/utils/cpx_erf.irp.f b/src/utils/cpx_erf.irp.f new file mode 100644 index 00000000..61f81055 --- /dev/null +++ b/src/utils/cpx_erf.irp.f @@ -0,0 +1,204 @@ + +! --- + +complex*16 function cpx_erf(x, y) + + BEGIN_DOC + ! + ! compute erf(z) for z = x + i y + ! + ! REF: Abramowitz and Stegun + ! + END_DOC + + implicit none + + double precision, intent(in) :: x, y + + double precision :: yabs + complex*16 :: erf_tmp1, erf_tmp2, erf_tmp3, erf_tot + + double precision :: erf_F + complex*16 :: erf_E, erf_G, erf_H + + yabs = dabs(y) + + if(yabs .lt. 1.d-15) then + + cpx_erf = (1.d0, 0.d0) * derf(x) + return + + else + + erf_tmp1 = (1.d0, 0.d0) * derf(x) + erf_tmp2 = erf_E(x, yabs) + erf_F(x, yabs) + erf_tmp3 = zexp(-(0.d0, 2.d0) * x * yabs) * ( erf_G(x, yabs) + erf_H(x, yabs) ) + erf_tot = erf_tmp1 + erf_tmp2 - erf_tmp3 + + endif + + if(y .gt. 0.d0) then + cpx_erf = erf_tot + else + cpx_erf = CONJG(erf_tot) + endif + +end function cpx_erf + +! --- + +complex*16 function erf_E(x, yabs) + + implicit none + include 'constants.include.F' + + double precision, intent(in) :: x, yabs + + if( (dabs(x).gt.6.d0) .or. (x==0.d0) ) then + erf_E = (0.d0, 0.d0) + return + endif + + if(dabs(x) .lt. 1.d-7) then + + erf_E = -inv_pi * (0.d0, 1.d0) * yabs + + else + + erf_E = 0.5d0 * inv_pi * dexp(-x*x) & + * ((1.d0, 0.d0) - zexp(-(2.d0, 0.d0) * x * yabs)) / x + + endif + +end function erf_E + +! --- + +double precision function erf_F(x, yabs) + + implicit none + include 'constants.include.F' + + double precision, intent(in) :: x, yabs + + integer, parameter :: Nmax = 13 + + integer :: i + double precision :: tmp1, tmp2, x2, ct + + + if(dabs(x) .gt. 5.8d0) then + + erf_F = 0.d0 + + else + + x2 = x * x + ct = x * inv_pi + + erf_F = 0.d0 + do i = 1, Nmax + + tmp1 = 0.25d0 * dble(i) * dble(i) + x2 + tmp2 = dexp(-tmp1) / tmp1 + erf_F = erf_F + tmp2 + + if(dabs(tmp2) .lt. 1d-15) exit + enddo + erf_F = ct * erf_F + + endif + +end function erf_F + +! --- + +complex*16 function erf_G(x, yabs) + + implicit none + include 'constants.include.F' + + double precision, intent(in) :: x, yabs + + integer, parameter :: Nmax = 13 + + integer :: i, tmpi, imin, imax + double precision :: tmp0, tmp1, x2, idble + complex*16 :: tmp2 + + if(x .eq. 0.d0) then + erf_G = (0.d0, 0.d0) + return + endif + + tmpi = int(2.d0 * yabs) + imin = max(1, tmpi-Nmax) + imax = tmpi + Nmax + + x2 = x * x + + erf_G = 0.d0 + do i = imin, imax + + idble = dble(i) + tmp0 = 0.5d0 * idble + tmp1 = tmp0 * tmp0 + x2 + tmp2 = dexp( idble * yabs - tmp1 - dlog(tmp1) - dlog_2pi) * (x - (0.d0, 1.d0)*tmp0) + + erf_G = erf_G + tmp2 + + enddo + +end function erf_G + +! --- + +complex*16 function erf_H(x, yabs) + + implicit none + include 'constants.include.F' + + double precision, intent(in) :: x, yabs + + integer, parameter :: Nmax = 13 + + integer :: i + double precision :: tmp0, tmp1, tmp_mod, x2, ct, idble + complex*16 :: tmp2 + + if(x .eq. 0.d0) then + erf_H = (0.d0, 0.d0) + return + endif + + + if( (dabs(x) .lt. 10d0) .and. (yabs .lt. 6.1d0) ) then + + x2 = x * x + ct = 0.5d0 * inv_pi + + erf_H = 0.d0 + do i = 1, Nmax + + idble = dble(i) + tmp0 = 0.5d0 * idble + tmp1 = tmp0 * tmp0 + x2 + tmp2 = dexp(-tmp1-idble*yabs) * (x + (0.d0, 1.d0)*tmp0) / tmp1 + erf_H = erf_H + tmp2 + + tmp_mod = dsqrt(REAL(tmp2)*REAL(tmp2) + AIMAG(tmp2)*AIMAG(tmp2)) + if(tmp_mod .lt. 1d-15) exit + enddo + erf_H = ct * erf_H + + else + + erf_H = (0.d0, 0.d0) + + endif + +end function erf_H + +! --- + + diff --git a/src/utils/format_w_error.irp.f b/src/utils/format_w_error.irp.f deleted file mode 100644 index 1378d367..00000000 --- a/src/utils/format_w_error.irp.f +++ /dev/null @@ -1,71 +0,0 @@ -subroutine format_w_error(value,error,size_nb,max_nb_digits,format_value,str_error) - - implicit none - - BEGIN_DOC - ! Format for double precision, value(error) - END_DOC - - ! in - ! | value | double precision | value... | - ! | error | double precision | error... | - ! | size_nb | integer | X in FX.Y | - ! | max_nb_digits | integer | Max Y in FX.Y | - - ! out - ! | format_value | character | string FX.Y for the format | - ! | str_error | character | string of the error | - - ! internal - ! | str_size | character | size in string format | - ! | nb_digits | integer | number of digits Y in FX.Y depending of the error | - ! | str_nb_digits | character | nb_digits in string format | - ! | str_exp | character | string of the value in exponential format | - - ! in - double precision, intent(in) :: error, value - integer, intent(in) :: size_nb, max_nb_digits - - ! out - character(len=20), intent(out) :: str_error, format_value - - ! internal - character(len=20) :: str_size, str_nb_digits, str_exp - integer :: nb_digits - - ! max_nb_digit: Y max - ! size_nb = Size of the double: X (FX.Y) - write(str_size,'(I3)') size_nb - - ! Error - write(str_exp,'(1pE20.0)') error - str_error = trim(adjustl(str_exp)) - - ! Number of digit: Y (FX.Y) from the exponent - str_nb_digits = str_exp(19:20) - read(str_nb_digits,*) nb_digits - - ! If the error is 0d0 - if (error <= 1d-16) then - write(str_nb_digits,*) max_nb_digits - endif - - ! If the error is too small - if (nb_digits > max_nb_digits) then - write(str_nb_digits,*) max_nb_digits - str_error(1:1) = '0' - endif - - ! If the error is too big (>= 0.5) - if (error >= 0.5d0) then - str_nb_digits = '1' - str_error(1:1) = '*' - endif - - ! FX.Y,A1,A1,A1 for value(str_error) - !string = 'F'//trim(adjustl(str_size))//'.'//trim(adjustl(str_nb_digits))//',A1,A1,A1' - - ! FX.Y just for the value - format_value = 'F'//trim(adjustl(str_size))//'.'//trim(adjustl(str_nb_digits)) - -end diff --git a/src/utils/integration.irp.f b/src/utils/integration.irp.f index 38e198dc..fe4418ac 100644 --- a/src/utils/integration.irp.f +++ b/src/utils/integration.irp.f @@ -443,14 +443,16 @@ end -double precision function rint(n,rho) - implicit none +double precision function rint(n, rho) + BEGIN_DOC -!.. math:: -! -! \int_0^1 dx \exp(-p x^2) x^n -! + !.. math:: + ! + ! \int_0^1 dx \exp(-p x^2) x^n + ! END_DOC + + implicit none include 'constants.include.F' double precision :: rho,u,rint1,v,val0,rint_large_n,u_inv integer :: n,k @@ -464,6 +466,7 @@ double precision function rint(n,rho) u=rho*u_inv rint=0.5d0*u_inv*sqpi*derf(u) endif +! print *, n, rho, rint return endif if(rho.lt.1.d0)then @@ -487,6 +490,7 @@ double precision function rint(n,rho) rint=rint_large_n(n,rho) endif endif +! print *, n, rho, rint end @@ -503,20 +507,24 @@ double precision function rint_sum(n_pt_out,rho,d1) integer :: n,k,i double precision :: two_rho_inv, rint_tmp, di +! print *, ' rho = ', rho if(rho < 1.d0)then if(rho == 0.d0)then rint_sum=d1(0) +! print *, 0, d1(0), 1 else u_inv=1.d0/dsqrt(rho) u=rho*u_inv rint_sum=0.5d0*u_inv*sqpi*derf(u) *d1(0) +! print *, 0, d1(0), 0.5d0*u_inv*sqpi*derf(u) endif do i=2,n_pt_out,2 n = shiftr(i,1) rint_sum = rint_sum + d1(i)*rint1(n,rho) +! print *, n, d1(i), rint1(n,rho) enddo else @@ -532,19 +540,25 @@ double precision function rint_sum(n_pt_out,rho,d1) two_rho_inv = 0.5d0*u_inv*u_inv val0=0.5d0*u_inv*sqpi*derf(u) rint_sum=val0*d1(0) +! print *, 0, d1(0), val0 + rint_tmp=(val0-v)*two_rho_inv di = 3.d0 do i=2,min(n_pt_out,40),2 rint_sum = rint_sum + d1(i)*rint_tmp +! print *, i, d1(i), rint_tmp rint_tmp = (rint_tmp*di-v)*two_rho_inv di = di+2.d0 enddo do i=42,n_pt_out,2 n = shiftr(i,1) rint_sum = rint_sum + d1(i)*rint_large_n(n,rho) +! print *, i, d1(i), rint_large_n(n, rho) enddo endif + +! print *, 'sum = ', rint_sum end double precision function hermite(n,x) @@ -627,3 +641,94 @@ double precision function rint1(n,rho) write(*,*)'pb in rint1 k too large!' stop 1 end + +! --- + +double precision function V_phi(n, m) + + 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 + + implicit none + integer, intent(in) :: n, m + + integer :: i + double precision :: prod + + double precision :: 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 function V_phi + +! --- + +double precision function V_theta(n, m) + + 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 + + implicit none + include 'utils/constants.include.F' + integer, intent(in) :: n, m + + integer :: i + double precision :: prod + + double precision :: Wallis + + 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 function V_theta + +! --- + +double precision function Wallis(n) + + BEGIN_DOC + ! Wallis integral: + ! + ! $\int_{0}^{\pi} \cos(\theta)^n d\theta$. + END_DOC + + implicit none + include 'utils/constants.include.F' + + integer, intent(in) :: n + + integer :: p + + double precision :: fact + + 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 function Wallis + +! --- + diff --git a/src/utils/linear_algebra.irp.f b/src/utils/linear_algebra.irp.f index 405d2d20..ae0bb8e5 100644 --- a/src/utils/linear_algebra.irp.f +++ b/src/utils/linear_algebra.irp.f @@ -1649,3 +1649,103 @@ subroutine restore_symmetry(m,n,A,LDA,thresh) enddo end + + + + + + + + + + + + + + + + + +!subroutine svd_s(A, LDA, U, LDU, D, Vt, LDVt, m, n) +! implicit none +! BEGIN_DOC +! ! !!! +! ! DGESVD computes the singular value decomposition (SVD) of a real +! ! M-by-N matrix A, optionally computing the left and/or right singular +! ! vectors. The SVD is written: +! ! A = U * SIGMA * transpose(V) +! ! where SIGMA is an M-by-N matrix which is zero except for its +! ! min(m,n) diagonal elements, U is an M-by-M orthogonal matrix, and +! ! V is an N-by-N orthogonal matrix. The diagonal elements of SIGMA +! ! are the singular values of A; they are real and non-negative, and +! ! are returned in descending order. The first min(m,n) columns of +! ! U and V are the left and right singular vectors of A. +! ! +! ! Note that the routine returns V**T, not V. +! ! !!! +! END_DOC +! +! integer, intent(in) :: LDA, LDU, LDVt, m, n +! double precision, intent(in) :: A(LDA,n) +! double precision, intent(out) :: U(LDU,m), Vt(LDVt,n), D(min(m,n)) +! double precision,allocatable :: work(:), A_tmp(:,:) +! integer :: info, lwork, i, j, k +! +! +! allocate (A_tmp(LDA,n)) +! do k=1,n +! do i=1,m +! !A_tmp(i,k) = A(i,k) + 1d-16 +! A_tmp(i,k) = A(i,k) +! enddo +! enddo +! +! ! Find optimal size for temp arrays +! allocate(work(1)) +! lwork = -1 +! ! 'A': all M columns of U are returned in array U +! ! 'A': all N rows of V**T are returned in the array VT +! call dgesvd('A', 'A', m, n, A_tmp, LDA, D, U, LDU, Vt, LDVt, work, lwork, info) +! ! /!\ int(WORK(1)) becomes negative when WORK(1) > 2147483648 +! if( info.ne.0 ) then +! print *, ' problem in first call DGESVD !!!!' +! print *, ' info = ', info +! print *, ' < 0 : if INFO = -i, the i-th argument had an illegal value.' +! print *, ' > 0 : if DBDSQR did not converge, INFO specifies how many ' +! print *, ' superdiagonals of an intermediate bidiagonal form B ' +! print *, ' did not converge to zero. See the description of WORK' +! print *, ' above for details. ' +! stop +! endif +! lwork = max(int(work(1)), 5*MIN(M,N)) +! deallocate(work) +! +! allocate(work(lwork)) +! +! call dgesvd('A', 'A', m, n, A_tmp, LDA, D, U, LDU, Vt, LDVt, work, lwork, info) +! if( info.ne.0 ) then +! print *, ' problem in second call DGESVD !!!!' +! print *, ' info = ', info +! print *, ' < 0 : if INFO = -i, the i-th argument had an illegal value.' +! print *, ' > 0 : if DBDSQR did not converge, INFO specifies how many ' +! print *, ' superdiagonals of an intermediate bidiagonal form B ' +! print *, ' did not converge to zero. See the description of WORK' +! print *, ' above for details. ' +! stop +! endif +! +! deallocate(A_tmp,work) +! +! !do j=1, m +! ! do i=1, LDU +! ! if (dabs(U(i,j)) < 1.d-14) U(i,j) = 0.d0 +! ! enddo +! !enddo +! !do j = 1, n +! ! do i = 1, LDVt +! ! if (dabs(Vt(i,j)) < 1.d-14) Vt(i,j) = 0.d0 +! ! enddo +! !enddo +! +!end +! diff --git a/src/utils/map_module.f90 b/src/utils/map_module.f90 index ceaec874..98e73470 100644 --- a/src/utils/map_module.f90 +++ b/src/utils/map_module.f90 @@ -238,11 +238,11 @@ subroutine cache_map_sort(map) iorder(i) = i enddo if (cache_key_kind == 2) then - call i2sort(map%key,iorder,map%n_elements,-1) + call i2radix_sort(map%key,iorder,map%n_elements,-1) else if (cache_key_kind == 4) then - call isort(map%key,iorder,map%n_elements,-1) + call iradix_sort(map%key,iorder,map%n_elements,-1) else if (cache_key_kind == 8) then - call i8sort(map%key,iorder,map%n_elements,-1) + call i8radix_sort(map%key,iorder,map%n_elements,-1) endif if (integral_kind == 4) then call set_order(map%value,iorder,map%n_elements) diff --git a/src/utils/memory.irp.f b/src/utils/memory.irp.f index d5a066a1..3ea242b0 100644 --- a/src/utils/memory.irp.f +++ b/src/utils/memory.irp.f @@ -114,7 +114,7 @@ subroutine print_memory_usage() call resident_memory(rss) call total_memory(mem) - write(*,'(A,F14.3,A,F14.3,A)') & + write(*,'(A,F14.6,A,F14.6,A)') & '.. >>>>> [ RES MEM : ', rss , & ' GB ] [ VIRT MEM : ', mem, ' GB ] <<<<< ..' end diff --git a/src/utils/qsort.c b/src/utils/qsort.c deleted file mode 100644 index c011b35a..00000000 --- a/src/utils/qsort.c +++ /dev/null @@ -1,373 +0,0 @@ -/* [[file:~/qp2/src/utils/qsort.org::*Generated%20C%20file][Generated C file:1]] */ -#include -#include - -struct int16_t_comp { - int16_t x; - int32_t i; -}; - -int compare_int16_t( const void * l, const void * r ) -{ - const int16_t * restrict _l= l; - const int16_t * restrict _r= r; - if( *_l > *_r ) return 1; - if( *_l < *_r ) return -1; - return 0; -} - -void qsort_int16_t(int16_t* restrict A_in, int32_t* restrict iorder, int32_t isize) { - struct int16_t_comp* A = malloc(isize * sizeof(struct int16_t_comp)); - if (A == NULL) return; - - for (int i=0 ; i *_r ) return 1; - if( *_l < *_r ) return -1; - return 0; -} - -void qsort_int16_t_big(int16_t* restrict A_in, int64_t* restrict iorder, int64_t isize) { - struct int16_t_comp_big* A = malloc(isize * sizeof(struct int16_t_comp_big)); - if (A == NULL) return; - - for (int i=0 ; i *_r ) return 1; - if( *_l < *_r ) return -1; - return 0; -} - -void qsort_int32_t(int32_t* restrict A_in, int32_t* restrict iorder, int32_t isize) { - struct int32_t_comp* A = malloc(isize * sizeof(struct int32_t_comp)); - if (A == NULL) return; - - for (int i=0 ; i *_r ) return 1; - if( *_l < *_r ) return -1; - return 0; -} - -void qsort_int32_t_big(int32_t* restrict A_in, int64_t* restrict iorder, int64_t isize) { - struct int32_t_comp_big* A = malloc(isize * sizeof(struct int32_t_comp_big)); - if (A == NULL) return; - - for (int i=0 ; i *_r ) return 1; - if( *_l < *_r ) return -1; - return 0; -} - -void qsort_int64_t(int64_t* restrict A_in, int32_t* restrict iorder, int32_t isize) { - struct int64_t_comp* A = malloc(isize * sizeof(struct int64_t_comp)); - if (A == NULL) return; - - for (int i=0 ; i *_r ) return 1; - if( *_l < *_r ) return -1; - return 0; -} - -void qsort_int64_t_big(int64_t* restrict A_in, int64_t* restrict iorder, int64_t isize) { - struct int64_t_comp_big* A = malloc(isize * sizeof(struct int64_t_comp_big)); - if (A == NULL) return; - - for (int i=0 ; i *_r ) return 1; - if( *_l < *_r ) return -1; - return 0; -} - -void qsort_double(double* restrict A_in, int32_t* restrict iorder, int32_t isize) { - struct double_comp* A = malloc(isize * sizeof(struct double_comp)); - if (A == NULL) return; - - for (int i=0 ; i *_r ) return 1; - if( *_l < *_r ) return -1; - return 0; -} - -void qsort_double_big(double* restrict A_in, int64_t* restrict iorder, int64_t isize) { - struct double_comp_big* A = malloc(isize * sizeof(struct double_comp_big)); - if (A == NULL) return; - - for (int i=0 ; i *_r ) return 1; - if( *_l < *_r ) return -1; - return 0; -} - -void qsort_float(float* restrict A_in, int32_t* restrict iorder, int32_t isize) { - struct float_comp* A = malloc(isize * sizeof(struct float_comp)); - if (A == NULL) return; - - for (int i=0 ; i *_r ) return 1; - if( *_l < *_r ) return -1; - return 0; -} - -void qsort_float_big(float* restrict A_in, int64_t* restrict iorder, int64_t isize) { - struct float_comp_big* A = malloc(isize * sizeof(struct float_comp_big)); - if (A == NULL) return; - - for (int i=0 ; i *_r ) return 1; - if( *_l < *_r ) return -1; - return 0; -} - -void qsort_TYPE_big(TYPE* restrict A_in, int32_t* restrict iorder, int32_t isize) { - struct TYPE_comp_big* A = malloc(isize * sizeof(struct TYPE_comp_big)); - if (A == NULL) return; - - for (int i=0 ; i> -""" -for typ in ["int16_t", "int32_t", "int64_t", "double", "float"]: - print( data.replace("TYPE", typ).replace("_big", "") ) - print( data.replace("int32_t", "int64_t").replace("TYPE", typ) ) -#+end_src - -#+NAME: replaced_f -#+begin_src python :results output :noweb yes -data = """ -<> -""" -c1 = { - "int16_t": "i2", - "int32_t": "i", - "int64_t": "i8", - "double": "d", - "float": "" -} -c2 = { - "int16_t": "integer", - "int32_t": "integer", - "int64_t": "integer", - "double": "real", - "float": "real" -} - -for typ in ["int16_t", "int32_t", "int64_t", "double", "float"]: - print( data.replace("real",c2[typ]).replace("L",c1[typ]).replace("TYPE", typ).replace("_big", "") ) - print( data.replace("real",c2[typ]).replace("L",c1[typ]).replace("int32_t", "int64_t").replace("TYPE", typ) ) -#+end_src - -#+NAME: replaced_f2 -#+begin_src python :results output :noweb yes -data = """ -<> -""" -c1 = { - "int16_t": "i2", - "int32_t": "i", - "int64_t": "i8", - "double": "d", - "float": "" -} -c2 = { - "int16_t": "integer", - "int32_t": "integer", - "int64_t": "integer", - "double": "real", - "float": "real" -} - -for typ in ["int16_t", "int32_t", "int64_t", "double", "float"]: - print( data.replace("real",c2[typ]).replace("L",c1[typ]).replace("TYPE", typ).replace("_big", "") ) - print( data.replace("real",c2[typ]).replace("L",c1[typ]).replace("int32_t", "int64_t").replace("TYPE", typ) ) -#+end_src - -* Generated C file - -#+BEGIN_SRC c :comments link :tangle qsort.c :noweb yes -#include -#include -<> -#+END_SRC - -* Generated Fortran file - -#+BEGIN_SRC f90 :tangle qsort_module.f90 :noweb yes -module qsort_module - use iso_c_binding - - interface - <> - end interface - -end module qsort_module - -<> - -#+END_SRC - diff --git a/src/utils/qsort_module.f90 b/src/utils/qsort_module.f90 deleted file mode 100644 index a72a4f9e..00000000 --- a/src/utils/qsort_module.f90 +++ /dev/null @@ -1,347 +0,0 @@ -module qsort_module - use iso_c_binding - - interface - - subroutine i2sort_c(A, iorder, isize) bind(C, name="qsort_int16_t") - use iso_c_binding - integer(c_int32_t), value :: isize - integer(c_int32_t) :: iorder(isize) - integer (c_int16_t) :: A(isize) - end subroutine i2sort_c - - subroutine i2sort_noidx_c(A, isize) bind(C, name="qsort_int16_t_noidx") - use iso_c_binding - integer(c_int32_t), value :: isize - integer (c_int16_t) :: A(isize) - end subroutine i2sort_noidx_c - - - - subroutine i2sort_big_c(A, iorder, isize) bind(C, name="qsort_int16_t_big") - use iso_c_binding - integer(c_int64_t), value :: isize - integer(c_int64_t) :: iorder(isize) - integer (c_int16_t) :: A(isize) - end subroutine i2sort_big_c - - subroutine i2sort_noidx_big_c(A, isize) bind(C, name="qsort_int16_t_noidx_big") - use iso_c_binding - integer(c_int64_t), value :: isize - integer (c_int16_t) :: A(isize) - end subroutine i2sort_noidx_big_c - - - - subroutine isort_c(A, iorder, isize) bind(C, name="qsort_int32_t") - use iso_c_binding - integer(c_int32_t), value :: isize - integer(c_int32_t) :: iorder(isize) - integer (c_int32_t) :: A(isize) - end subroutine isort_c - - subroutine isort_noidx_c(A, isize) bind(C, name="qsort_int32_t_noidx") - use iso_c_binding - integer(c_int32_t), value :: isize - integer (c_int32_t) :: A(isize) - end subroutine isort_noidx_c - - - - subroutine isort_big_c(A, iorder, isize) bind(C, name="qsort_int32_t_big") - use iso_c_binding - integer(c_int64_t), value :: isize - integer(c_int64_t) :: iorder(isize) - integer (c_int32_t) :: A(isize) - end subroutine isort_big_c - - subroutine isort_noidx_big_c(A, isize) bind(C, name="qsort_int32_t_noidx_big") - use iso_c_binding - integer(c_int64_t), value :: isize - integer (c_int32_t) :: A(isize) - end subroutine isort_noidx_big_c - - - - subroutine i8sort_c(A, iorder, isize) bind(C, name="qsort_int64_t") - use iso_c_binding - integer(c_int32_t), value :: isize - integer(c_int32_t) :: iorder(isize) - integer (c_int64_t) :: A(isize) - end subroutine i8sort_c - - subroutine i8sort_noidx_c(A, isize) bind(C, name="qsort_int64_t_noidx") - use iso_c_binding - integer(c_int32_t), value :: isize - integer (c_int64_t) :: A(isize) - end subroutine i8sort_noidx_c - - - - subroutine i8sort_big_c(A, iorder, isize) bind(C, name="qsort_int64_t_big") - use iso_c_binding - integer(c_int64_t), value :: isize - integer(c_int64_t) :: iorder(isize) - integer (c_int64_t) :: A(isize) - end subroutine i8sort_big_c - - subroutine i8sort_noidx_big_c(A, isize) bind(C, name="qsort_int64_t_noidx_big") - use iso_c_binding - integer(c_int64_t), value :: isize - integer (c_int64_t) :: A(isize) - end subroutine i8sort_noidx_big_c - - - - subroutine dsort_c(A, iorder, isize) bind(C, name="qsort_double") - use iso_c_binding - integer(c_int32_t), value :: isize - integer(c_int32_t) :: iorder(isize) - real (c_double) :: A(isize) - end subroutine dsort_c - - subroutine dsort_noidx_c(A, isize) bind(C, name="qsort_double_noidx") - use iso_c_binding - integer(c_int32_t), value :: isize - real (c_double) :: A(isize) - end subroutine dsort_noidx_c - - - - subroutine dsort_big_c(A, iorder, isize) bind(C, name="qsort_double_big") - use iso_c_binding - integer(c_int64_t), value :: isize - integer(c_int64_t) :: iorder(isize) - real (c_double) :: A(isize) - end subroutine dsort_big_c - - subroutine dsort_noidx_big_c(A, isize) bind(C, name="qsort_double_noidx_big") - use iso_c_binding - integer(c_int64_t), value :: isize - real (c_double) :: A(isize) - end subroutine dsort_noidx_big_c - - - - subroutine sort_c(A, iorder, isize) bind(C, name="qsort_float") - use iso_c_binding - integer(c_int32_t), value :: isize - integer(c_int32_t) :: iorder(isize) - real (c_float) :: A(isize) - end subroutine sort_c - - subroutine sort_noidx_c(A, isize) bind(C, name="qsort_float_noidx") - use iso_c_binding - integer(c_int32_t), value :: isize - real (c_float) :: A(isize) - end subroutine sort_noidx_c - - - - subroutine sort_big_c(A, iorder, isize) bind(C, name="qsort_float_big") - use iso_c_binding - integer(c_int64_t), value :: isize - integer(c_int64_t) :: iorder(isize) - real (c_float) :: A(isize) - end subroutine sort_big_c - - subroutine sort_noidx_big_c(A, isize) bind(C, name="qsort_float_noidx_big") - use iso_c_binding - integer(c_int64_t), value :: isize - real (c_float) :: A(isize) - end subroutine sort_noidx_big_c - - - - end interface - -end module qsort_module - - -subroutine i2sort(A, iorder, isize) - use qsort_module - use iso_c_binding - integer(c_int32_t) :: isize - integer(c_int32_t) :: iorder(isize) - integer (c_int16_t) :: A(isize) - call i2sort_c(A, iorder, isize) -end subroutine i2sort - -subroutine i2sort_noidx(A, isize) - use iso_c_binding - use qsort_module - integer(c_int32_t) :: isize - integer (c_int16_t) :: A(isize) - call i2sort_noidx_c(A, isize) -end subroutine i2sort_noidx - - - -subroutine i2sort_big(A, iorder, isize) - use qsort_module - use iso_c_binding - integer(c_int64_t) :: isize - integer(c_int64_t) :: iorder(isize) - integer (c_int16_t) :: A(isize) - call i2sort_big_c(A, iorder, isize) -end subroutine i2sort_big - -subroutine i2sort_noidx_big(A, isize) - use iso_c_binding - use qsort_module - integer(c_int64_t) :: isize - integer (c_int16_t) :: A(isize) - call i2sort_noidx_big_c(A, isize) -end subroutine i2sort_noidx_big - - - -subroutine isort(A, iorder, isize) - use qsort_module - use iso_c_binding - integer(c_int32_t) :: isize - integer(c_int32_t) :: iorder(isize) - integer (c_int32_t) :: A(isize) - call isort_c(A, iorder, isize) -end subroutine isort - -subroutine isort_noidx(A, isize) - use iso_c_binding - use qsort_module - integer(c_int32_t) :: isize - integer (c_int32_t) :: A(isize) - call isort_noidx_c(A, isize) -end subroutine isort_noidx - - - -subroutine isort_big(A, iorder, isize) - use qsort_module - use iso_c_binding - integer(c_int64_t) :: isize - integer(c_int64_t) :: iorder(isize) - integer (c_int32_t) :: A(isize) - call isort_big_c(A, iorder, isize) -end subroutine isort_big - -subroutine isort_noidx_big(A, isize) - use iso_c_binding - use qsort_module - integer(c_int64_t) :: isize - integer (c_int32_t) :: A(isize) - call isort_noidx_big_c(A, isize) -end subroutine isort_noidx_big - - - -subroutine i8sort(A, iorder, isize) - use qsort_module - use iso_c_binding - integer(c_int32_t) :: isize - integer(c_int32_t) :: iorder(isize) - integer (c_int64_t) :: A(isize) - call i8sort_c(A, iorder, isize) -end subroutine i8sort - -subroutine i8sort_noidx(A, isize) - use iso_c_binding - use qsort_module - integer(c_int32_t) :: isize - integer (c_int64_t) :: A(isize) - call i8sort_noidx_c(A, isize) -end subroutine i8sort_noidx - - - -subroutine i8sort_big(A, iorder, isize) - use qsort_module - use iso_c_binding - integer(c_int64_t) :: isize - integer(c_int64_t) :: iorder(isize) - integer (c_int64_t) :: A(isize) - call i8sort_big_c(A, iorder, isize) -end subroutine i8sort_big - -subroutine i8sort_noidx_big(A, isize) - use iso_c_binding - use qsort_module - integer(c_int64_t) :: isize - integer (c_int64_t) :: A(isize) - call i8sort_noidx_big_c(A, isize) -end subroutine i8sort_noidx_big - - - -subroutine dsort(A, iorder, isize) - use qsort_module - use iso_c_binding - integer(c_int32_t) :: isize - integer(c_int32_t) :: iorder(isize) - real (c_double) :: A(isize) - call dsort_c(A, iorder, isize) -end subroutine dsort - -subroutine dsort_noidx(A, isize) - use iso_c_binding - use qsort_module - integer(c_int32_t) :: isize - real (c_double) :: A(isize) - call dsort_noidx_c(A, isize) -end subroutine dsort_noidx - - - -subroutine dsort_big(A, iorder, isize) - use qsort_module - use iso_c_binding - integer(c_int64_t) :: isize - integer(c_int64_t) :: iorder(isize) - real (c_double) :: A(isize) - call dsort_big_c(A, iorder, isize) -end subroutine dsort_big - -subroutine dsort_noidx_big(A, isize) - use iso_c_binding - use qsort_module - integer(c_int64_t) :: isize - real (c_double) :: A(isize) - call dsort_noidx_big_c(A, isize) -end subroutine dsort_noidx_big - - - -subroutine sort(A, iorder, isize) - use qsort_module - use iso_c_binding - integer(c_int32_t) :: isize - integer(c_int32_t) :: iorder(isize) - real (c_float) :: A(isize) - call sort_c(A, iorder, isize) -end subroutine sort - -subroutine sort_noidx(A, isize) - use iso_c_binding - use qsort_module - integer(c_int32_t) :: isize - real (c_float) :: A(isize) - call sort_noidx_c(A, isize) -end subroutine sort_noidx - - - -subroutine sort_big(A, iorder, isize) - use qsort_module - use iso_c_binding - integer(c_int64_t) :: isize - integer(c_int64_t) :: iorder(isize) - real (c_float) :: A(isize) - call sort_big_c(A, iorder, isize) -end subroutine sort_big - -subroutine sort_noidx_big(A, isize) - use iso_c_binding - use qsort_module - integer(c_int64_t) :: isize - real (c_float) :: A(isize) - call sort_noidx_big_c(A, isize) -end subroutine sort_noidx_big diff --git a/src/utils/set_multiple_levels_omp.irp.f b/src/utils/set_multiple_levels_omp.irp.f deleted file mode 100644 index 572a13f4..00000000 --- a/src/utils/set_multiple_levels_omp.irp.f +++ /dev/null @@ -1,26 +0,0 @@ -subroutine set_multiple_levels_omp(activate) - - BEGIN_DOC -! If true, activate OpenMP nested parallelism. If false, deactivate. - END_DOC - - implicit none - logical, intent(in) :: activate - - if (activate) then - call omp_set_max_active_levels(3) - - IRP_IF SET_NESTED - call omp_set_nested(.True.) - IRP_ENDIF - - else - - call omp_set_max_active_levels(1) - - IRP_IF SET_NESTED - call omp_set_nested(.False.) - IRP_ENDIF - end if - -end diff --git a/src/utils/sort.irp.f b/src/utils/sort.irp.f index 089c3871..a63eb4a3 100644 --- a/src/utils/sort.irp.f +++ b/src/utils/sort.irp.f @@ -1,4 +1,222 @@ BEGIN_TEMPLATE + subroutine insertion_$Xsort (x,iorder,isize) + implicit none + BEGIN_DOC + ! Sort array x(isize) using the insertion sort algorithm. + ! iorder in input should be (1,2,3,...,isize), and in output + ! contains the new order of the elements. + END_DOC + integer,intent(in) :: isize + $type,intent(inout) :: x(isize) + integer,intent(inout) :: iorder(isize) + $type :: xtmp + integer :: i, i0, j, jmax + + do i=2,isize + xtmp = x(i) + i0 = iorder(i) + j=i-1 + do while (j>0) + if ((x(j) <= xtmp)) exit + x(j+1) = x(j) + iorder(j+1) = iorder(j) + j=j-1 + enddo + x(j+1) = xtmp + iorder(j+1) = i0 + enddo + end subroutine insertion_$Xsort + + subroutine quick_$Xsort(x, iorder, isize) + implicit none + BEGIN_DOC + ! Sort array x(isize) using the quicksort algorithm. + ! iorder in input should be (1,2,3,...,isize), and in output + ! contains the new order of the elements. + END_DOC + integer,intent(in) :: isize + $type,intent(inout) :: x(isize) + integer,intent(inout) :: iorder(isize) + integer, external :: omp_get_num_threads + call rec_$X_quicksort(x,iorder,isize,1,isize,nproc) + end + + recursive subroutine rec_$X_quicksort(x, iorder, isize, first, last, level) + implicit none + integer, intent(in) :: isize, first, last, level + integer,intent(inout) :: iorder(isize) + $type, intent(inout) :: x(isize) + $type :: c, tmp + integer :: itmp + integer :: i, j + + if(isize<2)return + + c = x( shiftr(first+last,1) ) + i = first + j = last + do + do while (x(i) < c) + i=i+1 + end do + do while (c < x(j)) + j=j-1 + end do + if (i >= j) exit + tmp = x(i) + x(i) = x(j) + x(j) = tmp + itmp = iorder(i) + iorder(i) = iorder(j) + iorder(j) = itmp + i=i+1 + j=j-1 + enddo + if ( ((i-first <= 10000).and.(last-j <= 10000)).or.(level<=0) ) then + if (first < i-1) then + call rec_$X_quicksort(x, iorder, isize, first, i-1,level/2) + endif + if (j+1 < last) then + call rec_$X_quicksort(x, iorder, isize, j+1, last,level/2) + endif + else + if (first < i-1) then + call rec_$X_quicksort(x, iorder, isize, first, i-1,level/2) + endif + if (j+1 < last) then + call rec_$X_quicksort(x, iorder, isize, j+1, last,level/2) + endif + endif + end + + subroutine heap_$Xsort(x,iorder,isize) + implicit none + BEGIN_DOC + ! Sort array x(isize) using the heap sort algorithm. + ! iorder in input should be (1,2,3,...,isize), and in output + ! contains the new order of the elements. + END_DOC + integer,intent(in) :: isize + $type,intent(inout) :: x(isize) + integer,intent(inout) :: iorder(isize) + + integer :: i, k, j, l, i0 + $type :: xtemp + + l = isize/2+1 + k = isize + do while (.True.) + if (l>1) then + l=l-1 + xtemp = x(l) + i0 = iorder(l) + else + xtemp = x(k) + i0 = iorder(k) + x(k) = x(1) + iorder(k) = iorder(1) + k = k-1 + if (k == 1) then + x(1) = xtemp + iorder(1) = i0 + exit + endif + endif + i=l + j = shiftl(l,1) + do while (j1) then + l=l-1 + xtemp = x(l) + i0 = iorder(l) + else + xtemp = x(k) + i0 = iorder(k) + x(k) = x(1) + iorder(k) = iorder(1) + k = k-1 + if (k == 1) then + x(1) = xtemp + iorder(1) = i0 + exit + endif + endif + i=l + j = shiftl(l,1) + do while (j0_8) + if (x(j)<=xtmp) exit + x(j+1_8) = x(j) + iorder(j+1_8) = iorder(j) + j = j-1_8 + enddo + x(j+1_8) = xtmp + iorder(j+1_8) = i0 + enddo + + end subroutine insertion_$Xsort_big + subroutine $Xset_order_big(x,iorder,isize) implicit none BEGIN_DOC @@ -90,3 +563,223 @@ SUBST [ X, type ] END_TEMPLATE +BEGIN_TEMPLATE + +recursive subroutine $Xradix_sort$big(x,iorder,isize,iradix) + implicit none + + BEGIN_DOC + ! Sort integer array x(isize) using the radix sort algorithm. + ! iorder in input should be (1,2,3,...,isize), and in output + ! contains the new order of the elements. + ! iradix should be -1 in input. + END_DOC + integer*$int_type, intent(in) :: isize + integer*$int_type, intent(inout) :: iorder(isize) + integer*$type, intent(inout) :: x(isize) + integer, intent(in) :: iradix + integer :: iradix_new + integer*$type, allocatable :: x2(:), x1(:) + integer*$type :: i4 ! data type + integer*$int_type, allocatable :: iorder1(:),iorder2(:) + integer*$int_type :: i0, i1, i2, i3, i ! index type + integer*$type :: mask + integer :: err + !DIR$ ATTRIBUTES ALIGN : 128 :: iorder1,iorder2, x2, x1 + + if (isize < 2) then + return + endif + + if (iradix == -1) then ! Sort Positive and negative + + allocate(x1(isize),iorder1(isize), x2(isize),iorder2(isize),stat=err) + if (err /= 0) then + print *, irp_here, ': Unable to allocate arrays' + stop + endif + + i1=1_$int_type + i2=1_$int_type + do i=1_$int_type,isize + if (x(i) < 0_$type) then + iorder1(i1) = iorder(i) + x1(i1) = -x(i) + i1 = i1+1_$int_type + else + iorder2(i2) = iorder(i) + x2(i2) = x(i) + i2 = i2+1_$int_type + endif + enddo + i1=i1-1_$int_type + i2=i2-1_$int_type + + do i=1_$int_type,i2 + iorder(i1+i) = iorder2(i) + x(i1+i) = x2(i) + enddo + deallocate(x2,iorder2,stat=err) + if (err /= 0) then + print *, irp_here, ': Unable to deallocate arrays x2, iorder2' + stop + endif + + + if (i1 > 1_$int_type) then + call $Xradix_sort$big(x1,iorder1,i1,-2) + do i=1_$int_type,i1 + x(i) = -x1(1_$int_type+i1-i) + iorder(i) = iorder1(1_$int_type+i1-i) + enddo + endif + + if (i2>1_$int_type) then + call $Xradix_sort$big(x(i1+1_$int_type),iorder(i1+1_$int_type),i2,-2) + endif + + deallocate(x1,iorder1,stat=err) + if (err /= 0) then + print *, irp_here, ': Unable to deallocate arrays x1, iorder1' + stop + endif + return + + else if (iradix == -2) then ! Positive + + ! Find most significant bit + + i0 = 0_$int_type + i4 = maxval(x) + + iradix_new = max($integer_size-1-leadz(i4),1) + mask = ibset(0_$type,iradix_new) + + allocate(x1(isize),iorder1(isize), x2(isize),iorder2(isize),stat=err) + if (err /= 0) then + print *, irp_here, ': Unable to allocate arrays' + stop + endif + + i1=1_$int_type + i2=1_$int_type + + do i=1_$int_type,isize + if (iand(mask,x(i)) == 0_$type) then + iorder1(i1) = iorder(i) + x1(i1) = x(i) + i1 = i1+1_$int_type + else + iorder2(i2) = iorder(i) + x2(i2) = x(i) + i2 = i2+1_$int_type + endif + enddo + i1=i1-1_$int_type + i2=i2-1_$int_type + + do i=1_$int_type,i1 + iorder(i0+i) = iorder1(i) + x(i0+i) = x1(i) + enddo + i0 = i0+i1 + i3 = i0 + deallocate(x1,iorder1,stat=err) + if (err /= 0) then + print *, irp_here, ': Unable to deallocate arrays x1, iorder1' + stop + endif + + + do i=1_$int_type,i2 + iorder(i0+i) = iorder2(i) + x(i0+i) = x2(i) + enddo + i0 = i0+i2 + deallocate(x2,iorder2,stat=err) + if (err /= 0) then + print *, irp_here, ': Unable to deallocate arrays x2, iorder2' + stop + endif + + + if (i3>1_$int_type) then + call $Xradix_sort$big(x,iorder,i3,iradix_new-1) + endif + + if (isize-i3>1_$int_type) then + call $Xradix_sort$big(x(i3+1_$int_type),iorder(i3+1_$int_type),isize-i3,iradix_new-1) + endif + + return + endif + + ASSERT (iradix >= 0) + + if (isize < 48) then + call insertion_$Xsort$big(x,iorder,isize) + return + endif + + + allocate(x2(isize),iorder2(isize),stat=err) + if (err /= 0) then + print *, irp_here, ': Unable to allocate arrays x1, iorder1' + stop + endif + + + mask = ibset(0_$type,iradix) + i0=1_$int_type + i1=1_$int_type + + do i=1_$int_type,isize + if (iand(mask,x(i)) == 0_$type) then + iorder(i0) = iorder(i) + x(i0) = x(i) + i0 = i0+1_$int_type + else + iorder2(i1) = iorder(i) + x2(i1) = x(i) + i1 = i1+1_$int_type + endif + enddo + i0=i0-1_$int_type + i1=i1-1_$int_type + + do i=1_$int_type,i1 + iorder(i0+i) = iorder2(i) + x(i0+i) = x2(i) + enddo + + deallocate(x2,iorder2,stat=err) + if (err /= 0) then + print *, irp_here, ': Unable to allocate arrays x2, iorder2' + stop + endif + + + if (iradix == 0) then + return + endif + + + if (i1>1_$int_type) then + call $Xradix_sort$big(x(i0+1_$int_type),iorder(i0+1_$int_type),i1,iradix-1) + endif + if (i0>1) then + call $Xradix_sort$big(x,iorder,i0,iradix-1) + endif + + end + +SUBST [ X, type, integer_size, is_big, big, int_type ] + i ; 4 ; 32 ; .False. ; ; 4 ;; + i8 ; 8 ; 64 ; .False. ; ; 4 ;; + i2 ; 2 ; 16 ; .False. ; ; 4 ;; + i ; 4 ; 32 ; .True. ; _big ; 8 ;; + i8 ; 8 ; 64 ; .True. ; _big ; 8 ;; +END_TEMPLATE + + + diff --git a/src/utils/units.irp.f b/src/utils/units.irp.f deleted file mode 100644 index 1850b28b..00000000 --- a/src/utils/units.irp.f +++ /dev/null @@ -1,22 +0,0 @@ -BEGIN_PROVIDER [double precision, ha_to_ev] - - implicit none - BEGIN_DOC - ! Converstion from Hartree to eV - END_DOC - - ha_to_ev = 27.211396641308d0 - -END_PROVIDER - -BEGIN_PROVIDER [double precision, au_to_D] - - implicit none - BEGIN_DOC - ! Converstion from au to Debye - END_DOC - - au_to_D = 2.5415802529d0 - -END_PROVIDER - diff --git a/src/utils/util.irp.f b/src/utils/util.irp.f index 84593031..184d8052 100644 --- a/src/utils/util.irp.f +++ b/src/utils/util.irp.f @@ -37,10 +37,6 @@ double precision function binom_func(i,j) else binom_func = dexp( logfact(i)-logfact(j)-logfact(i-j) ) endif - - ! To avoid .999999 numbers - binom_func = floor(binom_func + 0.5d0) - end @@ -136,7 +132,7 @@ double precision function logfact(n) enddo end function - +! --- BEGIN_PROVIDER [ double precision, fact_inv, (128) ] implicit none @@ -150,6 +146,29 @@ BEGIN_PROVIDER [ double precision, fact_inv, (128) ] enddo END_PROVIDER +! --- + +BEGIN_PROVIDER [ double precision, shiftfact_op5_inv, (128) ] + + BEGIN_DOC + ! + ! 1 / Gamma(n + 0.5) + ! + END_DOC + + implicit none + integer :: i + double precision :: tmp + + do i = 1, size(shiftfact_op5_inv) + !tmp = dgamma(dble(i) + 0.5d0) + tmp = gamma(dble(i) + 0.5d0) + shiftfact_op5_inv(i) = 1.d0 / tmp + enddo + +END_PROVIDER + +! --- double precision function dble_fact(n) implicit none @@ -304,12 +323,12 @@ subroutine wall_time(t) end BEGIN_PROVIDER [ integer, nproc ] - use omp_lib implicit none BEGIN_DOC ! Number of current OpenMP threads END_DOC + integer :: omp_get_num_threads nproc = 1 !$OMP PARALLEL !$OMP MASTER