Revert "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/travis.cfg
-  - source ./quantum_package.rc ; qp_module.py install Full_CI Full_CI_ZMQ Hartree_Fock CAS_SD_ZMQ mrcepa0 All_singles
+  - ./configure  --production ./config/gfortran.cfg
+  - source ./quantum_package.rc ; qp_module.py install Full_CI Full_CI_ZMQ Hartree_Fock CAS_SD mrcepa0 All_singles
   - 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
-* Blas/Lapack
+* Blast/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 --align=32 
+IRPF90_FLAGS : --ninja --assert --align=32 
 
 # Global options
 ################

config/ifort.cfg

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

config/travis.cfg

@@ -1,62 +0,0 @@
-# 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++", "make" ],
-    "f77zmq" : [ "zeromq", "python", "make" ],
+    "zeromq" : [ "g++" ],
+    "f77zmq" : [ "zeromq", "python" ],
     "python": [],
     "ninja": ["g++", "python"],
     "make": [],
@@ -102,7 +102,7 @@ curl = Info(
     default_path=join(QP_ROOT_BIN, "curl"))
 
 zlib = Info(
-    url='http://www.zlib.net/zlib-1.2.11.tar.gz',
+    url='http://zlib.net/zlib-1.2.8.tar.gz',
     description=' zlib',
     default_path=join(QP_ROOT_LIB, "libz.a"))
 
@@ -150,6 +150,7 @@ 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',
@@ -165,7 +166,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))
 
 
@@ -493,24 +494,16 @@ 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 C_INCLUDE_PATH="${C_INCLUDE_PATH}":"${QP_ROOT}"/include',
-        '',
-        'source ${QP_ROOT}/install/EZFIO/Bash/ezfio.sh',
+        'export LIBRARY_PATH="${QP_ROOT}"/lib:"${LIBRARY_PATH}"', "",
+        'source ${QP_ROOT}/install/EZFIO/Bash/ezfio.sh', "",
+        'source ${HOME}/.opam/opam-init/init.sh > /dev/null 2> /dev/null || true',
         '',
         '# 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,11 +4,7 @@
 BUILD=_build/${TARGET}
 rm -rf -- ${BUILD}
 mkdir ${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
+tar -zxf Downloads/${TARGET}.tar.gz --strip-components=1 --directory=${BUILD} || exit 1
 _install || exit 1
 rm -rf -- ${BUILD} _build/${TARGET}.log
 exit 0

install/scripts/install_curl.sh

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

install/scripts/install_f77zmq.sh

@@ -7,9 +7,10 @@ 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}"/include/zmq.h
+  export ZMQ_H="${QP_ROOT}"/lib/zmq.h
   cd "${BUILD}"
   make -j 8                        || exit 1
   mv libf77zmq.a "${QP_ROOT}"/lib  || exit 1

install/scripts/install_gmp.sh

@@ -1,17 +0,0 @@
-#!/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,7 +8,8 @@ function _install()
   QP_ROOT=$PWD
   cd -
   cd ${BUILD}
-  ./configure --prefix=$QP_ROOT && make || exit 1 
+  ./configure && 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.1.10 ocamlfind sexplib ZMQ"
+PACKAGES="core cryptokit zarith ocamlfind sexplib ZMQ"
 #ppx_sexp_conv
 
 # Needed for ZeroMQ
-export C_INCLUDE_PATH="${QP_ROOT}"/include:"${C_INCLUDE_PATH}"
+export C_INCLUDE_PATH="${QP_ROOT}"/lib:"${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} && make || exit 1
+  ./configure --prefix=${QP_ROOT}/install/${TARGET} && make || exit 1
   make install || exit 1
   cd -
   cp ${TARGET}/bin/${TARGET} ${QP_ROOT}/bin || exit 1

install/scripts/install_zeromq.sh

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

install/scripts/install_zlib.sh

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

ocaml/Pseudo.ml

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

ocaml/qp_create_guess.ml

@@ -88,9 +88,8 @@ 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.init (List.length determinants) (fun _ -> Det_coef.of_float ((Random.float 2.)-.1.))
+    Array.create ~len:(List.length determinants) (Det_coef.of_float 1.)
   in
  
   determinants 

plugins/All_singles/H_apply.irp.f

@@ -8,13 +8,6 @@ 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,7 +15,6 @@ 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_factor = selection_criterion_factor * 0.5d0
+     selection_criterion = selection_criterion * 0.5d0
     endif
     
   enddo

plugins/All_singles/all_1h_1p_singles.irp.f

@@ -1,76 +0,0 @@
-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,7 +3,6 @@
 .ninja_log
 AO_Basis
 Bitmask
-Davidson
 Determinants
 Electrons
 Ezfio_files

plugins/CAS_SD/README.rst

@@ -107,7 +107,6 @@ 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
 =============
@@ -194,6 +193,31 @@ 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 = max(threshold_selectors,threshold_selectors_pt2)
-    threshold_generators = max(threshold_generators,threshold_generators_pt2)
+    threshold_selectors = 1.d0
+    threshold_generators = 0.999d0
     call H_apply_CAS_SD_PT2(pt2, norm_pert, H_pert_diag,  N_st)
 
     print *,  'Final step'

plugins/CAS_SD_ZMQ/EZFIO.cfg

@@ -1,10 +0,0 @@
-[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

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

plugins/CAS_SD_ZMQ/README.rst

@@ -1,14 +0,0 @@
-==========
-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

@@ -1,255 +0,0 @@
-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

@@ -1,79 +0,0 @@
-
-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

@@ -1,11 +0,0 @@
-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

@@ -1,4 +0,0 @@
-! 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

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

plugins/CAS_SD_ZMQ/selection_buffer.irp.f

@@ -1,70 +0,0 @@
-
-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

@@ -1,93 +0,0 @@
-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

@@ -1,9 +0,0 @@
-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

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

plugins/DFT_Utils/NEEDED_CHILDREN_MODULES

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

plugins/DFT_Utils/grid_density.irp.f

@@ -1,165 +0,0 @@
-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

@@ -1,54 +0,0 @@
-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

@@ -1,109 +0,0 @@
- 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

@@ -1,219 +0,0 @@
-
-  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

@@ -1,24 +0,0 @@
-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,15 +19,10 @@ default: 0.00001
 
 [do_it_perturbative]
 type: logical
-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
+doc: if true, you do the FOBOCI calculation perturbatively 
 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
@@ -54,9 +49,3 @@ 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

@@ -1,889 +0,0 @@
-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,25 +1,13 @@
-subroutine all_single(e_pt2)
+subroutine all_single
   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))
-  if(.not.selected_fobo_ci)then
-   selection_criterion = 0.d0
-   soft_touch selection_criterion
-  else 
-   selection_criterion =  0.1d0 
-   selection_criterion_factor = 0.01d0
-   selection_criterion_min = selection_criterion
-   soft_touch selection_criterion
-  endif
-  print*, 'e_pt2 = ',e_pt2
-  pt2_max = 0.15d0 * e_pt2
-  soft_touch pt2_max
-  print*, 'pt2_max = ',pt2_max
+  selection_criterion = 0.d0
+  soft_touch selection_criterion
   threshold_davidson = 1.d-9
   soft_touch threshold_davidson davidson_criterion
   i = 0
@@ -29,8 +17,6 @@ subroutine all_single(e_pt2)
   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 '
@@ -43,7 +29,7 @@ subroutine all_single(e_pt2)
    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))) > dabs(pt2_max))
+  do while (N_det < n_det_max.and.maxval(abs(pt2(1:N_st))) > pt2_max)
     i += 1
     print*,'-----------------------'
     print*,'i = ',i
@@ -53,8 +39,6 @@ subroutine all_single(e_pt2)
     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
@@ -69,6 +53,7 @@ subroutine all_single(e_pt2)
     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,hij,delta_e,exc,contrib
