merge with MASTER

.travis.yml

@@ -13,6 +13,8 @@ addons:
     - gcc
     - liblapack-dev
     - graphviz
+#    - zlib1g-dev
+#    - libgmp3-dev
 
 cache:
   directories:
@@ -23,8 +25,8 @@ python:
     - "2.6"
 
 script: 
-  - ./configure  --production ./config/gfortran.cfg
-  - source ./quantum_package.rc ; qp_module.py install Full_CI Full_CI_ZMQ Hartree_Fock CAS_SD mrcepa0 All_singles
+  - ./configure  --production ./config/travis.cfg
+  - source ./quantum_package.rc ; qp_module.py install Full_CI Full_CI_ZMQ Hartree_Fock CAS_SD_ZMQ mrcepa0 All_singles
   - source ./quantum_package.rc ; ninja
   - source ./quantum_package.rc ; cd ocaml ; make ; cd -
-  - source ./quantum_package.rc ; cd tests ; ./run_tests.sh #-v
+  - source ./quantum_package.rc ; cd tests ; ./run_tests.sh -v

README.md

@@ -24,7 +24,7 @@ Demo
 * Python >= 2.6
 * GNU make
 * Bash
-* Blast/Lapack
+* Blas/Lapack
 * unzip
 * g++ (For ninja)
 
@@ -137,6 +137,10 @@ interface: ezfio
 
 #FAQ
 
+### Opam error: cryptokit
+
+You need to install `gmp-dev`.
+
 ### Error: ezfio_* is already defined.
 
 #### Why ?

config/gfortran_debug.cfg

@@ -13,7 +13,7 @@
 FC           : gfortran -g -ffree-line-length-none -I . -static-libgcc 
 LAPACK_LIB   : -llapack -lblas
 IRPF90       : irpf90
-IRPF90_FLAGS : --ninja --assert --align=32 
+IRPF90_FLAGS : --ninja --align=32 
 
 # Global options
 ################

config/ifort.cfg

@@ -38,7 +38,7 @@ FCFLAGS  : -xSSE4.2  -O2 -ip -ftz -g
 #################
 #
 [PROFILE]
-FC       : -p -g -traceback
+FC       : -p -g
 FCFLAGS  : -xSSE4.2 -O2 -ip -ftz
 
 # Debugging flags
@@ -53,7 +53,6 @@ FCFLAGS  : -xSSE4.2 -O2 -ip -ftz
 [DEBUG]
 FC      : -g -traceback
 FCFLAGS : -xSSE2 -C -fpe0 
-IRPF90_FLAGS : --openmp
 
 # OpenMP flags
 #################

config/travis.cfg

@@ -0,0 +1,62 @@
+# Common flags
+##############
+#
+# -ffree-line-length-none : Needed for IRPF90 which produces long lines
+# -lblas -llapack         : Link with libblas and liblapack libraries provided by the system
+# -I .                    : Include the curent directory (Mandatory)
+#
+# --ninja                 : Allow the utilisation of ninja. (Mandatory)
+# --align=32              : Align all provided arrays on a 32-byte boundary
+#
+#
+[COMMON]
+FC           : gfortran -ffree-line-length-none -I . -g
+LAPACK_LIB   : -llapack -lblas
+IRPF90       : irpf90
+IRPF90_FLAGS : --ninja --align=32
+
+# Global options
+################
+#
+# 1 : Activate
+# 0 : Deactivate
+#
+[OPTION]
+MODE    : OPT        ; [ OPT | PROFILE | DEBUG ] : Chooses the section below
+CACHE   : 1          ; Enable cache_compile.py
+OPENMP  : 1          ; Append OpenMP flags
+
+# Optimization flags
+####################
+#
+# -Ofast                  : Disregard strict standards compliance. Enables all -O3 optimizations.
+#                           It also enables optimizations that are not valid
+#                           for all standard-compliant programs.  It turns on
+#                           -ffast-math and the Fortran-specific
+#                           -fno-protect-parens and -fstack-arrays.
+[OPT]
+FCFLAGS : -Ofast -march=native
+
+# Profiling flags
+#################
+#
+[PROFILE]
+FC      : -p -g 
+FCFLAGS : -Ofast 
+
+# Debugging flags
+#################
+#
+# -fcheck=all  : Checks uninitialized variables,  array subscripts, etc...
+# -g           : Extra debugging information
+#
+[DEBUG]
+FCFLAGS : -fcheck=all -g
+
+# OpenMP flags
+#################
+#
+[OPENMP]
+FC           : -fopenmp
+IRPF90_FLAGS : --openmp 
+

configure

@@ -71,8 +71,8 @@ d_dependency = {
     "emsl": ["python"],
     "gcc": [],
     "g++": [],
-    "zeromq" : [ "g++" ],
-    "f77zmq" : [ "zeromq", "python" ],
+    "zeromq" : [ "g++", "make" ],
+    "f77zmq" : [ "zeromq", "python", "make" ],
     "python": [],
     "ninja": ["g++", "python"],
     "make": [],
@@ -102,7 +102,7 @@ curl = Info(
     default_path=join(QP_ROOT_BIN, "curl"))
 
 zlib = Info(
-    url='http://zlib.net/zlib-1.2.8.tar.gz',
+    url='http://www.zlib.net/zlib-1.2.10.tar.gz',
     description=' zlib',
     default_path=join(QP_ROOT_LIB, "libz.a"))
 
@@ -150,7 +150,6 @@ f77zmq = Info(
     url='{head}/zeromq/f77_zmq/{tail}'.format(**path_github),
     description=' F77-ZeroMQ',
     default_path=join(QP_ROOT_LIB, "libf77zmq.a") )
-#                join(QP_ROOT, "src", "ZMQ", "f77zmq.h") )
 
 p_graphviz = Info(
     url='https://github.com/xflr6/graphviz/archive/master.tar.gz',
@@ -166,7 +165,7 @@ d_info = dict()
 
 for m in ["ocaml", "m4", "curl", "zlib", "patch", "irpf90", "docopt",
           "resultsFile", "ninja", "emsl", "ezfio", "p_graphviz",
-          "zeromq", "f77zmq","bats" ]:
+          "zeromq", "f77zmq","bats"]: 
     exec ("d_info['{0}']={0}".format(m))
 
 
@@ -487,7 +486,6 @@ def create_ninja_and_rc(l_installed):
 
     l_rc = [
         'export QP_ROOT={0}'.format(QP_ROOT),
-        '#export QP_NIC=ib0   # Choose the correct network inuterface',
         'export QP_EZFIO={0}'.format(path_ezfio.replace(QP_ROOT,"${QP_ROOT}")),
         'export QP_PYTHON={0}'.format(":".join(l_python)), "",
         'export IRPF90={0}'.format(path_irpf90.replace(QP_ROOT,"${QP_ROOT}")),
@@ -495,12 +493,24 @@ def create_ninja_and_rc(l_installed):
         'export PYTHONPATH="${QP_EZFIO}/Python":"${QP_PYTHON}":"${PYTHONPATH}"',
         'export PATH="${QP_PYTHON}":"${QP_ROOT}"/bin:"${QP_ROOT}"/ocaml:"${PATH}"',
         'export LD_LIBRARY_PATH="${QP_ROOT}"/lib:"${LD_LIBRARY_PATH}"',
-        'export LIBRARY_PATH="${QP_ROOT}"/lib:"${LIBRARY_PATH}"', "",
-        'source ${QP_ROOT}/install/EZFIO/Bash/ezfio.sh', "",
-        'source ${HOME}/.opam/opam-init/init.sh > /dev/null 2> /dev/null || true',
-        ""
+        'export LIBRARY_PATH="${QP_ROOT}"/lib:"${LIBRARY_PATH}"',
+        'export C_INCLUDE_PATH="${C_INCLUDE_PATH}":"${QP_ROOT}"/include',
+        '',
+        'source ${QP_ROOT}/install/EZFIO/Bash/ezfio.sh',
+        '',
+        '# Choose the correct network interface',
+        '# export QP_NIC=ib0',
+        '# export QP_NIC=eth0',
+        ''
     ]
 
+    qp_opam_root = os.getenv('OPAMROOT')
+    if not qp_opam_root:
+        qp_opam_root = '${HOME}/.opam'
+    l_rc.append('export QP_OPAM={0}'.format(qp_opam_root))
+    l_rc.append('source ${QP_OPAM}/opam-init/init.sh > /dev/null 2> /dev/null || true')
+    l_rc.append('')
+
     path = join(QP_ROOT, "quantum_package.rc")
     with open(path, "w+") as f:
         f.write("\n".join(l_rc))

doc/source/conf.py

@@ -25,7 +25,7 @@ import sys, os
 
 # Add any Sphinx extension module names here, as strings. They can be extensions
 # coming with Sphinx (named 'sphinx.ext.*') or your custom ones.
-extensions = ['sphinx.ext.autodoc', 'sphinx.ext.doctest', 'sphinx.ext.todo', 'sphinx.ext.pngmath', 'sphinx.ext.mathjax', 'sphinx.ext.viewcode']
+extensions = ['sphinx.ext.autodoc', 'sphinx.ext.doctest', 'sphinx.ext.todo', 'sphinx.ext.mathjax', 'sphinx.ext.viewcode']
 
 # Add any paths that contain templates here, relative to this directory.
 templates_path = ['_templates']

install/scripts/build.sh

@@ -4,7 +4,11 @@
 BUILD=_build/${TARGET}
 rm -rf -- ${BUILD}
 mkdir ${BUILD} || exit 1
-tar -zxf Downloads/${TARGET}.tar.gz --strip-components=1 --directory=${BUILD} || exit 1
+if [[ -f Downloads/${TARGET}.tar.gz ]] ; then
+  tar -zxf Downloads/${TARGET}.tar.gz --strip-components=1 --directory=${BUILD} || exit 1
+elif  [[ -f Downloads/${TARGET}.tar.bz2 ]] ; then
+  tar -jxf Downloads/${TARGET}.tar.bz2 --strip-components=1 --directory=${BUILD} || exit 1
+fi
 _install || exit 1
 rm -rf -- ${BUILD} _build/${TARGET}.log
 exit 0

install/scripts/install_curl.sh

@@ -10,10 +10,4 @@ function _install()
   mv curl.ermine ${QP_ROOT}/bin/curl || return 1
 }
 
-BUILD=_build/${TARGET}
-rm -rf -- ${BUILD}
-mkdir ${BUILD} || exit 1
-tar -xvjf Downloads/${TARGET}.tar.bz2 --strip-components=1 --directory=${BUILD} || exit 1
-_install || exit 1
-rm -rf -- ${BUILD} _build/${TARGET}.log
-exit 0
+source scripts/build.sh

install/scripts/install_f77zmq.sh

@@ -7,10 +7,9 @@ function _install()
   cd ..
   QP_ROOT=$PWD
   cd -
-  export C_INCLUDE_PATH="${C_INCLUDE_PATH}":"${QP_ROOT}"/lib
   set -e
   set -u
-  export ZMQ_H="${QP_ROOT}"/lib/zmq.h
+  export ZMQ_H="${QP_ROOT}"/include/zmq.h
   cd "${BUILD}"
   make -j 8                        || exit 1
   mv libf77zmq.a "${QP_ROOT}"/lib  || exit 1

install/scripts/install_gmp.sh

@@ -0,0 +1,17 @@
+#!/bin/bash -x
+
+TARGET=gmp
+
+function _install()
+{
+  rm -rf -- ${TARGET}
+  mkdir ${TARGET} || exit 1
+  cd ..
+  QP_ROOT=$PWD
+  cd -
+  cd ${BUILD}
+  ./configure --prefix=$QP_ROOT && make -j 8 || exit 1
+  make install || exit 1
+}
+
+source scripts/build.sh

install/scripts/install_m4.sh

@@ -8,8 +8,7 @@ function _install()
   QP_ROOT=$PWD
   cd -
   cd ${BUILD}
-  ./configure && make || exit 1 
-  ln -sf ${PWD}/src/m4 ${QP_ROOT}/bin || exit 1 
+  ./configure --prefix=$QP_ROOT && make || exit 1 
 }
 
 source scripts/build.sh

install/scripts/install_ocaml.sh

@@ -5,11 +5,11 @@ QP_ROOT=$PWD
 cd -
 
 # Normal installation
-PACKAGES="core cryptokit ocamlfind sexplib ZMQ"
+PACKAGES="core cryptokit.1.10 ocamlfind sexplib ZMQ"
 #ppx_sexp_conv
 
 # Needed for ZeroMQ
-export C_INCLUDE_PATH="${QP_ROOT}"/lib:"${C_INCLUDE_PATH}"
+export C_INCLUDE_PATH="${QP_ROOT}"/include:"${C_INCLUDE_PATH}"
 export LIBRARY_PATH="${QP_ROOT}"/lib:"${LIBRARY_PATH}"
 export LD_LIBRARY_PATH="${QP_ROOT}"/lib:"${LD_LIBRARY_PATH}"
 

install/scripts/install_patch.sh

@@ -9,11 +9,11 @@ function _install()
   QP_ROOT=$PWD
   cd -
   cd ${BUILD}
-  ./configure --prefix=${QP_ROOT}/install/${TARGET} && make || exit 1
+  ./configure --prefix=${QP_ROOT} && make || exit 1
   make install || exit 1
   cd -
   cp ${TARGET}/bin/${TARGET} ${QP_ROOT}/bin || exit 1
   rm -R -- ${TARGET} || exit 1
 }
 
-source scripts/build.sh
+source scripts/build.sh

install/scripts/install_zeromq.sh

@@ -7,22 +7,13 @@ function _install()
   cd ..
   QP_ROOT=$PWD
   cd -
-  export C_INCLUDE_PATH="${C_INCLUDE_PATH}":./
   set -e
   set -u
   ORIG=$(pwd)
   cd "${BUILD}"
-  ./configure --without-libsodium || exit 1
+  ./configure --prefix=$QP_ROOT --without-libsodium || exit 1
   make -j 8 || exit 1
-  rm -f -- "${QP_ROOT}"/lib/libzmq.a "${QP_ROOT}"/lib/libzmq.so "${QP_ROOT}"/lib/libzmq.so.?
-  cp .libs/libzmq.a  "${QP_ROOT}"/lib 
-  cp .libs/libzmq.so "${QP_ROOT}"/lib/libzmq.so.5
-# cp src/.libs/libzmq.a  "${QP_ROOT}"/lib 
-# cp src/.libs/libzmq.so "${QP_ROOT}"/lib/libzmq.so.4
-  cp include/{zmq.h,zmq_utils.h} "${QP_ROOT}"/lib
-  cd "${QP_ROOT}"/lib
-  ln -s libzmq.so.5 libzmq.so
-# ln -s libzmq.so.4 libzmq.so
+  make install || exit 1
   cd ${ORIG}
   return 0
 }

install/scripts/install_zlib.sh

@@ -11,11 +11,8 @@ function _install()
   cd -
   cd ${BUILD}
   ./configure && make || exit 1
-  make install prefix=$QP_ROOT/install/${TARGET} || exit 1
-  ln -s -f $QP_ROOT/install/${TARGET}/lib/libz.so $QP_ROOT/lib || exit 1
-  ln -s -f $QP_ROOT/install/${TARGET}/lib/libz.a $QP_ROOT/lib || exit 1
-  ln -s -f $QP_ROOT/install/${TARGET}/include/zlib.h $QP_ROOT/lib || exit 1
-  ln -s -f $QP_ROOT/install/${TARGET}/include/zconf.h $QP_ROOT/lib || exit 1
+  ./configure --prefix=$QP_ROOT && make || exit 1 
+  make install || exit 1
 }
 
 source scripts/build.sh

ocaml/Address.ml

@@ -42,7 +42,7 @@ end = struct
     assert (String.is_prefix ~prefix:"inproc://" x);
     x
   let create name =
-    Printf.sprintf "ipc://%s" name
+    Printf.sprintf "inproc://%s" name
   let to_string x = x
 end
 

ocaml/Basis.ml

@@ -36,9 +36,11 @@ let read_element in_channel at_number element =
 
 
 
-let to_string_general ~fmt ~atom_sep b =
+let to_string_general ~fmt ~atom_sep ?ele_array b =
   let new_nucleus n = 
-    Printf.sprintf "Atom %d" n
+    match ele_array with
+    | None -> Printf.sprintf "Atom %d" n
+    | Some x -> Printf.sprintf "%s" (Element.to_string x.(n-1))
   in
   let rec do_work accu current_nucleus = function
   | [] -> List.rev accu
@@ -56,12 +58,12 @@ let to_string_general ~fmt ~atom_sep b =
   do_work [new_nucleus 1] 1 b
   |> String.concat ~sep:"\n"
 
-let to_string_gamess =
-    to_string_general ~fmt:Gto.Gamess ~atom_sep:""
+let to_string_gamess ?ele_array =
+    to_string_general ?ele_array ~fmt:Gto.Gamess ~atom_sep:""
 
-let to_string_gaussian b =
+let to_string_gaussian ?ele_array b =
   String.concat ~sep:"\n"
-  [ to_string_general ~fmt:Gto.Gaussian ~atom_sep:"****" b ; "****" ]
+  [ to_string_general ?ele_array ~fmt:Gto.Gaussian ~atom_sep:"****" b ; "****" ]
 
 let to_string ?(fmt=Gto.Gamess) =
   match fmt with

ocaml/Basis.mli

@@ -14,7 +14,7 @@ val read_element :
   in_channel -> Nucl_number.t -> Element.t -> (Gto.t * Nucl_number.t) list
 
 (** Convert the basis to a string *)
-val to_string : ?fmt:Gto.fmt -> (Gto.t * Nucl_number.t) list -> string
+val to_string : ?fmt:Gto.fmt -> ?ele_array:Element.t array -> (Gto.t * Nucl_number.t) list -> string
 
 (** Convert the basis to an MD5 hash *)
 val to_md5 :  (Gto.t * Nucl_number.t) list -> MD5.t

ocaml/Id.ml

@@ -1,26 +1,22 @@
-open Core.Std
-
-module Id : sig
-  type t
-  val of_int : int -> t
-  val to_int : t -> int
-  val of_string : string -> t
-  val to_string : t -> string
-  val increment : t -> t
-  val decrement : t -> t
-end
-= struct
+module Id = struct
   type t = int
+
   let of_int x = 
     assert (x>0); x
+
   let to_int x = x
+
   let of_string x = 
-    Int.of_string x
+    int_of_string x
     |> of_int
+
   let to_string x =
-    Int.to_string x
+    string_of_int x
+
   let increment x = x + 1
   let decrement x = x - 1
+
+  let compare = compare
 end
 
 module Task = struct

ocaml/Id.mli

@@ -0,0 +1,23 @@
+module Id :
+  sig
+    type t
+    val of_int : int -> t
+    val to_int : t -> int
+    val of_string : string -> t
+    val to_string : t -> string
+    val increment : t -> t
+    val decrement : t -> t
+    val compare   : t -> t -> int
+  end
+
+
+module Task :
+  sig
+    include (module type of Id)
+  end
+
+
+module Client :
+  sig
+    include (module type of Id)
+  end

ocaml/Progress_bar.ml

@@ -14,13 +14,13 @@ type t =
 
 let init ?(bar_length=20) ?(start_value=0.) ?(end_value=1.) ~title =
   { title ; start_value ; end_value ; bar_length ; cur_value=start_value ;
-    init_time= Time.now () ; dirty = true ; next = Time.now () } 
+    init_time= Time.now () ; dirty = false ; next = Time.now () } 
 
 let update ~cur_value bar =
   { bar with cur_value ; dirty=true }
 
 let increment_end bar =
-  { bar with end_value=(bar.end_value +. 1.) ; dirty=true }
+  { bar with end_value=(bar.end_value +. 1.) ; dirty=false }
 
 let increment_cur bar =
   { bar with cur_value=(bar.cur_value +. 1.) ; dirty=true }

ocaml/Pseudo.ml

@@ -124,23 +124,27 @@ let to_string t =
 let find in_channel element =
   In_channel.seek in_channel 0L;
   
-  let element_read, old_pos =
-     ref Element.X, 
+  let loop, element_read, old_pos =
+     ref true,
+     ref None, 
      ref (In_channel.pos in_channel)
   in
-  while !element_read <> element
+
+  while !loop
   do
-    let buffer = 
-      old_pos := In_channel.pos in_channel;
-      match In_channel.input_line in_channel with
-      | Some line -> String.split ~on:' ' line
-         |> List.hd_exn
-      | None -> ""
-    in
     try
-      element_read := Element.of_string buffer
+      let buffer = 
+        old_pos := In_channel.pos in_channel;
+        match In_channel.input_line in_channel with
+        | Some line -> String.split ~on:' ' line
+          |> List.hd_exn
+        | None -> raise End_of_file
+      in
+      element_read := Some (Element.of_string buffer);
+      loop := !element_read <> (Some element) 
     with
     | Element.ElementError _ -> ()
+    | End_of_file -> loop := false
   done ;
   In_channel.seek in_channel !old_pos;
   !element_read
@@ -148,124 +152,126 @@ let find in_channel element =
 
 (** Read the Pseudopotential in GAMESS format *)
 let read_element in_channel element =
-  ignore (find in_channel element);
-
-  let rec read result =
-    match In_channel.input_line in_channel with
-    | None -> result
-    | Some line ->
-      if (String.strip line = "") then
-        result
-      else
-        read (line::result)
-  in
-
-  let data = 
-    read []
-    |> List.rev
-  in
-
-  let debug_data = 
-    String.concat ~sep:"\n" data
-  in
-
-  let decode_first_line = function
-  | first_line :: rest ->
+  match find in_channel element with
+  | Some e when e = element -> 
     begin
-      let first_line_split = 
-        String.split first_line ~on:' '
-        |> List.filter ~f:(fun x -> (String.strip x) <> "")
+      let rec read result =
+        match In_channel.input_line in_channel with
+        | None -> result
+        | Some line ->
+          if (String.strip line = "") then
+            result
+          else
+            read (line::result)
       in
-      match first_line_split with
-      | e :: "GEN" :: n :: p ->
-        {  element = Element.of_string e ;
-           n_elec  = Int.of_string n |> Positive_int.of_int ;
-           local = [] ;
-           non_local = []
-        }, rest
-      | _ -> failwith (
-        Printf.sprintf "Unable to read Pseudopotential : \n%s\n"
-        debug_data )
-    end
-  | _ -> failwith ("Error reading pseudopotential\n"^debug_data)
-  in  
 
-  let rec loop create_primitive accu = function
-  | (0,rest) -> List.rev accu, rest
-  | (n,line::rest) -> 
-    begin
-      match
-        String.split line ~on:' '
-        |> List.filter ~f:(fun x -> String.strip x <> "")
-      with
-      | c :: i :: e :: [] ->
-        let i =
-          Int.of_string i
-        in
-        let elem =
-          ( create_primitive 
-            (Float.of_string e |> AO_expo.of_float)
-            (i-2 |> R_power.of_int),
-            Float.of_string c |> AO_coef.of_float 
-          )
-        in
-        loop create_primitive (elem::accu) (n-1, rest)
+      let data = 
+        read []
+        |> List.rev
+      in
+
+      let debug_data = 
+        String.concat ~sep:"\n" data
+      in
+
+      let decode_first_line = function
+      | first_line :: rest ->
+        begin
+          let first_line_split = 
+            String.split first_line ~on:' '
+            |> List.filter ~f:(fun x -> (String.strip x) <> "")
+          in
+          match first_line_split with
+          | e :: "GEN" :: n :: p ->
+            {  element = Element.of_string e ;
+              n_elec  = Int.of_string n |> Positive_int.of_int ;
+              local = [] ;
+              non_local = []
+            }, rest
+          | _ -> failwith (
+            Printf.sprintf "Unable to read Pseudopotential : \n%s\n"
+            debug_data )
+        end
       | _ -> failwith ("Error reading pseudopotential\n"^debug_data)
-    end
-  | _ -> failwith ("Error reading pseudopotential\n"^debug_data)
-  in
+      in  
 
-  let decode_local (pseudo,data) = 
-    let decode_local_n n rest =
-      let result, rest =
-        loop Primitive_local.of_expo_r_power [] (Positive_int.to_int n,rest)
+      let rec loop create_primitive accu = function
+      | (0,rest) -> List.rev accu, rest
+      | (n,line::rest) -> 
+        begin
+          match
+            String.split line ~on:' '
+            |> List.filter ~f:(fun x -> String.strip x <> "")
+          with
+          | c :: i :: e :: [] ->
+            let i =
+              Int.of_string i
+            in
+            let elem =
+              ( create_primitive 
+                (Float.of_string e |> AO_expo.of_float)
+                (i-2 |> R_power.of_int),
+                Float.of_string c |> AO_coef.of_float 
+              )
+            in
+            loop create_primitive (elem::accu) (n-1, rest)
+          | _ -> failwith ("Error reading pseudopotential\n"^debug_data)
+        end
+      | _ -> failwith ("Error reading pseudopotential\n"^debug_data)
       in
-      { pseudo with local = result }, rest
-    in
-    match data with
-    | n :: rest ->
-        let n =
-          String.strip n
-          |> Int.of_string
-          |> Positive_int.of_int
+
+      let decode_local (pseudo,data) = 
+        let decode_local_n n rest =
+          let result, rest =
+            loop Primitive_local.of_expo_r_power [] (Positive_int.to_int n,rest)
+          in
+          { pseudo with local = result }, rest
         in
-        decode_local_n n rest
-    | _ -> failwith ("Unable to read (non-)local pseudopotential\n"^debug_data)
-  in
-
-  let decode_non_local (pseudo,data) = 
-    let decode_non_local_n proj n (pseudo,data) =
-      let result, rest = 
-        loop (Primitive_non_local.of_proj_expo_r_power proj)
-          [] (Positive_int.to_int n, data)
+        match data with
+        | n :: rest ->
+            let n =
+              String.strip n
+              |> Int.of_string
+              |> Positive_int.of_int
+            in
+            decode_local_n n rest
+        | _ -> failwith ("Unable to read (non-)local pseudopotential\n"^debug_data)
       in
-      { pseudo with non_local = pseudo.non_local @ result }, rest
-    in
-    let rec new_proj (pseudo,data) proj = 
-      match data with
-      | n :: rest ->
-          let n =
-            String.strip n
-            |> Int.of_string
-            |> Positive_int.of_int
-          in
-          let result = 
-            decode_non_local_n proj n (pseudo,rest)
-          and proj_next =
-            (Positive_int.to_int proj)+1
-            |> Positive_int.of_int
-          in
-          new_proj result proj_next
-      | _ -> pseudo
-    in
-    new_proj (pseudo,data) (Positive_int.of_int 0)
-  in
 
-  decode_first_line data
-  |> decode_local
-  |> decode_non_local 
+      let decode_non_local (pseudo,data) = 
+        let decode_non_local_n proj n (pseudo,data) =
+          let result, rest = 
+            loop (Primitive_non_local.of_proj_expo_r_power proj)
+              [] (Positive_int.to_int n, data)
+          in
+          { pseudo with non_local = pseudo.non_local @ result }, rest
+        in
+        let rec new_proj (pseudo,data) proj = 
+          match data with
+          | n :: rest ->
+              let n =
+                String.strip n
+                |> Int.of_string
+                |> Positive_int.of_int
+              in
+              let result = 
+                decode_non_local_n proj n (pseudo,rest)
+              and proj_next =
+                (Positive_int.to_int proj)+1
+                |> Positive_int.of_int
+              in
+              new_proj result proj_next
+          | _ -> pseudo
+        in
+        new_proj (pseudo,data) (Positive_int.of_int 0)
+      in
+
+      decode_first_line data
+      |> decode_local
+      |> decode_non_local 
+    end
+  | _ -> empty element
 
-     
  
 
 include To_md5

ocaml/Qpackage.ml

@@ -127,3 +127,14 @@ let get_ezfio_default directory data =
   |> aux 
 ;;
 
+let ezfio_work ezfio_file = 
+  let result = 
+    Filename.concat ezfio_file  "work"
+  in
+  begin
+    match Sys.is_directory result with
+    | `Yes -> ()
+    | _ -> Unix.mkdir result
+  end;
+  result
+;;

ocaml/Queuing_system.ml

@@ -1,27 +1,35 @@
-open Core.Std
-open Qptypes
-
+module RunningMap = Map.Make (Id.Task)
+module TasksMap   = Map.Make (Id.Task)
+module ClientsSet = Set.Make (Id.Client)
 
 type t =
-{ queued         : Id.Task.t list ;
-  running        : (Id.Task.t, Id.Client.t) Map.Poly.t ;
-  tasks          : (Id.Task.t, string)      Map.Poly.t;
-  clients        : Id.Client.t Set.Poly.t;
+{ queued_front   : Id.Task.t list ;
+  queued_back    : Id.Task.t list ;
+  running        : Id.Client.t RunningMap.t;
+  tasks          : string TasksMap.t;
+  clients        : ClientsSet.t;
   next_client_id : Id.Client.t;
   next_task_id   : Id.Task.t;
-  number_of_queued : int;
+  number_of_queued  : int;
+  number_of_running : int;
+  number_of_tasks   : int;
+  number_of_clients : int;
 }
 
 
 
 let create () =
-  { queued         = [] ; 
-    running        = Map.Poly.empty ;
-    tasks          = Map.Poly.empty;
-    clients        = Set.Poly.empty;
+  { queued_front   = [] ; 
+    queued_back    = [] ; 
+    running        = RunningMap.empty ;
+    tasks          = TasksMap.empty;
+    clients        = ClientsSet.empty;
     next_client_id = Id.Client.of_int 1;
     next_task_id   = Id.Task.of_int 1;
-    number_of_queued = 0;
+    number_of_queued  = 0;
+    number_of_running = 0;
+    number_of_tasks   = 0;
+    number_of_clients = 0;
   }
 
 
@@ -32,10 +40,11 @@ let add_task ~task q =
     q.next_task_id 
   in
   { q with
-    queued = task_id :: q.queued ;
-    tasks  = Map.add q.tasks ~key:task_id ~data:task ;
+    queued_front = task_id :: q.queued_front ;
+    tasks  = TasksMap.add task_id task q.tasks;
     next_task_id = Id.Task.increment task_id ;
     number_of_queued = q.number_of_queued + 1;
+    number_of_tasks  = q.number_of_tasks  + 1;
   }
 
 
@@ -46,56 +55,73 @@ let add_client q =
     q.next_client_id 
   in
   { q with
-    clients = Set.add q.clients client_id;
+    clients = ClientsSet.add client_id q.clients;
     next_client_id = Id.Client.increment client_id;
+    number_of_clients = q.number_of_clients + 1;
   }, client_id
 
 
 let pop_task ~client_id q = 
-  let { queued ; running ; _ } =
+  let { queued_front ; queued_back ; running ; _ } =
     q
   in
-  assert (Set.mem q.clients client_id);
-  match queued with
+  assert (ClientsSet.mem client_id q.clients);
+  let queued_front', queued_back' =
+    match queued_front, queued_back with
+    | (l, []) -> ( [], List.rev l)
+    | t -> t
+  in
+  match queued_back' with
   | task_id :: new_queue ->
     let new_q =
       { q with
-        queued = new_queue ;
-        running = Map.add running ~key:task_id ~data:client_id ;
-        number_of_queued = q.number_of_queued - 1;
+        queued_front= queued_front' ;
+        queued_back = new_queue ;
+        running = RunningMap.add task_id client_id running;
+        number_of_queued  = q.number_of_queued  - 1;
+        number_of_running = q.number_of_running + 1;
       }
-    in new_q, Some task_id, (Map.find q.tasks task_id)
+    and found =
+      try Some (TasksMap.find task_id q.tasks)
+      with Not_found -> None
+    in new_q, Some task_id, found 
   | [] -> q, None, None
     
 
 let del_client ~client_id q =
-  assert (Set.mem q.clients client_id);
+  assert (ClientsSet.mem client_id q.clients);
   { q with 
-    clients = Set.remove q.clients client_id }
+    clients = ClientsSet.remove client_id q.clients;
+    number_of_clients = q.number_of_clients - 1
+  }
 
 
 let end_task ~task_id ~client_id q = 
   let { running ; tasks ; _ } =
     q
   in
-  assert (Set.mem q.clients client_id);
-  let () = 
-    match Map.Poly.find running task_id with
-    | None -> failwith "Task already finished"
-    | Some client_id_check -> assert (client_id_check = client_id)
+  assert (ClientsSet.mem client_id q.clients);
+  let () =
+    let client_id_check = 
+      try RunningMap.find task_id running with
+      Not_found -> failwith "Task already finished"
+    in
+    assert (client_id_check = client_id)
   in
   { q with
-    running  = Map.remove running task_id ;
+    running = RunningMap.remove task_id running ;
+    number_of_running = q.number_of_running - 1
   }
-    
+
 let del_task ~task_id q = 
   let { tasks ; _ } =
     q
   in
   
-  if (Map.mem tasks task_id) then
+  if (TasksMap.mem task_id tasks) then
       { q with
-        tasks    = Map.remove tasks task_id ;
+        tasks = TasksMap.remove task_id tasks;
+        number_of_tasks = q.number_of_tasks - 1;
       }
   else
       Printf.sprintf "Task %d is already deleted" (Id.Task.to_int task_id)
@@ -103,36 +129,81 @@ let del_task ~task_id q =
 
     
 
-let number q =
-  Map.length q.tasks
+let number_of_tasks q =
+  assert (q.number_of_tasks >= 0);
+  q.number_of_tasks
 
 let number_of_queued q =
+  assert (q.number_of_queued >= 0);
   q.number_of_queued
 
 let number_of_running q =
-  Map.length q.running
+  assert (q.number_of_running >= 0);
+  q.number_of_running
+
+let number_of_clients q =
+  assert (q.number_of_clients >= 0);
+  q.number_of_clients
 
 
-let to_string { queued ; running ; tasks ; _ } =
+let to_string qs =
+  let { queued_back ; queued_front ; running ; tasks ; _ } = qs in
   let q =
-    List.map ~f:Id.Task.to_string queued
-    |> String.concat ~sep:" ; "
+     (List.map Id.Task.to_string queued_front) @
+     (List.map Id.Task.to_string @@ List.rev queued_back)
+    |> String.concat " ; "
   and r =
-    Map.Poly.to_alist running
-    |> List.map ~f:(fun (t,c) -> "("^(Id.Task.to_string t)^", "
+    RunningMap.bindings running
+    |> List.map (fun (t,c) -> "("^(Id.Task.to_string t)^", "
        ^(Id.Client.to_string c)^")") 
-    |> String.concat ~sep:" ; "
+    |> String.concat " ; "
   and t = 
-    Map.Poly.to_alist tasks
-    |> List.map ~f:(fun (t,c) -> "("^(Id.Task.to_string t)^", \""
+    TasksMap.bindings tasks
+    |> List.map (fun (t,c) -> "("^(Id.Task.to_string t)^", \""
        ^c^"\")") 
-    |> String.concat ~sep:" ; "
+    |> String.concat " ; "
   in
   Printf.sprintf "{
+Tasks : %d   Queued : %d   Running : %d   Clients : %d
 queued   : { %s }
 running  : { %s }
 tasks    : [ %s
            ]
-}" q r t
+}"
+(number_of_tasks qs) (number_of_queued qs) (number_of_running qs) (number_of_clients qs)
+q r t
 
   
+
+let test () =
+  let q = 
+    create ()
+    |> add_task ~task:"First Task"
+    |> add_task ~task:"Second Task"
+  in
+  let q, client_id = 
+    add_client q
+  in
+  let q, task_id, task_content =
+    match pop_task ~client_id q with
+    | q, Some x, Some y -> q, Id.Task.to_int x, y
+    | _ -> assert false
+  in
+  Printf.printf "Task_id : %d \t\t Task : %s\n" task_id task_content;
+  to_string q |> print_endline  ;
+  let q, task_id, task_content =
+    match pop_task ~client_id q with
+    | q, Some x, Some y -> q, Id.Task.to_int x, y
+    | _ -> assert false
+  in
+  Printf.printf "Task_id : %d \t\t Task : %s\n" task_id task_content;
+  let q, task_id, task_content =
+    match pop_task ~client_id q with
+    | q, None, None -> q, 0, "None"
+    | _ -> assert false
+  in
+  Printf.printf "Task_id : %d \t\t Task : %s\n"  task_id task_content;
+  q
+  |> to_string
+  |> print_endline 
+

ocaml/Queuing_system.mli

@@ -0,0 +1,63 @@
+module RunningMap : Map.S with type key = Id.Task.t
+module TasksMap   : Map.S with type key = Id.Task.t
+module ClientsSet : Set.S with type elt = Id.Client.t
+
+type t = {
+  queued_front      : Id.Task.t list           ;
+  queued_back       : Id.Task.t list           ;
+  running           : Id.Client.t RunningMap.t ;
+  tasks             : string TasksMap.t        ;          
+  clients           : ClientsSet.t             ;          
+  next_client_id    : Id.Client.t              ;
+  next_task_id      : Id.Task.t                ;
+  number_of_queued  : int                      ;
+  number_of_running : int                      ;
+  number_of_tasks   : int                      ;
+  number_of_clients : int                      ;
+}
+
+(** Creates a new queuing system. Returns the new queue. *)
+val create : unit -> t
+
+(** Add a new task represented as a string. Returns the queue with the added task. *)
+val add_task : task:string -> t -> t
+
+(** Add a new client. Returns the queue and a new client_id. *)
+val add_client : t -> t * Id.Client.t
+
+(** Pops a task from the queue. The task is set as running on client client_id.
+    Returns the queue, a task_id and the content of the task. If the queue contains
+    no task, the task_id and the task content are None. *)
+val pop_task :
+  client_id:ClientsSet.elt -> t -> t * Id.Task.t option * string option
+
+(** Deletes a client from the queuing system *)
+val del_client : client_id:ClientsSet.elt -> t -> t
+
+(** Deletes a client from the queuing system. The client is assumed to be a member
+    of the set of clients. Returns the queue without the removed client. *)
+val end_task : task_id:RunningMap.key -> client_id:ClientsSet.elt -> t -> t
+
+(** Deletes a task from the queuing system. The task is assumed to be a member
+    of the map of tasks. Returns the queue without the removed task. *)
+val del_task : task_id:TasksMap.key -> t -> t
+
+(** Returns the number of tasks, assumed >= 0 *)
+val number_of_tasks : t -> int
+
+(** Returns the number of queued tasks, assumed >= 0 *)
+val number_of_queued : t -> int
+
+(** Returns the number of running tasks, assumed >= 0 *)
+val number_of_running : t -> int
+
+(** Returns the number of connected clients, assumed >= 0 *)
+val number_of_clients : t -> int
+
+(** Prints the content of the queue *)
+val to_string : t -> string
+
+(** Test function for debug *)
+val test : unit -> unit
+
+

ocaml/TaskServer.ml

@@ -48,20 +48,21 @@ let zmq_context =
   ZMQ.Context.create ()
 
 
-let bind_socket ~socket_type ~socket ~address =
+let bind_socket ~socket_type ~socket ~port =
   let rec loop = function
   | 0 -> failwith @@ Printf.sprintf
-        "Unable to bind the %s socket : %s "
-        socket_type address
+        "Unable to bind the %s socket to port : %d "
+        socket_type port
   | -1 -> ()
   | i -> 
       try
-        ZMQ.Socket.bind socket address;
+        ZMQ.Socket.bind socket @@ Printf.sprintf "tcp://*:%d" port;
         loop (-1)
       with
       | Unix.Unix_error _ -> (Time.pause @@ Time.Span.of_float 1. ; loop (i-1) )
       | other_exception -> raise other_exception
-  in loop 60
+  in loop 60;
+  ZMQ.Socket.bind socket @@ Printf.sprintf "ipc:///tmp/qp_run:%d" port
 
 
 let hostname = lazy (
@@ -115,7 +116,7 @@ let stop ~port =
     let req_socket =
       ZMQ.Socket.create zmq_context ZMQ.Socket.req
     and address =
-      Printf.sprintf "tcp://%s:%d" (Lazy.force ip_address) port
+      Printf.sprintf "ipc:///tmp/qp_run:%d" port
     in
     ZMQ.Socket.set_linger_period req_socket 1_000_000;
     ZMQ.Socket.connect req_socket address;
@@ -305,7 +306,7 @@ let del_task msg program_state rep_socket =
             }
         in
         let more = 
-            (Queuing_system.number new_program_state.queue > 0)
+            (Queuing_system.number_of_tasks new_program_state.queue > 0)
         in
         Message.DelTaskReply (Message.DelTaskReply_msg.create ~task_id ~more)
         |> Message.to_string
@@ -567,10 +568,8 @@ let start_pub_thread ~port =
 
       let pub_socket =
         ZMQ.Socket.create zmq_context ZMQ.Socket.pub
-      and address =
-        Printf.sprintf "tcp://*:%d" port
       in
-      bind_socket ~socket_type:"PUB" ~socket:pub_socket ~address;
+      bind_socket ~socket_type:"PUB" ~socket:pub_socket ~port;
 
       let pollitem =
         ZMQ.Poll.mask_of 
@@ -608,7 +607,7 @@ let run ~port =
     and address = 
       "inproc://pair" 
     in
-    bind_socket "PAIR" pair_socket address;
+    ZMQ.Socket.bind pair_socket address;
 
     let pub_thread = 
       start_pub_thread ~port:(port+1) ()
@@ -617,11 +616,9 @@ let run ~port =
     (** Bind REP socket *)
     let rep_socket =
       ZMQ.Socket.create zmq_context ZMQ.Socket.rep
-    and address =
-      Printf.sprintf "tcp://*:%d" port
     in
     ZMQ.Socket.set_linger_period rep_socket 1_000_000;
-    bind_socket "REP" rep_socket address;
+    bind_socket "REP" rep_socket port;
 
     let initial_program_state =
     {   queue = Queuing_system.create () ;
@@ -683,7 +680,7 @@ let run ~port =
               Printf.sprintf "q:%d  r:%d  n:%d  : %s\n%!"
               (Queuing_system.number_of_queued program_state.queue)
               (Queuing_system.number_of_running program_state.queue)
-              (Queuing_system.number program_state.queue)
+              (Queuing_system.number_of_tasks program_state.queue)
               (Message.to_string message)
               |> debug;
 
@@ -721,6 +718,7 @@ let run ~port =
 
     ZMQ.Socket.send pair_socket @@ string_of_pub_state Stopped;
     Thread.join pub_thread;
+    ZMQ.Socket.close rep_socket
 
 
 

ocaml/TaskServer.mli

@@ -23,9 +23,9 @@ val debug : string -> unit
 (** ZeroMQ context *)
 val zmq_context : ZMQ.Context.t
 
-(** Bind a ZMQ socket *)
+(** Bind a ZMQ socket to a TCP port and to an IPC file /tmp/qp_run.<port> *)
 val bind_socket :
-  socket_type:string -> socket:'a ZMQ.Socket.t -> address:string -> unit
+  socket_type:string -> socket:'a ZMQ.Socket.t -> port:int -> unit
 
 (** Name of the host on which the server runs *)
 val hostname : string lazy_t

ocaml/qp_create_guess.ml

@@ -88,8 +88,9 @@ let run ~multiplicity ezfio_file =
       ~alpha:(Elec_alpha_number.of_int alpha_new)
       ~beta:(Elec_beta_number.of_int beta_new) pair )
   in
+
   let c = 
-    Array.create ~len:(List.length determinants) (Det_coef.of_float 1.)
+    Array.init (List.length determinants) (fun _ -> Det_coef.of_float ((Random.float 2.)-.1.))
   in
  
   determinants 

ocaml/qp_run.ml

@@ -15,7 +15,7 @@ let print_list () =
 let () = 
   Random.self_init ()
 
-let run ~master exe ezfio_file =
+let run slave exe ezfio_file =
 
 
   (** Check availability of the ports *)
@@ -28,7 +28,7 @@ let run ~master exe ezfio_file =
     in
     let rec try_new_port port_number =
       try 
-        List.iter [ 0;1;2;3;4 ] ~f:(fun i ->
+        List.iter [ 0;1;2;3;4;5;6;7;8;9 ] ~f:(fun i ->
             let address = 
               Printf.sprintf "tcp://%s:%d" (Lazy.force TaskServer.ip_address) (port_number+i)
             in
@@ -75,16 +75,23 @@ let run ~master exe ezfio_file =
     | 0 -> ()
     | i -> failwith "Error: Input inconsistent\n"
   end;
-  begin
-    match master with
-    | Some address -> Unix.putenv ~key:"QP_RUN_ADDRESS_MASTER" ~data:address
-    | None -> ()
-  end;
 
-  (** Start task server *)
-  let address =
-    Printf.sprintf "tcp://%s:%d" (Lazy.force TaskServer.ip_address) port_number
+  let qp_run_address_filename = 
+   Filename.concat (Qpackage.ezfio_work ezfio_file) "qp_run_address"
   in
+
+  let () = 
+    if slave then
+      try
+        let address = 
+          In_channel.read_all qp_run_address_filename
+          |> String.strip
+        in
+        Unix.putenv ~key:"QP_RUN_ADDRESS_MASTER" ~data:address
+      with Sys_error _ -> failwith "No master is not running"
+  in
+       
+  (** Start task server *)
   let task_thread =
      let thread = 
       Thread.create ( fun () -> 
@@ -92,7 +99,16 @@ let run ~master exe ezfio_file =
      in
      thread ();
   in
+  let address =
+    Printf.sprintf "tcp://%s:%d" (Lazy.force TaskServer.ip_address) port_number
+  in
   Unix.putenv ~key:"QP_RUN_ADDRESS" ~data:address;
+  let () = 
+    if (not slave) then
+      Out_channel.with_file qp_run_address_filename  ~f:(
+        fun oc -> Out_channel.output_lines oc [address]) 
+  in
+
 
   (** Run executable *)
   let prefix = 
@@ -111,6 +127,8 @@ let run ~master exe ezfio_file =
 
   TaskServer.stop ~port:port_number;
   Thread.join task_thread;
+  if (not slave) then
+    Sys.remove qp_run_address_filename;
 
   let duration = Time.diff (Time.now()) time_start 
   |> Core.Span.to_string in
@@ -119,8 +137,8 @@ let run ~master exe ezfio_file =
 let spec = 
   let open Command.Spec in
   empty
-  +> flag "master" (optional string)
-     ~doc:("address Address of the master process")
+  +> flag "slave" no_arg
+     ~doc:(" Needed for slave tasks")
   +> anon ("executable" %: string)
   +> anon ("ezfio_file" %: string)
 ;;
@@ -138,8 +156,8 @@ Executes a Quantum Package binary file among these:\n\n"
     )
   )
   spec
-  (fun master exe ezfio_file () ->
-    run ~master exe ezfio_file
+  (fun slave exe ezfio_file () ->
+    run slave exe ezfio_file
   )
   |> Command.run   ~version: Git.sha1   ~build_info: Git.message
 

plugins/All_singles/H_apply.irp.f

@@ -8,6 +8,13 @@ s.unset_skip()
 s.filter_only_1h1p()
 print s
 
+s = H_apply("just_1h_1p_singles",do_double_exc=False)
+s.set_selection_pt2("epstein_nesbet_2x2")
+s.unset_skip()
+s.filter_only_1h1p()
+print s
+
+
 s = H_apply("just_mono",do_double_exc=False)
 s.set_selection_pt2("epstein_nesbet_2x2")
 s.unset_skip()

plugins/All_singles/README.rst

@@ -15,6 +15,7 @@ Needed Modules
 * `Properties <http://github.com/LCPQ/quantum_package/tree/master/plugins/Properties>`_
 * `Selectors_no_sorted <http://github.com/LCPQ/quantum_package/tree/master/plugins/Selectors_no_sorted>`_
 * `Utils <http://github.com/LCPQ/quantum_package/tree/master/src/Utils>`_
+* `Davidson <http://github.com/LCPQ/quantum_package/tree/master/src/Davidson>`_
 
 Documentation
 =============

plugins/All_singles/all_1h_1p.irp.f

@@ -49,7 +49,7 @@ subroutine routine
     endif
     call save_wavefunction
     if(n_det_before == N_det)then
-     selection_criterion = selection_criterion * 0.5d0
+     selection_criterion_factor = selection_criterion_factor * 0.5d0
     endif
     
   enddo

plugins/All_singles/all_1h_1p_singles.irp.f

@@ -0,0 +1,76 @@
+program restart_more_singles
+  BEGIN_DOC
+  ! Generates and select single and double excitations of type 1h-1p
+  ! on the top of a given restart wave function of type CAS
+  END_DOC
+  read_wf = .true.
+  touch read_wf 
+  print*,'ref_bitmask_energy = ',ref_bitmask_energy
+  call routine
+
+end 
+subroutine routine
+  implicit none
+  integer                        :: i,k
+  double precision, allocatable  :: pt2(:), norm_pert(:), H_pert_diag(:),E_before(:)
+  integer                        :: N_st, degree
+  integer :: n_det_before
+  N_st = N_states
+  allocate (pt2(N_st), norm_pert(N_st),H_pert_diag(N_st),E_before(N_st))
+  i = 0
+  print*,'N_det = ',N_det
+  print*,'n_det_max = ',n_det_max
+  print*,'pt2_max = ',pt2_max
+  pt2=-1.d0
+  E_before = ref_bitmask_energy
+  do while (N_det < n_det_max.and.maxval(abs(pt2(1:N_st))) > pt2_max)
+    n_det_before = N_det
+    i += 1
+    print*,'-----------------------'
+    print*,'i = ',i
+    call H_apply_just_1h_1p_singles(pt2, norm_pert, H_pert_diag,  N_st)
+    call diagonalize_CI
+    print*,'N_det = ',N_det
+    print*,'E        = ',CI_energy(1)
+    print*,'pt2      = ',pt2(1)
+    print*,'E+PT2    = ',E_before + pt2(1)
+    E_before = CI_energy
+    if(N_states_diag.gt.1)then
+     print*,'Variational Energy difference'
+     do i = 2, N_st
+      print*,'Delta E = ',CI_energy(i) - CI_energy(1)
+     enddo
+    endif
+    if(N_states.gt.1)then
+     print*,'Variational + perturbative Energy difference'
+     do i = 2, N_st
+      print*,'Delta E = ',E_before(i)+ pt2(i) - (E_before(1) + pt2(1))
+     enddo
+    endif
+    call save_wavefunction
+    if(n_det_before == N_det)then
+     selection_criterion_factor = selection_criterion_factor * 0.5d0
+    endif
+    
+  enddo
+
+  threshold_davidson = 1.d-10
+  soft_touch threshold_davidson davidson_criterion
+  call diagonalize_CI
+  if(N_states_diag.gt.1)then
+   print*,'Variational Energy difference'
+   do i = 2, N_st
+    print*,'Delta E = ',CI_energy(i) - CI_energy(1)
+   enddo
+  endif
+  if(N_states.gt.1)then
+   print*,'Variational + perturbative Energy difference'
+   do i = 2, N_st
+    print*,'Delta E = ',CI_energy(i)+ pt2(i) - (CI_energy(1) + pt2(1))
+   enddo
+  endif
+  call ezfio_set_all_singles_energy(CI_energy)
+
+  call save_wavefunction
+  deallocate(pt2,norm_pert)
+end

plugins/CAS_SD/.gitignore

@@ -3,6 +3,7 @@
 .ninja_log
 AO_Basis
 Bitmask
+Davidson
 Determinants
 Electrons
 Ezfio_files

plugins/CAS_SD/README.rst

@@ -107,6 +107,7 @@ Needed Modules
 * `Perturbation <http://github.com/LCPQ/quantum_package/tree/master/plugins/Perturbation>`_
 * `Selectors_full <http://github.com/LCPQ/quantum_package/tree/master/plugins/Selectors_full>`_
 * `Generators_CAS <http://github.com/LCPQ/quantum_package/tree/master/plugins/Generators_CAS>`_
+* `Davidson <http://github.com/LCPQ/quantum_package/tree/master/src/Davidson>`_
 
 Documentation
 =============
@@ -193,31 +194,6 @@ h_apply_cas_s_selected_monoexc
   Assume N_int is already provided.
 
 
-h_apply_cas_s_selected_no_skip
-  Calls H_apply on the HF determinant and selects all connected single and double
-  excitations (of the same symmetry). Auto-generated by the ``generate_h_apply`` script.
-
-
-h_apply_cas_s_selected_no_skip_diexc
-  Undocumented
-
-
-h_apply_cas_s_selected_no_skip_diexcorg
-  Generate all double excitations of key_in using the bit masks of holes and
-  particles.
-  Assume N_int is already provided.
-
-
-h_apply_cas_s_selected_no_skip_diexcp
-  Undocumented
-
-
-h_apply_cas_s_selected_no_skip_monoexc
-  Generate all single excitations of key_in using the bit masks of holes and
-  particles.
-  Assume N_int is already provided.
-
-
 h_apply_cas_sd
   Calls H_apply on the HF determinant and selects all connected single and double
   excitations (of the same symmetry). Auto-generated by the ``generate_h_apply`` script.

plugins/CAS_SD/cas_sd_selected.irp.f

@@ -93,8 +93,8 @@ program full_ci
    call diagonalize_CI
    if(do_pt2_end)then
     print*,'Last iteration only to compute the PT2'
-    threshold_selectors = 1.d0
-    threshold_generators = 0.999d0
+    threshold_selectors = max(threshold_selectors,threshold_selectors_pt2)
+    threshold_generators = max(threshold_generators,threshold_generators_pt2)
     call H_apply_CAS_SD_PT2(pt2, norm_pert, H_pert_diag,  N_st)
 
     print *,  'Final step'

plugins/CAS_SD_ZMQ/EZFIO.cfg

@@ -0,0 +1,10 @@
+[energy]
+type: double precision
+doc: "Calculated CAS-SD energy"
+interface: ezfio
+
+[energy_pt2]
+type: double precision
+doc: "Calculated selected CAS-SD energy with PT2 correction"
+interface: ezfio
+

plugins/CAS_SD_ZMQ/NEEDED_CHILDREN_MODULES

@@ -0,0 +1,2 @@
+Generators_CAS Perturbation Selectors_CASSD ZMQ 
+

plugins/CAS_SD_ZMQ/README.rst

@@ -0,0 +1,14 @@
+==========
+CAS_SD_ZMQ
+==========
+
+Selected CAS+SD  module with Zero-MQ parallelization.
+
+Needed Modules
+==============
+.. Do not edit this section It was auto-generated
+.. by the `update_README.py` script.
+Documentation
+=============
+.. Do not edit this section It was auto-generated
+.. by the `update_README.py` script.

plugins/CAS_SD_ZMQ/cassd_zmq.irp.f

@@ -0,0 +1,255 @@
+program fci_zmq
+  implicit none
+  integer                        :: i,j,k
+  logical, external              :: detEq
+  
+  double precision, allocatable  :: pt2(:)
+  integer                        :: degree
+  double precision               :: threshold_davidson_in
+  
+  allocate (pt2(N_states))
+  
+  pt2 = 1.d0
+  threshold_davidson_in = threshold_davidson
+  threshold_davidson = threshold_davidson_in * 100.d0
+  SOFT_TOUCH threshold_davidson
+
+  
+  if (N_det > N_det_max) then
+    call diagonalize_CI
+    call save_wavefunction
+    psi_det = psi_det_sorted
+    psi_coef = psi_coef_sorted
+    N_det = N_det_max
+    soft_touch N_det psi_det psi_coef
+    call diagonalize_CI
+    call save_wavefunction
+    print *,  'N_det    = ', N_det
+    print *,  'N_states = ', N_states
+    do k=1,N_states
+      print*,'State ',k
+      print *,  'PT2      = ', pt2(k)
+      print *,  'E        = ', CI_energy(k)
+      print *,  'E+PT2    = ', CI_energy(k) + pt2(k)
+      print *,  '-----'
+    enddo
+  endif
+  double precision               :: E_CI_before(N_states)
+  
+  
+  integer                        :: n_det_before, to_select
+  print*,'Beginning the selection ...'
+  E_CI_before(1:N_states) = CI_energy(1:N_states)
+  
+  do while ( (N_det < N_det_max) .and. (maxval(abs(pt2(1:N_states))) > pt2_max) )
+    
+    print *,  'N_det          = ', N_det
+    print *,  'N_states       = ', N_states
+    do k=1, N_states
+      print*,'State ',k
+      print *,  'PT2            = ', pt2(k)
+      print *,  'E              = ', CI_energy(k)
+      print *,  'E(before)+PT2  = ', E_CI_before(k)+pt2(k)
+    enddo
+    print *,  '-----'
+    if(N_states.gt.1)then
+      print*,'Variational Energy difference'
+      do i = 2, N_states
+        print*,'Delta E = ',CI_energy(i) - CI_energy(1)
+      enddo
+    endif
+    if(N_states.gt.1)then
+      print*,'Variational + perturbative Energy difference'
+      do i = 2, N_states
+        print*,'Delta E = ',E_CI_before(i)+ pt2(i) - (E_CI_before(1) + pt2(1))
+      enddo
+    endif
+    E_CI_before(1:N_states) = CI_energy(1:N_states)
+    call ezfio_set_cas_sd_zmq_energy(CI_energy(1))
+    
+    n_det_before = N_det
+    to_select = 2*N_det
+    to_select = max(64-to_select, to_select)
+    to_select = min(to_select,N_det_max-n_det_before)
+    call ZMQ_selection(to_select, pt2)
+    
+    PROVIDE  psi_coef
+    PROVIDE  psi_det
+    PROVIDE  psi_det_sorted
+    
+    if (N_det == N_det_max) then
+      threshold_davidson = threshold_davidson_in
+      SOFT_TOUCH threshold_davidson
+    endif
+    call diagonalize_CI
+    call save_wavefunction
+    call ezfio_set_cas_sd_zmq_energy(CI_energy(1))
+  enddo
+  
+  if (N_det < N_det_max) then
+    threshold_davidson = threshold_davidson_in
+    SOFT_TOUCH threshold_davidson
+    call diagonalize_CI
+    call save_wavefunction
+    call ezfio_set_cas_sd_zmq_energy(CI_energy(1))
+  endif
+
+  integer :: exc_max, degree_min
+  exc_max = 0
+  print *,  'CAS determinants : ', N_det_cas
+  do i=1,min(N_det_cas,20)
+    do k=i,N_det_cas
+      call get_excitation_degree(psi_cas(1,1,k),psi_cas(1,1,i),degree,N_int)
+      exc_max = max(exc_max,degree)
+    enddo
+    print *,  psi_cas_coef(i,:)
+    call debug_det(psi_cas(1,1,i),N_int)
+    print *,  ''
+  enddo
+  print *,  'Max excitation degree in the CAS :', exc_max
+
+  if(do_pt2_end)then
+    print*,'Last iteration only to compute the PT2'
+    threshold_selectors = max(threshold_selectors,threshold_selectors_pt2)
+    threshold_generators = max(threshold_generators,threshold_generators_pt2)
+    TOUCH threshold_selectors threshold_generators
+    E_CI_before(1:N_states) = CI_energy(1:N_states)
+    call ZMQ_selection(0, pt2)
+    print *,  'Final step'
+    print *,  'N_det    = ', N_det
+    print *,  'N_states = ', N_states
+    do k=1,N_states
+      print *, 'State', k
+      print *,  'PT2      = ', pt2(k)
+      print *,  'E        = ', E_CI_before(k)
+      print *,  'E+PT2    = ', E_CI_before(k)+pt2(k)
+      print *,  '-----'
+    enddo
+    call ezfio_set_cas_sd_zmq_energy_pt2(E_CI_before+pt2)
+  endif
+  call save_wavefunction
+  call ezfio_set_cas_sd_zmq_energy(CI_energy(1))
+  call ezfio_set_cas_sd_zmq_energy_pt2(E_CI_before(1)+pt2(1))
+
+end
+
+
+
+
+subroutine ZMQ_selection(N_in, pt2)
+  use f77_zmq
+  use selection_types
+  
+  implicit none
+  
+  character*(512)                :: task 
+  integer(ZMQ_PTR)               :: zmq_to_qp_run_socket 
+  integer, intent(in)            :: N_in
+  type(selection_buffer)         :: b
+  integer                        :: i, N
+  integer, external              :: omp_get_thread_num
+  double precision, intent(out)  :: pt2(N_states)
+  
+  
+  if (.True.) then
+    PROVIDE pt2_e0_denominator
+    N = max(N_in,1)
+    provide nproc
+    call new_parallel_job(zmq_to_qp_run_socket,"selection")
+    call zmq_put_psi(zmq_to_qp_run_socket,1,pt2_e0_denominator,size(pt2_e0_denominator))
+    call zmq_set_running(zmq_to_qp_run_socket)
+    call create_selection_buffer(N, N*2, b)
+  endif
+
+  integer :: i_generator, i_generator_start, i_generator_max, step
+!  step = int(max(1.,10*elec_num/mo_tot_num)
+
+  step = int(5000000.d0 / dble(N_int * N_states * elec_num * elec_num * mo_tot_num * mo_tot_num ))
+  step = max(1,step)
+  do i= 1, N_det_generators,step
+    i_generator_start = i
+    i_generator_max = min(i+step-1,N_det_generators)
+    write(task,*) i_generator_start, i_generator_max, 1, N
+    call add_task_to_taskserver(zmq_to_qp_run_socket,task)
+  end do
+
+  !$OMP PARALLEL DEFAULT(shared)  SHARED(b, pt2)  PRIVATE(i) NUM_THREADS(nproc+1)
+  i = omp_get_thread_num()
+  if (i==0) then
+    call selection_collector(b, pt2)
+  else
+    call selection_slave_inproc(i)
+  endif
+  !$OMP END PARALLEL
+  call end_parallel_job(zmq_to_qp_run_socket, 'selection')
+  if (N_in > 0) then
+    call fill_H_apply_buffer_no_selection(b%cur,b%det,N_int,0) !!! PAS DE ROBIN
+    call copy_H_apply_buffer_to_wf()
+    if (s2_eig) then
+      call make_s2_eigenfunction
+    endif
+  endif
+end subroutine
+
+
+subroutine selection_slave_inproc(i)
+  implicit none
+  integer, intent(in)            :: i
+
+  call run_selection_slave(1,i,pt2_e0_denominator)
+end
+
+subroutine selection_collector(b, pt2)
+  use f77_zmq
+  use selection_types
+  use bitmasks
+  implicit none
+
+
+  type(selection_buffer), intent(inout) :: b
+  double precision, intent(out)       :: pt2(N_states)
+  double precision                   :: pt2_mwen(N_states)
+  integer(ZMQ_PTR),external      :: new_zmq_to_qp_run_socket
+  integer(ZMQ_PTR)               :: zmq_to_qp_run_socket
+
+  integer(ZMQ_PTR), external     :: new_zmq_pull_socket
+  integer(ZMQ_PTR)               :: zmq_socket_pull
+
+  integer :: msg_size, rc, more
+  integer :: acc, i, j, robin, N, ntask
+  double precision, allocatable :: val(:)
+  integer(bit_kind), allocatable :: det(:,:,:)
+  integer, allocatable :: task_id(:)
+  integer :: done
+  real :: time, time0
+  zmq_to_qp_run_socket = new_zmq_to_qp_run_socket()
+  zmq_socket_pull = new_zmq_pull_socket()
+  allocate(val(b%N), det(N_int, 2, b%N), task_id(N_det))
+  done = 0
+  more = 1
+  pt2(:) = 0d0
+  call CPU_TIME(time0)
+  do while (more == 1)
+    call pull_selection_results(zmq_socket_pull, pt2_mwen, val(1), det(1,1,1), N, task_id, ntask)
+    pt2 += pt2_mwen
+    do i=1, N
+      call add_to_selection_buffer(b, det(1,1,i), val(i))
+    end do
+
+    do i=1, ntask
+      if(task_id(i) == 0) then
+          print *,  "Error in collector"
+      endif
+      call zmq_delete_task(zmq_to_qp_run_socket,zmq_socket_pull,task_id(i),more)
+    end do
+    done += ntask
+    call CPU_TIME(time)
+!    print *, "DONE" , done, time - time0
+  end do
+
+
+  call end_zmq_to_qp_run_socket(zmq_to_qp_run_socket)
+  call end_zmq_pull_socket(zmq_socket_pull)
+  call sort_selection_buffer(b)
+end subroutine
+

plugins/CAS_SD_ZMQ/e_corr_selectors.irp.f

@@ -0,0 +1,79 @@
+
+use bitmasks
+ BEGIN_PROVIDER [integer, exc_degree_per_selectors, (N_det_selectors)]
+&BEGIN_PROVIDER [integer, double_index_selectors, (N_det_selectors)]
+&BEGIN_PROVIDER [integer, n_double_selectors]
+ implicit none
+ BEGIN_DOC
+ ! degree of excitation respect to Hartree Fock for the wave function
+ !
+ ! for the all the selectors determinants
+ !
+ ! double_index_selectors = list of the index of the double excitations
+ ! 
+ ! n_double_selectors = number of double excitations in the selectors determinants
+ END_DOC
+ integer :: i,degree
+ n_double_selectors = 0
+ do i = 1, N_det_selectors
+  call get_excitation_degree(psi_selectors(1,1,i),ref_bitmask,degree,N_int)
+  exc_degree_per_selectors(i) = degree
+  if(degree==2)then
+   n_double_selectors += 1
+   double_index_selectors(n_double_selectors) =i
+  endif
+ enddo
+END_PROVIDER
+
+  BEGIN_PROVIDER[double precision, coef_hf_selector]
+ &BEGIN_PROVIDER[double precision, inv_selectors_coef_hf]
+ &BEGIN_PROVIDER[double precision, inv_selectors_coef_hf_squared]
+ &BEGIN_PROVIDER[double precision, E_corr_per_selectors, (N_det_selectors)]
+ &BEGIN_PROVIDER[double precision, i_H_HF_per_selectors, (N_det_selectors)]
+ &BEGIN_PROVIDER[double precision, Delta_E_per_selector, (N_det_selectors)]
+ &BEGIN_PROVIDER[double precision, E_corr_double_only ]
+ &BEGIN_PROVIDER[double precision, E_corr_second_order ]
+ implicit none
+ BEGIN_DOC
+ ! energy of correlation per determinant respect to the Hartree Fock determinant
+ !
+ ! for the all the double excitations in the selectors determinants
+ !
+ ! E_corr_per_selectors(i) = <D_i|H|HF> * c(D_i)/c(HF) if |D_i> is a double excitation
+ ! 
+ ! E_corr_per_selectors(i) = -1000.d0 if it is not a double excitation 
+ !
+ ! coef_hf_selector = coefficient of the Hartree Fock determinant in the selectors determinants
+ END_DOC
+ PROVIDE  ref_bitmask_energy psi_selectors ref_bitmask N_int psi_selectors
+ integer :: i,degree
+ double precision :: hij,diag_H_mat_elem
+ E_corr_double_only = 0.d0
+ E_corr_second_order = 0.d0
+ do i = 1, N_det_selectors
+  if(exc_degree_per_selectors(i)==2)then
+   call i_H_j(ref_bitmask,psi_selectors(1,1,i),N_int,hij)
+   i_H_HF_per_selectors(i) = hij
+   E_corr_per_selectors(i) = psi_selectors_coef(i,1) * hij
+   E_corr_double_only += E_corr_per_selectors(i)
+!  E_corr_second_order += hij * hij /(ref_bitmask_energy - diag_H_mat_elem(psi_selectors(1,1,i),N_int))
+  elseif(exc_degree_per_selectors(i) == 0)then
+   coef_hf_selector = psi_selectors_coef(i,1)
+   E_corr_per_selectors(i) = -1000.d0
+   Delta_E_per_selector(i) = 0.d0
+  else
+   E_corr_per_selectors(i) = -1000.d0
+  endif
+ enddo
+ if (dabs(coef_hf_selector) > 1.d-8) then
+   inv_selectors_coef_hf = 1.d0/coef_hf_selector
+   inv_selectors_coef_hf_squared = inv_selectors_coef_hf * inv_selectors_coef_hf
+ else
+   inv_selectors_coef_hf = 0.d0
+   inv_selectors_coef_hf_squared = 0.d0
+ endif
+ do i = 1,n_double_selectors
+  E_corr_per_selectors(double_index_selectors(i)) *=inv_selectors_coef_hf
+ enddo
+ E_corr_double_only = E_corr_double_only * inv_selectors_coef_hf
+ END_PROVIDER

plugins/CAS_SD_ZMQ/energy.irp.f

@@ -0,0 +1,11 @@
+BEGIN_PROVIDER [ double precision, pt2_E0_denominator, (N_states) ]
+ implicit none
+ BEGIN_DOC
+ ! E0 in the denominator of the PT2
+ END_DOC
+ pt2_E0_denominator(1:N_states) = CI_electronic_energy(1:N_states)
+! pt2_E0_denominator(1:N_states) = HF_energy - nuclear_repulsion
+! pt2_E0_denominator(1:N_states) = barycentric_electronic_energy(1:N_states)
+ call write_double(6,pt2_E0_denominator(1)+nuclear_repulsion, 'PT2 Energy denominator')
+END_PROVIDER
+

plugins/CAS_SD_ZMQ/ezfio_interface.irp.f

@@ -0,0 +1,4 @@
+! DO NOT MODIFY BY HAND
+! Created by $QP_ROOT/scripts/ezfio_interface/ei_handler.py
+! from file /home/scemama/quantum_package/src/CAS_SD_ZMQ/EZFIO.cfg
+

plugins/CAS_SD_ZMQ/run_selection_slave.irp.f

@@ -0,0 +1,156 @@
+
+subroutine run_selection_slave(thread,iproc,energy)
+  use f77_zmq
+  use selection_types
+  implicit none
+
+  double precision, intent(in)    :: energy(N_states)
+  integer,  intent(in)            :: thread, iproc
+  integer                        :: rc, i
+
+  integer                        :: worker_id, task_id(1), ctask, ltask
+  character*(512)                :: task
+
+  integer(ZMQ_PTR),external      :: new_zmq_to_qp_run_socket
+  integer(ZMQ_PTR)               :: zmq_to_qp_run_socket
+
+  integer(ZMQ_PTR), external     :: new_zmq_push_socket
+  integer(ZMQ_PTR)               :: zmq_socket_push
+
+  type(selection_buffer) :: buf, buf2
+  logical :: done
+  double precision :: pt2(N_states)
+
+  zmq_to_qp_run_socket = new_zmq_to_qp_run_socket()
+  zmq_socket_push      = new_zmq_push_socket(thread)
+  call connect_to_taskserver(zmq_to_qp_run_socket,worker_id,thread)
+  if(worker_id == -1) then
+    print *, "WORKER -1"
+    !call disconnect_from_taskserver(zmq_to_qp_run_socket,zmq_socket_push,worker_id)
+    call end_zmq_to_qp_run_socket(zmq_to_qp_run_socket)
+    call end_zmq_push_socket(zmq_socket_push,thread)
+    return
+  end if
+  buf%N = 0
+  ctask = 1
+  pt2 = 0d0
+
+  do
+    call get_task_from_taskserver(zmq_to_qp_run_socket,worker_id, task_id(ctask), task)
+    done = task_id(ctask) == 0
+    if (done) then
+      ctask = ctask - 1
+    else
+      integer :: i_generator, i_generator_start, i_generator_max, step, N
+      read (task,*) i_generator_start, i_generator_max, step, N
+      if(buf%N == 0) then
+        ! Only first time 
+        call create_selection_buffer(N, N*2, buf)
+        call create_selection_buffer(N, N*3, buf2)
+      else
+        if(N /= buf%N) stop "N changed... wtf man??"
+      end if
+      !print *, "psi_selectors_coef ", psi_selectors_coef(N_det_selectors-5:N_det_selectors, 1)
+      !call debug_det(psi_selectors(1,1,N_det_selectors), N_int)
+      do i_generator=i_generator_start,i_generator_max,step
+        call select_connected(i_generator,energy,pt2,buf)
+      enddo
+    endif
+
+    if(done .or. ctask == size(task_id)) then
+      if(buf%N == 0 .and. ctask > 0) stop "uninitialized selection_buffer"
+      do i=1, ctask
+         call task_done_to_taskserver(zmq_to_qp_run_socket,worker_id,task_id(i))
+      end do
+      if(ctask > 0) then
+        call push_selection_results(zmq_socket_push, pt2, buf, task_id(1), ctask)
+        do i=1,buf%cur
+          call add_to_selection_buffer(buf2, buf%det(1,1,i), buf%val(i))
+        enddo
+        call sort_selection_buffer(buf2)
+        buf%mini = buf2%mini
+        pt2 = 0d0
+        buf%cur = 0
+      end if
+      ctask = 0
+    end if
+
+    if(done) exit
+    ctask = ctask + 1
+  end do
+  call disconnect_from_taskserver(zmq_to_qp_run_socket,zmq_socket_push,worker_id)
+  call end_zmq_to_qp_run_socket(zmq_to_qp_run_socket)
+  call end_zmq_push_socket(zmq_socket_push,thread)
+end subroutine
+
+
+subroutine push_selection_results(zmq_socket_push, pt2, b, task_id, ntask)
+  use f77_zmq
+  use selection_types
+  implicit none
+
+  integer(ZMQ_PTR), intent(in)   :: zmq_socket_push
+  double precision, intent(in)   :: pt2(N_states)
+  type(selection_buffer), intent(inout) :: b
+  integer, intent(in) :: ntask, task_id(*)
+  integer :: rc
+
+  call sort_selection_buffer(b)
+
+  rc = f77_zmq_send( zmq_socket_push, b%cur, 4, ZMQ_SNDMORE)
+  if(rc /= 4) stop "push"
+  rc = f77_zmq_send( zmq_socket_push, pt2, 8*N_states, ZMQ_SNDMORE)
+  if(rc /= 8*N_states) stop "push"
+
+  rc = f77_zmq_send( zmq_socket_push, b%val(1), 8*b%cur, ZMQ_SNDMORE)
+  if(rc /= 8*b%cur) stop "push"
+
+  rc = f77_zmq_send( zmq_socket_push, b%det(1,1,1), bit_kind*N_int*2*b%cur, ZMQ_SNDMORE)
+  if(rc /= bit_kind*N_int*2*b%cur) stop "push"
+
+  rc = f77_zmq_send( zmq_socket_push, ntask, 4, ZMQ_SNDMORE)
+  if(rc /= 4) stop "push"
+
+  rc = f77_zmq_send( zmq_socket_push, task_id(1), ntask*4, 0)
+  if(rc /= 4*ntask) stop "push"
+
+! Activate is zmq_socket_push is a REQ
+!  rc = f77_zmq_recv( zmq_socket_push, task_id(1), ntask*4, 0)
+end subroutine
+
+
+subroutine pull_selection_results(zmq_socket_pull, pt2, val, det, N, task_id, ntask)
+  use f77_zmq
+  use selection_types
+  implicit none
+  integer(ZMQ_PTR), intent(in)   :: zmq_socket_pull
+  double precision, intent(inout) :: pt2(N_states)
+  double precision, intent(out) :: val(*)
+  integer(bit_kind), intent(out) :: det(N_int, 2, *)
+  integer, intent(out) :: N, ntask, task_id(*)
+  integer :: rc, rn, i
+
+  rc = f77_zmq_recv( zmq_socket_pull, N, 4, 0)
+  if(rc /= 4) stop "pull"
+
+  rc = f77_zmq_recv( zmq_socket_pull, pt2, N_states*8, 0)
+  if(rc /= 8*N_states) stop "pull"
+
+  rc = f77_zmq_recv( zmq_socket_pull, val(1), 8*N, 0)
+  if(rc /= 8*N) stop "pull"
+
+  rc = f77_zmq_recv( zmq_socket_pull, det(1,1,1), bit_kind*N_int*2*N, 0)
+  if(rc /= bit_kind*N_int*2*N) stop "pull"
+
+  rc = f77_zmq_recv( zmq_socket_pull, ntask, 4, 0)
+  if(rc /= 4) stop "pull"
+
+  rc = f77_zmq_recv( zmq_socket_pull, task_id(1), ntask*4, 0)
+  if(rc /= 4*ntask) stop "pull"
+
+! Activate is zmq_socket_pull is a REP
+!  rc = f77_zmq_send( zmq_socket_pull, task_id(1), ntask*4, 0)
+end subroutine
+ 
+ 
+

plugins/CAS_SD_ZMQ/selection_buffer.irp.f

@@ -0,0 +1,70 @@
+
+subroutine create_selection_buffer(N, siz, res)
+  use selection_types
+  implicit none
+
+  integer, intent(in) :: N, siz
+  type(selection_buffer), intent(out) :: res
+
+  allocate(res%det(N_int, 2, siz), res%val(siz))
+
+  res%val = 0d0
+  res%det = 0_8
+  res%N = N
+  res%mini = 0d0
+  res%cur = 0
+end subroutine
+
+  
+subroutine add_to_selection_buffer(b, det, val)
+  use selection_types
+  implicit none
+
+  type(selection_buffer), intent(inout) :: b
+  integer(bit_kind), intent(in) :: det(N_int, 2)
+  double precision, intent(in) :: val
+  integer :: i
+
+  if(dabs(val) >= b%mini) then
+    b%cur += 1
+    b%det(:,:,b%cur) = det(:,:)
+    b%val(b%cur) = val
+    if(b%cur == size(b%val)) then
+      call sort_selection_buffer(b)
+    end if
+  end if
+end subroutine
+
+
+subroutine sort_selection_buffer(b)
+  use selection_types
+  implicit none
+
+  type(selection_buffer), intent(inout) :: b
+  double precision, allocatable :: vals(:), absval(:)
+  integer, allocatable :: iorder(:)
+  integer(bit_kind), allocatable :: detmp(:,:,:)
+  integer :: i, nmwen
+  logical, external :: detEq
+  nmwen = min(b%N, b%cur)
+
+
+  allocate(iorder(b%cur), detmp(N_int, 2, nmwen), absval(b%cur), vals(nmwen))
+  absval = -dabs(b%val(:b%cur))
+  do i=1,b%cur
+    iorder(i) = i
+  end do
+  call dsort(absval, iorder, b%cur)
+
+  do i=1, nmwen
+    detmp(:,:,i) = b%det(:,:,iorder(i))
+    vals(i) = b%val(iorder(i))
+  end do
+  b%det(:,:,:nmwen) = detmp(:,:,:)
+  b%det(:,:,nmwen+1:) = 0_bit_kind
+  b%val(:nmwen) = vals(:)
+  b%val(nmwen+1:) = 0d0
+  b%mini = max(b%mini,dabs(b%val(b%N)))
+  b%cur = nmwen
+end subroutine
+

plugins/CAS_SD_ZMQ/selection_cassd_slave.irp.f

@@ -0,0 +1,93 @@
+program selection_slave
+  implicit none
+  BEGIN_DOC
+! Helper program to compute the PT2 in distributed mode.
+  END_DOC
+
+  read_wf = .False.
+  SOFT_TOUCH read_wf
+  call provide_everything
+  call switch_qp_run_to_master
+  call run_wf
+end
+
+subroutine provide_everything
+  PROVIDE H_apply_buffer_allocated mo_bielec_integrals_in_map psi_det_generators psi_coef_generators psi_det_sorted_bit psi_selectors n_det_generators n_states generators_bitmask zmq_context
+   PROVIDE pt2_e0_denominator mo_tot_num N_int
+end
+
+subroutine run_wf
+  use f77_zmq
+  implicit none
+
+  integer(ZMQ_PTR), external :: new_zmq_to_qp_run_socket
+  integer(ZMQ_PTR) :: zmq_to_qp_run_socket
+  double precision :: energy(N_states)
+  character*(64) :: states(1)
+  integer :: rc, i
+  
+  call provide_everything
+  
+  zmq_context = f77_zmq_ctx_new ()
+  states(1) = 'selection'
+
+  zmq_to_qp_run_socket = new_zmq_to_qp_run_socket()
+
+  do
+
+    call wait_for_states(states,zmq_state,1)
+
+    if(trim(zmq_state) == 'Stopped') then
+
+      exit
+
+    else if (trim(zmq_state) == 'selection') then
+
+      ! Selection
+      ! ---------
+
+      print *,  'Selection'
+      call zmq_get_psi(zmq_to_qp_run_socket,1,energy,N_states)
+  
+      !$OMP PARALLEL PRIVATE(i)
+      i = omp_get_thread_num()
+      call selection_slave_tcp(i, energy)
+      !$OMP END PARALLEL
+      print *,  'Selection done'
+
+    endif
+
+  end do
+end
+
+subroutine update_energy(energy)
+  implicit none
+  double precision, intent(in) :: energy(N_states)
+  BEGIN_DOC
+! Update energy when it is received from ZMQ
+  END_DOC
+  integer :: j,k
+  do j=1,N_states
+    do k=1,N_det
+      CI_eigenvectors(k,j) = psi_coef(k,j)
+    enddo
+  enddo
+  call u_0_S2_u_0(CI_eigenvectors_s2,CI_eigenvectors,N_det,psi_det,N_int)
+  if (.True.) then
+    do k=1,N_states
+      ci_electronic_energy(k) = energy(k)
+    enddo
+    TOUCH ci_electronic_energy CI_eigenvectors_s2 CI_eigenvectors
+  endif
+
+  call write_double(6,ci_energy,'Energy')
+end
+
+subroutine selection_slave_tcp(i,energy)
+  implicit none
+  double precision, intent(in) :: energy(N_states)
+  integer, intent(in)            :: i
+
+  call run_selection_slave(0,i,energy)
+end
+

plugins/CAS_SD_ZMQ/selection_types.f90

@@ -0,0 +1,9 @@
+module selection_types
+  type selection_buffer
+    integer :: N, cur
+    integer(8), allocatable :: det(:,:,:)
+    double precision, allocatable :: val(:)
+    double precision :: mini
+  endtype
+end module
+

plugins/DFT_Utils/EZFIO.cfg

@@ -0,0 +1,4 @@
+[energy]
+type: double precision
+doc: Calculated energy
+interface: ezfio

plugins/DFT_Utils/NEEDED_CHILDREN_MODULES

@@ -0,0 +1 @@
+Determinants 

plugins/DFT_Utils/grid_density.irp.f

@@ -0,0 +1,165 @@
+BEGIN_PROVIDER [integer, n_points_angular_grid]
+ implicit none
+ n_points_angular_grid = 50
+END_PROVIDER 
+
+BEGIN_PROVIDER [integer, n_points_radial_grid]
+ implicit none
+ n_points_radial_grid = 10000
+END_PROVIDER 
+
+
+ BEGIN_PROVIDER [double precision, angular_quadrature_points, (n_points_angular_grid,3) ]
+&BEGIN_PROVIDER [double precision, weights_angular_points, (n_points_angular_grid)]
+ implicit none
+ BEGIN_DOC
+! weights and grid points for the integration on the angular variables on 
+! the unit sphere centered on (0,0,0)
+! According to the LEBEDEV scheme
+ END_DOC
+ call cal_quad(n_points_angular_grid, angular_quadrature_points,weights_angular_points)
+ include 'constants.include.F'
+ integer :: i
+ double precision :: accu
+ double precision :: degre_rad
+!degre_rad = 180.d0/pi
+!accu = 0.d0
+!do i = 1, n_points_integration_angular_lebedev
+! accu += weights_angular_integration_lebedev(i)
+! weights_angular_points(i) = weights_angular_integration_lebedev(i) * 2.d0 * pi
+! angular_quadrature_points(i,1) = dcos ( degre_rad *  theta_angular_integration_lebedev(i)) & 
+!                                * dsin ( degre_rad *  phi_angular_integration_lebedev(i))
+! angular_quadrature_points(i,2) = dsin ( degre_rad *  theta_angular_integration_lebedev(i)) & 
+!                                * dsin ( degre_rad *  phi_angular_integration_lebedev(i))
+! angular_quadrature_points(i,3) = dcos ( degre_rad *  phi_angular_integration_lebedev(i))   
+!enddo
+!print*,'ANGULAR'
+!print*,''
+!print*,'accu = ',accu
+!ASSERT( dabs(accu - 1.D0) < 1.d-10)
+
+END_PROVIDER 
+
+BEGIN_PROVIDER [integer , m_knowles]
+ implicit none
+ BEGIN_DOC
+! value of the "m" parameter in the equation (7) of the paper of Knowles (JCP, 104, 1996)
+ END_DOC
+ m_knowles = 3
+END_PROVIDER 
+
+ BEGIN_PROVIDER [double precision, grid_points_radial, (n_points_radial_grid)]
+&BEGIN_PROVIDER [double precision, dr_radial_integral]
+
+ implicit none
+ BEGIN_DOC
+! points in [0,1] to map the radial integral [0,\infty] 
+ END_DOC
+ dr_radial_integral = 1.d0/dble(n_points_radial_grid-1)
+ integer :: i
+ do i = 1, n_points_radial_grid-1
+  grid_points_radial(i) = (i-1) * dr_radial_integral
+ enddo
+
+END_PROVIDER 
+
+BEGIN_PROVIDER [double precision, grid_points_per_atom, (3,n_points_angular_grid,n_points_radial_grid,nucl_num)]
+ BEGIN_DOC
+! points for integration over space
+ END_DOC
+ implicit none
+ integer :: i,j,k
+ double precision :: dr,x_ref,y_ref,z_ref
+ double precision :: knowles_function
+ do i = 1, nucl_num
+  x_ref = nucl_coord(i,1)
+  y_ref = nucl_coord(i,2)
+  z_ref = nucl_coord(i,3)
+  do j = 1, n_points_radial_grid-1
+   double precision :: x,r
+   x = grid_points_radial(j) ! x value for the mapping of the [0, +\infty] to [0,1]
+   r = knowles_function(alpha_knowles(int(nucl_charge(i))),m_knowles,x) ! value of the radial coordinate for the integration 
+   do k = 1, n_points_angular_grid  ! explicit values of the grid points centered around each atom 
+    grid_points_per_atom(1,k,j,i) = x_ref + angular_quadrature_points(k,1) * r
+    grid_points_per_atom(2,k,j,i) = y_ref + angular_quadrature_points(k,2) * r
+    grid_points_per_atom(3,k,j,i) = z_ref + angular_quadrature_points(k,3) * r
+   enddo
+  enddo
+ enddo
+END_PROVIDER 
+
+BEGIN_PROVIDER [double precision, weight_functions_at_grid_points, (n_points_angular_grid,n_points_radial_grid,nucl_num) ]
+ BEGIN_DOC 
+! Weight function at grid points : w_n(r) according to the equation (22) of Becke original paper (JCP, 88, 1988)
+! the "n" discrete variable represents the nucleis which in this array is represented by the last dimension 
+! and the points are labelled by the other dimensions
+ END_DOC
+ implicit none
+ integer :: i,j,k,l,m
+ double precision :: r(3)
+ double precision :: accu,cell_function_becke
+ double precision :: tmp_array(nucl_num)
+ ! run over all points in space
+  do j = 1, nucl_num  ! that are referred to each atom 
+   do k = 1, n_points_radial_grid -1  !for each radial grid attached to the "jth" atom
+    do l = 1, n_points_angular_grid ! for each angular point attached to the "jth" atom
+     r(1) = grid_points_per_atom(1,l,k,j)
+     r(2) = grid_points_per_atom(2,l,k,j)
+     r(3) = grid_points_per_atom(3,l,k,j)
+     accu = 0.d0
+     do i = 1, nucl_num ! For each of these points in space, ou need to evaluate the P_n(r)
+                        ! function defined for each atom "i" by equation (13) and (21) with k == 3
+      tmp_array(i) = cell_function_becke(r,i) ! P_n(r)
+      ! Then you compute the summ the P_n(r) function for each of the "r" points
+      accu += tmp_array(i)
+     enddo
+     accu = 1.d0/accu
+     weight_functions_at_grid_points(l,k,j) = tmp_array(j) * accu 
+!    print*,weight_functions_at_grid_points(l,k,j)
+    enddo
+   enddo
+  enddo
+
+
+END_PROVIDER 
+
+ BEGIN_PROVIDER [double precision, one_body_dm_mo_alpha_at_grid_points, (n_points_angular_grid,n_points_radial_grid,nucl_num) ]
+&BEGIN_PROVIDER [double precision, one_body_dm_mo_beta_at_grid_points, (n_points_angular_grid,n_points_radial_grid,nucl_num) ]
+ implicit none
+ integer :: i,j,k,l,m
+ double precision :: contrib
+ double precision :: r(3)
+ double precision :: aos_array(ao_num),mos_array(mo_tot_num)
+  do j = 1, nucl_num
+   do k = 1, n_points_radial_grid -1
+    do l = 1, n_points_angular_grid
+     one_body_dm_mo_alpha_at_grid_points(l,k,j) = 0.d0
+     one_body_dm_mo_beta_at_grid_points(l,k,j) = 0.d0
+     r(1) = grid_points_per_atom(1,l,k,j)
+     r(2) = grid_points_per_atom(2,l,k,j)
+     r(3) = grid_points_per_atom(3,l,k,j)
+
+!    call give_all_aos_at_r(r,aos_array)
+!    do i = 1, ao_num
+!      do m = 1, ao_num
+!       contrib = aos_array(i) * aos_array(m)
+!       one_body_dm_mo_alpha_at_grid_points(l,k,j) +=  one_body_dm_ao_alpha(i,m) * contrib
+!       one_body_dm_mo_beta_at_grid_points(l,k,j) +=  one_body_dm_ao_beta(i,m)  * contrib
+!      enddo
+!    enddo
+
+     call give_all_mos_at_r(r,mos_array)
+     do i = 1, mo_tot_num
+      do m = 1, mo_tot_num
+       contrib = mos_array(i) * mos_array(m)
+       one_body_dm_mo_alpha_at_grid_points(l,k,j) += one_body_dm_mo_alpha(i,m) * contrib
+       one_body_dm_mo_beta_at_grid_points(l,k,j) += one_body_dm_mo_beta(i,m) * contrib
+      enddo
+     enddo
+
+    enddo
+   enddo
+  enddo
+
+END_PROVIDER 
+

plugins/DFT_Utils/integration_3d.irp.f

@@ -0,0 +1,54 @@
+double precision function step_function_becke(x)
+ implicit none
+ double precision, intent(in) :: x
+ double precision :: f_function_becke
+ integer :: i,n_max_becke
+
+!if(x.lt.-1.d0)then
+! step_function_becke = 0.d0
+!else if (x .gt.1)then
+! step_function_becke = 0.d0
+!else 
+  step_function_becke = f_function_becke(x)
+!!n_max_becke = 1
+  do i = 1, 4
+   step_function_becke = f_function_becke(step_function_becke)
+  enddo
+  step_function_becke = 0.5d0*(1.d0 - step_function_becke)
+!endif
+end
+
+double precision function f_function_becke(x)
+ implicit none
+ double precision, intent(in) :: x
+ f_function_becke = 1.5d0 * x - 0.5d0 * x*x*x
+end
+
+double precision function cell_function_becke(r,atom_number)
+ implicit none
+ double precision, intent(in) :: r(3)
+ integer, intent(in) :: atom_number
+ BEGIN_DOC
+ ! atom_number :: atom on which the cell function of Becke (1988, JCP,88(4))
+ ! r(1:3) :: x,y,z coordinantes of the current point 
+ END_DOC
+ double precision :: mu_ij,nu_ij
+ double precision :: distance_i,distance_j,step_function_becke
+ integer :: j
+ distance_i = (r(1) - nucl_coord_transp(1,atom_number) ) * (r(1) - nucl_coord_transp(1,atom_number))  
+ distance_i += (r(2) - nucl_coord_transp(2,atom_number) ) * (r(2) - nucl_coord_transp(2,atom_number))  
+ distance_i += (r(3) - nucl_coord_transp(3,atom_number) ) * (r(3) - nucl_coord_transp(3,atom_number))
+ distance_i = dsqrt(distance_i)
+ cell_function_becke = 1.d0
+ do j = 1, nucl_num
+  if(j==atom_number)cycle
+  distance_j = (r(1) - nucl_coord_transp(1,j) ) * (r(1) - nucl_coord_transp(1,j))  
+  distance_j+= (r(2) - nucl_coord_transp(2,j) ) * (r(2) - nucl_coord_transp(2,j))  
+  distance_j+= (r(3) - nucl_coord_transp(3,j) ) * (r(3) - nucl_coord_transp(3,j))
+  distance_j = dsqrt(distance_j)
+  mu_ij = (distance_i - distance_j)/nucl_dist(atom_number,j)
+  nu_ij = mu_ij + slater_bragg_type_inter_distance_ua(atom_number,j) * (1.d0 - mu_ij*mu_ij)
+  cell_function_becke *= step_function_becke(nu_ij)
+ enddo
+end
+

plugins/DFT_Utils/integration_radial.irp.f

@@ -0,0 +1,109 @@
+ BEGIN_PROVIDER [ double precision, integral_density_alpha_knowles_becke_per_atom, (nucl_num)]
+&BEGIN_PROVIDER [ double precision, integral_density_beta_knowles_becke_per_atom, (nucl_num)]
+ implicit none
+ double precision :: accu
+ integer :: i,j,k,l
+ double precision :: x
+ double precision :: integrand(n_points_angular_grid), weights(n_points_angular_grid)
+ double precision :: f_average_angular_alpha,f_average_angular_beta
+ double precision :: derivative_knowles_function,knowles_function
+
+ ! Run over all nuclei in order to perform the Voronoi partition 
+ ! according ot equation (6) of the paper of Becke (JCP, (88), 1988)
+ ! Here the m index is referred to the w_m(r) weight functions of equation (22)
+   ! Run over all points of integrations : there are  
+   ! n_points_radial_grid (i) * n_points_angular_grid (k) 
+   do j = 1, nucl_num 
+    integral_density_alpha_knowles_becke_per_atom(j) = 0.d0
+    integral_density_beta_knowles_becke_per_atom(j) = 0.d0
+    do i = 1, n_points_radial_grid-1
+     ! Angular integration over the solid angle Omega for a FIXED angular coordinate "r"
+     f_average_angular_alpha = 0.d0
+     f_average_angular_beta = 0.d0
+     do k = 1, n_points_angular_grid
+      f_average_angular_alpha += weights_angular_points(k) * one_body_dm_mo_alpha_at_grid_points(k,i,j) * weight_functions_at_grid_points(k,i,j)
+      f_average_angular_beta  += weights_angular_points(k) * one_body_dm_mo_beta_at_grid_points(k,i,j)  * weight_functions_at_grid_points(k,i,j)
+     enddo
+     ! 
+     x = grid_points_radial(i) ! x value for the mapping of the [0, +\infty] to [0,1]
+     double precision ::  contrib_integration
+!    print*,m_knowles
+     contrib_integration = derivative_knowles_function(alpha_knowles(int(nucl_charge(j))),m_knowles,x) & 
+                          *knowles_function(alpha_knowles(int(nucl_charge(j))),m_knowles,x)**2          
+     integral_density_alpha_knowles_becke_per_atom(j) += contrib_integration *f_average_angular_alpha
+     integral_density_beta_knowles_becke_per_atom(j) += contrib_integration *f_average_angular_beta
+    enddo
+    integral_density_alpha_knowles_becke_per_atom(j) *= dr_radial_integral
+    integral_density_beta_knowles_becke_per_atom(j) *= dr_radial_integral
+   enddo
+ 
+END_PROVIDER 
+
+ double precision function knowles_function(alpha,m,x)
+ implicit none
+ BEGIN_DOC
+! function proposed by Knowles (JCP, 104, 1996) for distributing the radial points : 
+! the Log "m" function ( equation (7) in the paper )
+ END_DOC
+ double precision, intent(in) :: alpha,x
+ integer, intent(in) :: m
+ knowles_function = -alpha * dlog(1.d0-x**m)
+ end
+
+ double precision function derivative_knowles_function(alpha,m,x)
+ implicit none
+ BEGIN_DOC
+! derivative of the function proposed by Knowles (JCP, 104, 1996) for distributing the radial points
+ END_DOC
+ double precision, intent(in) :: alpha,x
+ integer, intent(in) :: m
+ derivative_knowles_function = alpha * dble(m) * x**(m-1) / (1.d0 - x**m)
+ end
+
+ BEGIN_PROVIDER [double precision, alpha_knowles, (100)]
+ implicit none
+ integer :: i
+ BEGIN_DOC
+! recommended values for the alpha parameters according to the paper of Knowles (JCP, 104, 1996)
+! as a function of the nuclear charge
+ END_DOC
+
+ ! H-He
+ alpha_knowles(1) = 5.d0 
+ alpha_knowles(2) = 5.d0 
+ 
+ ! Li-Be
+ alpha_knowles(3) = 7.d0 
+ alpha_knowles(4) = 7.d0 
+
+ ! B-Ne
+ do i = 5, 10
+  alpha_knowles(i) = 5.d0 
+ enddo
+
+ ! Na-Mg
+ do i = 11, 12
+  alpha_knowles(i) = 7.d0 
+ enddo
+
+ ! Al-Ar
+ do i = 13, 18
+  alpha_knowles(i) = 5.d0 
+ enddo
+
+ ! K-Ca 
+ do i = 19, 20
+  alpha_knowles(i) = 7.d0 
+ enddo
+
+ ! Sc-Zn
+ do i = 21, 30
+  alpha_knowles(i) = 5.d0 
+ enddo
+
+ ! Ga-Kr
+ do i = 31, 36
+  alpha_knowles(i) = 7.d0 
+ enddo
+
+ END_PROVIDER 

plugins/DFT_Utils/routines_roland.irp.f

@@ -0,0 +1,219 @@
+
+  subroutine cal_quad(n_quad, quad, weight)
+! --------------------------------------------------------------------------------
+! 
+! Arguments  : subroutine cal_quad
+! Description: evaluates quadrature points an weights
+! 
+! Authors    : B. Lévy, P. Pernot
+! Date       : 15 Nov 2000
+! --------------------------------------------------------------------------------
+  implicit none
+  integer, intent(in) :: n_quad
+  double precision, intent(out) :: weight(n_quad)
+  double precision, intent(out) :: quad(n_quad,3)
+  
+! local:
+    double precision, parameter :: zero=0.d0, one= 1.d0
+
+    double precision, parameter :: p=0.707106781186547462d0
+    double precision, parameter :: q=0.577350269189625842d0
+    double precision, parameter :: r=0.301511344577763629d0
+    double precision, parameter :: s=0.904534033733290888d0
+
+    double precision, parameter :: fourpi= 12.5663706143591725d0
+
+    double precision, parameter :: a6=0.166666666666666657d0
+    double precision, parameter :: a18=0.333333333333333329d-01
+    double precision, parameter :: b18=0.666666666666666657d-01
+    double precision, parameter :: a26=0.476190476190476164d-01
+    double precision, parameter :: b26=0.380952380952380987d-01
+    double precision, parameter :: c26=0.321428571428571397d-01
+    double precision, parameter :: a50=0.126984126984126984d-01
+    double precision, parameter :: b50=0.225749559082892431d-01
+    double precision, parameter :: c50=0.210937500000000014d-01
+    double precision, parameter :: d50=0.201733355379188697d-01
+
+    double precision            :: apt(3,6),bpt(3,12),cpt(3,8),dpt(3,24)
+    double precision            :: awght,bwght,cwght,dwght
+    double precision            :: s1, s2, s3
+    integer             :: idim, ipt, i1, i2, i3, is1, is2, is3
+    integer             :: iquad
+
+! begin:
+! l_here ='cal_quad'
+! call enter (l_here,3)
+
+! verifications:
+!   message = 'in '//trim(l_here)//', number of dimensions='//&
+!             trim(encode(dimensions_nb))//', must be 3'
+!   call ensure(message, dimensions_nb .eq. 3 )
+
+!   message = 'in '//trim(l_here)//', invalid number of quadrature points ='&
+!             //trim(encode(n_quad))
+!   call ensure(message,(n_quad-2)*(n_quad-6)*(n_quad-18)*(n_quad-26)*(n_quad-50) .eq. 0)
+
+! initialize weights
+    awght = zero
+    bwght = zero
+    cwght = zero
+    dwght = zero
+
+! type A points : (+/-1,0,0)
+    awght=a6*fourpi
+    ipt= 1
+    apt=0.
+    do idim = 1, 3
+      apt(idim,ipt)=one
+      ipt=ipt+1
+      apt(idim,ipt)=-one
+      ipt=ipt+1
+    enddo     
+
+! type B points : (+/-p,+/-p,0) with p= 1/sqrt(2)
+    if(n_quad.gt.6) then
+
+      awght=a18*fourpi
+      bwght=b18*fourpi
+
+      s1=p
+      s2=p
+      ipt= 1
+      bpt=0.
+      do idim = 1, 3
+        i1=idim+1
+        if(i1.gt.3) i1=i1-3
+        i2=idim+2
+        if(i2.gt.3) i2=i2-3
+        do is1= 1,2
+          do is2= 1,2
+            bpt(i1,ipt)=s1
+            bpt(i2,ipt)=s2
+            s2=-s2
+            ipt=ipt+1
+          enddo      
+          s1=-s1
+        enddo       
+      enddo    
+    endif
+
+! type C points : (+/-q,+/-q,+/-q) with q= 1/sqrt(3)
+   if(n_quad.gt.18) then
+
+      awght=a26*fourpi
+      bwght=b26*fourpi
+      cwght=c26*fourpi
+
+      s1=q
+      s2=q
+      s3=q
+      ipt= 1
+      cpt=0.
+      do is1= 1,2
+        do is2= 1,2
+          do is3= 1,2
+            cpt(1,ipt)=s1
+            cpt(2,ipt)=s2
+            cpt(3,ipt)=s3
+            s3=-s3
+            ipt=ipt+1
+          enddo       
+          s2=-s2
+        enddo       
+        s1=-s1
+      enddo    
+    endif
+
+! type D points : (+/-r,+/-r,+/-s)
+    if(n_quad.gt.26) then
+
+      awght=a50*fourpi
+      bwght=b50*fourpi
+      cwght=c50*fourpi
+      dwght=d50*fourpi
+
+      ipt= 1
+      dpt=0.
+      do i1= 1, 3
+        s1=s
+        s2=r
+        s3=r
+        i2=i1+1
+        if(i2.gt.3) i2=i2-3
+        i3=i1+2
+        if(i3.gt.3) i3=i3-3
+        do is1= 1,2
+          do is2= 1,2
+            do is3= 1,2
+              dpt(i1,ipt)=s1
+              dpt(i2,ipt)=s2
+              dpt(i3,ipt)=s3
+              s3=-s3
+              ipt=ipt+1
+            enddo         
+            s2=-s2
+          enddo        
+          s1=-s1
+        enddo         
+      enddo     
+    endif
+
+! fill the points and weights tables
+    iquad= 1
+    do ipt= 1, 6
+      do idim = 1, 3
+        quad(iquad,idim)=apt(idim,ipt)
+      enddo
+      weight(iquad)=awght
+      iquad=iquad+1
+    enddo     
+
+    if(n_quad.gt.6) then
+      do ipt= 1,12
+        do idim = 1, 3
+          quad(iquad,idim)=bpt(idim,ipt)
+        enddo
+        weight(iquad)=bwght
+        iquad=iquad+1
+      enddo            
+    endif
+
+    if(n_quad.gt.18) then
+      do ipt= 1,8
+        do idim = 1, 3
+          quad(iquad,idim)=cpt(idim,ipt)
+        enddo
+        weight(iquad)=cwght
+        iquad=iquad+1
+      enddo            
+    endif
+
+    if(n_quad.gt.26) then
+      do ipt= 1,24
+        do idim = 1, 3
+          quad(iquad,idim)=dpt(idim,ipt)
+        enddo
+        weight(iquad)=dwght
+        iquad=iquad+1
+      enddo            
+    endif
+
+!   if (debug) then
+!     write(6,*)
+!     write(6,'(1X,a)') trim(l_here)//'-d : '//&
+!       '------------------------------------------------------'
+!     write(6,'(1X,a)') trim(l_here)//'-d : '//'  I    Weight      Quad_points'
+!     write(6,'(1X,a)') trim(l_here)//'-d : '//&
+!       '-----  ----------  -----------------------------------'
+!     do iquad= 1, n_quad
+!        write(6,'(1X,A,i5,4e12.3)') trim(l_here)//'-d : ',&
+!          iquad,weight(iquad),quad(iquad,1:3)
+!     enddo
+!     write(6,'(1X,a)') trim(l_here)//'-d : '//&
+!       '------------------------------------------------------'
+!     write(6,*)
+!   endif
+
+! call exit (l_here,3)
+
+  end subroutine cal_quad

plugins/DFT_Utils/test_integration_3d_density.irp.f

@@ -0,0 +1,24 @@
+program pouet
+ print*,'coucou'
+ read_wf = .True.
+ touch read_wf
+ print*,'m_knowles = ',m_knowles
+ call routine
+
+end
+subroutine routine
+ implicit none
+ integer :: i
+ double precision :: accu(2)
+ accu = 0.d0
+ do i = 1, nucl_num
+  accu(1) += integral_density_alpha_knowles_becke_per_atom(i)
+  accu(2) += integral_density_beta_knowles_becke_per_atom(i)
+ enddo
+ print*,'accu(1) = ',accu(1)
+ print*,'Nalpha  = ',elec_alpha_num
+ print*,'accu(2) = ',accu(2)
+ print*,'Nalpha  = ',elec_beta_num
+
+
+end

plugins/FOBOCI/EZFIO.cfg

@@ -19,10 +19,15 @@ default: 0.00001
 
 [do_it_perturbative]
 type: logical
-doc: if true, you do the FOBOCI calculation perturbatively 
+doc: if true, when a given 1h or 1p determinant is not selected because of its perturbation estimate, then if its coefficient is lower than threshold_perturbative, it is acounted in the FOBOCI differential density matrices
 interface: ezfio,provider,ocaml
 default: .False.
 
+[threshold_perturbative]
+type: double precision
+doc: when do_it_perturbative is True, threshold_perturbative select if a given determinant ia selected or not for beign taken into account in the FOBO-SCF treatment. In practive, if the coefficient is larger then threshold_perturbative it means that it not selected as the perturbation should not be too importan. A value of 0.01 is in general OK.
+interface: ezfio,provider,ocaml
+default: 0.001
 
 [speed_up_convergence_foboscf]
 type: logical
@@ -49,3 +54,9 @@ doc: if true, you do all 2p type excitation on the LMCT
 interface: ezfio,provider,ocaml
 default: .True.
 
+[selected_fobo_ci]
+type: logical
+doc: if true, for each CI step you will run a CIPSI calculation that stops at  pt2_max 
+interface: ezfio,provider,ocaml
+default: .False.
+

plugins/FOBOCI/SC2_1h1p.irp.f

@@ -0,0 +1,889 @@
+subroutine dressing_1h1p(dets_in,u_in,diag_H_elements,dim_in,sze,N_st,Nint,convergence)
+  use bitmasks
+  implicit none
+  BEGIN_DOC
+  ! CISD+SC2 method              :: take off all the disconnected terms of a ROHF+1h1p (selected or not)
+  !
+  ! 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
+  integer, intent(in)            :: dim_in, sze, N_st, Nint
+  integer(bit_kind), intent(in)  :: dets_in(Nint,2,sze)
+  double precision, intent(inout) :: u_in(dim_in,N_st)
+  double precision, intent(out)  :: diag_H_elements(dim_in)
+  double precision, intent(in)   :: convergence
+  
+  integer :: i,j,k,l
+  integer :: n_singles
+  integer :: index_singles(sze),hole_particles_singles(sze,3)
+  integer :: n_doubles
+  integer :: index_doubles(sze),hole_particles_doubles(sze,2)
+  integer :: index_hf
+  double precision :: e_corr_singles(mo_tot_num,2)
+  double precision :: e_corr_doubles(mo_tot_num)
+  double precision :: e_corr_singles_total(2)
+  double precision :: e_corr_doubles_1h1p
+
+  integer :: exc(0:2,2,2),degree
+  integer :: h1,h2,p1,p2,s1,s2
+  integer :: other_spin(2)
+  double precision :: phase
+  integer(bit_kind) :: key_tmp(N_int,2)
+  integer :: i_ok
+  double precision :: phase_single_double,phase_double_hf,get_mo_bielec_integral
+  double precision :: hij,c_ref,contrib
+  integer :: iorb
+
+  other_spin(1) = 2
+  other_spin(2) = 1
+
+  n_singles = 0
+  n_doubles = 0
+  do i = 1,sze
+   call get_excitation(ref_bitmask,dets_in(1,1,i),exc,degree,phase,N_int)
+   call decode_exc(exc,degree,h1,p1,h2,p2,s1,s2)
+   call i_H_j(dets_in(1,1,i),dets_in(1,1,i),N_int,hij)
+   diag_H_elements(i) = hij
+   if(degree == 0)then
+    index_hf = i
+   else if (degree == 1)then
+    n_singles +=1
+    index_singles(n_singles) = i
+    ! h1 = inactive orbital of the hole
+    hole_particles_singles(n_singles,1) = h1
+    ! p1 = virtual orbital of the particle
+    hole_particles_singles(n_singles,2) = p1
+    ! s1 = spin of the electron excited
+    hole_particles_singles(n_singles,3) = s1
+   else if (degree == 2)then
+    n_doubles +=1
+    index_doubles(n_doubles) = i
+    ! h1 = inactive orbital of the hole (beta of course)
+    hole_particles_doubles(n_doubles,1) = h1
+    ! p1 = virtual orbital of the particle (alpha of course)
+    hole_particles_doubles(n_doubles,2) = p2
+   else 
+    print*,'PB !! found out other thing than a single or double'
+    print*,'stopping ..'
+    stop
+   endif
+  enddo
+
+  e_corr_singles = 0.d0
+  e_corr_doubles = 0.d0
+  e_corr_singles_total = 0.d0
+  e_corr_doubles_1h1p = 0.d0
+  c_ref = 1.d0/u_in(index_hf,1)
+  print*,'c_ref = ',c_ref
+  do i = 1,sze
+   call get_excitation(ref_bitmask,dets_in(1,1,i),exc,degree,phase,N_int)
+   call decode_exc(exc,degree,h1,p1,h2,p2,s1,s2)
+   call i_H_j(ref_bitmask,dets_in(1,1,i),N_int,hij)
+   contrib = hij * u_in(i,1) * c_ref
+   if (degree == 1)then
+    e_corr_singles(h1,s1) += contrib
+    e_corr_singles(p1,s1) += contrib
+    e_corr_singles_total(s1)+= contrib
+   else if (degree == 2)then
+    e_corr_doubles_1h1p += contrib
+    e_corr_doubles(h1) += contrib
+    e_corr_doubles(p2) += contrib
+   endif
+  enddo
+  print*,'e_corr_singles alpha = ',e_corr_singles_total(1)
+  print*,'e_corr_singles beta  = ',e_corr_singles_total(2)
+  print*,'e_corr_doubles_1h1p  = ',e_corr_doubles_1h1p
+  
+  ! repeat all the correlation energy on the singles
+  do i = 1,n_singles
+   ! you can repeat all the correlation energy of the single excitation of the other spin
+   diag_H_elements(index_singles(i)) += e_corr_singles_total(other_spin(hole_particles_singles(i,3)))
+
+   ! you can repeat all the correlation energy of the single excitation of the same spin
+   do j = 1, n_inact_orb
+    iorb = list_inact(j)
+    ! except the one of the hole
+    if(iorb == hole_particles_singles(i,1))cycle
+    ! ispin = hole_particles_singles(i,3)
+    diag_H_elements(index_singles(i)) += e_corr_singles(iorb,hole_particles_singles(i,3))
+   enddo
+   ! also exclude all the energy coming from the virtual orbital
+   diag_H_elements(index_singles(i)) -= e_corr_singles(hole_particles_singles(i,2),hole_particles_singles(i,3))
+ 
+   ! If it is a single excitation alpha, you can repeat : 
+   !  +) all the double excitation 1h1p, appart the part involving the virtual orbital "r"
+   ! If it is a single excitation alpha, you can repeat : 
+   !  +) all the double excitation 1h1p, appart the part involving the inactive orbital "i"
+   diag_H_elements(index_singles(i)) += e_corr_doubles_1h1p
+   if(hole_particles_singles(i,3) == 1)then  ! alpha single excitation
+    diag_H_elements(index_singles(i)) -= e_corr_doubles(hole_particles_singles(i,2))
+   else  ! beta single exctitation 
+    diag_H_elements(index_singles(i)) -= e_corr_doubles(hole_particles_singles(i,1))
+   endif
+  enddo
+
+  ! repeat all the correlation energy on the doubles
+  ! as all the doubles involve the active space, you cannot repeat any of them one on another
+  do i = 1, n_doubles
+   ! on a given double, you can repeat all the correlation energy of the singles alpha 
+   do j = 1, n_inact_orb
+    iorb = list_inact(j)
+    ! ispin = hole_particles_singles(i,3)
+    diag_H_elements(index_doubles(i)) += e_corr_singles(iorb,1)
+   enddo
+   ! except the part involving the virtual orbital "hole_particles_doubles(i,2)"
+   diag_H_elements(index_doubles(i)) -= e_corr_singles(hole_particles_doubles(i,2),1)
+   ! on a given double, you can repeat all the correlation energy of the singles beta
+   do j = 1, n_inact_orb
+    iorb = list_inact(j)
+    ! except the one of the hole
+    if(iorb == hole_particles_doubles(i,1))cycle
+    ! ispin = hole_particles_singles(i,3)
+    diag_H_elements(index_doubles(i)) += e_corr_singles(iorb,2)
+   enddo
+  enddo
+
+
+  ! Taking into account the connected part of the 2h2p on the HF determinant 
+  ! 1/2 \sum_{ir,js} c_{ir}^{sigma} c_{js}^{sigma}
+  
+! diag_H_elements(index_hf) += total_corr_e_2h2p
+  return
+  c_ref = c_ref * c_ref
+  print*,'diag_H_elements(index_hf) = ',diag_H_elements(index_hf)
+  do i = 1, n_singles
+   ! start on the single excitation "|i>"
+   h1 = hole_particles_singles(i,1)
+   p1 = hole_particles_singles(i,2)
+   do j = 1, n_singles
+    do k = 1, N_int
+     key_tmp(k,1) = dets_in(k,1,index_singles(i))
+     key_tmp(k,2) = dets_in(k,2,index_singles(i))
+    enddo
+    h2 = hole_particles_singles(j,1)
+    p2 = hole_particles_singles(j,2)
+    call do_mono_excitation(key_tmp,h2,p2,hole_particles_singles(j,3),i_ok)    
+    ! apply the excitation operator from the single excitation "|j>"
+    if(i_ok .ne. 1)cycle
+    double precision :: phase_ref_other_single,diag_H_mat_elem,hijj,contrib_e2,coef_1
+    call get_excitation(key_tmp,dets_in(1,1,index_singles(i)),exc,degree,phase_single_double,N_int)
+    call get_excitation(ref_bitmask,dets_in(1,1,index_singles(j)),exc,degree,phase_ref_other_single,N_int)
+    call i_H_j(ref_bitmask,key_tmp,N_int,hij)
+    diag_H_elements(index_hf) += u_in(index_singles(i),1) * u_in(index_singles(j),1) * c_ref * hij & 
+                                * phase_single_double * phase_ref_other_single
+   enddo
+  enddo
+  print*,'diag_H_elements(index_hf) = ',diag_H_elements(index_hf)
+
+end
+
+
+subroutine dressing_1h1p_by_2h2p(dets_in,u_in,diag_H_elements,dim_in,sze,N_st,Nint,convergence)
+  use bitmasks
+  implicit none
+  BEGIN_DOC
+  ! CISD+SC2 method              :: take off all the disconnected terms of a ROHF+1h1p (selected or not)
+  !
+  ! 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
+  integer, intent(in)            :: dim_in, sze, N_st, Nint
+  integer(bit_kind), intent(in)  :: dets_in(Nint,2,sze)
+  double precision, intent(inout) :: u_in(dim_in,N_st)
+  double precision, intent(out)  :: diag_H_elements(0:dim_in)
+  double precision, intent(in)   :: convergence
+  
+  integer :: i,j,k,l
+  integer :: r,s,i0,j0,r0,s0
+  integer :: n_singles
+  integer :: index_singles(sze),hole_particles_singles(sze,3)
+  integer :: n_doubles
+  integer :: index_doubles(sze),hole_particles_doubles(sze,2)
+  integer :: index_hf
+  double precision :: e_corr_singles(mo_tot_num,2)
+  double precision :: e_corr_doubles(mo_tot_num)
+  double precision :: e_corr_singles_total(2)
+  double precision :: e_corr_doubles_1h1p
+
+  integer :: exc(0:2,2,2),degree
+  integer :: h1,h2,p1,p2,s1,s2
+  integer :: other_spin(2)
+  double precision :: phase
+  integer(bit_kind) :: key_tmp(N_int,2)
+  integer :: i_ok
+  double precision :: phase_single_double,phase_double_hf,get_mo_bielec_integral
+  double precision :: hij,c_ref,contrib
+  integer :: iorb
+
+  other_spin(1) = 2
+  other_spin(2) = 1
+
+  n_singles = 0
+  n_doubles = 0
+  do i = 1,sze
+   call get_excitation(ref_bitmask,dets_in(1,1,i),exc,degree,phase,N_int)
+   call decode_exc(exc,degree,h1,p1,h2,p2,s1,s2)
+   call i_H_j(dets_in(1,1,i),dets_in(1,1,i),N_int,hij)
+   diag_H_elements(i) = hij
+   if(degree == 0)then
+    index_hf = i
+   else if (degree == 1)then
+    n_singles +=1
+    index_singles(n_singles) = i
+    ! h1 = inactive orbital of the hole
+    hole_particles_singles(n_singles,1) = h1
+    ! p1 = virtual orbital of the particle
+    hole_particles_singles(n_singles,2) = p1
+    ! s1 = spin of the electron excited
+    hole_particles_singles(n_singles,3) = s1
+   else if (degree == 2)then
+    n_doubles +=1
+    index_doubles(n_doubles) = i
+    ! h1 = inactive orbital of the hole (beta of course)
+    hole_particles_doubles(n_doubles,1) = h1
+    ! p1 = virtual orbital of the particle (alpha of course)
+    hole_particles_doubles(n_doubles,2) = p2
+   else 
+    print*,'PB !! found out other thing than a single or double'
+    print*,'stopping ..'
+    stop
+   endif
+  enddo
+  double precision :: delta_e
+  double precision :: coef_ijrs
+  diag_H_elements = 0.d0
+  do i0 = 1, n_core_inact_orb
+   i= list_core_inact(i0)
+   do j0 = i0+1, n_core_inact_orb
+    j = list_core_inact(j0)
+    print*, i,j
+    do r0 = 1, n_virt_orb
+     r = list_virt(r0)
+     do s0 = r0+1, n_virt_orb
+      s = list_virt(s0)
+     !!! alpha (i-->r) / beta (j-->s)
+      s1 = 1
+      s2 = 2
+      key_tmp = ref_bitmask
+      call do_mono_excitation(key_tmp,i,r,s1,i_ok)
+      if(i_ok .ne.1)then
+       print*, 'pb !!'
+       stop
+      endif
+      call do_mono_excitation(key_tmp,j,s,s2,i_ok)
+      if(i_ok .ne.1)then
+       print*, 'pb !!'
+       stop
+      endif
+      call i_H_j(ref_bitmask, key_tmp, N_int,hij)
+      delta_e = Fock_matrix_diag_mo(i) + Fock_matrix_diag_mo(j) - Fock_matrix_diag_mo(r) - Fock_matrix_diag_mo(s)
+      coef_ijrs = hij/delta_e
+      do k = 1, n_singles
+       l = index_singles(k) 
+       call i_H_j(dets_in(1,1,l), key_tmp, N_int,hij)
+       diag_H_elements(l) += coef_ijrs * hij
+      enddo
+     !if(i>j.and.r>s)then
+       !! alpha (i-->r) / alpha (j-->s)
+       s1 = 1
+       s2 = 1
+       key_tmp = ref_bitmask
+       call do_mono_excitation(key_tmp,i,r,s1,i_ok)
+       if(i_ok .ne.1)then
+        print*, 'pb !!'
+        stop
+       endif
+       call do_mono_excitation(key_tmp,j,s,s2,i_ok)
+       if(i_ok .ne.1)then
+        print*, 'pb !!'
+        stop
+       endif
+       call i_H_j(ref_bitmask, key_tmp, N_int,hij)
+       delta_e = Fock_matrix_diag_mo(i) + Fock_matrix_diag_mo(j) - Fock_matrix_diag_mo(r) - Fock_matrix_diag_mo(s)
+       coef_ijrs = hij/delta_e
+       do k = 1, n_singles
+        l = index_singles(k) 
+        call i_H_j(dets_in(1,1,l), key_tmp, N_int,hij)
+        diag_H_elements(l) += coef_ijrs * hij
+       enddo
+       !! beta (i-->r) / beta (j-->s)
+       s1 = 2
+       s2 = 2
+       key_tmp = ref_bitmask
+       call do_mono_excitation(key_tmp,i,r,s1,i_ok)
+       if(i_ok .ne.1)then
+        print*, 'pb !!'
+        stop
+       endif
+       call do_mono_excitation(key_tmp,j,s,s2,i_ok)
+       if(i_ok .ne.1)then
+        print*, 'pb !!'
+        stop
+       endif
+       call i_H_j(ref_bitmask, key_tmp, N_int,hij)
+       delta_e = Fock_matrix_diag_mo(i) + Fock_matrix_diag_mo(j) - Fock_matrix_diag_mo(r) - Fock_matrix_diag_mo(s)
+       coef_ijrs = hij/delta_e
+       do k = 1, n_singles
+        l = index_singles(k) 
+        call i_H_j(dets_in(1,1,l), key_tmp, N_int,hij)
+        diag_H_elements(l) += coef_ijrs * hij
+       enddo
+     !endif
+     enddo
+    enddo
+   enddo
+  enddo
+  c_ref = 1.d0/u_in(index_hf,1)
+  do k = 1, n_singles
+   l = index_singles(k)
+   diag_H_elements(0) -= diag_H_elements(l)
+  enddo
+! do k = 1, n_doubles
+!  l = index_doubles(k)
+!  diag_H_elements(0) += diag_H_elements(l)
+! enddo
+
+
+end
+  
+
+subroutine dressing_1h1p_full(dets_in,u_in,H_matrix,dim_in,sze,N_st,Nint,convergence)
+  use bitmasks
+  implicit none
+  BEGIN_DOC
+  ! CISD+SC2 method              :: take off all the disconnected terms of a ROHF+1h1p (selected or not)
+  !
+  ! 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
+  integer, intent(in)            :: dim_in, sze, N_st, Nint
+  integer(bit_kind), intent(in)  :: dets_in(Nint,2,sze)
+  double precision, intent(in) :: u_in(dim_in,N_st)
+  double precision, intent(inout)  :: H_matrix(sze,sze)
+  double precision, intent(in)   :: convergence
+  
+  integer :: i,j,k,l
+  integer :: n_singles
+  integer :: index_singles(sze),hole_particles_singles(sze,3)
+  integer :: n_doubles
+  integer :: index_doubles(sze),hole_particles_doubles(sze,2)
+  integer :: index_hf
+  double precision :: e_corr_singles(mo_tot_num,2)
+  double precision :: e_corr_doubles(mo_tot_num)
+  double precision :: e_corr_singles_total(2)
+  double precision :: e_corr_doubles_1h1p
+
+  integer :: exc(0:2,2,2),degree
+  integer :: h1,h2,p1,p2,s1,s2
+  integer :: other_spin(2)
+  double precision :: phase
+  integer(bit_kind) :: key_tmp(N_int,2)
+  integer :: i_ok
+  double precision :: phase_single_double,phase_double_hf,get_mo_bielec_integral
+  double precision :: hij,c_ref,contrib
+  integer :: iorb
+
+  other_spin(1) = 2
+  other_spin(2) = 1
+
+  n_singles = 0
+  n_doubles = 0
+  do i = 1,sze
+   call get_excitation(ref_bitmask,dets_in(1,1,i),exc,degree,phase,N_int)
+   call decode_exc(exc,degree,h1,p1,h2,p2,s1,s2)
+   if(degree == 0)then
+    index_hf = i
+   else if (degree == 1)then
+    n_singles +=1
+    index_singles(n_singles) = i
+    ! h1 = inactive orbital of the hole
+    hole_particles_singles(n_singles,1) = h1
+    ! p1 = virtual orbital of the particle
+    hole_particles_singles(n_singles,2) = p1
+    ! s1 = spin of the electron excited
+    hole_particles_singles(n_singles,3) = s1
+   else if (degree == 2)then
+    n_doubles +=1
+    index_doubles(n_doubles) = i
+    ! h1 = inactive orbital of the hole (beta of course)
+    hole_particles_doubles(n_doubles,1) = h1
+    ! p1 = virtual orbital of the particle (alpha of course)
+    hole_particles_doubles(n_doubles,2) = p2
+   else 
+    print*,'PB !! found out other thing than a single or double'
+    print*,'stopping ..'
+    stop
+   endif
+  enddo
+  double precision, allocatable :: dressing_H_mat_elem(:)
+  allocate(dressing_H_mat_elem(N_det))
+  logical :: lmct
+  dressing_H_mat_elem = 0.d0
+  call dress_diag_elem_2h2p(dressing_H_mat_elem,N_det)
+  lmct = .False.
+  call dress_diag_elem_2h1p(dressing_H_mat_elem,N_det,lmct,1000)
+  lmct = .true.
+  call dress_diag_elem_1h2p(dressing_H_mat_elem,N_det,lmct,1000)
+  do i = 1, N_det
+   H_matrix(i,i) += dressing_H_mat_elem(i)
+  enddo
+
+  e_corr_singles = 0.d0
+  e_corr_doubles = 0.d0
+  e_corr_singles_total = 0.d0
+  e_corr_doubles_1h1p = 0.d0
+  c_ref = 1.d0/u_in(index_hf,1)
+  print*,'c_ref = ',c_ref
+  do i = 1,sze
+   call get_excitation(ref_bitmask,dets_in(1,1,i),exc,degree,phase,N_int)
+   call decode_exc(exc,degree,h1,p1,h2,p2,s1,s2)
+   call i_H_j(ref_bitmask,dets_in(1,1,i),N_int,hij)
+   contrib = hij * u_in(i,1) * c_ref
+   if (degree == 1)then
+    e_corr_singles(h1,s1) += contrib
+    e_corr_singles(p1,s1) += contrib
+    e_corr_singles_total(s1)+= contrib
+   else if (degree == 2)then
+    e_corr_doubles_1h1p += contrib
+    e_corr_doubles(h1) += contrib
+    e_corr_doubles(p2) += contrib
+   endif
+  enddo
+  print*,'e_corr_singles alpha = ',e_corr_singles_total(1)
+  print*,'e_corr_singles beta  = ',e_corr_singles_total(2)
+  print*,'e_corr_doubles_1h1p  = ',e_corr_doubles_1h1p
+ 
+  
+  ! repeat all the correlation energy on the singles
+! do i = 1,n_singles
+!  ! you can repeat all the correlation energy of the single excitation of the other spin
+!  H_matrix(index_singles(i),index_singles(i)) += e_corr_singles_total(other_spin(hole_particles_singles(i,3)))
+
+!  ! you can repeat all the correlation energy of the single excitation of the same spin
+!  do j = 1, n_inact_orb
+!   iorb = list_inact(j)
+!   ! except the one of the hole
+!   if(iorb == hole_particles_singles(i,1))cycle
+!   ! ispin = hole_particles_singles(i,3)
+!   H_matrix(index_singles(i),index_singles(i)) += e_corr_singles(iorb,hole_particles_singles(i,3))
+!  enddo
+!  ! also exclude all the energy coming from the virtual orbital
+!  H_matrix(index_singles(i),index_singles(i)) -= e_corr_singles(hole_particles_singles(i,2),hole_particles_singles(i,3))
+!
+!  ! If it is a single excitation alpha, you can repeat : 
+!  !  +) all the double excitation 1h1p, appart the part involving the virtual orbital "r"
+!  ! If it is a single excitation alpha, you can repeat : 
+!  !  +) all the double excitation 1h1p, appart the part involving the inactive orbital "i"
+!  H_matrix(index_singles(i),index_singles(i)) += e_corr_doubles_1h1p
+!  if(hole_particles_singles(i,3) == 1)then  ! alpha single excitation
+!   H_matrix(index_singles(i),index_singles(i)) -= e_corr_doubles(hole_particles_singles(i,2))
+!  else  ! beta single exctitation 
+!   H_matrix(index_singles(i),index_singles(i)) -= e_corr_doubles(hole_particles_singles(i,1))
+!  endif
+! enddo
+
+! ! repeat all the correlation energy on the doubles
+! ! as all the doubles involve the active space, you cannot repeat any of them one on another
+! do i = 1, n_doubles
+!  ! on a given double, you can repeat all the correlation energy of the singles alpha 
+!  do j = 1, n_inact_orb
+!   iorb = list_inact(j)
+!   ! ispin = hole_particles_singles(i,3)
+!   H_matrix(index_doubles(i),index_doubles(i)) += e_corr_singles(iorb,1)
+!  enddo
+!  ! except the part involving the virtual orbital "hole_particles_doubles(i,2)"
+!  H_matrix(index_doubles(i),index_doubles(i)) -= e_corr_singles(hole_particles_doubles(i,2),1)
+!  ! on a given double, you can repeat all the correlation energy of the singles beta
+!  do j = 1, n_inact_orb
+!   iorb = list_inact(j)
+!   ! except the one of the hole
+!   if(iorb == hole_particles_doubles(i,1))cycle
+!   ! ispin = hole_particles_singles(i,3)
+!   H_matrix(index_doubles(i),index_doubles(i)) += e_corr_singles(iorb,2)
+!  enddo
+! enddo
+
+
+  ! Taking into account the connected part of the 2h2p on the HF determinant 
+  ! 1/2 \sum_{ir,js} c_{ir}^{sigma} c_{js}^{sigma}
+  
+! H_matrix(index_hf) += total_corr_e_2h2p
+  print*,'H_matrix(index_hf,index_hf) = ',H_matrix(index_hf,index_hf)
+  do i = 1, n_singles
+   ! start on the single excitation "|i>"
+   h1 = hole_particles_singles(i,1)
+   p1 = hole_particles_singles(i,2)
+   print*,'i = ',i
+   do j = i+1, n_singles
+    do k = 1, N_int
+     key_tmp(k,1) = dets_in(k,1,index_singles(i))
+     key_tmp(k,2) = dets_in(k,2,index_singles(i))
+    enddo
+    h2 = hole_particles_singles(j,1)
+    p2 = hole_particles_singles(j,2)
+    call do_mono_excitation(key_tmp,h2,p2,hole_particles_singles(j,3),i_ok)    
+    ! apply the excitation operator from the single excitation "|j>"
+    if(i_ok .ne. 1)cycle
+    double precision :: H_array(sze),diag_H_mat_elem,hjj
+    do k = 1, sze
+     call get_excitation_degree(dets_in(1,1,k),key_tmp,degree,N_int)
+     H_array(k) = 0.d0
+     if(degree > 2)cycle
+     call i_H_j(dets_in(1,1,k),key_tmp,N_int,hij)
+     H_array(k) = hij
+    enddo
+    hjj = 1.d0/(ref_bitmask_energy - diag_H_mat_elem(key_tmp,N_int))
+!   contrib_e2 = 0.5d0 * (delta_e + dsqrt(delta_e * delta_e + 4.d0 * hij * hij))
+    do l = 2, sze
+!    pause
+     H_matrix(l,l) += H_array(l) * H_array(l) * hjj
+!    H_matrix(1,l) += H_array(1) * H_array(l) * hjj
+!    H_matrix(l,1) += H_array(1) * H_array(l) * hjj
+    enddo
+   enddo
+  enddo
+  print*,'H_matrix(index_hf,index_hf) = ',H_matrix(index_hf,index_hf)
+
+end
+
+subroutine SC2_1h1p_full(dets_in,u_in,energies,H_matrix,dim_in,sze,N_st,Nint,convergence)
+  use bitmasks
+  implicit none
+  BEGIN_DOC
+  ! CISD+SC2 method              :: take off all the disconnected terms of a CISD (selected or not)
+  !
+  ! 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
+  integer, intent(in)            :: dim_in, sze, N_st, Nint
+  integer(bit_kind), intent(in)  :: dets_in(Nint,2,sze)
+  double precision, intent(inout) :: u_in(dim_in,N_st)
+  double precision, intent(out)  :: energies(N_st)
+  double precision, intent(out)  :: H_matrix(sze,sze)
+  double precision, intent(in)   :: convergence
+  integer :: i,j,iter
+  print*,'sze = ',sze
+  H_matrix = 0.d0
+  do iter = 1, 1
+!   if(sze<=N_det_max_jacobi)then
+      double precision, allocatable  :: eigenvectors(:,:), eigenvalues(:),H_matrix_tmp(:,:)
+      allocate (H_matrix_tmp(size(H_matrix_all_dets,1),sze),eigenvalues(sze),eigenvectors(size(H_matrix_all_dets,1),sze))
+      H_matrix_tmp = 0.d0
+      call dressing_1h1p_full(dets_in,u_in,H_matrix_tmp,dim_in,sze,N_st,Nint,convergence)
+      do j=1,sze
+        do i=1,sze
+          H_matrix_tmp(i,j) += H_matrix_all_dets(i,j)
+        enddo
+      enddo
+      print*,'passed the dressing'
+      call lapack_diag(eigenvalues,eigenvectors,                     &
+          H_matrix_tmp,size(H_matrix_all_dets,1),sze)
+      do j=1,min(N_states_diag,sze)
+        do i=1,sze
+          u_in(i,j) = eigenvectors(i,j)
+        enddo
+        energies(j) = eigenvalues(j)
+      enddo
+      deallocate (H_matrix_tmp, eigenvalues, eigenvectors)
+!   else
+!     call davidson_diag_hjj(dets_in,u_in,diag_H_elements,energies,dim_in,sze,N_st,Nint,output_determinants)
+!   endif
+    print*,'E = ',energies(1) + nuclear_repulsion
+
+  enddo
+
+  
+end
+
+
+subroutine SC2_1h1p(dets_in,u_in,energies,diag_H_elements,dim_in,sze,N_st,Nint,convergence)
+  use bitmasks
+  implicit none
+  BEGIN_DOC
+  ! CISD+SC2 method              :: take off all the disconnected terms of a CISD (selected or not)
+  !
+  ! 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
+  integer, intent(in)            :: dim_in, sze, N_st, Nint
+  integer(bit_kind), intent(in)  :: dets_in(Nint,2,sze)
+  double precision, intent(inout) :: u_in(dim_in,N_st)
+  double precision, intent(out)  :: energies(N_st)
+  double precision, intent(out)  :: diag_H_elements(dim_in)
+  double precision               :: extra_diag_H_elements(dim_in)
+  double precision, intent(in)   :: convergence
+  integer :: i,j,iter
+  DIAG_H_ELEMENTS = 0.d0
+  do iter = 1, 1
+!  call dressing_1h1p(dets_in,u_in,diag_H_elements,dim_in,sze,N_st,Nint,convergence)
+   call dressing_1h1p_by_2h2p(dets_in,u_in,extra_diag_H_elements,dim_in,sze,N_st,Nint,convergence)
+!   if(sze<=N_det_max_jacobi)then
+      double precision, allocatable  :: eigenvectors(:,:), eigenvalues(:),H_matrix_tmp(:,:)
+      allocate (H_matrix_tmp(size(H_matrix_all_dets,1),sze),eigenvalues(sze),eigenvectors(size(H_matrix_all_dets,1),sze))
+      do j=1,sze
+        do i=1,sze
+          H_matrix_tmp(i,j) = H_matrix_all_dets(i,j)
+        enddo
+      enddo
+      H_matrix_tmp(1,1) += extra_diag_H_elements(1)
+      do i = 2,sze
+        H_matrix_tmp(1,i) += extra_diag_H_elements(i)
+        H_matrix_tmp(i,1) += extra_diag_H_elements(i)
+      enddo
+     !do i = 1,sze
+     !  H_matrix_tmp(i,i) = diag_H_elements(i)
+     !enddo
+      call lapack_diag(eigenvalues,eigenvectors,                     &
+          H_matrix_tmp,size(H_matrix_all_dets,1),sze)
+      do j=1,min(N_states_diag,sze)
+        do i=1,sze
+          u_in(i,j) = eigenvectors(i,j)
+        enddo
+        energies(j) = eigenvalues(j)
+      enddo
+      deallocate (H_matrix_tmp, eigenvalues, eigenvectors)
+!   else
+!     call davidson_diag_hjj(dets_in,u_in,diag_H_elements,energies,dim_in,sze,N_st,Nint,output_determinants)
+!   endif
+    print*,'E = ',energies(1) + nuclear_repulsion
+
+  enddo
+
+  
+end
+
+
+subroutine density_matrix_1h1p(dets_in,u_in,density_matrix_alpha,density_matrix_beta,norm,dim_in,sze,N_st,Nint)
+  use bitmasks
+  implicit none
+  BEGIN_DOC
+  ! CISD+SC2 method              :: take off all the disconnected terms of a ROHF+1h1p (selected or not)
+  !
+  ! 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
+  integer, intent(in)            :: dim_in, sze, N_st, Nint
+  integer(bit_kind), intent(in)  :: dets_in(Nint,2,sze)
+  double precision, intent(inout) :: u_in(dim_in,N_st)
+  double precision, intent(inout)  :: density_matrix_alpha(mo_tot_num_align,mo_tot_num)
+  double precision, intent(inout)  :: density_matrix_beta(mo_tot_num_align,mo_tot_num)
+  double precision, intent(inout)  :: norm
+  
+  integer :: i,j,k,l
+  integer :: n_singles
+  integer :: index_singles(sze),hole_particles_singles(sze,3)
+  integer :: n_doubles
+  integer :: index_doubles(sze),hole_particles_doubles(sze,2)
+  integer :: index_hf
+
+  integer :: exc(0:2,2,2),degree
+  integer :: h1,h2,p1,p2,s1,s2
+  integer :: other_spin(2)
+  double precision :: phase
+  integer(bit_kind) :: key_tmp(N_int,2)
+  integer :: i_ok
+  double precision :: phase_single_double,phase_double_hf,get_mo_bielec_integral
+  double precision :: hij,c_ref,contrib
+  integer :: iorb
+
+  other_spin(1) = 2
+  other_spin(2) = 1
+
+  n_singles = 0
+  n_doubles = 0
+  norm = 0.d0
+  do i = 1,sze
+   call get_excitation(ref_bitmask,dets_in(1,1,i),exc,degree,phase,N_int)
+   call decode_exc(exc,degree,h1,p1,h2,p2,s1,s2)
+   norm += u_in(i,1)* u_in(i,1)
+   if(degree == 0)then
+    index_hf = i
+    c_ref = 1.d0/psi_coef(i,1)
+   else if (degree == 1)then
+    n_singles +=1
+    index_singles(n_singles) = i
+    ! h1 = inactive orbital of the hole
+    hole_particles_singles(n_singles,1) = h1
+    ! p1 = virtual orbital of the particle
+    hole_particles_singles(n_singles,2) = p1
+    ! s1 = spin of the electron excited
+    hole_particles_singles(n_singles,3) = s1
+   else if (degree == 2)then
+    n_doubles +=1
+    index_doubles(n_doubles) = i
+    ! h1 = inactive orbital of the hole (beta of course)
+    hole_particles_doubles(n_doubles,1) = h1
+    ! p1 = virtual orbital of the particle (alpha of course)
+    hole_particles_doubles(n_doubles,2) = p2
+   else 
+    print*,'PB !! found out other thing than a single or double'
+    print*,'stopping ..'
+    stop
+   endif
+  enddo
+  print*,'norm = ',norm
+
+  ! Taking into account the connected part of the 2h2p on the HF determinant 
+  ! 1/2 \sum_{ir,js} c_{ir}^{sigma} c_{js}^{sigma}
+  
+  do i = 1, n_singles
+   ! start on the single excitation "|i>"
+   h1 = hole_particles_singles(i,1)
+   p1 = hole_particles_singles(i,2)
+   do j = 1, n_singles
+    do k = 1, N_int
+     key_tmp(k,1) = dets_in(k,1,index_singles(i))
+     key_tmp(k,2) = dets_in(k,2,index_singles(i))
+    enddo
+    h2 = hole_particles_singles(j,1)
+    p2 = hole_particles_singles(j,2)
+    call do_mono_excitation(key_tmp,h2,p2,hole_particles_singles(j,3),i_ok)    
+    ! apply the excitation operator from the single excitation "|j>"
+    if(i_ok .ne. 1)cycle
+    double precision :: coef_ijrs,phase_other_single_ref
+    integer                        :: occ(N_int*bit_kind_size,2),n_occ(2)
+    call get_excitation(key_tmp,dets_in(1,1,index_singles(i)),exc,degree,phase_single_double,N_int)
+    call get_excitation(ref_bitmask,dets_in(1,1,index_singles(j)),exc,degree,phase_other_single_ref,N_int)
+    call get_excitation(key_tmp,dets_in(1,1,index_singles(j)),exc,degree,phase_other_single_ref,N_int)
+    coef_ijrs = u_in(index_singles(i),1) * u_in(index_singles(j),1) * c_ref * c_ref & 
+                                * phase_single_double * phase_other_single_ref
+    call bitstring_to_list_ab(key_tmp, occ, n_occ, N_int)
+    do k=1,elec_alpha_num
+      l = occ(k,1)
+      density_matrix_alpha(l,l) += coef_ijrs*coef_ijrs
+    enddo
+    do k=1,elec_beta_num
+      l = occ(k,1)
+      density_matrix_beta(l,l) += coef_ijrs*coef_ijrs
+    enddo
+    norm += coef_ijrs* coef_ijrs
+    if(hole_particles_singles(j,3) == 1)then ! single alpha
+     density_matrix_alpha(h2,p2) += coef_ijrs * phase_single_double * u_in(index_singles(i),1) * c_ref
+     density_matrix_alpha(p2,h2) += coef_ijrs * phase_single_double * u_in(index_singles(i),1) * c_ref
+    else
+     density_matrix_beta(h2,p2) += coef_ijrs * phase_single_double * u_in(index_singles(i),1) * c_ref
+     density_matrix_beta(p2,h2) += coef_ijrs * phase_single_double * u_in(index_singles(i),1) * c_ref
+    endif
+   enddo
+  enddo
+
+
+  do i = 1, n_doubles
+   ! start on the double excitation "|i>"
+   h1 = hole_particles_doubles(i,1)
+   p1 = hole_particles_doubles(i,2)
+   do j = 1, n_singles
+    do k = 1, N_int
+     key_tmp(k,1) = dets_in(k,1,index_doubles(i))
+     key_tmp(k,2) = dets_in(k,2,index_doubles(i))
+    enddo
+    h2 = hole_particles_singles(j,1)
+    p2 = hole_particles_singles(j,2)
+    call do_mono_excitation(key_tmp,h2,p2,hole_particles_singles(j,3),i_ok)    
+    ! apply the excitation operator from the single excitation "|j>"
+    if(i_ok .ne. 1)cycle
+    double precision :: coef_ijrs_kv,phase_double_triple
+    call get_excitation(key_tmp,dets_in(1,1,index_singles(i)),exc,degree,phase_double_triple,N_int)
+    call get_excitation(ref_bitmask,dets_in(1,1,index_singles(j)),exc,degree,phase_other_single_ref,N_int)
+    call get_excitation(key_tmp,dets_in(1,1,index_singles(j)),exc,degree,phase_other_single_ref,N_int)
+    coef_ijrs_kv = u_in(index_doubles(i),1) * u_in(index_singles(j),1) * c_ref * c_ref & 
+                                * phase_double_triple * phase_other_single_ref
+    call bitstring_to_list_ab(key_tmp, occ, n_occ, N_int)
+    do k=1,elec_alpha_num
+      l = occ(k,1)
+      density_matrix_alpha(l,l) += coef_ijrs_kv*coef_ijrs_kv
+    enddo
+    do k=1,elec_beta_num
+      l = occ(k,1)
+      density_matrix_beta(l,l) += coef_ijrs_kv*coef_ijrs_kv
+    enddo
+    norm += coef_ijrs_kv* coef_ijrs_kv
+    if(hole_particles_singles(j,3) == 1)then ! single alpha
+     density_matrix_alpha(h2,p2) += coef_ijrs_kv * phase_double_triple * u_in(index_doubles(i),1) * c_ref
+     density_matrix_alpha(p2,h2) += coef_ijrs_kv * phase_double_triple * u_in(index_doubles(i),1) * c_ref
+    else
+     density_matrix_beta(h2,p2) += coef_ijrs_kv * phase_double_triple * u_in(index_doubles(i),1) * c_ref
+     density_matrix_beta(p2,h2) += coef_ijrs_kv * phase_double_triple * u_in(index_doubles(i),1) * c_ref
+    endif
+   enddo
+  enddo
+
+
+
+
+  print*,'norm = ',norm
+  norm = 1.d0/norm
+  do i = 1, mo_tot_num
+   do j = 1, mo_tot_num
+    density_matrix_alpha(i,j) *= norm
+    density_matrix_beta(i,j) *= norm
+   enddo
+  enddo
+  coef_ijrs = 0.d0
+  do i = 1, mo_tot_num
+   coef_ijrs += density_matrix_beta(i,i) + density_matrix_beta(i,i)
+  enddo
+  print*,'accu = ',coef_ijrs
+
+end
+

plugins/FOBOCI/all_singles.irp.f

@@ -1,13 +1,25 @@
-subroutine all_single
+subroutine all_single(e_pt2)
   implicit none
+  double precision, intent(in)   :: e_pt2
   integer                        :: i,k
   double precision, allocatable  :: pt2(:), norm_pert(:), H_pert_diag(:)
   integer                        :: N_st, degree
   double precision,allocatable :: E_before(:)
   N_st = N_states
   allocate (pt2(N_st), norm_pert(N_st),H_pert_diag(N_st),E_before(N_st))
-  selection_criterion = 0.d0
-  soft_touch selection_criterion
+  if(.not.selected_fobo_ci)then
+   selection_criterion = 0.d0
+   soft_touch selection_criterion
+  else 
+   selection_criterion =  0.1d0 
+   selection_criterion_factor = 0.01d0
+   selection_criterion_min = selection_criterion
+   soft_touch selection_criterion
+  endif
+  print*, 'e_pt2 = ',e_pt2
+  pt2_max = 0.15d0 * e_pt2
+  soft_touch pt2_max
+  print*, 'pt2_max = ',pt2_max
   threshold_davidson = 1.d-9
   soft_touch threshold_davidson davidson_criterion
   i = 0
@@ -17,6 +29,8 @@ subroutine all_single
   print*,'pt2_max = ',pt2_max
   print*,'N_det_generators = ',N_det_generators
   pt2=-1.d0
+  print*, 'ref_bitmask_energy   =',ref_bitmask_energy
+  print*, 'CI_expectation_value =',psi_energy(1)
   E_before = ref_bitmask_energy
  
   print*,'Initial Step '
@@ -29,7 +43,7 @@ subroutine all_single
    print*,'S^2      = ',CI_eigenvectors_s2(i)
   enddo
   n_det_max = 100000
-  do while (N_det < n_det_max.and.maxval(abs(pt2(1:N_st))) > pt2_max)
+  do while (N_det < n_det_max.and.maxval(abs(pt2(1:N_st))) > dabs(pt2_max))
     i += 1
     print*,'-----------------------'
     print*,'i = ',i
@@ -39,6 +53,8 @@ subroutine all_single
     print*,'E        = ',CI_energy(1)
     print*,'pt2      = ',pt2(1)
     print*,'E+PT2    = ',E_before + pt2(1)
+    print*,'pt2_max  = ',pt2_max
+    print*, maxval(abs(pt2(1:N_st))) > dabs(pt2_max)
     if(N_states_diag.gt.1)then
      print*,'Variational Energy difference'
      do i = 2, N_st
@@ -53,7 +69,6 @@ subroutine all_single
     endif
     E_before = CI_energy
     !!!!!!!!!!!!!!!!!!!!!!!!!!! DOING ONLY ONE ITERATION OF SELECTION AS THE SELECTION CRITERION IS SET TO ZERO
-    exit
   enddo
 ! threshold_davidson = 1.d-8
 ! soft_touch threshold_davidson davidson_criterion

plugins/FOBOCI/corr_energy_2h2p.irp.f

@@ -15,7 +15,7 @@
  integer(bit_kind) :: key_tmp(N_int,2)
  integer :: i,j,k,l
  integer :: i_hole,j_hole,k_part,l_part
- double precision :: get_mo_bielec_integral_schwartz,hij,delta_e,exc,contrib
+ double precision :: get_mo_bielec_integral,hij,delta_e,exc,contrib
  double precision :: diag_H_mat_elem
  integer :: i_ok,ispin
  ! Alpha - Beta correlation energy
@@ -46,7 +46,7 @@
      if(i_ok .ne.1)cycle
      delta_e  = (ref_bitmask_energy - diag_H_mat_elem(key_tmp,N_int))
 
-     hij = get_mo_bielec_integral_schwartz(i_hole,j_hole,k_part,l_part,mo_integrals_map)
+     hij = get_mo_bielec_integral(i_hole,j_hole,k_part,l_part,mo_integrals_map)
      contrib = hij*hij/delta_e
      total_corr_e_2h2p += contrib
      ! Single orbital contribution
@@ -81,8 +81,8 @@
     k_part = list_virt(k)
     do l = k+1,n_virt_orb
      l_part = list_virt(l)
-     hij = get_mo_bielec_integral_schwartz(i_hole,j_hole,k_part,l_part,mo_integrals_map)
-     exc = get_mo_bielec_integral_schwartz(i_hole,j_hole,l_part,k_part,mo_integrals_map)
+     hij = get_mo_bielec_integral(i_hole,j_hole,k_part,l_part,mo_integrals_map)
+     exc = get_mo_bielec_integral(i_hole,j_hole,l_part,k_part,mo_integrals_map)
      key_tmp = ref_bitmask
      ispin = 1
      call do_mono_excitation(key_tmp,i_hole,k_part,ispin,i_ok)
@@ -114,8 +114,8 @@
     k_part = list_virt(k)
     do l = k+1,n_virt_orb
      l_part = list_virt(l)
-     hij = get_mo_bielec_integral_schwartz(i_hole,j_hole,k_part,l_part,mo_integrals_map)
-     exc = get_mo_bielec_integral_schwartz(i_hole,j_hole,l_part,k_part,mo_integrals_map)
+     hij = get_mo_bielec_integral(i_hole,j_hole,k_part,l_part,mo_integrals_map)
+     exc = get_mo_bielec_integral(i_hole,j_hole,l_part,k_part,mo_integrals_map)
      key_tmp = ref_bitmask
      ispin = 2
      call do_mono_excitation(key_tmp,i_hole,k_part,ispin,i_ok)
@@ -161,7 +161,7 @@ END_PROVIDER
  integer(bit_kind) :: key_tmp(N_int,2)
  integer :: i,j,k,l
  integer :: i_hole,j_hole,k_part,l_part
- double precision :: get_mo_bielec_integral_schwartz,hij,delta_e,exc,contrib
+ double precision :: get_mo_bielec_integral,hij,delta_e,exc,contrib
  double precision :: diag_H_mat_elem
  integer :: i_ok,ispin
  ! Alpha - Beta correlation energy
@@ -191,7 +191,7 @@ END_PROVIDER
      if(i_ok .ne.1)cycle
      delta_e  = -(ref_bitmask_energy - diag_H_mat_elem(key_tmp,N_int))
 
-     hij = get_mo_bielec_integral_schwartz(i_hole,j_hole,k_part,l_part,mo_integrals_map)
+     hij = get_mo_bielec_integral(i_hole,j_hole,k_part,l_part,mo_integrals_map)
      contrib = 0.5d0 * (delta_e - dsqrt(delta_e * delta_e + 4.d0 * hij*hij))
      total_corr_e_2h1p += contrib
      corr_energy_2h1p_ab_bb_per_2_orb(i_hole,j_hole) += contrib
@@ -211,8 +211,8 @@ END_PROVIDER
     k_part = list_act(k)
     do l = 1,n_virt_orb
      l_part = list_virt(l)
-     hij = get_mo_bielec_integral_schwartz(i_hole,j_hole,k_part,l_part,mo_integrals_map)
-     exc = get_mo_bielec_integral_schwartz(i_hole,j_hole,l_part,k_part,mo_integrals_map)
+     hij = get_mo_bielec_integral(i_hole,j_hole,k_part,l_part,mo_integrals_map)
+     exc = get_mo_bielec_integral(i_hole,j_hole,l_part,k_part,mo_integrals_map)
      key_tmp = ref_bitmask
      ispin = 1
      call do_mono_excitation(key_tmp,i_hole,k_part,ispin,i_ok)
@@ -241,8 +241,8 @@ END_PROVIDER
     k_part = list_act(k)
     do l = 1,n_virt_orb
      l_part = list_virt(l)
-     hij = get_mo_bielec_integral_schwartz(i_hole,j_hole,k_part,l_part,mo_integrals_map)
-     exc = get_mo_bielec_integral_schwartz(i_hole,j_hole,l_part,k_part,mo_integrals_map)
+     hij = get_mo_bielec_integral(i_hole,j_hole,k_part,l_part,mo_integrals_map)
+     exc = get_mo_bielec_integral(i_hole,j_hole,l_part,k_part,mo_integrals_map)
      key_tmp = ref_bitmask
      ispin = 2
      call do_mono_excitation(key_tmp,i_hole,k_part,ispin,i_ok)
@@ -276,7 +276,7 @@ END_PROVIDER
  integer(bit_kind) :: key_tmp(N_int,2)
  integer :: i,j,k,l
  integer :: i_hole,j_hole,k_part,l_part
- double precision :: get_mo_bielec_integral_schwartz,hij,delta_e,exc,contrib
+ double precision :: get_mo_bielec_integral,hij,delta_e,exc,contrib
  double precision :: diag_H_mat_elem
  integer :: i_ok,ispin
  ! Alpha - Beta correlation energy
@@ -302,7 +302,7 @@ END_PROVIDER
      if(i_ok .ne.1)cycle
      delta_e  = -(ref_bitmask_energy - diag_H_mat_elem(key_tmp,N_int))
 
-     hij = get_mo_bielec_integral_schwartz(i_hole,j_hole,k_part,l_part,mo_integrals_map)
+     hij = get_mo_bielec_integral(i_hole,j_hole,k_part,l_part,mo_integrals_map)
      contrib = 0.5d0 * (delta_e - dsqrt(delta_e * delta_e + 4.d0 * hij*hij))
 
      total_corr_e_1h2p += contrib
@@ -324,8 +324,8 @@ END_PROVIDER
     k_part = list_act(k)
     do l = i+1,n_virt_orb
      l_part = list_virt(l)
-     hij = get_mo_bielec_integral_schwartz(i_hole,j_hole,k_part,l_part,mo_integrals_map)
-     exc = get_mo_bielec_integral_schwartz(i_hole,j_hole,l_part,k_part,mo_integrals_map)
+     hij = get_mo_bielec_integral(i_hole,j_hole,k_part,l_part,mo_integrals_map)
+     exc = get_mo_bielec_integral(i_hole,j_hole,l_part,k_part,mo_integrals_map)
 
      key_tmp = ref_bitmask
      ispin = 1
@@ -356,8 +356,8 @@ END_PROVIDER
     k_part = list_act(k)
     do l = i+1,n_virt_orb
      l_part = list_virt(l)
-     hij = get_mo_bielec_integral_schwartz(i_hole,j_hole,k_part,l_part,mo_integrals_map)
-     exc = get_mo_bielec_integral_schwartz(i_hole,j_hole,l_part,k_part,mo_integrals_map)
+     hij = get_mo_bielec_integral(i_hole,j_hole,k_part,l_part,mo_integrals_map)
+     exc = get_mo_bielec_integral(i_hole,j_hole,l_part,k_part,mo_integrals_map)
 
      key_tmp = ref_bitmask
      ispin = 2
@@ -388,7 +388,7 @@ END_PROVIDER
  integer(bit_kind) :: key_tmp(N_int,2)
  integer :: i,j,k,l
  integer :: i_hole,j_hole,k_part,l_part
- double precision :: get_mo_bielec_integral_schwartz,hij,delta_e,exc,contrib
+ double precision :: get_mo_bielec_integral,hij,delta_e,exc,contrib
  double precision :: diag_H_mat_elem
  integer :: i_ok,ispin
  ! Alpha - Beta correlation energy
@@ -412,7 +412,7 @@ END_PROVIDER
      if(i_ok .ne.1)cycle
      delta_e  = -(ref_bitmask_energy - diag_H_mat_elem(key_tmp,N_int))
 
-     hij = get_mo_bielec_integral_schwartz(i_hole,j_hole,k_part,l_part,mo_integrals_map)
+     hij = get_mo_bielec_integral(i_hole,j_hole,k_part,l_part,mo_integrals_map)
      contrib = 0.5d0 * (delta_e - dsqrt(delta_e * delta_e + 4.d0 * hij*hij))
 
      total_corr_e_1h1p_spin_flip += contrib

plugins/FOBOCI/create_1h_or_1p.irp.f

@@ -68,7 +68,9 @@ subroutine create_restart_and_1h(i_hole)
 
   SOFT_TOUCH N_det psi_det psi_coef
   logical :: found_duplicates
+  if(n_act_orb.gt.1)then
   call remove_duplicates_in_psi_det(found_duplicates)
+  endif
 end
 
 subroutine create_restart_and_1p(i_particle)
@@ -213,6 +215,8 @@ subroutine create_restart_1h_1p(i_hole,i_part)
 
   SOFT_TOUCH N_det psi_det psi_coef
   logical :: found_duplicates
+  if(n_act_orb.gt.1)then
   call remove_duplicates_in_psi_det(found_duplicates)
+  endif
 
 end

plugins/FOBOCI/diag_fock_inactiv_virt.irp.f

@@ -38,7 +38,7 @@ end
 subroutine diag_inactive_virt_new_and_update_mos
  implicit none
  integer :: i,j,i_inact,j_inact,i_virt,j_virt,k,k_act
- double precision :: tmp(mo_tot_num_align,mo_tot_num),accu,get_mo_bielec_integral_schwartz
+ double precision :: tmp(mo_tot_num_align,mo_tot_num),accu,get_mo_bielec_integral
  character*(64) :: label
  tmp = 0.d0
  do i = 1, mo_tot_num
@@ -52,8 +52,8 @@ subroutine diag_inactive_virt_new_and_update_mos
    accu =0.d0
    do k = 1, n_act_orb
     k_act = list_act(k)
-    accu += get_mo_bielec_integral_schwartz(i_inact,k_act,j_inact,k_act,mo_integrals_map)
-    accu -= get_mo_bielec_integral_schwartz(i_inact,k_act,k_act,j_inact,mo_integrals_map)
+    accu += get_mo_bielec_integral(i_inact,k_act,j_inact,k_act,mo_integrals_map)
+    accu -= get_mo_bielec_integral(i_inact,k_act,k_act,j_inact,mo_integrals_map)
    enddo
    tmp(i_inact,j_inact) = Fock_matrix_mo(i_inact,j_inact) + accu
    tmp(j_inact,i_inact) = Fock_matrix_mo(j_inact,i_inact) + accu
@@ -67,7 +67,7 @@ subroutine diag_inactive_virt_new_and_update_mos
    accu =0.d0
    do k = 1, n_act_orb
     k_act = list_act(k)
-    accu += get_mo_bielec_integral_schwartz(i_virt,k_act,j_virt,k_act,mo_integrals_map)
+    accu += get_mo_bielec_integral(i_virt,k_act,j_virt,k_act,mo_integrals_map)
    enddo
    tmp(i_virt,j_virt) = Fock_matrix_mo(i_virt,j_virt) - accu
    tmp(j_virt,i_virt) = Fock_matrix_mo(j_virt,i_virt) - accu

plugins/FOBOCI/dress_simple.irp.f

@@ -58,24 +58,7 @@ subroutine standard_dress(delta_ij_generators_,size_buffer,Ndet_generators,i_gen
        call i_h_j(det_buffer(1,1,i),det_buffer(1,1,i),Nint,haa)
        f = 1.d0/(E_ref-haa)
        
-!    if(second_order_h)then
       lambda_i = f
-!    else
-!      ! You write the new Hamiltonian matrix
-!      do k = 1, Ndet_generators
-!       H_matrix_tmp(k,Ndet_generators+1) = H_array(k)
-!       H_matrix_tmp(Ndet_generators+1,k) = H_array(k)
-!      enddo
-!      H_matrix_tmp(Ndet_generators+1,Ndet_generators+1) = haa
-!      ! Then diagonalize it
-!      call lapack_diag(eigenvalues,eigenvectors,H_matrix_tmp,Ndet_generators+1,Ndet_generators+1)
-!      ! Then you extract the effective denominator
-!      accu = 0.d0
-!      do k = 1, Ndet_generators
-!       accu += eigenvectors(k,1) * H_array(k)
-!      enddo
-!      lambda_i = eigenvectors(Ndet_generators+1,1)/accu
-!    endif
      do k=1,idx(0)
        contrib = H_array(idx(k)) * H_array(idx(k)) * lambda_i
        delta_ij_generators_(idx(k), idx(k)) += contrib
@@ -89,20 +72,21 @@ subroutine standard_dress(delta_ij_generators_,size_buffer,Ndet_generators,i_gen
 end
 
 
-subroutine is_a_good_candidate(threshold,is_ok,verbose)
+subroutine is_a_good_candidate(threshold,is_ok,e_pt2,verbose,exit_loop,is_ok_perturbative)
  use bitmasks
  implicit none
  double precision, intent(in) :: threshold
- logical, intent(out) :: is_ok
+ double precision, intent(out):: e_pt2
+ logical, intent(out) :: is_ok,exit_loop,is_ok_perturbative
  logical, intent(in) :: verbose
  
  integer :: l,k,m
  double precision,allocatable :: dressed_H_matrix(:,:)
- double precision,allocatable :: psi_coef_diagonalized_tmp(:,:)
+ double precision, allocatable :: psi_coef_diagonalized_tmp(:,:)
  integer(bit_kind), allocatable :: psi_det_generators_input(:,:,:)
+ double precision :: hij
 
- allocate(psi_det_generators_input(N_int,2,N_det_generators),dressed_H_matrix(N_det_generators,N_det_generators))
- allocate(psi_coef_diagonalized_tmp(N_det_generators,N_states))
+ allocate(psi_det_generators_input(N_int,2,N_det_generators),dressed_H_matrix(N_det_generators,N_det_generators),psi_coef_diagonalized_tmp(N_det_generators,N_states))
  dressed_H_matrix = 0.d0
  do k = 1, N_det_generators
   do l = 1, N_int
@@ -111,9 +95,20 @@ subroutine is_a_good_candidate(threshold,is_ok,verbose)
   enddo
  enddo
 !call H_apply_dressed_pert(dressed_H_matrix,N_det_generators,psi_det_generators_input)
- call dress_H_matrix_from_psi_det_input(psi_det_generators_input,N_det_generators,is_ok,psi_coef_diagonalized_tmp, dressed_H_matrix,threshold,verbose)
- if(do_it_perturbative)then
-  if(is_ok)then
+ call dress_H_matrix_from_psi_det_input(psi_det_generators_input,N_det_generators,is_ok,psi_coef_diagonalized_tmp, dressed_H_matrix,threshold,verbose,exit_loop,is_ok_perturbative)
+!do m = 1, N_states
+! do k = 1, N_det_generators
+!  do l = 1, N_int
+!    psi_selectors(l,1,k) = psi_det_generators_input(l,1,k) 
+!    psi_selectors(l,2,k) = psi_det_generators_input(l,2,k) 
+!  enddo
+!  psi_selectors_coef(k,m) = psi_coef_diagonalized_tmp(k,m)
+! enddo
+!enddo
+!soft_touch psi_selectors psi_selectors_coef 
+!if(do_it_perturbative)then
+   print*, 'is_ok_perturbative',is_ok_perturbative
+  if(is_ok.or.is_ok_perturbative)then
    N_det = N_det_generators
    do m = 1, N_states
     do k = 1, N_det_generators
@@ -122,11 +117,19 @@ subroutine is_a_good_candidate(threshold,is_ok,verbose)
        psi_det(l,2,k) = psi_det_generators_input(l,2,k) 
      enddo
      psi_coef(k,m) = psi_coef_diagonalized_tmp(k,m)
+     print*, 'psi_coef(k,m)',psi_coef(k,m)
+    enddo
+   enddo
+   soft_touch psi_det psi_coef  N_det
+   e_pt2 = 0.d0
+   do m =1, N_det_generators
+    do l = 1, N_det_generators
+     call i_h_j(psi_det_generators_input(1,1,m),psi_det_generators_input(1,1,l),N_int,hij)  ! Fill the zeroth order H matrix
+     e_pt2 += (dressed_H_matrix(m,l) - hij)* psi_coef_diagonalized_tmp(m,1)* psi_coef_diagonalized_tmp(l,1)
     enddo
    enddo
-   touch psi_coef psi_det N_det
   endif
- endif
+!endif
  
  deallocate(psi_det_generators_input,dressed_H_matrix,psi_coef_diagonalized_tmp)
 
@@ -135,14 +138,14 @@ subroutine is_a_good_candidate(threshold,is_ok,verbose)
 
 end
 
-subroutine dress_H_matrix_from_psi_det_input(psi_det_generators_input,Ndet_generators,is_ok,psi_coef_diagonalized_tmp, dressed_H_matrix,threshold,verbose)
+subroutine dress_H_matrix_from_psi_det_input(psi_det_generators_input,Ndet_generators,is_ok,psi_coef_diagonalized_tmp, dressed_H_matrix,threshold,verbose,exit_loop,is_ok_perturbative)
  use bitmasks
  implicit none
  integer(bit_kind), intent(in) :: psi_det_generators_input(N_int,2,Ndet_generators)
  integer, intent(in) :: Ndet_generators
  double precision, intent(in) :: threshold
  logical, intent(in) :: verbose
- logical, intent(out) :: is_ok
+ logical, intent(out) :: is_ok,exit_loop,is_ok_perturbative
  double precision, intent(out) :: psi_coef_diagonalized_tmp(Ndet_generators,N_states)
  double precision, intent(inout) :: dressed_H_matrix(Ndet_generators, Ndet_generators)
 
@@ -151,6 +154,7 @@ subroutine dress_H_matrix_from_psi_det_input(psi_det_generators_input,Ndet_gener
  double precision :: eigvalues(Ndet_generators), eigvectors(Ndet_generators,Ndet_generators),hij
  double precision :: psi_coef_ref(Ndet_generators,N_states),diag_h_mat_average,diag_h_mat_no_ref_average
  logical :: is_a_ref_det(Ndet_generators)
+ exit_loop = .False.
  
  is_a_ref_det = .False.
  do i = 1, N_det_generators
@@ -191,6 +195,7 @@ subroutine dress_H_matrix_from_psi_det_input(psi_det_generators_input,Ndet_gener
   if(number_of_holes(psi_det_generators_input(1,1,i)).eq.0 .and. number_of_particles(psi_det_generators_input(1,1,i)).eq.1)then
    if(diag_h_mat_average - dressed_H_matrix(index_ref_generators_restart,index_ref_generators_restart) .gt.2.d0)then
     is_ok = .False.
+    exit_loop = .True.
     return
    endif
   endif
@@ -278,9 +283,11 @@ subroutine dress_H_matrix_from_psi_det_input(psi_det_generators_input,Ndet_gener
     do k = 1, N_states 
      accu = 0.d0
      do j =1, Ndet_generators
+      print*,'',eigvectors(j,i) , psi_coef_ref(j,k)
       accu += eigvectors(j,i) * psi_coef_ref(j,k)
      enddo
-     if(dabs(accu).ge.0.8d0)then
+     print*,'accu = ',accu
+     if(dabs(accu).ge.0.72d0)then
       i_good_state(0) +=1
       i_good_state(i_good_state(0)) = i
      endif
@@ -321,10 +328,124 @@ subroutine dress_H_matrix_from_psi_det_input(psi_det_generators_input,Ndet_gener
    exit
   endif
  enddo
+ if(.not.is_ok)then
+  is_ok_perturbative = .True.
+  do i = 1, Ndet_generators
+   if(is_a_ref_det(i))cycle
+   do k = 1, N_states
+    print*, psi_coef_diagonalized_tmp(i,k),threshold_perturbative
+    if(dabs(psi_coef_diagonalized_tmp(i,k)) .gt.threshold_perturbative)then
+     is_ok_perturbative = .False.
+     exit
+    endif
+   enddo
+   if(.not.is_ok_perturbative)then
+    exit
+   endif
+  enddo
+ endif
  if(verbose)then
-  print*,'is_ok = ',is_ok
+  print*,'is_ok              = ',is_ok
+  print*,'is_ok_perturbative = ',is_ok_perturbative
  endif
  
 
 end
 
+subroutine fill_H_apply_buffer_no_selection_first_order_coef(n_selected,det_buffer,Nint,iproc)
+  use bitmasks
+  implicit none
+  BEGIN_DOC
+  !  Fill the H_apply buffer with determiants for CISD
+  END_DOC
+  
+  integer, intent(in)            :: n_selected, Nint, iproc
+  integer(bit_kind), intent(in)  :: det_buffer(Nint,2,n_selected)
+  integer                        :: i,j,k
+  integer                        :: new_size
+  PROVIDE H_apply_buffer_allocated
+  call omp_set_lock(H_apply_buffer_lock(1,iproc))
+  new_size = H_apply_buffer(iproc)%N_det + n_selected
+  if (new_size > H_apply_buffer(iproc)%sze) then
+    call resize_h_apply_buffer(max(2*H_apply_buffer(iproc)%sze,new_size),iproc)
+  endif
+  do i=1,H_apply_buffer(iproc)%N_det
+    ASSERT (sum(popcnt(H_apply_buffer(iproc)%det(:,1,i)) )== elec_alpha_num)
+    ASSERT (sum(popcnt(H_apply_buffer(iproc)%det(:,2,i))) == elec_beta_num)
+  enddo
+  do i=1,n_selected
+    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
+  double precision               :: i_H_psi_array(N_states),h,diag_H_mat_elem_fock,delta_e
+  do i=1,N_selected
+   call i_H_psi(det_buffer(1,1,i),psi_selectors,psi_selectors_coef,N_int,N_det_selectors,psi_selectors_size,N_states,i_H_psi_array)
+   call i_H_j(det_buffer(1,1,i),det_buffer(1,1,i),N_int,h)
+   do j=1,N_states
+      delta_e = -1.d0 /(h - psi_energy(j))
+      H_apply_buffer(iproc)%coef(i+H_apply_buffer(iproc)%N_det,j) = i_H_psi_array(j) * delta_e
+    enddo
+  enddo
+  H_apply_buffer(iproc)%N_det = new_size
+  do i=1,H_apply_buffer(iproc)%N_det
+    ASSERT (sum(popcnt(H_apply_buffer(iproc)%det(:,1,i)) )== elec_alpha_num)
+    ASSERT (sum(popcnt(H_apply_buffer(iproc)%det(:,2,i))) == elec_beta_num)
+  enddo
+  call omp_unset_lock(H_apply_buffer_lock(1,iproc))
+end
+
+
+
+subroutine make_s2_eigenfunction_first_order
+  implicit none
+  integer                        :: i,j,k
+  integer                        :: smax, s
+  integer(bit_kind), allocatable :: d(:,:,:), det_buffer(:,:,:)
+  integer                        :: N_det_new
+  integer, parameter             :: bufsze = 1000
+  logical, external              :: is_in_wavefunction
+
+  allocate (d(N_int,2,1), det_buffer(N_int,2,bufsze) )
+  smax = 1
+  N_det_new = 0
+
+  do i=1,N_occ_pattern
+    call occ_pattern_to_dets_size(psi_occ_pattern(1,1,i),s,elec_alpha_num,N_int)
+    s += 1
+    if (s > smax) then
+      deallocate(d)
+      allocate ( d(N_int,2,s) )
+      smax = s
+    endif
+    call occ_pattern_to_dets(psi_occ_pattern(1,1,i),d,s,elec_alpha_num,N_int)
+    do j=1,s
+      if (.not. is_in_wavefunction(d(1,1,j), N_int) ) then
+        N_det_new += 1
+        do k=1,N_int
+          det_buffer(k,1,N_det_new) = d(k,1,j)
+          det_buffer(k,2,N_det_new) = d(k,2,j)
+        enddo
+        if (N_det_new == bufsze) then
+          call fill_H_apply_buffer_no_selection(bufsze,det_buffer,N_int,0)
+          N_det_new = 0
+        endif
+      endif
+    enddo
+  enddo
+
+  if (N_det_new > 0) then
+    call fill_H_apply_buffer_no_selection_first_order_coef(N_det_new,det_buffer,N_int,0)
+    call copy_H_apply_buffer_to_wf
+    SOFT_TOUCH N_det psi_coef psi_det
+  endif
+
+  deallocate(d,det_buffer)
+
+   call write_int(output_determinants,N_det_new, 'Added deteminants for S^2')
+
+end
+

plugins/FOBOCI/fobo_scf.irp.f

@@ -1,8 +1,13 @@
 program foboscf
  implicit none
- call run_prepare
+!if(disk_access_ao_integrals == "None" .or. disk_access_ao_integrals == "Read" )then
+! disk_access_ao_integrals = "Write"
+! touch disk_access_ao_integrals
+!endif
+!print*, 'disk_access_ao_integrals',disk_access_ao_integrals
  no_oa_or_av_opt = .True.
  touch no_oa_or_av_opt
+ call run_prepare
  call routine_fobo_scf
  call save_mos
 
@@ -10,8 +15,8 @@ end
 
 subroutine run_prepare
  implicit none
-  no_oa_or_av_opt = .False.
-  touch no_oa_or_av_opt
+! no_oa_or_av_opt = .False.
+! touch no_oa_or_av_opt
   call damping_SCF
   call diag_inactive_virt_and_update_mos
 end
@@ -27,6 +32,7 @@ subroutine routine_fobo_scf
   print*,'*******************************************************************************'
   print*,'*******************************************************************************'
   print*,'FOBO-SCF Iteration ',i
+  print*, 'ao_bielec_integrals_in_map = ',ao_bielec_integrals_in_map
   print*,'*******************************************************************************'
   print*,'*******************************************************************************'
   if(speed_up_convergence_foboscf)then
@@ -46,7 +52,7 @@ subroutine routine_fobo_scf
     soft_touch threshold_lmct threshold_mlct
    endif
   endif
-  call FOBOCI_lmct_mlct_old_thr
+  call FOBOCI_lmct_mlct_old_thr(i)
   call save_osoci_natural_mos
   call damping_SCF
   call diag_inactive_virt_and_update_mos

plugins/FOBOCI/foboci_lmct_mlct_threshold_old.irp.f

@@ -1,7 +1,8 @@
 
-subroutine FOBOCI_lmct_mlct_old_thr
+subroutine FOBOCI_lmct_mlct_old_thr(iter)
   use bitmasks
  implicit none
+ integer, intent(in) :: iter
  integer :: i,j,k,l
  integer(bit_kind),allocatable :: unpaired_bitmask(:,:)
  integer, allocatable :: occ(:,:)
@@ -10,7 +11,7 @@ subroutine FOBOCI_lmct_mlct_old_thr
  logical :: test_sym
  double precision :: thr,hij
  double precision, allocatable :: dressing_matrix(:,:)
- logical :: verbose,is_ok
+ logical :: verbose,is_ok,is_ok_perturbative
  verbose = .True.
  thr = 1.d-12
  allocate(unpaired_bitmask(N_int,2))
@@ -38,6 +39,7 @@ subroutine FOBOCI_lmct_mlct_old_thr
  integer(bit_kind) , allocatable :: psi_singles(:,:,:)
  logical :: lmct
  double precision, allocatable :: psi_singles_coef(:,:)
+ logical :: exit_loop
  allocate( zero_bitmask(N_int,2) )
   do i = 1, n_inact_orb
    lmct = .True.
@@ -45,87 +47,45 @@ subroutine FOBOCI_lmct_mlct_old_thr
    i_hole_osoci = list_inact(i)
    print*,'--------------------------'
    ! First set the current generators to the one of restart
-   call set_generators_to_generators_restart
-   call set_psi_det_to_generators
    call check_symetry(i_hole_osoci,thr,test_sym)
    if(.not.test_sym)cycle
+   call set_generators_to_generators_restart
+   call set_psi_det_to_generators
    print*,'i_hole_osoci = ',i_hole_osoci
    call create_restart_and_1h(i_hole_osoci)
    call set_generators_to_psi_det
    print*,'Passed set generators'
    call set_bitmask_particl_as_input(reunion_of_bitmask)
    call set_bitmask_hole_as_input(reunion_of_bitmask)
-   call is_a_good_candidate(threshold_lmct,is_ok,verbose)
+   double precision :: e_pt2
+   call is_a_good_candidate(threshold_lmct,is_ok,e_pt2,verbose,exit_loop,is_ok_perturbative)
    print*,'is_ok = ',is_ok
-   if(.not.is_ok)cycle
-   allocate(dressing_matrix(N_det_generators,N_det_generators))
-   dressing_matrix = 0.d0
-   if(.not.do_it_perturbative)then
-
-    do k = 1, N_det_generators
-     do l = 1, N_det_generators
-       call i_h_j(psi_det_generators(1,1,k),psi_det_generators(1,1,l),N_int,hkl)
-       dressing_matrix(k,l) = hkl
+   if(is_ok)then
+    allocate(dressing_matrix(N_det_generators,N_det_generators))
+    dressing_matrix = 0.d0
+     do k = 1, N_det_generators
+      do l = 1, N_det_generators
+        call i_h_j(psi_det_generators(1,1,k),psi_det_generators(1,1,l),N_int,hkl)
+        dressing_matrix(k,l) = hkl
+      enddo
      enddo
-    enddo
-    hkl = dressing_matrix(1,1)
-    do k = 1, N_det_generators
-      dressing_matrix(k,k) = dressing_matrix(k,k) - hkl
-    enddo
-    print*,'Naked matrix'
-    do k = 1, N_det_generators
-     write(*,'(100(F12.5,X))')dressing_matrix(k,:)
-    enddo
-
-    ! Do all the single excitations on top of the CAS and 1h determinants
-    call set_bitmask_particl_as_input(reunion_of_bitmask)
-    call set_bitmask_hole_as_input(reunion_of_bitmask)
-    call all_single
-!   if(dressing_2h2p)then
-!    call diag_dressed_2h2p_hamiltonian_and_update_psi_det(i_hole_osoci,lmct)
-!   endif
-
-!   ! Change the mask of the holes and particles to perform all the 
-!   ! double excitations that starts from the active space in order 
-!   ! to introduce the Coulomb hole in the active space
-!   ! These are the 1h2p excitations that have the i_hole_osoci hole in common
-!   ! and the 2p if there is more than one electron in the active space
-!   do k = 1, N_int
-!    zero_bitmask(k,1) = 0_bit_kind
-!    zero_bitmask(k,2) = 0_bit_kind
-!   enddo
-!   ! hole is possible only in the orbital i_hole_osoci 
-!   call set_bit_to_integer(i_hole_osoci,zero_bitmask(1,1),N_int)
-!   call set_bit_to_integer(i_hole_osoci,zero_bitmask(1,2),N_int)
-!   ! and in the active space
-!   do k = 1, n_act_orb
-!    call set_bit_to_integer(list_act(k),zero_bitmask(1,1),N_int)
-!    call set_bit_to_integer(list_act(k),zero_bitmask(1,2),N_int)
-!   enddo
-!   call set_bitmask_hole_as_input(zero_bitmask)
-
-!   call set_bitmask_particl_as_input(reunion_of_bitmask)
-
-!   call all_1h2p
-!   call diagonalize_CI_SC2
-!   call provide_matrix_dressing(dressing_matrix,n_det_generators,psi_det_generators)
-
-!   ! Change the mask of the holes and particles to perform all the 
-!   ! double excitations that from the orbital i_hole_osoci
-!   do k = 1, N_int
-!    zero_bitmask(k,1) = 0_bit_kind
-!    zero_bitmask(k,2) = 0_bit_kind
-!   enddo
-!   ! hole is possible only in the orbital i_hole_osoci 
-!   call set_bit_to_integer(i_hole_osoci,zero_bitmask(1,1),N_int)
-!   call set_bit_to_integer(i_hole_osoci,zero_bitmask(1,2),N_int)
-!   call set_bitmask_hole_as_input(zero_bitmask)
-
-!   call set_bitmask_particl_as_input(reunion_of_bitmask)
-
-!   call set_psi_det_to_generators
-!   call all_2h2p
-!   call diagonalize_CI_SC2
+     hkl = dressing_matrix(1,1)
+     do k = 1, N_det_generators
+       dressing_matrix(k,k) = dressing_matrix(k,k) - hkl
+     enddo
+     print*,'Naked matrix'
+     do k = 1, N_det_generators
+      write(*,'(100(F12.5,X))')dressing_matrix(k,:)
+     enddo
+    
+     ! Do all the single excitations on top of the CAS and 1h determinants
+     call set_bitmask_particl_as_input(reunion_of_bitmask)
+     call set_bitmask_hole_as_input(reunion_of_bitmask)
+     call all_single(e_pt2)
+     call make_s2_eigenfunction_first_order
+     threshold_davidson = 1.d-6
+     soft_touch threshold_davidson davidson_criterion
+     call diagonalize_ci
     double precision :: hkl
     call provide_matrix_dressing(dressing_matrix,n_det_generators,psi_det_generators)
     hkl = dressing_matrix(1,1)
@@ -136,7 +96,10 @@ subroutine FOBOCI_lmct_mlct_old_thr
     do k = 1, N_det_generators
      write(*,'(100(F12.5,X))')dressing_matrix(k,:)
     enddo
-!   call diag_dressed_matrix_and_set_to_psi_det(psi_det_generators,N_det_generators,dressing_matrix)
+    deallocate(dressing_matrix)
+   else 
+    if(.not.do_it_perturbative)cycle
+    if(.not. is_ok_perturbative)cycle
    endif
    call set_intermediate_normalization_lmct_old(norm_tmp,i_hole_osoci)
 
@@ -145,7 +108,6 @@ subroutine FOBOCI_lmct_mlct_old_thr
     norm_total(k) += norm_tmp(k)
    enddo
    call update_density_matrix_osoci
-   deallocate(dressing_matrix)
  enddo
 
  if(.True.)then
@@ -159,10 +121,10 @@ subroutine FOBOCI_lmct_mlct_old_thr
 
     print*,'--------------------------'
     ! First set the current generators to the one of restart
-    call set_generators_to_generators_restart
-    call set_psi_det_to_generators
     call check_symetry(i_particl_osoci,thr,test_sym)
     if(.not.test_sym)cycle
+    call set_generators_to_generators_restart
+    call set_psi_det_to_generators
     print*,'i_particl_osoci= ',i_particl_osoci
     ! Initialize the bitmask to the restart ones
     call initialize_bitmask_to_restart_ones
@@ -178,24 +140,33 @@ subroutine FOBOCI_lmct_mlct_old_thr
     call set_bitmask_particl_as_input(reunion_of_bitmask)
     call set_bitmask_hole_as_input(reunion_of_bitmask)
 !!  ! so all the mono excitation on the new generators 
-    call is_a_good_candidate(threshold_mlct,is_ok,verbose)
+    call is_a_good_candidate(threshold_mlct,is_ok,e_pt2,verbose,exit_loop,is_ok_perturbative)
     print*,'is_ok = ',is_ok
-    if(.not.is_ok)cycle
-     allocate(dressing_matrix(N_det_generators,N_det_generators))
-    if(.not.do_it_perturbative)then
-     dressing_matrix = 0.d0
-     do k = 1, N_det_generators
-      do l = 1, N_det_generators
-        call i_h_j(psi_det_generators(1,1,k),psi_det_generators(1,1,l),N_int,hkl)
-        dressing_matrix(k,l) = hkl
+    if(is_ok)then
+      allocate(dressing_matrix(N_det_generators,N_det_generators))
+      dressing_matrix = 0.d0
+      do k = 1, N_det_generators
+       do l = 1, N_det_generators
+         call i_h_j(psi_det_generators(1,1,k),psi_det_generators(1,1,l),N_int,hkl)
+         dressing_matrix(k,l) = hkl
+       enddo
       enddo
-     enddo
- !   call all_single_split(psi_det_generators,psi_coef_generators,N_det_generators,dressing_matrix)
- !   call diag_dressed_matrix_and_set_to_psi_det(psi_det_generators,N_det_generators,dressing_matrix)
-     call all_single
-!    if(dressing_2h2p)then
-!     call diag_dressed_2h2p_hamiltonian_and_update_psi_det(i_particl_osoci,lmct)
-!    endif
+      call all_single(e_pt2)
+      call make_s2_eigenfunction_first_order
+      threshold_davidson = 1.d-6
+      soft_touch threshold_davidson davidson_criterion
+     
+      call diagonalize_ci
+      deallocate(dressing_matrix)
+    else
+     if(exit_loop)then
+      call set_generators_to_generators_restart
+      call set_psi_det_to_generators
+      exit
+     else 
+      if(.not.do_it_perturbative)cycle
+      if(.not. is_ok_perturbative)cycle
+     endif
     endif
     call set_intermediate_normalization_mlct_old(norm_tmp,i_particl_osoci)
     do k = 1, N_states
@@ -203,7 +174,6 @@ subroutine FOBOCI_lmct_mlct_old_thr
      norm_total(k) += norm_tmp(k)
     enddo
     call update_density_matrix_osoci
-   deallocate(dressing_matrix)
   enddo
  endif
 
@@ -230,7 +200,7 @@ subroutine FOBOCI_mlct_old
  double precision :: norm_tmp,norm_total
  logical :: test_sym
  double precision :: thr
- logical :: verbose,is_ok
+ logical :: verbose,is_ok,exit_loop
  verbose = .False.
  thr = 1.d-12
  allocate(unpaired_bitmask(N_int,2))
@@ -270,7 +240,7 @@ subroutine FOBOCI_mlct_old
    call set_bitmask_particl_as_input(reunion_of_bitmask)
    call set_bitmask_hole_as_input(reunion_of_bitmask)
 !  ! so all the mono excitation on the new generators 
-   call is_a_good_candidate(threshold_mlct,is_ok,verbose)
+   call is_a_good_candidate(threshold_mlct,is_ok,verbose,exit_loop)
    print*,'is_ok = ',is_ok
    is_ok =.True.
    if(.not.is_ok)cycle
@@ -304,7 +274,7 @@ subroutine FOBOCI_lmct_old
  double precision :: norm_tmp,norm_total
  logical :: test_sym
  double precision :: thr
- logical :: verbose,is_ok
+ logical :: verbose,is_ok,exit_loop
  verbose = .False.
  thr = 1.d-12
  allocate(unpaired_bitmask(N_int,2))
@@ -342,7 +312,7 @@ subroutine FOBOCI_lmct_old
    call set_generators_to_psi_det
    call set_bitmask_particl_as_input(reunion_of_bitmask)
    call set_bitmask_hole_as_input(reunion_of_bitmask)
-   call is_a_good_candidate(threshold_lmct,is_ok,verbose)
+   call is_a_good_candidate(threshold_lmct,is_ok,verbose,exit_loop)
    print*,'is_ok = ',is_ok
    if(.not.is_ok)cycle
 !  ! so all the mono excitation on the new generators 
@@ -365,3 +335,303 @@ subroutine FOBOCI_lmct_old
    enddo
    print*,'accu = ',accu
 end
+
+subroutine FOBOCI_lmct_mlct_old_thr_restart(iter)
+  use bitmasks
+ implicit none
+ integer, intent(in) :: iter
+ integer :: i,j,k,l
+ integer(bit_kind),allocatable :: unpaired_bitmask(:,:)
+ integer, allocatable :: occ(:,:)
+ integer       :: n_occ_alpha, n_occ_beta
+ double precision :: norm_tmp(N_states),norm_total(N_states)
+ logical :: test_sym
+ double precision :: thr,hij
+ double precision, allocatable :: dressing_matrix(:,:)
+ logical :: verbose,is_ok,is_ok_perturbative
+ verbose = .True.
+ thr = 1.d-12
+ allocate(unpaired_bitmask(N_int,2))
+ allocate (occ(N_int*bit_kind_size,2))
+ do i = 1, N_int
+  unpaired_bitmask(i,1) = unpaired_alpha_electrons(i)
+  unpaired_bitmask(i,2) = unpaired_alpha_electrons(i)
+ enddo
+ norm_total = 0.d0
+ call initialize_density_matrix_osoci
+ call bitstring_to_list(inact_bitmask(1,1), occ(1,1), n_occ_beta, N_int)
+ print*,''
+ print*,''
+ print*,'mulliken spin population analysis'
+ accu =0.d0
+ do i = 1, nucl_num
+  accu += mulliken_spin_densities(i)
+  print*,i,nucl_charge(i),mulliken_spin_densities(i)
+ enddo
+ print*,''
+ print*,''
+ print*,'DOING FIRST LMCT !!'
+ print*,'Threshold_lmct = ',threshold_lmct
+ integer(bit_kind) , allocatable :: zero_bitmask(:,:)
+ integer(bit_kind) , allocatable :: psi_singles(:,:,:)
+ logical :: lmct
+ double precision, allocatable :: psi_singles_coef(:,:)
+ logical :: exit_loop
+ allocate( zero_bitmask(N_int,2) )
+ if(iter.ne.1)then
+   do i = 1, n_inact_orb
+    lmct = .True.
+    integer :: i_hole_osoci
+    i_hole_osoci = list_inact(i)
+    print*,'--------------------------'
+    ! First set the current generators to the one of restart
+    call check_symetry(i_hole_osoci,thr,test_sym)
+    if(.not.test_sym)cycle
+    call set_generators_to_generators_restart
+    call set_psi_det_to_generators
+    print*,'i_hole_osoci = ',i_hole_osoci
+    call create_restart_and_1h(i_hole_osoci)
+    call set_generators_to_psi_det
+    print*,'Passed set generators'
+    call set_bitmask_particl_as_input(reunion_of_bitmask)
+    call set_bitmask_hole_as_input(reunion_of_bitmask)
+    double precision :: e_pt2
+    call is_a_good_candidate(threshold_lmct,is_ok,e_pt2,verbose,exit_loop,is_ok_perturbative)
+    print*,'is_ok = ',is_ok
+    if(is_ok)then
+     allocate(dressing_matrix(N_det_generators,N_det_generators))
+     dressing_matrix = 0.d0
+      do k = 1, N_det_generators
+       do l = 1, N_det_generators
+         call i_h_j(psi_det_generators(1,1,k),psi_det_generators(1,1,l),N_int,hkl)
+         dressing_matrix(k,l) = hkl
+       enddo
+      enddo
+      hkl = dressing_matrix(1,1)
+      do k = 1, N_det_generators
+        dressing_matrix(k,k) = dressing_matrix(k,k) - hkl
+      enddo
+      print*,'Naked matrix'
+      do k = 1, N_det_generators
+       write(*,'(100(F12.5,X))')dressing_matrix(k,:)
+      enddo
+     
+      ! Do all the single excitations on top of the CAS and 1h determinants
+      call set_bitmask_particl_as_input(reunion_of_bitmask)
+      call set_bitmask_hole_as_input(reunion_of_bitmask)
+      call all_single(e_pt2)
+      call make_s2_eigenfunction_first_order
+      threshold_davidson = 1.d-6
+      soft_touch threshold_davidson davidson_criterion
+      call diagonalize_ci
+     double precision :: hkl
+     call provide_matrix_dressing(dressing_matrix,n_det_generators,psi_det_generators)
+     hkl = dressing_matrix(1,1)
+     do k = 1, N_det_generators
+       dressing_matrix(k,k) = dressing_matrix(k,k) - hkl
+     enddo
+     print*,'Dressed matrix'
+     do k = 1, N_det_generators
+      write(*,'(100(F12.5,X))')dressing_matrix(k,:)
+     enddo
+     deallocate(dressing_matrix)
+    else 
+     if(.not.do_it_perturbative)cycle
+     if(.not. is_ok_perturbative)cycle
+    endif
+    call set_intermediate_normalization_lmct_old(norm_tmp,i_hole_osoci)
+ 
+    do k = 1, N_states
+     print*,'norm_tmp = ',norm_tmp(k)
+     norm_total(k) += norm_tmp(k)
+    enddo
+    call update_density_matrix_osoci
+  enddo
+ else 
+  double precision :: array_dm(mo_tot_num)
+  call read_dm_from_lmct(array_dm)
+  call update_density_matrix_beta_osoci_read(array_dm)
+ endif
+
+ if(iter.ne.1)then
+  if(.True.)then
+   print*,''
+   print*,'DOING THEN THE MLCT !!'
+   print*,'Threshold_mlct = ',threshold_mlct
+    lmct = .False.
+    do i = 1, n_virt_orb
+     integer :: i_particl_osoci
+     i_particl_osoci = list_virt(i)
+ 
+     print*,'--------------------------'
+     ! First set the current generators to the one of restart
+     call check_symetry(i_particl_osoci,thr,test_sym)
+     if(.not.test_sym)cycle
+     call set_generators_to_generators_restart
+     call set_psi_det_to_generators
+     print*,'i_particl_osoci= ',i_particl_osoci
+     ! Initialize the bitmask to the restart ones
+     call initialize_bitmask_to_restart_ones
+     ! Impose that only the hole i_hole_osoci can be done
+     call modify_bitmasks_for_particl(i_particl_osoci)
+     call print_generators_bitmasks_holes
+     ! Impose that only the active part can be reached 
+     call set_bitmask_hole_as_input(unpaired_bitmask)
+!!!  call all_single_h_core
+     call create_restart_and_1p(i_particl_osoci)
+!!!  ! Update the generators 
+     call set_generators_to_psi_det
+     call set_bitmask_particl_as_input(reunion_of_bitmask)
+     call set_bitmask_hole_as_input(reunion_of_bitmask)
+!!!  ! so all the mono excitation on the new generators 
+     call is_a_good_candidate(threshold_mlct,is_ok,e_pt2,verbose,exit_loop,is_ok_perturbative)
+     print*,'is_ok = ',is_ok
+     if(is_ok)then
+       allocate(dressing_matrix(N_det_generators,N_det_generators))
+       dressing_matrix = 0.d0
+       do k = 1, N_det_generators
+        do l = 1, N_det_generators
+          call i_h_j(psi_det_generators(1,1,k),psi_det_generators(1,1,l),N_int,hkl)
+          dressing_matrix(k,l) = hkl
+        enddo
+       enddo
+       call all_single(e_pt2)
+       call make_s2_eigenfunction_first_order
+       threshold_davidson = 1.d-6
+       soft_touch threshold_davidson davidson_criterion
+      
+       call diagonalize_ci
+       deallocate(dressing_matrix)
+     else
+      if(exit_loop)then
+       call set_generators_to_generators_restart
+       call set_psi_det_to_generators
+       exit
+      else 
+       if(.not.do_it_perturbative)cycle
+       if(.not. is_ok_perturbative)cycle
+      endif
+     endif
+     call set_intermediate_normalization_mlct_old(norm_tmp,i_particl_osoci)
+     do k = 1, N_states
+      print*,'norm_tmp = ',norm_tmp(k)
+      norm_total(k) += norm_tmp(k)
+     enddo
+     call update_density_matrix_osoci
+   enddo
+  endif
+ else 
+  integer :: norb
+  call read_dm_from_mlct(array_dm,norb)
+  call update_density_matrix_alpha_osoci_read(array_dm)
+    do i = norb+1, n_virt_orb
+     i_particl_osoci = list_virt(i)
+ 
+     print*,'--------------------------'
+     ! First set the current generators to the one of restart
+     call check_symetry(i_particl_osoci,thr,test_sym)
+     if(.not.test_sym)cycle
+     call set_generators_to_generators_restart
+     call set_psi_det_to_generators
+     print*,'i_particl_osoci= ',i_particl_osoci
+     ! Initialize the bitmask to the restart ones
+     call initialize_bitmask_to_restart_ones
+     ! Impose that only the hole i_hole_osoci can be done
+     call modify_bitmasks_for_particl(i_particl_osoci)
+     call print_generators_bitmasks_holes
+     ! Impose that only the active part can be reached 
+     call set_bitmask_hole_as_input(unpaired_bitmask)
+!!!  call all_single_h_core
+     call create_restart_and_1p(i_particl_osoci)
+!!!  ! Update the generators 
+     call set_generators_to_psi_det
+     call set_bitmask_particl_as_input(reunion_of_bitmask)
+     call set_bitmask_hole_as_input(reunion_of_bitmask)
+!!!  ! so all the mono excitation on the new generators 
+     call is_a_good_candidate(threshold_mlct,is_ok,e_pt2,verbose,exit_loop,is_ok_perturbative)
+     print*,'is_ok = ',is_ok
+     if(is_ok)then
+       allocate(dressing_matrix(N_det_generators,N_det_generators))
+       dressing_matrix = 0.d0
+       do k = 1, N_det_generators
+        do l = 1, N_det_generators
+          call i_h_j(psi_det_generators(1,1,k),psi_det_generators(1,1,l),N_int,hkl)
+          dressing_matrix(k,l) = hkl
+        enddo
+       enddo
+       call all_single(e_pt2)
+       call make_s2_eigenfunction_first_order
+       threshold_davidson = 1.d-6
+       soft_touch threshold_davidson davidson_criterion
+      
+       call diagonalize_ci
+       deallocate(dressing_matrix)
+     else
+      if(exit_loop)then
+       call set_generators_to_generators_restart
+       call set_psi_det_to_generators
+       exit
+      else 
+       if(.not.do_it_perturbative)cycle
+       if(.not. is_ok_perturbative)cycle
+      endif
+     endif
+     call set_intermediate_normalization_mlct_old(norm_tmp,i_particl_osoci)
+     do k = 1, N_states
+      print*,'norm_tmp = ',norm_tmp(k)
+      norm_total(k) += norm_tmp(k)
+     enddo
+     call update_density_matrix_osoci
+   enddo
+ endif
+
+   print*,'norm_total = ',norm_total
+   norm_total = norm_generators_restart
+   norm_total = 1.d0/norm_total
+!  call rescale_density_matrix_osoci(norm_total)
+   double precision :: accu
+   accu = 0.d0
+   do i = 1, mo_tot_num
+    accu += one_body_dm_mo_alpha_osoci(i,i) + one_body_dm_mo_beta_osoci(i,i)
+   enddo
+   print*,'accu = ',accu
+end
+
+subroutine read_dm_from_lmct(array)
+ implicit none
+ integer :: i,iunit ,getUnitAndOpen
+ double precision :: stuff
+ double precision, intent(out) :: array(mo_tot_num)
+ character*(128) :: input
+ input=trim("fort.33")
+ iunit= getUnitAndOpen(input,'r')
+ print*, iunit
+ array = 0.d0
+ do i = 1, n_inact_orb
+  read(iunit,*) stuff
+  print*, list_inact(i),stuff
+  array(list_inact(i)) =  stuff
+ enddo
+end
+
+subroutine read_dm_from_mlct(array,norb)
+ implicit none
+ integer :: i,iunit ,getUnitAndOpen
+ double precision :: stuff
+ double precision, intent(out) :: array(mo_tot_num)
+ character*(128) :: input
+ input=trim("fort.35")
+ iunit= getUnitAndOpen(input,'r')
+ integer,intent(out) :: norb
+ read(iunit,*)norb
+ print*, iunit
+ input=trim("fort.34")
+ iunit= getUnitAndOpen(input,'r')
+ array = 0.d0
+ print*, 'norb = ',norb
+ do i = 1, norb
+  read(iunit,*) stuff
+  print*, list_virt(i),stuff
+  array(list_virt(i)) =  stuff
+ enddo
+end

plugins/FOBOCI/generators_restart_save.irp.f

@@ -9,6 +9,7 @@ BEGIN_PROVIDER [ integer, N_det_generators_restart ]
  integer :: i
  integer, save :: ifirst = 0
  double precision :: norm
+ print*, ' Providing N_det_generators_restart'
  if(ifirst == 0)then
   call ezfio_get_determinants_n_det(N_det_generators_restart)
   ifirst = 1
@@ -30,6 +31,7 @@ END_PROVIDER
  integer                        :: i, k
  integer, save :: ifirst = 0
  double precision, allocatable  :: psi_coef_read(:,:)
+ print*, ' Providing psi_det_generators_restart'
  if(ifirst == 0)then
   call read_dets(psi_det_generators_restart,N_int,N_det_generators_restart)
    do k = 1, N_int

plugins/FOBOCI/hcc_1h1p.irp.f

@@ -1,82 +0,0 @@
-program test_sc2
- implicit none
- read_wf = .True.
- touch read_wf
- call routine
-
-
-end
-
-subroutine routine
-  implicit none
-  double precision, allocatable :: energies(:),diag_H_elements(:)
-  double precision, allocatable :: H_matrix(:,:)
-  allocate(energies(N_states),diag_H_elements(N_det))
-  call diagonalize_CI
-  call test_hcc
-  call test_mulliken
-  allocate(H_matrix(N_det,N_det))
-  stop 'SC2_1h1p_full is not in the git!'
-!  call SC2_1h1p_full(psi_det,psi_coef,energies, &
-!        H_matrix,size(psi_coef,1),N_det,N_states_diag,N_int,threshold_convergence_SC2)
-  deallocate(H_matrix)
-  integer :: i,j
-  double precision :: accu,coef_hf
-! coef_hf = 1.d0/psi_coef(1,1)
-! do i = 1, N_det
-!  psi_coef(i,1) *= coef_hf
-! enddo
-  touch psi_coef
-  call pouet
-end
-
-subroutine pouet
-  implicit none
-  double precision :: accu,coef_hf
-! provide one_body_dm_mo_alpha one_body_dm_mo_beta
-! call density_matrix_1h1p(psi_det,psi_coef,one_body_dm_mo_alpha,one_body_dm_mo_beta,accu,size(psi_coef,1),N_det,N_states_diag,N_int)
-! touch one_body_dm_mo_alpha one_body_dm_mo_beta 
-  call test_hcc
-  call test_mulliken
-! call save_wavefunction
-
-end
-
-subroutine test_hcc
- implicit none
- double precision :: accu
- integer :: i,j
- print*,'Z               AU           GAUSS              MHZ             cm^-1'
- do i = 1, nucl_num
-  write(*,'(I2,X,F3.1,X,4(F16.6,X))')i,nucl_charge(i),spin_density_at_nucleous(i),iso_hcc_gauss(i),iso_hcc_mhz(i),iso_hcc_cm_1(i)
- enddo
-
-end
-
-subroutine test_mulliken
- double precision :: accu
- integer :: i
- integer :: j
- accu= 0.d0
- do i = 1, nucl_num
-  print*,i,nucl_charge(i),mulliken_spin_densities(i)
-  accu += mulliken_spin_densities(i)
- enddo
- print*,'Sum of Mulliken SD = ',accu
-!print*,'AO SPIN POPULATIONS'
- accu = 0.d0
-!do i = 1, ao_num
-! accu += spin_gross_orbital_product(i)
-! write(*,'(X,I3,X,A4,X,I2,X,A4,X,F10.7)')i,trim(element_name(int(nucl_charge(ao_nucl(i))))),ao_nucl(i),trim(l_to_charater(ao_l(i))),spin_gross_orbital_product(i)
-!enddo
-!print*,'sum = ',accu
-!accu = 0.d0
-!print*,'Angular momentum analysis'
-!do i = 0,  ao_l_max
-! accu += spin_population_angular_momentum(i)
-! print*,' ',trim(l_to_charater(i)),spin_population_angular_momentum(i)
-!print*,'sum = ',accu
-!enddo
-
-end
-

plugins/FOBOCI/routines_foboci.irp.f

@@ -212,12 +212,50 @@ subroutine update_density_matrix_osoci
  integer :: iorb,jorb
  do i = 1, mo_tot_num
   do j = 1, mo_tot_num
-   one_body_dm_mo_alpha_osoci(i,j) = one_body_dm_mo_alpha_osoci(i,j) + (one_body_dm_mo_alpha(i,j) - one_body_dm_mo_alpha_generators_restart(i,j))
-   one_body_dm_mo_beta_osoci(i,j) = one_body_dm_mo_beta_osoci(i,j) + (one_body_dm_mo_beta(i,j) - one_body_dm_mo_beta_generators_restart(i,j))
+   one_body_dm_mo_alpha_osoci(i,j) = one_body_dm_mo_alpha_osoci(i,j) + (one_body_dm_mo_alpha_average(i,j) - one_body_dm_mo_alpha_generators_restart(i,j))
+   one_body_dm_mo_beta_osoci(i,j) = one_body_dm_mo_beta_osoci(i,j) + (one_body_dm_mo_beta_average(i,j) - one_body_dm_mo_beta_generators_restart(i,j))
   enddo
  enddo
 
 
+end
+
+subroutine update_density_matrix_beta_osoci_read(array)
+ implicit none
+ BEGIN_DOC
+ ! one_body_dm_mo_alpha_osoci += Delta rho alpha
+ ! one_body_dm_mo_beta_osoci  += Delta rho beta
+ END_DOC
+ integer :: i,j
+ integer :: iorb,jorb
+ double precision :: array(mo_tot_num)
+ do i = 1, mo_tot_num
+   j = list_act(1)
+   one_body_dm_mo_beta_osoci(i,j) += array(i)
+   one_body_dm_mo_beta_osoci(j,i) += array(i)
+   one_body_dm_mo_beta_osoci(i,i) += array(i) * array(i)
+ enddo
+
+
+end
+
+subroutine update_density_matrix_alpha_osoci_read(array)
+ implicit none
+ BEGIN_DOC
+ ! one_body_dm_mo_alpha_osoci += Delta rho alpha
+ ! one_body_dm_mo_beta_osoci  += Delta rho beta
+ END_DOC
+ integer :: i,j
+ integer :: iorb,jorb
+ double precision :: array(mo_tot_num)
+ do i = 1, mo_tot_num
+   j = list_act(1)
+   one_body_dm_mo_alpha_osoci(i,j) += array(i)
+   one_body_dm_mo_alpha_osoci(j,i) += array(i)
+   one_body_dm_mo_alpha_osoci(i,i) += array(i) * array(i)
+ enddo
+
+
 end
 
 
@@ -387,14 +425,14 @@ subroutine save_osoci_natural_mos
   print*,'ACTIVE ORBITAL  ',iorb
   do j = 1, n_inact_orb
    jorb = list_inact(j)
-   if(dabs(tmp(iorb,jorb)).gt.threshold_lmct)then
+   if(dabs(tmp(iorb,jorb)).gt.0.0001d0)then
     print*,'INACTIVE  '
     print*,'DM ',iorb,jorb,(tmp(iorb,jorb))
    endif
   enddo
   do j = 1, n_virt_orb
    jorb = list_virt(j)
-   if(dabs(tmp(iorb,jorb)).gt.threshold_mlct)then
+   if(dabs(tmp(iorb,jorb)).gt.0.0001d0)then
     print*,'VIRT      '
     print*,'DM ',iorb,jorb,(tmp(iorb,jorb))
    endif
@@ -412,6 +450,10 @@ subroutine save_osoci_natural_mos
  label = "Natural"
  
  call mo_as_eigvectors_of_mo_matrix(tmp,size(tmp,1),size(tmp,2),label,1)
+!if(disk_access_ao_integrals == "None" .or. disk_access_ao_integrals == "Write" )then
+! disk_access_ao_integrals = "Read"
+! touch disk_access_ao_integrals
+!endif
 !soft_touch mo_coef
  deallocate(tmp,occ)
 
@@ -588,14 +630,14 @@ end
    integer :: i
    double precision :: accu_tot,accu_sd
    print*,'touched the one_body_dm_mo_beta'
-   one_body_dm_mo_alpha = one_body_dm_mo_alpha_osoci
-   one_body_dm_mo_beta = one_body_dm_mo_beta_osoci
+   one_body_dm_mo_alpha_average = one_body_dm_mo_alpha_osoci
+   one_body_dm_mo_beta_average = one_body_dm_mo_beta_osoci
    touch one_body_dm_mo_alpha  one_body_dm_mo_beta 
    accu_tot = 0.d0
    accu_sd  = 0.d0
    do i = 1, mo_tot_num
-    accu_tot += one_body_dm_mo_alpha(i,i) + one_body_dm_mo_beta(i,i)
-    accu_sd  += one_body_dm_mo_alpha(i,i) - one_body_dm_mo_beta(i,i)
+    accu_tot += one_body_dm_mo_alpha_average(i,i) + one_body_dm_mo_beta_average(i,i)
+    accu_sd  += one_body_dm_mo_alpha_average(i,i) - one_body_dm_mo_beta_average(i,i)
    enddo
    print*,'accu_tot = ',accu_tot
    print*,'accu_sdt = ',accu_sd 

plugins/Full_CI/.gitignore

@@ -3,6 +3,7 @@
 .ninja_log
 AO_Basis
 Bitmask
+Davidson
 Determinants
 Electrons
 Ezfio_files
@@ -28,7 +29,6 @@ full_ci
 full_ci_no_skip
 irpf90.make
 irpf90_entities
-micro_pt2
 tags
 target_pt2
 var_pt2_ratio

plugins/Full_CI/H_apply.irp.f

@@ -7,16 +7,17 @@ s.set_selection_pt2("epstein_nesbet_2x2")
 #s.unset_openmp()
 print s
 
-#s = H_apply("FCI_PT2")
-#s.set_perturbation("epstein_nesbet_2x2")
-#s.unset_openmp()
-#print s
-
-s = H_apply_zmq("FCI_PT2")
+s = H_apply("FCI_PT2")
 s.set_perturbation("epstein_nesbet_2x2")
 s.unset_openmp()
 print s
 
+s = H_apply("FCI_PT2_new")
+s.set_perturbation("decontracted")
+s.unset_openmp()
+print s
+
+
 s = H_apply("FCI_no_skip")
 s.set_selection_pt2("epstein_nesbet_2x2")
 s.unset_skip()

plugins/Full_CI/README.rst

@@ -16,6 +16,7 @@ Needed Modules
 * `Perturbation <http://github.com/LCPQ/quantum_package/tree/master/plugins/Perturbation>`_
 * `Selectors_full <http://github.com/LCPQ/quantum_package/tree/master/plugins/Selectors_full>`_
 * `Generators_full <http://github.com/LCPQ/quantum_package/tree/master/plugins/Generators_full>`_
+* `Davidson <http://github.com/LCPQ/quantum_package/tree/master/src/Davidson>`_
 
 Documentation
 =============
@@ -77,6 +78,31 @@ h_apply_fci_monoexc
   Assume N_int is already provided.
 
 
+h_apply_fci_no_selection
+  Calls H_apply on the HF determinant and selects all connected single and double
+  excitations (of the same symmetry). Auto-generated by the ``generate_h_apply`` script.
+
+
+h_apply_fci_no_selection_diexc
+  Undocumented
+
+
+h_apply_fci_no_selection_diexcorg
+  Generate all double excitations of key_in using the bit masks of holes and
+  particles.
+  Assume N_int is already provided.
+
+
+h_apply_fci_no_selection_diexcp
+  Undocumented
+
+
+h_apply_fci_no_selection_monoexc
+  Generate all single excitations of key_in using the bit masks of holes and
+  particles.
+  Assume N_int is already provided.
+
+
 h_apply_fci_no_skip
   Calls H_apply on the HF determinant and selects all connected single and double
   excitations (of the same symmetry). Auto-generated by the ``generate_h_apply`` script.
@@ -144,118 +170,6 @@ h_apply_fci_pt2_slave_tcp
   Computes a buffer over the network
 
 
-h_apply_pt2_mono_delta_rho
-  Calls H_apply on the HF determinant and selects all connected single and double
-  excitations (of the same symmetry). Auto-generated by the ``generate_h_apply`` script.
-
-
-h_apply_pt2_mono_delta_rho_diexc
-  Undocumented
-
-
-h_apply_pt2_mono_delta_rho_diexcorg
-  Generate all double excitations of key_in using the bit masks of holes and
-  particles.
-  Assume N_int is already provided.
-
-
-h_apply_pt2_mono_delta_rho_diexcp
-  Undocumented
-
-
-h_apply_pt2_mono_delta_rho_monoexc
-  Generate all single excitations of key_in using the bit masks of holes and
-  particles.
-  Assume N_int is already provided.
-
-
-h_apply_pt2_mono_di_delta_rho
-  Calls H_apply on the HF determinant and selects all connected single and double
-  excitations (of the same symmetry). Auto-generated by the ``generate_h_apply`` script.
-
-
-h_apply_pt2_mono_di_delta_rho_diexc
-  Undocumented
-
-
-h_apply_pt2_mono_di_delta_rho_diexcorg
-  Generate all double excitations of key_in using the bit masks of holes and
-  particles.
-  Assume N_int is already provided.
-
-
-h_apply_pt2_mono_di_delta_rho_diexcp
-  Undocumented
-
-
-h_apply_pt2_mono_di_delta_rho_monoexc
-  Generate all single excitations of key_in using the bit masks of holes and
-  particles.
-  Assume N_int is already provided.
-
-
-h_apply_select_mono_delta_rho
-  Calls H_apply on the HF determinant and selects all connected single and double
-  excitations (of the same symmetry). Auto-generated by the ``generate_h_apply`` script.
-
-
-h_apply_select_mono_delta_rho_diexc
-  Undocumented
-
-
-h_apply_select_mono_delta_rho_diexcorg
-  Generate all double excitations of key_in using the bit masks of holes and
-  particles.
-  Assume N_int is already provided.
-
-
-h_apply_select_mono_delta_rho_diexcp
-  Undocumented
-
-
-h_apply_select_mono_delta_rho_monoexc
-  Generate all single excitations of key_in using the bit masks of holes and
-  particles.
-  Assume N_int is already provided.
-
-
-h_apply_select_mono_di_delta_rho
-  Calls H_apply on the HF determinant and selects all connected single and double
-  excitations (of the same symmetry). Auto-generated by the ``generate_h_apply`` script.
-
-
-h_apply_select_mono_di_delta_rho_diexc
-  Undocumented
-
-
-h_apply_select_mono_di_delta_rho_diexcorg
-  Generate all double excitations of key_in using the bit masks of holes and
-  particles.
-  Assume N_int is already provided.
-
-
-h_apply_select_mono_di_delta_rho_diexcp
-  Undocumented
-
-
-h_apply_select_mono_di_delta_rho_monoexc
-  Generate all single excitations of key_in using the bit masks of holes and
-  particles.
-  Assume N_int is already provided.
-
-
-`micro_pt2 <http://github.com/LCPQ/quantum_package/tree/master/plugins/Full_CI/micro_pt2.irp.f#L1>`_
-  Helper program to compute the PT2 in distributed mode.
-
-
-`provide_everything <http://github.com/LCPQ/quantum_package/tree/master/plugins/Full_CI/micro_pt2.irp.f#L15>`_
-  Undocumented
-
-
-`run_wf <http://github.com/LCPQ/quantum_package/tree/master/plugins/Full_CI/micro_pt2.irp.f#L19>`_
-  Undocumented
-
-
 `var_pt2_ratio_run <http://github.com/LCPQ/quantum_package/tree/master/plugins/Full_CI/var_pt2_ratio.irp.f#L1>`_
   Undocumented
 

plugins/Full_CI/full_ci.irp.f

@@ -92,8 +92,9 @@ program full_ci
    call diagonalize_CI
    if(do_pt2_end)then
     print*,'Last iteration only to compute the PT2'
-    threshold_selectors = 1.d0
-    threshold_generators = 0.999d0
+    threshold_generators = threshold_generators_pt2
+    threshold_selectors = threshold_selectors_pt2
+    SOFT_TOUCH threshold_generators threshold_selectors
     call H_apply_FCI_PT2(pt2, norm_pert, H_pert_diag,  N_st)
  
     print *,  'Final step'

plugins/Full_CI/full_ci_no_skip.irp.f

@@ -73,9 +73,11 @@ program full_ci
    call diagonalize_CI
    if(do_pt2_end)then
     print*,'Last iteration only to compute the PT2'
+    threshold_generators = threshold_generators_pt2
+    threshold_selectors = threshold_selectors_pt2
+    SOFT_TOUCH threshold_generators threshold_selectors
+    
 !   print*,'The thres'
-    threshold_selectors = 1.d0
-    threshold_generators = 0.999d0
     call H_apply_FCI_PT2(pt2, norm_pert, H_pert_diag,  N_st)
  
     print *,  'Final step'

plugins/Full_CI_ZMQ/EZFIO.cfg

@@ -0,0 +1,11 @@
+[energy]
+type: double precision
+doc: Calculated Selected FCI energy
+interface: ezfio
+
+[energy_pt2]
+type: double precision
+doc: Calculated FCI energy + PT2
+interface: ezfio
+
+

plugins/Full_CI_ZMQ/NEEDED_CHILDREN_MODULES

@@ -1 +1 @@
-Perturbation Selectors_full Generators_full ZMQ Full_CI
+Perturbation Selectors_full Generators_full ZMQ 

plugins/Full_CI_ZMQ/README.rst

@@ -0,0 +1,461 @@
+Needed Modules
+==============
+.. Do not edit this section It was auto-generated
+.. by the `update_README.py` script.
+
+
+.. image:: tree_dependency.png
+
+* `Perturbation <http://github.com/LCPQ/quantum_package/tree/master/plugins/Perturbation>`_
+* `Selectors_full <http://github.com/LCPQ/quantum_package/tree/master/plugins/Selectors_full>`_
+* `Generators_full <http://github.com/LCPQ/quantum_package/tree/master/plugins/Generators_full>`_
+* `ZMQ <http://github.com/LCPQ/quantum_package/tree/master/src/ZMQ>`_
+* `Full_CI <http://github.com/LCPQ/quantum_package/tree/master/plugins/Full_CI>`_
+
+Documentation
+=============
+.. Do not edit this section It was auto-generated
+.. by the `update_README.py` script.
+
+
+`add_task_to_taskserver <http://github.com/LCPQ/quantum_package/tree/master/plugins/Full_CI_ZMQ/utils.irp.f#L677>`_
+  Get a task from the task server
+
+
+`add_to_selection_buffer <http://github.com/LCPQ/quantum_package/tree/master/plugins/Full_CI_ZMQ/selection_buffer.irp.f#L19>`_
+  Undocumented
+
+
+`assert <http://github.com/LCPQ/quantum_package/tree/master/plugins/Full_CI_ZMQ/selection.irp.f#L25>`_
+  Undocumented
+
+
+`connect_to_taskserver <http://github.com/LCPQ/quantum_package/tree/master/plugins/Full_CI_ZMQ/utils.irp.f#L594>`_
+  Connect to the task server and obtain the worker ID
+
+
+`create_selection_buffer <http://github.com/LCPQ/quantum_package/tree/master/plugins/Full_CI_ZMQ/selection_buffer.irp.f#L2>`_
+  Undocumented
+
+
+`disconnect_from_taskserver <http://github.com/LCPQ/quantum_package/tree/master/plugins/Full_CI_ZMQ/utils.irp.f#L637>`_
+  Disconnect from the task server
+
+
+`end_parallel_job <http://github.com/LCPQ/quantum_package/tree/master/plugins/Full_CI_ZMQ/utils.irp.f#L559>`_
+  End a new parallel job with name 'name'. The slave tasks execute subroutine 'slave'
+
+
+`end_zmq_pair_socket <http://github.com/LCPQ/quantum_package/tree/master/plugins/Full_CI_ZMQ/utils.irp.f#L419>`_
+  Terminate socket on which the results are sent.
+
+
+`end_zmq_pull_socket <http://github.com/LCPQ/quantum_package/tree/master/plugins/Full_CI_ZMQ/utils.irp.f#L437>`_
+  Terminate socket on which the results are sent.
+
+
+`end_zmq_push_socket <http://github.com/LCPQ/quantum_package/tree/master/plugins/Full_CI_ZMQ/utils.irp.f#L456>`_
+  Terminate socket on which the results are sent.
+
+
+`end_zmq_sub_socket <http://github.com/LCPQ/quantum_package/tree/master/plugins/Full_CI_ZMQ/utils.irp.f#L401>`_
+  Terminate socket on which the results are sent.
+
+
+`end_zmq_to_qp_run_socket <http://github.com/LCPQ/quantum_package/tree/master/plugins/Full_CI_ZMQ/utils.irp.f#L790>`_
+  Terminate the socket from the application to qp_run
+
+
+`fci_zmq <http://github.com/LCPQ/quantum_package/tree/master/plugins/Full_CI_ZMQ/fci_zmq.irp.f#L1>`_
+  Undocumented
+
+
+`fill_buffer_double <http://github.com/LCPQ/quantum_package/tree/master/plugins/Full_CI_ZMQ/selection_double.irp.f#L156>`_
+  Undocumented
+
+
+`fill_buffer_single <http://github.com/LCPQ/quantum_package/tree/master/plugins/Full_CI_ZMQ/selection_single.irp.f#L60>`_
+  Undocumented
+
+
+`full_ci <http://github.com/LCPQ/quantum_package/tree/master/plugins/Full_CI_ZMQ/full_ci_no_skip.irp.f#L1>`_
+  Undocumented
+
+
+`get_d0 <http://github.com/LCPQ/quantum_package/tree/master/plugins/Full_CI_ZMQ/selection_double.irp.f#L582>`_
+  Undocumented
+
+
+`get_d1 <http://github.com/LCPQ/quantum_package/tree/master/plugins/Full_CI_ZMQ/selection_double.irp.f#L413>`_
+  Undocumented
+
+
+`get_d2 <http://github.com/LCPQ/quantum_package/tree/master/plugins/Full_CI_ZMQ/selection_double.irp.f#L295>`_
+  Undocumented
+
+
+`get_m0 <http://github.com/LCPQ/quantum_package/tree/master/plugins/Full_CI_ZMQ/selection_single.irp.f#L279>`_
+  Undocumented
+
+
+`get_m1 <http://github.com/LCPQ/quantum_package/tree/master/plugins/Full_CI_ZMQ/selection_single.irp.f#L217>`_
+  Undocumented
+
+
+`get_m2 <http://github.com/LCPQ/quantum_package/tree/master/plugins/Full_CI_ZMQ/selection_single.irp.f#L158>`_
+  Undocumented
+
+
+`get_mask_phase <http://github.com/LCPQ/quantum_package/tree/master/plugins/Full_CI_ZMQ/selection.irp.f#L36>`_
+  Undocumented
+
+
+`get_phase_bi <http://github.com/LCPQ/quantum_package/tree/master/plugins/Full_CI_ZMQ/selection.irp.f#L87>`_
+  Undocumented
+
+
+`get_task_from_taskserver <http://github.com/LCPQ/quantum_package/tree/master/plugins/Full_CI_ZMQ/utils.irp.f#L737>`_
+  Get a task from the task server
+
+
+h_apply_fci
+  Calls H_apply on the HF determinant and selects all connected single and double
+  excitations (of the same symmetry). Auto-generated by the ``generate_h_apply`` script.
+
+
+h_apply_fci_diexc
+  Undocumented
+
+
+h_apply_fci_diexcorg
+  Generate all double excitations of key_in using the bit masks of holes and
+  particles.
+  Assume N_int is already provided.
+
+
+h_apply_fci_diexcp
+  Undocumented
+
+
+h_apply_fci_mono
+  Calls H_apply on the HF determinant and selects all connected single and double
+  excitations (of the same symmetry). Auto-generated by the ``generate_h_apply`` script.
+
+
+h_apply_fci_mono_diexc
+  Undocumented
+
+
+h_apply_fci_mono_diexcorg
+  Generate all double excitations of key_in using the bit masks of holes and
+  particles.
+  Assume N_int is already provided.
+
+
+h_apply_fci_mono_diexcp
+  Undocumented
+
+
+h_apply_fci_mono_monoexc
+  Generate all single excitations of key_in using the bit masks of holes and
+  particles.
+  Assume N_int is already provided.
+
+
+h_apply_fci_monoexc
+  Generate all single excitations of key_in using the bit masks of holes and
+  particles.
+  Assume N_int is already provided.
+
+
+h_apply_fci_no_selection
+  Calls H_apply on the HF determinant and selects all connected single and double
+  excitations (of the same symmetry). Auto-generated by the ``generate_h_apply`` script.
+
+
+h_apply_fci_no_selection_diexc
+  Undocumented
+
+
+h_apply_fci_no_selection_diexcorg
+  Generate all double excitations of key_in using the bit masks of holes and
+  particles.
+  Assume N_int is already provided.
+
+
+h_apply_fci_no_selection_diexcp
+  Undocumented
+
+
+h_apply_fci_no_selection_monoexc
+  Generate all single excitations of key_in using the bit masks of holes and
+  particles.
+  Assume N_int is already provided.
+
+
+h_apply_fci_no_skip
+  Calls H_apply on the HF determinant and selects all connected single and double
+  excitations (of the same symmetry). Auto-generated by the ``generate_h_apply`` script.
+
+
+h_apply_fci_no_skip_diexc
+  Undocumented
+
+
+h_apply_fci_no_skip_diexcorg
+  Generate all double excitations of key_in using the bit masks of holes and
+  particles.
+  Assume N_int is already provided.
+
+
+h_apply_fci_no_skip_diexcp
+  Undocumented
+
+
+h_apply_fci_no_skip_monoexc
+  Generate all single excitations of key_in using the bit masks of holes and
+  particles.
+  Assume N_int is already provided.
+
+
+h_apply_fci_pt2
+  Calls H_apply on the HF determinant and selects all connected single and double
+  excitations (of the same symmetry). Auto-generated by the ``generate_h_apply`` script.
+
+
+h_apply_fci_pt2_collector
+  Collects results from the selection in an array of generators
+
+
+h_apply_fci_pt2_diexc
+  Undocumented
+
+
+h_apply_fci_pt2_diexcorg
+  Generate all double excitations of key_in using the bit masks of holes and
+  particles.
+  Assume N_int is already provided.
+
+
+h_apply_fci_pt2_diexcp
+  Undocumented
+
+
+h_apply_fci_pt2_monoexc
+  Generate all single excitations of key_in using the bit masks of holes and
+  particles.
+  Assume N_int is already provided.
+
+
+h_apply_fci_pt2_slave
+  Calls H_apply on the HF determinant and selects all connected single and double
+  excitations (of the same symmetry). Auto-generated by the ``generate_h_apply`` script.
+
+
+h_apply_fci_pt2_slave_inproc
+  Computes a buffer using threads
+
+
+h_apply_fci_pt2_slave_tcp
+  Computes a buffer over the network
+
+
+`integral8 <http://github.com/LCPQ/quantum_package/tree/master/plugins/Full_CI_ZMQ/selection.irp.f#L4>`_
+  Undocumented
+
+
+`new_parallel_job <http://github.com/LCPQ/quantum_package/tree/master/plugins/Full_CI_ZMQ/utils.irp.f#L490>`_
+  Start a new parallel job with name 'name'. The slave tasks execute subroutine 'slave'
+
+
+`new_zmq_pair_socket <http://github.com/LCPQ/quantum_package/tree/master/plugins/Full_CI_ZMQ/utils.irp.f#L164>`_
+  Socket on which the collector and the main communicate
+
+
+`new_zmq_pull_socket <http://github.com/LCPQ/quantum_package/tree/master/plugins/Full_CI_ZMQ/utils.irp.f#L224>`_
+  Socket on which the results are sent. If thread is 1, use inproc
+
+
+`new_zmq_push_socket <http://github.com/LCPQ/quantum_package/tree/master/plugins/Full_CI_ZMQ/utils.irp.f#L300>`_
+  Socket on which the results are sent. If thread is 1, use inproc
+
+
+`new_zmq_sub_socket <http://github.com/LCPQ/quantum_package/tree/master/plugins/Full_CI_ZMQ/utils.irp.f#L360>`_
+  Socket to read the state published by the Task server
+
+
+`new_zmq_to_qp_run_socket <http://github.com/LCPQ/quantum_package/tree/master/plugins/Full_CI_ZMQ/utils.irp.f#L126>`_
+  Socket on which the qp_run process replies
+
+
+`past_d1 <http://github.com/LCPQ/quantum_package/tree/master/plugins/Full_CI_ZMQ/selection_double.irp.f#L642>`_
+  Undocumented
+
+
+`past_d2 <http://github.com/LCPQ/quantum_package/tree/master/plugins/Full_CI_ZMQ/selection_double.irp.f#L658>`_
+  Undocumented
+
+
+`provide_everything <http://github.com/LCPQ/quantum_package/tree/master/plugins/Full_CI_ZMQ/selection_slave.irp.f#L14>`_
+  Undocumented
+
+
+`psi_phasemask <http://github.com/LCPQ/quantum_package/tree/master/plugins/Full_CI_ZMQ/selection.irp.f#L14>`_
+  Undocumented
+
+
+`pull_selection_results <http://github.com/LCPQ/quantum_package/tree/master/plugins/Full_CI_ZMQ/run_selection_slave.irp.f#L122>`_
+  Undocumented
+
+
+`push_selection_results <http://github.com/LCPQ/quantum_package/tree/master/plugins/Full_CI_ZMQ/run_selection_slave.irp.f#L87>`_
+  Undocumented
+
+
+`qp_run_address <http://github.com/LCPQ/quantum_package/tree/master/plugins/Full_CI_ZMQ/utils.irp.f#L19>`_
+  Address of the qp_run socket
+  Example : tcp://130.120.229.139:12345
+
+
+`reset_zmq_addresses <http://github.com/LCPQ/quantum_package/tree/master/plugins/Full_CI_ZMQ/utils.irp.f#L67>`_
+  Socket which pulls the results (2)
+
+
+`run_selection_slave <http://github.com/LCPQ/quantum_package/tree/master/plugins/Full_CI_ZMQ/run_selection_slave.irp.f#L2>`_
+  Undocumented
+
+
+`run_wf <http://github.com/LCPQ/quantum_package/tree/master/plugins/Full_CI_ZMQ/selection_slave.irp.f#L19>`_
+  Undocumented
+
+
+`select_connected <http://github.com/LCPQ/quantum_package/tree/master/plugins/Full_CI_ZMQ/selection.irp.f#L58>`_
+  Undocumented
+
+
+`select_doubles <http://github.com/LCPQ/quantum_package/tree/master/plugins/Full_CI_ZMQ/selection_double.irp.f#L2>`_
+  Undocumented
+
+
+`select_singles <http://github.com/LCPQ/quantum_package/tree/master/plugins/Full_CI_ZMQ/selection_single.irp.f#L3>`_
+  Select determinants connected to i_det by H
+
+
+`selection_collector <http://github.com/LCPQ/quantum_package/tree/master/plugins/Full_CI_ZMQ/fci_zmq.irp.f#L167>`_
+  Undocumented
+
+
+`selection_slave <http://github.com/LCPQ/quantum_package/tree/master/plugins/Full_CI_ZMQ/selection_slave.irp.f#L1>`_
+  Helper program to compute the PT2 in distributed mode.
+
+
+`selection_slave_inproc <http://github.com/LCPQ/quantum_package/tree/master/plugins/Full_CI_ZMQ/fci_zmq.irp.f#L160>`_
+  Undocumented
+
+
+`selection_slave_tcp <http://github.com/LCPQ/quantum_package/tree/master/plugins/Full_CI_ZMQ/selection_slave.irp.f#L86>`_
+  Undocumented
+
+
+`sort_selection_buffer <http://github.com/LCPQ/quantum_package/tree/master/plugins/Full_CI_ZMQ/selection_buffer.irp.f#L39>`_
+  Undocumented
+
+
+`splash_p <http://github.com/LCPQ/quantum_package/tree/master/plugins/Full_CI_ZMQ/selection_single.irp.f#L107>`_
+  Undocumented
+
+
+`splash_pq <http://github.com/LCPQ/quantum_package/tree/master/plugins/Full_CI_ZMQ/selection_double.irp.f#L221>`_
+  Undocumented
+
+
+`spot_hasbeen <http://github.com/LCPQ/quantum_package/tree/master/plugins/Full_CI_ZMQ/selection_single.irp.f#L305>`_
+  Undocumented
+
+
+`spot_isinwf <http://github.com/LCPQ/quantum_package/tree/master/plugins/Full_CI_ZMQ/selection_double.irp.f#L684>`_
+  Undocumented
+
+
+`switch_qp_run_to_master <http://github.com/LCPQ/quantum_package/tree/master/plugins/Full_CI_ZMQ/utils.irp.f#L84>`_
+  Address of the master qp_run socket
+  Example : tcp://130.120.229.139:12345
+
+
+`task_done_to_taskserver <http://github.com/LCPQ/quantum_package/tree/master/plugins/Full_CI_ZMQ/utils.irp.f#L708>`_
+  Get a task from the task server
+
+
+`update_energy <http://github.com/LCPQ/quantum_package/tree/master/plugins/Full_CI_ZMQ/selection_slave.irp.f#L63>`_
+  Update energy when it is received from ZMQ
+
+
+`var_pt2_ratio_run <http://github.com/LCPQ/quantum_package/tree/master/plugins/Full_CI_ZMQ/var_pt2_ratio.irp.f#L1>`_
+  Undocumented
+
+
+`wait_for_next_state <http://github.com/LCPQ/quantum_package/tree/master/plugins/Full_CI_ZMQ/utils.irp.f#L855>`_
+  Undocumented
+
+
+`wait_for_state <http://github.com/LCPQ/quantum_package/tree/master/plugins/Full_CI_ZMQ/utils.irp.f#L879>`_
+  Wait for the ZMQ state to be ready
+
+
+`wait_for_states <http://github.com/LCPQ/quantum_package/tree/master/plugins/Full_CI_ZMQ/utils.irp.f#L907>`_
+  Wait for the ZMQ state to be ready
+
+
+`zmq_context <http://github.com/LCPQ/quantum_package/tree/master/plugins/Full_CI_ZMQ/utils.irp.f#L8>`_
+  Context for the ZeroMQ library
+
+
+`zmq_delete_task <http://github.com/LCPQ/quantum_package/tree/master/plugins/Full_CI_ZMQ/utils.irp.f#L813>`_
+  When a task is done, it has to be removed from the list of tasks on the qp_run
+  queue. This guarantees that the results have been received in the pull.
+
+
+`zmq_port <http://github.com/LCPQ/quantum_package/tree/master/plugins/Full_CI_ZMQ/utils.irp.f#L113>`_
+  Return the value of the ZMQ port from the corresponding integer
+
+
+`zmq_port_start <http://github.com/LCPQ/quantum_package/tree/master/plugins/Full_CI_ZMQ/utils.irp.f#L20>`_
+  Address of the qp_run socket
+  Example : tcp://130.120.229.139:12345
+
+
+`zmq_selection <http://github.com/LCPQ/quantum_package/tree/master/plugins/Full_CI_ZMQ/fci_zmq.irp.f#L109>`_
+  Undocumented
+
+
+`zmq_set_running <http://github.com/LCPQ/quantum_package/tree/master/plugins/Full_CI_ZMQ/utils.irp.f#L530>`_
+  Set the job to Running in QP-run
+
+
+`zmq_socket_pair_inproc_address <http://github.com/LCPQ/quantum_package/tree/master/plugins/Full_CI_ZMQ/utils.irp.f#L45>`_
+  Socket which pulls the results (2)
+
+
+`zmq_socket_pull_inproc_address <http://github.com/LCPQ/quantum_package/tree/master/plugins/Full_CI_ZMQ/utils.irp.f#L47>`_
+  Socket which pulls the results (2)
+
+
+`zmq_socket_pull_tcp_address <http://github.com/LCPQ/quantum_package/tree/master/plugins/Full_CI_ZMQ/utils.irp.f#L44>`_
+  Socket which pulls the results (2)
+
+
+`zmq_socket_push_inproc_address <http://github.com/LCPQ/quantum_package/tree/master/plugins/Full_CI_ZMQ/utils.irp.f#L48>`_
+  Socket which pulls the results (2)
+
+
+`zmq_socket_push_tcp_address <http://github.com/LCPQ/quantum_package/tree/master/plugins/Full_CI_ZMQ/utils.irp.f#L46>`_
+  Socket which pulls the results (2)
+
+
+`zmq_socket_sub_tcp_address <http://github.com/LCPQ/quantum_package/tree/master/plugins/Full_CI_ZMQ/utils.irp.f#L49>`_
+  Socket which pulls the results (2)
+
+
+`zmq_state <http://github.com/LCPQ/quantum_package/tree/master/plugins/Full_CI_ZMQ/utils.irp.f#L482>`_
+  Threads executing work through the ZeroMQ interface
+

plugins/Full_CI_ZMQ/energy.irp.f

@@ -0,0 +1,11 @@
+BEGIN_PROVIDER [ double precision, pt2_E0_denominator, (N_states) ]
+ implicit none
+ BEGIN_DOC
+ ! E0 in the denominator of the PT2
+ END_DOC
+ pt2_E0_denominator(1:N_states) = CI_electronic_energy(1:N_states)
+! pt2_E0_denominator(1:N_states) = HF_energy - nuclear_repulsion
+! pt2_E0_denominator(1:N_states) = barycentric_electronic_energy(1:N_states)
+ call write_double(6,pt2_E0_denominator(1)+nuclear_repulsion, 'PT2 Energy denominator')
+END_PROVIDER
+

plugins/Full_CI_ZMQ/fci_zmq.irp.f

@@ -5,11 +5,15 @@ program fci_zmq
   
   double precision, allocatable  :: pt2(:)
   integer                        :: degree
+  integer                        :: n_det_before, to_select
+  double precision               :: threshold_davidson_in
   
   allocate (pt2(N_states))
   
   pt2 = 1.d0
-  diag_algorithm = "Lapack"
+  threshold_davidson_in = threshold_davidson
+  threshold_davidson = threshold_davidson_in * 100.d0
+  SOFT_TOUCH threshold_davidson
   
   if (N_det > N_det_max) then
     call diagonalize_CI
@@ -33,29 +37,11 @@ program fci_zmq
   double precision               :: E_CI_before(N_states)
   
   
-  integer                        :: n_det_before
   print*,'Beginning the selection ...'
   E_CI_before(1:N_states) = CI_energy(1:N_states)
+  n_det_before = 0
   
   do while ( (N_det < N_det_max) .and. (maxval(abs(pt2(1:N_states))) > pt2_max) )
-    n_det_before = N_det
-    call ZMQ_selection(max(1024-N_det, N_det), pt2)
-    
-    PROVIDE  psi_coef
-    PROVIDE  psi_det
-    PROVIDE  psi_det_sorted
-
-    call diagonalize_CI
-    call save_wavefunction
-    
-    if (N_det > N_det_max) then
-      psi_det = psi_det_sorted
-      psi_coef = psi_coef_sorted
-      N_det = N_det_max
-      soft_touch N_det psi_det psi_coef
-      call diagonalize_CI
-      call save_wavefunction
-    endif
     
     print *,  'N_det          = ', N_det
     print *,  'N_states       = ', N_states
@@ -79,13 +65,42 @@ program fci_zmq
       enddo
     endif
     E_CI_before(1:N_states) = CI_energy(1:N_states)
-    call ezfio_set_full_ci_energy(CI_energy)
+    call ezfio_set_full_ci_zmq_energy(CI_energy(1))
+
+    n_det_before = N_det
+    to_select = 2*N_det
+    to_select = max(64-to_select, to_select)
+    to_select = min(to_select, N_det_max-n_det_before)
+    call ZMQ_selection(to_select, pt2)
+    
+    PROVIDE  psi_coef
+    PROVIDE  psi_det
+    PROVIDE  psi_det_sorted
+
+    if (N_det == N_det_max) then
+      threshold_davidson = threshold_davidson_in
+      SOFT_TOUCH threshold_davidson
+    endif
+    call diagonalize_CI
+    call save_wavefunction
+    call ezfio_set_full_ci_zmq_energy(CI_energy(1))
   enddo
 
+  if (N_det < N_det_max) then
+      threshold_davidson = threshold_davidson_in
+      SOFT_TOUCH threshold_davidson
+      call diagonalize_CI
+      call save_wavefunction
+      call ezfio_set_full_ci_zmq_energy(CI_energy(1))
+  endif
+
   if(do_pt2_end)then
     print*,'Last iteration only to compute the PT2'
+    !threshold_selectors = max(threshold_selectors,threshold_selectors_pt2)
+    !threshold_generators = max(threshold_generators,threshold_generators_pt2)
+    !TOUCH threshold_selectors threshold_generators
     threshold_selectors = 1.d0
-    threshold_generators = 1d0 ! 0.9999d0
+    threshold_generators = 1d0 
     E_CI_before(1:N_states) = CI_energy(1:N_states)
     !call ZMQ_selection(0, pt2)! pour non-stochastic
     call ZMQ_pt2(pt2)
@@ -99,9 +114,11 @@ program fci_zmq
       print *,  'E+PT2    = ', E_CI_before+pt2
       print *,  '-----'
     enddo
-    call ezfio_set_full_ci_energy_pt2(E_CI_before+pt2)
+    call ezfio_set_full_ci_zmq_energy_pt2(E_CI_before(1)+pt2(1))
   endif
   call save_wavefunction
+  call ezfio_set_full_ci_zmq_energy(CI_energy(1))
+  call ezfio_set_full_ci_zmq_energy_pt2(E_CI_before(1)+pt2(1))
 end
 
 

plugins/Full_CI_ZMQ/run_selection_slave.irp.f

@@ -4,7 +4,7 @@ subroutine run_selection_slave(thread,iproc,energy)
   use selection_types
   implicit none
 
-  double precision, intent(in)    :: energy(N_states_diag)
+  double precision, intent(in)    :: energy(N_states)
   integer,  intent(in)            :: thread, iproc
   integer                        :: rc, i
 

plugins/Full_CI_ZMQ/selection_davidson_slave.irp.f

@@ -13,7 +13,7 @@ end
 
 subroutine provide_everything
   PROVIDE H_apply_buffer_allocated mo_bielec_integrals_in_map psi_det_generators psi_coef_generators psi_det_sorted_bit psi_selectors n_det_generators n_states generators_bitmask zmq_context mo_mono_elec_integral
-!   PROVIDE ci_electronic_energy mo_tot_num N_int
+!   PROVIDE pt2_e0_denominator mo_tot_num N_int
 end
 
 subroutine run_wf
@@ -22,7 +22,7 @@ subroutine run_wf
 
   integer(ZMQ_PTR), external :: new_zmq_to_qp_run_socket
   integer(ZMQ_PTR) :: zmq_to_qp_run_socket
-  double precision :: energy(N_states_diag)
+  double precision :: energy(N_states)
   character*(64) :: states(2)
   integer :: rc, i
   
@@ -48,7 +48,7 @@ subroutine run_wf
       ! ---------
 
       print *,  'Selection'
-      call zmq_get_psi(zmq_to_qp_run_socket,1,energy,N_states_diag)
+      call zmq_get_psi(zmq_to_qp_run_socket,1,energy,N_states)
   
       !$OMP PARALLEL PRIVATE(i)
       i = omp_get_thread_num()
@@ -76,7 +76,7 @@ end
 
 subroutine update_energy(energy)
   implicit none
-  double precision, intent(in) :: energy(N_states_diag)
+  double precision, intent(in) :: energy(N_states)
   BEGIN_DOC
 ! Update energy when it is received from ZMQ
   END_DOC
@@ -88,7 +88,7 @@ subroutine update_energy(energy)
   enddo
   call u_0_S2_u_0(CI_eigenvectors_s2,CI_eigenvectors,N_det,psi_det,N_int)
   if (.True.) then
-    do k=1,size(ci_electronic_energy)
+    do k=1,N_states
       ci_electronic_energy(k) = energy(k)
     enddo
     TOUCH ci_electronic_energy CI_eigenvectors_s2 CI_eigenvectors
@@ -99,7 +99,7 @@ end
 
 subroutine selection_slave_tcp(i,energy)
   implicit none
-  double precision, intent(in) :: energy(N_states_diag)
+  double precision, intent(in) :: energy(N_states)
   integer, intent(in)            :: i
 
   call run_selection_slave(0,i,energy)

plugins/Full_CI_ZMQ/selection_slave.irp.f

@@ -13,7 +13,7 @@ end
 
 subroutine provide_everything
   PROVIDE H_apply_buffer_allocated mo_bielec_integrals_in_map psi_det_generators psi_coef_generators psi_det_sorted_bit psi_selectors n_det_generators n_states generators_bitmask zmq_context
-!   PROVIDE ci_electronic_energy mo_tot_num N_int
+   PROVIDE pt2_e0_denominator mo_tot_num N_int
 end
 
 subroutine run_wf
@@ -22,7 +22,7 @@ subroutine run_wf
 
   integer(ZMQ_PTR), external :: new_zmq_to_qp_run_socket
   integer(ZMQ_PTR) :: zmq_to_qp_run_socket
-  double precision :: energy(N_states_diag)
+  double precision :: energy(N_states)
   character*(64) :: states(1)
   integer :: rc, i
   
@@ -47,7 +47,7 @@ subroutine run_wf
       ! ---------
 
       print *,  'Selection'
-      call zmq_get_psi(zmq_to_qp_run_socket,1,energy,N_states_diag)
+      call zmq_get_psi(zmq_to_qp_run_socket,1,energy,N_states)
   
       !$OMP PARALLEL PRIVATE(i)
       i = omp_get_thread_num()
@@ -62,7 +62,7 @@ end
 
 subroutine update_energy(energy)
   implicit none
-  double precision, intent(in) :: energy(N_states_diag)
+  double precision, intent(in) :: energy(N_states)
   BEGIN_DOC
 ! Update energy when it is received from ZMQ
   END_DOC
@@ -74,7 +74,7 @@ subroutine update_energy(energy)
   enddo
   call u_0_S2_u_0(CI_eigenvectors_s2,CI_eigenvectors,N_det,psi_det,N_int)
   if (.True.) then
-    do k=1,size(ci_electronic_energy)
+    do k=1,N_states
       ci_electronic_energy(k) = energy(k)
     enddo
     TOUCH ci_electronic_energy CI_eigenvectors_s2 CI_eigenvectors
@@ -85,7 +85,7 @@ end
 
 subroutine selection_slave_tcp(i,energy)
   implicit none
-  double precision, intent(in) :: energy(N_states_diag)
+  double precision, intent(in) :: energy(N_states)
   integer, intent(in)            :: i
 
   call run_selection_slave(0,i,energy)

plugins/Full_CI_ZMQ/target_pt2_ratio_zmq.irp.f

@@ -0,0 +1,105 @@
+program fci_zmq
+  implicit none
+  integer                        :: i,j,k
+  logical, external              :: detEq
+  
+  double precision, allocatable  :: pt2(:)
+  integer                        :: Nmin, Nmax
+  integer                        :: n_det_before, to_select
+  double precision               :: threshold_davidson_in, ratio, E_ref
+
+  double precision, allocatable  :: psi_coef_ref(:,:)
+  integer(bit_kind), allocatable :: psi_det_ref(:,:,:)
+
+  
+  allocate (pt2(N_states))
+  
+  pt2 = 1.d0
+  threshold_davidson_in = threshold_davidson
+  threshold_davidson = threshold_davidson_in * 100.d0
+  SOFT_TOUCH threshold_davidson 
+  
+  ! Stopping criterion is the PT2max
+
+  double precision               :: E_CI_before(N_states)
+  do while (dabs(pt2(1)) > pt2_max)
+    print *,  'N_det          = ', N_det
+    print *,  'N_states       = ', N_states
+    do k=1, N_states
+      print*,'State ',k
+      print *,  'PT2            = ', pt2(k)
+      print *,  'E              = ', CI_energy(k)
+      print *,  'E(before)+PT2  = ', E_CI_before(k)+pt2(k)
+    enddo
+    print *,  '-----'
+    E_CI_before(1:N_states) = CI_energy(1:N_states)
+    call ezfio_set_full_ci_zmq_energy(CI_energy(1))
+
+    n_det_before = N_det
+    to_select = N_det
+    to_select = max(64-to_select, to_select)
+    call ZMQ_selection(to_select, pt2)
+    
+    PROVIDE  psi_coef
+    PROVIDE  psi_det
+    PROVIDE  psi_det_sorted
+
+    call diagonalize_CI
+    call save_wavefunction
+    call ezfio_set_full_ci_zmq_energy(CI_energy(1))
+  enddo
+
+  threshold_selectors = max(threshold_selectors,threshold_selectors_pt2)
+  threshold_generators = max(threshold_generators,threshold_generators_pt2)
+  threshold_davidson = threshold_davidson_in
+  TOUCH threshold_selectors threshold_generators threshold_davidson
+  call diagonalize_CI
+  call ZMQ_selection(0, pt2)
+
+  E_ref = CI_energy(1) + pt2(1)
+  print *,  'Est FCI   = ', E_ref
+
+  Nmax = N_det
+  Nmin = 2
+  allocate (psi_coef_ref(size(psi_coef_sorted,1),size(psi_coef_sorted,2)))
+  allocate (psi_det_ref(N_int,2,size(psi_det_sorted,3)))
+  psi_coef_ref = psi_coef_sorted
+  psi_det_ref = psi_det_sorted
+  psi_det = psi_det_sorted
+  psi_coef = psi_coef_sorted
+  TOUCH psi_coef psi_det
+  do while (Nmax-Nmin > 1)
+    psi_coef = psi_coef_ref
+    psi_det  = psi_det_ref
+    TOUCH psi_det psi_coef
+    call diagonalize_CI
+    ratio = (CI_energy(1) - HF_energy) / (E_ref - HF_energy)
+    if (ratio < var_pt2_ratio) then
+        Nmin = N_det
+    else
+        Nmax = N_det
+    endif
+    N_det = Nmin + (Nmax-Nmin)/2
+    print *,  '-----'
+    print *,  'Det min, Det max: ', Nmin, Nmax
+    print *,  'Ratio           : ', ratio, '  ~  ', var_pt2_ratio
+    print *,  'N_det     = ', N_det
+    print *,  'E         = ', CI_energy(1)
+  enddo
+  call ZMQ_selection(0, pt2)
+  print *,  '------'
+  print *,  'HF_energy = ', HF_energy
+  print *,  'Est FCI   = ', E_ref
+  print *,  'E         = ', CI_energy(1)
+  print *,  'PT2       = ', pt2(1)
+  print *,  'E+PT2     = ', CI_energy(1)+pt2(1)
+
+  E_CI_before(1:N_states) = CI_energy(1:N_states)
+  call save_wavefunction
+  call ezfio_set_full_ci_zmq_energy(CI_energy(1))
+  call ezfio_set_full_ci_zmq_energy_pt2(E_CI_before(1)+pt2(1))
+end
+
+
+
+

plugins/Full_CI_ZMQ/target_pt2_zmq.irp.f

@@ -0,0 +1,95 @@
+program fci_zmq
+  implicit none
+  integer                        :: i,j,k
+  logical, external              :: detEq
+  
+  double precision, allocatable  :: pt2(:)
+  integer                        :: Nmin, Nmax
+  integer                        :: n_det_before, to_select
+  double precision               :: threshold_davidson_in, ratio, E_ref, pt2_ratio
+  
+  allocate (pt2(N_states))
+  
+  pt2 = 1.d0
+  threshold_davidson_in = threshold_davidson
+  threshold_davidson = threshold_davidson_in * 100.d0
+  SOFT_TOUCH threshold_davidson 
+  
+  double precision               :: E_CI_before(N_states)
+  do while (dabs(pt2(1)) > pt2_max)
+    print *,  'N_det          = ', N_det
+    print *,  'N_states       = ', N_states
+    do k=1, N_states
+      print*,'State ',k
+      print *,  'PT2            = ', pt2(k)
+      print *,  'E              = ', CI_energy(k)
+      print *,  'E(before)+PT2  = ', E_CI_before(k)+pt2(k)
+    enddo
+    print *,  '-----'
+    E_CI_before(1:N_states) = CI_energy(1:N_states)
+    call ezfio_set_full_ci_zmq_energy(CI_energy(1))
+
+    n_det_before = N_det
+    to_select = N_det
+    to_select = max(64-to_select, to_select)
+    call ZMQ_selection(to_select, pt2)
+    
+    PROVIDE  psi_coef
+    PROVIDE  psi_det
+    PROVIDE  psi_det_sorted
+
+    call diagonalize_CI
+    call save_wavefunction
+    call ezfio_set_full_ci_zmq_energy(CI_energy(1))
+  enddo
+
+  threshold_selectors = max(threshold_selectors,threshold_selectors_pt2)
+  threshold_generators = max(threshold_generators,threshold_generators_pt2)
+  threshold_davidson = threshold_davidson_in
+  TOUCH threshold_selectors threshold_generators threshold_davidson
+  call diagonalize_CI
+  call ZMQ_selection(0, pt2)
+
+  E_ref = CI_energy(1) + pt2(1)
+  pt2_ratio = (E_ref + pt2_max - HF_energy) / (E_ref - HF_energy)
+  print *,  'Est FCI   = ', E_ref
+
+  Nmax = N_det
+  Nmin = N_det/8
+  do while (Nmax-Nmin > 1)
+    call diagonalize_CI
+    ratio = (CI_energy(1) - HF_energy) / (E_ref - HF_energy)
+    psi_det = psi_det_sorted
+    psi_coef = psi_coef_sorted
+    TOUCH psi_coef psi_det
+    if (ratio < pt2_ratio) then
+        Nmin = N_det
+        to_select = (Nmax-Nmin)/2
+        call ZMQ_selection(to_select, pt2)
+    else
+        Nmax = N_det
+        N_det = Nmin + (Nmax-Nmin)/2
+    endif
+    print *,  '-----'
+    print *,  'Det min, Det max: ', Nmin, Nmax
+    print *,  'Ratio           : ', ratio, '  ~  ', pt2_ratio
+    print *,  'HF_energy = ', HF_energy
+    print *,  'Est FCI   = ', E_ref
+    print *,  'N_det     = ', N_det
+    print *,  'E         = ', CI_energy(1)
+    print *,  'PT2       = ', pt2(1)
+  enddo
+  call ZMQ_selection(0, pt2)
+  print *,  '------'
+  print *,  'E         = ', CI_energy(1)
+  print *,  'PT2       = ', pt2(1)
+
+  E_CI_before(1:N_states) = CI_energy(1:N_states)
+  call save_wavefunction
+  call ezfio_set_full_ci_zmq_energy(CI_energy(1))
+  call ezfio_set_full_ci_zmq_energy_pt2(E_CI_before(1)+pt2(1))
+end
+
+
+
+

plugins/Full_CI_ZMQ/zmq_selection.irp.f

@@ -0,0 +1,117 @@
+subroutine ZMQ_selection(N_in, pt2)
+  use f77_zmq
+  use selection_types
+  
+  implicit none
+  
+  character*(512)                :: task 
+  integer(ZMQ_PTR)               :: zmq_to_qp_run_socket 
+  integer, intent(in)            :: N_in
+  type(selection_buffer)         :: b
+  integer                        :: i, N
+  integer, external              :: omp_get_thread_num
+  double precision, intent(out)  :: pt2(N_states)
+  
+  
+  if (.True.) then
+    PROVIDE pt2_e0_denominator
+    N = max(N_in,1)
+    provide nproc
+    call new_parallel_job(zmq_to_qp_run_socket,"selection")
+    call zmq_put_psi(zmq_to_qp_run_socket,1,pt2_e0_denominator,size(pt2_e0_denominator))
+    call zmq_set_running(zmq_to_qp_run_socket)
+    call create_selection_buffer(N, N*2, b)
+  endif
+
+  integer :: i_generator, i_generator_start, i_generator_max, step
+!  step = int(max(1.,10*elec_num/mo_tot_num)
+
+  step = int(5000000.d0 / dble(N_int * N_states * elec_num * elec_num * mo_tot_num * mo_tot_num ))
+  step = max(1,step)
+  do i= 1, N_det_generators,step
+    i_generator_start = i
+    i_generator_max = min(i+step-1,N_det_generators)
+    write(task,*) i_generator_start, i_generator_max, 1, N
+    call add_task_to_taskserver(zmq_to_qp_run_socket,task)
+  end do
+
+  !$OMP PARALLEL DEFAULT(shared)  SHARED(b, pt2)  PRIVATE(i) NUM_THREADS(nproc+1)
+  i = omp_get_thread_num()
+  if (i==0) then
+    call selection_collector(b, pt2)
+  else
+    call selection_slave_inproc(i)
+  endif
+  !$OMP END PARALLEL
+  call end_parallel_job(zmq_to_qp_run_socket, 'selection')
+  if (N_in > 0) then
+    call fill_H_apply_buffer_no_selection(b%cur,b%det,N_int,0) !!! PAS DE ROBIN
+    call copy_H_apply_buffer_to_wf()
+    if (s2_eig) then
+      call make_s2_eigenfunction
+    endif
+  endif
+end subroutine
+
+
+subroutine selection_slave_inproc(i)
+  implicit none
+  integer, intent(in)            :: i
+
+  call run_selection_slave(1,i,pt2_e0_denominator)
+end
+
+subroutine selection_collector(b, pt2)
+  use f77_zmq
+  use selection_types
+  use bitmasks
+  implicit none
+
+
+  type(selection_buffer), intent(inout) :: b
+  double precision, intent(out)       :: pt2(N_states)
+  double precision                   :: pt2_mwen(N_states)
+  integer(ZMQ_PTR),external      :: new_zmq_to_qp_run_socket
+  integer(ZMQ_PTR)               :: zmq_to_qp_run_socket
+
+  integer(ZMQ_PTR), external     :: new_zmq_pull_socket
+  integer(ZMQ_PTR)               :: zmq_socket_pull
+
+  integer :: msg_size, rc, more
+  integer :: acc, i, j, robin, N, ntask
+  double precision, allocatable :: val(:)
+  integer(bit_kind), allocatable :: det(:,:,:)
+  integer, allocatable :: task_id(:)
+  integer :: done
+  real :: time, time0
+  zmq_to_qp_run_socket = new_zmq_to_qp_run_socket()
+  zmq_socket_pull = new_zmq_pull_socket()
+  allocate(val(b%N), det(N_int, 2, b%N), task_id(N_det))
+  done = 0
+  more = 1
+  pt2(:) = 0d0
+  call CPU_TIME(time0)
+  do while (more == 1)
+    call pull_selection_results(zmq_socket_pull, pt2_mwen, val(1), det(1,1,1), N, task_id, ntask)
+    pt2 += pt2_mwen
+    do i=1, N
+      call add_to_selection_buffer(b, det(1,1,i), val(i))
+    end do
+
+    do i=1, ntask
+      if(task_id(i) == 0) then
+          print *,  "Error in collector"
+      endif
+      call zmq_delete_task(zmq_to_qp_run_socket,zmq_socket_pull,task_id(i),more)
+    end do
+    done += ntask
+    call CPU_TIME(time)
+!    print *, "DONE" , done, time - time0
+  end do
+
+
+  call end_zmq_to_qp_run_socket(zmq_to_qp_run_socket)
+  call end_zmq_pull_socket(zmq_socket_pull)
+  call sort_selection_buffer(b)
+end subroutine
+

plugins/Generators_full/README.rst

@@ -33,7 +33,7 @@ Documentation
 .. by the `update_README.py` script.
 
 
-`degree_max_generators <http://github.com/LCPQ/quantum_package/tree/master/plugins/Generators_full/generators.irp.f#L43>`_
+`degree_max_generators <http://github.com/LCPQ/quantum_package/tree/master/plugins/Generators_full/generators.irp.f#L45>`_
   Max degree of excitation (respect to HF) of the generators
 
 
@@ -52,10 +52,10 @@ Documentation
   Hartree-Fock determinant
 
 
-`select_max <http://github.com/LCPQ/quantum_package/tree/master/plugins/Generators_full/generators.irp.f#L66>`_
+`select_max <http://github.com/LCPQ/quantum_package/tree/master/plugins/Generators_full/generators.irp.f#L68>`_
   Memo to skip useless selectors
 
 
-`size_select_max <http://github.com/LCPQ/quantum_package/tree/master/plugins/Generators_full/generators.irp.f#L58>`_
+`size_select_max <http://github.com/LCPQ/quantum_package/tree/master/plugins/Generators_full/generators.irp.f#L60>`_
   Size of the select_max array
 

plugins/Hartree_Fock/README.rst

@@ -67,11 +67,11 @@ Documentation
   Alpha Fock matrix in AO basis set
 
 
-`fock_matrix_alpha_mo <http://github.com/LCPQ/quantum_package/tree/master/plugins/Hartree_Fock/Fock_matrix.irp.f#L268>`_
+`fock_matrix_alpha_mo <http://github.com/LCPQ/quantum_package/tree/master/plugins/Hartree_Fock/Fock_matrix.irp.f#L269>`_
   Fock matrix on the MO basis
 
 
-`fock_matrix_ao <http://github.com/LCPQ/quantum_package/tree/master/plugins/Hartree_Fock/Fock_matrix.irp.f#L326>`_
+`fock_matrix_ao <http://github.com/LCPQ/quantum_package/tree/master/plugins/Hartree_Fock/Fock_matrix.irp.f#L327>`_
   Fock matrix in AO basis set
 
 
@@ -79,7 +79,7 @@ Documentation
   Alpha Fock matrix in AO basis set
 
 
-`fock_matrix_beta_mo <http://github.com/LCPQ/quantum_package/tree/master/plugins/Hartree_Fock/Fock_matrix.irp.f#L288>`_
+`fock_matrix_beta_mo <http://github.com/LCPQ/quantum_package/tree/master/plugins/Hartree_Fock/Fock_matrix.irp.f#L289>`_
   Fock matrix on the MO basis
 
 
@@ -115,7 +115,7 @@ Documentation
   .br
 
 
-`fock_mo_to_ao <http://github.com/LCPQ/quantum_package/tree/master/plugins/Hartree_Fock/Fock_matrix.irp.f#L388>`_
+`fock_mo_to_ao <http://github.com/LCPQ/quantum_package/tree/master/plugins/Hartree_Fock/Fock_matrix.irp.f#L389>`_
   Undocumented
 
 
@@ -135,7 +135,7 @@ Documentation
   S^-1 Beta density matrix in the AO basis x S^-1
 
 
-`hf_energy <http://github.com/LCPQ/quantum_package/tree/master/plugins/Hartree_Fock/Fock_matrix.irp.f#L307>`_
+`hf_energy <http://github.com/LCPQ/quantum_package/tree/master/plugins/Hartree_Fock/Fock_matrix.irp.f#L308>`_
   Hartree-Fock energy
 
 

plugins/MP2/mp2.irp.f

@@ -1,4 +1,10 @@
 program mp2
+  no_vvvv_integrals = .True.
+  SOFT_TOUCH no_vvvv_integrals
+  call run
+end
+
+subroutine run
   implicit none
   double precision, allocatable  :: pt2(:), norm_pert(:)
   double precision               :: H_pert_diag, E_old

plugins/MP2/mp2_wf.irp.f

@@ -1,4 +1,10 @@
 program mp2_wf
+  no_vvvv_integrals = .True.
+  SOFT_TOUCH no_vvvv_integrals
+  call run
+end
+
+subroutine run
   implicit none
   BEGIN_DOC
 ! Save the MP2 wave function

plugins/MRCC_Utils/.gitignore

@@ -3,6 +3,7 @@
 .ninja_log
 AO_Basis
 Bitmask
+Davidson
 Determinants
 Electrons
 Ezfio_files

plugins/MRCC_Utils/README.rst

@@ -36,11 +36,19 @@ Documentation
   Compute 1st dimension such that it is aligned for vectorization.
 
 
-`apply_rotation <http://github.com/LCPQ/quantum_package/tree/master/plugins/MRCC_Utils/LinearAlgebra.irp.f#L283>`_
+`apply_hole_local <http://github.com/LCPQ/quantum_package/tree/master/plugins/MRCC_Utils/mrcc_utils.irp.f#L1282>`_
+  Undocumented
+
+
+`apply_particle_local <http://github.com/LCPQ/quantum_package/tree/master/plugins/MRCC_Utils/mrcc_utils.irp.f#L1319>`_
+  Undocumented
+
+
+`apply_rotation <http://github.com/LCPQ/quantum_package/tree/master/plugins/MRCC_Utils/LinearAlgebra.irp.f#L320>`_
   Apply the rotation found by find_rotation
 
 
-`approx_dble <http://github.com/LCPQ/quantum_package/tree/master/plugins/MRCC_Utils/util.irp.f#L382>`_
+`approx_dble <http://github.com/LCPQ/quantum_package/tree/master/plugins/MRCC_Utils/util.irp.f#L371>`_
   Undocumented
 
 
@@ -63,23 +71,23 @@ Documentation
   Binomial coefficients
 
 
-`ci_eigenvectors_dressed <http://github.com/LCPQ/quantum_package/tree/master/plugins/MRCC_Utils/mrcc_utils.irp.f#L105>`_
-  Eigenvectors/values of the CI matrix
+`ci_eigenvectors_dressed <http://github.com/LCPQ/quantum_package/tree/master/plugins/MRCC_Utils/mrcc_utils.irp.f#L120>`_
+  Eigenvectors/values of the dressed CI matrix
 
 
-`ci_eigenvectors_s2_dressed <http://github.com/LCPQ/quantum_package/tree/master/plugins/MRCC_Utils/mrcc_utils.irp.f#L106>`_
-  Eigenvectors/values of the CI matrix
+`ci_eigenvectors_s2_dressed <http://github.com/LCPQ/quantum_package/tree/master/plugins/MRCC_Utils/mrcc_utils.irp.f#L121>`_
+  Eigenvectors/values of the dressed CI matrix
 
 
-`ci_electronic_energy_dressed <http://github.com/LCPQ/quantum_package/tree/master/plugins/MRCC_Utils/mrcc_utils.irp.f#L104>`_
-  Eigenvectors/values of the CI matrix
+`ci_electronic_energy_dressed <http://github.com/LCPQ/quantum_package/tree/master/plugins/MRCC_Utils/mrcc_utils.irp.f#L119>`_
+  Eigenvectors/values of the dressed CI matrix
 
 
-`ci_energy_dressed <http://github.com/LCPQ/quantum_package/tree/master/plugins/MRCC_Utils/mrcc_utils.irp.f#L171>`_
+`ci_energy_dressed <http://github.com/LCPQ/quantum_package/tree/master/plugins/MRCC_Utils/mrcc_utils.irp.f#L247>`_
   N_states lowest eigenvalues of the dressed CI matrix
 
 
-`davidson_diag_hjj_mrcc <http://github.com/LCPQ/quantum_package/tree/master/plugins/MRCC_Utils/davidson.irp.f#L59>`_
+`davidson_diag_hjj_mrcc <http://github.com/LCPQ/quantum_package/tree/master/plugins/MRCC_Utils/davidson.irp.f#L57>`_
   Davidson diagonalization with specific diagonal elements of the H matrix
   .br
   H_jj : specific diagonal H matrix elements to diagonalize de Davidson
@@ -95,12 +103,39 @@ Documentation
   .br
   N_st : Number of eigenstates
   .br
+  N_st_diag : Number of states in which H is diagonalized
+  .br
   iunit : Unit for the I/O
   .br
   Initial guess vectors are not necessarily orthonormal
 
 
-`davidson_diag_mrcc <http://github.com/LCPQ/quantum_package/tree/master/plugins/MRCC_Utils/davidson.irp.f#L4>`_
+`davidson_diag_hjj_sjj_mrcc <http://github.com/LCPQ/quantum_package/tree/master/plugins/MRCC_Utils/davidson.irp.f#L610>`_
+  Davidson diagonalization with specific diagonal elements of the H matrix
+  .br
+  H_jj : specific diagonal H matrix elements to diagonalize de Davidson
+  .br
+  S2_jj : specific diagonal S^2 matrix elements
+  .br
+  dets_in : bitmasks corresponding to determinants
+  .br
+  u_in : guess coefficients on the various states. Overwritten
+  on exit
+  .br
+  dim_in : leftmost dimension of u_in
+  .br
+  sze : Number of determinants
+  .br
+  N_st : Number of eigenstates
+  .br
+  N_st_diag : Number of states in which H is diagonalized. Assumed > sze
+  .br
+  iunit : Unit for the I/O
+  .br
+  Initial guess vectors are not necessarily orthonormal
+
+
+`davidson_diag_mrcc <http://github.com/LCPQ/quantum_package/tree/master/plugins/MRCC_Utils/davidson.irp.f#L1>`_
   Davidson diagonalization.
   .br
   dets_in : bitmasks corresponding to determinants
@@ -119,19 +154,38 @@ Documentation
   Initial guess vectors are not necessarily orthonormal
 
 
-`dble_fact <http://github.com/LCPQ/quantum_package/tree/master/plugins/MRCC_Utils/util.irp.f#L138>`_
+`davidson_diag_mrcc_hs2 <http://github.com/LCPQ/quantum_package/tree/master/plugins/MRCC_Utils/davidson.irp.f#L552>`_
+  Davidson diagonalization.
+  .br
+  dets_in : bitmasks corresponding to determinants
+  .br
+  u_in : guess coefficients on the various states. Overwritten
+  on exit
+  .br
+  dim_in : leftmost dimension of u_in
+  .br
+  sze : Number of determinants
+  .br
+  N_st : Number of eigenstates
+  .br
+  iunit : Unit number for the I/O
+  .br
+  Initial guess vectors are not necessarily orthonormal
+
+
+`dble_fact <http://github.com/LCPQ/quantum_package/tree/master/plugins/MRCC_Utils/util.irp.f#L136>`_
   Undocumented
 
 
-`dble_fact_even <http://github.com/LCPQ/quantum_package/tree/master/plugins/MRCC_Utils/util.irp.f#L155>`_
+`dble_fact_even <http://github.com/LCPQ/quantum_package/tree/master/plugins/MRCC_Utils/util.irp.f#L153>`_
   n!!
 
 
-`dble_fact_odd <http://github.com/LCPQ/quantum_package/tree/master/plugins/MRCC_Utils/util.irp.f#L176>`_
+`dble_fact_odd <http://github.com/LCPQ/quantum_package/tree/master/plugins/MRCC_Utils/util.irp.f#L197>`_
   n!!
 
 
-`dble_logfact <http://github.com/LCPQ/quantum_package/tree/master/plugins/MRCC_Utils/util.irp.f#L210>`_
+`dble_logfact <http://github.com/LCPQ/quantum_package/tree/master/plugins/MRCC_Utils/util.irp.f#L231>`_
   n!!
 
 
@@ -139,19 +193,23 @@ Documentation
   Undocumented
 
 
-`delta_ii <http://github.com/LCPQ/quantum_package/tree/master/plugins/MRCC_Utils/mrcc_utils.irp.f#L68>`_
-  Dressing matrix in N_det basis
+`dec_exc <http://github.com/LCPQ/quantum_package/tree/master/plugins/MRCC_Utils/mrcc_utils.irp.f#L532>`_
+  Undocumented
 
 
-`delta_ij <http://github.com/LCPQ/quantum_package/tree/master/plugins/MRCC_Utils/mrcc_utils.irp.f#L67>`_
-  Dressing matrix in N_det basis
-
-
-`diagonalize_ci_dressed <http://github.com/LCPQ/quantum_package/tree/master/plugins/MRCC_Utils/mrcc_utils.irp.f#L186>`_
+`diagonalize_ci_dressed <http://github.com/LCPQ/quantum_package/tree/master/plugins/MRCC_Utils/mrcc_utils.irp.f#L265>`_
   Replace the coefficients of the CI states by the coefficients of the
   eigenstates of the CI matrix
 
 
+`dij <http://github.com/LCPQ/quantum_package/tree/master/plugins/MRCC_Utils/mrcc_utils.irp.f#L1092>`_
+  Undocumented
+
+
+`dij_unique <http://github.com/LCPQ/quantum_package/tree/master/plugins/MRCC_Utils/mrcc_utils.irp.f#L617>`_
+  Undocumented
+
+
 `dset_order <http://github.com/LCPQ/quantum_package/tree/master/plugins/MRCC_Utils/sort.irp.f_template_216#L27>`_
   array A has already been sorted, and iorder has contains the new order of
   elements of A. This subroutine changes the order of x to match the new order of A.
@@ -170,10 +228,26 @@ Documentation
   contains the new order of the elements.
 
 
+`dtranspose <http://github.com/LCPQ/quantum_package/tree/master/plugins/MRCC_Utils/transpose.irp.f#L41>`_
+  Transpose input matrix A into output matrix B
+
+
 `erf0 <http://github.com/LCPQ/quantum_package/tree/master/plugins/MRCC_Utils/need.irp.f#L105>`_
   Undocumented
 
 
+`exc_inf <http://github.com/LCPQ/quantum_package/tree/master/plugins/MRCC_Utils/mrcc_utils.irp.f#L479>`_
+  Undocumented
+
+
+`exccmp <http://github.com/LCPQ/quantum_package/tree/master/plugins/MRCC_Utils/mrcc_utils.irp.f#L1265>`_
+  Undocumented
+
+
+`exceq <http://github.com/LCPQ/quantum_package/tree/master/plugins/MRCC_Utils/mrcc_utils.irp.f#L1253>`_
+  Undocumented
+
+
 `f_integral <http://github.com/LCPQ/quantum_package/tree/master/plugins/MRCC_Utils/integration.irp.f#L408>`_
   function that calculates the following integral
   \int_{\-infty}^{+\infty} x^n \exp(-p x^2) dx
@@ -183,19 +257,19 @@ Documentation
   n!
 
 
-`fact_inv <http://github.com/LCPQ/quantum_package/tree/master/plugins/MRCC_Utils/util.irp.f#L125>`_
+`fact_inv <http://github.com/LCPQ/quantum_package/tree/master/plugins/MRCC_Utils/util.irp.f#L123>`_
   1/n!
 
 
-`find_rotation <http://github.com/LCPQ/quantum_package/tree/master/plugins/MRCC_Utils/LinearAlgebra.irp.f#L264>`_
+`find_rotation <http://github.com/LCPQ/quantum_package/tree/master/plugins/MRCC_Utils/LinearAlgebra.irp.f#L301>`_
   Find A.C = B
 
 
-`find_triples_and_quadruples <http://github.com/LCPQ/quantum_package/tree/master/plugins/MRCC_Utils/mrcc_dress.irp.f#L315>`_
+`find_triples_and_quadruples <http://github.com/LCPQ/quantum_package/tree/master/plugins/MRCC_Utils/mrcc_dress.irp.f#L286>`_
   Undocumented
 
 
-`find_triples_and_quadruples_micro <http://github.com/LCPQ/quantum_package/tree/master/plugins/MRCC_Utils/mrcc_dress.irp.f#L375>`_
+`find_triples_and_quadruples_micro <http://github.com/LCPQ/quantum_package/tree/master/plugins/MRCC_Utils/mrcc_dress.irp.f#L346>`_
   Undocumented
 
 
@@ -221,7 +295,15 @@ Documentation
   Undocumented
 
 
-`get_pseudo_inverse <http://github.com/LCPQ/quantum_package/tree/master/plugins/MRCC_Utils/LinearAlgebra.irp.f#L210>`_
+`get_dij <http://github.com/LCPQ/quantum_package/tree/master/plugins/MRCC_Utils/mrcc_utils.irp.f#L1129>`_
+  Undocumented
+
+
+`get_dij_index <http://github.com/LCPQ/quantum_package/tree/master/plugins/MRCC_Utils/mrcc_utils.irp.f#L1113>`_
+  Undocumented
+
+
+`get_pseudo_inverse <http://github.com/LCPQ/quantum_package/tree/master/plugins/MRCC_Utils/LinearAlgebra.irp.f#L247>`_
   Find C = A^-1
 
 
@@ -306,11 +388,63 @@ h_apply_mrcc_pt2_monoexc
   Assume N_int is already provided.
 
 
-`h_matrix_dressed <http://github.com/LCPQ/quantum_package/tree/master/plugins/MRCC_Utils/mrcc_utils.irp.f#L79>`_
+h_apply_mrcepa_pt2
+  Calls H_apply on the HF determinant and selects all connected single and double
+  excitations (of the same symmetry). Auto-generated by the ``generate_h_apply`` script.
+
+
+h_apply_mrcepa_pt2_collector
+  Collects results from the selection in an array of generators
+
+
+h_apply_mrcepa_pt2_diexc
+  Undocumented
+
+
+h_apply_mrcepa_pt2_diexcorg
+  Generate all double excitations of key_in using the bit masks of holes and
+  particles.
+  Assume N_int is already provided.
+
+
+h_apply_mrcepa_pt2_diexcp
+  Undocumented
+
+
+h_apply_mrcepa_pt2_monoexc
+  Generate all single excitations of key_in using the bit masks of holes and
+  particles.
+  Assume N_int is already provided.
+
+
+h_apply_mrcepa_pt2_slave
+  Calls H_apply on the HF determinant and selects all connected single and double
+  excitations (of the same symmetry). Auto-generated by the ``generate_h_apply`` script.
+
+
+h_apply_mrcepa_pt2_slave_inproc
+  Computes a buffer using threads
+
+
+h_apply_mrcepa_pt2_slave_tcp
+  Computes a buffer over the network
+
+
+`h_matrix_dressed <http://github.com/LCPQ/quantum_package/tree/master/plugins/MRCC_Utils/mrcc_utils.irp.f#L94>`_
   Dressed H with Delta_ij
 
 
-`h_u_0_mrcc <http://github.com/LCPQ/quantum_package/tree/master/plugins/MRCC_Utils/davidson.irp.f#L367>`_
+`h_s2_u_0_mrcc_nstates <http://github.com/LCPQ/quantum_package/tree/master/plugins/MRCC_Utils/davidson.irp.f#L997>`_
+  Computes v_0 = H|u_0> and s_0 = S^2 |u_0>
+  .br
+  n : number of determinants
+  .br
+  H_jj : array of <j|H|j>
+  .br
+  S2_jj : array of <j|S^2|j>
+
+
+`h_u_0_mrcc_nstates <http://github.com/LCPQ/quantum_package/tree/master/plugins/MRCC_Utils/davidson.irp.f#L409>`_
   Computes v_0 = H|u_0>
   .br
   n : number of determinants
@@ -392,7 +526,15 @@ h_apply_mrcc_pt2_monoexc
   Hermite polynomial
 
 
-`hij_mrcc <http://github.com/LCPQ/quantum_package/tree/master/plugins/MRCC_Utils/mrcc_utils.irp.f#L53>`_
+`hh_exists <http://github.com/LCPQ/quantum_package/tree/master/plugins/MRCC_Utils/mrcc_utils.irp.f#L1181>`_
+  Undocumented
+
+
+`hh_shortcut <http://github.com/LCPQ/quantum_package/tree/master/plugins/MRCC_Utils/mrcc_utils.irp.f#L1182>`_
+  Undocumented
+
+
+`hij_mrcc <http://github.com/LCPQ/quantum_package/tree/master/plugins/MRCC_Utils/mrcc_utils.irp.f#L66>`_
   < ref | H | Non-ref > matrix
 
 
@@ -523,7 +665,7 @@ h_apply_mrcc_pt2_monoexc
   to be in integer*8 format
 
 
-`inv_int <http://github.com/LCPQ/quantum_package/tree/master/plugins/MRCC_Utils/util.irp.f#L257>`_
+`inv_int <http://github.com/LCPQ/quantum_package/tree/master/plugins/MRCC_Utils/util.irp.f#L278>`_
   1/i
 
 
@@ -541,6 +683,10 @@ h_apply_mrcc_pt2_monoexc
   iradix should be -1 in input.
 
 
+`is_generable <http://github.com/LCPQ/quantum_package/tree/master/plugins/MRCC_Utils/mrcc_utils.irp.f#L284>`_
+  Undocumented
+
+
 `iset_order <http://github.com/LCPQ/quantum_package/tree/master/plugins/MRCC_Utils/sort.irp.f_template_216#L52>`_
   array A has already been sorted, and iorder has contains the new order of
   elements of A. This subroutine changes the order of x to match the new order of A.
@@ -559,15 +705,19 @@ h_apply_mrcc_pt2_monoexc
   contains the new order of the elements.
 
 
-`lambda_mrcc <http://github.com/LCPQ/quantum_package/tree/master/plugins/MRCC_Utils/mrcc_utils.irp.f#L1>`_
+`lambda_mrcc <http://github.com/LCPQ/quantum_package/tree/master/plugins/MRCC_Utils/mrcc_utils.irp.f#L8>`_
   cm/<Psi_0|H|D_m> or perturbative 1/Delta_E(m)
 
 
-`lambda_mrcc_pt2 <http://github.com/LCPQ/quantum_package/tree/master/plugins/MRCC_Utils/mrcc_utils.irp.f#L2>`_
+`lambda_mrcc_kept <http://github.com/LCPQ/quantum_package/tree/master/plugins/MRCC_Utils/mrcc_utils.irp.f#L10>`_
   cm/<Psi_0|H|D_m> or perturbative 1/Delta_E(m)
 
 
-`lapack_diag <http://github.com/LCPQ/quantum_package/tree/master/plugins/MRCC_Utils/LinearAlgebra.irp.f#L362>`_
+`lambda_mrcc_pt2 <http://github.com/LCPQ/quantum_package/tree/master/plugins/MRCC_Utils/mrcc_utils.irp.f#L9>`_
+  cm/<Psi_0|H|D_m> or perturbative 1/Delta_E(m)
+
+
+`lapack_diag <http://github.com/LCPQ/quantum_package/tree/master/plugins/MRCC_Utils/LinearAlgebra.irp.f#L399>`_
   Diagonalize matrix H
   .br
   H is untouched between input and ouptut
@@ -578,7 +728,7 @@ h_apply_mrcc_pt2_monoexc
   .br
 
 
-`lapack_diag_s2 <http://github.com/LCPQ/quantum_package/tree/master/plugins/MRCC_Utils/LinearAlgebra.irp.f#L425>`_
+`lapack_diag_s2 <http://github.com/LCPQ/quantum_package/tree/master/plugins/MRCC_Utils/LinearAlgebra.irp.f#L462>`_
   Diagonalize matrix H
   .br
   H is untouched between input and ouptut
@@ -589,7 +739,7 @@ h_apply_mrcc_pt2_monoexc
   .br
 
 
-`lapack_diagd <http://github.com/LCPQ/quantum_package/tree/master/plugins/MRCC_Utils/LinearAlgebra.irp.f#L295>`_
+`lapack_diagd <http://github.com/LCPQ/quantum_package/tree/master/plugins/MRCC_Utils/LinearAlgebra.irp.f#L332>`_
   Diagonalize matrix H
   .br
   H is untouched between input and ouptut
@@ -600,7 +750,7 @@ h_apply_mrcc_pt2_monoexc
   .br
 
 
-`lapack_partial_diag <http://github.com/LCPQ/quantum_package/tree/master/plugins/MRCC_Utils/LinearAlgebra.irp.f#L491>`_
+`lapack_partial_diag <http://github.com/LCPQ/quantum_package/tree/master/plugins/MRCC_Utils/LinearAlgebra.irp.f#L528>`_
   Diagonalize matrix H
   .br
   H is untouched between input and ouptut
@@ -611,19 +761,27 @@ h_apply_mrcc_pt2_monoexc
   .br
 
 
-`logfact <http://github.com/LCPQ/quantum_package/tree/master/plugins/MRCC_Utils/util.irp.f#L93>`_
+`logfact <http://github.com/LCPQ/quantum_package/tree/master/plugins/MRCC_Utils/util.irp.f#L91>`_
   n!
 
 
-`lowercase <http://github.com/LCPQ/quantum_package/tree/master/plugins/MRCC_Utils/util.irp.f#L406>`_
+`lowercase <http://github.com/LCPQ/quantum_package/tree/master/plugins/MRCC_Utils/util.irp.f#L395>`_
   Transform to lower case
 
 
+`map_load_from_disk <http://github.com/LCPQ/quantum_package/tree/master/plugins/MRCC_Utils/map_functions.irp.f#L70>`_
+  Undocumented
+
+
+`map_save_to_disk <http://github.com/LCPQ/quantum_package/tree/master/plugins/MRCC_Utils/map_functions.irp.f#L1>`_
+  Undocumented
+
+
 `mrcc_dress <http://github.com/LCPQ/quantum_package/tree/master/plugins/MRCC_Utils/mrcc_dress.irp.f#L17>`_
   Undocumented
 
 
-`mrcc_iterations <http://github.com/LCPQ/quantum_package/tree/master/plugins/MRCC_Utils/mrcc_general.irp.f#L7>`_
+`mrmode <http://github.com/LCPQ/quantum_package/tree/master/plugins/MRCC_Utils/mrcc_utils.irp.f#L3>`_
   Undocumented
 
 
@@ -632,12 +790,24 @@ h_apply_mrcc_pt2_monoexc
   D(t) =! D(t) +( B(t)*C(t))
 
 
-`normalize <http://github.com/LCPQ/quantum_package/tree/master/plugins/MRCC_Utils/util.irp.f#L358>`_
+`n_ex_exists <http://github.com/LCPQ/quantum_package/tree/master/plugins/MRCC_Utils/mrcc_utils.irp.f#L575>`_
+  Undocumented
+
+
+`n_hh_exists <http://github.com/LCPQ/quantum_package/tree/master/plugins/MRCC_Utils/mrcc_utils.irp.f#L573>`_
+  Undocumented
+
+
+`n_pp_exists <http://github.com/LCPQ/quantum_package/tree/master/plugins/MRCC_Utils/mrcc_utils.irp.f#L574>`_
+  Undocumented
+
+
+`normalize <http://github.com/LCPQ/quantum_package/tree/master/plugins/MRCC_Utils/util.irp.f#L348>`_
   Normalizes vector u
   u is expected to be aligned in memory.
 
 
-`nproc <http://github.com/LCPQ/quantum_package/tree/master/plugins/MRCC_Utils/util.irp.f#L283>`_
+`nproc <http://github.com/LCPQ/quantum_package/tree/master/plugins/MRCC_Utils/util.irp.f#L304>`_
   Number of current OpenMP threads
 
 
@@ -659,7 +829,7 @@ h_apply_mrcc_pt2_monoexc
   .br
 
 
-`ortho_lowdin <http://github.com/LCPQ/quantum_package/tree/master/plugins/MRCC_Utils/LinearAlgebra.irp.f#L128>`_
+`ortho_lowdin <http://github.com/LCPQ/quantum_package/tree/master/plugins/MRCC_Utils/LinearAlgebra.irp.f#L162>`_
   Compute C_new=C_old.S^-1/2 orthogonalization.
   .br
   overlap : overlap matrix
@@ -677,6 +847,19 @@ h_apply_mrcc_pt2_monoexc
   .br
 
 
+`ortho_qr <http://github.com/LCPQ/quantum_package/tree/master/plugins/MRCC_Utils/LinearAlgebra.irp.f#L128>`_
+  Orthogonalization using Q.R factorization
+  .br
+  A : matrix to orthogonalize
+  .br
+  LDA : leftmost dimension of A
+  .br
+  n : Number of rows of A
+  .br
+  m : Number of columns of A
+  .br
+
+
 `overlap_a_b_c <http://github.com/LCPQ/quantum_package/tree/master/plugins/MRCC_Utils/one_e_integration.irp.f#L35>`_
   Undocumented
 
@@ -707,6 +890,10 @@ h_apply_mrcc_pt2_monoexc
   Undocumented
 
 
+`pp_exists <http://github.com/LCPQ/quantum_package/tree/master/plugins/MRCC_Utils/mrcc_utils.irp.f#L1183>`_
+  Undocumented
+
+
 `progress_active <http://github.com/LCPQ/quantum_package/tree/master/plugins/MRCC_Utils/progress.irp.f#L29>`_
   Current status for displaying progress bars. Global variable.
 
@@ -727,6 +914,14 @@ h_apply_mrcc_pt2_monoexc
   Current status for displaying progress bars. Global variable.
 
 
+`psi_non_ref_sorted <http://github.com/LCPQ/quantum_package/tree/master/plugins/MRCC_Utils/mrcc_utils.irp.f#L609>`_
+  Undocumented
+
+
+`psi_non_ref_sorted_idx <http://github.com/LCPQ/quantum_package/tree/master/plugins/MRCC_Utils/mrcc_utils.irp.f#L610>`_
+  Undocumented
+
+
 `psi_ref_lock <http://github.com/LCPQ/quantum_package/tree/master/plugins/MRCC_Utils/mrcc_dress.irp.f#L4>`_
   Locks on ref determinants to fill delta_ij
 
@@ -735,6 +930,10 @@ h_apply_mrcc_pt2_monoexc
   Recenter two polynomials
 
 
+`rho_mrcc <http://github.com/LCPQ/quantum_package/tree/master/plugins/MRCC_Utils/mrcc_utils.irp.f#L618>`_
+  Undocumented
+
+
 `rint <http://github.com/LCPQ/quantum_package/tree/master/plugins/MRCC_Utils/integration.irp.f#L436>`_
   .. math::
   .br
@@ -762,10 +961,6 @@ h_apply_mrcc_pt2_monoexc
   Undocumented
 
 
-`run_mrcc <http://github.com/LCPQ/quantum_package/tree/master/plugins/MRCC_Utils/mrcc_general.irp.f#L1>`_
-  Undocumented
-
-
 `run_progress <http://github.com/LCPQ/quantum_package/tree/master/plugins/MRCC_Utils/progress.irp.f#L45>`_
   Display a progress bar with documentation of what is happening
 
@@ -774,7 +969,15 @@ h_apply_mrcc_pt2_monoexc
   Undocumented
 
 
-`set_generators_bitmasks_as_holes_and_particles <http://github.com/LCPQ/quantum_package/tree/master/plugins/MRCC_Utils/mrcc_general.irp.f#L59>`_
+`searchdet <http://github.com/LCPQ/quantum_package/tree/master/plugins/MRCC_Utils/mrcc_utils.irp.f#L337>`_
+  Undocumented
+
+
+`searchexc <http://github.com/LCPQ/quantum_package/tree/master/plugins/MRCC_Utils/mrcc_utils.irp.f#L388>`_
+  Undocumented
+
+
+`set_generators_bitmasks_as_holes_and_particles <http://github.com/LCPQ/quantum_package/tree/master/plugins/MRCC_Utils/mrcc_general.irp.f#L2>`_
   Undocumented
 
 
@@ -790,7 +993,7 @@ h_apply_mrcc_pt2_monoexc
   to be in integer*8 format
 
 
-`set_zero_extra_diag <http://github.com/LCPQ/quantum_package/tree/master/plugins/MRCC_Utils/LinearAlgebra.irp.f#L548>`_
+`set_zero_extra_diag <http://github.com/LCPQ/quantum_package/tree/master/plugins/MRCC_Utils/LinearAlgebra.irp.f#L585>`_
   Undocumented
 
 
@@ -800,6 +1003,14 @@ h_apply_mrcc_pt2_monoexc
   contains the new order of the elements.
 
 
+`sort_det <http://github.com/LCPQ/quantum_package/tree/master/plugins/MRCC_Utils/mrcc_utils.irp.f#L417>`_
+  Undocumented
+
+
+`sort_exc <http://github.com/LCPQ/quantum_package/tree/master/plugins/MRCC_Utils/mrcc_utils.irp.f#L453>`_
+  Undocumented
+
+
 `start_progress <http://github.com/LCPQ/quantum_package/tree/master/plugins/MRCC_Utils/progress.irp.f#L1>`_
   Starts the progress bar
 
@@ -817,18 +1028,37 @@ h_apply_mrcc_pt2_monoexc
   .br
 
 
-`u_dot_u <http://github.com/LCPQ/quantum_package/tree/master/plugins/MRCC_Utils/util.irp.f#L326>`_
+`tamise_exc <http://github.com/LCPQ/quantum_package/tree/master/plugins/MRCC_Utils/mrcc_utils.irp.f#L495>`_
+  Uncodumented : TODO
+
+
+`transpose <http://github.com/LCPQ/quantum_package/tree/master/plugins/MRCC_Utils/transpose.irp.f#L2>`_
+  Transpose input matrix A into output matrix B
+
+
+`u_0_h_u_0_mrcc_nstates <http://github.com/LCPQ/quantum_package/tree/master/plugins/MRCC_Utils/davidson.irp.f#L374>`_
+  Computes e_0 = <u_0|H|u_0>/<u_0|u_0>
+  .br
+  n : number of determinants
+  .br
+
+
+`u_dot_u <http://github.com/LCPQ/quantum_package/tree/master/plugins/MRCC_Utils/util.irp.f#L334>`_
   Compute <u|u>
 
 
-`u_dot_v <http://github.com/LCPQ/quantum_package/tree/master/plugins/MRCC_Utils/util.irp.f#L299>`_
+`u_dot_v <http://github.com/LCPQ/quantum_package/tree/master/plugins/MRCC_Utils/util.irp.f#L320>`_
   Compute <u|v>
 
 
-`wall_time <http://github.com/LCPQ/quantum_package/tree/master/plugins/MRCC_Utils/util.irp.f#L268>`_
+`unsortedsearchdet <http://github.com/LCPQ/quantum_package/tree/master/plugins/MRCC_Utils/mrcc_utils.irp.f#L368>`_
+  Undocumented
+
+
+`wall_time <http://github.com/LCPQ/quantum_package/tree/master/plugins/MRCC_Utils/util.irp.f#L289>`_
   The equivalent of cpu_time, but for the wall time.
 
 
-`write_git_log <http://github.com/LCPQ/quantum_package/tree/master/plugins/MRCC_Utils/util.irp.f#L243>`_
+`write_git_log <http://github.com/LCPQ/quantum_package/tree/master/plugins/MRCC_Utils/util.irp.f#L264>`_
   Write the last git commit in file iunit.
 

plugins/MRCC_Utils/amplitudes.irp.f

@@ -0,0 +1,238 @@
+ BEGIN_PROVIDER [ integer, n_exc_active ]
+&BEGIN_PROVIDER [ integer, active_pp_idx, (hh_nex) ]
+&BEGIN_PROVIDER [ integer, active_hh_idx, (hh_nex) ]
+&BEGIN_PROVIDER [ logical, is_active_exc, (hh_nex) ]
+ implicit none
+ BEGIN_DOC
+ ! is_active_exc : True if the excitation involves at least one active MO
+ !
+ ! n_exc_active : Number of active excitations : Number of excitations without the inactive ones.
+ !
+ ! active_hh_idx : 
+ !
+ ! active_pp_idx :
+ END_DOC
+ integer                        :: hh, pp, II
+ integer                        :: ind
+ logical                        :: ok
+ integer(bit_kind)              :: myDet(N_int, 2), myMask(N_int, 2)
+
+ integer, allocatable           :: pathTo(:)
+ integer, external              :: searchDet
+
+ allocate(pathTo(N_det_non_ref))
+
+ pathTo(:) = 0
+ is_active_exc(:) = .false.
+ n_exc_active = 0
+
+ do hh = 1, hh_shortcut(0)
+   do pp = hh_shortcut(hh), hh_shortcut(hh+1)-1
+     do II = 1, N_det_ref
+
+       call apply_hole_local(psi_ref(1,1,II), hh_exists(1, hh), myMask, ok, N_int)
+       if(.not. ok) cycle
+
+       call apply_particle_local(myMask, pp_exists(1, pp), myDet, ok, N_int)
+       if(.not. ok) cycle
+
+       ind = searchDet(psi_non_ref_sorted(1,1,1), myDet(1,1), N_det_non_ref, N_int)
+       if(ind == -1) cycle
+
+       ind = psi_non_ref_sorted_idx(ind)
+       if(pathTo(ind) == 0) then
+         pathTo(ind) = pp
+       else
+         is_active_exc(pp) = .true.
+         is_active_exc(pathTo(ind)) = .true.
+       end if
+     end do
+   end do
+ end do
+!is_active_exc=.true.
+ do hh = 1, hh_shortcut(0)
+  do pp = hh_shortcut(hh), hh_shortcut(hh+1)-1
+    if(is_active_exc(pp)) then
+      n_exc_active = n_exc_active + 1
+      active_hh_idx(n_exc_active) = hh
+      active_pp_idx(n_exc_active) = pp
+    end if
+  end do
+ end do
+
+ deallocate(pathTo)
+
+ print *, n_exc_active, "active excitations /", hh_nex
+
+END_PROVIDER
+
+BEGIN_PROVIDER [ integer, n_exc_active_sze ]
+ implicit none
+ BEGIN_DOC
+ ! Dimension of arrays to avoid zero-sized arrays
+ END_DOC
+ n_exc_active_sze = max(n_exc_active,1)
+END_PROVIDER
+
+
+
+ BEGIN_PROVIDER [ integer, active_excitation_to_determinants_idx, (0:N_det_ref+1, n_exc_active_sze) ]
+&BEGIN_PROVIDER [ double precision, active_excitation_to_determinants_val, (N_states,N_det_ref+1, n_exc_active_sze) ]
+ implicit none
+ BEGIN_DOC
+ ! Sparse matrix A containing the matrix to transform the active excitations to
+ ! determinants : A | \Psi_0 > = | \Psi_SD >
+ END_DOC
+ integer                        :: s, ppp, pp, hh, II, ind, wk, i
+ integer, allocatable           :: lref(:) 
+ integer(bit_kind)              :: myDet(N_int,2), myMask(N_int,2)
+ double precision               :: phase
+ logical                        :: ok
+ integer, external              :: searchDet
+ 
+
+ !$OMP PARALLEL default(none) shared(psi_non_ref, hh_exists, pp_exists, N_int,&
+     !$OMP   active_excitation_to_determinants_val, active_excitation_to_determinants_idx)&
+     !$OMP shared(hh_shortcut, psi_ref_coef, N_det_non_ref, psi_non_ref_sorted, &
+     !$OMP   psi_non_ref_sorted_idx, psi_ref, N_det_ref, N_states)&
+     !$OMP shared(is_active_exc, active_hh_idx, active_pp_idx, n_exc_active)&
+     !$OMP private(lref, pp, II, ok, myMask, myDet, ind, phase, wk, ppp, hh, s)
+ allocate(lref(N_det_non_ref))
+ !$OMP DO schedule(dynamic)
+ do ppp=1,n_exc_active
+   active_excitation_to_determinants_val(:,:,ppp) = 0d0
+   active_excitation_to_determinants_idx(:,ppp)   = 0
+   pp = active_pp_idx(ppp)
+   hh = active_hh_idx(ppp)
+   lref = 0
+   do II = 1, N_det_ref
+     call apply_hole_local(psi_ref(1,1,II), hh_exists(1, hh), myMask, ok, N_int)
+     if(.not. ok) cycle
+     call apply_particle_local(myMask, pp_exists(1, pp), myDet, ok, N_int)
+     if(.not. ok) cycle
+     ind = searchDet(psi_non_ref_sorted(1,1,1), myDet(1,1), N_det_non_ref, N_int)
+     if(ind /= -1) then
+       call get_phase(myDet(1,1), psi_ref(1,1,II), phase, N_int)
+       if (phase  > 0.d0) then
+         lref(psi_non_ref_sorted_idx(ind)) =  II
+       else
+         lref(psi_non_ref_sorted_idx(ind)) = -II
+       endif
+     end if
+   end do
+   wk = 0
+   do i=1, N_det_non_ref
+     if(lref(i) > 0) then
+       wk += 1
+       do s=1,N_states
+        active_excitation_to_determinants_val(s,wk, ppp) = psi_ref_coef(lref(i), s)
+       enddo
+       active_excitation_to_determinants_idx(wk, ppp) = i
+     else if(lref(i) < 0) then
+       wk += 1
+       do s=1,N_states
+        active_excitation_to_determinants_val(s,wk, ppp) = -psi_ref_coef(-lref(i), s)
+       enddo
+       active_excitation_to_determinants_idx(wk, ppp) = i
+     end if
+   end do
+   active_excitation_to_determinants_idx(0,ppp) = wk
+ end do
+ !$OMP END DO
+ deallocate(lref)
+ !$OMP END PARALLEL
+
+END_PROVIDER
+
+
+ BEGIN_PROVIDER [ integer, mrcc_AtA_ind, (N_det_ref * n_exc_active_sze) ]
+&BEGIN_PROVIDER [ double precision, mrcc_AtA_val, (N_states, N_det_ref * n_exc_active_sze) ]
+&BEGIN_PROVIDER [ integer, mrcc_col_shortcut, (n_exc_active_sze) ]
+&BEGIN_PROVIDER [ integer, mrcc_N_col, (n_exc_active_sze) ]
+ implicit none
+ BEGIN_DOC
+ ! A is active_excitation_to_determinants in At.A
+ END_DOC
+ integer                        :: AtA_size, i,k
+ integer                        :: at_roww, at_row, wk, a_coll, a_col, r1, r2, s
+ double precision, allocatable  :: t(:), A_val_mwen(:,:), As2_val_mwen(:,:)
+ integer, allocatable           :: A_ind_mwen(:)
+ double precision               :: sij
+ PROVIDE psi_non_ref 
+
+ mrcc_AtA_ind(:) = 0
+ mrcc_AtA_val(:,:) = 0.d0
+ mrcc_col_shortcut(:) = 0
+ mrcc_N_col(:) = 0
+ AtA_size = 0
+
+
+  !$OMP PARALLEL default(none) shared(k, active_excitation_to_determinants_idx,&
+      !$OMP   active_excitation_to_determinants_val, hh_nex)         &
+      !$OMP private(at_row, a_col, t, i, r1, r2, wk, A_ind_mwen, A_val_mwen,&
+      !$OMP   As2_val_mwen, a_coll, at_roww,sij) &
+      !$OMP shared(N_states,mrcc_col_shortcut, mrcc_N_col, AtA_size, mrcc_AtA_val, mrcc_AtA_ind, &
+      !$OMP n_exc_active, active_pp_idx,psi_non_ref)
+  allocate(A_val_mwen(N_states,hh_nex), As2_val_mwen(N_states,hh_nex), A_ind_mwen(hh_nex), t(N_states) )
+
+  !$OMP DO schedule(dynamic, 100)
+  do at_roww = 1, n_exc_active ! hh_nex
+    at_row = active_pp_idx(at_roww)
+    wk = 0
+
+    do a_coll = 1, n_exc_active
+      a_col = active_pp_idx(a_coll)
+      t(:) = 0d0
+      r1 = 1
+      r2 = 1
+      do while ((active_excitation_to_determinants_idx(r1, at_roww) /= 0).and.(active_excitation_to_determinants_idx(r2, a_coll) /= 0))
+        if(active_excitation_to_determinants_idx(r1, at_roww) > active_excitation_to_determinants_idx(r2, a_coll)) then
+          r2 = r2+1
+        else if(active_excitation_to_determinants_idx(r1, at_roww) < active_excitation_to_determinants_idx(r2, a_coll)) then
+          r1 = r1+1
+        else
+          do s=1,N_states
+            t(s) = t(s) - active_excitation_to_determinants_val(s,r1, at_roww) * active_excitation_to_determinants_val(s,r2, a_coll)
+          enddo
+          r1 = r1+1
+          r2 = r2+1
+        end if
+      end do
+
+      if (a_col == at_row) then
+        t(:) = t(:) + 1.d0
+      endif
+      if (sum(dabs(t(:))) > 0.d0) then
+        wk = wk+1
+        A_ind_mwen(wk) = a_col
+        A_val_mwen(:,wk) = t(:)
+      endif
+
+    end do
+
+    if(wk /= 0) then
+      !$OMP CRITICAL
+      mrcc_col_shortcut(at_roww) = AtA_size+1
+      mrcc_N_col(at_roww) = wk
+      if (AtA_size+wk > size(mrcc_AtA_ind,1)) then
+        print *, AtA_size+wk , size(mrcc_AtA_ind,1)
+        stop 'too small'
+      endif
+      do i=1,wk
+        mrcc_AtA_ind(AtA_size+i) = A_ind_mwen(i)
+        do s=1,N_states
+          mrcc_AtA_val(s,AtA_size+i) = A_val_mwen(s,i)
+        enddo
+      enddo
+      AtA_size += wk
+      !$OMP END CRITICAL
+    end if
+  end do
+  !$OMP END DO NOWAIT
+  deallocate (A_ind_mwen, A_val_mwen, As2_val_mwen, t)
+  !$OMP END PARALLEL
+
+  print *, "At.A SIZE", ata_size
+
+END_PROVIDER
+

plugins/MRCC_Utils/davidson.irp.f

@@ -94,7 +94,6 @@ subroutine davidson_diag_hjj_mrcc(dets_in,u_in,H_jj,energies,dim_in,sze,N_st,N_s
   double precision, allocatable  :: overlap(:,:)
   double precision               :: u_dot_v, u_dot_u
   
-  integer, allocatable           :: kl_pairs(:,:)
   integer                        :: k_pairs, kl
   
   integer                        :: iter2
@@ -144,7 +143,6 @@ subroutine davidson_diag_hjj_mrcc(dets_in,u_in,H_jj,energies,dim_in,sze,N_st,N_s
   sze_8 = align_double(sze)
 
   allocate(                                                          &
-      kl_pairs(2,N_st_diag*(N_st_diag+1)/2),                         &
       W(sze_8,N_st_diag,davidson_sze_max),                           &
       U(sze_8,N_st_diag,davidson_sze_max),                           &
       R(sze_8,N_st_diag),                                            &
@@ -209,19 +207,6 @@ subroutine davidson_diag_hjj_mrcc(dets_in,u_in,H_jj,energies,dim_in,sze,N_st,N_s
       ! -------------------------------------------
 
 
-!      do l=1,N_st_diag
-!        do k=1,N_st_diag
-!          do iter2=1,iter-1
-!            h(k,iter2,l,iter) = u_dot_v(U(1,k,iter2),W(1,l,iter),sze)
-!            h(k,iter,l,iter2) = h(k,iter2,l,iter)
-!          enddo
-!        enddo
-!        do k=1,l
-!          h(k,iter,l,iter) = u_dot_v(U(1,k,iter),W(1,l,iter),sze)
-!          h(l,iter,k,iter) = h(k,iter,l,iter)
-!        enddo
-!      enddo
-
       call dgemm('T','N', N_st_diag*iter, N_st_diag, sze,            &
           1.d0, U, size(U,1), W(1,1,iter), size(W,1),                &
           0.d0, h(1,1,1,iter), size(h,1)*size(h,2))
@@ -330,20 +315,10 @@ subroutine davidson_diag_hjj_mrcc(dets_in,u_in,H_jj,energies,dim_in,sze,N_st,N_s
     ! -----------
     
     do k=1,N_st_diag
-      energies(k) = lambda(k)
       do i=1,sze
         u_in(i,k) = 0.d0
       enddo
     enddo
-!    do k=1,N_st_diag
-!      do i=1,sze
-!        do iter2=1,iter
-!          do l=1,N_st_diag
-!            u_in(i,k) += U(i,l,iter2)*y(l,iter2,k,1)
-!          enddo
-!        enddo
-!      enddo
-!    enddo
 
     call dgemm('N','N', sze, N_st_diag, N_st_diag*iter, 1.d0,      &
         U, size(U,1), y, N_st_diag*davidson_sze_max, &
@@ -351,6 +326,9 @@ subroutine davidson_diag_hjj_mrcc(dets_in,u_in,H_jj,energies,dim_in,sze,N_st,N_s
 
   enddo
 
+  do k=1,N_st_diag
+    energies(k) = lambda(k)
+  enddo
   write_buffer = '===== '
   do i=1,N_st
     write_buffer = trim(write_buffer)//' ================ ================'
@@ -360,7 +338,6 @@ subroutine davidson_diag_hjj_mrcc(dets_in,u_in,H_jj,energies,dim_in,sze,N_st,N_s
   call write_time(iunit)
 
   deallocate (                                                       &
-      kl_pairs,                                                      &
       W, residual_norm,                                              &
       U, overlap,                                                    &
       R, c,                                                          &
@@ -573,7 +550,7 @@ subroutine davidson_diag_mrcc_hs2(dets_in,u_in,dim_in,energies,sze,N_st,N_st_dia
   integer, intent(in)            :: dim_in, sze, N_st, N_st_diag, Nint, iunit, istate
   integer(bit_kind), intent(in)  :: dets_in(Nint,2,sze)
   double precision, intent(inout) :: u_in(dim_in,N_st_diag)
-  double precision, intent(out)  :: energies(N_st)
+  double precision, intent(out)  :: energies(N_st_diag)
   double precision, allocatable  :: H_jj(:), S2_jj(:)
   
   double precision               :: diag_h_mat_elem
@@ -646,14 +623,12 @@ subroutine davidson_diag_hjj_sjj_mrcc(dets_in,u_in,H_jj,S2_jj,energies,dim_in,sz
   integer                        :: i,j,k,l,m
   logical                        :: converged
   
-  double precision, allocatable  :: overlap(:,:)
   double precision               :: u_dot_v, u_dot_u
   
-  integer, allocatable           :: kl_pairs(:,:)
   integer                        :: k_pairs, kl
   
   integer                        :: iter2
-  double precision, allocatable  :: W(:,:),  U(:,:), R(:,:), S(:,:)
+  double precision, allocatable  :: W(:,:),  U(:,:), S(:,:), overlap(:,:)
   double precision, allocatable  :: y(:,:), h(:,:), lambda(:), s2(:)
   double precision, allocatable  :: c(:), s_(:,:), s_tmp(:,:)
   double precision               :: diag_h_mat_elem
@@ -661,12 +636,14 @@ subroutine davidson_diag_hjj_sjj_mrcc(dets_in,u_in,H_jj,S2_jj,energies,dim_in,sz
   character*(16384)              :: write_buffer
   double precision               :: to_print(3,N_st)
   double precision               :: cpu, wall
-  integer                        :: shift, shift2
+  integer                        :: shift, shift2, itermax
   include 'constants.include.F'
   
-  !DIR$ ATTRIBUTES ALIGN : $IRP_ALIGN :: U, W, R, S, y, h, lambda
-  if (N_st_diag > sze) then
-     stop 'error in Davidson : N_st_diag > sze'
+  !DIR$ ATTRIBUTES ALIGN : $IRP_ALIGN :: U, W, S, y, h, lambda
+  if (N_st_diag*3 > sze) then
+     print *,  'error in Davidson :'
+     print *,  'Increase n_det_max_jacobi to ', N_st_diag*3
+     stop -1
   endif
 
   PROVIDE nuclear_repulsion
@@ -691,7 +668,7 @@ subroutine davidson_diag_hjj_sjj_mrcc(dets_in,u_in,H_jj,S2_jj,energies,dim_in,sz
   write(iunit,'(A)') trim(write_buffer)
   write_buffer = ' Iter'
   do i=1,N_st
-    write_buffer = trim(write_buffer)//'      Energy          S^2      Residual'
+    write_buffer = trim(write_buffer)//'      Energy          S^2       Residual '
   enddo
   write(iunit,'(A)') trim(write_buffer)
   write_buffer = '===== '
@@ -703,30 +680,30 @@ subroutine davidson_diag_hjj_sjj_mrcc(dets_in,u_in,H_jj,S2_jj,energies,dim_in,sz
   integer, external :: align_double
   sze_8 = align_double(sze)
 
-  double precision :: delta
-
-  if (s2_eig) then
-    delta = 1.d0
-  else
-    delta = 0.d0
-  endif
-
+  itermax = min(davidson_sze_max, sze/N_st_diag)
   allocate(                                                          &
-      kl_pairs(2,N_st_diag*(N_st_diag+1)/2),                         &
-      W(sze_8,N_st_diag*davidson_sze_max),                           &
-      U(sze_8,N_st_diag*davidson_sze_max),                           &
-      R(sze_8,N_st_diag),                                            &
-      S(sze_8,N_st_diag*davidson_sze_max),                           &
-      h(N_st_diag*davidson_sze_max,N_st_diag*davidson_sze_max),      &
-      y(N_st_diag*davidson_sze_max,N_st_diag*davidson_sze_max),      &
-      s_(N_st_diag*davidson_sze_max,N_st_diag*davidson_sze_max),     &
-      s_tmp(N_st_diag*davidson_sze_max,N_st_diag*davidson_sze_max),  &
+      W(sze_8,N_st_diag*itermax),                                    &
+      U(sze_8,N_st_diag*itermax),                                    &
+      S(sze_8,N_st_diag*itermax),                                    &
+      h(N_st_diag*itermax,N_st_diag*itermax),                        &
+      y(N_st_diag*itermax,N_st_diag*itermax),                        &
+      s_(N_st_diag*itermax,N_st_diag*itermax),                       &
+      s_tmp(N_st_diag*itermax,N_st_diag*itermax),                    &
       residual_norm(N_st_diag),                                      &
-      overlap(N_st_diag,N_st_diag),                                  &
-      c(N_st_diag*davidson_sze_max),                                 &
-      s2(N_st_diag*davidson_sze_max),                                &
-      lambda(N_st_diag*davidson_sze_max))
-  
+      c(N_st_diag*itermax),                                          &
+      s2(N_st_diag*itermax),                                         &
+      overlap(N_st_diag*itermax,N_st_diag*itermax),                  &
+      lambda(N_st_diag*itermax))
+
+  h  = 0.d0
+  s_ = 0.d0
+  s_tmp = 0.d0
+  U = 0.d0
+  W = 0.d0
+  S = 0.d0
+  y = 0.d0
+
+
   ASSERT (N_st > 0)
   ASSERT (N_st_diag >= N_st)
   ASSERT (sze > 0)
@@ -738,25 +715,19 @@ subroutine davidson_diag_hjj_sjj_mrcc(dets_in,u_in,H_jj,S2_jj,energies,dim_in,sz
   
   converged = .False.
   
-  do k=1,N_st
-    call normalize(u_in(1,k),sze)
-  enddo
-
+  double precision               :: r1, r2
   do k=N_st+1,N_st_diag
+      u_in(k,k) = 10.d0
       do i=1,sze
-        double precision               :: r1, r2
         call random_number(r1)
         call random_number(r2)
-        u_in(i,k) = dsqrt(-2.d0*dlog(r1))*dcos(dtwo_pi*r2)
+        r1 = dsqrt(-2.d0*dlog(r1))
+        r2 = dtwo_pi*r2
+        u_in(i,k) = r1*dcos(r2)
       enddo
-    
-    ! Gram-Schmidt
-    ! ------------
-    call dgemv('T',sze,k-1,1.d0,u_in,size(u_in,1),                   &
-        u_in(1,k),1,0.d0,c,1)
-    call dgemv('N',sze,k-1,-1.d0,u_in,size(u_in,1),                  &
-        c,1,1.d0,u_in(1,k),1)
-    call normalize(u_in(1,k),sze)
+  enddo
+  do k=1,N_st_diag
+      call normalize(u_in(1,k),sze)
   enddo
 
   
@@ -773,10 +744,10 @@ subroutine davidson_diag_hjj_sjj_mrcc(dets_in,u_in,H_jj,S2_jj,energies,dim_in,sz
       shift  = N_st_diag*(iter-1)
       shift2 = N_st_diag*iter
 
+      call ortho_qr(U,size(U,1),sze,shift2)
 
       ! Compute |W_k> = \sum_i |i><i|H|u_k>
       ! -----------------------------------------
-      
        
       call H_S2_u_0_mrcc_nstates(W(1,shift+1),S(1,shift+1),U(1,shift+1),H_jj,S2_jj,sze,dets_in,Nint,&
         istate,N_st_diag,sze_8)
@@ -786,31 +757,57 @@ subroutine davidson_diag_hjj_sjj_mrcc(dets_in,u_in,H_jj,S2_jj,energies,dim_in,sz
       ! -------------------------------------------
 
 
-!      do l=1,N_st_diag
-!        do k=1,N_st_diag
-!          do iter2=1,iter-1
-!            h(k,iter2,l,iter) = u_dot_v(U(1,k,iter2),W(1,l,iter),sze)
-!            h(k,iter,l,iter2) = h(k,iter2,l,iter)
-!          enddo
-!        enddo
-!        do k=1,l
-!          h(k,iter,l,iter) = u_dot_v(U(1,k,iter),W(1,l,iter),sze)
-!          h(l,iter,k,iter) = h(k,iter,l,iter)
+      call dgemm('T','N', shift2, shift2, sze,            &
+          1.d0, U, size(U,1), W, size(W,1),                &
+          0.d0, h, size(h,1))
+
+      call dgemm('T','N', shift2, shift2, sze,            &
+          1.d0, U, size(U,1), S, size(S,1),                &
+          0.d0, s_, size(s_,1))
+
+!      ! Diagonalize S^2
+!      ! ---------------
+!
+!      call lapack_diag(s2,y,s_,size(s_,1),shift2)
+!
+!      ! Rotate H in the basis of eigenfunctions of s2
+!      ! ---------------------------------------------
+!
+!      call dgemm('N','N',shift2,shift2,shift2,                       &
+!          1.d0, h, size(h,1), y, size(y,1),                          &
+!          0.d0, s_tmp, size(s_tmp,1))
+!      
+!      call dgemm('T','N',shift2,shift2,shift2,                       &
+!          1.d0, y, size(y,1), s_tmp, size(s_tmp,1),                  &
+!          0.d0, h, size(h,1))
+!
+!      ! Damp interaction between different spin states
+!      ! ------------------------------------------------
+!
+!      do k=1,shift2
+!        do l=1,shift2
+!          if (dabs(s2(k) - s2(l)) > 1.d0) then
+!            h(k,l) = h(k,l)*(max(0.d0,1.d0 - dabs(s2(k) - s2(l))))
+!          endif
 !        enddo
 !      enddo
+!
+!      ! Rotate back H 
+!      ! -------------
+!
+!      call dgemm('N','T',shift2,shift2,shift2,                       &
+!          1.d0, h, size(h,1), y, size(y,1),                          &
+!          0.d0, s_tmp, size(s_tmp,1))
+!      
+!      call dgemm('N','N',shift2,shift2,shift2,                       &
+!          1.d0, y, size(y,1), s_tmp, size(s_tmp,1),                  &
+!          0.d0, h, size(h,1))
 
-      call dgemm('T','N', shift2, N_st_diag, sze,            &
-          1.d0, U, size(U,1), W(1,shift+1), size(W,1),                &
-          0.d0, h(1,shift+1), size(h,1))
-
-      call dgemm('T','N', shift2, N_st_diag, sze,            &
-          1.d0, U, size(U,1), S(1,shift+1), size(S,1),                &
-          0.d0, s_(1,shift+1), size(s_,1))
-
+      
       ! Diagonalize h
       ! -------------
       call lapack_diag(lambda,y,h,size(h,1),shift2)
-      
+
       ! Compute S2 for each eigenvector
       ! -------------------------------
 
@@ -827,46 +824,81 @@ subroutine davidson_diag_hjj_sjj_mrcc(dets_in,u_in,H_jj,S2_jj,energies,dim_in,sz
       enddo
 
       if (s2_eig) then
-        logical :: state_ok(N_st_diag*davidson_sze_max)
-        do k=1,shift2
-          state_ok(k) = (dabs(s2(k)-expected_s2) < 0.3d0)
+          logical :: state_ok(N_st_diag*davidson_sze_max)
+          do k=1,shift2
+            state_ok(k) = (dabs(s2(k)-expected_s2) < 0.6d0)
+          enddo
+      else
+        do k=1,size(state_ok)
+          state_ok(k) = .True.
         enddo
+      endif
+
+      do k=1,shift2
+        if (.not. state_ok(k)) then
+          do l=k+1,shift2
+            if (state_ok(l)) then
+              call dswap(shift2, y(1,k), 1, y(1,l), 1)
+              call dswap(1, s2(k), 1, s2(l), 1)
+              call dswap(1, lambda(k), 1, lambda(l), 1)
+              state_ok(k) = .True.
+              state_ok(l) = .False.
+              exit
+            endif
+          enddo
+        endif
+      enddo
+
+      if (state_following) then
+
+        ! Compute overlap with U_in
+        ! -------------------------
+        
+        integer                        :: order(N_st_diag)
+        double precision               :: cmax
+        overlap = -1.d0
         do k=1,shift2
-          if (.not. state_ok(k)) then
-            do l=k+1,shift2
-              if (state_ok(l)) then
-                call dswap(shift2, y(1,k), 1, y(1,l), 1)
-                call dswap(1, s2(k), 1, s2(l), 1)
-                call dswap(1, lambda(k), 1, lambda(l), 1)
-                state_ok(k) = .True.
-                state_ok(l) = .False.
-                exit
-              endif
-            enddo
+          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,shift2
+            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)
+          overlap(k,2) = s2(k)
+        enddo
+        do k=1,N_st
+          l = order(k)
+          if (k /= l) then
+            lambda(k) = overlap(l,1)
+            s2(k) = overlap(l,2)
+          endif
+        enddo
+        
       endif
 
 
       ! Express eigenvectors of h in the determinant basis
       ! --------------------------------------------------
       
-!      do k=1,N_st_diag
-!        do i=1,sze
-!          U(i,shift2+k) = 0.d0
-!          W(i,shift2+k) = 0.d0
-!          S(i,shift2+k) = 0.d0
-!        enddo
-!        do l=1,N_st_diag*iter
-!          do i=1,sze
-!            U(i,shift2+k) = U(i,shift2+k) + U(i,l)*y(l,k)
-!            W(i,shift2+k) = W(i,shift2+k) + W(i,l)*y(l,k)
-!            S(i,shift2+k) = S(i,shift2+k) + S(i,l)*y(l,k)
-!          enddo
-!        enddo
-!      enddo
-!
-!
       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))
       call dgemm('N','N', sze, N_st_diag, shift2,                    &
@@ -876,102 +908,65 @@ subroutine davidson_diag_hjj_sjj_mrcc(dets_in,u_in,H_jj,S2_jj,energies,dim_in,sz
 
       ! Compute residual vector
       ! -----------------------
-      
-!      do k=1,N_st_diag
-!        print *,  s2(k)
-!        s2(k) = u_dot_v(U(1,shift2+k),  S(1,shift2+k), sze) + S_z2_Sz
-!        print *,  s2(k)
-!        print *,  ''
-!        pause
-!      enddo
+
       do k=1,N_st_diag
-        do i=1,sze
-          R(i,k) = (lambda(k) * U(i,shift2+k) - W(i,shift2+k) ) &
-            * (1.d0 + s2(k) * U(i,shift2+k) - S(i,shift2+k) - S_z2_Sz)
-        enddo
+!        if (state_ok(k)) then
+          do i=1,sze
+            U(i,shift2+k) = (lambda(k) * U(i,shift2+k) - W(i,shift2+k) )      &
+                * (1.d0 + s2(k) * U(i,shift2+k) - S(i,shift2+k) - S_z2_Sz &
+              )/max(H_jj(i) - lambda (k),1.d-2)
+          enddo
+!        else
+!          ! Randomize components with bad <S2>
+!            do i=1,sze-2,2
+!              call random_number(r1)
+!              call random_number(r2)
+!              r1 = dsqrt(-2.d0*dlog(r1))
+!              r2 = dtwo_pi*r2
+!              U(i,shift2+k) = r1*dcos(r2)
+!              U(i+1,shift2+k) = r1*dsin(r2)
+!            enddo
+!            do i=sze-2+1,sze
+!              call random_number(r1)
+!              call random_number(r2)
+!              r1 = dsqrt(-2.d0*dlog(r1))
+!              r2 = dtwo_pi*r2
+!              U(i,shift2+k) = r1*dcos(r2)
+!            enddo
+!        endif
+
         if (k <= N_st) then
-          residual_norm(k) = u_dot_u(R(1,k),sze)
+          residual_norm(k) = u_dot_u(U(1,shift2+k),sze)
           to_print(1,k) = lambda(k) + nuclear_repulsion
           to_print(2,k) = s2(k)
           to_print(3,k) = residual_norm(k)
-          if (residual_norm(k) > 1.e9) then
-            stop 'Davidson failed'
-          endif
         endif
       enddo
       
-      write(iunit,'(X,I3,X,100(X,F16.10,X,F11.6,X,E11.3))')  iter, to_print(:,1:N_st)
+      write(iunit,'(X,I3,X,100(X,F16.10,X,F11.6,X,E11.3))')  iter, to_print(1:3,1:N_st)
       call davidson_converged(lambda,residual_norm,wall,iter,cpu,N_st,converged)
+      do k=1,N_st
+        if (residual_norm(k) > 1.e8) then
+        print *,  ''
+          stop 'Davidson failed'
+        endif
+      enddo
       if (converged) then
         exit
       endif
-      
-      ! Davidson step
-      ! -------------
-      
-      do k=1,N_st_diag
-        do i=1,sze
-          U(i,shift2+k) =  - R(i,k)/max(H_jj(i) - lambda(k),1.d-2) 
-        enddo
-      enddo
-      
-      ! Gram-Schmidt
-      ! ------------
-      
-      do k=1,N_st_diag
-
-!        do l=1,N_st_diag*iter
-!            c(1) = u_dot_v(U(1,shift2+k),U(1,l),sze)
-!            do i=1,sze
-!              U(i,k,iter+1) = U(i,shift2+k) - c(1) * U(i,l)
-!            enddo
-!        enddo
-!
-        call dgemv('T',sze,N_st_diag*iter,1.d0,U,size(U,1),  &
-              U(1,shift2+k),1,0.d0,c,1)
-        call dgemv('N',sze,N_st_diag*iter,-1.d0,U,size(U,1), &
-              c,1,1.d0,U(1,shift2+k),1)
-!
-!        do l=1,k-1
-!          c(1) = u_dot_v(U(1,shift2+k),U(1,shift2+l),sze)
-!          do i=1,sze
-!            U(i,k,iter+1) = U(i,shift2+k) - c(1) * U(i,shift2+l)
-!          enddo
-!        enddo
-!
-        call dgemv('T',sze,k-1,1.d0,U(1,shift2+1),size(U,1),   &
-            U(1,shift2+k),1,0.d0,c,1)
-        call dgemv('N',sze,k-1,-1.d0,U(1,shift2+1),size(U,1),        &
-            c,1,1.d0,U(1,shift2+k),1)
-
-        call normalize( U(1,shift2+k), sze )
-      enddo
 
     enddo
 
-    if (.not.converged) then
-      iter = davidson_sze_max-1
-    endif
-    
     ! Re-contract to u_in
     ! -----------
     
-    do k=1,N_st_diag
-      energies(k) = lambda(k)
-    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
-!        do l=1,iter*N_st_diag
-!            u_in(i,k) += U(i,l)*y(l,k)
-!          enddo
-!        enddo
-!      enddo
-!    enddo
-
-    call dgemm('N','N', sze, N_st_diag, N_st_diag*iter, 1.d0,      &
-        U, size(U,1), y, size(y,1), 0.d0, u_in, size(u_in,1))
+  enddo
 
+  do k=1,N_st_diag
+    energies(k) = lambda(k)
   enddo
 
   write_buffer = '===== '
@@ -983,10 +978,9 @@ subroutine davidson_diag_hjj_sjj_mrcc(dets_in,u_in,H_jj,S2_jj,energies,dim_in,sz
   call write_time(iunit)
 
   deallocate (                                                       &
-      kl_pairs,                                                      &
       W, residual_norm,                                              &
       U, overlap,                                                    &
-      R, c, S,                                                       &
+      c, S,                                                       &
       h,                                                             &
       y, s_, s_tmp,                                                  &
       lambda                                                         &
@@ -1048,15 +1042,16 @@ subroutine H_S2_u_0_mrcc_nstates(v_0,s_0,u_0,H_jj,S2_jj,n,keys_tmp,Nint,istate_i
   call sort_dets_ab_v(keys_tmp, sorted(1,1,1), sort_idx(1,1), shortcut(0,1), version(1,1,1), n, Nint)
   call sort_dets_ba_v(keys_tmp, sorted(1,1,2), sort_idx(1,2), shortcut(0,2), version(1,1,2), n, Nint)
 
+  PROVIDE delta_ij_s2 
   !$OMP PARALLEL DEFAULT(NONE)                                       &
       !$OMP PRIVATE(i,hij,s2,j,k,jj,vt,st,ii,sh,sh2,ni,exa,ext,org_i,org_j,endi,sorted_i,istate)&
       !$OMP SHARED(n,keys_tmp,ut,Nint,v_0,s_0,sorted,shortcut,sort_idx,version,N_st,N_st_8, &
-      !$OMP  N_det_ref, idx_ref, N_det_non_ref, idx_non_ref, delta_ij,istate_in)
+      !$OMP  N_det_ref, idx_ref, N_det_non_ref, idx_non_ref, delta_ij, delta_ij_s2,istate_in)
   allocate(vt(N_st_8,n),st(N_st_8,n))
   Vt = 0.d0
   St = 0.d0
 
-  !$OMP DO SCHEDULE(dynamic)
+  !$OMP DO SCHEDULE(guided)
   do sh=1,shortcut(0,1)
     do sh2=sh,shortcut(0,1)
       exa = 0
@@ -1098,8 +1093,8 @@ subroutine H_S2_u_0_mrcc_nstates(v_0,s_0,u_0,H_jj,S2_jj,n,keys_tmp,Nint,istate_i
       enddo
     enddo
   enddo
-  !$OMP END DO NOWAIT
-  !$OMP DO SCHEDULE(dynamic)
+  !$OMP END DO
+  !$OMP DO SCHEDULE(guided)
   do sh=1,shortcut(0,2)
     do i=shortcut(sh,2),shortcut(sh+1,2)-1
       org_i = sort_idx(i,2)
@@ -1122,7 +1117,7 @@ subroutine H_S2_u_0_mrcc_nstates(v_0,s_0,u_0,H_jj,S2_jj,n,keys_tmp,Nint,istate_i
       end do
     end do
   enddo
-  !$OMP END DO NOWAIT
+  !$OMP END DO
 
 ! --------------------------
 ! Begin Specific to dressing
@@ -1136,6 +1131,8 @@ subroutine H_S2_u_0_mrcc_nstates(v_0,s_0,u_0,H_jj,S2_jj,n,keys_tmp,Nint,istate_i
         do istate=1,N_st
           vt (istate,i) = vt (istate,i) + delta_ij(istate_in,jj,ii)*ut(istate,j)
           vt (istate,j) = vt (istate,j) + delta_ij(istate_in,jj,ii)*ut(istate,i)
+          st (istate,i) = st (istate,i) + delta_ij_s2(istate_in,jj,ii)*ut(istate,j)
+          st (istate,j) = st (istate,j) + delta_ij_s2(istate_in,jj,ii)*ut(istate,i)
         enddo
     enddo
   enddo

plugins/MRCC_Utils/mrcc_dress.irp.f

@@ -271,7 +271,7 @@ subroutine mrcc_dress(delta_ij_, delta_ii_, Nstates, Ndet_non_ref, Ndet_ref,i_ge
           !delta_ii_(i_state,i_I)  = 0.d0
           do l_sd=1,idx_alpha(0)
             k_sd = idx_alpha(l_sd)
-            delta_ij_(i_state,k_sd,i_I) = delta_ij_(i_state,k_sd,i_I) + dIa_hla(i_state,k_sd)
+            delta_ij_(i_state,k_sd,i_I) = delta_ij_(i_state,k_sd,i_I) + 0.5d0 * dIa_hla(i_state,k_sd)
           enddo
         endif
       enddo

plugins/MRCC_Utils/mrcc_dummy.irp.f

@@ -1,4 +0,0 @@
-program pouet
-
-
-end

plugins/MRCC_Utils/mrcc_utils.irp.f

@@ -33,6 +33,7 @@ END_PROVIDER
       if (ihpsi_current(k) == 0.d0) then
         ihpsi_current(k) = 1.d-32
       endif
+!      lambda_mrcc(k,i) = psi_non_ref_coef(i,k)/ihpsi_current(k) 
       lambda_mrcc(k,i) = min(-1.d-32,psi_non_ref_coef(i,k)/ihpsi_current(k) )
       lambda_pert = 1.d0 / (psi_ref_energy_diagonalized(k)-hii)
       if (lambda_pert / lambda_mrcc(k,i)  < 0.5d0) then
@@ -77,19 +78,6 @@ BEGIN_PROVIDER [ double precision, hij_mrcc, (N_det_non_ref,N_det_ref) ]
 
 END_PROVIDER
 
- BEGIN_PROVIDER [ double precision, delta_ij, (N_states,N_det_non_ref,N_det_ref) ]
-&BEGIN_PROVIDER [ double precision, delta_ii, (N_states,N_det_ref) ]
- implicit none
- BEGIN_DOC
- ! Dressing matrix in N_det basis
- END_DOC
- integer :: i,j,m
- delta_ij = 0.d0
- delta_ii = 0.d0
- call H_apply_mrcc(delta_ij,delta_ii,N_states,N_det_non_ref,N_det_ref)
-
-END_PROVIDER
-             
 
 BEGIN_PROVIDER [ double precision, h_matrix_dressed, (N_det,N_det,N_states) ]
  implicit none
@@ -139,7 +127,6 @@ END_PROVIDER
 
    integer :: mrcc_state 
    
-   mrcc_state = N_states
    do j=1,min(N_states,N_det)
      do i=1,N_det
        CI_eigenvectors_dressed(i,j) = psi_coef(i,j)
@@ -148,17 +135,34 @@ END_PROVIDER
    
    if (diag_algorithm == "Davidson") then
      
-!     call davidson_diag_mrcc(psi_det,CI_eigenvectors_dressed,CI_electronic_energy_dressed,&
-!          size(CI_eigenvectors_dressed,1),N_det,N_states,N_states_diag,N_int,output_determinants,mrcc_state)
-
-     call davidson_diag_mrcc_HS2(psi_det,CI_eigenvectors_dressed,&
-          size(CI_eigenvectors_dressed,1), &
-          CI_electronic_energy_dressed,N_det,N_states,N_states_diag,N_int, &
-          output_determinants,mrcc_state)
-
-     call u_0_S2_u_0(CI_eigenvectors_s2_dressed,CI_eigenvectors_dressed,N_det,psi_det,N_int,&
-         N_states_diag,size(CI_eigenvectors_dressed,1))
+     allocate (eigenvectors(size(CI_eigenvectors_dressed,1),size(CI_eigenvectors_dressed,2)), &
+     eigenvalues(size(CI_electronic_energy_dressed,1)))
+     do j=1,min(N_states,N_det)
+       do i=1,N_det
+         eigenvectors(i,j) = psi_coef(i,j)
+       enddo
+     enddo
+     do mrcc_state=1,N_states
+      do j=mrcc_state,min(N_states,N_det)
+        do i=1,N_det
+          eigenvectors(i,j) = psi_coef(i,j)
+        enddo
+      enddo
+      call davidson_diag_mrcc_HS2(psi_det,eigenvectors,&
+            size(eigenvectors,1), &
+            eigenvalues,N_det,N_states,N_states_diag,N_int, &
+            output_determinants,mrcc_state)
+      CI_eigenvectors_dressed(1:N_det,mrcc_state) = eigenvectors(1:N_det,mrcc_state)
+      CI_electronic_energy_dressed(mrcc_state) = eigenvalues(mrcc_state)
+   enddo
+   do k=N_states+1,N_states_diag
+     CI_eigenvectors_dressed(1:N_det,k) = eigenvectors(1:N_det,k)
+     CI_electronic_energy_dressed(k) = eigenvalues(k)
+   enddo
+   call u_0_S2_u_0(CI_eigenvectors_s2_dressed,CI_eigenvectors_dressed,N_det,psi_det,N_int,&
+          N_states_diag,size(CI_eigenvectors_dressed,1))
 
+   deallocate (eigenvectors,eigenvalues)
      
    else if (diag_algorithm == "Lapack") then
      
@@ -614,207 +618,52 @@ END_PROVIDER
 END_PROVIDER
 
 
- BEGIN_PROVIDER [ double precision, dIj_unique, (hh_shortcut(hh_shortcut(0)+1)-1, N_states) ]
+ BEGIN_PROVIDER [ double precision, dIj_unique, (hh_nex, N_states) ]
 &BEGIN_PROVIDER [ double precision, rho_mrcc, (N_det_non_ref, N_states) ]
   implicit none
   logical                        :: ok
-  integer                        :: i, j, k, s, II, pp, ppp, hh, ind, wk, nex, a_col, at_row
+  integer                        :: i, j, k, s, II, pp, ppp, hh, ind, wk, a_col, at_row
   integer, external              :: searchDet, unsortedSearchDet
   integer(bit_kind)              :: myDet(N_int, 2), myMask(N_int, 2)
-  integer                        :: N, INFO, AtA_size, r1, r2
-  double precision , allocatable :: AtB(:), AtA_val(:), A_val(:,:), x(:), x_new(:), A_val_mwen(:)
-  double precision               :: t, norm, cx, res
-  integer, allocatable           :: A_ind(:,:), lref(:), AtA_ind(:), A_ind_mwen(:), col_shortcut(:), N_col(:)
+  integer                        :: N, INFO, r1, r2
+  double precision , allocatable :: AtB(:), x(:), x_new(:), A_val_mwen(:,:), t(:)
+  double precision               :: norm, cx, res
+  integer, allocatable           :: lref(:), A_ind_mwen(:)
   double precision               :: phase
   
   
-  integer, allocatable :: pathTo(:), active_hh_idx(:), active_pp_idx(:)
-  logical, allocatable :: active(:)
-  double precision, allocatable :: rho_mrcc_init(:,:)
-  integer :: nactive
+  double precision, allocatable :: rho_mrcc_init(:)
+  integer                        :: a_coll, at_roww
   
-  nex = hh_shortcut(hh_shortcut(0)+1)-1
-  print *, "TI", nex, N_det_non_ref
-  
-  allocate(pathTo(N_det_non_ref), active(nex))
-  allocate(active_pp_idx(nex), active_hh_idx(nex))
-  allocate(rho_mrcc_init(N_det_non_ref, N_states))
-  
-  pathTo = 0
-  active = .false.
-  nactive = 0
-  
-  
-  do hh = 1, hh_shortcut(0)
-    do pp = hh_shortcut(hh), hh_shortcut(hh+1)-1
-      do II = 1, N_det_ref
-        call apply_hole_local(psi_ref(1,1,II), hh_exists(1, hh), myMask, ok, N_int)
-        if(.not. ok) cycle
-        call apply_particle_local(myMask, pp_exists(1, pp), myDet, ok, N_int)
-        if(.not. ok) cycle
-        ind = searchDet(psi_non_ref_sorted(1,1,1), myDet(1,1), N_det_non_ref, N_int)
-        if(ind == -1) cycle
-        ind = psi_non_ref_sorted_idx(ind)
-        if(pathTo(ind) == 0) then
-          pathTo(ind) = pp
-        else
-          active(pp) = .true.
-          active(pathTo(ind)) = .true.
-        end if
-      end do
-    end do
-  end do
-  
-   do hh = 1, hh_shortcut(0)
-    do pp = hh_shortcut(hh), hh_shortcut(hh+1)-1
-      if(active(pp)) then
-        nactive = nactive + 1
-        active_hh_idx(nactive) = hh
-        active_pp_idx(nactive) = pp
-      end if
-    end do
-   end do
-  
-  print *, nactive, "inact/", size(active)
-  
-  allocate(A_ind(0:N_det_ref+1, nactive), A_val(N_det_ref+1, nactive))
-  allocate(AtA_ind(N_det_ref * nactive), AtA_val(N_det_ref * nactive)) 
-  allocate(x(nex), AtB(nex))
-  allocate(N_col(nactive), col_shortcut(nactive))
-  allocate(x_new(nex))
-        
+  print *, "TI", hh_nex, N_det_non_ref
 
-  
-  do s = 1, N_states
-    
-    A_val = 0d0
-    A_ind = 0
-    AtA_ind = 0
-    AtB = 0d0
-    AtA_val = 0d0
-    x = 0d0
-    N_col = 0
-    col_shortcut = 0
-    
-    !$OMP PARALLEL default(none) shared(psi_non_ref, hh_exists, pp_exists, N_int, A_val, A_ind)&
-        !$OMP shared(s, hh_shortcut, psi_ref_coef, N_det_non_ref, psi_non_ref_sorted, psi_non_ref_sorted_idx, psi_ref, N_det_ref)&
-        !$OMP shared(active, active_hh_idx, active_pp_idx, nactive)&
-        !$OMP private(lref, pp, II, ok, myMask, myDet, ind, phase, wk, ppp, hh)
-     allocate(lref(N_det_non_ref))
-    !$OMP DO schedule(static,10) 
-      do ppp=1,nactive
-        pp = active_pp_idx(ppp)
-        hh = active_hh_idx(ppp)
-        lref = 0
-        do II = 1, N_det_ref
-          call apply_hole_local(psi_ref(1,1,II), hh_exists(1, hh), myMask, ok, N_int)
-          if(.not. ok) cycle
-          call apply_particle_local(myMask, pp_exists(1, pp), myDet, ok, N_int)
-          if(.not. ok) cycle
-          ind = searchDet(psi_non_ref_sorted(1,1,1), myDet(1,1), N_det_non_ref, N_int)
-          if(ind /= -1) then
-            call get_phase(myDet(1,1), psi_ref(1,1,II), phase, N_int)
-            if (phase  > 0.d0) then
-              lref(psi_non_ref_sorted_idx(ind)) =  II
-            else
-              lref(psi_non_ref_sorted_idx(ind)) = -II
-            endif
-          end if
-        end do
-        wk = 0
-        do i=1, N_det_non_ref
-          if(lref(i) > 0) then
-            wk += 1
-            A_val(wk, ppp) = psi_ref_coef(lref(i), s)
-            A_ind(wk, ppp) = i
-          else if(lref(i) < 0) then
-            wk += 1
-            A_val(wk, ppp) = -psi_ref_coef(-lref(i), s)
-            A_ind(wk, ppp) = i
-          end if
-        end do
-        A_ind(0,ppp) = wk
-      end do
-    !$OMP END DO
-    deallocate(lref)
-    !$OMP END PARALLEL   
+  allocate(rho_mrcc_init(N_det_non_ref))
+  allocate(x_new(hh_nex))
+  allocate(x(hh_nex), AtB(hh_nex))
 
+  do s=1,N_states
 
-    print *,  'Done building A_val, A_ind'
+    AtB(:) = 0.d0
+    !$OMP PARALLEL default(none) shared(k, psi_non_ref_coef, active_excitation_to_determinants_idx,&
+        !$OMP   active_excitation_to_determinants_val, N_det_ref, hh_nex, N_det_non_ref)          &
+        !$OMP private(at_row, a_col, i, j, r1, r2, wk, A_ind_mwen, A_val_mwen, a_coll, at_roww)&
+        !$OMP shared(N_states,mrcc_col_shortcut, mrcc_N_col, AtB, mrcc_AtA_val, mrcc_AtA_ind, s, n_exc_active, active_pp_idx)
     
-    AtA_size = 0
-    col_shortcut = 0
-    N_col = 0
-    integer :: a_coll, at_roww
-    
-    
-    !$OMP PARALLEL default(none) shared(k, psi_non_ref_coef, A_ind, A_val, x, N_det_ref, nex, N_det_non_ref)&
-        !$OMP private(at_row, a_col, t, i, j, r1, r2, wk, A_ind_mwen, A_val_mwen, a_coll, at_roww)&
-        !$OMP shared(col_shortcut, N_col, AtB, AtA_size, AtA_val, AtA_ind, s, nactive, active_pp_idx)
-    allocate(A_val_mwen(nex), A_ind_mwen(nex))
-     
     !$OMP DO schedule(dynamic, 100)
-    do at_roww = 1, nactive ! nex
+    do at_roww = 1, n_exc_active ! hh_nex
       at_row = active_pp_idx(at_roww)
-      wk = 0
-      if(mod(at_roww, 100) == 0) print *, "AtA", at_row, "/", nex
-      do i=1,A_ind(0,at_roww)
-        j = active_pp_idx(i)
-        AtB(at_row) = AtB(at_row) + psi_non_ref_coef(A_ind(i, at_roww), s) * A_val(i, at_roww)
+      do i=1,active_excitation_to_determinants_idx(0,at_roww)
+          AtB(at_row) = AtB(at_row) + psi_non_ref_coef(active_excitation_to_determinants_idx(i, at_roww), s) * active_excitation_to_determinants_val(s,i, at_roww)
       end do
-
-      do a_coll = 1, nactive 
-        a_col = active_pp_idx(a_coll)
-        t = 0d0
-        r1 = 1
-        r2 = 1
-        do while ((A_ind(r1, at_roww) /= 0).and.(A_ind(r2, a_coll) /= 0))
-          if(A_ind(r1, at_roww) > A_ind(r2, a_coll)) then
-            r2 = r2+1
-          else if(A_ind(r1, at_roww) < A_ind(r2, a_coll)) then
-            r1 = r1+1
-          else
-            t = t - A_val(r1, at_roww) * A_val(r2, a_coll)
-            r1 = r1+1
-            r2 = r2+1
-          end if
-        end do
-        
-        if(a_col == at_row) then
-          t = t + 1.d0
-        end if
-        if(t /= 0.d0) then
-          wk += 1
-          A_ind_mwen(wk) = a_col
-          A_val_mwen(wk) = t
-        end if
-      end do
-      
-      if(wk /= 0) then
-        !$OMP CRITICAL
-        col_shortcut(at_roww) = AtA_size+1
-        N_col(at_roww) = wk
-        if (AtA_size+wk > size(AtA_ind,1)) then
-           print *, AtA_size+wk , size(AtA_ind,1)
-           stop 'too small'
-        endif
-        do i=1,wk
-         AtA_ind(AtA_size+i) = A_ind_mwen(i)
-         AtA_val(AtA_size+i) = A_val_mwen(i)
-        enddo
-        AtA_size += wk
-        !$OMP END CRITICAL
-      end if
     end do
-    !$OMP END DO NOWAIT
-    deallocate (A_ind_mwen, A_val_mwen)
+    !$OMP END DO
+   
     !$OMP END PARALLEL
-    
-    print *, "ATA SIZE", ata_size
-    x = 0d0
+
+    X(:) = 0d0
     
     
-    do a_coll = 1, nactive
+    do a_coll = 1, n_exc_active
       a_col = active_pp_idx(a_coll)
       X(a_col) = AtB(a_col)
     end do
@@ -822,122 +671,122 @@ END_PROVIDER
     rho_mrcc_init = 0d0
     
     allocate(lref(N_det_ref))
-    !$OMP PARALLEL DO default(shared) schedule(static, 1) &
-        !$OMP private(lref, hh, pp, II, myMask, myDet, ok, ind, phase)
     do hh = 1, hh_shortcut(0)
-     do pp = hh_shortcut(hh), hh_shortcut(hh+1)-1
-      if(active(pp)) cycle
-      lref = 0
-      do II=1,N_det_ref
-        call apply_hole_local(psi_ref(1,1,II), hh_exists(1, hh), myMask, ok, N_int)
-        if(.not. ok) cycle
-        call apply_particle_local(myMask, pp_exists(1, pp), myDet, ok, N_int)
-        if(.not. ok) cycle
-        ind = searchDet(psi_non_ref_sorted(1,1,1), myDet(1,1), N_det_non_ref, N_int)
-        if(ind == -1) cycle
-        ind = psi_non_ref_sorted_idx(ind)
-        call get_phase(myDet(1,1), psi_ref(1,1,II), phase, N_int)
-        X(pp) += psi_ref_coef(II,s)**2
-        AtB(pp) += psi_non_ref_coef(ind, s) * psi_ref_coef(II, s) * phase
-        lref(II) = ind
-        if(phase < 0d0) lref(II) = -ind
+      do pp = hh_shortcut(hh), hh_shortcut(hh+1)-1
+        if(is_active_exc(pp)) cycle
+        lref = 0
+        AtB(pp) = 0.d0
+        do II=1,N_det_ref
+          call apply_hole_local(psi_ref(1,1,II), hh_exists(1, hh), myMask, ok, N_int)
+          if(.not. ok) cycle
+          call apply_particle_local(myMask, pp_exists(1, pp), myDet, ok, N_int)
+          if(.not. ok) cycle
+          ind = searchDet(psi_non_ref_sorted(1,1,1), myDet(1,1), N_det_non_ref, N_int)
+          if(ind == -1) cycle
+          ind = psi_non_ref_sorted_idx(ind)
+          call get_phase(myDet(1,1), psi_ref(1,1,II), phase, N_int)
+          AtB(pp) += psi_non_ref_coef(ind, s) * psi_ref_coef(II, s) * phase
+          lref(II) = ind
+          if(phase < 0.d0) lref(II) = -ind
+        end do
+        X(pp) =  AtB(pp) 
+        do II=1,N_det_ref
+          if(lref(II) > 0) then
+            rho_mrcc_init(lref(II)) = psi_ref_coef(II,s) * X(pp)
+          else if(lref(II) < 0) then
+            rho_mrcc_init(-lref(II)) = -psi_ref_coef(II,s) * X(pp)
+          end if
+        end do
       end do
-      X(pp) =  AtB(pp) / X(pp)
-      do II=1,N_det_ref
-        if(lref(II) > 0) then
-          rho_mrcc_init(lref(II),s) = psi_ref_coef(II,s) * X(pp)
-        else if(lref(II) < 0) then
-          rho_mrcc_init(-lref(II),s) = -psi_ref_coef(II,s) * X(pp)
-        end if
-      end do
-     end do
     end do
-    !$OMP END PARALLEL DO
-    
+    deallocate(lref)
+
+    do i=1,N_det_non_ref
+      rho_mrcc(i,s) = rho_mrcc_init(i) 
+    enddo
+
     x_new = x
-     
-    double precision :: factor, resold
+    
+    double precision               :: factor, resold
     factor = 1.d0
     resold = huge(1.d0)
-    do k=0,100000
-      !$OMP PARALLEL default(shared) private(cx, i, j, a_col, a_coll)
-      
+
+    do k=0,10*hh_nex
+      res = 0.d0
+      !$OMP PARALLEL default(shared) private(cx, i, a_col, a_coll) reduction(+:res)
       !$OMP DO
-      do i=1,N_det_non_ref
-        rho_mrcc(i,s) = rho_mrcc_init(i,s) ! 0d0
-      enddo
-      !$OMP END DO
-      
-      !$OMP DO
-      do a_coll = 1, nactive !: nex
+      do a_coll = 1, n_exc_active
         a_col = active_pp_idx(a_coll)
-        cx = 0d0
-        do i=col_shortcut(a_coll), col_shortcut(a_coll) + N_col(a_coll) - 1
-          cx = cx + x(AtA_ind(i)) * AtA_val(i)
+        cx = 0.d0
+        do i=mrcc_col_shortcut(a_coll), mrcc_col_shortcut(a_coll) + mrcc_N_col(a_coll) - 1
+          cx = cx + x(mrcc_AtA_ind(i)) * mrcc_AtA_val(s,i)
         end do
         x_new(a_col) = AtB(a_col) + cx * factor
+        res = res + (X_new(a_col) - X(a_col))*(X_new(a_col) - X(a_col))
+        X(a_col) = X_new(a_col)
       end do
       !$OMP END DO
-      
       !$OMP END PARALLEL
       
-      res = 0.d0
-     
-      
-      if (res < resold) then
-         do a_coll=1,nactive ! nex
-          a_col = active_pp_idx(a_coll)
-          do j=1,N_det_non_ref
-            i = A_ind(j,a_coll)
-            if (i==0) exit
-            rho_mrcc(i,s) = rho_mrcc(i,s) + A_val(j,a_coll) * X_new(a_col)
-          enddo
-          res = res + (X_new(a_col) - X(a_col))*(X_new(a_col) - X(a_col))
-          X(a_col) = X_new(a_col)
-         end do
-         factor = 1.d0
-      else
-        factor = -factor * 0.5d0
+      if (res > resold) then
+        factor = factor * 0.5d0
       endif
       resold = res
-
-      if(mod(k, 5) == 0) then
+      
+      if(iand(k, 4095) == 0) then
         print *, "res ", k, res
       end if
       
-      if(res < 1d-12) exit
+      if(res < 1d-10) exit
     end do
-    
-    
-    
-    norm = 0.d0
-     do i=1,N_det_non_ref
-       norm = norm + rho_mrcc(i,s)*rho_mrcc(i,s)
-     enddo
-     ! Norm now contains the norm of A.X
+    dIj_unique(1:size(X), s) = X(1:size(X))
 
-     do i=1,N_det_ref
-       norm = norm + psi_ref_coef(i,s)*psi_ref_coef(i,s)
-     enddo
-     ! Norm now contains the norm of Psi + A.X
-     
-     print *, k, "res : ", res, "norm : ", sqrt(norm)
-     
-     !dIj_unique(:size(X), s) = X(:)
+  enddo
+
+  do s=1,N_states
+
+    do a_coll=1,n_exc_active
+      a_col = active_pp_idx(a_coll)
+      do j=1,N_det_non_ref
+        i = active_excitation_to_determinants_idx(j,a_coll)
+        if (i==0) exit
+        rho_mrcc(i,s) = rho_mrcc(i,s) + active_excitation_to_determinants_val(s,j,a_coll) * dIj_unique(a_col,s)
+      enddo
+    end do
+
+    norm = 0.d0
+    do i=1,N_det_non_ref
+      norm = norm + rho_mrcc(i,s)*rho_mrcc(i,s)
+    enddo
+    ! Norm now contains the norm of A.X
+    
+    do i=1,N_det_ref
+      norm = norm + psi_ref_coef(i,s)*psi_ref_coef(i,s)
+    enddo
+    ! Norm now contains the norm of Psi + A.X
+    
+    print *, "norm : ", sqrt(norm)
+   enddo
      
+        
+   do s=1,N_states
      norm = 0.d0
-     double precision :: f
+     double precision               :: f
      do i=1,N_det_non_ref
        if (rho_mrcc(i,s) == 0.d0) then
          rho_mrcc(i,s) = 1.d-32
        endif
 
-       ! f is such that f.\tilde{c_i} = c_i
-       f = psi_non_ref_coef(i,s) / rho_mrcc(i,s)
+       if (lambda_type == 2) then
+         f = 1.d0
+       else
+        ! f is such that f.\tilde{c_i} = c_i
+        f = psi_non_ref_coef(i,s) / rho_mrcc(i,s)
 
-       ! Avoid numerical instabilities
-       f = min(f,2.d0)
-       f = max(f,-2.d0)
+        ! Avoid numerical instabilities
+        f = min(f,2.d0)
+        f = max(f,-2.d0)
+      endif
 
        norm = norm + f*f *rho_mrcc(i,s)*rho_mrcc(i,s)
        rho_mrcc(i,s) = f
@@ -958,6 +807,9 @@ END_PROVIDER
 
      norm = norm*f
      print *,  'norm of |T Psi_0> = ', dsqrt(norm)
+     if (dsqrt(norm) > 1.d0) then
+       stop 'Error : Norm of the SD larger than the norm of the reference.'
+     endif
 
      do i=1,N_det_ref
        norm = norm + psi_ref_coef(i,s)*psi_ref_coef(i,s)
@@ -969,8 +821,8 @@ END_PROVIDER
      ! rho_mrcc now contains the product of the scaling factors and the
      ! normalization constant
     
-     dIj_unique(:size(X), s) = X(:)
   end do
+
 END_PROVIDER
 
 
@@ -980,17 +832,14 @@ BEGIN_PROVIDER [ double precision, dij, (N_det_ref, N_det_non_ref, N_states) ]
   integer :: s,i,j
   double precision, external :: get_dij_index
   print *, "computing amplitudes..."
-  !$OMP PARALLEL DEFAULT(shared) PRIVATE(s,i,j)
   do s=1, N_states
-    !$OMP DO
     do i=1, N_det_non_ref
       do j=1, N_det_ref
+        !DIR$ FORCEINLINE
         dij(j, i, s) = get_dij_index(j, i, s, N_int)
       end do
     end do
-    !$OMP END DO 
   end do
-  !$OMP END PARALLEL
   print *, "done computing amplitudes"
 END_PROVIDER
 
@@ -1006,9 +855,13 @@ double precision function get_dij_index(II, i, s, Nint)
     call get_phase(psi_ref(1,1,II), psi_non_ref(1,1,i), phase, N_int)
     get_dij_index = get_dij(psi_ref(1,1,II), psi_non_ref(1,1,i), s, Nint) * phase
     get_dij_index = get_dij_index * rho_mrcc(i,s) 
-  else
+  else if(lambda_type == 1) then
     call i_h_j(psi_ref(1,1,II), psi_non_ref(1,1,i), Nint, HIi)
     get_dij_index = HIi * lambda_mrcc(s, i)
+  else if(lambda_type == 2) then
+    call get_phase(psi_ref(1,1,II), psi_non_ref(1,1,i), phase, N_int)
+    get_dij_index = get_dij(psi_ref(1,1,II), psi_non_ref(1,1,i), s, Nint) * phase
+    get_dij_index = get_dij_index * rho_mrcc(i,s) 
   end if
 end function
 
@@ -1066,9 +919,21 @@ end function
 
 
  BEGIN_PROVIDER [ integer*2, hh_exists, (4, N_hh_exists) ]
-&BEGIN_PROVIDER [ integer, hh_shortcut, (0:N_hh_exists + 1) ]
 &BEGIN_PROVIDER [ integer*2, pp_exists, (4, N_pp_exists) ]
+&BEGIN_PROVIDER [ integer, hh_shortcut, (0:N_hh_exists + 1) ]
+&BEGIN_PROVIDER [ integer, hh_nex ]
   implicit none
+  BEGIN_DOC
+  !
+  ! hh_exists : 
+  !
+  ! pp_exists : 
+  !
+  ! hh_shortcut : 
+  !
+  ! hh_nex : Total number of excitation operators
+  !
+  END_DOC
   integer*2,allocatable :: num(:,:)
   integer :: exc(0:2, 2, 2), degree, n, on, s, l, i
   integer*2 :: h1, h2, p1, p2
@@ -1134,6 +999,7 @@ end function
       end if
     end do
   end do
+  hh_nex = hh_shortcut(hh_shortcut(0)+1)-1
 END_PROVIDER