Merge pull request #1 from LCPQ/master

Merge...

.travis.yml

@@ -9,12 +9,12 @@ sudo: false
 addons:
   apt:
     packages:
-    - zlib1g-dev
-    - libgmp3-dev
     - gfortran
     - gcc
     - liblapack-dev
     - graphviz
+#    - zlib1g-dev
+#    - libgmp3-dev
 
 cache:
   directories:
@@ -25,8 +25,8 @@ python:
     - "2.6"
 
 script: 
-  - ./configure  --production ./config/gfortran.cfg
+  - ./configure  --production ./config/travis.cfg
-  - source ./quantum_package.rc ; qp_module.py install Full_CI Full_CI_ZMQ Hartree_Fock CAS_SD mrcepa0 All_singles
+  - 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)
 

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++" ],
+    "zeromq" : [ "g++", "make" ],
-    "f77zmq" : [ "zeromq", "python" ],
+    "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.11.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))
 
 
@@ -494,16 +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}"', "",
+        'export LIBRARY_PATH="${QP_ROOT}"/lib:"${LIBRARY_PATH}"',
-        'source ${QP_ROOT}/install/EZFIO/Bash/ezfio.sh', "",
+        'export C_INCLUDE_PATH="${C_INCLUDE_PATH}":"${QP_ROOT}"/include',
-        'source ${HOME}/.opam/opam-init/init.sh > /dev/null 2> /dev/null || true',
+        '',
+        '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))

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}
+source scripts/build.sh
-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

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 
+  ./configure --prefix=$QP_ROOT && make || exit 1 
-  ln -sf ${PWD}/src/m4 ${QP_ROOT}/bin || exit 1 
 }
 
 source scripts/build.sh

install/scripts/install_ocaml.sh

@@ -5,11 +5,11 @@ QP_ROOT=$PWD
 cd -
 
 # Normal installation
-PACKAGES="core cryptokit zarith 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,7 +9,7 @@ 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

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.?
+  make install || exit 1
-  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
   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
+  ./configure --prefix=$QP_ROOT && make || exit 1 
-  ln -s -f $QP_ROOT/install/${TARGET}/lib/libz.so $QP_ROOT/lib || exit 1
+  make install || 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
 }
 
 source scripts/build.sh

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 =
+  let loop, element_read, old_pos =
-     ref Element.X, 
+     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,123 +152,125 @@ let find in_channel element =
 
 (** Read the Pseudopotential in GAMESS format *)
 let read_element in_channel element =
-  ignore (find in_channel element);
+  match find in_channel element with
-
+  | Some e when e = 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 ->
     begin
-      let first_line_split = 
+      let rec read result =
-        String.split first_line ~on:' '
+        match In_channel.input_line in_channel with
-        |> List.filter ~f:(fun x -> (String.strip x) <> "")
+        | 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
+      let data = 
-  | (0,rest) -> List.rev accu, rest
+        read []
-  | (n,line::rest) -> 
+        |> List.rev
-    begin
+      in
-      match
+
-        String.split line ~on:' '
+      let debug_data = 
-        |> List.filter ~f:(fun x -> String.strip x <> "")
+        String.concat ~sep:"\n" data
-      with
+      in
-      | c :: i :: e :: [] ->
+
-        let i =
+      let decode_first_line = function
-          Int.of_string i
+      | first_line :: rest ->
-        in
+        begin
-        let elem =
+          let first_line_split = 
-          ( create_primitive 
+            String.split first_line ~on:' '
-            (Float.of_string e |> AO_expo.of_float)
+            |> List.filter ~f:(fun x -> (String.strip x) <> "")
-            (i-2 |> R_power.of_int),
+          in
-            Float.of_string c |> AO_coef.of_float 
+          match first_line_split with
-          )
+          | e :: "GEN" :: n :: p ->
-        in
+            {  element = Element.of_string e ;
-        loop create_primitive (elem::accu) (n-1, rest)
+              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
-
-  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
+      let rec loop create_primitive accu = function
-    match data with
+      | (0,rest) -> List.rev accu, rest
-    | n :: rest ->
+      | (n,line::rest) -> 
-        let n =
+        begin
-          String.strip n
+          match
-          |> Int.of_string
+            String.split line ~on:' '
-          |> Positive_int.of_int
+            |> 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
+
+      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
+        match data with
-    | _ -> failwith ("Unable to read (non-)local pseudopotential\n"^debug_data)
+        | n :: rest ->
-  in
+            let n =
-
+              String.strip n
-  let decode_non_local (pseudo,data) = 
+              |> Int.of_string
-    let decode_non_local_n proj n (pseudo,data) =
+              |> Positive_int.of_int
-      let result, rest = 
+            in
-        loop (Primitive_non_local.of_proj_expo_r_power proj)
+            decode_local_n n rest
-          [] (Positive_int.to_int n, data)
+        | _ -> 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
+      let decode_non_local (pseudo,data) = 
-  |> decode_local
+        let decode_non_local_n proj n (pseudo,data) =
-  |> decode_non_local 
+          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
 
  
 

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 

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_selectors = max(threshold_selectors,threshold_selectors_pt2)
-    threshold_generators = 0.999d0
+    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.irp.f

@@ -1,3 +1,480 @@
+use bitmasks
+
+
+double precision function integral8(i,j,k,l)
+  implicit none
+  
+  integer, intent(in) :: i,j,k,l
+  double precision, external :: get_mo_bielec_integral
+  integer :: ii
+  ii = l-mo_integrals_cache_min
+  ii = ior(ii, k-mo_integrals_cache_min)
+  ii = ior(ii, j-mo_integrals_cache_min)
+  ii = ior(ii, i-mo_integrals_cache_min)
+  if (iand(ii, -64) /= 0) then
+    integral8 = get_mo_bielec_integral(i,j,k,l,mo_integrals_map)
+  else
+    ii = l-mo_integrals_cache_min
+    ii = ior( ishft(ii,6), k-mo_integrals_cache_min)
+    ii = ior( ishft(ii,6), j-mo_integrals_cache_min)
+    ii = ior( ishft(ii,6), i-mo_integrals_cache_min)
+    integral8 = mo_integrals_cache(ii)
+  endif
+end function
+
+
+BEGIN_PROVIDER [ integer(1), psi_phasemask, (N_int*bit_kind_size, 2, N_det)]
+  use bitmasks
+  implicit none
+  
+  integer :: i
+  do i=1, N_det
+    call get_mask_phase(psi_selectors(1,1,i), psi_phasemask(1,1,i))
+  end do
+END_PROVIDER
+
+
+subroutine assert(cond, msg)
+  character(*), intent(in) :: msg
+  logical, intent(in) :: cond
+  
+  if(.not. cond) then
+    print *, "assert fail: "//msg
+    stop
+  end if
+end subroutine
+
+
+subroutine get_mask_phase(det, phasemask)
+  use bitmasks
+  implicit none
+
+  integer(bit_kind), intent(in) :: det(N_int, 2)
+  integer(1), intent(out) :: phasemask(N_int*bit_kind_size, 2)
+  integer :: s, ni, i
+  logical :: change
+
+  phasemask = 0_1
+  do s=1,2
+    change = .false.
+    do ni=1,N_int
+      do i=0,bit_kind_size-1
+        if(BTEST(det(ni, s), i)) change = .not. change
+          if(change) phasemask((ni-1)*bit_kind_size + i + 1, s) = 1_1
+      end do
+    end do
+  end do
+end subroutine
+
+
+subroutine select_connected(i_generator,E0,pt2,b)
+  use bitmasks
+  use selection_types
+  implicit none
+  integer, intent(in)            :: i_generator
+  type(selection_buffer), intent(inout) :: b
+  double precision, intent(inout)  :: pt2(N_states)
+  integer :: k,l
+  double precision, intent(in)   :: E0(N_states)
+
+  integer(bit_kind)              :: hole_mask(N_int,2), particle_mask(N_int,2)
+  double precision               :: fock_diag_tmp(2,mo_tot_num+1)
+  
+  call build_fock_tmp(fock_diag_tmp,psi_det_generators(1,1,i_generator),N_int)
+
+  do l=1,N_generators_bitmask
+    do k=1,N_int
+      hole_mask(k,1) = iand(generators_bitmask(k,1,s_hole,l), psi_det_generators(k,1,i_generator))
+      hole_mask(k,2) = iand(generators_bitmask(k,2,s_hole,l), psi_det_generators(k,2,i_generator))
+      particle_mask(k,1) = iand(generators_bitmask(k,1,s_part,l), not(psi_det_generators(k,1,i_generator)) )
+      particle_mask(k,2) = iand(generators_bitmask(k,2,s_part,l), not(psi_det_generators(k,2,i_generator)) )
+
+    enddo
+    call select_doubles(i_generator,hole_mask,particle_mask,fock_diag_tmp,E0,pt2,b)
+    call select_singles(i_generator,hole_mask,particle_mask,fock_diag_tmp,E0,pt2,b)
+  enddo
+end subroutine
+
+
+double precision function get_phase_bi(phasemask, s1, s2, h1, p1, h2, p2)
+  use bitmasks
+  implicit none
+
+  integer(1), intent(in) :: phasemask(N_int*bit_kind_size, 2)
+  integer, intent(in) :: s1, s2, h1, h2, p1, p2
+  logical :: change
+  integer(1) :: np
+  double precision, parameter :: res(0:1) = (/1d0, -1d0/)
+
+  np = phasemask(h1,s1) + phasemask(p1,s1) + phasemask(h2,s2) + phasemask(p2,s2)
+  if(p1 < h1) np = np + 1_1
+  if(p2 < h2) np = np + 1_1
+  
+  if(s1 == s2 .and. max(h1, p1) > min(h2, p2)) np = np + 1_1
+  get_phase_bi = res(iand(np,1_1))
+end subroutine
+
+
+
+! Selection single
+! ----------------
+
+subroutine select_singles(i_gen,hole_mask,particle_mask,fock_diag_tmp,E0,pt2,buf)
+  use bitmasks
+  use selection_types
+  implicit none
+  BEGIN_DOC
+! Select determinants connected to i_det by H
+  END_DOC
+  integer, intent(in)             :: i_gen
+  integer(bit_kind), intent(in)   :: hole_mask(N_int,2), particle_mask(N_int,2)
+  double precision, intent(in)    :: fock_diag_tmp(mo_tot_num)
+  double precision, intent(in)    :: E0(N_states)
+  double precision, intent(inout) :: pt2(N_states)
+  type(selection_buffer), intent(inout) :: buf
+  
+  double precision                :: vect(N_states, mo_tot_num)
+  logical                         :: bannedOrb(mo_tot_num)
+  integer                         :: i, j, k
+  integer                         :: h1,h2,s1,s2,i1,i2,ib,sp
+  integer(bit_kind)               :: hole(N_int,2), particle(N_int,2), mask(N_int, 2)
+  logical                         :: fullMatch, ok
+  
+  
+  do k=1,N_int
+    hole    (k,1) = iand(psi_det_generators(k,1,i_gen), hole_mask(k,1))
+    hole    (k,2) = iand(psi_det_generators(k,2,i_gen), hole_mask(k,2))
+    particle(k,1) = iand(not(psi_det_generators(k,1,i_gen)), particle_mask(k,1))
+    particle(k,2) = iand(not(psi_det_generators(k,2,i_gen)), particle_mask(k,2))
+  enddo
+
+  ! Create lists of holes and particles
+  ! -----------------------------------
+
+  integer                        :: N_holes(2), N_particles(2)
+  integer                        :: hole_list(N_int*bit_kind_size,2)
+  integer                        :: particle_list(N_int*bit_kind_size,2)
+
+  call bitstring_to_list_ab(hole    , hole_list    , N_holes    , N_int)
+  call bitstring_to_list_ab(particle, particle_list, N_particles, N_int)
+
+  do sp=1,2
+    do i=1, N_holes(sp)
+      h1 = hole_list(i,sp)
+      call apply_hole(psi_det_generators(1,1,i_gen), sp, h1, mask, ok, N_int)
+      bannedOrb = .true.
+      do j=1,N_particles(sp)
+        bannedOrb(particle_list(j, sp)) = .false.
+      end do
+      call spot_hasBeen(mask, sp, psi_selectors, i_gen, N_det, bannedOrb, fullMatch)
+      if(fullMatch) cycle
+      vect = 0d0
+      call splash_p(mask, sp, psi_selectors(1,1,i_gen), psi_phasemask(1,1,i_gen), psi_selectors_coef_transp(1,i_gen), N_det_selectors - i_gen + 1, bannedOrb, vect)
+      call fill_buffer_single(i_gen, sp, h1, bannedOrb, fock_diag_tmp, E0, pt2, vect, buf)
+    end do
+  enddo
+end subroutine
+
+
+subroutine fill_buffer_single(i_generator, sp, h1, bannedOrb, fock_diag_tmp, E0, pt2, vect, buf)
+  use bitmasks
+  use selection_types
+  implicit none
+  
+  integer, intent(in) :: i_generator, sp, h1
+  double precision, intent(in) :: vect(N_states, mo_tot_num)
+  logical, intent(in) :: bannedOrb(mo_tot_num)
+  double precision, intent(in)           :: fock_diag_tmp(mo_tot_num)
+  double precision, intent(in)    :: E0(N_states)
+  double precision, intent(inout) :: pt2(N_states)
+  type(selection_buffer), intent(inout) :: buf
+  logical :: ok
+  integer :: s1, s2, p1, p2, ib, istate
+  integer(bit_kind) :: mask(N_int, 2), det(N_int, 2)
+  double precision :: e_pert, delta_E, val, Hii, max_e_pert, tmp
+  double precision, external :: diag_H_mat_elem_fock
+  
+  
+  call apply_hole(psi_det_generators(1,1,i_generator), sp, h1, mask, ok, N_int)
+  
+  do p1=1,mo_tot_num
+    if(bannedOrb(p1)) cycle
+    if(vect(1, p1) == 0d0) cycle
+    call apply_particle(mask, sp, p1, det, ok, N_int)
+    
+    Hii = diag_H_mat_elem_fock(psi_det_generators(1,1,i_generator),det,fock_diag_tmp,N_int)
+    max_e_pert = 0d0
+    
+    do istate=1,N_states
+      val = vect(istate, p1) + vect(istate, p1)
+      delta_E = E0(istate) - Hii
+      tmp = dsqrt(delta_E * delta_E + val * val)
+      if (delta_E < 0.d0) then
+        tmp = -tmp
+      endif
+      e_pert = 0.5d0 * ( tmp - delta_E)
+      pt2(istate) += e_pert
+      if(dabs(e_pert) > dabs(max_e_pert)) max_e_pert = e_pert
+    end do
+    
+    if(dabs(max_e_pert) > buf%mini) then
+       call add_to_selection_buffer(buf, det, max_e_pert)
+     endif
+  end do
+end subroutine
+
+
+subroutine splash_p(mask, sp, det, phasemask, coefs, N_sel, bannedOrb, vect)
+  use bitmasks
+  implicit none
+
+  integer(bit_kind),intent(in) :: mask(N_int, 2), det(N_int,2,N_sel)
+  integer(1), intent(in) :: phasemask(N_int*bit_kind_size, 2, N_sel)
+  double precision, intent(in) :: coefs(N_states, N_sel)
+  integer, intent(in) :: sp, N_sel
+  logical, intent(inout) :: bannedOrb(mo_tot_num)
+  double precision, intent(inout)     :: vect(N_states, mo_tot_num)
+
+  integer :: i, j, h(0:2,2), p(0:3,2), nt
+  integer(bit_kind) :: perMask(N_int, 2), mobMask(N_int, 2), negMask(N_int, 2)
+  
+  do i=1,N_int
+    negMask(i,1) = not(mask(i,1))
+    negMask(i,2) = not(mask(i,2))
+  end do
+
+  do i=1, N_sel
+    nt = 0
+    do j=1,N_int
+      mobMask(j,1) = iand(negMask(j,1), det(j,1,i))
+      mobMask(j,2) = iand(negMask(j,2), det(j,2,i))
+      nt += popcnt(mobMask(j, 1)) + popcnt(mobMask(j, 2))
+    end do
+
+    if(nt > 3) cycle
+      
+    do j=1,N_int
+      perMask(j,1) = iand(mask(j,1), not(det(j,1,i)))
+      perMask(j,2) = iand(mask(j,2), not(det(j,2,i)))
+    end do
+
+    call bitstring_to_list(perMask(1,1), h(1,1), h(0,1), N_int)
+    call bitstring_to_list(perMask(1,2), h(1,2), h(0,2), N_int)
+
+    call bitstring_to_list(mobMask(1,1), p(1,1), p(0,1), N_int)
+    call bitstring_to_list(mobMask(1,2), p(1,2), p(0,2), N_int)
+    
+    if(nt == 3) then
+      call get_m2(det(1,1,i), phasemask(1,1,i), bannedOrb, vect, mask, h, p, sp, coefs(1, i))
+    else if(nt == 2) then
+      call get_m1(det(1,1,i), phasemask(1,1,i), bannedOrb, vect, mask, h, p, sp, coefs(1, i))
+    else
+      call get_m0(det(1,1,i), phasemask(1,1,i), bannedOrb, vect, mask, h, p, sp, coefs(1, i))
+    end if
+  end do
+end subroutine
+
+
+subroutine get_m2(gen, phasemask, bannedOrb, vect, mask, h, p, sp, coefs)
+  use bitmasks
+  implicit none
+  
+  integer(bit_kind), intent(in) :: gen(N_int, 2), mask(N_int, 2)
+  integer(1), intent(in) :: phasemask(N_int*bit_kind_size, 2)
+  logical, intent(in) :: bannedOrb(mo_tot_num)
+  double precision, intent(in) :: coefs(N_states)
+  double precision, intent(inout) :: vect(N_states, mo_tot_num)
+  integer, intent(in) :: sp, h(0:2, 2), p(0:3, 2)
+  integer :: i, j, h1, h2, p1, p2, sfix, hfix, pfix, hmob, pmob, puti
+  double precision :: hij
+  double precision, external :: get_phase_bi, integral8
+  
+  integer, parameter :: turn3_2(2,3) = reshape((/2,3, 1,3, 1,2/), (/2,3/))
+  integer, parameter :: turn2(2) = (/2,1/) 
+  
+  if(h(0,sp) == 2) then
+    h1 = h(1, sp)
+    h2 = h(2, sp)
+    do i=1,3
+      puti = p(i, sp)
+      if(bannedOrb(puti)) cycle
+      p1 = p(turn3_2(1,i), sp)
+      p2 = p(turn3_2(2,i), sp)
+      hij = integral8(p1, p2, h1, h2) - integral8(p2, p1, h1, h2)
+      hij *= get_phase_bi(phasemask, sp, sp, h1, p1, h2, p2)
+      vect(:, puti) += hij * coefs
+    end do
+  else if(h(0,sp) == 1) then
+    sfix = turn2(sp)
+    hfix = h(1,sfix)
+    pfix = p(1,sfix)
+    hmob = h(1,sp)
+    do j=1,2
+      puti = p(j, sp)
+      if(bannedOrb(puti)) cycle
+      pmob = p(turn2(j), sp)
+      hij = integral8(pfix, pmob, hfix, hmob)
+      hij *= get_phase_bi(phasemask, sp, sfix, hmob, pmob, hfix, pfix)
+      vect(:, puti) += hij * coefs
+    end do
+  else
+    puti = p(1,sp)
+    if(.not. bannedOrb(puti)) then
+      sfix = turn2(sp)
+      p1 = p(1,sfix)
+      p2 = p(2,sfix)
+      h1 = h(1,sfix)
+      h2 = h(2,sfix)
+      hij = (integral8(p1,p2,h1,h2) - integral8(p2,p1,h1,h2))
+      hij *= get_phase_bi(phasemask, sfix, sfix, h1, p1, h2, p2)
+      vect(:, puti) += hij * coefs
+    end if
+  end if
+end subroutine
+
+
+
+subroutine get_m1(gen, phasemask, bannedOrb, vect, mask, h, p, sp, coefs)
+  use bitmasks
+  implicit none
+  
+  integer(bit_kind), intent(in) :: gen(N_int, 2), mask(N_int, 2)
+  integer(1), intent(in) :: phasemask(N_int*bit_kind_size, 2)
+  logical, intent(in) :: bannedOrb(mo_tot_num)
+  double precision, intent(in) :: coefs(N_states)
+  double precision, intent(inout) :: vect(N_states, mo_tot_num)
+  integer, intent(in) :: sp, h(0:2, 2), p(0:3, 2)
+  integer :: i, hole, p1, p2, sh
+  logical :: ok, lbanned(mo_tot_num)
+  integer(bit_kind) :: det(N_int, 2)
+  double precision :: hij
+  double precision, external :: get_phase_bi, integral8
+  
+  lbanned = bannedOrb
+  sh = 1
+  if(h(0,2) == 1) sh = 2
+  hole = h(1, sh)
+  lbanned(p(1,sp)) = .true.
+  if(p(0,sp) == 2) lbanned(p(2,sp)) = .true.
+  !print *, "SPm1", sp, sh
+  
+  p1 = p(1, sp)
+  
+  if(sp == sh) then
+    p2 = p(2, sp)
+    lbanned(p2) = .true.
+    
+    do i=1,hole-1
+      if(lbanned(i)) cycle
+      hij = (integral8(p1, p2, i, hole) - integral8(p2, p1, i, hole))
+      hij *= get_phase_bi(phasemask, sp, sp, i, p1, hole, p2)
+      vect(:,i) += hij * coefs
+    end do
+    do i=hole+1,mo_tot_num
+      if(lbanned(i)) cycle
+      hij = (integral8(p1, p2, hole, i) - integral8(p2, p1, hole, i))
+      hij *= get_phase_bi(phasemask, sp, sp, hole, p1, i, p2)
+      vect(:,i) += hij * coefs
+    end do
+
+    call apply_particle(mask, sp, p2, det, ok,  N_int)
+    call i_h_j(gen, det, N_int, hij)
+    vect(:, p2) += hij * coefs
+  else
+    p2 = p(1, sh)
+    do i=1,mo_tot_num
+      if(lbanned(i)) cycle
+      hij = integral8(p1, p2, i, hole)
+      hij *= get_phase_bi(phasemask, sp, sh, i, p1, hole, p2)
+      vect(:,i) += hij * coefs
+    end do
+  end if
+
+  call apply_particle(mask, sp, p1, det, ok,  N_int)
+  call i_h_j(gen, det, N_int, hij)
+  vect(:, p1) += hij * coefs
+end subroutine
+
+
+subroutine get_m0(gen, phasemask, bannedOrb, vect, mask, h, p, sp, coefs)
+  use bitmasks
+  implicit none
+  
+  integer(bit_kind), intent(in) :: gen(N_int, 2), mask(N_int, 2)
+  integer(1), intent(in) :: phasemask(N_int*bit_kind_size, 2)
+  logical, intent(in) :: bannedOrb(mo_tot_num)
+  double precision, intent(in) :: coefs(N_states)
+  double precision, intent(inout) :: vect(N_states, mo_tot_num)
+  integer, intent(in) :: sp, h(0:2, 2), p(0:3, 2)
+  integer :: i
+  logical :: ok, lbanned(mo_tot_num)
+  integer(bit_kind) :: det(N_int, 2)
+  double precision :: hij
+  
+  lbanned = bannedOrb
+  lbanned(p(1,sp)) = .true.
+  do i=1,mo_tot_num
+    if(lbanned(i)) cycle
+    call apply_particle(mask, sp, i, det, ok, N_int)
+    call i_h_j(gen, det, N_int, hij)
+    vect(:, i) += hij * coefs
+  end do
+end subroutine
+
+
+subroutine spot_hasBeen(mask, sp, det, i_gen, N, banned, fullMatch)
+  use bitmasks
+  implicit none
+  
+  integer(bit_kind),intent(in) :: mask(N_int, 2), det(N_int, 2, N)
+  integer, intent(in) :: i_gen, N, sp
+  logical, intent(inout) :: banned(mo_tot_num)
+  logical, intent(out) :: fullMatch
+
+
+  integer :: i, j, na, nb, list(3), nt
+  integer(bit_kind) :: myMask(N_int, 2), negMask(N_int, 2)
+
+  fullMatch = .false.
+
+  do i=1,N_int
+    negMask(i,1) = not(mask(i,1))
+    negMask(i,2) = not(mask(i,2))
+  end do
+
+  do i=1, N
+    nt = 0
+    
+    do j=1, N_int
+      myMask(j, 1) = iand(det(j, 1, i), negMask(j, 1))
+      myMask(j, 2) = iand(det(j, 2, i), negMask(j, 2))
+      nt += popcnt(myMask(j, 1)) + popcnt(myMask(j, 2))
+    end do
+    
+    if(nt > 3) cycle
+    
+    if(nt <= 2 .and. i < i_gen) then
+      fullMatch = .true.
+      return
+    end if
+    
+    call bitstring_to_list(myMask(1,sp), list(1), na, N_int)
+    
+    if(nt == 3 .and. i < i_gen) then
+      do j=1,na
+        banned(list(j)) = .true.
+      end do
+    else if(nt == 1 .and. na == 1) then
+      banned(list(1)) = .true.
+    end if
+  end do 
+end subroutine
+
+
+
+
+! Selection double
+! ----------------
  
 subroutine select_doubles(i_generator,hole_mask,particle_mask,fock_diag_tmp,E0,pt2,buf)
   use bitmasks
@@ -49,8 +526,8 @@ subroutine select_doubles(i_generator,hole_mask,particle_mask,fock_diag_tmp,E0,p
   do i=1,N_det
     nt = 0
     do j=1,N_int
-      mobMask(j,1) = iand(negMask(j,1), psi_det_sorted(j,1,i))
+      mobMask(j,1) = iand(negMask(j,1), psi_selectors(j,1,i))
-      mobMask(j,2) = iand(negMask(j,2), psi_det_sorted(j,2,i))
+      mobMask(j,2) = iand(negMask(j,2), psi_selectors(j,2,i))
       nt += popcnt(mobMask(j, 1)) + popcnt(mobMask(j, 2))
     end do
 
@@ -83,19 +560,19 @@ subroutine select_doubles(i_generator,hole_mask,particle_mask,fock_diag_tmp,E0,p
         i = preinteresting(ii)
         nt = 0
         do j=1,N_int
-          mobMask(j,1) = iand(negMask(j,1), psi_det_sorted(j,1,i))
+          mobMask(j,1) = iand(negMask(j,1), psi_selectors(j,1,i))
-          mobMask(j,2) = iand(negMask(j,2), psi_det_sorted(j,2,i))
+          mobMask(j,2) = iand(negMask(j,2), psi_selectors(j,2,i))
           nt += popcnt(mobMask(j, 1)) + popcnt(mobMask(j, 2))
         end do
         
         if(nt <= 4) then
           interesting(0) += 1
           interesting(interesting(0)) = i
-          minilist(:,:,interesting(0)) = psi_det_sorted(:,:,i)
+          minilist(:,:,interesting(0)) = psi_selectors(:,:,i)
           if(nt <= 2) then
             fullinteresting(0) += 1
             fullinteresting(fullinteresting(0)) = i
-            fullminilist(:,:,fullinteresting(0)) = psi_det_sorted(:,:,i)
+            fullminilist(:,:,fullinteresting(0)) = psi_selectors(:,:,i)
           end if
         end if
       end do
@@ -104,15 +581,15 @@ subroutine select_doubles(i_generator,hole_mask,particle_mask,fock_diag_tmp,E0,p
         i = prefullinteresting(ii)
         nt = 0
         do j=1,N_int
-          mobMask(j,1) = iand(negMask(j,1), psi_det_sorted(j,1,i))
+          mobMask(j,1) = iand(negMask(j,1), psi_selectors(j,1,i))
-          mobMask(j,2) = iand(negMask(j,2), psi_det_sorted(j,2,i))
+          mobMask(j,2) = iand(negMask(j,2), psi_selectors(j,2,i))
           nt += popcnt(mobMask(j, 1)) + popcnt(mobMask(j, 2))
         end do
 
         if(nt <= 2) then
           fullinteresting(0) += 1
           fullinteresting(fullinteresting(0)) = i
-          fullminilist(:,:,fullinteresting(0)) = psi_det_sorted(:,:,i)
+          fullminilist(:,:,fullinteresting(0)) = psi_selectors(:,:,i)
         end if
       end do
       
@@ -168,7 +645,7 @@ subroutine fill_buffer_double(i_generator, sp, h1, h2, bannedOrb, banned, fock_d
   logical :: ok
   integer :: s1, s2, p1, p2, ib, j, istate
   integer(bit_kind) :: mask(N_int, 2), det(N_int, 2)
-  double precision :: e_pert, delta_E, val, Hii, max_e_pert
+  double precision :: e_pert, delta_E, val, Hii, max_e_pert,tmp
   double precision, external :: diag_H_mat_elem_fock
   
   logical, external :: detEq
@@ -193,6 +670,10 @@ subroutine fill_buffer_double(i_generator, sp, h1, h2, bannedOrb, banned, fock_d
       if(banned(p1,p2)) cycle
       if(mat(1, p1, p2) == 0d0) cycle
       call apply_particles(mask, s1, p1, s2, p2, det, ok, N_int)
+logical, external :: is_in_wavefunction
+if (is_in_wavefunction(det,N_int)) then
+  cycle
+endif
       
       
       Hii = diag_H_mat_elem_fock(psi_det_generators(1,1,i_generator),det,fock_diag_tmp,N_int)
@@ -200,14 +681,14 @@ subroutine fill_buffer_double(i_generator, sp, h1, h2, bannedOrb, banned, fock_d
       
       do istate=1,N_states
         delta_E = E0(istate) - Hii
-        val = mat(istate, p1, p2)
+        val = mat(istate, p1, p2) + mat(istate, p1, p2) 
+        tmp = dsqrt(delta_E * delta_E + val * val)
         if (delta_E < 0.d0) then
-          e_pert = 0.5d0 * (-dsqrt(delta_E * delta_E + 4.d0 * val * val) - delta_E)
+          tmp = -tmp
-        else
-          e_pert = 0.5d0 * ( dsqrt(delta_E * delta_E + 4.d0 * val * val) - delta_E)
         endif
-        pt2(istate) += e_pert
+        e_pert = 0.5d0 * ( tmp - delta_E)
-        if(dabs(e_pert) > dabs(max_e_pert)) max_e_pert = e_pert
+        pt2(istate) = pt2(istate) + e_pert
+        max_e_pert = min(e_pert,max_e_pert)
       end do
       
       if(dabs(max_e_pert) > buf%mini) then

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
+  if(.not.selected_fobo_ci)then
-  soft_touch selection_criterion
+   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)
+     hij = get_mo_bielec_integral(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)
+     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)
+     hij = get_mo_bielec_integral(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)
+     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)
+     hij = get_mo_bielec_integral(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)
+     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)
+     hij = get_mo_bielec_integral(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)
+     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)
+     hij = get_mo_bielec_integral(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)
+     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)
+     hij = get_mo_bielec_integral(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)
+     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(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,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_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))
- allocate(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)
+ 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)
- if(do_it_perturbative)then
+!do m = 1, N_states
-  if(is_ok)then
+! 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.
+! no_oa_or_av_opt = .False.
-  touch no_oa_or_av_opt
+! 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
+   if(is_ok)then
-   allocate(dressing_matrix(N_det_generators,N_det_generators))
+    allocate(dressing_matrix(N_det_generators,N_det_generators))
-   dressing_matrix = 0.d0
+    dressing_matrix = 0.d0
-   if(.not.do_it_perturbative)then
+     do k = 1, N_det_generators
-
+      do l = 1, N_det_generators
-    do k = 1, N_det_generators
+        call i_h_j(psi_det_generators(1,1,k),psi_det_generators(1,1,l),N_int,hkl)
-     do l = 1, N_det_generators
+        dressing_matrix(k,l) = hkl
-       call i_h_j(psi_det_generators(1,1,k),psi_det_generators(1,1,l),N_int,hkl)
+      enddo
-       dressing_matrix(k,l) = hkl
+     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
-    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
+     ! 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_particl_as_input(reunion_of_bitmask)
-    call set_bitmask_hole_as_input(reunion_of_bitmask)
+     call set_bitmask_hole_as_input(reunion_of_bitmask)
-    call all_single
+     call all_single(e_pt2)
-!   if(dressing_2h2p)then
+     call make_s2_eigenfunction_first_order
-!    call diag_dressed_2h2p_hamiltonian_and_update_psi_det(i_hole_osoci,lmct)
+     threshold_davidson = 1.d-6
-!   endif
+     soft_touch threshold_davidson davidson_criterion
-
+     call diagonalize_ci
-!   ! 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
     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