+ double precision :: get_mo_bielec_integral_schwartz,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(i_hole,j_hole,k_part,l_part,mo_integrals_map)
+     hij = get_mo_bielec_integral_schwartz(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(i_hole,j_hole,k_part,l_part,mo_integrals_map)
-     exc = get_mo_bielec_integral(i_hole,j_hole,l_part,k_part,mo_integrals_map)
+     hij = get_mo_bielec_integral_schwartz(i_hole,j_hole,k_part,l_part,mo_integrals_map)
+     exc = get_mo_bielec_integral_schwartz(i_hole,j_hole,l_part,k_part,mo_integrals_map)
      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(i_hole,j_hole,k_part,l_part,mo_integrals_map)
-     exc = get_mo_bielec_integral(i_hole,j_hole,l_part,k_part,mo_integrals_map)
+     hij = get_mo_bielec_integral_schwartz(i_hole,j_hole,k_part,l_part,mo_integrals_map)
+     exc = get_mo_bielec_integral_schwartz(i_hole,j_hole,l_part,k_part,mo_integrals_map)
      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,hij,delta_e,exc,contrib
+ double precision :: get_mo_bielec_integral_schwartz,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(i_hole,j_hole,k_part,l_part,mo_integrals_map)
+     hij = get_mo_bielec_integral_schwartz(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(i_hole,j_hole,k_part,l_part,mo_integrals_map)
-     exc = get_mo_bielec_integral(i_hole,j_hole,l_part,k_part,mo_integrals_map)
+     hij = get_mo_bielec_integral_schwartz(i_hole,j_hole,k_part,l_part,mo_integrals_map)
+     exc = get_mo_bielec_integral_schwartz(i_hole,j_hole,l_part,k_part,mo_integrals_map)
      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(i_hole,j_hole,k_part,l_part,mo_integrals_map)
-     exc = get_mo_bielec_integral(i_hole,j_hole,l_part,k_part,mo_integrals_map)
+     hij = get_mo_bielec_integral_schwartz(i_hole,j_hole,k_part,l_part,mo_integrals_map)
+     exc = get_mo_bielec_integral_schwartz(i_hole,j_hole,l_part,k_part,mo_integrals_map)
      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,hij,delta_e,exc,contrib
+ double precision :: get_mo_bielec_integral_schwartz,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(i_hole,j_hole,k_part,l_part,mo_integrals_map)
+     hij = get_mo_bielec_integral_schwartz(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(i_hole,j_hole,k_part,l_part,mo_integrals_map)
-     exc = get_mo_bielec_integral(i_hole,j_hole,l_part,k_part,mo_integrals_map)
+     hij = get_mo_bielec_integral_schwartz(i_hole,j_hole,k_part,l_part,mo_integrals_map)
+     exc = get_mo_bielec_integral_schwartz(i_hole,j_hole,l_part,k_part,mo_integrals_map)
 
      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(i_hole,j_hole,k_part,l_part,mo_integrals_map)
-     exc = get_mo_bielec_integral(i_hole,j_hole,l_part,k_part,mo_integrals_map)
+     hij = get_mo_bielec_integral_schwartz(i_hole,j_hole,k_part,l_part,mo_integrals_map)
+     exc = get_mo_bielec_integral_schwartz(i_hole,j_hole,l_part,k_part,mo_integrals_map)
 
      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,hij,delta_e,exc,contrib
+ double precision :: get_mo_bielec_integral_schwartz,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(i_hole,j_hole,k_part,l_part,mo_integrals_map)
+     hij = get_mo_bielec_integral_schwartz(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,9 +68,7 @@ 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)
@@ -215,8 +213,6 @@ 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
+ double precision :: tmp(mo_tot_num_align,mo_tot_num),accu,get_mo_bielec_integral_schwartz
  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(i_inact,k_act,j_inact,k_act,mo_integrals_map)
-    accu -= get_mo_bielec_integral(i_inact,k_act,k_act,j_inact,mo_integrals_map)
+    accu += get_mo_bielec_integral_schwartz(i_inact,k_act,j_inact,k_act,mo_integrals_map)
+    accu -= get_mo_bielec_integral_schwartz(i_inact,k_act,k_act,j_inact,mo_integrals_map)
    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(i_virt,k_act,j_virt,k_act,mo_integrals_map)
+    accu += get_mo_bielec_integral_schwartz(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,7 +58,24 @@ 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
@@ -72,21 +89,20 @@ subroutine standard_dress(delta_ij_generators_,size_buffer,Ndet_generators,i_gen
 end
 
 
-subroutine is_a_good_candidate(threshold,is_ok,e_pt2,verbose,exit_loop,is_ok_perturbative)
+subroutine is_a_good_candidate(threshold,is_ok,verbose)
  use bitmasks
  implicit none
  double precision, intent(in) :: threshold
- double precision, intent(out):: e_pt2
- logical, intent(out) :: is_ok,exit_loop,is_ok_perturbative
+ logical, intent(out) :: is_ok
  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),psi_coef_diagonalized_tmp(N_det_generators,N_states))
+ allocate(psi_det_generators_input(N_int,2,N_det_generators),dressed_H_matrix(N_det_generators,N_det_generators))
+ 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
@@ -95,20 +111,9 @@ subroutine is_a_good_candidate(threshold,is_ok,e_pt2,verbose,exit_loop,is_ok_per
   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,exit_loop,is_ok_perturbative)
-!do m = 1, N_states
-! do k = 1, N_det_generators
-!  do l = 1, N_int
-!    psi_selectors(l,1,k) = psi_det_generators_input(l,1,k) 
-!    psi_selectors(l,2,k) = psi_det_generators_input(l,2,k) 
-!  enddo
-!  psi_selectors_coef(k,m) = psi_coef_diagonalized_tmp(k,m)
-! enddo
-!enddo
-!soft_touch psi_selectors psi_selectors_coef 
-!if(do_it_perturbative)then
-   print*, 'is_ok_perturbative',is_ok_perturbative
-  if(is_ok.or.is_ok_perturbative)then
+ call dress_H_matrix_from_psi_det_input(psi_det_generators_input,N_det_generators,is_ok,psi_coef_diagonalized_tmp, dressed_H_matrix,threshold,verbose)
+ if(do_it_perturbative)then
+  if(is_ok)then
    N_det = N_det_generators
    do m = 1, N_states
     do k = 1, N_det_generators
@@ -117,19 +122,11 @@ subroutine is_a_good_candidate(threshold,is_ok,e_pt2,verbose,exit_loop,is_ok_per
        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)
 
@@ -138,14 +135,14 @@ subroutine is_a_good_candidate(threshold,is_ok,e_pt2,verbose,exit_loop,is_ok_per
 
 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,exit_loop,is_ok_perturbative)
+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)
  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,exit_loop,is_ok_perturbative
+ logical, intent(out) :: is_ok
  double precision, intent(out) :: psi_coef_diagonalized_tmp(Ndet_generators,N_states)
  double precision, intent(inout) :: dressed_H_matrix(Ndet_generators, Ndet_generators)
 
@@ -154,7 +151,6 @@ 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
@@ -195,7 +191,6 @@ 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
@@ -283,11 +278,9 @@ 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
-     print*,'accu = ',accu
-     if(dabs(accu).ge.0.72d0)then
+     if(dabs(accu).ge.0.8d0)then
       i_good_state(0) +=1
       i_good_state(i_good_state(0)) = i
      endif
@@ -328,124 +321,10 @@ 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_perturbative = ',is_ok_perturbative
+  print*,'is_ok = ',is_ok
  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,13 +1,8 @@
 program foboscf
  implicit none
-!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
+ call run_prepare
  no_oa_or_av_opt = .True.
  touch no_oa_or_av_opt
- call run_prepare
  call routine_fobo_scf
  call save_mos
 
@@ -15,8 +10,8 @@ end
 
 subroutine run_prepare
  implicit none
-! no_oa_or_av_opt = .False.
-! touch no_oa_or_av_opt
+  no_oa_or_av_opt = .False.
+  touch no_oa_or_av_opt
   call damping_SCF
   call diag_inactive_virt_and_update_mos
 end
@@ -32,7 +27,6 @@ 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
@@ -52,7 +46,7 @@ subroutine routine_fobo_scf
     soft_touch threshold_lmct threshold_mlct
    endif
   endif
-  call FOBOCI_lmct_mlct_old_thr(i)
+  call FOBOCI_lmct_mlct_old_thr
   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,8 +1,7 @@
 
-subroutine FOBOCI_lmct_mlct_old_thr(iter)
+subroutine FOBOCI_lmct_mlct_old_thr
   use bitmasks
  implicit none
- integer, intent(in) :: iter
  integer :: i,j,k,l
  integer(bit_kind),allocatable :: unpaired_bitmask(:,:)
  integer, allocatable :: occ(:,:)
@@ -11,7 +10,7 @@ subroutine FOBOCI_lmct_mlct_old_thr(iter)
  logical :: test_sym
  double precision :: thr,hij
  double precision, allocatable :: dressing_matrix(:,:)
- logical :: verbose,is_ok,is_ok_perturbative
+ logical :: verbose,is_ok
  verbose = .True.
  thr = 1.d-12
  allocate(unpaired_bitmask(N_int,2))
@@ -39,7 +38,6 @@ subroutine FOBOCI_lmct_mlct_old_thr(iter)
  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.
@@ -47,45 +45,87 @@ subroutine FOBOCI_lmct_mlct_old_thr(iter)
    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
+   call check_symetry(i_hole_osoci,thr,test_sym)
+   if(.not.test_sym)cycle
    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)
+   call is_a_good_candidate(threshold_lmct,is_ok,verbose)
    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
+   if(.not.is_ok)cycle
+   allocate(dressing_matrix(N_det_generators,N_det_generators))
+   dressing_matrix = 0.d0
+   if(.not.do_it_perturbative)then
 
-     ! Do 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
+    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
+!   if(dressing_2h2p)then
+!    call diag_dressed_2h2p_hamiltonian_and_update_psi_det(i_hole_osoci,lmct)
+!   endif
+
+!   ! Change the mask of the holes and particles to perform all the 
+!   ! double excitations that starts from the active space in order 
+!   ! to introduce the Coulomb hole in the active space
+!   ! These are the 1h2p excitations that have the i_hole_osoci hole in common
+!   ! and the 2p if there is more than one electron in the active space
+!   do k = 1, N_int
+!    zero_bitmask(k,1) = 0_bit_kind
+!    zero_bitmask(k,2) = 0_bit_kind
+!   enddo
+!   ! hole is possible only in the orbital i_hole_osoci 
+!   call set_bit_to_integer(i_hole_osoci,zero_bitmask(1,1),N_int)
+!   call set_bit_to_integer(i_hole_osoci,zero_bitmask(1,2),N_int)
+!   ! and in the active space
+!   do k = 1, n_act_orb
+!    call set_bit_to_integer(list_act(k),zero_bitmask(1,1),N_int)
+!    call set_bit_to_integer(list_act(k),zero_bitmask(1,2),N_int)
+!   enddo
+!   call set_bitmask_hole_as_input(zero_bitmask)
+
+!   call set_bitmask_particl_as_input(reunion_of_bitmask)
+
+!   call all_1h2p
+!   call diagonalize_CI_SC2
+!   call provide_matrix_dressing(dressing_matrix,n_det_generators,psi_det_generators)
+
+!   ! Change the mask of the holes and particles to perform all the 
+!   ! double excitations that from the orbital i_hole_osoci
+!   do k = 1, N_int
+!    zero_bitmask(k,1) = 0_bit_kind
+!    zero_bitmask(k,2) = 0_bit_kind
+!   enddo
+!   ! hole is possible only in the orbital i_hole_osoci 
+!   call set_bit_to_integer(i_hole_osoci,zero_bitmask(1,1),N_int)
+!   call set_bit_to_integer(i_hole_osoci,zero_bitmask(1,2),N_int)
+!   call set_bitmask_hole_as_input(zero_bitmask)
+
+!   call set_bitmask_particl_as_input(reunion_of_bitmask)
+
+!   call set_psi_det_to_generators
+!   call all_2h2p
+!   call diagonalize_CI_SC2
     double precision :: hkl
     call provide_matrix_dressing(dressing_matrix,n_det_generators,psi_det_generators)
     hkl = dressing_matrix(1,1)
@@ -96,10 +136,7 @@ subroutine FOBOCI_lmct_mlct_old_thr(iter)
     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
+!   call diag_dressed_matrix_and_set_to_psi_det(psi_det_generators,N_det_generators,dressing_matrix)
    endif
    call set_intermediate_normalization_lmct_old(norm_tmp,i_hole_osoci)
 
@@ -108,6 +145,7 @@ subroutine FOBOCI_lmct_mlct_old_thr(iter)
     norm_total(k) += norm_tmp(k)
    enddo
    call update_density_matrix_osoci
+   deallocate(dressing_matrix)
  enddo
 
  if(.True.)then
@@ -121,10 +159,10 @@ subroutine FOBOCI_lmct_mlct_old_thr(iter)
 
     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
+    call check_symetry(i_particl_osoci,thr,test_sym)
+    if(.not.test_sym)cycle
     print*,'i_particl_osoci= ',i_particl_osoci
     ! Initialize the bitmask to the restart ones
     call initialize_bitmask_to_restart_ones
@@ -140,33 +178,24 @@ subroutine FOBOCI_lmct_mlct_old_thr(iter)
     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)
