merged with Abdallah

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, <positional-argument>, commands, which could be
+    [optional], (required), (mutually | exclusive) or repeated...
+
+    Parameters
+    ----------
+    doc : str
+        Description of your command-line interface.
+    argv : list of str, optional
+        Argument vector to be parsed. sys.argv[1:] is used if not
+        provided.
+    help : bool (default: True)
+        Set to False to disable automatic help on -h or --help
+        options.
+    version : any object
+        If passed, the object will be printed if --version is in
+        `argv`.
+    options_first : bool (default: False)
+        Set to True to require options preceed positional arguments,
+        i.e. to forbid options and positional arguments intermix.
+
+    Returns
+    -------
+    args : dict
+        A dictionary, where keys are names of command-line elements
+        such as e.g. "--verbose" and "<path>", and values are the
+        parsed values of those elements.
+
+    Example
+    -------
+    >>> from docopt import docopt
+    >>> doc = '''
+    Usage:
+        my_program tcp <host> <port> [--timeout=<seconds>]
+        my_program serial <port> [--baud=<n>] [--timeout=<seconds>]
+        my_program (-h | --help | --version)
+
+    Options:
+        -h, --help  Show this screen and exit.
+        --baud=<n>  Baudrate [default: 9600]
+    '''
+    >>> argv = ['tcp', '127.0.0.1', '80', '--timeout', '30']
+    >>> docopt(doc, argv)
+    {'--baud': '9600',
+     '--help': False,
+     '--timeout': '30',
+     '--version': False,
+     '<host>': '127.0.0.1',
+     '<port>': '80',
+     'serial': False,
+     'tcp': True}
+
+    See also
+    --------
+    * For video introduction see http://docopt.org
+    * Full documentation is available in README.rst as well as online
+      at https://github.com/docopt/docopt#readme
+
+    """
+    if argv is None:
+        argv = sys.argv[1:]
+    DocoptExit.usage = printable_usage(doc)
+    options = parse_defaults(doc)
+    pattern = parse_pattern(formal_usage(DocoptExit.usage), options)
+    # [default] syntax for argument is disabled
+    #for a in pattern.flat(Argument):
+    #    same_name = [d for d in arguments if d.name == a.name]
+    #    if same_name:
+    #        a.value = same_name[0].value
+    argv = parse_argv(TokenStream(argv, DocoptExit), list(options),
+                      options_first)
+    pattern_options = set(pattern.flat(Option))
+    for ao in pattern.flat(AnyOptions):
+        doc_options = parse_defaults(doc)
+        ao.children = list(set(doc_options) - pattern_options)
+        #if any_options:
+        #    ao.children += [Option(o.short, o.long, o.argcount)
+        #                    for o in argv if type(o) is Option]
+    extras(help, version, argv, doc)
+    matched, left, collected = pattern.fix().match(argv)
+    if matched and left == []:  # better error message if left?
+        return Dict((a.name, a.value) for a in (pattern.flat() + collected))
+    raise DocoptExit()

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

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 ()
+        (help () ; exit 0);
-    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."))
-            )
 
+    (* 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.")
+        )
 ;;
 
 

ocaml/Command_line.mli

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

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

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

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

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

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

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

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 ;

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

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
+                  x.Pseudo.non_local 
-                |> List.length ) pseudo
+                |> 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
+      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_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 shell_prim_idx =
-          let rec make_list n accu = function
-          | 0 -> accu
-          | i -> make_list n (n :: accu) (i-1)
-          in
           let rec aux count accu = function
           | [] -> List.rev accu
           | l::rest ->
-            let new_l = make_list count accu (List.length l) in
+            let newcount = count+(List.length l) in
-            aux (count+1) new_l rest
+            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
+        Ezfio.set_basis_shell_prim_index (Ezfio.ezfio_array_of_list
-          ~rank:1 ~dim:[| prim_num |] ~data:shell_idx) ;
+          ~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 |]
+          ~rank:1 ~dim:[| nucl_num |]
-          ~data:( list_map (fun (_,n) -> Nucl_number.to_int n) basis)
+          ~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 ->
+          |> List.fold_left (fun accu i -> 
-            match accu with
+            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
 
 

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

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 ->
+    | EZFIO   x -> 
-	let ic =
+	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
+      | SUB ->
-
-
-    let action_in =
-        fun () -> Zmq.Socket.recv_all  socket_in  |> Zmq.Socket.send_all  socket_out
-    in
-
-    let action_out =
-        fun () -> Zmq.Socket.recv_all  socket_out |> Zmq.Socket.send_all  socket_in
-    in
-
-    let pollitem =
-      Zmq.Poll.mask_of
-        [| (socket_convert socket_in,  Zmq.Poll.In) ; (socket_convert socket_out, Zmq.Poll.In) |]
-    in
-
-    while !run_status do
-
-        let polling =
-          Zmq.Poll.poll  ~timeout:1000  pollitem
-        in
-
-        match polling with
-          | [| Some Zmq.Poll.In ; Some Zmq.Poll.In |]     -> ( action_out () ; action_in () )
-          | [| _                ; Some Zmq.Poll.In |]     ->   action_out ()
-          | [| Some Zmq.Poll.In ; _                |]     ->   action_in  ()
-          | _                    -> ()
-    done;
-
-    Zmq.Socket.close  socket_in;
-    Zmq.Socket.close  socket_out;
-  in
-
-  let new_thread_sub addr_in addr_out =
-    let socket_in, socket_out =
           create_socket  Zmq.Socket.sub  Zmq.Socket.connect  addr_in,
           create_socket  Zmq.Socket.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 =
+   let action_in = 
-        fun () -> Zmq.Socket.recv_all  socket_in  |> Zmq.Socket.send_all  socket_out
+      match req_or_sub with
+        | REQ -> (fun () -> Zmq.Socket.recv_all  socket_in  |> Zmq.Socket.send_all  socket_out)
+        | SUB -> (fun () -> Zmq.Socket.recv_all  socket_in  |> Zmq.Socket.send_all  socket_out)
     in
 
-    let action_out =
+    let action_out = 
-        fun () -> ()
+      match req_or_sub with
+        | REQ -> (fun () -> Zmq.Socket.recv_all  socket_out |> Zmq.Socket.send_all  socket_in )
+        | SUB -> (fun () -> () )
     in
 
     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_out () 
-          | [| Some Zmq.Poll.In ; _                |]     ->   action_in  ()
+          | [| Some Zmq.Poll.In ; _                |]     ->   action_in  () 
           | _                    -> ()
     done;
 
@@ -220,8 +193,8 @@ let () =
       Printf.sprintf "tcp://*:%d"  localport
     in
 
-    let f () =
+    let f () = 
-      new_thread_req  addr_in  addr_out
+      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 () =
+    let f () = 
-      new_thread_req  addr_in  addr_out
+      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 () =
+    let f () = 
-      new_thread_sub  addr_in  addr_out
+      new_thread  SUB  addr_in  addr_out
     in
     (Thread.create f) ()
   in
@@ -263,7 +236,7 @@ let () =
 
 
   let input_thread =
-    let f () =
+    let f () = 
       let addr_out =
         match arg with
         | EZFIO _ -> None
@@ -275,22 +248,22 @@ let () =
         Printf.sprintf "tcp://*:%d"  (localport+9)
       in
 
-      let socket_in =
+      let socket_in = 
         create_socket  Zmq.Socket.rep  Zmq.Socket.bind     addr_in
       in
 
       let socket_out =
-        match addr_out with
+        match addr_out with 
         | Some addr_out -> Some (
             create_socket  Zmq.Socket.req  Zmq.Socket.connect  addr_out)
         | None -> None
       in
 
-      let temp_file =
+      let temp_file = 
         Filename.temp_file "qp_tunnel" ".tar.gz"
       in
 
-      let get_ezfio_filename () =
+      let get_ezfio_filename () = 
         match arg with
         | EZFIO x -> x
         | ADDRESS _ ->
@@ -304,9 +277,9 @@ let () =
           end
       in
 
-      let get_input () =
+      let get_input () = 
         match arg with
-        | EZFIO x ->
+        | EZFIO x -> 
           begin
             Printf.sprintf "tar --exclude=\"*.gz.*\" -zcf %s %s" temp_file x
             |> Sys.command |> ignore;
@@ -318,11 +291,11 @@ let () =
             in
             ignore @@ Unix.lseek  fd  0  Unix.SEEK_SET ;
             let bstr =
-                Unix.map_file  fd  Bigarray.char
+                Unix.map_file  fd  Bigarray.char 
                   Bigarray.c_layout false [| len |]
                 |> Bigarray.array1_of_genarray
             in
-            let result =
+            let result = 
               String.init len (fun i -> bstr.{i}) ;
             in
             Unix.close fd;
@@ -340,7 +313,7 @@ let () =
           end
       in
 
-      let () =
+      let () = 
         match socket_out with
         | None -> ()
         | Some socket_out ->
@@ -356,7 +329,7 @@ let () =
           | ADDRESS _ ->
             begin
               Printf.printf "Getting input... %!";
-              let ezfio_filename =
+              let ezfio_filename = 
                 get_ezfio_filename ()
               in
               Printf.printf "%s%!" ezfio_filename;
@@ -370,7 +343,7 @@ let () =
               |> Sys.command |> ignore ;
               let oc =
                 Filename.concat  (Qpackage.ezfio_work ezfio_filename)  "qp_run_address"
-                |> open_out
+                |> open_out 
               in
               Printf.fprintf oc "tcp://%s:%d\n"  localhost  localport;
               close_out oc;
@@ -386,9 +359,9 @@ let () =
       let action () =
         match Zmq.Socket.recv socket_in with
         | "get_input" -> get_input ()
-                        |> Zmq.Socket.send socket_in
+                        |> Zmq.Socket.send socket_in 
         | "get_ezfio_filename" -> get_ezfio_filename ()
-                        |> Zmq.Socket.send socket_in
+                        |> Zmq.Socket.send socket_in 
         | "test" -> Zmq.Socket.send socket_in "OK"
         | x -> Printf.sprintf "Message '%s' not understood" x
                |> Zmq.Socket.send socket_in
@@ -399,7 +372,7 @@ On remote hosts, create ssh tunnel using:
  ssh -L %d:%s:%d -L %d:%s:%d -L %d:%s:%d -L %d:%s:%d %s &
 Or from this host connect to clients using:
  ssh -R %d:localhost:%d -R %d:localhost:%d -R %d:localhost:%d -R %d:localhost:%d <host> &
-%!"
+%!" 
                 (port  ) localhost (localport  )
                 (port+1) localhost (localport+1)
                 (port+2) localhost (localport+2)
@@ -419,12 +392,12 @@ Or from this host connect to clients using:
           match polling.(0) with
             | Some Zmq.Poll.In     -> action ()
             | None                 -> ()
-            | Some Zmq.Poll.In_out
+            | Some Zmq.Poll.In_out 
             | Some Zmq.Poll.Out    -> ()
 
       done;
 
-      let () =
+      let () = 
         match socket_out with
         | Some socket_out -> Zmq.Socket.close  socket_out
         | None -> ()
@@ -442,7 +415,7 @@ Or from this host connect to clients using:
   Thread.join ocaml_thread;
   Zmq.Context.terminate zmq_context;
   Printf.printf "qp_tunnel exited properly.\n"
-
+  
 
 
 

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]

src/ao_basis/aos.irp.f

@@ -16,7 +16,7 @@ BEGIN_PROVIDER [ integer, ao_shell, (ao_num) ]
 END_PROVIDER
 
 
-BEGIN_PROVIDER [ double precision, ao_coef , (ao_num,ao_prim_num_max) ]
+ BEGIN_PROVIDER [ double precision, ao_coef , (ao_num,ao_prim_num_max) ]
 &BEGIN_PROVIDER [ double precision, ao_expo , (ao_num,ao_prim_num_max) ]
  implicit none
  BEGIN_DOC

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)
+ power_ao(1:3)= ao_power(i,1:3)
-! center_ao(1:3) = nucl_coord(num_ao,1:3)
+ center_ao(1:3) = nucl_coord(num_ao,1:3)
-! dx = (r(1) - center_ao(1))
+ dx = (r(1) - center_ao(1))
-! dy = (r(2) - center_ao(2))
+ dy = (r(2) - center_ao(2))
-! dz = (r(3) - center_ao(3))
+ dz = (r(3) - center_ao(3))
-! r2 = dx*dx + dy*dy + dz*dz
+ r2 = dx*dx + dy*dy + dz*dz
-! dx = dx**power_ao(1)
+ dx = dx**power_ao(1)
-! dy = dy**power_ao(2)
+ dy = dy**power_ao(2)
-! dz = dz**power_ao(3)
+ dz = dz**power_ao(3)
 
  accu = 0.d0
-! do m=1,ao_prim_num(i)
+ do m=1,ao_prim_num(i)
-!   beta = ao_expo_ordered_transp(m,i)
+   beta = ao_expo_ordered_transp(m,i)
-!   accu += ao_coef_normalized_ordered_transp(m,i) * dexp(-beta*r2)
+   accu += ao_coef_normalized_ordered_transp(m,i) * dexp(-beta*r2)
-! enddo
+ enddo
  ao_value = accu * dx * dy * dz
 
 end

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

src/ao_one_e_ints/NEED

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

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) ]
+ BEGIN_PROVIDER [ double precision, ao_overlap  , (ao_num, ao_num) ]
-  implicit none
+&BEGIN_PROVIDER [ double precision, ao_overlap_x, (ao_num, ao_num) ]
+&BEGIN_PROVIDER [ double precision, ao_overlap_y, (ao_num, ao_num) ]
+&BEGIN_PROVIDER [ double precision, ao_overlap_z, (ao_num, ao_num) ]
+
   BEGIN_DOC
-! Overlap between atomic basis functions:
+  ! Overlap between atomic basis functions:
-!
+  !
-! :math:`\int \chi_i(r) \chi_j(r) dr`
+  ! :math:`\int \chi_i(r) \chi_j(r) dr`
   END_DOC
-  integer :: i,j,n,l
+
-  double precision :: f
+  implicit none
-  integer :: dim1
+  integer          :: i, j, n, l, dim1, power_A(3), power_B(3)
   double precision :: overlap, overlap_x, overlap_y, overlap_z
   double precision :: 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))
+  if(read_ao_integrals_overlap) then
-     print *,  'AO overlap integrals read from disk'
+
+    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
+    if(use_cosgtos) then
-    !$OMP PARALLEL DO SCHEDULE(GUIDED) &
+      !print*, ' use_cosgtos for ao_overlap ?', use_cosgtos
-    !$OMP DEFAULT(NONE) &
+
-    !$OMP PRIVATE(A_center,B_center,power_A,power_B,&
+      do j = 1, ao_num
-    !$OMP  overlap_x,overlap_y, overlap_z, overlap, &
+        do i = 1, ao_num
-    !$OMP  alpha, beta,i,j,c) &
+          ao_overlap  (i,j) = ao_overlap_cosgtos  (i,j) 
-    !$OMP SHARED(nucl_coord,ao_power,ao_prim_num, &
+          ao_overlap_x(i,j) = ao_overlap_cosgtos_x(i,j)
-    !$OMP  ao_overlap_x,ao_overlap_y,ao_overlap_z,ao_overlap,ao_num,ao_coef_normalized_ordered_transp,ao_nucl, &
+          ao_overlap_y(i,j) = ao_overlap_cosgtos_y(i,j)
-    !$OMP  ao_expo_ordered_transp,dim1)
+          ao_overlap_z(i,j) = ao_overlap_cosgtos_z(i,j)
-    do j=1,ao_num
+        enddo
-    A_center(1) = nucl_coord( ao_nucl(j), 1 )
+      enddo
-    A_center(2) = nucl_coord( ao_nucl(j), 2 )
+
-    A_center(3) = nucl_coord( ao_nucl(j), 3 )
+    else
-    power_A(1)  = ao_power( j, 1 )
+
-    power_A(2)  = ao_power( j, 2 )
+      dim1=100
-    power_A(3)  = ao_power( j, 3 )
+      !$OMP PARALLEL DO SCHEDULE(GUIDED) &
-    do i= 1,ao_num
+      !$OMP DEFAULT(NONE) &
-      B_center(1) = nucl_coord( ao_nucl(i), 1 )
+      !$OMP PRIVATE(A_center,B_center,power_A,power_B,&
-      B_center(2) = nucl_coord( ao_nucl(i), 2 )
+      !$OMP  overlap_x,overlap_y, overlap_z, overlap, &
-      B_center(3) = nucl_coord( ao_nucl(i), 3 )
+      !$OMP  alpha, beta,i,j,c) &
-      power_B(1)  = ao_power( i, 1 )
+      !$OMP SHARED(nucl_coord,ao_power,ao_prim_num, &
-      power_B(2)  = ao_power( i, 2 )
+      !$OMP  ao_overlap_x,ao_overlap_y,ao_overlap_z,ao_overlap,ao_num,ao_coef_normalized_ordered_transp,ao_nucl, &
-      power_B(3)  = ao_power( i, 3 )
+      !$OMP  ao_expo_ordered_transp,dim1)
-      do n = 1,ao_prim_num(j)
+      do j=1,ao_num
-      alpha = ao_expo_ordered_transp(n,j)
+      A_center(1) = nucl_coord( ao_nucl(j), 1 )
-      do l = 1, ao_prim_num(i)
+      A_center(2) = nucl_coord( ao_nucl(j), 2 )
-        beta = ao_expo_ordered_transp(l,i)
+      A_center(3) = nucl_coord( ao_nucl(j), 3 )
-        call overlap_gaussian_xyz(A_center,B_center,alpha,beta,power_A,power_B,overlap_x,overlap_y,overlap_z,overlap,dim1)
+      power_A(1)  = ao_power( j, 1 )
-        c = ao_coef_normalized_ordered_transp(n,j) * ao_coef_normalized_ordered_transp(l,i)
+      power_A(2)  = ao_power( j, 2 )
-        ao_overlap(i,j) += c * overlap
+      power_A(3)  = ao_power( j, 3 )
-        if(isnan(ao_overlap(i,j)))then
+      do i= 1,ao_num
-         print*,'i,j',i,j
+        B_center(1) = nucl_coord( ao_nucl(i), 1 )
-         print*,'l,n',l,n
+        B_center(2) = nucl_coord( ao_nucl(i), 2 )
-         print*,'c,overlap',c,overlap
+        B_center(3) = nucl_coord( ao_nucl(i), 3 )
-         print*,overlap_x,overlap_y,overlap_z
+        power_B(1)  = ao_power( i, 1 )
-         stop
+        power_B(2)  = ao_power( i, 2 )
-        endif
+        power_B(3)  = ao_power( i, 3 )
-        ao_overlap_x(i,j) += c * overlap_x
+        do n = 1,ao_prim_num(j)
-        ao_overlap_y(i,j) += c * overlap_y
+        alpha = ao_expo_ordered_transp(n,j)
-        ao_overlap_z(i,j) += c * overlap_z
+        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
+      !$OMP END PARALLEL DO
-    enddo
+
-    !$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:
+  ! Overlap between absolute values of atomic basis functions:
-!
+  !
-! :math:`\int |\chi_i(r)| |\chi_j(r)| dr`
+  ! :math:`\int |\chi_i(r)| |\chi_j(r)| dr`
   END_DOC
-  integer :: i,j,n,l
+
-  double precision :: f
+  implicit none
-  integer :: dim1
+  integer          :: i, j, n, l, dim1, power_A(3), power_B(3)
-  double precision :: overlap, overlap_x, overlap_y, overlap_z
+  double precision :: overlap_x, overlap_y, overlap_z
   double precision :: alpha, beta
   double precision :: 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
+  if(is_periodic) then
-      do i= 1,ao_num
+
-        ao_overlap_abs(i,j)= cdabs(ao_overlap_complex(i,j))
+    do j = 1, ao_num
+      do i = 1, ao_num
+        ao_overlap_abs(i,j) = cdabs(ao_overlap_complex(i,j))
       enddo
     enddo
+
   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

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
+  implicit none
-  integer :: dim1
+  integer          :: i, j, n, l, dim1, power_A(3), power_B(3)
   double precision :: overlap, overlap_y, overlap_z
   double precision :: overlap_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
+  if(use_cosgtos) then
-   A_center(:) = 0.d0
+    !print*, 'use_cosgtos for ao_kinetic_integrals ?', use_cosgtos
-   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)
-  ! --
 
-  !$OMP PARALLEL DO SCHEDULE(GUIDED) &
+    do j = 1, ao_num
-  !$OMP DEFAULT(NONE) &
+      do i = 1, ao_num
-  !$OMP PRIVATE(A_center,B_center,power_A,power_B,&
+        ao_deriv2_x(i,j) = ao_deriv2_cosgtos_x(i,j)
-  !$OMP  overlap_y, overlap_z, overlap, &
+        ao_deriv2_y(i,j) = ao_deriv2_cosgtos_y(i,j)
-  !$OMP  alpha, beta,i,j,c,d_a_2,d_2,deriv_tmp, &
+        ao_deriv2_z(i,j) = ao_deriv2_cosgtos_z(i,j)
-  !$OMP  overlap_x0,overlap_y0,overlap_z0) &
+      enddo
-  !$OMP SHARED(nucl_coord,ao_power,ao_prim_num, &
+    enddo
-  !$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(1) = power_A(1)-2
+  else
-      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
 
-      double precision :: deriv_tmp
+    dim1=100
-      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
+    ! -- Dummy call to provide everything
-      power_A(2) = power_A(2)-2
+    A_center(:) = 0.d0
-      if (power_A(2)>-1) then
+    B_center(:) = 1.d0
-        call overlap_gaussian_xyz(A_center,B_center,alpha,beta,power_A,power_B,overlap_y,d_a_2,overlap_z,overlap,dim1)
+    alpha = 1.d0
-      else
+    beta  = .1d0
-        d_a_2 = 0.d0
+    power_A = 1
-      endif
+    power_B = 0
-      power_A(2) = power_A(2)+4
+    call overlap_gaussian_xyz(A_center,B_center,alpha,beta,power_A,power_B,overlap_y,d_a_2,overlap_z,overlap,dim1)
-      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 &
+    !$OMP PARALLEL DO SCHEDULE(GUIDED) &
-      +power_A(2) * (power_A(2)-1.d0) * d_a_2 &
+    !$OMP DEFAULT(NONE) &
-      +4.d0 * alpha * alpha * d_2   )*overlap_x0*overlap_z0
+    !$OMP PRIVATE(A_center,B_center,power_A,power_B,&
-      ao_deriv2_y(i,j) += c*deriv_tmp
+    !$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
+        power_A(1) = power_A(1)-2
-      if (power_A(3)>-1) then
+        if (power_A(1)>-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)
+          call overlap_gaussian_xyz(A_center,B_center,alpha,beta,power_A,power_B,d_a_2,overlap_y,overlap_z,overlap,dim1)
-      else
+        else
-        d_a_2 = 0.d0
+          d_a_2 = 0.d0
-      endif
+        endif
-      power_A(3) = power_A(3)+4
+        power_A(1) = power_A(1)+4
-      call overlap_gaussian_xyz(A_center,B_center,alpha,beta,power_A,power_B,overlap_y,overlap_z,d_2,overlap,dim1)
+        call overlap_gaussian_xyz(A_center,B_center,alpha,beta,power_A,power_B,d_2,overlap_y,overlap_z,overlap,dim1)
-      power_A(3) = power_A(3)-2
+        power_A(1) = power_A(1)-2
 
-      deriv_tmp = (-2.d0 * alpha * (2.d0 * power_A(3) +1.d0 ) * overlap_z0 &
+        double precision :: deriv_tmp
-      +power_A(3) * (power_A(3)-1.d0) * d_a_2 &
+        deriv_tmp = (-2.d0 * alpha * (2.d0 * power_A(1) +1.d0) * overlap_x0 &
-      +4.d0 * alpha * alpha * d_2   )*overlap_x0*overlap_y0
+        +power_A(1) * (power_A(1)-1.d0) * d_a_2 &
-      ao_deriv2_z(i,j) += c*deriv_tmp
+        +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
+    !$OMP END PARALLEL DO
-  enddo
+
-  !$OMP END PARALLEL DO
+  endif
 
 END_PROVIDER
 
+! ---
+
 BEGIN_PROVIDER [double precision, ao_kinetic_integrals, (ao_num,ao_num)]
   implicit none
   BEGIN_DOC

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, power_A(3), power_B(3)
-  integer                        :: num_A,num_B
+  integer          :: i, j, k, l, n_pt_in, m
-  double precision               :: A_center(3),B_center(3),C_center(3)
+  double precision :: alpha, beta
-  integer                        :: power_A(3),power_B(3)
+  double precision :: A_center(3),B_center(3),C_center(3)
-  integer                        :: i,j,k,l,n_pt_in,m
+  double precision :: overlap_x,overlap_y,overlap_z,overlap,dx,NAI_pol_mult
-  double precision               :: overlap_x,overlap_y,overlap_z,overlap,dx,NAI_pol_mult
 
   if (read_ao_integrals_n_e) then
+
     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                                                   &
+    else
-        !$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)
 
-    n_pt_in = n_pt_max_integrals
+      ao_integrals_n_e = 0.d0
 
-    !$OMP DO SCHEDULE (dynamic)
+      !        _
+      ! /|  / |_)
+      !  | /  | \
+      !
 
-    do j = 1, ao_num
+      !$OMP PARALLEL                                                   &
-      num_A = ao_nucl(j)
+          !$OMP DEFAULT (NONE)                                         &
-      power_A(1:3)= ao_power(j,1:3)
+          !$OMP PRIVATE (i,j,k,l,m,alpha,beta,A_center,B_center,C_center,power_A,power_B,&
-      A_center(1:3) = nucl_coord(num_A,1:3)
+          !$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)
+      !$OMP DO SCHEDULE (dynamic)
-        power_B(1:3)= ao_power(i,1:3)
-        B_center(1:3) = nucl_coord(num_B,1:3)
 
-        do l=1,ao_prim_num(j)
+      do j = 1, ao_num
-          alpha = ao_expo_ordered_transp(l,j)
+        num_A = ao_nucl(j)
+        power_A(1:3)= ao_power(j,1:3)
+        A_center(1:3) = nucl_coord(num_A,1:3)
 
-          do m=1,ao_prim_num(i)
+        do i = 1, ao_num
-            beta = ao_expo_ordered_transp(m,i)
 
-            double precision               :: c
+          num_B = ao_nucl(i)
-            c = 0.d0
+          power_B(1:3)= ao_power(i,1:3)
+          B_center(1:3) = nucl_coord(num_B,1:3)
 
-            do  k = 1, nucl_num
+          do l=1,ao_prim_num(j)
-              double precision               :: Z
+            alpha = ao_expo_ordered_transp(l,j)
-              Z = nucl_charge(k)
 
-              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,            &
+              double precision               :: c, c1
-                  power_A,power_B,alpha,beta,C_center,n_pt_in)
+              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
-
-

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

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)

src/ao_two_e_ints/gauss_legendre.irp.f

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

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 <ij|kl>
   END_DOC
   integer, intent(in)            :: i,j,k,l
   integer(key_kind)              :: idx

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
+
+! ---

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
+
+! ---
+
+

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

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
+doc: Max number of primitives in a shell
-size: (basis.prim_num)
+size: (basis.shell_num)
 interface: ezfio, provider
 
 [basis_nucleus_index]
 type: integer
-doc: Nucleus on which the shell is centered
+doc: Index of the nucleus on which the shell is centered
-size: (basis.shell_num)
+size: (nuclei.nucl_num)
 interface: ezfio, provider
 
 [prim_normalization_factor]

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 ' 

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

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

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
-

src/cipsi/NEED

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

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.               &
+        (maxval(abs(pt2_data % pt2(1:N_states))) > pt2_max) .and.               &
-        (sum(abs(pt2_data % variance(1:N_states)) * state_average_weight(1:N_states)) > variance_max) .and.     &
+        (maxval(abs(pt2_data % variance(1:N_states))) > variance_max) .and.     &
         (correlation_energy_ratio <= correlation_energy_ratio_max)   &
         )
       write(*,'(A)')  '--------------------------------------------------------------------------------'

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
+
+

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 n_act_orb n_inact_orb n_core_orb n_virt_orb n_del_orb seniority_max
-  PROVIDE excitation_beta_max  excitation_alpha_max excitation_max
+  PROVIDE pert_2rdm excitation_beta_max  excitation_alpha_max excitation_max
 
   if (h0_type == 'CFG') then
     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)', '========== ======================= ===================== ===================== ==========='
+      print '(A)', ' Samples          Energy                Variance               Norm^2          Seconds'
-      !print '(A)', ' Samples          Energy                Variance               Norm^2            Seconds'
+      print '(A)', '========== ======================= ===================== ===================== ==========='
-      !print '(A)', '========== ======================= ===================== ===================== ==========='
-      print '(A)', '========== ==================== ================ ================ ================ ============= ==========='
-      print '(A)', ' Samples           Energy             PT2            Variance          Norm^2       Convergence    Seconds'
-      print '(A)', '========== ==================== ================ ================ ================ ============= ==========='
 
       PROVIDE global_selection_buffer
 
@@ -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
-      do k=1,N_states
+      pt2_overlap(pt2_stoch_istate,k) = pt2_data % overlap(k,pt2_stoch_istate)
-        pt2_overlap(pt2_stoch_istate,k) = pt2_data % overlap(k,pt2_stoch_istate)
+    enddo
-      enddo
+    SOFT_TOUCH pt2_overlap
-      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
-
+            print '(I10, X, F12.6, X, G10.3, X, F10.6, X, G10.3, X, F10.6, X, G10.3, X, F10.4)', c, &
-            value1 =  pt2_data     % pt2(pt2_stoch_istate) + E
+              pt2_data     % pt2(pt2_stoch_istate) +E, &
-            error1 =  pt2_data_err % pt2(pt2_stoch_istate)           
+              pt2_data_err % pt2(pt2_stoch_istate), &
-            value2 =  pt2_data     % pt2(pt2_stoch_istate)
+              pt2_data     % variance(pt2_stoch_istate), &
-            error2 =  pt2_data_err % pt2(pt2_stoch_istate)           
+              pt2_data_err % variance(pt2_stoch_istate), &
-            value3 =  pt2_data     % variance(pt2_stoch_istate)           
+              pt2_data     % overlap(pt2_stoch_istate,pt2_stoch_istate), &
-            error3 =  pt2_data_err % variance(pt2_stoch_istate)           
+              pt2_data_err % overlap(pt2_stoch_istate,pt2_stoch_istate), &
-            value4 =  pt2_data     % overlap(pt2_stoch_istate,pt2_stoch_istate)           
+              time-time0
-            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)) )
-
             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*,'PB !!!'
-          print*,'If you see this, send a bug report with the following content'
+         print*,'If you see this, send a bug report with the following content'
-          print*,irp_here
+         print*,irp_here
-          print*,'i,index(i),size(pt2_data_I,1) = ',i,index(i),size(pt2_data_I,1)
+         print*,'i,index(i),size(pt2_data_I,1) = ',i,index(i),size(pt2_data_I,1)
-          stop -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

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)
-    call run_pt2_slave_large(thread,iproc,energy)
+!  if (N_det > nproc*(elec_alpha_num * (mo_num-elec_alpha_num))**2) then
-  else
+!    call run_pt2_slave_large(thread,iproc,energy)
-    call run_pt2_slave_small(thread,iproc,energy)
+!  else
-  endif
+!    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
+!double precision :: time2
-!      call wall_time(time2)
+!call wall_time(time2)
       call select_connected(i_generator(k),energy,pt2_data(k),b,subset(k),pt2_F(i_generator(k)))
-!      call wall_time(time1)
+!call wall_time(time1)
-!      print *,  i_generator(1), time1-time2, n_tasks, pt2_F(i_generator(1))
+!print *,  i_generator(1), time1-time2, n_tasks, pt2_F(i_generator(1))
     enddo
     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

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'
+          print *, 'bug in ', irp_here
-          stop -1
+          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
 

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(:)
-
+  double precision, parameter :: norm_thr = 1.d-16
-  ! Removed to avoid introducing determinants already presents in the wf
-  !double precision, parameter :: norm_thr = 1.d-16
-
   allocate (indices(N_det),                                          &
       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
+      if(pert_2rdm)then
-!        allocate(coef_fullminilist_rev(N_states,fullinteresting(0)))
+        allocate(coef_fullminilist_rev(N_states,fullinteresting(0)))
-!        do i=1,fullinteresting(0)
+        do i=1,fullinteresting(0)
-!          do j = 1, N_states
+          do j = 1, N_states
-!            coef_fullminilist_rev(j,i) = psi_coef_sorted(fullinteresting(i),j)
+            coef_fullminilist_rev(j,i) = psi_coef_sorted(fullinteresting(i),j)
-!          enddo
+          enddo
-!        enddo
+        enddo
-!      endif
+      endif
 
       do i=1,fullinteresting(0)
-        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
+            else
-!             call fill_buffer_double_rdm(i_generator, sp, h1, h2, bannedOrb, banned, fock_diag_tmp, E0, pt2_data, mat, buf,fullminilist, coef_fullminilist_rev, fullinteresting(0))
+             call fill_buffer_double_rdm(i_generator, sp, h1, h2, bannedOrb, banned, fock_diag_tmp, E0, pt2_data, mat, buf,fullminilist, coef_fullminilist_rev, fullinteresting(0))
-!            endif
+            endif
           end if
         enddo
         if(s1 /= s2) monoBdo = .false.
       enddo
       deallocate(fullminilist,minilist)
-!      if(pert_2rdm)then
+      if(pert_2rdm)then
-!        deallocate(coef_fullminilist_rev)
+        deallocate(coef_fullminilist_rev)
-!      endif
+      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(:,istate) = pt2_data % overlap(:,istate) + coef(:) * coef(istate)
-          pt2_data % overlap(k,istate) = pt2_data % overlap(k,istate) + coef(k) * coef(istate)
-        end do
         pt2_data % variance(istate)  = pt2_data % variance(istate) + alpha_h_psi * alpha_h_psi
         pt2_data % 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)

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)
+  rss = memory_of_double(sze) + 2*N_int*memory_of_double(sze)
-!  call check_mem(rss,irp_here)
+  call check_mem(rss,irp_here)
   allocate(val(sze), detmp(N_int, 2, sze))
   i1=1
   i2=1
-
+  do i=1,nmwen
-  select case (N_int)
+    if ( (i1 > b1%cur).and.(i2 > b2%cur) ) then
-BEGIN_TEMPLATE 
+      exit
-  case $case
+    else if (i1 > b1%cur) then
-    do i=1,nmwen
+        val(i) = b2%val(i2)
-      if ( (i1 > b1%cur).and.(i2 > b2%cur) ) then
+        detmp(1:N_int,1,i) = b2%det(1:N_int,1,i2)
-        exit
+        detmp(1:N_int,2,i) = b2%det(1:N_int,2,i2)
-      else if (i1 > b1%cur) then
+        i2=i2+1
-          val(i) = b2%val(i2)
+    else if (i2 > b2%cur) then
-          detmp(1:$N_int,1,i) = b2%det(1:$N_int,1,i2)
+        val(i) = b1%val(i1)
-          detmp(1:$N_int,2,i) = b2%det(1:$N_int,2,i2)
+        detmp(1:N_int,1,i) = b1%det(1:N_int,1,i1)
-          i2=i2+1
+        detmp(1:N_int,2,i) = b1%det(1:N_int,2,i1)
-      else if (i2 > b2%cur) then
+        i1=i1+1
-          val(i) = b1%val(i1)
+    else
-          detmp(1:$N_int,1,i) = b1%det(1:$N_int,1,i1)
+      if (b1%val(i1) <= b2%val(i2)) then
-          detmp(1:$N_int,2,i) = b1%det(1:$N_int,2,i1)
+        val(i) = b1%val(i1)
-          i1=i1+1
+        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) = b2%val(i2)
-          val(i) = b1%val(i1)
+        detmp(1:N_int,1,i) = b2%det(1:N_int,1,i2)
-          detmp(1:$N_int,1,i) = b1%det(1:$N_int,1,i1)
+        detmp(1:N_int,2,i) = b2%det(1:N_int,2,i2)
-          detmp(1:$N_int,2,i) = b1%det(1:$N_int,2,i1)
+        i2=i2+1
-          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
       endif
-    enddo
+    endif
-    do i=nmwen+1,b2%N
+  enddo
-      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
   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))
+  rss = memory_of_int(b%cur) + 2*N_int*memory_of_double(size(b%det,3))
-!  call check_mem(rss,irp_here)
+  call check_mem(rss,irp_here)
   allocate(iorder(b%cur), detmp(N_int, 2, size(b%det,3)))
   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. &
+        if ( (tmp_array(k,1,i) /= tmp_array(k,1,j))                   &
-             (tmp_array(k,2,i) /= tmp_array(k,2,j)) ) then
+              .or. (tmp_array(k,2,i) /= tmp_array(k,2,j)) ) then
           dup = .False.
           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)
 

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 = exp(dt*(pt2(k)/avg - 1.d0))
-!    element = min(2.0d0 , element)
+    element = min(2.0d0 , element)
-!    element = max(0.5d0 , element)
+    element = max(0.5d0 , element)
     pt2_match_weight(k) *= element
   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 = exp(dt*(variance(k)/avg -1.d0))
-!    element = min(2.0d0 , element)
+    element = min(2.0d0 , element)
-!    element = max(0.5d0 , element)
+    element = max(0.5d0 , element)
     variance_match_weight(k) *= element
   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

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

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.               &
+        (maxval(abs(pt2_data % pt2(1:N_states))) > pt2_max) .and.               &
-        (sum(abs(pt2_data % variance(1:N_states)) * state_average_weight(1:N_states)) > variance_max) .and.     &
+        (maxval(abs(pt2_data % variance(1:N_states))) > variance_max) .and.     &
         (correlation_energy_ratio <= correlation_energy_ratio_max)   &
         )
       write(*,'(A)')  '--------------------------------------------------------------------------------'

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
+
+

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

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*,'******************************************************'
+    print*,'Excitation energies '
-    print*,'Excitation energies (au)                     (eV)'
     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

src/cis_read/EZFIO.cfg

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

src/cis_read/NEED

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

src/cis_read/README.rst

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

src/cis_read/cis_read.irp.f

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

src/cis_read/h_apply.irp.f

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

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)
-      cisdq(i) = CI_energy(i) + delta_E * (1.d0 - psi_coef_sorted(k,i)**2)
-    endif
   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'
+    print*,'Excitation energies (au)    (CISD+Q)'
-    do i = 1,N_states
+    do i = 2, N_states
-      print *,  i, cisdq(i)
+      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

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 

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
-
+    bfIcfg = max(1,nint((binom(s,(s+1)/2)-binom(s,((s+1)/2)+1))))
-    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
 
     ! perhaps blocking with CFGs of same seniority
     ! can be more efficient

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
+ logabsgamma = log(abs(gamma(x)))
- if (x>0.d0) then
-   logabsgamma = log(abs(gamma(x)))
- endif
  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 
+        k = 0
-        ! Loop over l with a constraint to ensure that l <= size(cfg_seniority_index,1)-1
+        do while(cfg_seniority_index(i+2+k) < ncfgpersomo)
-        ! Old version commented just below
+          k = k + 2
-        do l = min(size(cfg_seniority_index,1)-1, i+2), size(cfg_seniority_index,1)-1, 2
+          ncfgpersomo = cfg_seniority_index(i+2+k)
-          if (cfg_seniority_index(l) >= ncfgpersomo) then
-            ncfgpersomo = cfg_seniority_index(l)
-          endif
         enddo
-        !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
+    if(iand(MS,1) .EQ. 0) then
-      dimcsfpercfg = 1
+      !dimcsfpercfg = max(1,nint((binom(i,i/2)-binom(i,i/2+1))))
-    elseif( i .EQ. 3) then
+      binom1 = dexp(logabsgamma(1.0d0*(i+1))                            &
-      dimcsfpercfg = 2
+                  - 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+1)/2)-binom(i,(i+3)/2))))
-        dimcsfpercfg = max(1,nint((binom(i,i/2)-binom(i,i/2+1))))
+      binom1 = dexp(logabsgamma(1.0d0*(i+1))                            &
-      else
+                  - logabsgamma(1.0d0*(((i+1)/2)+1))                    &
-        dimcsfpercfg = max(1,nint((binom(i,(i+1)/2)-binom(i,(i+3)/2))))
+                  - logabsgamma(1.0d0*(i-(((i+1)/2))+1)));
-      endif
+      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 
+      k = 0
-      ! Loop over l with a constraint to ensure that l <= size(cfg_seniority_index,1)-1
+      do while(cfg_seniority_index(i+2+k) < ncfgprev)
-      ! Old version commented just below
+        k = k + 2
-      do l = min(size(cfg_seniority_index,1)-1, i+2), size(cfg_seniority_index,1)-1, 2
+        ncfgprev = cfg_seniority_index(i+2+k)
-        if (cfg_seniority_index(l) >= ncfgprev) then
-          ncfgprev = cfg_seniority_index(l)
-        endif
       enddo
-      !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

src/dav_general_mat/NEED

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

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

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

src/dav_general_mat/dav_ext_rout_nonsym_B1space.irp.f

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

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

src/davidson/EZFIO.cfg

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

src/davidson/NEED

@@ -1 +1,2 @@
 csf
+davidson_keywords

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()
@@ -546,19 +546,19 @@ end
 
 
 
-BEGIN_PROVIDER [ integer, nthreads_davidson ]
+!BEGIN_PROVIDER [ integer, nthreads_davidson ]
- implicit none
+! implicit none
- BEGIN_DOC
+! BEGIN_DOC
- ! Number of threads for Davidson
+! ! Number of threads for Davidson
- END_DOC
+! END_DOC
- nthreads_davidson = nproc
+! nthreads_davidson = nproc
- character*(32) :: env
+! character*(32) :: env
- call getenv('QP_NTHREADS_DAVIDSON',env)
+! call getenv('QP_NTHREADS_DAVIDSON',env)
- if (trim(env) /= '') then
+! if (trim(env) /= '') then
-   read(env,*) nthreads_davidson
+!   read(env,*) nthreads_davidson
-   call write_int(6,nthreads_davidson,'Target number of threads for <Psi|H|Psi>')
+!   call write_int(6,nthreads_davidson,'Target number of threads for <Psi|H|Psi>')
- endif
+! endif
-END_PROVIDER
+!END_PROVIDER
 
 
 integer function zmq_put_N_states_diag(zmq_to_qp_run_socket,worker_id)

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

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

src/davidson/diagonalization_hcsf_dressed.irp.f

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

src/davidson/diagonalization_hs2_dressed.irp.f

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

src/davidson/diagonalization_nonsym_h_dressed.irp.f

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

src/davidson/diagonalize_ci.irp.f

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

src/davidson/input.irp.f

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

src/davidson/overlap_states.irp.f

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

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

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
+  BEGIN_DOC
-   ! Eigenvectors/values of the CI matrix
+  ! Eigenvectors/values of the CI matrix
-   END_DOC
+  END_DOC
-   implicit none
+  implicit none
-   double precision               :: ovrlp,u_dot_v
+  double precision               :: ovrlp,u_dot_v
-   integer                        :: i_good_state
+  integer                        :: i_good_state
-   integer, allocatable           :: index_good_state_array(:)
+  integer, allocatable           :: index_good_state_array(:)
-   logical, allocatable           :: good_state_array(:)
+  logical, allocatable           :: good_state_array(:)
-   double precision, allocatable  :: s2_values_tmp(:)
+  double precision, allocatable  :: s2_values_tmp(:)
-   integer                        :: i_other_state
+  integer                        :: i_other_state
-   double precision, allocatable  :: eigenvectors(:,:), eigenvectors_s2(:,:), eigenvalues(:)
+  double precision, allocatable  :: eigenvectors(:,:), eigenvectors_s2(:,:), eigenvalues(:)
-   integer                        :: i_state
+  integer                        :: i_state
-   double precision               :: e_0
+  double precision               :: e_0
-   integer                        :: i,j,k,mrcc_state
+  integer                        :: i,j,k,mrcc_state
-   double precision, allocatable  :: s2_eigvalues(:)
+  double precision, allocatable  :: s2_eigvalues(:)
-   double precision, allocatable  :: e_array(:)
+  double precision, allocatable  :: e_array(:)
-   integer, allocatable           :: iorder(:)
+  integer, allocatable           :: iorder(:)
-    logical                        :: converged
+
-    logical                        :: do_csf
+  PROVIDE threshold_davidson nthreads_davidson
-  
+  ! Guess values for the "N_states" states of the CI_eigenvectors_dressed
-   PROVIDE threshold_davidson nthreads_davidson
+  do j=1,min(N_states,N_det)
-   ! Guess values for the "N_states" states of the CI_eigenvectors_dressed
+    do i=1,N_det
-   do j=1,min(N_states,N_det)
+      CI_eigenvectors_dressed(i,j) = psi_coef(i,j)
-     do i=1,N_det
+    enddo
-       CI_eigenvectors_dressed(i,j) = psi_coef(i,j)
+  enddo
-     enddo
+
-   enddo
+  do j=min(N_states,N_det)+1,N_states_diag
-  
+    do i=1,N_det
-   do j=min(N_states,N_det)+1,N_states_diag
+      CI_eigenvectors_dressed(i,j) = 0.d0
-     do i=1,N_det
+    enddo
-       CI_eigenvectors_dressed(i,j) = 0.d0
+  enddo
-     enddo
+
-   enddo
+  if (diag_algorithm == "Davidson") then
-  
+
-   do_csf = s2_eig .and. only_expected_s2 .and. csf_based
+    do j=1,min(N_states,N_det)
-  
+      do i=1,N_det
-   if (diag_algorithm == "Davidson") then
+        CI_eigenvectors_dressed(i,j) = psi_coef(i,j)
-  
+      enddo
-     do j=1,min(N_states,N_det)
+    enddo
-       do i=1,N_det
+    logical :: converged
-         CI_eigenvectors_dressed(i,j) = psi_coef(i,j)
+    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
+       if(i_state .ne.0)then
-     converged = .False.
+         ! Fill the first "i_state" states that have a correct S^2 value
-     if (do_csf) then
+         do j = 1, i_state
-       call davidson_diag_H_csf(psi_det,CI_eigenvectors_dressed, &
+           do i=1,N_det
-         size(CI_eigenvectors_dressed,1),CI_electronic_energy_dressed, &
+             CI_eigenvectors_dressed(i,j) = eigenvectors(i,index_good_state_array(j))
-         N_det,N_csf,min(N_det,N_states),min(N_det,N_states_diag),N_int,1,converged)
+           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,&
+       call u_0_S2_u_0(CI_eigenvectors_s2_dressed,eigenvectors,N_det,psi_det,N_int,&
-         size(CI_eigenvectors_dressed,1), CI_electronic_energy_dressed,&
+          min(N_det,N_states_diag),size(eigenvectors,1))
-         N_det,min(N_det,N_states),min(N_det,N_states_diag),N_int,1,converged)
+       ! 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)
-     integer :: N_states_diag_save
+  endif
-     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
 
 END_PROVIDER
 

src/davidson_dressed/nonsym_diagonalize_ci.irp.f

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

src/davidson_undressed/null_dressing_vector.irp.f

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

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

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

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

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 z_dipole = ',z_dipole_moment
-! print*,'electron part for y_dipole = ',y_dipole_moment
+ print*,'electron part for y_dipole = ',y_dipole_moment
-! print*,'electron part for x_dipole = ',x_dipole_moment
+ print*,'electron part for x_dipole = ',x_dipole_moment
-! 
+ 
  nuclei_part_z = 0.d0
  nuclei_part_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 z_dipole = ',nuclei_part_z
-! print*,'nuclei   part for y_dipole = ',nuclei_part_y
+ print*,'nuclei   part for y_dipole = ',nuclei_part_y
-! print*,'nuclei   part for x_dipole = ',nuclei_part_x
+ print*,'nuclei   part for x_dipole = ',nuclei_part_x
-!
+
  do istate = 1, N_states
   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)
+ call cpu_time(cpu1)
-! print*,'Time to provide the dipole moment :',cpu1-cpu0
+ 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 :  '
+  print*, 'z_dipole_moment                  = ',z_dipole_moment
-  do i = 1,N_states
-    write(*,'(i16)',advance='no') i
-  end do
-  write(*,*) ''
-  write(*,'(A23,100(1pE16.8))') 'x_dipole_moment (au) = ',x_dipole_moment
-  write(*,'(A23,100(1pE16.8))') 'y_dipole_moment (au) = ',y_dipole_moment
-  write(*,'(A23,100(1pE16.8))') 'z_dipole_moment (au) = ',z_dipole_moment
-  write(*,*) ''
-  write(*,'(A23,100(1pE16.8))') 'x_dipole_moment (D) = ',x_dipole_moment * au_to_D
-  write(*,'(A23,100(1pE16.8))') 'y_dipole_moment (D) = ',y_dipole_moment * au_to_D
-  write(*,'(A23,100(1pE16.8))') 'z_dipole_moment (D) = ',z_dipole_moment * au_to_D
-  !print*, 'x_dipole_moment                  = ',x_dipole_moment
-  !print*, 'y_dipole_moment                  = ',y_dipole_moment
-  !print*, 'z_dipole_moment                  = ',z_dipole_moment
   print*,  '****************************************'
  end

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

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, s2_values, (N_states) ]
-&BEGIN_PROVIDER [ double precision, s_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
 

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 mo_two_e_integrals_in_map mo_integrals_map big_array_exchange_integrals
-  PROVIDE ao_one_e_integrals mo_one_e_integrals
 
   ASSERT (Nint > 0)
   ASSERT (Nint == 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

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)

src/determinants/spindeterminants.ezfio_config

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

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)

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
-

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

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 

src/dft_utils_func/mu_of_r_dft.irp.f

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

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
+

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- B*rs + C*rs**2 + D*rs**3 + E*rs**4)*dexp(x)
-   g0_UEG_mu_inf= 0.5d0 * (1d0+ rs* (-B + rs*(C + rs*(D + rs*E))))*dexp(x)
   else
    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
 

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)]
+ BEGIN_PROVIDER[double precision, aos_lapl_in_r_array, (ao_num,n_points_final_grid,3)]
- implicit none
- integer :: i,j,m
- do i = 1, n_points_final_grid
-  do j = 1, ao_num
-   do m = 1, 3
-    aos_lapl_in_r_array_transp(j,i,m) =  aos_lapl_in_r_array(m,j,i)
-   enddo
-  enddo
- enddo
- END_PROVIDER 
-
- BEGIN_PROVIDER [double precision, aos_lapl_in_r_array, (3,ao_num,n_points_final_grid)]
  implicit none
  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_grad_array(ao_num,3)
- double precision :: aos_lapl_array(3,ao_num)
+ double precision :: aos_lapl_array(ao_num,3)
  !$OMP PARALLEL DO &
  !$OMP 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
+ do m = 1, 3
-  r(1) = final_grid_points(1,i)
+  do i = 1, n_points_final_grid
-  r(2) = final_grid_points(2,i)
+   r(1) = final_grid_points(1,i)
-  r(3) = final_grid_points(3,i)
+   r(2) = final_grid_points(2,i)
-  call give_all_aos_and_grad_and_lapl_at_r(r,aos_array,aos_grad_array,aos_lapl_array)
+   r(3) = final_grid_points(3,i)
-  do j = 1, ao_num
+   call give_all_aos_and_grad_and_lapl_at_r(r,aos_array,aos_grad_array,aos_lapl_array)
-   do m = 1, 3
+   do j = 1, ao_num
-    aos_lapl_in_r_array(m,j,i) = aos_lapl_array(m,j)
+    aos_lapl_in_r_array(j,i,m) = aos_lapl_array(j,m)
    enddo
   enddo
  enddo

src/dft_utils_in_r/ints_grad.irp.f

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

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
 

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)

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