+    if(is_ok)then
-     allocate(dressing_matrix(N_det_generators,N_det_generators))
+      allocate(dressing_matrix(N_det_generators,N_det_generators))
-    if(.not.do_it_perturbative)then
+      dressing_matrix = 0.d0
-     dressing_matrix = 0.d0
+      do k = 1, N_det_generators
-     do k = 1, N_det_generators
+       do l = 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)
-        call i_h_j(psi_det_generators(1,1,k),psi_det_generators(1,1,l),N_int,hkl)
+         dressing_matrix(k,l) = hkl
-        dressing_matrix(k,l) = hkl
+       enddo
       enddo
-     enddo
+      call all_single(e_pt2)
- !   call all_single_split(psi_det_generators,psi_coef_generators,N_det_generators,dressing_matrix)
+      call make_s2_eigenfunction_first_order
- !   call diag_dressed_matrix_and_set_to_psi_det(psi_det_generators,N_det_generators,dressing_matrix)
+      threshold_davidson = 1.d-6
-     call all_single
+      soft_touch threshold_davidson davidson_criterion
-!    if(dressing_2h2p)then
+     
-!     call diag_dressed_2h2p_hamiltonian_and_update_psi_det(i_particl_osoci,lmct)
+      call diagonalize_ci
-!    endif
+      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_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(i,j) - one_body_dm_mo_beta_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_alpha_average = one_body_dm_mo_alpha_osoci
-   one_body_dm_mo_beta = one_body_dm_mo_beta_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_tot += one_body_dm_mo_alpha_average(i,i) + one_body_dm_mo_beta_average(i,i)
-    accu_sd  += one_body_dm_mo_alpha(i,i) - one_body_dm_mo_beta(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 = H_apply("FCI_PT2")
-#s.set_perturbation("epstein_nesbet_2x2")
-#s.unset_openmp()
-#print s
-
-s = H_apply_zmq("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 = threshold_generators_pt2
-    threshold_generators = 0.999d0
+    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/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,40 @@ 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 = 1.d0
+    threshold_selectors = max(threshold_selectors,threshold_selectors_pt2)
-    threshold_generators = 0.9999d0
+    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'
@@ -98,9 +111,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
 
 
@@ -121,38 +136,43 @@ subroutine ZMQ_selection(N_in, pt2)
   double precision, intent(out)  :: pt2(N_states)
   
   
-  N = max(N_in,1)
+  if (.True.) then
-  provide nproc
+    PROVIDE pt2_e0_denominator
-  provide ci_electronic_energy
+    N = max(N_in,1)
-  call new_parallel_job(zmq_to_qp_run_socket,"selection")
+    provide nproc
-  call zmq_put_psi(zmq_to_qp_run_socket,1,ci_electronic_energy,size(ci_electronic_energy))
+    call new_parallel_job(zmq_to_qp_run_socket,"selection")
-  call zmq_set_running(zmq_to_qp_run_socket)
+    call zmq_put_psi(zmq_to_qp_run_socket,1,pt2_e0_denominator,size(pt2_e0_denominator))
-  call create_selection_buffer(N, N*2, b)
+    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= N_det_generators, 1, -step
+  do i= 1, N_det_generators,step
-    i_generator_start = max(i-step+1,1)
+    i_generator_start = i
-    i_generator_max = 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(none)  SHARED(b, pt2)  PRIVATE(i) NUM_THREADS(nproc+1) shared(ci_electronic_energy_is_built, n_det_generators_is_built, n_states_is_built, n_int_is_built, nproc_is_built)
+  !$OMP PARALLEL DEFAULT(shared)  SHARED(b, pt2)  PRIVATE(i) NUM_THREADS(nproc+1)
-      i = omp_get_thread_num()
+  i = omp_get_thread_num()
-      if (i==0) then
+  if (i==0) then
-        call selection_collector(b, pt2)
+    call selection_collector(b, pt2)
-      else
+  else
-        call selection_slave_inproc(i)
+    call selection_slave_inproc(i)
-      endif
+  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
 
@@ -161,7 +181,7 @@ subroutine selection_slave_inproc(i)
   implicit none
   integer, intent(in)            :: i
 
-  call run_selection_slave(1,i,ci_electronic_energy)
+  call run_selection_slave(1,i,pt2_e0_denominator)
 end
 
 subroutine selection_collector(b, pt2)

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_single.irp.f

@@ -1,354 +0,0 @@
- 
-
-subroutine select_singles(i_gen,hole_mask,particle_mask,fock_diag_tmp,E0,pt2,buf)
-  use bitmasks
-  use selection_types
-  implicit none
-  BEGIN_DOC
-! Select determinants connected to i_det by H
-  END_DOC
-  integer, intent(in)             :: i_gen
-  integer(bit_kind), intent(in)   :: hole_mask(N_int,2), particle_mask(N_int,2)
-  double precision, intent(in)    :: fock_diag_tmp(mo_tot_num)
-  double precision, intent(in)    :: E0(N_states)
-  double precision, intent(inout) :: pt2(N_states)
-  type(selection_buffer), intent(inout) :: buf
-  
-  double precision                :: vect(N_states, mo_tot_num)
-  logical                         :: bannedOrb(mo_tot_num)
-  integer                         :: i, j, k
-  integer                         :: h1,h2,s1,s2,i1,i2,ib,sp
-  integer(bit_kind)               :: hole(N_int,2), particle(N_int,2), mask(N_int, 2)
-  logical                         :: fullMatch, ok
-  
-  
-  do k=1,N_int
-    hole    (k,1) = iand(psi_det_generators(k,1,i_gen), hole_mask(k,1))
-    hole    (k,2) = iand(psi_det_generators(k,2,i_gen), hole_mask(k,2))
-    particle(k,1) = iand(not(psi_det_generators(k,1,i_gen)), particle_mask(k,1))
-    particle(k,2) = iand(not(psi_det_generators(k,2,i_gen)), particle_mask(k,2))
-  enddo
-
-  ! Create lists of holes and particles
-  ! -----------------------------------
-
-  integer                        :: N_holes(2), N_particles(2)
-  integer                        :: hole_list(N_int*bit_kind_size,2)
-  integer                        :: particle_list(N_int*bit_kind_size,2)
-
-  call bitstring_to_list_ab(hole    , hole_list    , N_holes    , N_int)
-  call bitstring_to_list_ab(particle, particle_list, N_particles, N_int)
-
-  do sp=1,2
-    do i=1, N_holes(sp)
-      h1 = hole_list(i,sp)
-      call apply_hole(psi_det_generators(1,1,i_gen), sp, h1, mask, ok, N_int)
-      bannedOrb = .true.
-      do j=1,N_particles(sp)
-        bannedOrb(particle_list(j, sp)) = .false.
-      end do
-      call spot_hasBeen(mask, sp, psi_det_sorted, i_gen, N_det, bannedOrb, fullMatch)
-      if(fullMatch) cycle
-      vect = 0d0
-      call splash_p(mask, sp, psi_selectors(1,1,i_gen), psi_phasemask(1,1,i_gen), psi_selectors_coef_transp(1,i_gen), N_det_selectors - i_gen + 1, bannedOrb, vect)
-      call fill_buffer_single(i_gen, sp, h1, bannedOrb, fock_diag_tmp, E0, pt2, vect, buf)
-    end do
-  enddo
-end subroutine
-
-
-subroutine fill_buffer_single(i_generator, sp, h1, bannedOrb, fock_diag_tmp, E0, pt2, vect, buf)
-  use bitmasks
-  use selection_types
-  implicit none
-  
-  integer, intent(in) :: i_generator, sp, h1
-  double precision, intent(in) :: vect(N_states, mo_tot_num)
-  logical, intent(in) :: bannedOrb(mo_tot_num)
-  double precision, intent(in)           :: fock_diag_tmp(mo_tot_num)
-  double precision, intent(in)    :: E0(N_states)
-  double precision, intent(inout) :: pt2(N_states)
-  type(selection_buffer), intent(inout) :: buf
-  logical :: ok
-  integer :: s1, s2, p1, p2, ib, istate
-  integer(bit_kind) :: mask(N_int, 2), det(N_int, 2)
-  double precision :: e_pert, delta_E, val, Hii, max_e_pert
-  double precision, external :: diag_H_mat_elem_fock
-  
-  
-  call apply_hole(psi_det_generators(1,1,i_generator), sp, h1, mask, ok, N_int)
-  
-  do p1=1,mo_tot_num
-    if(bannedOrb(p1)) cycle
-    if(vect(1, p1) == 0d0) cycle
-    call apply_particle(mask, sp, p1, det, ok, N_int)
-    
-    
-    Hii = diag_H_mat_elem_fock(psi_det_generators(1,1,i_generator),det,fock_diag_tmp,N_int)
-    max_e_pert = 0d0
-    
-    do istate=1,N_states
-      val = vect(istate, p1)
-      delta_E = E0(istate) - Hii
-      if (delta_E < 0.d0) then
-        e_pert = 0.5d0 * (-dsqrt(delta_E * delta_E + 4.d0 * val * val) - delta_E)
-      else
-        e_pert = 0.5d0 * ( dsqrt(delta_E * delta_E + 4.d0 * val * val) - delta_E)
-      endif
-      pt2(istate) += e_pert
-      if(dabs(e_pert) > dabs(max_e_pert)) max_e_pert = e_pert
-    end do
-    
-    if(dabs(max_e_pert) > buf%mini) call add_to_selection_buffer(buf, det, max_e_pert)
-  end do
-end subroutine
-
-
-subroutine splash_p(mask, sp, det, phasemask, coefs, N_sel, bannedOrb, vect)
-  use bitmasks
-  implicit none
-
-  integer(bit_kind),intent(in) :: mask(N_int, 2), det(N_int,2,N_sel)
-  integer(1), intent(in) :: phasemask(N_int*bit_kind_size, 2, N_sel)
-  double precision, intent(in) :: coefs(N_states, N_sel)
-  integer, intent(in) :: sp, N_sel
-  logical, intent(inout) :: bannedOrb(mo_tot_num)
-  double precision, intent(inout)     :: vect(N_states, mo_tot_num)
-
-  integer :: i, j, h(0:2,2), p(0:3,2), nt
-  integer(bit_kind) :: perMask(N_int, 2), mobMask(N_int, 2), negMask(N_int, 2)
-  
-  do i=1,N_int
-    negMask(i,1) = not(mask(i,1))
-    negMask(i,2) = not(mask(i,2))
-  end do
-
-  do i=1, N_sel
-    nt = 0
-    do j=1,N_int
-      mobMask(j,1) = iand(negMask(j,1), det(j,1,i))
-      mobMask(j,2) = iand(negMask(j,2), det(j,2,i))
-      nt += popcnt(mobMask(j, 1)) + popcnt(mobMask(j, 2))
-    end do
-
-    if(nt > 3) cycle
-      
-    do j=1,N_int
-      perMask(j,1) = iand(mask(j,1), not(det(j,1,i)))
-      perMask(j,2) = iand(mask(j,2), not(det(j,2,i)))
-    end do
-
-    call bitstring_to_list(perMask(1,1), h(1,1), h(0,1), N_int)
-    call bitstring_to_list(perMask(1,2), h(1,2), h(0,2), N_int)
-
-    call bitstring_to_list(mobMask(1,1), p(1,1), p(0,1), N_int)
-    call bitstring_to_list(mobMask(1,2), p(1,2), p(0,2), N_int)
-    
-    if(nt == 3) then
-      call get_m2(det(1,1,i), phasemask(1,1,i), bannedOrb, vect, mask, h, p, sp, coefs(1, i))
-    else if(nt == 2) then
-      call get_m1(det(1,1,i), phasemask(1,1,i), bannedOrb, vect, mask, h, p, sp, coefs(1, i))
-    else
-      call get_m0(det(1,1,i), phasemask(1,1,i), bannedOrb, vect, mask, h, p, sp, coefs(1, i))
-    end if
-  end do
-end subroutine
-
-
-subroutine get_m2(gen, phasemask, bannedOrb, vect, mask, h, p, sp, coefs)
-  use bitmasks
-  implicit none
-  
-  integer(bit_kind), intent(in) :: gen(N_int, 2), mask(N_int, 2)
-  integer(1), intent(in) :: phasemask(N_int*bit_kind_size, 2)
-  logical, intent(in) :: bannedOrb(mo_tot_num)
-  double precision, intent(in) :: coefs(N_states)
-  double precision, intent(inout) :: vect(N_states, mo_tot_num)
-  integer, intent(in) :: sp, h(0:2, 2), p(0:3, 2)
-  integer :: i, j, h1, h2, p1, p2, sfix, hfix, pfix, hmob, pmob, puti
-  double precision :: hij
-  double precision, external :: get_phase_bi, integral8
-  
-  integer, parameter :: turn3_2(2,3) = reshape((/2,3, 1,3, 1,2/), (/2,3/))
-  integer, parameter :: turn2(2) = (/2,1/) 
-  
-  if(h(0,sp) == 2) then
-    h1 = h(1, sp)
-    h2 = h(2, sp)
-    do i=1,3
-      puti = p(i, sp)
-      if(bannedOrb(puti)) cycle
-      p1 = p(turn3_2(1,i), sp)
-      p2 = p(turn3_2(2,i), sp)
-      hij = integral8(p1, p2, h1, h2) - integral8(p2, p1, h1, h2)
-      hij *= get_phase_bi(phasemask, sp, sp, h1, p1, h2, p2)
-      vect(:, puti) += hij * coefs
-    end do
-  else if(h(0,sp) == 1) then
-    sfix = turn2(sp)
-    hfix = h(1,sfix)
-    pfix = p(1,sfix)
-    hmob = h(1,sp)
-    do j=1,2
-      puti = p(j, sp)
-      if(bannedOrb(puti)) cycle
-      pmob = p(turn2(j), sp)
-      hij = integral8(pfix, pmob, hfix, hmob)
-      hij *= get_phase_bi(phasemask, sp, sfix, hmob, pmob, hfix, pfix)
-      vect(:, puti) += hij * coefs
-    end do
-  else
-    puti = p(1,sp)
-    if(.not. bannedOrb(puti)) then
-      sfix = turn2(sp)
-      p1 = p(1,sfix)
-      p2 = p(2,sfix)
-      h1 = h(1,sfix)
-      h2 = h(2,sfix)
-      hij = (integral8(p1,p2,h1,h2) - integral8(p2,p1,h1,h2))
-      hij *= get_phase_bi(phasemask, sfix, sfix, h1, p1, h2, p2)
-      vect(:, puti) += hij * coefs
-    end if
-  end if
-end subroutine
-
-
-
-subroutine get_m1(gen, phasemask, bannedOrb, vect, mask, h, p, sp, coefs)
-  use bitmasks
-  implicit none
-  
-  integer(bit_kind), intent(in) :: gen(N_int, 2), mask(N_int, 2)
-  integer(1), intent(in) :: phasemask(N_int*bit_kind_size, 2)
-  logical, intent(in) :: bannedOrb(mo_tot_num)
-  double precision, intent(in) :: coefs(N_states)
-  double precision, intent(inout) :: vect(N_states, mo_tot_num)
-  integer, intent(in) :: sp, h(0:2, 2), p(0:3, 2)
-  integer :: i, hole, p1, p2, sh
-  logical :: ok, lbanned(mo_tot_num)
-  integer(bit_kind) :: det(N_int, 2)
-  double precision :: hij
-  double precision, external :: get_phase_bi, integral8
-  
-  lbanned = bannedOrb
-  sh = 1
-  if(h(0,2) == 1) sh = 2
-  hole = h(1, sh)
-  lbanned(p(1,sp)) = .true.
-  if(p(0,sp) == 2) lbanned(p(2,sp)) = .true.
-  !print *, "SPm1", sp, sh
-  
-  p1 = p(1, sp)
-  
-  if(sp == sh) then
-    p2 = p(2, sp)
-    lbanned(p2) = .true.
-    
-    do i=1,hole-1
-      if(lbanned(i)) cycle
-      hij = (integral8(p1, p2, i, hole) - integral8(p2, p1, i, hole))
-      hij *= get_phase_bi(phasemask, sp, sp, i, p1, hole, p2)
-      vect(:,i) += hij * coefs
-    end do
-    do i=hole+1,mo_tot_num
-      if(lbanned(i)) cycle
-      hij = (integral8(p1, p2, hole, i) - integral8(p2, p1, hole, i))
-      hij *= get_phase_bi(phasemask, sp, sp, hole, p1, i, p2)
-      vect(:,i) += hij * coefs
-    end do
-
-    call apply_particle(mask, sp, p2, det, ok,  N_int)
-    call i_h_j(gen, det, N_int, hij)
-    vect(:, p2) += hij * coefs
-  else
-    p2 = p(1, sh)
-    do i=1,mo_tot_num
-      if(lbanned(i)) cycle
-      hij = integral8(p1, p2, i, hole)
-      hij *= get_phase_bi(phasemask, sp, sh, i, p1, hole, p2)
-      vect(:,i) += hij * coefs
-    end do
-  end if
-
-  call apply_particle(mask, sp, p1, det, ok,  N_int)
-  call i_h_j(gen, det, N_int, hij)
-  vect(:, p1) += hij * coefs
-end subroutine
-
-
-subroutine get_m0(gen, phasemask, bannedOrb, vect, mask, h, p, sp, coefs)
-  use bitmasks
-  implicit none
-  
-  integer(bit_kind), intent(in) :: gen(N_int, 2), mask(N_int, 2)
-  integer(1), intent(in) :: phasemask(N_int*bit_kind_size, 2)
-  logical, intent(in) :: bannedOrb(mo_tot_num)
-  double precision, intent(in) :: coefs(N_states)
-  double precision, intent(inout) :: vect(N_states, mo_tot_num)
-  integer, intent(in) :: sp, h(0:2, 2), p(0:3, 2)
-  integer :: i
-  logical :: ok, lbanned(mo_tot_num)
-  integer(bit_kind) :: det(N_int, 2)
-  double precision :: hij
-  
-  lbanned = bannedOrb
-  lbanned(p(1,sp)) = .true.
-  do i=1,mo_tot_num
-    if(lbanned(i)) cycle
-    call apply_particle(mask, sp, i, det, ok, N_int)
-    call i_h_j(gen, det, N_int, hij)
-    vect(:, i) += hij * coefs
-  end do
-end subroutine
-
-
-subroutine spot_hasBeen(mask, sp, det, i_gen, N, banned, fullMatch)
-  use bitmasks
-  implicit none
-  
-  integer(bit_kind),intent(in) :: mask(N_int, 2), det(N_int, 2, N)
-  integer, intent(in) :: i_gen, N, sp
-  logical, intent(inout) :: banned(mo_tot_num)
-  logical, intent(out) :: fullMatch
-
-
-  integer :: i, j, na, nb, list(3), nt
-  integer(bit_kind) :: myMask(N_int, 2), negMask(N_int, 2)
-
-  fullMatch = .false.
-
-  do i=1,N_int
-    negMask(i,1) = not(mask(i,1))
-    negMask(i,2) = not(mask(i,2))
-  end do
-
-  genl : do i=1, N
-    nt = 0
-    
-    do j=1, N_int
-      myMask(j, 1) = iand(det(j, 1, i), negMask(j, 1))
-      myMask(j, 2) = iand(det(j, 2, i), negMask(j, 2))
-      nt += popcnt(myMask(j, 1)) + popcnt(myMask(j, 2))
-    end do
-    
-    if(nt > 3) cycle
-    
-    if(nt <= 2 .and. i < i_gen) then
-      fullMatch = .true.
-      return
-    end if
-    
-    call bitstring_to_list(myMask(1,sp), list(1), na, N_int)
-    
-    if(nt == 3 .and. i < i_gen) then
-      do j=1,na
-        banned(list(j)) = .true.
-      end do
-    else if(nt == 1 .and. na == 1) then
-      banned(list(1)) = .true.
-    end if
-  end do genl
-end subroutine
-
-
-

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/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>`_
+`ci_eigenvectors_dressed <http://github.com/LCPQ/quantum_package/tree/master/plugins/MRCC_Utils/mrcc_utils.irp.f#L120>`_
-  Eigenvectors/values of the CI matrix
+  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>`_
+`ci_eigenvectors_s2_dressed <http://github.com/LCPQ/quantum_package/tree/master/plugins/MRCC_Utils/mrcc_utils.irp.f#L121>`_
-  Eigenvectors/values of the CI matrix
+  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>`_
+`ci_electronic_energy_dressed <http://github.com/LCPQ/quantum_package/tree/master/plugins/MRCC_Utils/mrcc_utils.irp.f#L119>`_
-  Eigenvectors/values of the CI matrix
+  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>`_
+`dec_exc <http://github.com/LCPQ/quantum_package/tree/master/plugins/MRCC_Utils/mrcc_utils.irp.f#L532>`_
-  Dressing matrix in N_det basis
+  Undocumented
 
 
-`delta_ij <http://github.com/LCPQ/quantum_package/tree/master/plugins/MRCC_Utils/mrcc_utils.irp.f#L67>`_
+`diagonalize_ci_dressed <http://github.com/LCPQ/quantum_package/tree/master/plugins/MRCC_Utils/mrcc_utils.irp.f#L265>`_
-  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>`_
   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
+  !DIR$ ATTRIBUTES ALIGN : $IRP_ALIGN :: U, W, S, y, h, lambda
-  if (N_st_diag > sze) then
+  if (N_st_diag*3 > sze) then
-     stop 'error in Davidson : N_st_diag > sze'
+     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,29 +680,29 @@ 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
+  itermax = min(davidson_sze_max, sze/N_st_diag)
-
-  if (s2_eig) then
-    delta = 1.d0
-  else
-    delta = 0.d0
-  endif
-
   allocate(                                                          &
-      kl_pairs(2,N_st_diag*(N_st_diag+1)/2),                         &
+      W(sze_8,N_st_diag*itermax),                                    &
-      W(sze_8,N_st_diag*davidson_sze_max),                           &
+      U(sze_8,N_st_diag*itermax),                                    &
-      U(sze_8,N_st_diag*davidson_sze_max),                           &
+      S(sze_8,N_st_diag*itermax),                                    &
-      R(sze_8,N_st_diag),                                            &
+      h(N_st_diag*itermax,N_st_diag*itermax),                        &
-      S(sze_8,N_st_diag*davidson_sze_max),                           &
+      y(N_st_diag*itermax,N_st_diag*itermax),                        &
-      h(N_st_diag*davidson_sze_max,N_st_diag*davidson_sze_max),      &
+      s_(N_st_diag*itermax,N_st_diag*itermax),                       &
-      y(N_st_diag*davidson_sze_max,N_st_diag*davidson_sze_max),      &
+      s_tmp(N_st_diag*itermax,N_st_diag*itermax),                    &
-      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),  &
       residual_norm(N_st_diag),                                      &
-      overlap(N_st_diag,N_st_diag),                                  &
+      c(N_st_diag*itermax),                                          &
-      c(N_st_diag*davidson_sze_max),                                 &
+      s2(N_st_diag*itermax),                                         &
-      s2(N_st_diag*davidson_sze_max),                                &
+      overlap(N_st_diag*itermax,N_st_diag*itermax),                  &
-      lambda(N_st_diag*davidson_sze_max))
+      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)
@@ -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
+  double precision               :: r1, r2
-    call normalize(u_in(1,k),sze)
-  enddo
-
   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
-    
+  enddo
-    ! Gram-Schmidt
+  do k=1,N_st_diag
-    ! ------------
+      call normalize(u_in(1,k),sze)
-    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
 
   
@@ -773,11 +744,11 @@ 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,26 +757,52 @@ subroutine davidson_diag_hjj_sjj_mrcc(dets_in,u_in,H_jj,S2_jj,energies,dim_in,sz
       ! -------------------------------------------
 
 
-!      do l=1,N_st_diag
+      call dgemm('T','N', shift2, shift2, sze,            &
-!        do k=1,N_st_diag
+          1.d0, U, size(U,1), W, size(W,1),                &
-!          do iter2=1,iter-1
+          0.d0, h, size(h,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)
+      call dgemm('T','N', shift2, shift2, sze,            &
-!          enddo
+          1.d0, U, size(U,1), S, size(S,1),                &
-!        enddo
+          0.d0, s_, size(s_,1))
-!        do k=1,l
+
-!          h(k,iter,l,iter) = u_dot_v(U(1,k,iter),W(1,l,iter),sze)
+!      ! Diagonalize S^2
-!          h(l,iter,k,iter) = h(k,iter,l,iter)
+!      ! ---------------
+!
+!      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
       ! -------------
@@ -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)
+          logical :: state_ok(N_st_diag*davidson_sze_max)
-        do k=1,shift2
+          do k=1,shift2
-          state_ok(k) = (dabs(s2(k)-expected_s2) < 0.3d0)
+            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 i=1,shift2
-            do l=k+1,shift2
+            overlap(k,i) = dabs(y(k,i))
-              if (state_ok(l)) then
+          enddo
-                call dswap(shift2, y(1,k), 1, y(1,l), 1)
+        enddo
-                call dswap(1, s2(k), 1, s2(l), 1)
+        do k=1,N_st
-                call dswap(1, lambda(k), 1, lambda(l), 1)
+          cmax = -1.d0
-                state_ok(k) = .True.
+          do i=1,N_st
-                state_ok(l) = .False.
+            if (overlap(i,k) > cmax) then
-                exit
+              cmax = overlap(i,k) 
-              endif
+              order(k) = i
-            enddo
+            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,                    &
@@ -877,101 +909,64 @@ 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
+!        if (state_ok(k)) then
-          R(i,k) = (lambda(k) * U(i,shift2+k) - W(i,shift2+k) ) &
+          do i=1,sze
-            * (1.d0 + s2(k) * U(i,shift2+k) - S(i,shift2+k) - S_z2_Sz)
+            U(i,shift2+k) = (lambda(k) * U(i,shift2+k) - W(i,shift2+k) )      &
-        enddo
+                * (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
+    call dgemm('N','N', sze, N_st_diag, shift2,                    &
-      energies(k) = lambda(k)
+        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
+  enddo
-!      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))
 
+  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 END DO
-  !$OMP DO SCHEDULE(dynamic)
+  !$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_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
@@ -75,19 +76,6 @@ BEGIN_PROVIDER [ double precision, hij_mrcc, (N_det_non_ref,N_det_ref) ]
     enddo
   enddo
 
-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
 
 
@@ -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,&
+     allocate (eigenvectors(size(CI_eigenvectors_dressed,1),size(CI_eigenvectors_dressed,2)), &
-!          size(CI_eigenvectors_dressed,1),N_det,N_states,N_states_diag,N_int,output_determinants,mrcc_state)
+     eigenvalues(size(CI_electronic_energy_dressed,1)))
-
+     do j=1,min(N_states,N_det)
-     call davidson_diag_mrcc_HS2(psi_det,CI_eigenvectors_dressed,&
+       do i=1,N_det
-          size(CI_eigenvectors_dressed,1), &
+         eigenvectors(i,j) = psi_coef(i,j)
-          CI_electronic_energy_dressed,N_det,N_states,N_states_diag,N_int, &
+       enddo
-          output_determinants,mrcc_state)
+     enddo
-
+     do mrcc_state=1,N_states
-     call u_0_S2_u_0(CI_eigenvectors_s2_dressed,CI_eigenvectors_dressed,N_det,psi_det,N_int,&
+      do j=mrcc_state,min(N_states,N_det)
-         N_states_diag,size(CI_eigenvectors_dressed,1))
+        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
+  integer                        :: N, INFO, r1, r2
-  double precision , allocatable :: AtB(:), AtA_val(:), A_val(:,:), x(:), x_new(:), A_val_mwen(:)
+  double precision , allocatable :: AtB(:), x(:), x_new(:), A_val_mwen(:,:), t(:)
-  double precision               :: t, norm, cx, res
+  double precision               :: norm, cx, res
-  integer, allocatable           :: A_ind(:,:), lref(:), AtA_ind(:), A_ind_mwen(:), col_shortcut(:), N_col(:)
+  integer, allocatable           :: lref(:), A_ind_mwen(:)
   double precision               :: phase
   
   
-  integer, allocatable :: pathTo(:), active_hh_idx(:), active_pp_idx(:)
+  double precision, allocatable :: rho_mrcc_init(:)
-  logical, allocatable :: active(:)
+  integer                        :: a_coll, at_roww
-  double precision, allocatable :: rho_mrcc_init(:,:)
-  integer :: nactive
   
-  nex = hh_shortcut(hh_shortcut(0)+1)-1
+  print *, "TI", hh_nex, N_det_non_ref
-  print *, "TI", nex, N_det_non_ref
 
-  allocate(pathTo(N_det_non_ref), active(nex))
+  allocate(rho_mrcc_init(N_det_non_ref))
-  allocate(active_pp_idx(nex), active_hh_idx(nex))
+  allocate(x_new(hh_nex))
-  allocate(rho_mrcc_init(N_det_non_ref, N_states))
+  allocate(x(hh_nex), AtB(hh_nex))
 
-  pathTo = 0
+  do s=1,N_states
-  active = .false.
-  nactive = 0
 
-  
+    AtB(:) = 0.d0
-  do hh = 1, hh_shortcut(0)
+    !$OMP PARALLEL default(none) shared(k, psi_non_ref_coef, active_excitation_to_determinants_idx,&
-    do pp = hh_shortcut(hh), hh_shortcut(hh+1)-1
+        !$OMP   active_excitation_to_determinants_val, N_det_ref, hh_nex, N_det_non_ref)          &
-      do II = 1, N_det_ref
+        !$OMP private(at_row, a_col, i, j, r1, r2, wk, A_ind_mwen, A_val_mwen, a_coll, at_roww)&
-        call apply_hole_local(psi_ref(1,1,II), hh_exists(1, hh), myMask, ok, N_int)
+        !$OMP shared(N_states,mrcc_col_shortcut, mrcc_N_col, AtB, mrcc_AtA_val, mrcc_AtA_ind, s, n_exc_active, active_pp_idx)
-        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))
-        
-
-  
-  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
-    
-    
-    print *,  'Done building A_val, A_ind'
-    
-    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
+      do i=1,active_excitation_to_determinants_idx(0,at_roww)
-      if(mod(at_roww, 100) == 0) print *, "AtA", at_row, "/", nex
+          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)
-      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)
       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
+    !$OMP END DO
-    deallocate (A_ind_mwen, A_val_mwen)
+   
     !$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,12 +671,11 @@ 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
+        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
@@ -837,78 +685,74 @@ END_PROVIDER
           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
+          if(phase < 0.d0) lref(II) = -ind
         end do
-        X(pp) =  AtB(pp) / X(pp)
+        X(pp) =  AtB(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)
+            rho_mrcc_init(lref(II)) = 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)
+            rho_mrcc_init(-lref(II)) = -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
     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
+      do a_coll = 1, n_exc_active
-        rho_mrcc(i,s) = rho_mrcc_init(i,s) ! 0d0
-      enddo
-      !$OMP END DO
-      
-      !$OMP DO
-      do a_coll = 1, nactive !: nex
         a_col = active_pp_idx(a_coll)
-        cx = 0d0
+        cx = 0.d0
-        do i=col_shortcut(a_coll), col_shortcut(a_coll) + N_col(a_coll) - 1
+        do i=mrcc_col_shortcut(a_coll), mrcc_col_shortcut(a_coll) + mrcc_N_col(a_coll) - 1
-          cx = cx + x(AtA_ind(i)) * AtA_val(i)
+          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
-      
+        factor = factor * 0.5d0
-      
-      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
       endif
       resold = res
       
-      if(mod(k, 100) == 0) then
+      if(iand(k, 4095) == 0) then
         print *, "res ", k, res
       end if
       
-      if(res < 1d-9) exit
+      if(res < 1d-10) exit
     end do
+    dIj_unique(1:size(X), s) = X(1:size(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
@@ -921,122 +765,11 @@ END_PROVIDER
     enddo
     ! Norm now contains the norm of Psi + A.X
     
-    print *, k, "res : ", res, "norm : ", sqrt(norm)
+    print *, "norm : ", sqrt(norm)
+   enddo
      
-!---------------
-! double precision               :: e_0, overlap
-! double precision, allocatable  :: u_0(:)
-! integer(bit_kind), allocatable :: keys_tmp(:,:,:)
-! allocate (u_0(N_det), keys_tmp(N_int,2,N_det) )
-! k=0
-! overlap = 0.d0
-! do i=1,N_det_ref
-!   k = k+1
-!   u_0(k) = psi_ref_coef(i,1)
-!   keys_tmp(:,:,k) = psi_ref(:,:,i)
-!   overlap += u_0(k)*psi_ref_coef(i,1)
-! enddo
-! norm = 0.d0
-! do i=1,N_det_non_ref
-!   k = k+1
-!   u_0(k) = psi_non_ref_coef(i,1)
-!   keys_tmp(:,:,k) = psi_non_ref(:,:,i)
-!   overlap += u_0(k)*psi_non_ref_coef(i,1)
-! enddo
-! 
-! call u_0_H_u_0(e_0,u_0,N_det,keys_tmp,N_int,1,N_det)
-! print *,  'Energy of |Psi_CASSD> : ', e_0 + nuclear_repulsion, overlap
-!
-! k=0
-! overlap = 0.d0
-! do i=1,N_det_ref
-!   k = k+1
-!   u_0(k) = psi_ref_coef(i,1)
-!   keys_tmp(:,:,k) = psi_ref(:,:,i)
-!   overlap += u_0(k)*psi_ref_coef(i,1)
-! enddo
-! norm = 0.d0
-! do i=1,N_det_non_ref
-!   k = k+1
-!   ! f is such that f.\tilde{c_i} = c_i
-!   f = psi_non_ref_coef(i,1) / rho_mrcc(i,1)
-!   
-!   ! Avoid numerical instabilities
-!   f = min(f,2.d0)
-!   f = max(f,-2.d0)
-!
-!   f = 1.d0
-!
-!   u_0(k) = rho_mrcc(i,1)*f
-!   keys_tmp(:,:,k) = psi_non_ref(:,:,i)
-!   norm += u_0(k)**2
-!   overlap += u_0(k)*psi_non_ref_coef(i,1)
-! enddo
-! 
-! call u_0_H_u_0(e_0,u_0,N_det,keys_tmp,N_int,1,N_det)
-! print *,  'Energy of |(1+T)Psi_0> : ', e_0 + nuclear_repulsion, overlap
-!
-! f = 1.d0/norm
-! norm = 1.d0
-! do i=1,N_det_ref
-!  norm = norm - psi_ref_coef(i,s)*psi_ref_coef(i,s)
-! enddo
-! f = dsqrt(f*norm)
-! overlap = norm
-! do i=1,N_det_non_ref
-!   u_0(k) = rho_mrcc(i,1)*f
-!   overlap += u_0(k)*psi_non_ref_coef(i,1)
-! enddo
-!
-! call u_0_H_u_0(e_0,u_0,N_det,keys_tmp,N_int,1,N_det)
-! print *,  'Energy of |(1+T)Psi_0> (normalized) : ', e_0 + nuclear_repulsion,  overlap
-!
-! k=0
-! overlap = 0.d0
-! do i=1,N_det_ref
-!   k = k+1
-!   u_0(k) = psi_ref_coef(i,1)
-!   keys_tmp(:,:,k) = psi_ref(:,:,i)
-!   overlap += u_0(k)*psi_ref_coef(i,1)
-! enddo
-! norm = 0.d0
-! do i=1,N_det_non_ref
-!   k = k+1
-!   ! f is such that f.\tilde{c_i} = c_i
-!   f = psi_non_ref_coef(i,1) / rho_mrcc(i,1)
-!   
-!   ! Avoid numerical instabilities
-!   f = min(f,2.d0)
-!   f = max(f,-2.d0)
-!
-!   u_0(k) = rho_mrcc(i,1)*f
-!   keys_tmp(:,:,k) = psi_non_ref(:,:,i)
-!   norm += u_0(k)**2
-!   overlap += u_0(k)*psi_non_ref_coef(i,1)
-! enddo
-! 
-! call u_0_H_u_0(e_0,u_0,N_det,keys_tmp,N_int,1,N_det)
-! print *,  'Energy of |(1+T)Psi_0> (mu_i): ', e_0 + nuclear_repulsion, overlap
-!
-! f = 1.d0/norm
-! norm = 1.d0
-! do i=1,N_det_ref
-!  norm = norm - psi_ref_coef(i,s)*psi_ref_coef(i,s)
-! enddo
-! overlap = norm
-! f = dsqrt(f*norm)
-! do i=1,N_det_non_ref
-!   u_0(k) = rho_mrcc(i,1)*f
-!   overlap += u_0(k)*psi_non_ref_coef(i,1)
-! enddo
-!
-! call u_0_H_u_0(e_0,u_0,N_det,keys_tmp,N_int,1,N_det)
-! print *,  'Energy of |(1+T)Psi_0> (normalized mu_i) : ', e_0 + nuclear_repulsion, overlap
-!
-! deallocate(u_0, keys_tmp)
-!
-!---------------
         
+   do s=1,N_states
      norm = 0.d0
      double precision               :: f
      do i=1,N_det_non_ref
@@ -1044,12 +777,16 @@ END_PROVIDER
          rho_mrcc(i,s) = 1.d-32
        endif
 
-       ! f is such that f.\tilde{c_i} = c_i
+       if (lambda_type == 2) then
-       f = psi_non_ref_coef(i,s) / rho_mrcc(i,s)
+         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
+        ! Avoid numerical instabilities
-       f = min(f,2.d0)
+        f = min(f,2.d0)
-       f = max(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
@@ -1070,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)
@@ -1081,7 +821,6 @@ 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
@@ -1093,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
 
@@ -1119,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
 
@@ -1179,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
@@ -1247,6 +999,7 @@ end function
       end if
     end do
   end do
+  hh_nex = hh_shortcut(hh_shortcut(0)+1)-1
 END_PROVIDER
 
 

plugins/MRCC_Utils/multi_state.irp.f

@@ -0,0 +1,101 @@
+subroutine multi_state(CI_electronic_energy_dressed_,CI_eigenvectors_dressed_,LDA)
+  implicit none
+  BEGIN_DOC
+  ! Multi-state mixing
+  END_DOC
+  integer, intent(in)            :: LDA
+  double precision, intent(inout) :: CI_electronic_energy_dressed_(N_states)
+  double precision, intent(inout) :: CI_eigenvectors_dressed_(LDA,N_states)
+  double precision, allocatable  :: h(:,:,:), s(:,:), Psi(:,:), H_Psi(:,:,:), H_jj(:)
+  
+  allocate( h(N_states,N_states,0:N_states), s(N_states,N_states) )
+  allocate( Psi(LDA,N_states), H_Psi(LDA,N_states,0:N_states) )
+  allocate (H_jj(LDA) )
+  
+!    e_0(i) = u_dot_v(v_0(1,i),u_0(1,i),n)/u_dot_u(u_0(1,i),n)
+
+  integer                        :: i,j,k,istate
+  double precision :: U(N_states,N_states), Vt(N_states,N_states), D(N_states)
+  double precision, external :: diag_H_mat_elem
+  do istate=1,N_states
+    do i=1,N_det
+      H_jj(i) = diag_H_mat_elem(psi_det(1,1,i),N_int)
+    enddo
+
+    do i=1,N_det_ref
+      H_jj(idx_ref(i)) +=  delta_ii(istate,i)
+    enddo
+  
+    do k=1,N_states
+      do i=1,N_det
+        Psi(i,k) = CI_eigenvectors_dressed_(i,k)
+      enddo
+    enddo
+    call H_u_0_mrcc_nstates(H_Psi(1,1,istate),Psi,H_jj,N_det,psi_det,N_int,istate,N_states,LDA)
+
+    do k=1,N_states
+      do i=1,N_states
+        double precision, external :: u_dot_v
+        h(i,k,istate) = u_dot_v(Psi(1,i), H_Psi(1,k,istate), N_det)
+      enddo
+    enddo
+  enddo
+
+  do k=1,N_states
+    do i=1,N_states
+      s(i,k) = u_dot_v(Psi(1,i), Psi(1,k), N_det)
+    enddo
+  enddo
+
+  print *,  s(:,:)
+  print *,  ''
+
+  h(:,:,0) = h(:,:,1)
+  do istate=2,N_states
+    U(:,:) = h(:,:,0)
+    call dgemm('N','N',N_states,N_states,N_states,1.d0,&
+      U, size(U,1), h(1,1,istate), size(h,1), 0.d0, &
+      h(1,1,0), size(Vt,1))
+  enddo
+
+  call svd(h(1,1,0), size(h,1), U, size(U,1), D, Vt, size(Vt,1), N_states, N_states)
+  do k=1,N_states
+    D(k) = D(k)**(1./dble(N_states))
+    if (D(k) > 0.d0) then
+      D(k) = -D(k)
+    endif
+  enddo
+
+  do j=1,N_states
+    do i=1,N_states
+      h(i,j,0) = 0.d0
+      do k=1,N_states
+        h(i,j,0) += U(i,k) * D(k) * Vt(k,j)
+      enddo
+    enddo
+  enddo
+
+  print *,  h(:,:,0)
+  print *,''
+
+  integer :: LWORK, INFO
+  double precision, allocatable :: WORK(:)
+  LWORK=3*N_states
+  allocate (WORK(LWORK))
+  call dsygv(1, 'V', 'U', N_states, h(1,1,0), size(h,1), s, size(s,1), D, WORK, LWORK, INFO)
+  deallocate(WORK)
+
+   do j=1,N_states
+     do i=1,N_det
+       CI_eigenvectors_dressed_(i,j) = 0.d0
+       do k=1,N_states
+         CI_eigenvectors_dressed_(i,j) += Psi(i,k) * h(k,j,0)
+       enddo
+     enddo
+     CI_electronic_energy_dressed_(j) = D(j)
+   enddo
+
+
+  deallocate (h,s, H_jj)
+  deallocate( Psi, H_Psi )
+end

plugins/MRPT/MRPT_Utils.main.irp.f

@@ -0,0 +1,43 @@
+program MRPT_Utils
+  implicit none
+  read_wf = .True.
+  touch read_wf
+! call routine
+! call routine_2
+  call routine_3
+end
+
+
+subroutine routine_3
+ implicit none
+!provide fock_virt_total_spin_trace
+ provide delta_ij 
+ 
+ print *,  'N_det    = ', N_det
+ print *,  'N_states = ', N_states
+ print *,  'PT2      = ', second_order_pt_new(1)
+ print *,  'E        = ', CI_energy(1)
+ print *,  'E+PT2    = ', CI_energy(1)+second_order_pt_new(1)
+ print *,'****** DIAGONALIZATION OF DRESSED MATRIX ******'
+ print *,  'E dressed= ', CI_dressed_pt2_new_energy(1)
+
+end
+
+subroutine routine_2
+ implicit none
+ integer :: i
+ do i = 1, n_core_inact_orb
+  print*,fock_core_inactive_total(i,1,1),fock_core_inactive(i)
+ enddo
+ double precision :: accu
+ accu = 0.d0
+ do i = 1, n_act_orb
+  integer :: j_act_orb
+  j_act_orb = list_act(i)
+  accu += one_body_dm_mo_alpha(j_act_orb,j_act_orb,1)
+  print*,one_body_dm_mo_alpha(j_act_orb,j_act_orb,1),one_body_dm_mo_beta(j_act_orb,j_act_orb,1) 
+ enddo
+ print*,'accu = ',accu
+
+end
+

plugins/MRPT/NEEDED_CHILDREN_MODULES

@@ -0,0 +1 @@
+MRPT_Utils Selectors_full Generators_full

plugins/MRPT/README.rst

@@ -0,0 +1,14 @@
+====
+MRPT
+====
+
+Executables for Multi-reference perturbation.
+
+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/MRPT/mrpt.irp.f

@@ -0,0 +1,38 @@
+program MRPT
+  implicit none
+  BEGIN_DOC
+! TODO
+  END_DOC
+  print *, '  _/                              '
+  print *, ' -:\_?,     _Jm####La             '
+  print *, 'J"(:" >  _]#AZ#Z#UUZ##,           '
+  print *, '_,::./   %(|i%12XmX1*1XL      _?, '
+  print *, '  \..\ _\(vmWQwodY+ia%lnL  _",/ ( '
+  print *, '   .:< ]J=mQD?WXn<uQWmmvd, -.-:=!'
+  print *, '   "{Z jC]QW|=3Zv)Bi3BmXv3  =   _7'
+  print *, '    ]h[Z6)WQ;)jZs]C;|$BZv+, : ./  '
+  print *, '    -#sJX%$Wmm#ev]hinW#Xi:` c ;   '
+  print *, '     #X#X23###1}vI$WWmX1>|,)nr"   '
+  print *, '     4XZ#Xov1v}=)vnXAX1nnv;1n"    '
+  print *, '     ]XX#ZXoovvvivnnnlvvo2*i7     '
+  print *, '     "23Z#1S2oo2XXSnnnoSo2>v"     '
+  print *, '      miX#L -~`""!!1}oSoe|i7      '
+  print *, '      4cn#m,        v221=|v[      '
+  print *, '      ]hI3Zma,;..__wXSe=+vo       '
+  print *, '      ]Zov*XSUXXZXZXSe||vo2       '
+  print *, '      ]Z#><iiii|i||||==vn2(       '
+  print *, '      ]Z#i<ii||+|=||=:{no2[       '
+  print *, '      ]ZUsiiiiivi|=||=vo22[       '
+  print *, '      ]XZvlliiIi|i=|+|vooo        '
+  print *, '      =v1llli||||=|||||lii(       '
+  print *, '      ]iillii||||||||=>=|<        '
+  print *, '      -ziiiii||||||+||==+>        '
+  print *, '       -%|+++||=|=+|=|==/         '
+  print *, '        -a>====+|====-:-          '
+  print *, '          "~,- --   /-            '
+  print *, '            -.     )>             '
+  print *, '           .~      +-             '
+  print *, '           . .... : .             '
+  print *, '            -------~              '
+  print *, ''
+end

plugins/MRPT/print_1h2p.irp.f

@@ -0,0 +1,51 @@
+program print_1h2p
+ implicit none
+ read_wf = .True.
+ touch read_wf
+ call routine
+end
+
+subroutine routine
+ implicit none
+ double precision,allocatable :: matrix_1h2p(:,:,:) 
+ allocate (matrix_1h2p(N_det,N_det,N_states))
+ integer :: i,j,istate
+ do i = 1, N_det
+  do j = 1, N_det
+   do istate = 1, N_states
+    matrix_1h2p(i,j,istate) = 0.d0
+   enddo
+  enddo
+ enddo
+ if(.False.)then
+ call give_1h2p_contrib(matrix_1h2p)
+ double precision :: accu
+ accu = 0.d0
+ do i = 1, N_det
+  do j = 1, N_det 
+   accu += matrix_1h2p(i,j,1) * psi_coef(i,1) * psi_coef(j,1)
+  enddo
+ enddo
+ print*, 'second order ', accu
+ endif
+
+ if(.True.)then
+ do i = 1, N_det
+  do j = 1, N_det
+   do istate = 1, N_states
+    matrix_1h2p(i,j,istate) = 0.d0
+   enddo
+  enddo
+ enddo
+ call give_1h2p_new(matrix_1h2p)
+ accu = 0.d0
+ do i = 1, N_det
+  do j = 1, N_det 
+   accu += matrix_1h2p(i,j,1) * psi_coef(i,1) * psi_coef(j,1)
+  enddo
+ enddo
+ endif
+ print*, 'third  order ', accu
+
+ deallocate (matrix_1h2p)
+end

plugins/MRPT_Utils/EZFIO.cfg

@@ -0,0 +1,7 @@
+[do_third_order_1h1p]
+type: logical
+doc: If true, compute the third order contribution for the 1h1p
+interface: ezfio,provider,ocaml
+default: True
+
+

plugins/MRPT_Utils/H_apply.irp.f

@@ -0,0 +1,187 @@
+use bitmasks
+BEGIN_SHELL [ /usr/bin/env python ]
+from generate_h_apply import *
+
+s = H_apply("mrpt")
+s.data["parameters"] = ", delta_ij_, Ndet"
+s.data["declarations"] += """
+    integer, intent(in) :: Ndet
+    double precision, intent(in) :: delta_ij_(Ndet,Ndet,*)
+"""
+s.data["keys_work"] = "call mrpt_dress(delta_ij_,Ndet,i_generator,key_idx,keys_out,N_int,iproc,key_mask)"
+s.data["params_post"] += ", delta_ij_, Ndet"
+s.data["params_main"] += "delta_ij_,  Ndet"
+s.data["decls_main"] += """
+    integer, intent(in) :: Ndet
+    double precision, intent(in) :: delta_ij_(Ndet,Ndet,*)
+"""
+s.data["finalization"] = ""
+s.data["copy_buffer"] = ""
+s.data["generate_psi_guess"] = ""
+s.data["size_max"] = "3072"
+print s
+
+s = H_apply("mrpt_1h")
+s.filter_only_1h()
+s.data["parameters"] = ", delta_ij_, Ndet"
+s.data["declarations"] += """
+    integer, intent(in) :: Ndet
+    double precision, intent(in) :: delta_ij_(Ndet,Ndet,*)
+"""
+s.data["keys_work"] = "call mrpt_dress(delta_ij_,Ndet,i_generator,key_idx,keys_out,N_int,iproc,key_mask)"
+s.data["params_post"] += ", delta_ij_, Ndet"
+s.data["params_main"] += "delta_ij_,  Ndet"
+s.data["decls_main"] += """
+    integer, intent(in) :: Ndet
+    double precision, intent(in) :: delta_ij_(Ndet,Ndet,*)
+"""
+s.data["finalization"] = ""
+s.data["copy_buffer"] = ""
+s.data["generate_psi_guess"] = ""
+s.data["size_max"] = "3072"
+print s
+
+s = H_apply("mrpt_1p")
+s.filter_only_1p()
+s.data["parameters"] = ", delta_ij_, Ndet"
+s.data["declarations"] += """
+    integer, intent(in) :: Ndet
+    double precision, intent(in) :: delta_ij_(Ndet,Ndet,*)
+"""
+s.data["keys_work"] = "call mrpt_dress(delta_ij_,Ndet,i_generator,key_idx,keys_out,N_int,iproc,key_mask)"
+s.data["params_post"] += ", delta_ij_, Ndet"
+s.data["params_main"] += "delta_ij_,  Ndet"
+s.data["decls_main"] += """
+    integer, intent(in) :: Ndet
+    double precision, intent(in) :: delta_ij_(Ndet,Ndet,*)
+"""
+s.data["finalization"] = ""
+s.data["copy_buffer"] = ""
+s.data["generate_psi_guess"] = ""
+s.data["size_max"] = "3072"
+print s
+
+s = H_apply("mrpt_1h1p")
+s.filter_only_1h1p()
+s.data["parameters"] = ", delta_ij_, Ndet"
+s.data["declarations"] += """
+    integer, intent(in) :: Ndet
+    double precision, intent(in) :: delta_ij_(Ndet,Ndet,*)
+"""
+s.data["keys_work"] = "call mrpt_dress(delta_ij_,Ndet,i_generator,key_idx,keys_out,N_int,iproc,key_mask)"
+s.data["params_post"] += ", delta_ij_, Ndet"
+s.data["params_main"] += "delta_ij_,  Ndet"
+s.data["decls_main"] += """
+    integer, intent(in) :: Ndet
+    double precision, intent(in) :: delta_ij_(Ndet,Ndet,*)
+"""
+s.data["finalization"] = ""
+s.data["copy_buffer"] = ""
+s.data["generate_psi_guess"] = ""
+s.data["size_max"] = "3072"
+print s
+
+s = H_apply("mrpt_2p")
+s.filter_only_2p()
+s.data["parameters"] = ", delta_ij_, Ndet"
+s.data["declarations"] += """
+    integer, intent(in) :: Ndet
+    double precision, intent(in) :: delta_ij_(Ndet,Ndet,*)
+"""
+s.data["keys_work"] = "call mrpt_dress(delta_ij_,Ndet,i_generator,key_idx,keys_out,N_int,iproc,key_mask)"
+s.data["params_post"] += ", delta_ij_, Ndet"
+s.data["params_main"] += "delta_ij_,  Ndet"
+s.data["decls_main"] += """
+    integer, intent(in) :: Ndet
+    double precision, intent(in) :: delta_ij_(Ndet,Ndet,*)
+"""
+s.data["finalization"] = ""
+s.data["copy_buffer"] = ""
+s.data["generate_psi_guess"] = ""
+s.data["size_max"] = "3072"
+print s
+
+s = H_apply("mrpt_2h")
+s.filter_only_2h()
+s.data["parameters"] = ", delta_ij_, Ndet"
+s.data["declarations"] += """
+    integer, intent(in) :: Ndet
+    double precision, intent(in) :: delta_ij_(Ndet,Ndet,*)
+"""
+s.data["keys_work"] = "call mrpt_dress(delta_ij_,Ndet,i_generator,key_idx,keys_out,N_int,iproc,key_mask)"
+s.data["params_post"] += ", delta_ij_, Ndet"
+s.data["params_main"] += "delta_ij_,  Ndet"
+s.data["decls_main"] += """
+    integer, intent(in) :: Ndet
+    double precision, intent(in) :: delta_ij_(Ndet,Ndet,*)
+"""
+s.data["finalization"] = ""
+s.data["copy_buffer"] = ""
+s.data["generate_psi_guess"] = ""
+s.data["size_max"] = "3072"
+print s
+
+
+s = H_apply("mrpt_1h2p")
+s.filter_only_1h2p()
+s.data["parameters"] = ", delta_ij_, Ndet"
+s.data["declarations"] += """
+    integer, intent(in) :: Ndet
+    double precision, intent(in) :: delta_ij_(Ndet,Ndet,*)
+"""
+s.data["keys_work"] = "call mrpt_dress(delta_ij_,Ndet,i_generator,key_idx,keys_out,N_int,iproc,key_mask)"
+s.data["params_post"] += ", delta_ij_, Ndet"
+s.data["params_main"] += "delta_ij_,  Ndet"
+s.data["decls_main"] += """
+    integer, intent(in) :: Ndet
+    double precision, intent(in) :: delta_ij_(Ndet,Ndet,*)
+"""
+s.data["finalization"] = ""
+s.data["copy_buffer"] = ""
+s.data["generate_psi_guess"] = ""
+s.data["size_max"] = "3072"
+print s
+
+s = H_apply("mrpt_2h1p")
+s.filter_only_2h1p()
+s.data["parameters"] = ", delta_ij_, Ndet"
+s.data["declarations"] += """
+    integer, intent(in) :: Ndet
+    double precision, intent(in) :: delta_ij_(Ndet,Ndet,*)
+"""
+s.data["keys_work"] = "call mrpt_dress(delta_ij_,Ndet,i_generator,key_idx,keys_out,N_int,iproc,key_mask)"
+s.data["params_post"] += ", delta_ij_, Ndet"
+s.data["params_main"] += "delta_ij_,  Ndet"
+s.data["decls_main"] += """
+    integer, intent(in) :: Ndet
+    double precision, intent(in) :: delta_ij_(Ndet,Ndet,*)
+"""
+s.data["finalization"] = ""
+s.data["copy_buffer"] = ""
+s.data["generate_psi_guess"] = ""
+s.data["size_max"] = "3072"
+print s
+
+s = H_apply("mrpt_2h2p")
+s.filter_only_2h2p()
+s.data["parameters"] = ", delta_ij_, Ndet"
+s.data["declarations"] += """
+    integer, intent(in) :: Ndet
+    double precision, intent(in) :: delta_ij_(Ndet,Ndet,*)
+"""
+s.data["keys_work"] = "call mrpt_dress(delta_ij_,Ndet,i_generator,key_idx,keys_out,N_int,iproc,key_mask)"
+s.data["params_post"] += ", delta_ij_, Ndet"
+s.data["params_main"] += "delta_ij_,  Ndet"
+s.data["decls_main"] += """
+    integer, intent(in) :: Ndet
+    double precision, intent(in) :: delta_ij_(Ndet,Ndet,*)
+"""
+s.data["finalization"] = ""
+s.data["copy_buffer"] = ""
+s.data["generate_psi_guess"] = ""
+s.data["size_max"] = "3072"
+print s
+
+
+END_SHELL
+

plugins/MRPT_Utils/NEEDED_CHILDREN_MODULES

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

plugins/MRPT_Utils/README.rst

@@ -0,0 +1,13 @@
+==========
+MRPT_Utils
+==========
+
+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/MRPT_Utils/excitations_cas.irp.f

@@ -0,0 +1,708 @@
+subroutine apply_exc_to_psi(orb,hole_particle,spin_exc, & 
+           norm_out,psi_in_out,psi_in_out_coef, ndet,dim_psi_in,dim_psi_coef,N_states_in)
+  use bitmasks
+ implicit none
+ integer, intent(in) :: orb, hole_particle,spin_exc,N_states_in,ndet,dim_psi_in,dim_psi_coef
+ double precision, intent(out)  :: norm_out(N_states_in)
+ integer(bit_kind), intent(inout) :: psi_in_out(N_int,2,dim_psi_in)
+ double precision,  intent(inout) :: psi_in_out_coef(dim_psi_coef,N_states_in)
+  BEGIN_DOC
+  ! apply a contracted excitation to psi_in_out whose coefficients 
+  ! are psi_in_out_coef
+  ! hole_particle =  1  ===> creation     of an electron in psi_in_out
+  !               = -1  ===> annhilation  of an electron in psi_in_out
+  ! orb ===> is the index of orbital where you want wether to create or 
+  !          annhilate an electron
+  ! spin_exc ===> is the spin of the electron (1 == alpha) (2 == beta)
+  ! the wave function gets out normalized to unity
+  !
+  ! norm_out is the sum of the squared of the coefficients 
+  ! on which the excitation has been possible
+  END_DOC
+
+  integer :: elec_num_tab_local(2)
+  integer :: i,j,accu_elec,k
+  integer :: det_tmp(N_int), det_tmp_bis(N_int)
+  double precision :: phase
+  double precision :: norm_factor
+
+  elec_num_tab_local = 0
+  do i = 1, ndet
+   if( psi_in_out_coef (i,1) .ne. 0.d0)then
+    do j = 1, N_int
+     elec_num_tab_local(1) += popcnt(psi_in_out(j,1,i))
+     elec_num_tab_local(2) += popcnt(psi_in_out(j,2,i))
+    enddo
+    exit
+   endif
+  enddo
+  if(hole_particle == 1)then
+   do i = 1, ndet
+     call set_bit_to_integer(orb,psi_in_out(1,spin_exc,i),N_int) 
+     accu_elec = 0
+     do j = 1, N_int
+      accu_elec += popcnt(psi_in_out(j,spin_exc,i))
+     enddo 
+     if(accu_elec .ne. elec_num_tab_local(spin_exc)+1)then
+      do j = 1, N_int
+       psi_in_out(j,1,i) = 0_bit_kind
+       psi_in_out(j,2,i) = 0_bit_kind
+      enddo
+      do j = 1, N_states_in
+       psi_in_out_coef(i,j) = 0.d0
+      enddo
+     endif
+     phase = 1.d0
+     do k = 1, orb
+      do j = 1, N_int
+       det_tmp(j) = 0_bit_kind
+      enddo
+      call set_bit_to_integer(k,det_tmp,N_int) 
+      accu_elec = 0
+      do j = 1, N_int
+       det_tmp_bis(j) = iand(det_tmp(j),(psi_in_out(j,spin_exc,i)))
+       accu_elec += popcnt(det_tmp_bis(j))
+      enddo
+      if(accu_elec == 1)then
+       phase = -phase
+      endif
+     enddo
+     do j = 1, N_states_in
+      psi_in_out_coef(i,j) = psi_in_out_coef(i,j)  * phase
+     enddo
+   enddo
+
+  else if (hole_particle == -1)then
+
+   do i = 1, ndet
+     call clear_bit_to_integer(orb,psi_in_out(1,spin_exc,i),N_int) 
+     accu_elec = 0
+     do j = 1, N_int
+      accu_elec += popcnt(psi_in_out(j,spin_exc,i))
+     enddo 
+     if(accu_elec .ne. elec_num_tab_local(spin_exc)-1)then
+      do j = 1, N_int
+       psi_in_out(j,1,i) = 0_bit_kind
+       psi_in_out(j,2,i) = 0_bit_kind
+      enddo
+      do j = 1, N_states_in
+       psi_in_out_coef(i,j) = 0.d0
+      enddo
+     endif
+
+     phase = 1.d0
+     do k = 1, orb-1
+      do j = 1, N_int
+       det_tmp(j) = 0_bit_kind
+      enddo
+      call set_bit_to_integer(k,det_tmp,N_int) 
+      accu_elec = 0
+      do j = 1, N_int
+       det_tmp_bis(j) = iand(det_tmp(j),(psi_in_out(j,spin_exc,i)))
+       accu_elec += popcnt(det_tmp_bis(j)) 
+      enddo
+      if(accu_elec == 1)then
+       phase = -phase 
+      endif
+     enddo
+     do j = 1, N_states_in
+      psi_in_out_coef(i,j) = psi_in_out_coef(i,j)  * phase
+     enddo
+   enddo
+  endif
+
+
+  norm_out = 0.d0
+  do j = 1, N_states_in
+   do i = 1, ndet
+    norm_out(j) += psi_in_out_coef(i,j) * psi_in_out_coef(i,j)
+   enddo
+   if(norm_out(j).le.1.d-10)then
+    norm_factor = 0.d0
+   else 
+    norm_factor = 1.d0/(dsqrt(norm_out(j)))
+   endif
+   do i = 1, ndet
+    psi_in_out_coef(i,j) = psi_in_out_coef(i,j) * norm_factor
+   enddo
+  enddo
+end
+
+
+double precision function diag_H_mat_elem_no_elec_check(det_in,Nint)
+  implicit none
+  BEGIN_DOC
+  ! Computes <i|H|i>
+  END_DOC
+  integer,intent(in)             :: Nint
+  integer(bit_kind),intent(in)   :: det_in(Nint,2)
+  
+  integer                        :: i, j, iorb, jorb 
+  integer                        :: occ(Nint*bit_kind_size,2)
+  integer                        ::  elec_num_tab_local(2)
+
+  double precision :: core_act
+  double precision :: alpha_alpha
+  double precision :: alpha_beta
+  double precision :: beta_beta
+  double precision :: mono_elec
+  core_act = 0.d0
+  alpha_alpha = 0.d0
+  alpha_beta = 0.d0
+  beta_beta = 0.d0
+  mono_elec = 0.d0
+
+  diag_H_mat_elem_no_elec_check = 0.d0
+  call bitstring_to_list(det_in(1,1), occ(1,1), elec_num_tab_local(1), N_int)
+  call bitstring_to_list(det_in(1,2), occ(1,2), elec_num_tab_local(2), N_int)
+  ! alpha - alpha 
+! print*, 'elec_num_tab_local(1)',elec_num_tab_local(1)
+! print*, 'elec_num_tab_local(2)',elec_num_tab_local(2)
+  do i = 1, elec_num_tab_local(1)
+   iorb =  occ(i,1)
+   diag_H_mat_elem_no_elec_check += mo_mono_elec_integral(iorb,iorb)
+   mono_elec += mo_mono_elec_integral(iorb,iorb)
+   do j = i+1, elec_num_tab_local(1)
+    jorb = occ(j,1)
+    diag_H_mat_elem_no_elec_check +=  mo_bielec_integral_jj_anti(jorb,iorb)
+    alpha_alpha += mo_bielec_integral_jj_anti(jorb,iorb)
+   enddo
+  enddo 
+
+  ! beta - beta   
+  do i = 1, elec_num_tab_local(2)
+   iorb =  occ(i,2)
+   diag_H_mat_elem_no_elec_check += mo_mono_elec_integral(iorb,iorb)
+   mono_elec += mo_mono_elec_integral(iorb,iorb)
+   do j = i+1, elec_num_tab_local(2)
+    jorb = occ(j,2)
+    diag_H_mat_elem_no_elec_check +=  mo_bielec_integral_jj_anti(jorb,iorb)
+    beta_beta +=  mo_bielec_integral_jj_anti(jorb,iorb)
+   enddo
+  enddo 
+  
+
+  ! alpha - beta   
+  do i = 1, elec_num_tab_local(2)
+   iorb =  occ(i,2)
+   do j = 1, elec_num_tab_local(1)
+    jorb = occ(j,1)
+    diag_H_mat_elem_no_elec_check +=  mo_bielec_integral_jj(jorb,iorb)
+    alpha_beta += mo_bielec_integral_jj(jorb,iorb)
+   enddo
+  enddo 
+  
+
+  ! alpha - core-act
+  do i = 1, elec_num_tab_local(1)
+   iorb =  occ(i,1)
+   do j = 1, n_core_inact_orb
+    jorb = list_core_inact(j)
+    diag_H_mat_elem_no_elec_check +=  2.d0 * mo_bielec_integral_jj(jorb,iorb) - mo_bielec_integral_jj_exchange(jorb,iorb)
+    core_act += 2.d0 * mo_bielec_integral_jj(jorb,iorb) - mo_bielec_integral_jj_exchange(jorb,iorb)
+   enddo
+  enddo 
+
+  ! beta - core-act
+  do i = 1, elec_num_tab_local(2)
+   iorb =  occ(i,2)
+   do j = 1, n_core_inact_orb
+    jorb = list_core_inact(j)
+    diag_H_mat_elem_no_elec_check +=  2.d0 * mo_bielec_integral_jj(jorb,iorb) - mo_bielec_integral_jj_exchange(jorb,iorb)
+    core_act += 2.d0 * mo_bielec_integral_jj(jorb,iorb) - mo_bielec_integral_jj_exchange(jorb,iorb)
+   enddo
+  enddo 
+! print*,'core_act    = ',core_act
+! print*,'alpha_alpha = ',alpha_alpha
+! print*,'alpha_beta  = ',alpha_beta
+! print*,'beta_beta   = ',beta_beta
+! print*,'mono_elec   = ',mono_elec
+
+! do i = 1, n_core_inact_orb
+!  iorb = list_core_inact(i)
+!  diag_H_mat_elem_no_elec_check += 2.d0 * fock_core_inactive_total_spin_trace(iorb,1)
+! enddo
+
+
+!!!!!!!!!!!!
+return
+!!!!!!!!!!!!
+
+
+  ! alpha - alpha
+  do i = 1, n_core_inact_orb
+   iorb = list_core_inact(i)
+   diag_H_mat_elem_no_elec_check += 1.d0 * mo_mono_elec_integral(iorb,iorb)
+   do j = i+1, n_core_inact_orb
+    jorb = list_core_inact(j)
+    diag_H_mat_elem_no_elec_check += 1.d0 * mo_bielec_integral_jj(jorb,iorb) - 1.d0 *  mo_bielec_integral_jj_exchange(jorb,iorb)
+   enddo
+  enddo
+
+  do i = 1, n_core_inact_orb
+   iorb = list_core_inact(i)
+   diag_H_mat_elem_no_elec_check += 1.d0 * mo_mono_elec_integral(iorb,iorb)
+   do j = i+1, n_core_inact_orb
+    jorb = list_core_inact(j)
+    diag_H_mat_elem_no_elec_check += 1.d0 * mo_bielec_integral_jj(jorb,iorb) - 1.d0 *  mo_bielec_integral_jj_exchange(jorb,iorb)
+   enddo
+  enddo
+
+  do i = 1, n_core_inact_orb
+   iorb = list_core_inact(i)
+   do j = 1, n_core_inact_orb
+    jorb = list_core_inact(j)
+    diag_H_mat_elem_no_elec_check += 1.d0 * mo_bielec_integral_jj(jorb,iorb) 
+   enddo
+  enddo
+  
+end
+
+subroutine i_H_j_dyall(key_i,key_j,Nint,hij)
+  use bitmasks
+  implicit none
+  BEGIN_DOC
+  ! Returns <i|H|j> where i and j are determinants
+  END_DOC
+  integer, intent(in)            :: Nint
+  integer(bit_kind), intent(in)  :: key_i(Nint,2), key_j(Nint,2)
+  double precision, intent(out)  :: hij
+  
+  integer                        :: exc(0:2,2,2)
+  integer                        :: degree
+  double precision               :: get_mo_bielec_integral
+  integer                        :: m,n,p,q
+  integer                        :: i,j,k
+  integer                        :: occ(Nint*bit_kind_size,2)
+  double precision               :: diag_H_mat_elem_no_elec_check, phase,phase_2
+  integer                        :: n_occ_ab(2)
+  logical                        :: has_mipi(Nint*bit_kind_size)
+  double precision               :: mipi(Nint*bit_kind_size), miip(Nint*bit_kind_size)
+  PROVIDE mo_bielec_integrals_in_map mo_integrals_map
+  
+  ASSERT (Nint > 0)
+  ASSERT (Nint == N_int)
+  
+  hij = 0.d0
+  !DIR$ FORCEINLINE
+  call get_excitation_degree(key_i,key_j,degree,Nint)
+  select case (degree)
+    case (2)
+      call get_double_excitation(key_i,key_j,exc,phase,Nint)
+      if (exc(0,1,1) == 1) then
+        ! Mono alpha, mono beta
+        hij = phase*get_mo_bielec_integral(                          &
+            exc(1,1,1),                                              &
+            exc(1,1,2),                                              &
+            exc(1,2,1),                                              &
+            exc(1,2,2) ,mo_integrals_map)
+      else if (exc(0,1,1) == 2) then
+        ! Double alpha
+        hij = phase*(get_mo_bielec_integral(                         &
+            exc(1,1,1),                                              &
+            exc(2,1,1),                                              &
+            exc(1,2,1),                                              &
+            exc(2,2,1) ,mo_integrals_map) -                          &
+            get_mo_bielec_integral(                                  &
+            exc(1,1,1),                                              &
+            exc(2,1,1),                                              &
+            exc(2,2,1),                                              &
+            exc(1,2,1) ,mo_integrals_map) )
+      else if (exc(0,1,2) == 2) then
+        ! Double beta
+        hij = phase*(get_mo_bielec_integral(                         &
+            exc(1,1,2),                                              &
+            exc(2,1,2),                                              &
+            exc(1,2,2),                                              &
+            exc(2,2,2) ,mo_integrals_map) -                          &
+            get_mo_bielec_integral(                                  &
+            exc(1,1,2),                                              &
+            exc(2,1,2),                                              &
+            exc(2,2,2),                                              &
+            exc(1,2,2) ,mo_integrals_map) )
+      endif
+    case (1)
+      call get_mono_excitation(key_i,key_j,exc,phase,Nint)
+      !DIR$ FORCEINLINE
+      call bitstring_to_list_ab(key_i, occ, n_occ_ab, Nint)
+      has_mipi = .False.
+      if (exc(0,1,1) == 1) then
+        ! Mono alpha
+        m = exc(1,1,1)
+        p = exc(1,2,1)
+        do k = 1, n_occ_ab(1)
+          i = occ(k,1)
+          if (.not.has_mipi(i)) then
+            mipi(i) = get_mo_bielec_integral(m,i,p,i,mo_integrals_map)
+            miip(i) = get_mo_bielec_integral(m,i,i,p,mo_integrals_map)
+            has_mipi(i) = .True.
+          endif
+        enddo
+        do k = 1, n_occ_ab(2)
+          i = occ(k,2)
+          if (.not.has_mipi(i)) then
+            mipi(i) = get_mo_bielec_integral(m,i,p,i,mo_integrals_map)
+            has_mipi(i) = .True.
+          endif
+        enddo
+        
+        do k = 1, n_occ_ab(1)
+          hij = hij + mipi(occ(k,1)) - miip(occ(k,1))
+        enddo
+        do k = 1, n_occ_ab(2)
+          hij = hij + mipi(occ(k,2))
+        enddo
+        
+      else
+        ! Mono beta
+        m = exc(1,1,2)
+        p = exc(1,2,2)
+        do k = 1, n_occ_ab(2)
+          i = occ(k,2)
+          if (.not.has_mipi(i)) then
+            mipi(i) = get_mo_bielec_integral(m,i,p,i,mo_integrals_map)
+            miip(i) = get_mo_bielec_integral(m,i,i,p,mo_integrals_map)
+            has_mipi(i) = .True.
+          endif
+        enddo
+        do k = 1, n_occ_ab(1)
+          i = occ(k,1)
+          if (.not.has_mipi(i)) then
+            mipi(i) = get_mo_bielec_integral(m,i,p,i,mo_integrals_map)
+            has_mipi(i) = .True.
+          endif
+        enddo
+        
+        do k = 1, n_occ_ab(1)
+          hij = hij + mipi(occ(k,1))
+        enddo
+        do k = 1, n_occ_ab(2)
+          hij = hij + mipi(occ(k,2)) - miip(occ(k,2))
+        enddo
+        
+      endif
+      hij = phase*(hij + mo_mono_elec_integral(m,p)  + fock_operator_active_from_core_inact(m,p) )
+      
+    case (0)
+      hij = diag_H_mat_elem_no_elec_check(key_i,Nint)
+  end select
+end
+
+
+subroutine u0_H_dyall_u0(energies,psi_in,psi_in_coef,ndet,dim_psi_in,dim_psi_coef,N_states_in,state_target)
+  use bitmasks
+ implicit none
+ integer, intent(in) :: N_states_in,ndet,dim_psi_in,dim_psi_coef,state_target
+ integer(bit_kind), intent(in) :: psi_in(N_int,2,dim_psi_in)
+ double precision,  intent(in) :: psi_in_coef(dim_psi_coef,N_states_in)
+ double precision,  intent(out) :: energies(N_states_in)
+ 
+ integer :: i,j 
+ double precision :: hij,accu
+ energies = 0.d0
+ accu = 0.d0
+ double precision, allocatable :: psi_coef_tmp(:)
+ allocate(psi_coef_tmp(ndet))
+ 
+ do i = 1, ndet
+  psi_coef_tmp(i) = psi_in_coef(i,state_target)
+ enddo
+
+ double precision :: hij_bis
+ do i = 1, ndet
+  if(psi_coef_tmp(i)==0.d0)cycle
+  do j = 1, ndet
+   if(psi_coef_tmp(j)==0.d0)cycle
+   call i_H_j_dyall(psi_in(1,1,i),psi_in(1,1,j),N_int,hij)
+   accu += psi_coef_tmp(i) * psi_coef_tmp(j) * hij
+  enddo
+ enddo
+ energies(state_target) = accu
+ deallocate(psi_coef_tmp)
+end
+
+
+double precision function coulomb_value_no_check(det_in,Nint)
+  implicit none
+  BEGIN_DOC
+  ! Computes <i|H|i>
+  END_DOC
+  integer,intent(in)             :: Nint
+  integer(bit_kind),intent(in)   :: det_in(Nint,2)
+  
+  integer                        :: i, j, iorb, jorb 
+  integer                        :: occ(Nint*bit_kind_size,2)
+  integer                        ::  elec_num_tab_local(2)
+
+  double precision :: core_act
+  double precision :: alpha_alpha
+  double precision :: alpha_beta
+  double precision :: beta_beta
+  double precision :: mono_elec
+  core_act = 0.d0
+  alpha_alpha = 0.d0
+  alpha_beta = 0.d0
+  beta_beta = 0.d0
+  mono_elec = 0.d0
+
+  coulomb_value_no_check = 0.d0
+  call bitstring_to_list(det_in(1,1), occ(1,1), elec_num_tab_local(1), N_int)
+  call bitstring_to_list(det_in(1,2), occ(1,2), elec_num_tab_local(2), N_int)
+  ! alpha - alpha 
+  do i = 1, elec_num_tab_local(1)
+   iorb =  occ(i,1)
+   do j = i+1, elec_num_tab_local(1)
+    jorb = occ(j,1)
+    coulomb_value_no_check +=  mo_bielec_integral_jj_anti(jorb,iorb)
+    alpha_alpha += mo_bielec_integral_jj_anti(jorb,iorb)
+   enddo
+  enddo 
+
+  ! beta - beta   
+  do i = 1, elec_num_tab_local(2)
+   iorb =  occ(i,2)
+   do j = i+1, elec_num_tab_local(2)
+    jorb = occ(j,2)
+    coulomb_value_no_check +=  mo_bielec_integral_jj_anti(jorb,iorb)
+    beta_beta +=  mo_bielec_integral_jj_anti(jorb,iorb)
+   enddo
+  enddo 
+  
+
+  ! alpha - beta   
+  do i = 1, elec_num_tab_local(2)
+   iorb =  occ(i,2)
+   do j = 1, elec_num_tab_local(1)
+    jorb = occ(j,1)
+    coulomb_value_no_check +=  mo_bielec_integral_jj(jorb,iorb)
+    alpha_beta += mo_bielec_integral_jj(jorb,iorb)
+   enddo
+  enddo 
+  
+
+end
+
+subroutine i_H_j_dyall_no_exchange(key_i,key_j,Nint,hij)
+  use bitmasks
+  implicit none
+  BEGIN_DOC
+  ! Returns <i|H|j> where i and j are determinants
+  END_DOC
+  integer, intent(in)            :: Nint
+  integer(bit_kind), intent(in)  :: key_i(Nint,2), key_j(Nint,2)
+  double precision, intent(out)  :: hij
+  
+  integer                        :: exc(0:2,2,2)
+  integer                        :: degree
+  double precision               :: get_mo_bielec_integral
+  integer                        :: m,n,p,q
+  integer                        :: i,j,k
+  integer                        :: occ(Nint*bit_kind_size,2)
+  double precision               :: diag_H_mat_elem_no_elec_check_no_exchange, phase,phase_2
+  integer                        :: n_occ_ab(2)
+  logical                        :: has_mipi(Nint*bit_kind_size)
+  double precision               :: mipi(Nint*bit_kind_size)
+  PROVIDE mo_bielec_integrals_in_map mo_integrals_map
+  
+  ASSERT (Nint > 0)
+  ASSERT (Nint == N_int)
+  
+  hij = 0.d0
+  !DIR$ FORCEINLINE
+  call get_excitation_degree(key_i,key_j,degree,Nint)
+  select case (degree)
+    case (2)
+      call get_double_excitation(key_i,key_j,exc,phase,Nint)
+      if (exc(0,1,1) == 1) then
+        ! Mono alpha, mono beta
+        if(exc(1,1,1) == exc(1,2,2) .and. exc(1,2,1) == exc(1,1,2))then
+         hij = 0.d0
+        else 
+         hij = phase*get_mo_bielec_integral(                          &
+            exc(1,1,1),                                              &
+            exc(1,1,2),                                              &
+            exc(1,2,1),                                              &
+            exc(1,2,2) ,mo_integrals_map)
+        endif
+      else if (exc(0,1,1) == 2) then
+        ! Double alpha
+        hij = phase*get_mo_bielec_integral(                &
+            exc(1,1,1),                                              &
+            exc(2,1,1),                                              &
+            exc(1,2,1),                                              &
+            exc(2,2,1) ,mo_integrals_map) 
+      else if (exc(0,1,2) == 2) then
+        ! Double beta
+        hij = phase*get_mo_bielec_integral(                         &
+            exc(1,1,2),                                              &
+            exc(2,1,2),                                              &
+            exc(1,2,2),                                              &
+            exc(2,2,2) ,mo_integrals_map) 
+      endif
+    case (1)
+      call get_mono_excitation(key_i,key_j,exc,phase,Nint)
+      !DIR$ FORCEINLINE
+      call bitstring_to_list_ab(key_i, occ, n_occ_ab, Nint)
+      has_mipi = .False.
+      if (exc(0,1,1) == 1) then
+        ! Mono alpha
+        m = exc(1,1,1)
+        p = exc(1,2,1)
+        do k = 1, n_occ_ab(1)
+          i = occ(k,1)
+          if (.not.has_mipi(i)) then
+            mipi(i) = get_mo_bielec_integral(m,i,p,i,mo_integrals_map)
+            has_mipi(i) = .True.
+          endif
+        enddo
+        do k = 1, n_occ_ab(2)
+          i = occ(k,2)
+          if (.not.has_mipi(i)) then
+            mipi(i) = get_mo_bielec_integral(m,i,p,i,mo_integrals_map)
+            has_mipi(i) = .True.
+          endif
+        enddo
+        
+        do k = 1, n_occ_ab(1)
+          hij = hij + mipi(occ(k,1)) 
+        enddo
+        do k = 1, n_occ_ab(2)
+          hij = hij + mipi(occ(k,2))
+        enddo
+        
+      else
+        ! Mono beta
+        m = exc(1,1,2)
+        p = exc(1,2,2)
+        do k = 1, n_occ_ab(2)
+          i = occ(k,2)
+          if (.not.has_mipi(i)) then
+            mipi(i) = get_mo_bielec_integral(m,i,p,i,mo_integrals_map)
+            has_mipi(i) = .True.
+          endif
+        enddo
+        do k = 1, n_occ_ab(1)
+          i = occ(k,1)
+          if (.not.has_mipi(i)) then
+            mipi(i) = get_mo_bielec_integral(m,i,p,i,mo_integrals_map)
+            has_mipi(i) = .True.
+          endif
+        enddo
+        
+        do k = 1, n_occ_ab(1)
+          hij = hij + mipi(occ(k,1))
+        enddo
+        do k = 1, n_occ_ab(2)
+          hij = hij + mipi(occ(k,2)) 
+        enddo
+        
+      endif
+      hij = phase*(hij + mo_mono_elec_integral(m,p)  + fock_operator_active_from_core_inact(m,p) )
+      
+    case (0)
+      hij = diag_H_mat_elem_no_elec_check_no_exchange(key_i,Nint)
+  end select
+end
+
+
+double precision function diag_H_mat_elem_no_elec_check_no_exchange(det_in,Nint)
+  implicit none
+  BEGIN_DOC
+  ! Computes <i|H|i>
+  END_DOC
+  integer,intent(in)             :: Nint
+  integer(bit_kind),intent(in)   :: det_in(Nint,2)
+  
+  integer                        :: i, j, iorb, jorb 
+  integer                        :: occ(Nint*bit_kind_size,2)
+  integer                        ::  elec_num_tab_local(2)
+
+  double precision :: core_act_exchange(2)
+  core_act_exchange = 0.d0
+  diag_H_mat_elem_no_elec_check_no_exchange = 0.d0
+  call bitstring_to_list(det_in(1,1), occ(1,1), elec_num_tab_local(1), N_int)
+  call bitstring_to_list(det_in(1,2), occ(1,2), elec_num_tab_local(2), N_int)
+  ! alpha - alpha 
+  do i = 1, elec_num_tab_local(1)
+   iorb =  occ(i,1)
+   diag_H_mat_elem_no_elec_check_no_exchange += mo_mono_elec_integral(iorb,iorb)
+   do j = i+1, elec_num_tab_local(1)
+    jorb = occ(j,1)
+    diag_H_mat_elem_no_elec_check_no_exchange +=  mo_bielec_integral_jj(jorb,iorb)
+   enddo
+  enddo 
+
+  ! beta - beta   
+  do i = 1, elec_num_tab_local(2)
+   iorb =  occ(i,2)
+   diag_H_mat_elem_no_elec_check_no_exchange += mo_mono_elec_integral(iorb,iorb)
+   do j = i+1, elec_num_tab_local(2)
+    jorb = occ(j,2)
+    diag_H_mat_elem_no_elec_check_no_exchange +=  mo_bielec_integral_jj(jorb,iorb)
+   enddo
+  enddo 
+  
+
+  ! alpha - beta   
+  do i = 1, elec_num_tab_local(2)
+   iorb =  occ(i,2)
+   do j = 1, elec_num_tab_local(1)
+    jorb = occ(j,1)
+    diag_H_mat_elem_no_elec_check_no_exchange +=  mo_bielec_integral_jj(jorb,iorb)
+   enddo
+  enddo 
+  
+
+  ! alpha - core-act
+  do i = 1, elec_num_tab_local(1)
+   iorb =  occ(i,1)
+   do j = 1, n_core_inact_orb
+    jorb = list_core_inact(j)
+    diag_H_mat_elem_no_elec_check_no_exchange +=  2.d0 * mo_bielec_integral_jj(jorb,iorb) 
+    core_act_exchange(1) += - mo_bielec_integral_jj_exchange(jorb,iorb)
+   enddo
+  enddo 
+
+  ! beta - core-act
+  do i = 1, elec_num_tab_local(2)
+   iorb =  occ(i,2)
+   do j = 1, n_core_inact_orb
+    jorb = list_core_inact(j)
+    diag_H_mat_elem_no_elec_check_no_exchange +=  2.d0 * mo_bielec_integral_jj(jorb,iorb) 
+    core_act_exchange(2) += - mo_bielec_integral_jj_exchange(jorb,iorb)
+   enddo
+  enddo 
+  
+end
+
+subroutine u0_H_dyall_u0_no_exchange(energies,psi_in,psi_in_coef,ndet,dim_psi_in,dim_psi_coef,N_states_in,state_target)
+  use bitmasks
+ implicit none
+ integer, intent(in) :: N_states_in,ndet,dim_psi_in,dim_psi_coef,state_target
+ integer(bit_kind), intent(in) :: psi_in(N_int,2,dim_psi_in)
+ double precision,  intent(in) :: psi_in_coef(dim_psi_coef,N_states_in)
+ double precision,  intent(out) :: energies(N_states_in)
+ 
+ integer :: i,j 
+ double precision :: hij,accu
+ energies = 0.d0
+ accu = 0.d0
+ double precision, allocatable :: psi_coef_tmp(:)
+ allocate(psi_coef_tmp(ndet))
+ 
+ do i = 1, ndet
+  psi_coef_tmp(i) = psi_in_coef(i,state_target)
+ enddo
+
+ double precision :: hij_bis
+ do i = 1, ndet
+  if(psi_coef_tmp(i)==0.d0)cycle
+  do j = 1, ndet
+   if(psi_coef_tmp(j)==0.d0)cycle
+   call i_H_j_dyall_no_exchange(psi_in(1,1,i),psi_in(1,1,j),N_int,hij)
+   accu += psi_coef_tmp(i) * psi_coef_tmp(j) * hij
+  enddo
+ enddo
+ energies(state_target) = accu
+ deallocate(psi_coef_tmp)
+end

plugins/MRPT_Utils/ezfio_interface.irp.f

@@ -0,0 +1,23 @@
+! DO NOT MODIFY BY HAND
+! Created by $QP_ROOT/scripts/ezfio_interface/ei_handler.py
+! from file /home/scemama/quantum_package/src/MRPT_Utils/EZFIO.cfg
+
+
+BEGIN_PROVIDER [ logical, do_third_order_1h1p  ]
+  implicit none
+  BEGIN_DOC
+! If true, compute the third order contribution for the 1h1p
+  END_DOC
+
+  logical                        :: has
+  PROVIDE ezfio_filename
+  
+  call ezfio_has_mrpt_utils_do_third_order_1h1p(has)
+  if (has) then
+    call ezfio_get_mrpt_utils_do_third_order_1h1p(do_third_order_1h1p)
+  else
+    print *, 'mrpt_utils/do_third_order_1h1p not found in EZFIO file'
+    stop 1
+  endif
+
+END_PROVIDER

plugins/MRPT_Utils/fock_like_operators.irp.f

@@ -0,0 +1,210 @@
+ BEGIN_PROVIDER [double precision, fock_core_inactive, (mo_tot_num)]
+ BEGIN_DOC
+! inactive part of the fock operator with contributions only from the inactive
+ END_DOC
+ implicit none
+ integer :: i,j
+ double precision :: accu
+
+ integer :: j_inact_core_orb,i_inact_core_orb
+ do i = 1, n_core_inact_orb
+  accu = 0.d0
+  i_inact_core_orb = list_core_inact(i)
+  do j = 1, n_core_inact_orb
+   j_inact_core_orb = list_core_inact(j)
+   accu += 2.d0 * mo_bielec_integral_jj(i_inact_core_orb,j_inact_core_orb)  & 
+                - mo_bielec_integral_jj_exchange(i_inact_core_orb,j_inact_core_orb)
+  enddo
+  fock_core_inactive(i_inact_core_orb) = accu + mo_mono_elec_integral(i_inact_core_orb,i_inact_core_orb)
+ enddo
+ END_PROVIDER
+
+ BEGIN_PROVIDER [double precision, fock_virt_from_core_inact, (mo_tot_num)]
+ BEGIN_DOC
+! fock operator for the virtuals that comes from the doubly occupied orbitals
+ END_DOC
+ implicit none
+ integer :: i,j
+ double precision :: accu
+
+ integer :: j_inact_core_orb,i_virt_orb
+ do i = 1, n_virt_orb
+  accu = 0.d0
+  i_virt_orb = list_virt(i)
+  do j = 1, n_core_inact_orb
+! do j = 1, elec_alpha_num
+!  j_inact_core_orb = j
+   j_inact_core_orb = list_core_inact(j)
+   accu += 2.d0 * mo_bielec_integral_jj(i_virt_orb,j_inact_core_orb)  & 
+                - mo_bielec_integral_jj_exchange(i_virt_orb,j_inact_core_orb)
+  enddo
+  fock_virt_from_core_inact(i_virt_orb) = accu 
+ enddo
+ END_PROVIDER
+
+ BEGIN_PROVIDER [double precision, fock_core_inactive_from_act, (mo_tot_num,2,N_states)]
+ BEGIN_DOC
+! inactive part of the fock operator with contributions only from the active
+ END_DOC
+ implicit none
+ integer :: i,j,k
+ double precision :: accu_coulomb,accu_exchange(2)
+ double precision :: na,nb,ntot
+ double precision :: coulomb, exchange
+ double precision :: get_mo_bielec_integral
+ integer :: j_act_orb,k_act_orb,i_inact_core_orb
+ integer :: i_state
+
+ do i_state = 1,N_states
+  do i = 1, n_core_inact_orb
+   accu_coulomb = 0.d0
+   accu_exchange = 0.d0
+   i_inact_core_orb = list_core_inact(i)
+   do j = 1, n_act_orb
+    j_act_orb = list_act(j)
+    na = one_body_dm_mo_alpha(j_act_orb,j_act_orb,i_state)
+    nb = one_body_dm_mo_beta(j_act_orb,j_act_orb,i_state)
+    ntot = na + nb
+    coulomb = mo_bielec_integral_jj(i_inact_core_orb,j_act_orb)
+    exchange = mo_bielec_integral_jj_exchange(i_inact_core_orb,j_act_orb)
+    accu_coulomb += ntot * coulomb
+    accu_exchange(1) += na * exchange
+    accu_exchange(2) += nb * exchange
+    do k = j+1, n_act_orb
+     k_act_orb = list_act(k)
+     na = one_body_dm_mo_alpha(j_act_orb,k_act_orb,i_state)
+     nb = one_body_dm_mo_beta(j_act_orb,k_act_orb,i_state)
+     ntot = na + nb
+     coulomb = get_mo_bielec_integral(j_act_orb,i_inact_core_orb,k_act_orb,i_inact_core_orb,mo_integrals_map) 
+     exchange = get_mo_bielec_integral(j_act_orb,k_act_orb,i_inact_core_orb,i_inact_core_orb,mo_integrals_map)
+     accu_coulomb += 2.d0 * ntot * coulomb
+     accu_exchange(1) += 2.d0 * na * exchange
+     accu_exchange(2) += 2.d0 * nb * exchange
+    enddo
+   enddo
+   fock_core_inactive_from_act(i_inact_core_orb,1,i_state) = accu_coulomb - accu_exchange(1) 
+   fock_core_inactive_from_act(i_inact_core_orb,2,i_state) = accu_coulomb - accu_exchange(2) 
+  enddo
+ enddo
+ END_PROVIDER
+
+ BEGIN_PROVIDER [double precision, fock_virt_from_act, (mo_tot_num,2,N_states)]
+ BEGIN_DOC
+! virtual part of the fock operator with contributions only from the active
+ END_DOC
+ implicit none
+ integer :: i,j,k
+ double precision :: accu_coulomb,accu_exchange(2)
+ double precision :: na,nb,ntot
+ double precision :: coulomb, exchange
+ double precision :: get_mo_bielec_integral
+ integer :: j_act_orb,i_virt_orb,k_act_orb
+ integer :: i_state
+ ! TODO : inverse loop of i_state 
+
+ do i_state = 1, N_states
+  do i = 1, n_virt_orb
+   accu_coulomb = 0.d0
+   accu_exchange = 0.d0
+   i_virt_orb = list_virt(i)
+   do j = 1, n_act_orb
+    j_act_orb = list_act(j)
+    na = one_body_dm_mo_alpha(j_act_orb,j_act_orb,i_state)
+    nb = one_body_dm_mo_beta(j_act_orb,j_act_orb,i_state)
+    ntot = na + nb
+    coulomb = mo_bielec_integral_jj(i_virt_orb,j_act_orb)
+    exchange = mo_bielec_integral_jj_exchange(i_virt_orb,j_act_orb)
+    accu_coulomb += ntot * coulomb
+    accu_exchange(1) += na * exchange
+    accu_exchange(2) += nb * exchange
+    do k = j+1, n_act_orb
+     k_act_orb = list_act(k)
+     na = one_body_dm_mo_alpha(j_act_orb,k_act_orb,i_state)
+     nb = one_body_dm_mo_beta(j_act_orb,k_act_orb,i_state)
+     ntot = na + nb
+     coulomb = get_mo_bielec_integral(j_act_orb,i_virt_orb,k_act_orb,i_virt_orb,mo_integrals_map) 
+     exchange = get_mo_bielec_integral(j_act_orb,k_act_orb,i_virt_orb,i_virt_orb,mo_integrals_map)
+     accu_coulomb += 2.d0 * ntot * coulomb
+     accu_exchange(1) += 2.d0 * na * exchange
+     accu_exchange(2) += 2.d0 * nb * exchange
+    enddo
+   enddo
+   fock_virt_from_act(i_virt_orb,1,i_state) = accu_coulomb - accu_exchange(1) 
+   fock_virt_from_act(i_virt_orb,2,i_state) = accu_coulomb - accu_exchange(2) 
+  enddo
+ enddo
+ END_PROVIDER
+
+ BEGIN_PROVIDER [double precision, fock_core_inactive_total, (mo_tot_num,2,N_states)]
+&BEGIN_PROVIDER [double precision, fock_core_inactive_total_spin_trace, (mo_tot_num,N_states)]
+ BEGIN_DOC
+! inactive part of the fock operator 
+ END_DOC
+ implicit none
+ integer :: i
+ integer :: i_inact_core_orb
+ integer :: i_state
+ do i_state = 1, N_states
+  do i = 1, n_core_inact_orb
+   i_inact_core_orb = list_core_inact(i)
+   fock_core_inactive_total(i_inact_core_orb,1,i_state) = fock_core_inactive(i_inact_core_orb) + fock_core_inactive_from_act(i_inact_core_orb,1,i_state)
+   fock_core_inactive_total(i_inact_core_orb,2,i_state) = fock_core_inactive(i_inact_core_orb) + fock_core_inactive_from_act(i_inact_core_orb,2,i_state)
+   fock_core_inactive_total_spin_trace(i_inact_core_orb,i_state) = 0.5d0 * (fock_core_inactive_total(i_inact_core_orb,1,i_state) + fock_core_inactive_total(i_inact_core_orb,2,i_state))
+  enddo
+ enddo
+ END_PROVIDER
+
+ BEGIN_PROVIDER [double precision, fock_virt_total, (mo_tot_num,2,N_states)]
+&BEGIN_PROVIDER [double precision, fock_virt_total_spin_trace, (mo_tot_num,N_states)]
+ BEGIN_DOC
+! inactive part of the fock operator 
+ END_DOC
+ implicit none
+ integer :: i
+ integer :: i_virt_orb
+ integer :: i_state
+ do i_state = 1, N_states
+  do i = 1, n_virt_orb
+   i_virt_orb= list_virt(i)
+   fock_virt_total(i_virt_orb,1,i_state) = fock_virt_from_core_inact(i_virt_orb) + fock_virt_from_act(i_virt_orb,1,i_state)+ mo_mono_elec_integral(i_virt_orb,i_virt_orb)
+   fock_virt_total(i_virt_orb,2,i_state) = fock_virt_from_core_inact(i_virt_orb) + fock_virt_from_act(i_virt_orb,2,i_state)+ mo_mono_elec_integral(i_virt_orb,i_virt_orb)
+   fock_virt_total_spin_trace(i_virt_orb,i_state) = 0.5d0 * ( fock_virt_total(i_virt_orb,1,i_state) + fock_virt_total(i_virt_orb,2,i_state) )
+  enddo
+ enddo
+ END_PROVIDER
+
+
+
+
+
+ BEGIN_PROVIDER [double precision, fock_operator_active_from_core_inact, (mo_tot_num,mo_tot_num)]
+ BEGIN_DOC
+! active part of the fock operator with contributions only from the inactive
+ END_DOC
+ implicit none
+ integer :: i,j,k,k_inact_core_orb
+ integer :: iorb,jorb
+ double precision :: accu
+ double precision               :: get_mo_bielec_integral,coulomb, exchange
+ PROVIDE mo_bielec_integrals_in_map
+ fock_operator_active_from_core_inact = 0.d0
+ do i = 1, n_act_orb
+  iorb = list_act(i)
+  do j = 1, n_act_orb
+   jorb = list_act(j)
+   accu = 0.d0
+   do k = 1, n_core_inact_orb 
+    k_inact_core_orb = list_core_inact(k)
+    coulomb  = get_mo_bielec_integral(k_inact_core_orb,iorb,k_inact_core_orb,jorb,mo_integrals_map)
+    exchange = get_mo_bielec_integral(k_inact_core_orb,jorb,iorb,k_inact_core_orb,mo_integrals_map)
+    accu += 2.d0 * coulomb - exchange
+   enddo
+   fock_operator_active_from_core_inact(iorb,jorb) = accu
+  enddo
+ enddo
+
+ END_PROVIDER 
+
+ 
+
+

plugins/MRPT_Utils/give_2h2p.irp.f

@@ -0,0 +1,35 @@
+subroutine give_2h2p(contrib_2h2p)
+ implicit none
+ double precision, intent(out) :: contrib_2h2p(N_states)
+ integer :: i,j,k,l,m
+ integer :: iorb,jorb,korb,lorb
+
+ double precision               :: get_mo_bielec_integral
+ double precision               :: direct_int,exchange_int
+ double precision               :: numerator,denominator(N_states)
+
+ contrib_2h2p = 0.d0
+ do i = 1, n_inact_orb
+  iorb = list_inact(i)
+  do j = 1, n_inact_orb
+   jorb = list_inact(j)
+   do k = 1, n_virt_orb
+    korb = list_virt(k)
+    do l = 1, n_virt_orb
+     lorb = list_virt(l)
+     direct_int = get_mo_bielec_integral(iorb,jorb,korb,lorb ,mo_integrals_map)
+     exchange_int = get_mo_bielec_integral(iorb,jorb,lorb,korb ,mo_integrals_map)
+     numerator = 3.d0 * direct_int*direct_int + exchange_int*exchange_int -2.d0 * exchange_int * direct_int
+     do m = 1, N_states
+     denominator(m) = fock_core_inactive_total_spin_trace(iorb,m) + fock_core_inactive_total_spin_trace(jorb,m) &
+                     -fock_virt_total_spin_trace(korb,m) - fock_virt_total_spin_trace(lorb,m)
+     contrib_2h2p(m) += numerator / denominator(m)
+     enddo
+    enddo
+   enddo
+  enddo
+ enddo
+ contrib_2h2p = contrib_2h2p*0.5d0
+
+end
+

plugins/MRPT_Utils/mrpt_dress.irp.f

@@ -0,0 +1,186 @@
+use omp_lib
+use bitmasks
+
+BEGIN_PROVIDER [ integer(omp_lock_kind), psi_ref_bis_lock, (psi_det_size) ]
+ implicit none
+ BEGIN_DOC
+ ! Locks on ref determinants to fill delta_ij
+ END_DOC
+ integer :: i
+ do i=1,psi_det_size
+   call omp_init_lock( psi_ref_bis_lock(i) )
+ enddo
+
+END_PROVIDER
+
+
+subroutine mrpt_dress(delta_ij_,  Ndet,i_generator,n_selected,det_buffer,Nint,iproc,key_mask)
+ use bitmasks
+ implicit none
+
+  integer, intent(in)            :: i_generator,n_selected, Nint, iproc
+  integer, intent(in)            :: Ndet
+  integer(bit_kind),intent(in)   :: key_mask(Nint, 2)
+  integer(bit_kind), intent(in)  :: det_buffer(Nint,2,n_selected)
+  double precision, intent(inout) :: delta_ij_(Ndet,Ndet,*)
+
+
+  integer                        :: i,j,k,l
+  integer                        :: idx_alpha(0:psi_det_size)
+  integer                        :: degree_alpha(psi_det_size)
+  logical                        :: fullMatch
+ 
+  double precision               :: delta_e_inv_array(psi_det_size,N_states)
+  double precision               :: hij_array(psi_det_size)
+
+  integer(bit_kind)              :: tq(Nint,2,n_selected)
+  integer                        :: N_tq
+
+  double precision               :: hialpha,hij
+  integer                        :: i_state, i_alpha
+  
+  integer(bit_kind),allocatable  :: miniList(:,:,:)
+  integer,allocatable            :: idx_miniList(:)
+  integer                        :: N_miniList, leng
+  double precision               :: delta_e(N_states),hij_tmp
+  integer                        :: index_i,index_j
+  double precision :: phase_array(N_det),phase
+  integer                        :: exc(0:2,2,2),degree
+  
+  
+  leng = max(N_det_generators, N_det)
+  allocate(miniList(Nint, 2, leng), idx_miniList(leng))
+  
+  !create_minilist_find_previous(key_mask, fullList, miniList, N_fullList, N_miniList, fullMatch, Nint)
+  call create_minilist_find_previous(key_mask, psi_det_generators, miniList, i_generator-1, N_miniList, fullMatch, Nint)
+  
+  if(fullMatch) then
+    return
+  end if
+  
+  
+  call find_connections_previous(i_generator,n_selected,det_buffer,Nint,tq,N_tq,miniList,N_minilist)
+
+  if(N_tq > 0) then
+    call create_minilist(key_mask, psi_det, miniList, idx_miniList, N_det, N_minilist, Nint)
+  end if
+  
+  
+  do i_alpha=1,N_tq
+    call get_excitation_degree_vector(miniList,tq(1,1,i_alpha),degree_alpha,Nint,N_minilist,idx_alpha)
+    
+    do j=1,idx_alpha(0)
+      idx_alpha(j) = idx_miniList(idx_alpha(j))
+    enddo
+     
+!   double precision :: ihpsi0,coef_pert
+!   ihpsi0 = 0.d0
+!   coef_pert = 0.d0
+    phase_array  =0.d0
+    do i = 1,idx_alpha(0)
+      index_i = idx_alpha(i)
+      call i_h_j(tq(1,1,i_alpha),psi_det(1,1,index_i),Nint,hialpha)
+      double  precision :: coef_array(N_states)
+      do i_state = 1, N_states
+       coef_array(i_state) = psi_coef(index_i,i_state)
+      enddo
+      call get_delta_e_dyall(psi_det(1,1,index_i),tq(1,1,i_alpha),coef_array,hialpha,delta_e)
+      hij_array(index_i) = hialpha
+      call get_excitation(psi_det(1,1,index_i),tq(1,1,i_alpha),exc,degree,phase,N_int)
+!     phase_array(index_i) = phase
+      do i_state = 1,N_states
+       delta_e_inv_array(index_i,i_state) = 1.d0/delta_e(i_state)
+      enddo
+    enddo
+    
+    do i=1,idx_alpha(0)
+      index_i = idx_alpha(i)
+      hij_tmp = hij_array(index_i)
+      call omp_set_lock( psi_ref_bis_lock(index_i) )
+      do j = 1, idx_alpha(0)
+       index_j = idx_alpha(j)
+!      call get_excitation(psi_det(1,1,index_i),psi_det(1,1,index_i),exc,degree,phase,N_int)
+!      if(index_j.ne.index_i)then
+!       if(phase_array(index_j) * phase_array(index_i) .ne. phase)then
+!        print*, phase_array(index_j) , phase_array(index_i) ,phase
+!        call debug_det(psi_det(1,1,index_i),N_int)
+!        call debug_det(psi_det(1,1,index_j),N_int)
+!        call debug_det(tq(1,1,i_alpha),N_int)
+!        stop
+!       endif
+!      endif
+       do i_state=1,N_states
+! standard dressing first order
+         delta_ij_(index_i,index_j,i_state) += hij_array(index_j) * hij_tmp * delta_e_inv_array(index_j,i_state)
+       enddo
+      enddo
+      call omp_unset_lock( psi_ref_bis_lock(index_i))
+    enddo
+  enddo
+  deallocate(miniList, idx_miniList)
+end
+
+
+
+ BEGIN_PROVIDER [ integer(bit_kind), gen_det_sorted,  (N_int,2,N_det_generators,2) ]
+&BEGIN_PROVIDER [ integer, gen_det_shortcut, (0:N_det_generators,2) ]
+&BEGIN_PROVIDER [ integer, gen_det_version, (N_int, N_det_generators,2) ]
+&BEGIN_PROVIDER [ integer, gen_det_idx, (N_det_generators,2) ]
+  gen_det_sorted(:,:,:,1) = psi_det_generators(:,:,:N_det_generators)
+  gen_det_sorted(:,:,:,2) = psi_det_generators(:,:,:N_det_generators)
+  call sort_dets_ab_v(gen_det_sorted(:,:,:,1), gen_det_idx(:,1), gen_det_shortcut(0:,1), gen_det_version(:,:,1), N_det_generators, N_int)
+  call sort_dets_ba_v(gen_det_sorted(:,:,:,2), gen_det_idx(:,2), gen_det_shortcut(0:,2), gen_det_version(:,:,2), N_det_generators, N_int)
+END_PROVIDER
+
+
+subroutine find_connections_previous(i_generator,n_selected,det_buffer,Nint,tq,N_tq,miniList,N_miniList)
+
+ use bitmasks
+ implicit none
+
+  integer, intent(in)            :: i_generator,n_selected, Nint
+
+  integer(bit_kind), intent(in)  :: det_buffer(Nint,2,n_selected)
+  integer                        :: i,j,k,m
+  logical                        :: is_in_wavefunction
+  integer                        :: degree(psi_det_size)
+  integer                        :: idx(0:psi_det_size)
+  logical                        :: good
+
+  integer(bit_kind), intent(out) :: tq(Nint,2,n_selected)
+  integer, intent(out)           :: N_tq
+  
+  
+  integer                        :: nt,ni
+  logical, external              :: is_connected_to
+  
+  
+  integer(bit_kind),intent(in)  :: miniList(Nint,2,N_det_generators)
+  integer,intent(in)            :: N_miniList
+
+  
+  
+  N_tq = 0
+  
+  
+  i_loop : do i=1,N_selected
+    if(is_connected_to(det_buffer(1,1,i), miniList, Nint, N_miniList)) then
+      cycle
+    end if
+
+    if (.not. is_in_wavefunction(det_buffer(1,1,i),Nint,N_det)) then
+      N_tq += 1
+      do k=1,N_int
+        tq(k,1,N_tq) = det_buffer(k,1,i)
+        tq(k,2,N_tq) = det_buffer(k,2,i)
+      enddo
+    endif
+  enddo i_loop
+end
+
+
+
+
+
+
+

plugins/MRPT_Utils/mrpt_utils.irp.f

@@ -0,0 +1,367 @@
+
+ BEGIN_PROVIDER [ double precision, delta_ij, (N_det,N_det,N_states) ]
+&BEGIN_PROVIDER [ double precision, second_order_pt_new, (N_states) ]
+&BEGIN_PROVIDER [ double precision, second_order_pt_new_1h, (N_states) ]
+&BEGIN_PROVIDER [ double precision, second_order_pt_new_1p, (N_states) ]
+&BEGIN_PROVIDER [ double precision, second_order_pt_new_1h1p, (N_states) ]
+&BEGIN_PROVIDER [ double precision, second_order_pt_new_2h, (N_states) ]
+&BEGIN_PROVIDER [ double precision, second_order_pt_new_2p, (N_states) ]
+&BEGIN_PROVIDER [ double precision, second_order_pt_new_1h2p, (N_states) ]
+&BEGIN_PROVIDER [ double precision, second_order_pt_new_2h1p, (N_states) ]
+&BEGIN_PROVIDER [ double precision, second_order_pt_new_2h2p, (N_states) ]
+ implicit none
+ BEGIN_DOC
+ ! Dressing matrix in N_det basis
+ END_DOC
+ integer :: i,j,m
+ integer :: i_state
+ double precision :: accu(N_states)
+ double precision, allocatable :: delta_ij_tmp(:,:,:)
+
+
+ delta_ij = 0.d0
+
+ allocate (delta_ij_tmp(N_det,N_det,N_states))
+
+
+ ! 1h 
+ delta_ij_tmp = 0.d0
+ call H_apply_mrpt_1h(delta_ij_tmp,N_det)
+ accu = 0.d0
+ do i_state = 1, N_states
+ do i = 1, N_det
+  do j = 1, N_det
+   accu(i_state) += delta_ij_tmp(j,i,i_state) * psi_coef(i,i_state) * psi_coef(j,i_state)
+   delta_ij(j,i,i_state) += delta_ij_tmp(j,i,i_state)
+  enddo
+ enddo
+   second_order_pt_new_1h(i_state) = accu(i_state) 
+ enddo
+ print*, '1h   = ',accu
+ 
+ ! 1p 
+ delta_ij_tmp = 0.d0
+ call H_apply_mrpt_1p(delta_ij_tmp,N_det)
+ accu = 0.d0
+ do i_state = 1, N_states
+ do i = 1, N_det
+  do j = 1, N_det
+   accu(i_state) += delta_ij_tmp(j,i,i_state) * psi_coef(i,i_state) * psi_coef(j,i_state)
+   delta_ij(j,i,i_state) += delta_ij_tmp(j,i,i_state)
+  enddo
+ enddo
+ second_order_pt_new_1p(i_state) = accu(i_state) 
+ enddo
+ print*, '1p   = ',accu
+
+ ! 1h1p 
+ delta_ij_tmp = 0.d0
+ call H_apply_mrpt_1h1p(delta_ij_tmp,N_det)
+ double precision :: e_corr_from_1h1p_singles(N_states)
+!call give_singles_and_partial_doubles_1h1p_contrib(delta_ij_tmp,e_corr_from_1h1p_singles)
+!call give_1h1p_only_doubles_spin_cross(delta_ij_tmp)
+ accu = 0.d0
+ do i_state = 1, N_states
+ do i = 1, N_det
+  do j = 1, N_det
+   accu(i_state) += delta_ij_tmp(j,i,i_state) * psi_coef(i,i_state) * psi_coef(j,i_state)
+   delta_ij(j,i,i_state) += delta_ij_tmp(j,i,i_state)
+  enddo
+ enddo
+ second_order_pt_new_1h1p(i_state) = accu(i_state) 
+ enddo
+ print*, '1h1p = ',accu
+
+ ! 1h1p third order
+ if(do_third_order_1h1p)then
+  delta_ij_tmp = 0.d0
+  call give_1h1p_sec_order_singles_contrib(delta_ij_tmp)
+  accu = 0.d0
+  do i_state = 1, N_states
+  do i = 1, N_det
+   do j = 1, N_det
+    accu(i_state) += delta_ij_tmp(j,i,i_state) * psi_coef(i,i_state) * psi_coef(j,i_state)
+    delta_ij(j,i,i_state) += delta_ij_tmp(j,i,i_state)
+   enddo
+  enddo
+  second_order_pt_new_1h1p(i_state) = accu(i_state) 
+  enddo
+  print*, '1h1p(3)',accu
+ endif
+
+ ! 2h   
+ delta_ij_tmp = 0.d0
+ call H_apply_mrpt_2h(delta_ij_tmp,N_det)
+ accu = 0.d0
+ do i_state = 1, N_states
+ do i = 1, N_det
+  do j = 1, N_det
+   accu(i_state) += delta_ij_tmp(j,i,i_state) * psi_coef(i,i_state) * psi_coef(j,i_state)
+   delta_ij(j,i,i_state) += delta_ij_tmp(j,i,i_state)
+  enddo
+ enddo
+ second_order_pt_new_2h(i_state) = accu(i_state) 
+ enddo
+ print*, '2h   = ',accu
+
+ ! 2p   
+ delta_ij_tmp = 0.d0
+ call H_apply_mrpt_2p(delta_ij_tmp,N_det)
+ accu = 0.d0
+ do i_state = 1, N_states
+ do i = 1, N_det
+  do j = 1, N_det
+   accu(i_state) += delta_ij_tmp(j,i,i_state) * psi_coef(i,i_state) * psi_coef(j,i_state)
+   delta_ij(j,i,i_state) += delta_ij_tmp(j,i,i_state)
+  enddo
+ enddo
+ second_order_pt_new_2p(i_state) = accu(i_state) 
+ enddo
+ print*, '2p   = ',accu
+
+ ! 1h2p   
+ delta_ij_tmp = 0.d0
+!call give_1h2p_contrib(delta_ij_tmp)
+ call H_apply_mrpt_1h2p(delta_ij_tmp,N_det)
+ accu = 0.d0
+ do i_state = 1, N_states
+ do i = 1, N_det
+  do j = 1, N_det
+   accu(i_state) += delta_ij_tmp(j,i,i_state) * psi_coef(i,i_state) * psi_coef(j,i_state)
+   delta_ij(j,i,i_state) += delta_ij_tmp(j,i,i_state)
+  enddo
+ enddo
+ second_order_pt_new_1h2p(i_state) = accu(i_state) 
+ enddo
+ print*, '1h2p = ',accu
+
+ ! 2h1p   
+ delta_ij_tmp = 0.d0
+!call give_2h1p_contrib(delta_ij_tmp)
+ call H_apply_mrpt_2h1p(delta_ij_tmp,N_det)
+ accu = 0.d0
+ do i_state = 1, N_states
+ do i = 1, N_det
+  do j = 1, N_det
+   accu(i_state) += delta_ij_tmp(j,i,i_state) * psi_coef(i,i_state) * psi_coef(j,i_state)
+   delta_ij(j,i,i_state) += delta_ij_tmp(j,i,i_state)
+  enddo
+ enddo
+ second_order_pt_new_2h1p(i_state) = accu(i_state) 
+ enddo
+ print*, '2h1p = ',accu
+
+ ! 2h2p   
+!delta_ij_tmp = 0.d0
+!call H_apply_mrpt_2h2p(delta_ij_tmp,N_det)
+!accu = 0.d0
+!do i_state = 1, N_states
+!do i = 1, N_det
+! do j = 1, N_det
+!  accu(i_state) += delta_ij_tmp(j,i,i_state) * psi_coef(i,i_state) * psi_coef(j,i_state)
+!  delta_ij(j,i,i_state) += delta_ij_tmp(j,i,i_state)
+! enddo
+!enddo
+!second_order_pt_new_2h2p(i_state) = accu(i_state) 
+!enddo
+!print*, '2h2p = ',accu
+
+ double precision :: contrib_2h2p(N_states)
+ call give_2h2p(contrib_2h2p)
+ do i_state = 1, N_states
+ do i = 1, N_det
+   delta_ij(i,i,i_state) += contrib_2h2p(i_state)
+ enddo
+ second_order_pt_new_2h2p(i_state) = contrib_2h2p(i_state) 
+ enddo
+ print*, '2h2p = ',contrib_2h2p(1) 
+ 
+
+ ! total  
+ accu = 0.d0
+ do i_state = 1, N_states
+ do i = 1, N_det
+! write(*,'(1000(F16.10,x))')delta_ij(i,:,:)
+  do j = i_state, N_det
+   accu(i_state) += delta_ij(j,i,i_state) * psi_coef(i,i_state) * psi_coef(j,i_state)
+  enddo
+ enddo
+ second_order_pt_new(i_state) = accu(i_state) 
+ print*, 'total= ',accu(i_state)
+ enddo
+
+
+
+
+END_PROVIDER
+
+ BEGIN_PROVIDER [double precision, Hmatrix_dressed_pt2_new, (N_det,N_det,N_states)]
+ implicit none
+ integer :: i,j,i_state
+ do i_state = 1, N_states
+  do i = 1,N_det
+   do j = 1,N_det
+    Hmatrix_dressed_pt2_new(j,i,i_state) = H_matrix_all_dets(j,i) + delta_ij(j,i,i_state)
+   enddo
+  enddo
+ enddo
+ END_PROVIDER 
+
+ 
+
+ BEGIN_PROVIDER [double precision, Hmatrix_dressed_pt2_new_symmetrized, (N_det,N_det,N_states)]
+ implicit none
+ integer :: i,j,i_state
+ do i_state = 1, N_states
+  do i = 1,N_det
+   do j = i,N_det
+    Hmatrix_dressed_pt2_new_symmetrized(j,i,i_state) =  H_matrix_all_dets(j,i) & 
+                                            + 0.5d0 * ( delta_ij(j,i,i_state) + delta_ij(i,j,i_state) )
+    Hmatrix_dressed_pt2_new_symmetrized(i,j,i_state) =  Hmatrix_dressed_pt2_new_symmetrized(j,i,i_state) 
+   enddo
+  enddo
+ enddo
+ END_PROVIDER 
+
+  BEGIN_PROVIDER [ double precision, CI_electronic_dressed_pt2_new_energy, (N_states_diag) ]
+ &BEGIN_PROVIDER [ double precision, CI_dressed_pt2_new_eigenvectors, (N_det,N_states_diag) ]
+ &BEGIN_PROVIDER [ double precision, CI_dressed_pt2_new_eigenvectors_s2, (N_states_diag) ]
+  BEGIN_DOC
+  ! Eigenvectors/values of the CI matrix
+  END_DOC
+  implicit none
+  double precision :: ovrlp,u_dot_v
+  integer :: i_good_state
+  integer, allocatable  :: index_good_state_array(:)
+  logical, allocatable  :: good_state_array(:)
+  double precision, allocatable :: s2_values_tmp(:)
+  integer :: i_other_state
+  double precision, allocatable  :: eigenvectors(:,:), eigenvalues(:)
+  integer :: i_state
+  double precision :: s2,e_0
+  integer                        :: i,j,k
+  double precision, allocatable :: s2_eigvalues(:)
+  double precision, allocatable :: e_array(:)
+  integer, allocatable :: iorder(:)
+  
+  ! Guess values for the "N_states_diag" states of the CI_dressed_pt2_new_eigenvectors 
+  do j=1,min(N_states_diag,N_det)
+    do i=1,N_det
+      CI_dressed_pt2_new_eigenvectors(i,j) = psi_coef(i,j)
+    enddo
+  enddo
+
+  do j=N_det+1,N_states_diag
+    do i=1,N_det
+      CI_dressed_pt2_new_eigenvectors(i,j) = 0.d0
+    enddo
+  enddo
+  
+  if (diag_algorithm == "Davidson") then
+    
+    print*, 'Davidson not yet implemented for the dressing ... '
+    stop
+    
+   else if (diag_algorithm == "Lapack") then
+
+     allocate (eigenvectors(size(H_matrix_all_dets,1),N_det))
+     allocate (eigenvalues(N_det))
+     call lapack_diag(eigenvalues,eigenvectors,                      &
+         H_matrix_all_dets,size(H_matrix_all_dets,1),N_det)
+     CI_electronic_energy(:) = 0.d0
+     if (s2_eig) then
+       i_state = 0
+       allocate (s2_eigvalues(N_det))
+       allocate(index_good_state_array(N_det),good_state_array(N_det))
+       good_state_array = .False.
+       call u_0_S2_u_0(s2_eigvalues,eigenvectors,N_det,psi_det,N_int,&
+         N_det,size(eigenvectors,1))
+       do j=1,N_det
+         ! Select at least n_states states with S^2 values closed to "expected_s2"
+         if(dabs(s2_eigvalues(j)-expected_s2).le.0.5d0)then
+           i_state +=1
+           index_good_state_array(i_state) = j
+           good_state_array(j) = .True.
+         endif
+         if(i_state.eq.N_states) then
+           exit
+         endif
+       enddo
+       if(i_state .ne.0)then
+         ! Fill the first "i_state" states that have a correct S^2 value
+         do j = 1, i_state
+           do i=1,N_det
+             CI_eigenvectors(i,j) = eigenvectors(i,index_good_state_array(j))
+           enddo
+           CI_electronic_energy(j) = eigenvalues(index_good_state_array(j))
+           CI_eigenvectors_s2(j) = s2_eigvalues(index_good_state_array(j))
+         enddo
+         i_other_state = 0
+         do j = 1, N_det
+           if(good_state_array(j))cycle
+           i_other_state +=1
+           if(i_state+i_other_state.gt.n_states_diag)then
+             exit
+           endif
+           do i=1,N_det
+             CI_eigenvectors(i,i_state+i_other_state) = eigenvectors(i,j)
+           enddo
+           CI_electronic_energy(i_state+i_other_state) = eigenvalues(j)
+           CI_eigenvectors_s2(i_state+i_other_state) = s2_eigvalues(i_state+i_other_state)
+         enddo
+
+       else
+         print*,''
+         print*,'!!!!!!!!   WARNING  !!!!!!!!!'
+         print*,'  Within the ',N_det,'determinants selected'
+         print*,'  and the ',N_states_diag,'states requested'
+         print*,'  We did not find any state with S^2 values close to ',expected_s2
+         print*,'  We will then set the first N_states eigenvectors of the H matrix'
+         print*,'  as the CI_eigenvectors'
+         print*,'  You should consider more states and maybe ask for s2_eig to be .True. or just enlarge the CI space'
+         print*,''
+         do j=1,min(N_states_diag,N_det)
+           do i=1,N_det
+             CI_eigenvectors(i,j) = eigenvectors(i,j)
+           enddo
+           CI_electronic_energy(j) = eigenvalues(j)
+           CI_eigenvectors_s2(j) = s2_eigvalues(j)
+         enddo
+       endif
+       deallocate(index_good_state_array,good_state_array)
+       deallocate(s2_eigvalues)
+     else
+       call u_0_S2_u_0(CI_eigenvectors_s2,eigenvectors,N_det,psi_det,N_int,&
+          min(N_det,N_states_diag),size(eigenvectors,1))
+       ! Select the "N_states_diag" states of lowest energy
+       do j=1,min(N_det,N_states_diag)
+         do i=1,N_det
+           CI_eigenvectors(i,j) = eigenvectors(i,j)
+         enddo
+         CI_electronic_energy(j) = eigenvalues(j)
+       enddo
+     endif
+     deallocate(eigenvectors,eigenvalues)
+   endif
+
+ 
+END_PROVIDER
+ 
+
+BEGIN_PROVIDER [ double precision, CI_dressed_pt2_new_energy, (N_states_diag) ]
+  implicit none
+  BEGIN_DOC
+  ! N_states lowest eigenvalues of the CI matrix
+  END_DOC
+  
+  integer                        :: j
+  character*(8)                  :: st
+  call write_time(output_determinants)
+  do j=1,N_states_diag
+    CI_dressed_pt2_new_energy(j) = CI_electronic_dressed_pt2_new_energy(j) + nuclear_repulsion
+    write(st,'(I4)') j
+    call write_double(output_determinants,CI_dressed_pt2_new_energy(j),'Energy of state '//trim(st))
+    call write_double(output_determinants,CI_eigenvectors_s2(j),'S^2 of state '//trim(st))
+  enddo
+
+END_PROVIDER