+    call is_a_good_candidate(threshold_mlct,is_ok,verbose)
     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
+    if(.not.is_ok)cycle
+     allocate(dressing_matrix(N_det_generators,N_det_generators))
+    if(.not.do_it_perturbative)then
+     dressing_matrix = 0.d0
+     do k = 1, N_det_generators
+      do l = 1, N_det_generators
+        call i_h_j(psi_det_generators(1,1,k),psi_det_generators(1,1,l),N_int,hkl)
+        dressing_matrix(k,l) = hkl
       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
+     enddo
+ !   call all_single_split(psi_det_generators,psi_coef_generators,N_det_generators,dressing_matrix)
+ !   call diag_dressed_matrix_and_set_to_psi_det(psi_det_generators,N_det_generators,dressing_matrix)
+     call all_single
+!    if(dressing_2h2p)then
+!     call diag_dressed_2h2p_hamiltonian_and_update_psi_det(i_particl_osoci,lmct)
+!    endif
     endif
     call set_intermediate_normalization_mlct_old(norm_tmp,i_particl_osoci)
     do k = 1, N_states
@@ -174,6 +203,7 @@ subroutine FOBOCI_lmct_mlct_old_thr(iter)
      norm_total(k) += norm_tmp(k)
     enddo
     call update_density_matrix_osoci
+   deallocate(dressing_matrix)
   enddo
  endif
 
@@ -200,7 +230,7 @@ subroutine FOBOCI_mlct_old
  double precision :: norm_tmp,norm_total
  logical :: test_sym
  double precision :: thr
- logical :: verbose,is_ok,exit_loop
+ logical :: verbose,is_ok
  verbose = .False.
  thr = 1.d-12
  allocate(unpaired_bitmask(N_int,2))
@@ -240,7 +270,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,exit_loop)
+   call is_a_good_candidate(threshold_mlct,is_ok,verbose)
    print*,'is_ok = ',is_ok
    is_ok =.True.
    if(.not.is_ok)cycle
@@ -274,7 +304,7 @@ subroutine FOBOCI_lmct_old
  double precision :: norm_tmp,norm_total
  logical :: test_sym
  double precision :: thr
- logical :: verbose,is_ok,exit_loop
+ logical :: verbose,is_ok
  verbose = .False.
  thr = 1.d-12
  allocate(unpaired_bitmask(N_int,2))
@@ -312,7 +342,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,exit_loop)
+   call is_a_good_candidate(threshold_lmct,is_ok,verbose)
    print*,'is_ok = ',is_ok
    if(.not.is_ok)cycle
 !  ! so all the mono excitation on the new generators 
@@ -335,303 +365,3 @@ 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,7 +9,6 @@ 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
@@ -31,7 +30,6 @@ 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

@@ -0,0 +1,82 @@
+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,50 +212,12 @@ 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_average(i,j) - one_body_dm_mo_alpha_generators_restart(i,j))
-   one_body_dm_mo_beta_osoci(i,j) = one_body_dm_mo_beta_osoci(i,j) + (one_body_dm_mo_beta_average(i,j) - one_body_dm_mo_beta_generators_restart(i,j))
+   one_body_dm_mo_alpha_osoci(i,j) = one_body_dm_mo_alpha_osoci(i,j) + (one_body_dm_mo_alpha(i,j) - one_body_dm_mo_alpha_generators_restart(i,j))
+   one_body_dm_mo_beta_osoci(i,j) = one_body_dm_mo_beta_osoci(i,j) + (one_body_dm_mo_beta(i,j) - one_body_dm_mo_beta_generators_restart(i,j))
   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
 
 
@@ -425,14 +387,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.0.0001d0)then
+   if(dabs(tmp(iorb,jorb)).gt.threshold_lmct)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.0.0001d0)then
+   if(dabs(tmp(iorb,jorb)).gt.threshold_mlct)then
     print*,'VIRT      '
     print*,'DM ',iorb,jorb,(tmp(iorb,jorb))
    endif
@@ -450,10 +412,6 @@ 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)
 
@@ -630,14 +588,14 @@ end
    integer :: i
    double precision :: accu_tot,accu_sd
    print*,'touched the one_body_dm_mo_beta'
-   one_body_dm_mo_alpha_average = one_body_dm_mo_alpha_osoci
-   one_body_dm_mo_beta_average = one_body_dm_mo_beta_osoci
+   one_body_dm_mo_alpha = one_body_dm_mo_alpha_osoci
+   one_body_dm_mo_beta = 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_average(i,i) + one_body_dm_mo_beta_average(i,i)
-    accu_sd  += one_body_dm_mo_alpha_average(i,i) - one_body_dm_mo_beta_average(i,i)
+    accu_tot += one_body_dm_mo_alpha(i,i) + one_body_dm_mo_beta(i,i)
+    accu_sd  += one_body_dm_mo_alpha(i,i) - one_body_dm_mo_beta(i,i)
    enddo
    print*,'accu_tot = ',accu_tot
    print*,'accu_sdt = ',accu_sd 

plugins/Full_CI/.gitignore

@@ -3,7 +3,6 @@
 .ninja_log
 AO_Basis
 Bitmask
-Davidson
 Determinants
 Electrons
 Ezfio_files
@@ -29,6 +28,7 @@ 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,17 +7,16 @@ 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,7 +16,6 @@ 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
 =============
@@ -78,31 +77,6 @@ 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.
@@ -170,6 +144,118 @@ 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,9 +92,8 @@ 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
+    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/full_ci_no_skip.irp.f

@@ -73,11 +73,9 @@ 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

@@ -1,11 +0,0 @@
-[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 
+Perturbation Selectors_full Generators_full ZMQ Full_CI

plugins/Full_CI_ZMQ/energy.irp.f

@@ -1,11 +0,0 @@
-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,15 +5,11 @@ 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
-  threshold_davidson_in = threshold_davidson
-  threshold_davidson = threshold_davidson_in * 100.d0
-  SOFT_TOUCH threshold_davidson
+  diag_algorithm = "Lapack"
   
   if (N_det > N_det_max) then
     call diagonalize_CI
@@ -37,11 +33,29 @@ 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
@@ -65,40 +79,13 @@ program fci_zmq
       enddo
     endif
     E_CI_before(1:N_states) = CI_energy(1:N_states)
-    call ezfio_set_full_ci_zmq_energy(CI_energy(1))
-
-    n_det_before = N_det
-    to_select = 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))
+    call ezfio_set_full_ci_energy(CI_energy)
   enddo
 
-  if (N_det < N_det_max) then
-      threshold_davidson = threshold_davidson_in
-      SOFT_TOUCH threshold_davidson
-      call diagonalize_CI
-      call save_wavefunction
-      call ezfio_set_full_ci_zmq_energy(CI_energy(1))
-  endif
-
   if(do_pt2_end)then
     print*,'Last iteration only to compute the PT2'
-    threshold_selectors = max(threshold_selectors,threshold_selectors_pt2)
-    threshold_generators = max(threshold_generators,threshold_generators_pt2)
-    TOUCH threshold_selectors threshold_generators
+    threshold_selectors = 1.d0
+    threshold_generators = 0.9999d0
     E_CI_before(1:N_states) = CI_energy(1:N_states)
     call ZMQ_selection(0, pt2)
     print *,  'Final step'
@@ -111,11 +98,9 @@ program fci_zmq
       print *,  'E+PT2    = ', E_CI_before+pt2
       print *,  '-----'
     enddo
-    call ezfio_set_full_ci_zmq_energy_pt2(E_CI_before(1)+pt2(1))
+    call ezfio_set_full_ci_energy_pt2(E_CI_before+pt2)
   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
 
 
@@ -136,43 +121,38 @@ subroutine ZMQ_selection(N_in, pt2)
   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
+  N = max(N_in,1)
+  provide nproc
+  provide ci_electronic_energy
+  call new_parallel_job(zmq_to_qp_run_socket,"selection")
+  call zmq_put_psi(zmq_to_qp_run_socket,1,ci_electronic_energy,size(ci_electronic_energy))
+  call zmq_set_running(zmq_to_qp_run_socket)
+  call create_selection_buffer(N, N*2, b)
 
   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)
+  do i= N_det_generators, 1, -step
+    i_generator_start = max(i-step+1,1)
+    i_generator_max = i
     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 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)
+      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
 
@@ -181,7 +161,7 @@ subroutine selection_slave_inproc(i)
   implicit none
   integer, intent(in)            :: i
 
-  call run_selection_slave(1,i,pt2_e0_denominator)
+  call run_selection_slave(1,i,ci_electronic_energy)
 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)
+  double precision, intent(in)    :: energy(N_states_diag)
   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 pt2_e0_denominator mo_tot_num N_int
+!   PROVIDE ci_electronic_energy 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)
+  double precision :: energy(N_states_diag)
   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)
+      call zmq_get_psi(zmq_to_qp_run_socket,1,energy,N_states_diag)
   
       !$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)
+  double precision, intent(in) :: energy(N_states_diag)
   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,N_states
+    do k=1,size(ci_electronic_energy)
       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)
+  double precision, intent(in) :: energy(N_states_diag)
   integer, intent(in)            :: i
 
   call run_selection_slave(0,i,energy)

plugins/Full_CI_ZMQ/selection_double.irp.f

@@ -1,480 +1,3 @@
-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
@@ -526,8 +49,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_selectors(j,1,i))
-      mobMask(j,2) = iand(negMask(j,2), psi_selectors(j,2,i))
+      mobMask(j,1) = iand(negMask(j,1), psi_det_sorted(j,1,i))
+      mobMask(j,2) = iand(negMask(j,2), psi_det_sorted(j,2,i))
       nt += popcnt(mobMask(j, 1)) + popcnt(mobMask(j, 2))
     end do
 
@@ -560,19 +83,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_selectors(j,1,i))
-          mobMask(j,2) = iand(negMask(j,2), psi_selectors(j,2,i))
+          mobMask(j,1) = iand(negMask(j,1), psi_det_sorted(j,1,i))
+          mobMask(j,2) = iand(negMask(j,2), psi_det_sorted(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_selectors(:,:,i)
+          minilist(:,:,interesting(0)) = psi_det_sorted(:,:,i)
           if(nt <= 2) then
             fullinteresting(0) += 1
             fullinteresting(fullinteresting(0)) = i
-            fullminilist(:,:,fullinteresting(0)) = psi_selectors(:,:,i)
+            fullminilist(:,:,fullinteresting(0)) = psi_det_sorted(:,:,i)
           end if
         end if
       end do
@@ -581,15 +104,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_selectors(j,1,i))
-          mobMask(j,2) = iand(negMask(j,2), psi_selectors(j,2,i))
+          mobMask(j,1) = iand(negMask(j,1), psi_det_sorted(j,1,i))
+          mobMask(j,2) = iand(negMask(j,2), psi_det_sorted(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_selectors(:,:,i)
+          fullminilist(:,:,fullinteresting(0)) = psi_det_sorted(:,:,i)
         end if
       end do
       
@@ -645,7 +168,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,tmp
+  double precision :: e_pert, delta_E, val, Hii, max_e_pert
   double precision, external :: diag_H_mat_elem_fock
   
   logical, external :: detEq
@@ -670,10 +193,6 @@ 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)
@@ -681,14 +200,14 @@ endif
       
       do istate=1,N_states
         delta_E = E0(istate) - Hii
-        val = mat(istate, p1, p2) + mat(istate, p1, p2) 
-        tmp = dsqrt(delta_E * delta_E + val * val)
+        val = mat(istate, p1, p2)
         if (delta_E < 0.d0) then
-          tmp = -tmp
+          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
-        e_pert = 0.5d0 * ( tmp - delta_E)
-        pt2(istate) = pt2(istate) + e_pert
-        max_e_pert = min(e_pert,max_e_pert)
+        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

plugins/Full_CI_ZMQ/selection_single.irp.f

@@ -0,0 +1,354 @@
+ 
+
+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 pt2_e0_denominator mo_tot_num N_int
+!   PROVIDE ci_electronic_energy 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)
+  double precision :: energy(N_states_diag)
   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)
+      call zmq_get_psi(zmq_to_qp_run_socket,1,energy,N_states_diag)
   
       !$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)
+  double precision, intent(in) :: energy(N_states_diag)
   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,N_states
+    do k=1,size(ci_electronic_energy)
       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)
+  double precision, intent(in) :: energy(N_states_diag)
   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#L45>`_
+`degree_max_generators <http://github.com/LCPQ/quantum_package/tree/master/plugins/Generators_full/generators.irp.f#L43>`_
   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#L68>`_
+`select_max <http://github.com/LCPQ/quantum_package/tree/master/plugins/Generators_full/generators.irp.f#L66>`_
   Memo to skip useless selectors
 
 
-`size_select_max <http://github.com/LCPQ/quantum_package/tree/master/plugins/Generators_full/generators.irp.f#L60>`_
+`size_select_max <http://github.com/LCPQ/quantum_package/tree/master/plugins/Generators_full/generators.irp.f#L58>`_
   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#L269>`_
+`fock_matrix_alpha_mo <http://github.com/LCPQ/quantum_package/tree/master/plugins/Hartree_Fock/Fock_matrix.irp.f#L268>`_
   Fock matrix on the MO basis
 
 
-`fock_matrix_ao <http://github.com/LCPQ/quantum_package/tree/master/plugins/Hartree_Fock/Fock_matrix.irp.f#L327>`_
+`fock_matrix_ao <http://github.com/LCPQ/quantum_package/tree/master/plugins/Hartree_Fock/Fock_matrix.irp.f#L326>`_
   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#L289>`_
+`fock_matrix_beta_mo <http://github.com/LCPQ/quantum_package/tree/master/plugins/Hartree_Fock/Fock_matrix.irp.f#L288>`_
   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#L389>`_
+`fock_mo_to_ao <http://github.com/LCPQ/quantum_package/tree/master/plugins/Hartree_Fock/Fock_matrix.irp.f#L388>`_
   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#L308>`_
+`hf_energy <http://github.com/LCPQ/quantum_package/tree/master/plugins/Hartree_Fock/Fock_matrix.irp.f#L307>`_
   Hartree-Fock energy
 
 

plugins/MP2/mp2.irp.f

@@ -1,10 +1,4 @@
 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,10 +1,4 @@
 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,7 +3,6 @@
 .ninja_log
 AO_Basis
 Bitmask
-Davidson
 Determinants
 Electrons
 Ezfio_files

plugins/MRCC_Utils/README.rst

@@ -36,19 +36,11 @@ Documentation
   Compute 1st dimension such that it is aligned for vectorization.
 
 
-`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_rotation <http://github.com/LCPQ/quantum_package/tree/master/plugins/MRCC_Utils/LinearAlgebra.irp.f#L283>`_
   Apply the rotation found by find_rotation
 
 
-`approx_dble <http://github.com/LCPQ/quantum_package/tree/master/plugins/MRCC_Utils/util.irp.f#L371>`_
+`approx_dble <http://github.com/LCPQ/quantum_package/tree/master/plugins/MRCC_Utils/util.irp.f#L382>`_
   Undocumented
 
 
@@ -71,23 +63,23 @@ Documentation
   Binomial coefficients
 
 
-`ci_eigenvectors_dressed <http://github.com/LCPQ/quantum_package/tree/master/plugins/MRCC_Utils/mrcc_utils.irp.f#L120>`_
-  Eigenvectors/values of the dressed CI matrix
+`ci_eigenvectors_dressed <http://github.com/LCPQ/quantum_package/tree/master/plugins/MRCC_Utils/mrcc_utils.irp.f#L105>`_
+  Eigenvectors/values of the CI matrix
 
 
-`ci_eigenvectors_s2_dressed <http://github.com/LCPQ/quantum_package/tree/master/plugins/MRCC_Utils/mrcc_utils.irp.f#L121>`_
-  Eigenvectors/values of the dressed CI matrix
+`ci_eigenvectors_s2_dressed <http://github.com/LCPQ/quantum_package/tree/master/plugins/MRCC_Utils/mrcc_utils.irp.f#L106>`_
+  Eigenvectors/values of the CI matrix
 
 
-`ci_electronic_energy_dressed <http://github.com/LCPQ/quantum_package/tree/master/plugins/MRCC_Utils/mrcc_utils.irp.f#L119>`_
-  Eigenvectors/values of the dressed CI matrix
+`ci_electronic_energy_dressed <http://github.com/LCPQ/quantum_package/tree/master/plugins/MRCC_Utils/mrcc_utils.irp.f#L104>`_
+  Eigenvectors/values of the CI matrix
 
 
-`ci_energy_dressed <http://github.com/LCPQ/quantum_package/tree/master/plugins/MRCC_Utils/mrcc_utils.irp.f#L247>`_
+`ci_energy_dressed <http://github.com/LCPQ/quantum_package/tree/master/plugins/MRCC_Utils/mrcc_utils.irp.f#L171>`_
   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#L57>`_
+`davidson_diag_hjj_mrcc <http://github.com/LCPQ/quantum_package/tree/master/plugins/MRCC_Utils/davidson.irp.f#L59>`_
   Davidson diagonalization with specific diagonal elements of the H matrix
   .br
   H_jj : specific diagonal H matrix elements to diagonalize de Davidson
@@ -103,39 +95,12 @@ 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_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_diag_mrcc <http://github.com/LCPQ/quantum_package/tree/master/plugins/MRCC_Utils/davidson.irp.f#L4>`_
   Davidson diagonalization.
   .br
   dets_in : bitmasks corresponding to determinants
@@ -154,38 +119,19 @@ Documentation
   Initial guess vectors are not necessarily orthonormal
 
 
-`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>`_
+`dble_fact <http://github.com/LCPQ/quantum_package/tree/master/plugins/MRCC_Utils/util.irp.f#L138>`_
   Undocumented
 
 
-`dble_fact_even <http://github.com/LCPQ/quantum_package/tree/master/plugins/MRCC_Utils/util.irp.f#L153>`_
+`dble_fact_even <http://github.com/LCPQ/quantum_package/tree/master/plugins/MRCC_Utils/util.irp.f#L155>`_
   n!!
 
 
-`dble_fact_odd <http://github.com/LCPQ/quantum_package/tree/master/plugins/MRCC_Utils/util.irp.f#L197>`_
+`dble_fact_odd <http://github.com/LCPQ/quantum_package/tree/master/plugins/MRCC_Utils/util.irp.f#L176>`_
   n!!
 
 
-`dble_logfact <http://github.com/LCPQ/quantum_package/tree/master/plugins/MRCC_Utils/util.irp.f#L231>`_
+`dble_logfact <http://github.com/LCPQ/quantum_package/tree/master/plugins/MRCC_Utils/util.irp.f#L210>`_
   n!!
 
 
@@ -193,23 +139,19 @@ Documentation
   Undocumented
 
 
-`dec_exc <http://github.com/LCPQ/quantum_package/tree/master/plugins/MRCC_Utils/mrcc_utils.irp.f#L532>`_
-  Undocumented
+`delta_ii <http://github.com/LCPQ/quantum_package/tree/master/plugins/MRCC_Utils/mrcc_utils.irp.f#L68>`_
+  Dressing matrix in N_det basis
 
 
-`diagonalize_ci_dressed <http://github.com/LCPQ/quantum_package/tree/master/plugins/MRCC_Utils/mrcc_utils.irp.f#L265>`_
+`delta_ij <http://github.com/LCPQ/quantum_package/tree/master/plugins/MRCC_Utils/mrcc_utils.irp.f#L67>`_
+  Dressing matrix in N_det basis
+
+
+`diagonalize_ci_dressed <http://github.com/LCPQ/quantum_package/tree/master/plugins/MRCC_Utils/mrcc_utils.irp.f#L186>`_
   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.
@@ -228,26 +170,10 @@ 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
@@ -257,19 +183,19 @@ Documentation
   n!
 
 
-`fact_inv <http://github.com/LCPQ/quantum_package/tree/master/plugins/MRCC_Utils/util.irp.f#L123>`_
+`fact_inv <http://github.com/LCPQ/quantum_package/tree/master/plugins/MRCC_Utils/util.irp.f#L125>`_
   1/n!
 
 
-`find_rotation <http://github.com/LCPQ/quantum_package/tree/master/plugins/MRCC_Utils/LinearAlgebra.irp.f#L301>`_
+`find_rotation <http://github.com/LCPQ/quantum_package/tree/master/plugins/MRCC_Utils/LinearAlgebra.irp.f#L264>`_
   Find A.C = B
 
 
-`find_triples_and_quadruples <http://github.com/LCPQ/quantum_package/tree/master/plugins/MRCC_Utils/mrcc_dress.irp.f#L286>`_
+`find_triples_and_quadruples <http://github.com/LCPQ/quantum_package/tree/master/plugins/MRCC_Utils/mrcc_dress.irp.f#L315>`_
   Undocumented
 
 
-`find_triples_and_quadruples_micro <http://github.com/LCPQ/quantum_package/tree/master/plugins/MRCC_Utils/mrcc_dress.irp.f#L346>`_
+`find_triples_and_quadruples_micro <http://github.com/LCPQ/quantum_package/tree/master/plugins/MRCC_Utils/mrcc_dress.irp.f#L375>`_
   Undocumented
 
 
@@ -295,15 +221,7 @@ Documentation
   Undocumented
 
 
-`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>`_
+`get_pseudo_inverse <http://github.com/LCPQ/quantum_package/tree/master/plugins/MRCC_Utils/LinearAlgebra.irp.f#L210>`_
   Find C = A^-1
 
 
@@ -388,63 +306,11 @@ h_apply_mrcc_pt2_monoexc
   Assume N_int is already provided.
 
 
-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>`_
+`h_matrix_dressed <http://github.com/LCPQ/quantum_package/tree/master/plugins/MRCC_Utils/mrcc_utils.irp.f#L79>`_
   Dressed H with Delta_ij
 
 
-`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>`_
+`h_u_0_mrcc <http://github.com/LCPQ/quantum_package/tree/master/plugins/MRCC_Utils/davidson.irp.f#L367>`_
   Computes v_0 = H|u_0>
   .br
   n : number of determinants
@@ -526,15 +392,7 @@ h_apply_mrcepa_pt2_slave_tcp
   Hermite polynomial
 
 
-`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>`_
+`hij_mrcc <http://github.com/LCPQ/quantum_package/tree/master/plugins/MRCC_Utils/mrcc_utils.irp.f#L53>`_
   < ref | H | Non-ref > matrix
 
 
@@ -665,7 +523,7 @@ h_apply_mrcepa_pt2_slave_tcp
   to be in integer*8 format
 
 
-`inv_int <http://github.com/LCPQ/quantum_package/tree/master/plugins/MRCC_Utils/util.irp.f#L278>`_
+`inv_int <http://github.com/LCPQ/quantum_package/tree/master/plugins/MRCC_Utils/util.irp.f#L257>`_
   1/i
 
 
@@ -683,10 +541,6 @@ h_apply_mrcepa_pt2_slave_tcp
   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.
@@ -705,19 +559,15 @@ h_apply_mrcepa_pt2_slave_tcp
   contains the new order of the elements.
 
 
-`lambda_mrcc <http://github.com/LCPQ/quantum_package/tree/master/plugins/MRCC_Utils/mrcc_utils.irp.f#L8>`_
+`lambda_mrcc <http://github.com/LCPQ/quantum_package/tree/master/plugins/MRCC_Utils/mrcc_utils.irp.f#L1>`_
   cm/<Psi_0|H|D_m> or perturbative 1/Delta_E(m)
 
 
-`lambda_mrcc_kept <http://github.com/LCPQ/quantum_package/tree/master/plugins/MRCC_Utils/mrcc_utils.irp.f#L10>`_
+`lambda_mrcc_pt2 <http://github.com/LCPQ/quantum_package/tree/master/plugins/MRCC_Utils/mrcc_utils.irp.f#L2>`_
   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#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>`_
+`lapack_diag <http://github.com/LCPQ/quantum_package/tree/master/plugins/MRCC_Utils/LinearAlgebra.irp.f#L362>`_
   Diagonalize matrix H
   .br
   H is untouched between input and ouptut
@@ -728,7 +578,7 @@ h_apply_mrcepa_pt2_slave_tcp
   .br
 
 
-`lapack_diag_s2 <http://github.com/LCPQ/quantum_package/tree/master/plugins/MRCC_Utils/LinearAlgebra.irp.f#L462>`_
+`lapack_diag_s2 <http://github.com/LCPQ/quantum_package/tree/master/plugins/MRCC_Utils/LinearAlgebra.irp.f#L425>`_
   Diagonalize matrix H
   .br
   H is untouched between input and ouptut
@@ -739,7 +589,7 @@ h_apply_mrcepa_pt2_slave_tcp
   .br
 
 
-`lapack_diagd <http://github.com/LCPQ/quantum_package/tree/master/plugins/MRCC_Utils/LinearAlgebra.irp.f#L332>`_
+`lapack_diagd <http://github.com/LCPQ/quantum_package/tree/master/plugins/MRCC_Utils/LinearAlgebra.irp.f#L295>`_
   Diagonalize matrix H
   .br
   H is untouched between input and ouptut
@@ -750,7 +600,7 @@ h_apply_mrcepa_pt2_slave_tcp
   .br
 
 
-`lapack_partial_diag <http://github.com/LCPQ/quantum_package/tree/master/plugins/MRCC_Utils/LinearAlgebra.irp.f#L528>`_
+`lapack_partial_diag <http://github.com/LCPQ/quantum_package/tree/master/plugins/MRCC_Utils/LinearAlgebra.irp.f#L491>`_
   Diagonalize matrix H
   .br
   H is untouched between input and ouptut
@@ -761,27 +611,19 @@ h_apply_mrcepa_pt2_slave_tcp
   .br
 
 
-`logfact <http://github.com/LCPQ/quantum_package/tree/master/plugins/MRCC_Utils/util.irp.f#L91>`_
+`logfact <http://github.com/LCPQ/quantum_package/tree/master/plugins/MRCC_Utils/util.irp.f#L93>`_
   n!
 
 
-`lowercase <http://github.com/LCPQ/quantum_package/tree/master/plugins/MRCC_Utils/util.irp.f#L395>`_
+`lowercase <http://github.com/LCPQ/quantum_package/tree/master/plugins/MRCC_Utils/util.irp.f#L406>`_
   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
 
 
-`mrmode <http://github.com/LCPQ/quantum_package/tree/master/plugins/MRCC_Utils/mrcc_utils.irp.f#L3>`_
+`mrcc_iterations <http://github.com/LCPQ/quantum_package/tree/master/plugins/MRCC_Utils/mrcc_general.irp.f#L7>`_
   Undocumented
 
 
@@ -790,24 +632,12 @@ h_apply_mrcepa_pt2_slave_tcp
   D(t) =! D(t) +( B(t)*C(t))
 
 
-`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>`_
+`normalize <http://github.com/LCPQ/quantum_package/tree/master/plugins/MRCC_Utils/util.irp.f#L358>`_
   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#L304>`_
+`nproc <http://github.com/LCPQ/quantum_package/tree/master/plugins/MRCC_Utils/util.irp.f#L283>`_
   Number of current OpenMP threads
 
 
@@ -829,7 +659,7 @@ h_apply_mrcepa_pt2_slave_tcp
   .br
 
 
-`ortho_lowdin <http://github.com/LCPQ/quantum_package/tree/master/plugins/MRCC_Utils/LinearAlgebra.irp.f#L162>`_
+`ortho_lowdin <http://github.com/LCPQ/quantum_package/tree/master/plugins/MRCC_Utils/LinearAlgebra.irp.f#L128>`_
   Compute C_new=C_old.S^-1/2 orthogonalization.
   .br
   overlap : overlap matrix
@@ -847,19 +677,6 @@ h_apply_mrcepa_pt2_slave_tcp
   .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
 
@@ -890,10 +707,6 @@ h_apply_mrcepa_pt2_slave_tcp
   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.
 
@@ -914,14 +727,6 @@ h_apply_mrcepa_pt2_slave_tcp
   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
 
@@ -930,10 +735,6 @@ h_apply_mrcepa_pt2_slave_tcp
   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
@@ -961,6 +762,10 @@ h_apply_mrcepa_pt2_slave_tcp
   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
 
@@ -969,15 +774,7 @@ h_apply_mrcepa_pt2_slave_tcp
   Undocumented
 
 
-`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>`_
+`set_generators_bitmasks_as_holes_and_particles <http://github.com/LCPQ/quantum_package/tree/master/plugins/MRCC_Utils/mrcc_general.irp.f#L59>`_
   Undocumented
 
 
@@ -993,7 +790,7 @@ h_apply_mrcepa_pt2_slave_tcp
   to be in integer*8 format
 
 
-`set_zero_extra_diag <http://github.com/LCPQ/quantum_package/tree/master/plugins/MRCC_Utils/LinearAlgebra.irp.f#L585>`_
+`set_zero_extra_diag <http://github.com/LCPQ/quantum_package/tree/master/plugins/MRCC_Utils/LinearAlgebra.irp.f#L548>`_
   Undocumented
 
 
@@ -1003,14 +800,6 @@ h_apply_mrcepa_pt2_slave_tcp
   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
 
@@ -1028,37 +817,18 @@ h_apply_mrcepa_pt2_slave_tcp
   .br
 
 
-`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>`_
+`u_dot_u <http://github.com/LCPQ/quantum_package/tree/master/plugins/MRCC_Utils/util.irp.f#L326>`_
   Compute <u|u>
 
 
-`u_dot_v <http://github.com/LCPQ/quantum_package/tree/master/plugins/MRCC_Utils/util.irp.f#L320>`_
+`u_dot_v <http://github.com/LCPQ/quantum_package/tree/master/plugins/MRCC_Utils/util.irp.f#L299>`_
   Compute <u|v>
 
 
-`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>`_
+`wall_time <http://github.com/LCPQ/quantum_package/tree/master/plugins/MRCC_Utils/util.irp.f#L268>`_
   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#L264>`_
+`write_git_log <http://github.com/LCPQ/quantum_package/tree/master/plugins/MRCC_Utils/util.irp.f#L243>`_
   Write the last git commit in file iunit.
 

plugins/MRCC_Utils/amplitudes.irp.f

@@ -1,238 +0,0 @@
- 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,6 +94,7 @@ 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
@@ -143,6 +144,7 @@ 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),                                            &
@@ -207,6 +209,19 @@ 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))
@@ -315,10 +330,20 @@ 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, &
@@ -326,9 +351,6 @@ 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)//' ================ ================'
@@ -338,6 +360,7 @@ 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,                                                          &
@@ -550,7 +573,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_diag)
+  double precision, intent(out)  :: energies(N_st)
   double precision, allocatable  :: H_jj(:), S2_jj(:)
   
   double precision               :: diag_h_mat_elem
@@ -623,12 +646,14 @@ 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(:,:), S(:,:), overlap(:,:)
+  double precision, allocatable  :: W(:,:),  U(:,:), R(:,:), S(:,:)
   double precision, allocatable  :: y(:,:), h(:,:), lambda(:), s2(:)
   double precision, allocatable  :: c(:), s_(:,:), s_tmp(:,:)
   double precision               :: diag_h_mat_elem
@@ -636,14 +661,12 @@ 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, itermax
+  integer                        :: shift, shift2
   include 'constants.include.F'
   
-  !DIR$ ATTRIBUTES ALIGN : $IRP_ALIGN :: U, W, S, y, h, lambda
-  if (N_st_diag*3 > sze) then
-     print *,  'error in Davidson :'
-     print *,  'Increase n_det_max_jacobi to ', N_st_diag*3
-     stop -1
+  !DIR$ ATTRIBUTES ALIGN : $IRP_ALIGN :: U, W, R, S, y, h, lambda
+  if (N_st_diag > sze) then
+     stop 'error in Davidson : N_st_diag > sze'
   endif
 
   PROVIDE nuclear_repulsion
@@ -668,7 +691,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 = '===== '
@@ -680,29 +703,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)
 
-  itermax = min(davidson_sze_max, sze/N_st_diag)
+  double precision :: delta
+
+  if (s2_eig) then
+    delta = 1.d0
+  else
+    delta = 0.d0
+  endif
+
   allocate(                                                          &
-      W(sze_8,N_st_diag*itermax),                                    &
-      U(sze_8,N_st_diag*itermax),                                    &
-      S(sze_8,N_st_diag*itermax),                                    &
-      h(N_st_diag*itermax,N_st_diag*itermax),                        &
-      y(N_st_diag*itermax,N_st_diag*itermax),                        &
-      s_(N_st_diag*itermax,N_st_diag*itermax),                       &
-      s_tmp(N_st_diag*itermax,N_st_diag*itermax),                    &
+      kl_pairs(2,N_st_diag*(N_st_diag+1)/2),                         &
+      W(sze_8,N_st_diag*davidson_sze_max),                           &
+      U(sze_8,N_st_diag*davidson_sze_max),                           &
+      R(sze_8,N_st_diag),                                            &
+      S(sze_8,N_st_diag*davidson_sze_max),                           &
+      h(N_st_diag*davidson_sze_max,N_st_diag*davidson_sze_max),      &
+      y(N_st_diag*davidson_sze_max,N_st_diag*davidson_sze_max),      &
+      s_(N_st_diag*davidson_sze_max,N_st_diag*davidson_sze_max),     &
+      s_tmp(N_st_diag*davidson_sze_max,N_st_diag*davidson_sze_max),  &
       residual_norm(N_st_diag),                                      &
-      c(N_st_diag*itermax),                                          &
-      s2(N_st_diag*itermax),                                         &
-      overlap(N_st_diag*itermax,N_st_diag*itermax),                  &
-      lambda(N_st_diag*itermax))
-
-  h  = 0.d0
-  s_ = 0.d0
-  s_tmp = 0.d0
-  U = 0.d0
-  W = 0.d0
-  S = 0.d0
-  y = 0.d0
-
+      overlap(N_st_diag,N_st_diag),                                  &
+      c(N_st_diag*davidson_sze_max),                                 &
+      s2(N_st_diag*davidson_sze_max),                                &
+      lambda(N_st_diag*davidson_sze_max))
   
   ASSERT (N_st > 0)
   ASSERT (N_st_diag >= N_st)
@@ -715,19 +738,25 @@ subroutine davidson_diag_hjj_sjj_mrcc(dets_in,u_in,H_jj,S2_jj,energies,dim_in,sz
   
   converged = .False.
   
-  double precision               :: r1, r2
+  do k=1,N_st
+    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)
-        r1 = dsqrt(-2.d0*dlog(r1))
-        r2 = dtwo_pi*r2
-        u_in(i,k) = r1*dcos(r2)
+        u_in(i,k) = dsqrt(-2.d0*dlog(r1))*dcos(dtwo_pi*r2)
       enddo
-  enddo
-  do k=1,N_st_diag
-      call normalize(u_in(1,k),sze)
+    
+    ! Gram-Schmidt
+    ! ------------
+    call dgemv('T',sze,k-1,1.d0,u_in,size(u_in,1),                   &
+        u_in(1,k),1,0.d0,c,1)
+    call dgemv('N',sze,k-1,-1.d0,u_in,size(u_in,1),                  &
+        c,1,1.d0,u_in(1,k),1)
+    call normalize(u_in(1,k),sze)
   enddo
 
   
@@ -744,11 +773,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)
       
@@ -757,52 +786,26 @@ subroutine davidson_diag_hjj_sjj_mrcc(dets_in,u_in,H_jj,S2_jj,energies,dim_in,sz
       ! -------------------------------------------
 
 
-      call dgemm('T','N', shift2, shift2, sze,            &
-          1.d0, U, size(U,1), W, size(W,1),                &
-          0.d0, h, size(h,1))
-
-      call dgemm('T','N', shift2, shift2, sze,            &
-          1.d0, U, size(U,1), S, size(S,1),                &
-          0.d0, s_, size(s_,1))
-
-!      ! Diagonalize S^2
-!      ! ---------------
-!
-!      call lapack_diag(s2,y,s_,size(s_,1),shift2)
-!
-!      ! Rotate H in the basis of eigenfunctions of s2
-!      ! ---------------------------------------------
-!
-!      call dgemm('N','N',shift2,shift2,shift2,                       &
-!          1.d0, h, size(h,1), y, size(y,1),                          &
-!          0.d0, s_tmp, size(s_tmp,1))
-!      
-!      call dgemm('T','N',shift2,shift2,shift2,                       &
-!          1.d0, y, size(y,1), s_tmp, size(s_tmp,1),                  &
-!          0.d0, h, size(h,1))
-!
-!      ! Damp interaction between different spin states
-!      ! ------------------------------------------------
-!
-!      do k=1,shift2
-!        do l=1,shift2
-!          if (dabs(s2(k) - s2(l)) > 1.d0) then
-!            h(k,l) = h(k,l)*(max(0.d0,1.d0 - dabs(s2(k) - s2(l))))
-!          endif
+!      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
-!
-!      ! 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
       ! -------------
@@ -824,81 +827,46 @@ subroutine davidson_diag_hjj_sjj_mrcc(dets_in,u_in,H_jj,S2_jj,energies,dim_in,sz
       enddo
 
       if (s2_eig) then
-          logical :: state_ok(N_st_diag*davidson_sze_max)
-          do k=1,shift2
-            state_ok(k) = (dabs(s2(k)-expected_s2) < 0.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
+        logical :: state_ok(N_st_diag*davidson_sze_max)
         do k=1,shift2
-          do i=1,shift2
-            overlap(k,i) = dabs(y(k,i))
-          enddo
+          state_ok(k) = (dabs(s2(k)-expected_s2) < 0.3d0)
         enddo
-        do k=1,N_st
-          cmax = -1.d0
-          do i=1,N_st
-            if (overlap(i,k) > cmax) then
-              cmax = overlap(i,k) 
-              order(k) = i
-            endif
-          enddo
-          do i=1,shift2
-            overlap(order(k),i) = -1.d0
-          enddo
-        enddo
-        overlap = y
-        do k=1,N_st
-          l = order(k)
-          if (k /= l) then
-            y(1:shift2,k) = overlap(1:shift2,l)
+        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
-        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,                    &
@@ -909,64 +877,101 @@ 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
-!        if (state_ok(k)) then
-          do i=1,sze
-            U(i,shift2+k) = (lambda(k) * U(i,shift2+k) - W(i,shift2+k) )      &
-                * (1.d0 + s2(k) * U(i,shift2+k) - S(i,shift2+k) - S_z2_Sz &
-              )/max(H_jj(i) - lambda (k),1.d-2)
-          enddo
-!        else
-!          ! Randomize components with bad <S2>
-!            do i=1,sze-2,2
-!              call random_number(r1)
-!              call random_number(r2)
-!              r1 = dsqrt(-2.d0*dlog(r1))
-!              r2 = dtwo_pi*r2
-!              U(i,shift2+k) = r1*dcos(r2)
-!              U(i+1,shift2+k) = r1*dsin(r2)
-!            enddo
-!            do i=sze-2+1,sze
-!              call random_number(r1)
-!              call random_number(r2)
-!              r1 = dsqrt(-2.d0*dlog(r1))
-!              r2 = dtwo_pi*r2
-!              U(i,shift2+k) = r1*dcos(r2)
-!            enddo
-!        endif
-
+        do i=1,sze
+          R(i,k) = (lambda(k) * U(i,shift2+k) - W(i,shift2+k) ) &
+            * (1.d0 + s2(k) * U(i,shift2+k) - S(i,shift2+k) - S_z2_Sz)
+        enddo
         if (k <= N_st) then
-          residual_norm(k) = u_dot_u(U(1,shift2+k),sze)
+          residual_norm(k) = u_dot_u(R(1,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:3,1:N_st)
+      write(iunit,'(X,I3,X,100(X,F16.10,X,F11.6,X,E11.3))')  iter, to_print(:,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
     ! -----------
     
-    call dgemm('N','N', sze, N_st_diag, shift2,                    &
-        1.d0, U, size(U,1), y, size(y,1), 0.d0, u_in, size(u_in,1))
+    do k=1,N_st_diag
+      energies(k) = lambda(k)
+    enddo
 
-  enddo
+!    do k=1,N_st_diag
+!      do i=1,sze
+!        do l=1,iter*N_st_diag
+!            u_in(i,k) += U(i,l)*y(l,k)
+!          enddo
+!        enddo
+!      enddo
+!    enddo
+
+    call dgemm('N','N', sze, N_st_diag, N_st_diag*iter, 1.d0,      &
+        U, size(U,1), y, size(y,1), 0.d0, u_in, size(u_in,1))
 
-  do k=1,N_st_diag
-    energies(k) = lambda(k)
   enddo
 
   write_buffer = '===== '
@@ -978,9 +983,10 @@ 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,                                                    &
-      c, S,                                                       &
+      R, c, S,                                                       &
       h,                                                             &
       y, s_, s_tmp,                                                  &
       lambda                                                         &
@@ -1042,16 +1048,15 @@ 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, delta_ij_s2,istate_in)
+      !$OMP  N_det_ref, idx_ref, N_det_non_ref, idx_non_ref, delta_ij,istate_in)
   allocate(vt(N_st_8,n),st(N_st_8,n))
   Vt = 0.d0
   St = 0.d0
 
-  !$OMP DO SCHEDULE(guided)
+  !$OMP DO SCHEDULE(dynamic)
   do sh=1,shortcut(0,1)
     do sh2=sh,shortcut(0,1)
       exa = 0
@@ -1093,8 +1098,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
-  !$OMP DO SCHEDULE(guided)
+  !$OMP END DO NOWAIT
+  !$OMP DO SCHEDULE(dynamic)
   do sh=1,shortcut(0,2)
     do i=shortcut(sh,2),shortcut(sh+1,2)-1
       org_i = sort_idx(i,2)
@@ -1117,7 +1122,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
+  !$OMP END DO NOWAIT
 
 ! --------------------------
 ! Begin Specific to dressing
@@ -1131,8 +1136,6 @@ 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

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

plugins/MRCC_Utils/mrcc_utils.irp.f

@@ -33,7 +33,6 @@ 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
@@ -76,6 +75,19 @@ 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
              
 
@@ -127,6 +139,7 @@ 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)
@@ -135,34 +148,17 @@ END_PROVIDER
    
    if (diag_algorithm == "Davidson") then
      
-     allocate (eigenvectors(size(CI_eigenvectors_dressed,1),size(CI_eigenvectors_dressed,2)), &
-     eigenvalues(size(CI_electronic_energy_dressed,1)))
-     do j=1,min(N_states,N_det)
-       do i=1,N_det
-         eigenvectors(i,j) = psi_coef(i,j)
-       enddo
-     enddo
-     do mrcc_state=1,N_states
-      do j=mrcc_state,min(N_states,N_det)
-        do i=1,N_det
-          eigenvectors(i,j) = psi_coef(i,j)
-        enddo
-      enddo
-      call davidson_diag_mrcc_HS2(psi_det,eigenvectors,&
-            size(eigenvectors,1), &
-            eigenvalues,N_det,N_states,N_states_diag,N_int, &
-            output_determinants,mrcc_state)
-      CI_eigenvectors_dressed(1:N_det,mrcc_state) = eigenvectors(1:N_det,mrcc_state)
-      CI_electronic_energy_dressed(mrcc_state) = eigenvalues(mrcc_state)
-   enddo
-   do k=N_states+1,N_states_diag
-     CI_eigenvectors_dressed(1:N_det,k) = eigenvectors(1:N_det,k)
-     CI_electronic_energy_dressed(k) = eigenvalues(k)
-   enddo
-   call u_0_S2_u_0(CI_eigenvectors_s2_dressed,CI_eigenvectors_dressed,N_det,psi_det,N_int,&
-          N_states_diag,size(CI_eigenvectors_dressed,1))
+!     call davidson_diag_mrcc(psi_det,CI_eigenvectors_dressed,CI_electronic_energy_dressed,&
+!          size(CI_eigenvectors_dressed,1),N_det,N_states,N_states_diag,N_int,output_determinants,mrcc_state)
+
+     call davidson_diag_mrcc_HS2(psi_det,CI_eigenvectors_dressed,&
+          size(CI_eigenvectors_dressed,1), &
+          CI_electronic_energy_dressed,N_det,N_states,N_states_diag,N_int, &
+          output_determinants,mrcc_state)
+
+     call u_0_S2_u_0(CI_eigenvectors_s2_dressed,CI_eigenvectors_dressed,N_det,psi_det,N_int,&
+         N_states_diag,size(CI_eigenvectors_dressed,1))
 
-   deallocate (eigenvectors,eigenvalues)
      
    else if (diag_algorithm == "Lapack") then
      
@@ -618,52 +614,207 @@ END_PROVIDER
 END_PROVIDER
 
 
- BEGIN_PROVIDER [ double precision, dIj_unique, (hh_nex, N_states) ]
+ BEGIN_PROVIDER [ double precision, dIj_unique, (hh_shortcut(hh_shortcut(0)+1)-1, 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, a_col, at_row
+  integer                        :: i, j, k, s, II, pp, ppp, hh, ind, wk, nex, a_col, at_row
   integer, external              :: searchDet, unsortedSearchDet
   integer(bit_kind)              :: myDet(N_int, 2), myMask(N_int, 2)
-  integer                        :: N, INFO, r1, r2
-  double precision , allocatable :: AtB(:), x(:), x_new(:), A_val_mwen(:,:), t(:)
-  double precision               :: norm, cx, res
-  integer, allocatable           :: lref(:), A_ind_mwen(:)
+  integer                        :: N, INFO, AtA_size, r1, r2
+  double precision , allocatable :: AtB(:), AtA_val(:), A_val(:,:), x(:), x_new(:), A_val_mwen(:)
+  double precision               :: t, norm, cx, res
+  integer, allocatable           :: A_ind(:,:), lref(:), AtA_ind(:), A_ind_mwen(:), col_shortcut(:), N_col(:)
   double precision               :: phase
   
   
-  double precision, allocatable :: rho_mrcc_init(:)
-  integer                        :: a_coll, at_roww
+  integer, allocatable :: pathTo(:), active_hh_idx(:), active_pp_idx(:)
+  logical, allocatable :: active(:)
+  double precision, allocatable :: rho_mrcc_init(:,:)
+  integer :: nactive
   
-  print *, "TI", hh_nex, N_det_non_ref
+  nex = hh_shortcut(hh_shortcut(0)+1)-1
+  print *, "TI", nex, N_det_non_ref
   
-  allocate(rho_mrcc_init(N_det_non_ref))
-  allocate(x_new(hh_nex))
-  allocate(x(hh_nex), AtB(hh_nex))
+  allocate(pathTo(N_det_non_ref), active(nex))
+  allocate(active_pp_idx(nex), active_hh_idx(nex))
+  allocate(rho_mrcc_init(N_det_non_ref, N_states))
   
-  do s=1,N_states
+  pathTo = 0
+  active = .false.
+  nactive = 0
   
-    AtB(:) = 0.d0
-    !$OMP PARALLEL default(none) shared(k, psi_non_ref_coef, active_excitation_to_determinants_idx,&
-        !$OMP   active_excitation_to_determinants_val, N_det_ref, hh_nex, N_det_non_ref)          &
-        !$OMP private(at_row, a_col, i, j, r1, r2, wk, A_ind_mwen, A_val_mwen, a_coll, at_roww)&
-        !$OMP shared(N_states,mrcc_col_shortcut, mrcc_N_col, AtB, mrcc_AtA_val, mrcc_AtA_ind, s, n_exc_active, active_pp_idx)
   
-    !$OMP DO schedule(dynamic, 100)
-    do at_roww = 1, n_exc_active ! hh_nex
-      at_row = active_pp_idx(at_roww)
-      do i=1,active_excitation_to_determinants_idx(0,at_roww)
-          AtB(at_row) = AtB(at_row) + psi_non_ref_coef(active_excitation_to_determinants_idx(i, at_roww), s) * active_excitation_to_determinants_val(s,i, at_roww)
+  do hh = 1, hh_shortcut(0)
+    do pp = hh_shortcut(hh), hh_shortcut(hh+1)-1
+      do II = 1, N_det_ref
+        call apply_hole_local(psi_ref(1,1,II), hh_exists(1, hh), myMask, ok, N_int)
+        if(.not. ok) cycle
+        call apply_particle_local(myMask, pp_exists(1, pp), myDet, ok, N_int)
+        if(.not. ok) cycle
+        ind = searchDet(psi_non_ref_sorted(1,1,1), myDet(1,1), N_det_non_ref, N_int)
+        if(ind == -1) cycle
+        ind = psi_non_ref_sorted_idx(ind)
+        if(pathTo(ind) == 0) then
+          pathTo(ind) = pp
+        else
+          active(pp) = .true.
+          active(pathTo(ind)) = .true.
+        end if
       end do
     end do
-    !$OMP 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
     
-    X(:) = 0d0
+    
+    print *,  'Done building A_val, A_ind'
+    
+    AtA_size = 0
+    col_shortcut = 0
+    N_col = 0
+    integer                        :: a_coll, at_roww
     
     
-    do a_coll = 1, n_exc_active
+    !$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
+      at_row = active_pp_idx(at_roww)
+      wk = 0
+      if(mod(at_roww, 100) == 0) print *, "AtA", at_row, "/", nex
+      do i=1,A_ind(0,at_roww)
+        j = active_pp_idx(i)
+        AtB(at_row) = AtB(at_row) + psi_non_ref_coef(A_ind(i, at_roww), s) * A_val(i, at_roww)
+      end do
+      
+      do a_coll = 1, nactive
+        a_col = active_pp_idx(a_coll)
+        t = 0d0
+        r1 = 1
+        r2 = 1
+        do while ((A_ind(r1, at_roww) /= 0).and.(A_ind(r2, a_coll) /= 0))
+          if(A_ind(r1, at_roww) > A_ind(r2, a_coll)) then
+            r2 = r2+1
+          else if(A_ind(r1, at_roww) < A_ind(r2, a_coll)) then
+            r1 = r1+1
+          else
+            t = t - A_val(r1, at_roww) * A_val(r2, a_coll)
+            r1 = r1+1
+            r2 = r2+1
+          end if
+        end do
+        
+        if(a_col == at_row) then
+          t = t + 1.d0
+        end if
+        if(t /= 0.d0) then
+          wk += 1
+          A_ind_mwen(wk) = a_col
+          A_val_mwen(wk) = t
+        end if
+      end do
+      
+      if(wk /= 0) then
+        !$OMP CRITICAL
+        col_shortcut(at_roww) = AtA_size+1
+        N_col(at_roww) = wk
+        if (AtA_size+wk > size(AtA_ind,1)) then
+          print *, AtA_size+wk , size(AtA_ind,1)
+          stop 'too small'
+        endif
+        do i=1,wk
+          AtA_ind(AtA_size+i) = A_ind_mwen(i)
+          AtA_val(AtA_size+i) = A_val_mwen(i)
+        enddo
+        AtA_size += wk
+        !$OMP END CRITICAL
+      end if
+    end do
+    !$OMP END DO NOWAIT
+    deallocate (A_ind_mwen, A_val_mwen)
+    !$OMP END PARALLEL
+    
+    print *, "ATA SIZE", ata_size
+    x = 0d0
+    
+    
+    do a_coll = 1, nactive
       a_col = active_pp_idx(a_coll)
       X(a_col) = AtB(a_col)
     end do
@@ -671,11 +822,12 @@ 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(is_active_exc(pp)) cycle
+        if(active(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
@@ -685,74 +837,78 @@ 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 < 0.d0) lref(II) = -ind
+          if(phase < 0d0) lref(II) = -ind
         end do
-        X(pp) =  AtB(pp) 
+        X(pp) =  AtB(pp) / X(pp)
         do II=1,N_det_ref
           if(lref(II) > 0) then
-            rho_mrcc_init(lref(II)) = psi_ref_coef(II,s) * X(pp)
+            rho_mrcc_init(lref(II),s) = psi_ref_coef(II,s) * X(pp)
           else if(lref(II) < 0) then
-            rho_mrcc_init(-lref(II)) = -psi_ref_coef(II,s) * X(pp)
+            rho_mrcc_init(-lref(II),s) = -psi_ref_coef(II,s) * X(pp)
           end if
         end do
       end do
     end do
-    deallocate(lref)
-
-    do i=1,N_det_non_ref
-      rho_mrcc(i,s) = rho_mrcc_init(i) 
-    enddo
+    !$OMP END PARALLEL DO
     
     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 a_coll = 1, n_exc_active
+      do i=1,N_det_non_ref
+        rho_mrcc(i,s) = rho_mrcc_init(i,s) ! 0d0
+      enddo
+      !$OMP END DO
+      
+      !$OMP DO
+      do a_coll = 1, nactive !: nex
         a_col = active_pp_idx(a_coll)
-        cx = 0.d0
-        do i=mrcc_col_shortcut(a_coll), mrcc_col_shortcut(a_coll) + mrcc_N_col(a_coll) - 1
-          cx = cx + x(mrcc_AtA_ind(i)) * mrcc_AtA_val(s,i)
+        cx = 0d0
+        do i=col_shortcut(a_coll), col_shortcut(a_coll) + N_col(a_coll) - 1
+          cx = cx + x(AtA_ind(i)) * AtA_val(i)
         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
       
-      if (res > resold) then
-        factor = factor * 0.5d0
+      res = 0.d0
+      
+      
+      if (res < resold) then
+        do a_coll=1,nactive ! nex
+          a_col = active_pp_idx(a_coll)
+          do j=1,N_det_non_ref
+            i = A_ind(j,a_coll)
+            if (i==0) exit
+            rho_mrcc(i,s) = rho_mrcc(i,s) + A_val(j,a_coll) * X_new(a_col)
+          enddo
+          res = res + (X_new(a_col) - X(a_col))*(X_new(a_col) - X(a_col))
+          X(a_col) = X_new(a_col)
+        end do
+        factor = 1.d0
+      else
+        factor = -factor * 0.5d0
       endif
       resold = res
       
-      if(iand(k, 4095) == 0) then
+      if(mod(k, 100) == 0) then
         print *, "res ", k, res
       end if
       
-      if(res < 1d-10) exit
+      if(res < 1d-9) 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
@@ -765,11 +921,122 @@ END_PROVIDER
     enddo
     ! Norm now contains the norm of Psi + A.X
     
-    print *, "norm : ", sqrt(norm)
-   enddo
+    print *, k, "res : ", res, "norm : ", sqrt(norm)
         
+!---------------
+! 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
@@ -777,16 +1044,12 @@ END_PROVIDER
          rho_mrcc(i,s) = 1.d-32
        endif
 
-       if (lambda_type == 2) then
-         f = 1.d0
-       else
-        ! f is such that f.\tilde{c_i} = c_i
-        f = psi_non_ref_coef(i,s) / rho_mrcc(i,s)
+       ! f is such that f.\tilde{c_i} = c_i
+       f = psi_non_ref_coef(i,s) / rho_mrcc(i,s)
 
-        ! Avoid numerical instabilities
-        f = min(f,2.d0)
-        f = max(f,-2.d0)
-      endif
+       ! Avoid numerical instabilities
+       f = min(f,2.d0)
+       f = max(f,-2.d0)
 
        norm = norm + f*f *rho_mrcc(i,s)*rho_mrcc(i,s)
        rho_mrcc(i,s) = f
@@ -807,9 +1070,6 @@ 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)
@@ -821,6 +1081,7 @@ 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
@@ -832,14 +1093,17 @@ 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
 
@@ -855,13 +1119,9 @@ 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 if(lambda_type == 1) then
+  else
     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
 
@@ -919,21 +1179,9 @@ end function
 
 
  BEGIN_PROVIDER [ integer*2, hh_exists, (4, N_hh_exists) ]
-&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 ]
+&BEGIN_PROVIDER [ integer*2, pp_exists, (4, N_pp_exists) ]
   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
@@ -999,7 +1247,6 @@ 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

@@ -1,101 +0,0 @@
-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

@@ -1,43 +0,0 @@
-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

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

plugins/MRPT/README.rst

@@ -1,14 +0,0 @@
-====
-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

@@ -1,38 +0,0 @@
-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

@@ -1,51 +0,0 @@
-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

@@ -1,7 +0,0 @@
-[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

@@ -1,187 +0,0 @@
-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

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

plugins/MRPT_Utils/README.rst

@@ -1,13 +0,0 @@
-==========
-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

@@ -1,708 +0,0 @@
-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

@@ -1,23 +0,0 @@
-! 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

@@ -1,210 +0,0 @@
- 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

@@ -1,35 +0,0 @@
-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

@@ -1,186 +0,0 @@
-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

@@ -1,367 +0,0 @@
-
- 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