Merge pull request #201 from scemama/master

DIIS in HF + Fixed FCI bugs (correlation_ratio)

.travis.yml

@@ -4,6 +4,8 @@
 #  - sudo apt-get install gfortran liblapack-dev gcc
 #  - sudo apt-get install graphviz
 
+dist: trusty
+
 sudo: false
 
 addons:
@@ -25,7 +27,7 @@ python:
     - "2.6"
 
 script: 
-  - ./configure  --production ./config/travis.cfg
+  - ./configure  ./config/travis.cfg
   - source ./quantum_package.rc ; qp_module.py install Full_CI Full_CI_ZMQ Hartree_Fock CAS_SD_ZMQ mrcepa0 All_singles
   - source ./quantum_package.rc ; ninja
   - source ./quantum_package.rc ; cd ocaml ; make ; cd -

config/gfortran_debug.cfg

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

config/ifort_mpi.cfg

@@ -0,0 +1,63 @@
+# Common flags
+##############
+#
+# -mkl=[parallel|sequential] : Use the MKL library
+# --ninja                 : Allow the utilisation of ninja. It is mandatory !
+# --align=32                 : Align all provided arrays on a 32-byte boundary
+#
+[COMMON]
+FC           : mpif90
+LAPACK_LIB   : -mkl=parallel
+IRPF90       : irpf90
+IRPF90_FLAGS : --ninja --align=32 -DMPI
+
+# 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
+####################
+#
+# -xHost                     : Compile a binary optimized for the current architecture
+# -O2                        : O3 not better than O2.
+# -ip                        : Inter-procedural optimizations
+# -ftz                       : Flushes denormal results to zero
+#
+[OPT]
+FCFLAGS  : -xAVX -O2 -ip -ftz -g -traceback
+
+# Profiling flags
+#################
+#
+[PROFILE]
+FC       : -p -g
+FCFLAGS  : -xSSE4.2 -O2 -ip -ftz
+
+# Debugging flags
+#################
+#
+# -traceback   : Activate backtrace on runtime
+# -fpe0        : All floating point exaceptions
+# -C           : Checks uninitialized variables,  array subscripts, etc...
+# -g           : Extra debugging information
+# -xSSE2       : Valgrind needs a very simple x86 executable
+#
+[DEBUG]
+FC      : -g -traceback
+FCFLAGS : -xSSE2 -C  -fpe0 
+IRPF90_FLAGS : --openmp
+
+# OpenMP flags
+#################
+#
+[OPENMP]
+FC           : -openmp
+IRPF90_FLAGS : --openmp
+

configure

@@ -2,7 +2,7 @@
 # -*- coding: utf-8 -*-
 """configure
 
-Usage: configure <config_file> (--production | --development)
+Usage: configure <config_file> 
 
 
 Options:
@@ -10,18 +10,10 @@ Options:
     config_file   A config file with all the information for compiling.
                   Example config_files are given in config/
 
-   --production   You can only compile **all** the modules with this flag,
-                  but it will compile lighting fast.
-
-   --development  this will create a build.ninja for each directory which 
-                  contains a binary. In a second step you may compile them
-                  individually if you like.
-
-
 Examples:
 
-    ./configure config/gfortran.cfg --production
-    ./configure config/ifort.cfg    --development
+    ./configure config/gfortran.cfg 
+    ./configure config/ifort.cfg    
 
 
 """
@@ -34,10 +26,7 @@ import sys
 
 from os.path import join
 
-if not any(i in ["--production", "--development"] for i in sys.argv):
-    sys.argv += ["--development"]
-
-if len(sys.argv) != 3:
+if len(sys.argv) != 2:
     print __doc__
     sys.exit()
 
@@ -528,7 +517,7 @@ def create_ninja_and_rc(l_installed):
     qp_create_ninja = os.path.join(QP_ROOT, "scripts", "compilation",
                                    "qp_create_ninja.py")
 
-    l = [qp_create_ninja, "create"] + sys.argv[1:]
+    l = [qp_create_ninja, "create", "--development"] + sys.argv[1:]
 
     try:
         with open('/dev/null', 'w') as dnull:

data/basis/v5z-bfd

@@ -862,7 +862,7 @@ S 9
   4 0.174186      0.435946
   5 0.312836      -0.008188
   6 0.561850      0.049509
-  7 9077      -0.114576
+  7 1.009077     -0.114576
   8 1.812290      -0.067207
   9 3.254852      0.017250
 S 1

data/basis/vdz-bfd

@@ -898,7 +898,7 @@ S 9
   4 0.174186      0.435946
   5 0.312836      -0.008188
   6 0.561850      0.049509
-  7 9077      -0.114576
+  7 1.009077     -0.114576
   8 1.812290      -0.067207
   9 3.254852      0.017250
 S 1

data/basis/vqz-bfd

@@ -688,7 +688,7 @@ S 9
   4 0.174186      0.435946
   5 0.312836      -0.008188
   6 0.561850      0.049509
-  7 9077      -0.114576
+  7 1.009077     -0.114576
   8 1.812290      -0.067207
   9 3.254852      0.017250
 S 1

data/basis/vtz-bfd

@@ -1150,7 +1150,7 @@ S 9
   4 0.174186      0.435946
   5 0.312836      -0.008188
   6 0.561850      0.049509
-  7 9077      -0.114576
+  7 1.009077     -0.114576
   8 1.812290      -0.067207
   9 3.254852      0.017250
 S 1

ocaml/Gamess.ml

@@ -0,0 +1,457 @@
+(** CONTRL *)
+type scftyp_t = RHF | ROHF | MCSCF | NONE
+let string_of_scftyp = function
+| RHF -> "RHF"
+| ROHF -> "ROHF"
+| MCSCF -> "MCSCF"
+| NONE  -> "NONE"
+
+type contrl =
+{ scftyp: scftyp_t ;
+  maxit: int;
+  ispher: int;
+  icharg: int;
+  mult: int;
+  mplevl: int;
+}
+
+let string_of_contrl c =
+  Printf.sprintf " $CONTRL
+   EXETYP=RUN COORD=UNIQUE  UNITS=ANGS
+   RUNTYP=ENERGY SCFTYP=%s CITYP=NONE
+   MAXIT=%d
+   ISPHER=%d
+   MULT=%d
+   ICHARG=%d
+   MPLEVL=%d
+ $END"
+ (string_of_scftyp c.scftyp)
+ c.maxit c.ispher c.mult c.icharg c.mplevl
+
+let make_contrl ?(maxit=100) ?(ispher=1) ?(mplevl=0) ~mult ~charge scftyp =
+  { scftyp ; maxit ; ispher ; mult ; icharg=charge ; mplevl }
+
+
+(** Vec *)
+type vec_t = 
+| Canonical of string
+| Natural of string
+
+let read_mos guide filename =
+  let text =
+    let ic = open_in filename in
+    let n = in_channel_length ic in
+    let s = Bytes.create n in
+    really_input ic s 0 n;
+    close_in ic;
+    s
+  in
+
+  let re_vec =
+    Str.regexp " \\$VEC *\n"
+  and re_natural =
+    Str.regexp guide
+  and re_end =
+    Str.regexp " \\$END *\n"
+  and re_eol =
+    Str.regexp "\n"
+  in
+  let i =
+    Str.search_forward re_natural text 0
+  in
+  let start =
+    Str.search_forward re_vec text i
+  in
+  let i =
+    Str.search_forward re_end text start
+  in
+  let finish =
+    Str.search_forward re_eol text i
+  in
+  String.sub text start (finish-start)
+  
+let read_until_found f tries =
+  let result = 
+    List.fold_left (fun accu x ->
+      match accu with
+      | Some mos -> Some mos
+      | None ->
+        begin 
+          try
+            Some (read_mos x f)
+          with Not_found ->
+            None
+        end
+        ) None tries 
+  in
+  match result with
+  | Some mos -> mos
+  | None -> raise Not_found
+
+let read_natural_mos f =
+  let tries = [
+    "--- NATURAL ORBITALS OF MCSCF ---" ;
+    "MP2 NATURAL ORBITALS" ]
+  in
+  read_until_found f tries
+  
+let read_canonical_mos f =
+  let tries = [
+    "--- OPTIMIZED MCSCF MO-S ---"  ;
+    "--- CLOSED SHELL ORBITALS ---" ;
+    "--- OPEN SHELL ORBITALS ---"
+    ]
+  in
+  read_until_found f tries
+  
+let string_of_vec = function
+| Natural filename -> read_natural_mos filename
+| Canonical filename -> read_canonical_mos filename
+
+(** GUESS *)
+type guess_t =
+| Huckel
+| Hcore 
+| Canonical of (int*string)
+| Natural   of (int*string)
+
+let guess_of_string s =
+  match String.lowercase s with
+  | "huckel" -> Huckel
+  | "hcore"  -> Hcore
+  | _ -> raise (Invalid_argument "Bad MO guess")
+
+let string_of_guess g =
+ [
+ " $GUESS\n" ; "  GUESS=" ; 
+ begin
+  match g with
+    | Hcore  -> "HCORE\n"
+    | Huckel -> "HUCKEL\n"
+    | Canonical (norb,_) | Natural (norb,_) -> Printf.sprintf "MOREAD\n  NORB=%d\n" norb
+ end
+ ; " $END" ;
+ match g with
+    | Hcore
+    | Huckel  -> ""
+    | Natural (_,filename)  -> "\n\n"^(string_of_vec (Natural filename))
+    | Canonical (_,filename) ->"\n\n"^(string_of_vec (Canonical filename))
+ ] |> String.concat ""
+
+
+(** BASIS *)
+let string_of_basis =
+  Printf.sprintf " $BASIS
+  GBASIS=%s
+ $END" 
+
+
+(** DATA *)
+type coord_t = 
+| Atom          of Element.t
+| Diatomic_homo of (Element.t*float)
+| Diatomic      of (Element.t*Element.t*float)
+| Xyz           of (Element.t*float*float*float) list
+
+
+type data_t =
+{ sym: Sym.t ;
+  title: string;
+  xyz: string;
+  nucl_charge: int;
+}
+
+let data_of_atom ele =
+  let atom =
+    Element.to_string ele
+  in
+  let charge =
+    Element.to_charge ele
+    |> Charge.to_int
+  in
+  { sym=Sym.D4h ;
+    title=Printf.sprintf "%s" atom ;
+    xyz=Printf.sprintf "%s  %d.0  0. 0. 0." atom charge ;
+    nucl_charge = charge
+  }
+
+let data_of_diatomic_homo ele r =
+  assert (r > 0.);
+  let atom =
+    Element.to_string ele
+  in
+  let charge =
+    Element.to_charge ele
+    |> Charge.to_int
+  in
+  { sym=Sym.D4h ;
+    title=Printf.sprintf "%s2" atom ;
+    xyz=Printf.sprintf "%s  %d.0  0. 0. %f" atom charge (-.r *. 0.5) ;
+    nucl_charge = 2*charge
+  }
+
+let data_of_diatomic ele1 ele2 r =
+  assert (r > 0.);
+  let atom1, atom2 =
+    Element.to_string ele1,
+    Element.to_string ele2
+  in
+  let charge1, charge2 =
+    Charge.to_int @@ Element.to_charge ele1,
+    Charge.to_int @@ Element.to_charge ele2
+  in
+  { sym=Sym.C4v ;
+    title=Printf.sprintf "%s%s" atom1 atom2 ;
+    xyz=Printf.sprintf "%s  %d.0  0. 0. 0.\n%s  %d.0  0. 0. %f"
+        atom1 charge1 atom2 charge2 r ;
+    nucl_charge = charge1 + charge2
+  }
+
+let data_of_xyz l =
+  { sym   = Sym.C1 ;
+    title = "..." ;
+    xyz   = String.concat "\n" (
+      List.map (fun (e,x,y,z) -> Printf.sprintf "%s %f  %f %f %f"
+      (Element.to_string e) (Element.to_charge e)
+      x y z) l ) ;
+    nucl_charge = List.fold_left (fun accu (e,_,_,_) -> 
+      accu + (int_of_float @@ Element.to_charge e) ) 0 l
+  }
+
+let make_data = function
+| Atom          ele -> data_of_atom ele
+| Diatomic_homo (ele,r) -> data_of_diatomic_homo ele r
+| Diatomic      (ele1,ele2,r) -> data_of_diatomic ele1 ele2 r
+| Xyz           l -> data_of_xyz l
+
+let string_of_data d =
+  String.concat "\n" [ " $DATA" ;
+    d.title ;
+    Sym.to_data d.sym ;
+  ]  ^ d.xyz ^ "\n $END"
+    
+
+(** GUGDM *)
+type gugdm2_t = int
+
+let string_of_gugdm2 = function
+| 1 -> ""
+| i when i<1 -> raise (Invalid_argument "Nstates must be > 0")
+| i ->
+  let s =
+    Array.make i "1."
+    |> Array.to_list
+    |> String.concat ","
+  in
+  Printf.sprintf "
+ $GUGDM2
+   WSTATE(1)=%s
+ $END
+" s
+
+
+type gugdia_t = 
+{ nstate : int ;
+  itermx : int ;
+}
+
+let string_of_gugdia g =
+  Printf.sprintf "
+ $GUGDIA
+  PRTTOL=0.0001
+  NSTATE=%d
+  ITERMX=%d
+ $END
+" g.nstate g.itermx
+
+
+let make_gugdia ?(itermx=500) nstate =
+  assert (nstate > 0);
+  assert (itermx > 1);
+  { nstate ; itermx }
+
+
+(** MCSCF *)
+type mcscf_t = FULLNR | SOSCF | FOCAS
+
+let string_of_mcscf m =
+  " $MCSCF\n" ^ 
+  begin
+   match m with
+   | FOCAS  -> "   FOCAS=.T.    SOSCF=.F.   FULLNR=.F."
+   | SOSCF  -> "   FOCAS=.F.    SOSCF=.T.   FULLNR=.F."
+   | FULLNR -> "   FOCAS=.F.    SOSCF=.F.   FULLNR=.T."
+  end ^ "
+   CISTEP=GUGA EKT=.F. QUAD=.F. JACOBI=.f.
+   MAXIT=1000
+ $END"
+
+
+type drt_t = 
+{ nmcc: int ;
+  ndoc: int ;
+  nalp: int ;
+  nval: int ;
+  istsym: int;
+}
+
+
+let make_drt ?(istsym=1) n_elec_alpha n_elec_beta n_e n_act =
+  let n_elec_tot =
+     n_elec_alpha + n_elec_beta
+  in
+  let nmcc =
+     (n_elec_tot - n_e)/2
+  in
+  let ndoc = 
+     n_elec_beta - nmcc
+  in 
+  let nalp =
+     (n_elec_alpha - nmcc - ndoc)
+  in
+  let nval =
+    n_act - ndoc - nalp
+  in
+  { nmcc ; ndoc ; nalp ; nval ; istsym }
+
+let string_of_drt drt sym =
+  Printf.sprintf " $DRT
+  NMCC=%d
+  NDOC=%d
+  NALP=%d
+  NVAL=%d
+  NEXT=0
+  ISTSYM=%d
+  FORS=.TRUE.
+  GROUP=C1
+  MXNINT= 600000
+  NPRT=2
+ $END"
+ drt.nmcc drt.ndoc drt.nalp drt.nval drt.istsym 
+
+(** MP2 *)
+let string_of_mp2 = " $MP2
+   MP2PRP=.TRUE.
+ $END"
+
+
+(** Computation *)
+type computation = HF | MP2 |  CAS of (int*int)
+
+type system =
+{ mult: int ; charge: int ; basis: string ; coord: coord_t }
+
+let n_elec system =
+  let data = 
+    make_data system.coord
+  in
+  data.nucl_charge - system.charge
+
+let n_elec_alpha_beta system =
+  let n = 
+    n_elec system 
+  and m = 
+    system.mult
+  in
+  let alpha = 
+    (n+m-1)/2
+  in
+  let beta = 
+    n - alpha
+  in
+  (alpha, beta)
+
+  
+let create_single_det_input ~mp2 ~guess ?(vecfile="") s =
+  let scftyp =
+    match s.mult with
+    | 1 -> RHF
+    | _ -> ROHF
+  and mult = s.mult
+  and charge = s.charge
+  and n_elec_alpha, _ = 
+    n_elec_alpha_beta s
+  and mplevl =
+    if mp2 then 2 else 0
+  in
+  [
+    make_contrl ~mult ~charge ~mplevl scftyp
+    |> string_of_contrl 
+  ;
+    begin
+      match vecfile with
+      | "" ->     string_of_guess guess
+      | vecfile -> string_of_guess (Canonical (n_elec_alpha, vecfile))
+    end
+  ;
+    string_of_basis s.basis
+  ;
+    if mp2 then
+      string_of_mp2
+    else
+      ""
+  ;
+    make_data s.coord
+    |> string_of_data
+  ] |> String.concat "\n\n"
+  
+
+let create_hf_input ~guess =
+  create_single_det_input ~mp2:false ~guess
+
+let create_mp2_input ~guess =
+  create_single_det_input ~mp2:true ~guess
+
+
+let create_cas_input ?(vecfile="") ~guess ~nstate s n_e n_a =
+  let scftyp = MCSCF
+  and mult = s.mult
+  and charge = s.charge
+  in
+  let n_elec_alpha, n_elec_beta = 
+    n_elec_alpha_beta s
+  in
+  let drt = 
+    make_drt n_elec_alpha n_elec_beta n_e n_a
+  in
+  let data = 
+    make_data s.coord
+  in
+  [
+    make_contrl ~mult ~charge scftyp
+    |> string_of_contrl 
+  ;
+    begin
+      match vecfile with
+      | "" ->     string_of_guess guess
+      | vecfile -> 
+          let norb =
+            drt.nmcc + drt.ndoc + drt.nval + drt.nalp
+          in
+          try
+            string_of_guess (Natural (norb, vecfile))
+          with Not_found ->
+            string_of_guess (Canonical (norb, vecfile))
+    end
+  ;
+    string_of_basis s.basis
+  ;
+    string_of_mcscf FULLNR
+  ;
+    string_of_drt drt data.sym
+  ;
+    make_gugdia nstate
+    |> string_of_gugdia  
+  ;
+    string_of_gugdm2 nstate
+  ;
+    string_of_data data
+  ] |> String.concat "\n\n"
+  
+
+let create_input ?(vecfile="") ?(guess=Huckel) ~system ~nstate = function
+| HF   -> create_hf_input ~vecfile ~guess system
+| MP2  -> create_mp2_input ~vecfile  ~guess system
+| CAS (n_e,n_a) -> create_cas_input ~vecfile ~nstate ~guess system n_e n_a 
+
+

ocaml/GaussianPrimitive.ml

@@ -1,5 +1,5 @@
-open Qptypes;;
-open Core.Std;;
+open Qptypes
+open Core.Std
 
 type t =
 { sym  : Symmetry.t ;
@@ -11,8 +11,7 @@ let to_string p =
   Printf.sprintf "(%s, %f)" 
    (Symmetry.to_string s)
    (AO_expo.to_float e)
-;;
+
   
 let of_sym_expo s e = 
   { sym=s ; expo=e}
-;;

ocaml/Gto.ml

@@ -10,17 +10,17 @@ type fmt =
 
 type t =
 { sym  : Symmetry.t ;
-  lc   : ((Primitive.t * AO_coef.t) list)
+  lc   : ((GaussianPrimitive.t * AO_coef.t) list)
 } with sexp
 
 
 let of_prim_coef_list pc =
   let (p,c) = List.hd_exn pc in
-  let sym = p.Primitive.sym in
+  let sym = p.GaussianPrimitive.sym in
   let rec check = function
   | [] -> `OK
   | (p,c)::tl -> 
-      if p.Primitive.sym <> sym then
+      if p.GaussianPrimitive.sym <> sym then
         `Failed
       else
         check tl
@@ -59,7 +59,7 @@ let read_one in_channel =
           let coef = String.tr ~target:'D' ~replacement:'e' coef
           in
           let p =
-            Primitive.of_sym_expo sym 
+            GaussianPrimitive.of_sym_expo sym 
               (AO_expo.of_float (Float.of_string expo) )
           and c = AO_coef.of_float (Float.of_string coef) in
           read_lines ( (p,c)::result) (i-1)
@@ -80,7 +80,7 @@ let to_string_gamess { sym = sym ; lc = lc } =
   let rec do_work accu i = function
   | [] -> List.rev accu
   | (p,c)::tail -> 
-    let p = AO_expo.to_float p.Primitive.expo
+    let p = AO_expo.to_float p.GaussianPrimitive.expo
     and c = AO_coef.to_float c
     in
     let result = 
@@ -100,7 +100,7 @@ let to_string_gaussian { sym = sym ; lc = lc } =
   let rec do_work accu i = function
   | [] -> List.rev accu
   | (p,c)::tail -> 
-    let p = AO_expo.to_float p.Primitive.expo
+    let p = AO_expo.to_float p.GaussianPrimitive.expo
     and c = AO_coef.to_float c
     in
     let result = 

ocaml/Gto.mli

@@ -6,12 +6,12 @@ type fmt =
 
 type t =
   { sym : Symmetry.t ;
-    lc  : (Primitive.t * Qptypes.AO_coef.t) list;
+    lc  : (GaussianPrimitive.t * Qptypes.AO_coef.t) list;
   } with sexp
 
-(** Create from a list of Primitive.t * Qptypes.AO_coef.t *)
+(** Create from a list of GaussianPrimitive.t * Qptypes.AO_coef.t *)
 val of_prim_coef_list :
-  (Primitive.t * Qptypes.AO_coef.t) list -> t
+  (GaussianPrimitive.t * Qptypes.AO_coef.t) list -> t
 
 (** Read from a file *)
 val read_one : in_channel -> t

ocaml/Input_ao_basis.ml

@@ -112,8 +112,8 @@ end = struct
         let s = Symmetry.Xyz.to_symmetry b.ao_power.(i) in
         let ao_prim_num = AO_prim_number.to_int b.ao_prim_num.(i) in
         let prims = List.init ao_prim_num ~f:(fun j ->
-          let prim = { Primitive.sym  = s ;
-                       Primitive.expo = b.ao_expo.(ao_num*j+i)
+          let prim = { GaussianPrimitive.sym  = s ;
+                       GaussianPrimitive.expo = b.ao_expo.(ao_num*j+i)
                      }
           in
           let coef = b.ao_coef.(ao_num*j+i) in

ocaml/Input_mo_basis.ml

@@ -1,32 +1,32 @@
-open Qptypes;;
-open Qputils;;
-open Core.Std;;
+open Qptypes
+open Qputils
+open Core.Std
 
 type t_mo = 
-  { mo_tot_num      : MO_number.t ;
-    mo_label        : MO_label.t;
-    mo_occ          : MO_occ.t array;
-    mo_coef         : (MO_coef.t array) array;
-    ao_md5          : MD5.t;
-  } with sexp
+    { mo_tot_num      : MO_number.t ;
+      mo_label        : MO_label.t;
+      mo_class        : MO_class.t array;
+      mo_occ          : MO_occ.t array;
+      mo_coef         : (MO_coef.t array) array;
+      ao_md5          : MD5.t;
+    } with sexp
 
 module Mo_basis : sig
-  type t =  t_mo
+  type t = t_mo
   val read : unit -> t option
   val to_string : t -> string
   val to_rst : t -> Rst_string.t
 end = struct
   type t = t_mo
-
-  let get_default = Qpackage.get_ezfio_default "mo_basis";;
+  let get_default = Qpackage.get_ezfio_default "mo_basis"
 
   let read_mo_label () = 
     if not (Ezfio.has_mo_basis_mo_label ()) then
-       Ezfio.set_mo_basis_mo_label "None"
+      Ezfio.set_mo_basis_mo_label "None"
     ;
     Ezfio.get_mo_basis_mo_label ()
     |> MO_label.of_string
-  ;;
+
 
   let read_ao_md5 () = 
     let ao_md5 = 
@@ -46,12 +46,28 @@ end = struct
     if (ao_md5 <> result) then
       failwith "The current MOs don't correspond to the current AOs.";
     result
-  ;;
+
 
   let read_mo_tot_num () =
     Ezfio.get_mo_basis_mo_tot_num ()
     |> MO_number.of_int
-  ;;
+
+
+  let read_mo_class () =
+    if not (Ezfio.has_mo_basis_mo_class ()) then
+      begin
+        let mo_tot_num = MO_number.to_int (read_mo_tot_num ()) in
+        let data = 
+          Array.init mo_tot_num ~f:(fun _ -> MO_class.(to_string (Active [])))
+          |> Array.to_list
+        in
+        Ezfio.ezfio_array_of_list ~rank:1 
+          ~dim:[| mo_tot_num |] ~data:data
+        |> Ezfio.set_mo_basis_mo_class
+      end;
+    Ezfio.flattened_ezfio (Ezfio.get_mo_basis_mo_class () )
+    |> Array.map ~f:MO_class.of_string
+
 
   let read_mo_occ () =
     if not (Ezfio.has_mo_basis_mo_label ()) then
@@ -60,41 +76,42 @@ end = struct
         and elec_beta_num = Ezfio.get_electrons_elec_beta_num ()
         and mo_tot_num = MO_number.to_int (read_mo_tot_num ()) in
         let data = Array.init mo_tot_num ~f:(fun i ->
-          if (i<elec_beta_num) then 2.
-          else if (i < elec_alpha_num) then 1.
-          else 0.) |> Array.to_list in
+            if (i<elec_beta_num) then 2.
+            else if (i < elec_alpha_num) then 1.
+            else 0.) |> Array.to_list in
         Ezfio.ezfio_array_of_list ~rank:1 
           ~dim:[| mo_tot_num |] ~data:data
         |> Ezfio.set_mo_basis_mo_occ
       end;
     Ezfio.flattened_ezfio (Ezfio.get_mo_basis_mo_occ () )
     |> Array.map ~f:MO_occ.of_float
-  ;;
+
 
   let read_mo_coef () =
     let a = Ezfio.get_mo_basis_mo_coef () 
-    |> Ezfio.flattened_ezfio
-    |> Array.map ~f:MO_coef.of_float
+            |> Ezfio.flattened_ezfio
+            |> Array.map ~f:MO_coef.of_float
     in
     let mo_tot_num = read_mo_tot_num () |> MO_number.to_int in
     let ao_num = (Array.length a)/mo_tot_num in
     Array.init mo_tot_num ~f:(fun j ->
-      Array.sub ~pos:(j*ao_num) ~len:(ao_num) a
-    )
-  ;;
+        Array.sub ~pos:(j*ao_num) ~len:(ao_num) a
+      )
+
 
   let read () =
     if (Ezfio.has_mo_basis_mo_tot_num ()) then
       Some
-      { mo_tot_num      = read_mo_tot_num ();
-        mo_label        = read_mo_label () ;
-        mo_occ          = read_mo_occ ();
-        mo_coef         = read_mo_coef ();
-        ao_md5          = read_ao_md5 ();
-      }
+        { mo_tot_num      = read_mo_tot_num ();
+          mo_label        = read_mo_label () ;
+          mo_class        = read_mo_class ();
+          mo_occ          = read_mo_occ ();
+          mo_coef         = read_mo_coef ();
+          ao_md5          = read_ao_md5 ();
+        }
     else
       None
-  ;;
+
 
   let mo_coef_to_string mo_coef =
     let ao_num = Array.length mo_coef.(0) 
@@ -102,53 +119,53 @@ end = struct
     let rec print_five imin imax =
       match (imax-imin+1) with 
       | 1 ->
-          let header = [ Printf.sprintf "  #%15d" (imin+1) ; ] in
-          let new_lines = 
-            List.init ao_num ~f:(fun i ->
+        let header = [ Printf.sprintf "  #%15d" (imin+1) ; ] in
+        let new_lines = 
+          List.init ao_num ~f:(fun i ->
               Printf.sprintf "  %3d %15.10f " (i+1)
-              (MO_coef.to_float mo_coef.(imin  ).(i)) )
-          in header @ new_lines
+                (MO_coef.to_float mo_coef.(imin  ).(i)) )
+        in header @ new_lines
       | 2 ->
-          let header = [ Printf.sprintf "  #%15d %15d" (imin+1) (imin+2) ; ] in
-          let new_lines = 
-            List.init ao_num ~f:(fun i ->
+        let header = [ Printf.sprintf "  #%15d %15d" (imin+1) (imin+2) ; ] in
+        let new_lines = 
+          List.init ao_num ~f:(fun i ->
               Printf.sprintf "  %3d %15.10f %15.10f" (i+1)
-              (MO_coef.to_float mo_coef.(imin  ).(i))
-              (MO_coef.to_float mo_coef.(imin+1).(i)) )
-          in header @ new_lines
+                (MO_coef.to_float mo_coef.(imin  ).(i))
+                (MO_coef.to_float mo_coef.(imin+1).(i)) )
+        in header @ new_lines
       | 3 ->
-          let header = [ Printf.sprintf "  #%15d %15d %15d"
-              (imin+1) (imin+2) (imin+3); ] in
-          let new_lines = 
-            List.init ao_num ~f:(fun i ->
+        let header = [ Printf.sprintf "  #%15d %15d %15d"
+                         (imin+1) (imin+2) (imin+3); ] in
+        let new_lines = 
+          List.init ao_num ~f:(fun i ->
               Printf.sprintf "  %3d %15.10f %15.10f %15.10f" (i+1)
-              (MO_coef.to_float mo_coef.(imin  ).(i))
-              (MO_coef.to_float mo_coef.(imin+1).(i))
-              (MO_coef.to_float mo_coef.(imin+2).(i)) )
-          in header @ new_lines
+                (MO_coef.to_float mo_coef.(imin  ).(i))
+                (MO_coef.to_float mo_coef.(imin+1).(i))
+                (MO_coef.to_float mo_coef.(imin+2).(i)) )
+        in header @ new_lines
       | 4 ->
-          let header = [ Printf.sprintf "  #%15d %15d %15d %15d"
-              (imin+1) (imin+2) (imin+3) (imin+4) ; ] in
-          let new_lines = 
-            List.init ao_num ~f:(fun i ->
+        let header = [ Printf.sprintf "  #%15d %15d %15d %15d"
+                         (imin+1) (imin+2) (imin+3) (imin+4) ; ] in
+        let new_lines = 
+          List.init ao_num ~f:(fun i ->
               Printf.sprintf "  %3d %15.10f %15.10f %15.10f %15.10f" (i+1)
-              (MO_coef.to_float mo_coef.(imin  ).(i))
-              (MO_coef.to_float mo_coef.(imin+1).(i))
-              (MO_coef.to_float mo_coef.(imin+2).(i))
-              (MO_coef.to_float mo_coef.(imin+3).(i)) )
-          in header @ new_lines
+                (MO_coef.to_float mo_coef.(imin  ).(i))
+                (MO_coef.to_float mo_coef.(imin+1).(i))
+                (MO_coef.to_float mo_coef.(imin+2).(i))
+                (MO_coef.to_float mo_coef.(imin+3).(i)) )
+        in header @ new_lines
       | 5 ->
-          let header = [ Printf.sprintf "  #%15d %15d %15d %15d %15d"
-              (imin+1) (imin+2) (imin+3) (imin+4) (imin+5) ; ] in
-          let new_lines = 
-            List.init ao_num ~f:(fun i ->
+        let header = [ Printf.sprintf "  #%15d %15d %15d %15d %15d"
+                         (imin+1) (imin+2) (imin+3) (imin+4) (imin+5) ; ] in
+        let new_lines = 
+          List.init ao_num ~f:(fun i ->
               Printf.sprintf "  %3d %15.10f %15.10f %15.10f %15.10f %15.10f" (i+1)
-              (MO_coef.to_float mo_coef.(imin  ).(i))
-              (MO_coef.to_float mo_coef.(imin+1).(i))
-              (MO_coef.to_float mo_coef.(imin+2).(i))
-              (MO_coef.to_float mo_coef.(imin+3).(i))
-              (MO_coef.to_float mo_coef.(imin+4).(i)) )
-          in header @ new_lines 
+                (MO_coef.to_float mo_coef.(imin  ).(i))
+                (MO_coef.to_float mo_coef.(imin+1).(i))
+                (MO_coef.to_float mo_coef.(imin+2).(i))
+                (MO_coef.to_float mo_coef.(imin+3).(i))
+                (MO_coef.to_float mo_coef.(imin+4).(i)) )
+        in header @ new_lines 
       | _ -> assert false
     in
     let rec create_list accu i = 
@@ -158,7 +175,7 @@ end = struct
         (print_five i (mo_tot_num-1) |> String.concat ~sep:"\n")::accu |> List.rev
     in
     create_list [] 0 |> String.concat ~sep:"\n\n"
-  ;;
+
 
   let to_rst b =
     Printf.sprintf "
@@ -174,29 +191,32 @@ MO coefficients ::
 
 %s
 "
-    (MO_label.to_string b.mo_label)
-    (MO_number.to_string b.mo_tot_num)
-    (mo_coef_to_string b.mo_coef)
+      (MO_label.to_string b.mo_label)
+      (MO_number.to_string b.mo_tot_num)
+      (mo_coef_to_string b.mo_coef)
     |> Rst_string.of_string
 
-  ;;
+
 
   let to_string b =
     Printf.sprintf "
 mo_label        = %s
 mo_tot_num      = \"%s\"
+mo_clas         = %s
 mo_occ          = %s
 mo_coef         = %s
 "
-    (MO_label.to_string b.mo_label)
-    (MO_number.to_string b.mo_tot_num)
-    (b.mo_occ |> Array.to_list |> List.map
-      ~f:(MO_occ.to_string) |> String.concat ~sep:", " )
-    (b.mo_coef |> Array.map
-      ~f:(fun x-> Array.map ~f:MO_coef.to_string x |> String.concat_array
-      ~sep:"," ) |>
-      String.concat_array ~sep:"\n" )
-  ;;
+      (MO_label.to_string b.mo_label)
+      (MO_number.to_string b.mo_tot_num)
+      (b.mo_class |> Array.to_list |> List.map
+         ~f:(MO_class.to_string) |> String.concat ~sep:", " )
+      (b.mo_occ |> Array.to_list |> List.map
+         ~f:(MO_occ.to_string) |> String.concat ~sep:", " )
+      (b.mo_coef |> Array.map
+         ~f:(fun x-> Array.map ~f:MO_coef.to_string x |> String.concat_array
+                       ~sep:"," ) |>
+       String.concat_array ~sep:"\n" )
+
 
 end
 

ocaml/MO_class.ml

@@ -1,46 +1,63 @@
-open Core.Std;;
-open Qptypes ;;
+open Core.Std
+open Qptypes 
 
 type t = 
-| Core of MO_number.t list
-| Inactive of MO_number.t list
-| Active of MO_number.t list
-| Virtual of MO_number.t list
-| Deleted of MO_number.t list
+  | Core     of MO_number.t list
+  | Inactive of MO_number.t list
+  | Active   of MO_number.t list
+  | Virtual  of MO_number.t list
+  | Deleted  of MO_number.t list
 with sexp
 
 
 let to_string  x = 
   let print_list l =
     let s = List.map ~f:(fun x-> MO_number.to_int x |> string_of_int )l
-      |> (String.concat ~sep:", ")
+            |> (String.concat ~sep:", ")
     in
     "("^s^")"
   in
-  
+
   match x with
-  | Core     l ->  "Core : "^(print_list l) 
+  | Core     [] ->  "Core"
+  | Inactive [] ->  "Inactive"
+  | Active   [] ->  "Active"
+  | Virtual  [] ->  "Virtual"
+  | Deleted  [] ->  "Deleted"
+  | Core     l ->  "Core     : "^(print_list l) 
   | Inactive l ->  "Inactive : "^(print_list l)
-  | Active   l ->  "Active : "^(print_list l)
-  | Virtual  l ->  "Virtual : "^(print_list l)
-  | Deleted  l ->  "Deleted : "^(print_list l)
-;;
+  | Active   l ->  "Active   : "^(print_list l)
+  | Virtual  l ->  "Virtual  : "^(print_list l)
+  | Deleted  l ->  "Deleted  : "^(print_list l)
 
+
+let of_string s = 
+  match (String.lowercase s) with
+  | "core"     ->  Core     [] 
+  | "inactive" ->  Inactive [] 
+  | "active"   ->  Active   [] 
+  | "virtual"  ->  Virtual  [] 
+  | "deleted"  ->  Deleted  [] 
+  | _ -> failwith "MO_class should be (Core|Inactive|Active|Virtual|Deleted)"
+
+  
 let _mo_number_list_of_range range = 
- Range.of_string range |> List.map ~f:MO_number.of_int 
-;;
+  Range.of_string range |> List.map ~f:MO_number.of_int 
+
+
+let create_core     range = Core     (_mo_number_list_of_range range) 
+let create_inactive range = Inactive (_mo_number_list_of_range range) 
+let create_active   range = Active   (_mo_number_list_of_range range) 
+let create_virtual  range = Virtual  (_mo_number_list_of_range range) 
+let create_deleted  range = Deleted  (_mo_number_list_of_range range) 
 
-let create_core     range = Core     (_mo_number_list_of_range range) ;;
-let create_inactive range = Inactive (_mo_number_list_of_range range) ;;
-let create_active   range = Active   (_mo_number_list_of_range range) ;;
-let create_virtual  range = Virtual  (_mo_number_list_of_range range) ;;
-let create_deleted  range = Deleted  (_mo_number_list_of_range range) ;;
 
 let to_bitlist n_int x =
-   match x with    
-   | Core     l 
-   | Inactive l 
-   | Active   l 
-   | Virtual  l 
-   | Deleted  l -> Bitlist.of_mo_number_list n_int l
-;;
+  match x with    
+  | Core     l 
+  | Inactive l 
+  | Active   l 
+  | Virtual  l 
+  | Deleted  l -> Bitlist.of_mo_number_list n_int l
+
+

ocaml/MO_class.mli

@@ -19,3 +19,6 @@ val to_bitlist      : Qptypes.N_int_number.t -> t -> Bitlist.t
 
 (** Convert to string for printing *)
 val to_string : t -> string
+
+val of_string : string -> t
+

ocaml/Message.ml

@@ -324,33 +324,28 @@ end
 
 (** GetPsiReply_msg : Reply to the GetPsi message *)
 module GetPsiReply_msg : sig
-  type t =
-  { client_id :  Id.Client.t ;
-    psi       :  Psi.t }
-  val create : client_id:Id.Client.t -> psi:Psi.t -> t
-  val to_string_list : t -> string list
+  type t = string list
+  val create : psi:Psi.t -> t
   val to_string : t -> string
 end = struct
-  type t = 
-  { client_id :  Id.Client.t ;
-    psi       :  Psi.t }
-  let create ~client_id ~psi =
-    {  client_id ; psi }
-  let to_string x =
+  type t = string list
+  let create ~psi =
     let g, s = 
-      match x.psi.Psi.n_det_generators, x.psi.Psi.n_det_selectors with
+      match psi.Psi.n_det_generators, psi.Psi.n_det_selectors with
       | Some g, Some s -> Strictly_positive_int.to_int g, Strictly_positive_int.to_int s
       | _ -> -1, -1
     in
-    Printf.sprintf "get_psi_reply %d %d %d %d %d %d"
-      (Id.Client.to_int x.client_id)
-      (Strictly_positive_int.to_int x.psi.Psi.n_state)
-      (Strictly_positive_int.to_int x.psi.Psi.n_det) 
-      (Strictly_positive_int.to_int x.psi.Psi.psi_det_size) 
-      g s
-  let to_string_list x =
-    [ to_string x ;
-      x.psi.Psi.psi_det ; x.psi.Psi.psi_coef ; x.psi.Psi.energy ]
+    let head = 
+      Printf.sprintf "get_psi_reply %d %d %d %d %d"
+        (Strictly_positive_int.to_int psi.Psi.n_state)
+        (Strictly_positive_int.to_int psi.Psi.n_det) 
+        (Strictly_positive_int.to_int psi.Psi.psi_det_size) 
+        g s
+    in
+    [ head ; psi.Psi.psi_det ; psi.Psi.psi_coef ; psi.Psi.energy ]
+  let to_string = function
+    | head :: _ :: _ :: _ :: [] -> head
+    | _ -> raise (Invalid_argument "Bad wave function message")
 end
 
 
@@ -759,7 +754,6 @@ let to_string = function
 
 let to_string_list = function
 | PutPsi           x -> PutPsi_msg.to_string_list         x
-| GetPsiReply      x -> GetPsiReply_msg.to_string_list    x
 | PutVector        x -> PutVector_msg.to_string_list      x
 | GetVectorReply   x -> GetVectorReply_msg.to_string_list x
 | _                  -> assert false

ocaml/Molecule.ml

@@ -2,6 +2,7 @@ open Core.Std ;;
 open Qptypes ;;
 
 exception MultiplicityError of string;;
+exception XYZError ;;
 
 type t = {
   nuclei     : Atom.t list ;
@@ -144,8 +145,16 @@ let of_xyz_file
     ?(charge=(Charge.of_int 0)) ?(multiplicity=(Multiplicity.of_int 1))
     ?(units=Units.Angstrom)
     filename =
-  let (_,buffer) = In_channel.read_all filename 
-  |> String.lsplit2_exn ~on:'\n' in
+  let (x,buffer) = In_channel.read_all filename 
+  |> String.lsplit2_exn ~on:'\n'
+  in
+  let result =
+    try
+      int_of_string x > 0
+    with
+    | Failure "int_of_string"  -> false
+  in
+  if not result then raise XYZError;
   let (_,buffer) = String.lsplit2_exn buffer ~on:'\n' in
   of_xyz_string ~charge ~multiplicity ~units buffer
 
@@ -166,7 +175,7 @@ let of_file
     filename = 
   try
     of_xyz_file ~charge ~multiplicity ~units filename
-  with _ ->
+  with XYZError ->
     of_zmt_file ~charge ~multiplicity ~units filename
 
 

ocaml/Pseudo.ml

@@ -2,7 +2,7 @@ open Core.Std
 open Qptypes
 
 
-module Primitive_local : sig
+module GaussianPrimitive_local : sig
 
   type t = { 
     expo    : AO_expo.t ;
@@ -29,7 +29,7 @@ end = struct
 end
 
 
-module Primitive_non_local : sig
+module GaussianPrimitive_non_local : sig
 
   type t = { 
     expo    : AO_expo.t ;
@@ -64,8 +64,8 @@ end
 type t = {
   element   : Element.t ;
   n_elec    : Positive_int.t ;
-  local     : (Primitive_local.t * AO_coef.t ) list ;
-  non_local : (Primitive_non_local.t * AO_coef.t ) list 
+  local     : (GaussianPrimitive_local.t * AO_coef.t ) list ;
+  non_local : (GaussianPrimitive_non_local.t * AO_coef.t ) list 
 } with sexp
 
 let empty e =
@@ -83,8 +83,8 @@ let to_string_local = function
   ( Printf.sprintf "%20s %8s %20s" "Coeff." "r^n" "Exp." ) ::
   ( List.map t ~f:(fun (l,c) -> Printf.sprintf "%20f %8d %20f"
       (AO_coef.to_float c) 
-      (R_power.to_int   l.Primitive_local.r_power)
-      (AO_expo.to_float l.Primitive_local.expo)
+      (R_power.to_int   l.GaussianPrimitive_local.r_power)
+      (AO_expo.to_float l.GaussianPrimitive_local.expo)
   ) )
   |> String.concat ~sep:"\n" 
 
@@ -97,12 +97,12 @@ let to_string_non_local = function
   ( Printf.sprintf "%20s %8s %20s %8s" "Coeff." "r^n" "Exp." "Proj") ::
   ( List.map t ~f:(fun (l,c) ->
       let p = 
-        Positive_int.to_int l.Primitive_non_local.proj
+        Positive_int.to_int l.GaussianPrimitive_non_local.proj
       in
       Printf.sprintf "%20f %8d %20f   |%d><%d|"
       (AO_coef.to_float c) 
-      (R_power.to_int   l.Primitive_non_local.r_power)
-      (AO_expo.to_float l.Primitive_non_local.expo)
+      (R_power.to_int   l.GaussianPrimitive_non_local.r_power)
+      (AO_expo.to_float l.GaussianPrimitive_non_local.expo)
       p p
   ) )
   |> String.concat ~sep:"\n" 
@@ -223,7 +223,7 @@ let read_element in_channel element =
       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)
+            loop GaussianPrimitive_local.of_expo_r_power [] (Positive_int.to_int n,rest)
           in
           { pseudo with local = result }, rest
         in
@@ -241,7 +241,7 @@ let read_element in_channel element =
       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)
+            loop (GaussianPrimitive_non_local.of_proj_expo_r_power proj)
               [] (Positive_int.to_int n, data)
           in
           { pseudo with non_local = pseudo.non_local @ result }, rest

ocaml/TaskServer.ml

@@ -25,7 +25,7 @@ type t =
     state           : Message.State.t option ;
     address_tcp     : Address.Tcp.t option ; 
     address_inproc  : Address.Inproc.t option ;
-    psi             : Message.Psi.t option;
+    psi             : Message.GetPsiReply_msg.t option;
     vector             : Message.Vector.t option;
     progress_bar    : Progress_bar.t option ;
     running         : bool;
@@ -483,7 +483,7 @@ let put_psi msg rest_of_msg program_state rep_socket =
     in
     let new_program_state =
         { program_state with
-          psi = Some psi_local
+          psi = Some (Message.GetPsiReply_msg.create ~psi:psi_local)
         }
     and client_id =
       msg.Message.PutPsi_msg.client_id
@@ -496,17 +496,12 @@ let put_psi msg rest_of_msg program_state rep_socket =
 
 
 let get_psi msg program_state rep_socket =
-
-      let client_id =
-          msg.Message.GetPsi_msg.client_id
-      in
-      match program_state.psi with
-      | None -> failwith "No wave function saved in TaskServer"
-      | Some psi -> 
-          Message.GetPsiReply (Message.GetPsiReply_msg.create ~client_id ~psi)
-          |> Message.to_string_list 
-          |> ZMQ.Socket.send_all rep_socket;
-      program_state
+  begin
+    match program_state.psi with
+    | None -> failwith "No wave function saved in TaskServer"
+    | Some psi_message -> ZMQ.Socket.send_all rep_socket psi_message
+  end;
+  program_state
 
 
 

ocaml/TaskServer.mli

@@ -4,7 +4,7 @@ type t =
     state           : Message.State.t option ;
     address_tcp     : Address.Tcp.t option ;
     address_inproc  : Address.Inproc.t option ;
-    psi             : Message.Psi.t option;
+    psi             : Message.GetPsiReply_msg.t option;
     vector          : Message.Vector.t option ;
     progress_bar    : Progress_bar.t option ;
     running         : bool;

ocaml/qp_create_ezfio_from_xyz.ml

@@ -420,7 +420,7 @@ let run ?o b c d m p cart xyz_file =
           let x = 
             List.fold x.Pseudo.non_local ~init:0 ~f:(fun accu (x,_) ->
               let x = 
-                Positive_int.to_int x.Pseudo.Primitive_non_local.proj
+                Positive_int.to_int x.Pseudo.GaussianPrimitive_non_local.proj
               in
               if (x > accu) then x
               else accu
@@ -435,7 +435,7 @@ let run ?o b c d m p cart xyz_file =
          Array.init (lmax+1) ~f:(fun i->
            List.map pseudo ~f:(fun x -> 
              List.filter x.Pseudo.non_local ~f:(fun (y,_) -> 
-               (Positive_int.to_int y.Pseudo.Primitive_non_local.proj) = i)
+               (Positive_int.to_int y.Pseudo.GaussianPrimitive_non_local.proj) = i)
              |> List.length )
            |> List.fold ~init:0 ~f:(fun accu x ->
              if accu > x then accu else x)
@@ -458,8 +458,8 @@ let run ?o b c d m p cart xyz_file =
           List.iteri x.Pseudo.local ~f:(fun i (y,c) ->
             tmp_array_v_k.(i).(j)  <- AO_coef.to_float c;
             let y, z =
-              AO_expo.to_float y.Pseudo.Primitive_local.expo, 
-              R_power.to_int y.Pseudo.Primitive_local.r_power 
+              AO_expo.to_float y.Pseudo.GaussianPrimitive_local.expo, 
+              R_power.to_int y.Pseudo.GaussianPrimitive_local.r_power 
             in
             tmp_array_dz_k.(i).(j) <- y;
             tmp_array_n_k.(i).(j)  <- z;
@@ -494,9 +494,9 @@ let run ?o b c d m p cart xyz_file =
           in
           List.iter x.Pseudo.non_local ~f:(fun (y,c) -> 
             let k, y, z =
-              Positive_int.to_int y.Pseudo.Primitive_non_local.proj,
-              AO_expo.to_float y.Pseudo.Primitive_non_local.expo,
-              R_power.to_int y.Pseudo.Primitive_non_local.r_power
+              Positive_int.to_int y.Pseudo.GaussianPrimitive_non_local.proj,
+              AO_expo.to_float y.Pseudo.GaussianPrimitive_non_local.expo,
+              R_power.to_int y.Pseudo.GaussianPrimitive_non_local.r_power
             in
             let i = 
               last_idx.(k) 
@@ -602,7 +602,7 @@ let run ?o b c d m p cart xyz_file =
               List.map x.Gto.lc ~f:(fun (_,coef) -> AO_coef.to_float coef) )
             | `Expos -> List.map gtos ~f:(fun x->
               List.map x.Gto.lc ~f:(fun (prim,_) -> AO_expo.to_float
-              prim.Primitive.expo) )
+              prim.GaussianPrimitive.expo) )
             end
           in
           let rec get_n n accu = function

ocaml/qp_run.ml

@@ -120,10 +120,11 @@ let run slave exe ezfio_file =
     | Some (_,x) -> x^" "
     | None -> assert false
   in
-  match (Sys.command (prefix^exe^ezfio_file)) with
-  | 0 -> ()
-  | i -> Printf.printf "Program exited with code %d.\n%!" i;
-  ;
+  let exit_code = 
+    match (Sys.command (prefix^exe^ezfio_file)) with
+    | 0 -> 0
+    | i -> (Printf.printf "Program exited with code %d.\n%!" i; i)
+  in
 
   TaskServer.stop ~port:port_number;
   Thread.join task_thread;
@@ -132,7 +133,8 @@ let run slave exe ezfio_file =
 
   let duration = Time.diff (Time.now()) time_start 
   |> Core.Span.to_string in
-  Printf.printf "Wall time : %s\n\n" duration
+  Printf.printf "Wall time : %s\n\n" duration;
+  exit exit_code
 
 let spec = 
   let open Command.Spec in

ocaml/qp_set_ddci.ml

@@ -1,305 +0,0 @@
-open Qputils;;
-open Qptypes;;
-open Core.Std;;
-
-(*
- * Command-line arguments
- * ----------------------
- *)
-
-let build_mask from upto n_int =
-  let from  = MO_number.to_int from
-  and upto  = MO_number.to_int upto
-  and n_int = N_int_number.to_int n_int
-  in
-  let rec build_mask bit = function
-    | 0 -> []
-    | i -> 
-        if ( i = upto ) then
-          Bit.One::(build_mask Bit.One (i-1))
-        else if ( i = from ) then
-          Bit.One::(build_mask Bit.Zero (i-1))
-        else
-          bit::(build_mask bit (i-1))
-  in
-  let starting_bit = 
-    if ( (upto >= n_int*64) || (upto < 0) ) then Bit.One
-    else Bit.Zero
-  in
-  build_mask starting_bit (n_int*64)
-  |> List.rev
-;;
-
-
-let failure s = raise (Failure s)
-;;
-
-type t = 
-  | Core
-  | Inactive
-  | Active
-  | Virtual
-  | Deleted
-  | None
-;;
-
-let t_to_string = function
-  | Core -> "core"
-  | Inactive -> "inactive"
-  | Active -> "active"
-  | Virtual -> "virtual"
-  | Deleted -> "deleted"
-  | None -> assert false
-;;
-
-let run ?(core="[]") ?(inact="[]") ?(act="[]") ?(virt="[]") ?(del="[]") ezfio_filename =
-
-  Ezfio.set_file ezfio_filename ;
-  if not (Ezfio.has_mo_basis_mo_tot_num ()) then
-    failure "mo_basis/mo_tot_num not found" ;
-
-  let mo_tot_num = Ezfio.get_mo_basis_mo_tot_num () in
-  let n_int =
-     try  N_int_number.of_int (Ezfio.get_determinants_n_int ())
-     with _ -> Bitlist.n_int_of_mo_tot_num mo_tot_num 
-  in
-
-
-  let mo_class = Array.init mo_tot_num ~f:(fun i -> None) in
-
-  (* Check input data *)
-  let apply_class l = 
-    let rec apply_class t = function
-    | [] -> ()
-    | k::tail -> let i = MO_number.to_int k in
-        begin
-          match mo_class.(i-1) with
-          | None -> mo_class.(i-1) <- t ;
-            apply_class t tail;
-          | x -> failure 
-             (Printf.sprintf "Orbital %d is defined both in the %s and %s spaces"
-             i (t_to_string x) (t_to_string t))
-        end
-    in
-    match l with
-    | MO_class.Core     x -> apply_class Core      x
-    | MO_class.Inactive x -> apply_class Inactive  x
-    | MO_class.Active   x -> apply_class Active    x
-    | MO_class.Virtual  x -> apply_class Virtual   x
-    | MO_class.Deleted  x -> apply_class Deleted   x
-  in
-
-  let core_input = core in
-  let core  = MO_class.create_core     core in
-  let inact = MO_class.create_inactive inact in
-  let act   = MO_class.create_active   act in
-  let virt  = MO_class.create_virtual  virt in
-  let del   = MO_class.create_deleted  del in
-
-  apply_class core  ;
-  apply_class inact ;
-  apply_class act   ;
-  apply_class virt  ;
-  apply_class del   ;
-
-  for i=1 to (Array.length mo_class)
-  do
-    if (mo_class.(i-1) = None) then
-      failure (Printf.sprintf "Orbital %d is not specified (mo_tot_num = %d)" i mo_tot_num)
-  done;
-  
-  
-  (* Debug output *)
-  MO_class.to_string core  |> print_endline ;
-  MO_class.to_string inact |> print_endline ;
-  MO_class.to_string act   |> print_endline ;
-  MO_class.to_string virt  |> print_endline ;
-  MO_class.to_string del   |> print_endline ;
-
-  (* Create masks *)
-  let ia = Excitation.create_single inact act 
-  and aa = Excitation.create_single act act 
-  and av = Excitation.create_single act virt
-  and iv = Excitation.create_single inact virt
-  in
-  let single_excitations = [| ia ; aa ; av ; iv |]
-    |> Array.map ~f:Excitation.(fun x ->
-       match x with
-       | Single (x,y) -> 
-         ( MO_class.to_bitlist n_int (Hole.to_mo_class x),
-           MO_class.to_bitlist n_int (Particle.to_mo_class y) ) 
-       | Double _ -> assert false
-       )
-       
-  and double_excitations = [|
-    Excitation.double_of_singles ia ia ;
-    Excitation.double_of_singles ia aa ;
-    Excitation.double_of_singles ia iv ;
-    Excitation.double_of_singles ia av ;
-
-    Excitation.double_of_singles aa aa ;
-    Excitation.double_of_singles aa iv ;
-    Excitation.double_of_singles aa av ;
-
-    Excitation.double_of_singles iv aa ;
-    Excitation.double_of_singles iv av ;
-
-(*    Excitation.double_of_singles iv iv ; *)
- |]
-
-    |> Array.map ~f:Excitation.(fun x ->
-       match x with
-       | Single _ -> assert false
-       | Double (x,y,z,t) -> 
-         ( MO_class.to_bitlist n_int (Hole.to_mo_class x),
-           MO_class.to_bitlist n_int (Particle.to_mo_class y) , 
-           MO_class.to_bitlist n_int (Hole.to_mo_class z),
-           MO_class.to_bitlist n_int (Particle.to_mo_class t) )
-       )
-  in
-  
-  let extract_hole (h,_) = h 
-  and extract_particle (_,p) = p 
-  and extract_hole1 (h,_,_,_) = h 
-  and extract_particle1 (_,p,_,_) = p 
-  and extract_hole2 (_,_,h,_) = h 
-  and extract_particle2 (_,_,_,p) = p 
-  in
-(* --> TODO : This might be wrong *)
-  let result_ref = 
-    let core = MO_class.create_inactive core_input in
-    let cv = Excitation.create_single core virt in
-    let cv = match cv with
-    | Excitation.Single (x,y) ->  
-      ( MO_class.to_bitlist n_int (Excitation.Hole.to_mo_class x),
-        MO_class.to_bitlist n_int (Excitation.Particle.to_mo_class y) ) 
-    | Excitation.Double _ -> assert false
-    in
-    let iv = match iv with
-    | Excitation.Single (x,y) ->  
-      ( MO_class.to_bitlist n_int (Excitation.Hole.to_mo_class x),
-        MO_class.to_bitlist n_int (Excitation.Particle.to_mo_class y) ) 
-    | Excitation.Double _ -> assert false
-    in
-    [ Bitlist.or_operator (extract_hole iv) (extract_hole cv);
-      extract_particle iv ]
-  in
-(* <-- TODO : This might be wrong *)
-
-  let n_single = Array.length single_excitations in
-  let n_mask = Array.length double_excitations in
-  let zero = List.init (N_int_number.to_int n_int) ~f:(fun i -> 0L)
-   |> Bitlist.of_int64_list in
-  let result_gen = (List.init n_single ~f:(fun i-> [
-    extract_hole      single_excitations.(i) ; 
-    extract_particle  single_excitations.(i) ; 
-    extract_hole1     double_excitations.(i) ; 
-    extract_particle1 double_excitations.(i) ; 
-    extract_hole2     double_excitations.(i) ; 
-    extract_particle2 double_excitations.(i) ; ])
-   )@(List.init (n_mask-n_single) ~f:(fun i-> [
-    zero ; zero ;
-    extract_hole1     double_excitations.(n_single+i) ; 
-    extract_particle1 double_excitations.(n_single+i) ; 
-    extract_hole2     double_excitations.(n_single+i) ; 
-    extract_particle2 double_excitations.(n_single+i) ; ])
-   )
-   |> List.concat
-  in
-
-  (* Print bitmasks *)
-  print_endline "Reference  Bitmasks:";
-  List.iter ~f:(fun x-> print_endline (Bitlist.to_string x)) result_ref;
-
-  print_endline "Generators Bitmasks:";
-  List.iter ~f:(fun x-> print_endline (Bitlist.to_string x)) result_gen;
-
-  (* Transform to int64 *)
-  let result_gen =  List.map ~f:(fun x ->
-     let y = Bitlist.to_int64_list x in y@y )
-     result_gen 
-  |> List.concat
-  in
-  let result_ref =  List.map ~f:(fun x ->
-     let y = Bitlist.to_int64_list x in y@y )
-     result_ref 
-  |> List.concat
-  in
-
-  (* Write generators masks *)
-  Ezfio.set_bitmasks_n_int (N_int_number.to_int n_int);
-  Ezfio.set_bitmasks_bit_kind 8;
-  Ezfio.set_bitmasks_n_mask_gen n_mask;
-  Ezfio.ezfio_array_of_list ~rank:4 ~dim:([| (N_int_number.to_int n_int) ; 2; 6; n_mask|]) ~data:result_gen
-  |> Ezfio.set_bitmasks_generators ; 
-
-  (* Write CAS reference masks *)
-  Ezfio.set_bitmasks_n_mask_cas 1;
-  Ezfio.ezfio_array_of_list ~rank:3 ~dim:([| (N_int_number.to_int n_int) ; 2; 1|]) ~data:result_ref
-  |> Ezfio.set_bitmasks_cas ; 
-
-
-;;
-
-let ezfio_file =
-  let failure filename = 
-        eprintf "'%s' is not an EZFIO file.\n%!" filename;
-        exit 1
-  in
-  Command.Spec.Arg_type.create
-  (fun filename ->
-    match Sys.is_directory filename with
-    | `Yes -> 
-        begin
-          match Sys.is_file (filename ^ "/.version") with
-          | `Yes -> filename
-          | _ -> failure filename
-        end
-    | _ -> failure filename
-  )
-;;
-
-let default range =
-  let failure filename = 
-        eprintf "'%s' is not a regular file.\n%!" filename;
-        exit 1
-  in
-  Command.Spec.Arg_type.create
-  (fun filename ->
-    match Sys.is_directory filename with
-    | `Yes -> 
-        begin
-          match Sys.is_file (filename^"/.version") with
-          | `Yes -> filename
-          | _ -> failure filename
-        end
-    | _ -> failure filename
-  )
-;;
-
-let spec =
-  let open Command.Spec in
-  empty 
-  +> flag "core"   (optional string) ~doc:"range Range of core orbitals"
-  +> flag "inact"  (optional string) ~doc:"range Range of inactive orbitals"
-  +> flag "act"    (optional string) ~doc:"range Range of active orbitals"
-  +> flag "virt"   (optional string) ~doc:"range Range of virtual orbitals"
-  +> flag "del"    (optional string) ~doc:"range Range of deleted orbitals"
-  +> anon ("ezfio_filename" %: ezfio_file)
-;;
-
-let command = 
-    Command.basic 
-    ~summary: "Quantum Package command"
-    ~readme:(fun () ->
-     "Set the orbital classes in an EZFIO directory
-      The range of MOs has the form : \"[36-53,72-107,126-131]\"
-        ")
-    spec
-    (fun core inact act virt del ezfio_filename () -> run ?core ?inact ?act ?virt ?del ezfio_filename )
-;;
-
-let () =
-    Command.run command
-
-

ocaml/qp_set_mo_class.ml

@@ -1,6 +1,6 @@
-open Qputils;;
-open Qptypes;;
-open Core.Std;;
+open Qputils
+open Qptypes
+open Core.Std
 
 (*
  * Command-line arguments
@@ -15,12 +15,12 @@ let build_mask from upto n_int =
   let rec build_mask bit = function
     | 0 -> []
     | i -> 
-        if ( i = upto ) then
-          Bit.One::(build_mask Bit.One (i-1))
-        else if ( i = from ) then
-          Bit.One::(build_mask Bit.Zero (i-1))
-        else
-          bit::(build_mask bit (i-1))
+      if ( i = upto ) then
+        Bit.One::(build_mask Bit.One (i-1))
+      else if ( i = from ) then
+        Bit.One::(build_mask Bit.Zero (i-1))
+      else
+        bit::(build_mask bit (i-1))
   in
   let starting_bit = 
     if ( (upto >= n_int*64) || (upto < 0) ) then Bit.One
@@ -28,83 +28,78 @@ let build_mask from upto n_int =
   in
   build_mask starting_bit (n_int*64)
   |> List.rev
-;;
 
 
-type t = 
-  | Core
-  | Inactive
-  | Active
-  | Virtual
-  | Deleted
-  | None
-;;
 
-let t_to_string = function
-  | Core -> "core"
-  | Inactive -> "inactive"
-  | Active -> "active"
-  | Virtual -> "virtual"
-  | Deleted -> "deleted"
-  | None -> assert false
-;;
+type t = MO_class.t option
+
 
 let set ~core ~inact ~act ~virt ~del =
 
   let mo_tot_num =
-     Ezfio.get_mo_basis_mo_tot_num ()
+    Ezfio.get_mo_basis_mo_tot_num ()
   in
   let n_int =
-     try  N_int_number.of_int (Ezfio.get_determinants_n_int ())
-     with _ -> Bitlist.n_int_of_mo_tot_num mo_tot_num 
+    try  N_int_number.of_int (Ezfio.get_determinants_n_int ())
+    with _ -> Bitlist.n_int_of_mo_tot_num mo_tot_num 
   in
 
 
   let mo_class =
-     Array.init mo_tot_num ~f:(fun i -> None)
+    Array.init mo_tot_num ~f:(fun i -> None)
   in
 
   (* Check input data *)
   let apply_class l = 
     let rec apply_class t = function
-    | [] -> ()
-    | k::tail -> let i = MO_number.to_int k in
+      | [] -> ()
+      | k::tail -> let i = MO_number.to_int k in
         begin
           match mo_class.(i-1) with
-          | None -> mo_class.(i-1) <- t ;
+          | None -> mo_class.(i-1) <- Some t ;
             apply_class t tail;
-          | x -> failwith
-             (Printf.sprintf "Orbital %d is defined both in the %s and %s spaces"
-             i (t_to_string x) (t_to_string t))
+          | Some x -> failwith
+                        (Printf.sprintf "Orbital %d is defined both in the %s and %s spaces"
+                           i (MO_class.to_string x) (MO_class.to_string t))
         end
     in
     match l with
-    | MO_class.Core     x -> apply_class Core      x
-    | MO_class.Inactive x -> apply_class Inactive  x
-    | MO_class.Active   x -> apply_class Active    x
-    | MO_class.Virtual  x -> apply_class Virtual   x
-    | MO_class.Deleted  x -> apply_class Deleted   x
+    | MO_class.Core     x -> apply_class (MO_class.Core     []) x
+    | MO_class.Inactive x -> apply_class (MO_class.Inactive []) x
+    | MO_class.Active   x -> apply_class (MO_class.Active   []) x
+    | MO_class.Virtual  x -> apply_class (MO_class.Virtual  []) x
+    | MO_class.Deleted  x -> apply_class (MO_class.Deleted  []) x
   in
 
-  let core  = MO_class.create_core     core in
-  let inact = MO_class.create_inactive inact in
-  let act   = MO_class.create_active   act in
-  let virt  = MO_class.create_virtual  virt in
-  let del   = MO_class.create_deleted  del in
+  let check f x = 
+    try f x with Invalid_argument a ->
+      begin
+        Printf.printf "Number of MOs: %d\n%!" mo_tot_num;
+        raise (Invalid_argument a) 
+      end
+  in
+
+  let core  = check MO_class.create_core     core in
+  let inact = check MO_class.create_inactive inact in
+  let act   = check MO_class.create_active   act in
+  let virt  = check MO_class.create_virtual  virt in
+  let del   = check MO_class.create_deleted  del in
 
   apply_class core  ;
   apply_class inact ;
   apply_class act   ;
   apply_class virt  ;
   apply_class del   ;
+  
+
 
   for i=1 to (Array.length mo_class)
   do
     if (mo_class.(i-1) = None) then
       failwith (Printf.sprintf "Orbital %d is not specified (mo_tot_num = %d)" i mo_tot_num)
   done;
-  
-  
+
+
   (* Debug output *)
   MO_class.to_string core  |> print_endline ;
   MO_class.to_string inact |> print_endline ;
@@ -118,14 +113,14 @@ let set ~core ~inact ~act ~virt ~del =
   and av = Excitation.create_single act virt
   in
   let single_excitations = [ ia ; aa ; av ]
-    |> List.map ~f:Excitation.(fun x ->
-       match x with
-       | Single (x,y) -> 
-         ( MO_class.to_bitlist n_int (Hole.to_mo_class x),
-           MO_class.to_bitlist n_int (Particle.to_mo_class y) ) 
-       | Double _ -> assert false
-       )
-       
+                           |> List.map ~f:Excitation.(fun x ->
+                               match x with
+                               | Single (x,y) -> 
+                                 ( MO_class.to_bitlist n_int (Hole.to_mo_class x),
+                                   MO_class.to_bitlist n_int (Particle.to_mo_class y) ) 
+                               | Double _ -> assert false
+                             )
+
   and double_excitations = [
     Excitation.double_of_singles ia ia ;
     Excitation.double_of_singles ia aa ;
@@ -134,16 +129,16 @@ let set ~core ~inact ~act ~virt ~del =
     Excitation.double_of_singles aa av ;
     Excitation.double_of_singles av av ]
     |> List.map ~f:Excitation.(fun x ->
-       match x with
-       | Single _ -> assert false
-       | Double (x,y,z,t) -> 
-         ( MO_class.to_bitlist n_int (Hole.to_mo_class x),
-           MO_class.to_bitlist n_int (Particle.to_mo_class y) , 
-           MO_class.to_bitlist n_int (Hole.to_mo_class z),
-           MO_class.to_bitlist n_int (Particle.to_mo_class t) )
-       )
+        match x with
+        | Single _ -> assert false
+        | Double (x,y,z,t) -> 
+          ( MO_class.to_bitlist n_int (Hole.to_mo_class x),
+            MO_class.to_bitlist n_int (Particle.to_mo_class y) , 
+            MO_class.to_bitlist n_int (Hole.to_mo_class z),
+            MO_class.to_bitlist n_int (Particle.to_mo_class t) )
+      )
   in
-  
+
   let extract_hole (h,_) = h 
   and extract_particle (_,p) = p 
   and extract_hole1 (h,_,_,_) = h 
@@ -171,9 +166,9 @@ let set ~core ~inact ~act ~virt ~del =
 
   (* Write masks *)
   let result =  List.map ~f:(fun x ->
-     let y = Bitlist.to_int64_list x in y@y )
-     result 
-  |> List.concat
+      let y = Bitlist.to_int64_list x in y@y )
+      result 
+                |> List.concat
   in
 
   Ezfio.set_bitmasks_n_int (N_int_number.to_int n_int);
@@ -187,57 +182,83 @@ let set ~core ~inact ~act ~virt ~del =
     match aa with
     | Double _ -> assert false
     | Single (x,y) -> 
-        ( MO_class.to_bitlist n_int (Hole.to_mo_class x) ) @
-        ( MO_class.to_bitlist n_int (Particle.to_mo_class y) )
-        |> Bitlist.to_int64_list
+      ( MO_class.to_bitlist n_int (Hole.to_mo_class x) ) @
+      ( MO_class.to_bitlist n_int (Particle.to_mo_class y) )
+      |> Bitlist.to_int64_list
   in
   Ezfio.set_bitmasks_n_mask_cas 1;
   Ezfio.ezfio_array_of_list ~rank:3 ~dim:([| (N_int_number.to_int n_int) ; 2; 1|]) ~data:result
-  |> Ezfio.set_bitmasks_cas; 
-;;
+  |> Ezfio.set_bitmasks_cas;
+
+  let data = 
+    Array.to_list mo_class
+    |> List.map ~f:(fun x -> match x with
+        |None -> assert false
+        | Some x -> MO_class.to_string x
+      )
+  in
+  Ezfio.ezfio_array_of_list ~rank:1 ~dim:[| mo_tot_num |] ~data
+  |> Ezfio.set_mo_basis_mo_class
+
+
 
 let get () =
+  let data =
+    match Input.Mo_basis.read () with
+    | None -> failwith "Unable to read MOs"
+    | Some x -> x
+  in
 
   let mo_tot_num =
-     Ezfio.get_mo_basis_mo_tot_num ()
+    MO_number.to_int data.Input_mo_basis.mo_tot_num
   in
+
   let n_int =
-     try  N_int_number.of_int (Ezfio.get_determinants_n_int ())
-     with _ -> Bitlist.n_int_of_mo_tot_num mo_tot_num 
-  in
-
-  let bitmasks = 
-    match Input.Bitmasks.read () with
-    | Some x -> x
-    | None -> failwith "No data to print"
-  in
-  assert (bitmasks.Input.Bitmasks.n_mask_gen |> Bitmask_number.to_int = 1);
-  assert (bitmasks.Input.Bitmasks.n_mask_cas |> Bitmask_number.to_int = 1);
-
-  let (generators,cas) =
-    Bitlist.of_int64_array bitmasks.Input.Bitmasks.generators,
-    Bitlist.of_int64_array bitmasks.Input.Bitmasks.cas
+    try  N_int_number.of_int (Ezfio.get_determinants_n_int ())
+    with _ -> Bitlist.n_int_of_mo_tot_num mo_tot_num 
   in
 
   Printf.printf "MO  : %d\n" mo_tot_num;
   Printf.printf "n_int: %d\n" (N_int_number.to_int n_int);
-  Printf.printf "Gen : %s\nCAS : %s\n"
-    (Bitlist.to_string generators)
-    (Bitlist.to_string cas)
-  
-;;
 
-let run ~print ?(core="[]") ?(inact="[]") ?(act="[]") ?(virt="[]") ?(del="[]") ezfio_filename =
+
+  let rec work ?(core="[") ?(inact="[") ?(act="[") ?(virt="[") ?(del="[") i l =
+    match l with
+    | [] -> 
+      let (core, inact, act, virt, del) =
+       (core  ^"]",
+        inact ^"]",
+        act   ^"]",
+        virt  ^"]",
+        del   ^"]")
+      in
+      set ~core ~inact ~act ~virt ~del 
+    | (MO_class.Core     _) :: rest ->
+        work ~core:(Printf.sprintf "%s,%d" core  i) ~inact ~act  ~virt ~del  (i+1) rest
+    | (MO_class.Inactive _) :: rest ->
+        work ~inact:(Printf.sprintf "%s,%d" inact i) ~core  ~act  ~virt ~del  (i+1) rest
+    | (MO_class.Active   _) :: rest ->
+        work ~act:(Printf.sprintf "%s,%d" act   i) ~inact ~core ~virt ~del  (i+1) rest
+    | (MO_class.Virtual  _) :: rest ->
+        work ~virt:(Printf.sprintf "%s,%d" virt  i) ~inact ~act  ~core ~del  (i+1) rest
+    | (MO_class.Deleted  _) :: rest ->
+        work ~del:(Printf.sprintf "%s,%d" del   i) ~inact ~act  ~virt ~core (i+1) rest
+  in
+  work 1 (Array.to_list data.Input_mo_basis.mo_class)
+
+
+
+let run ~q ?(core="[]") ?(inact="[]") ?(act="[]") ?(virt="[]") ?(del="[]") ezfio_filename =
 
   Ezfio.set_file ezfio_filename ;
   if not (Ezfio.has_mo_basis_mo_tot_num ()) then
     failwith "mo_basis/mo_tot_num not found" ;
 
-  if print then
+  if q then
      get ()
   else
      set ~core ~inact ~act ~virt ~del
-;;
+
 
 let ezfio_file =
   let failure filename = 
@@ -255,7 +276,7 @@ let ezfio_file =
         end
     | _ -> failure filename
   )
-;;
+
 
 let default range =
   let failure filename = 
@@ -273,7 +294,7 @@ let default range =
         end
     | _ -> failure filename
   )
-;;
+
 
 let spec =
   let open Command.Spec in
@@ -283,9 +304,9 @@ let spec =
   +> flag "act"    (optional string) ~doc:"range Range of active orbitals"
   +> flag "virt"   (optional string) ~doc:"range Range of virtual orbitals"
   +> flag "del"    (optional string) ~doc:"range Range of deleted orbitals"
-  +> flag "print"  no_arg ~doc:" Print the current masks"
+  +> flag "q"       no_arg ~doc:" Query: print the current masks"
   +> anon ("ezfio_filename" %: ezfio_file)
-;;
+
 
 let command = 
     Command.basic 
@@ -295,8 +316,8 @@ let command =
       The range of MOs has the form : \"[36-53,72-107,126-131]\"
         ")
     spec
-    (fun core inact act virt del print ezfio_filename () -> run ~print ?core ?inact ?act ?virt ?del ezfio_filename )
-;;
+    (fun core inact act virt del q ezfio_filename () -> run ~q ?core ?inact ?act ?virt ?del ezfio_filename )
+
 
 let () =
     Command.run command

ocaml/qptypes_generator.ml

@@ -2,42 +2,52 @@ open Core.Std;;
 
 let input_data = "
 * Positive_float : float  
-  assert (x >= 0.) ; 
+  if not (x >= 0.) then
+    raise (Invalid_argument (Printf.sprintf \"Positive_float : (x >= 0.) : x=%f\"  x)); 
 
 * Strictly_positive_float : float  
-  assert (x > 0.) ; 
+  if not (x > 0.) then
+    raise (Invalid_argument (Printf.sprintf \"Strictly_positive_float : (x > 0.) : x=%f\" x));
 
 * Negative_float : float  
-  assert (x <= 0.) ; 
+  if not (x <= 0.) then
+    raise (Invalid_argument (Printf.sprintf \"Negative_float : (x <= 0.) : x=%f\" x));
 
 * Strictly_negative_float : float  
-  assert (x < 0.) ; 
+  if not (x < 0.) then
+    raise (Invalid_argument (Printf.sprintf \"Strictly_negative_float : (x < 0.) : x=%f\" x)); 
 
 * Positive_int64 : int64
-  assert (x >= 0L) ; 
+  if not (x >= 0L) then
+    raise (Invalid_argument (Printf.sprintf \"Positive_int64 : (x >= 0L) : x=%s\" (Int64.to_string x))); 
 
 * Positive_int : int  
-  assert (x >= 0) ; 
+  if not (x >= 0) then
+    raise (Invalid_argument (Printf.sprintf \"Positive_int : (x >= 0) : x=%d\" x)); 
 
 * Strictly_positive_int : int  
-  assert (x > 0) ; 
+  if not (x > 0) then
+    raise (Invalid_argument (Printf.sprintf \"Strictly_positive_int : (x > 0) : x=%d\" x)); 
 
 * Negative_int : int  
-  assert (x <= 0) ; 
+  if not (x <= 0) then
+    raise (Invalid_argument (Printf.sprintf \"Negative_int : (x <= 0) : x=%d\" x)); 
 
 * Det_coef : float
-  assert (x >= -1.) ; 
-  assert (x <=  1.) ; 
+  if (x < -1.) || (x > 1.) then
+    raise (Invalid_argument (Printf.sprintf \"Det_coef : (-1. <= x <= 1.) : x=%f\" x)); 
 
 * Normalized_float : float
-  assert (x <= 1.) ; 
-  assert (x >= 0.) ; 
+  if (x < 0.) || (x > 1.) then
+    raise (Invalid_argument (Printf.sprintf \"Normalized_float : (0. <= x <= 1.) : x=%f\" x)); 
 
 * Strictly_negative_int : int  
-  assert (x < 0) ; 
+  if not (x < 0) then
+    raise (Invalid_argument (Printf.sprintf \"Strictly_negative_int : (x < 0) : x=%d\" x)); 
 
 * Non_empty_string : string
-  assert (x <> \"\") ;
+  if (x = \"\") then
+    raise (Invalid_argument \"Non_empty_string\");
 
 
 * Det_number_max : int 
@@ -53,13 +63,13 @@ let input_data = "
 * Bit_kind_size : int  
   begin match x with
   | 8 | 16 | 32 | 64 -> ()
-  | _ -> raise (Failure \"Bit_kind_size should be (8|16|32|64).\")
+  | _ -> raise (Invalid_argument \"Bit_kind_size should be (8|16|32|64).\")
   end;
 
 * Bit_kind : int  
   begin match x with
   | 1 | 2 | 4 | 8 -> ()
-  | _ -> raise (Failure \"Bit_kind should be (1|2|4|8).\")
+  | _ -> raise (Invalid_argument \"Bit_kind should be (1|2|4|8).\")
   end;
 
 * Bitmask_number : int
@@ -68,12 +78,14 @@ let input_data = "
 * MO_coef : float
 
 * MO_occ : float
-  assert (x >= 0.); 
+  if (x < 0.) || (x > 2.) then
+    raise (Invalid_argument (Printf.sprintf \"MO_occ : (0. <= x <= 2.) : x=%f\" x)); 
 
 * AO_coef : float
 
 * AO_expo : float  
-  assert (x >= 0.) ; 
+  if (x < 0.) then
+    raise (Invalid_argument (Printf.sprintf \"AO_expo : (x >= 0.) : x=%f\" x)); 
 
 * AO_prim_number : int
   assert (x > 0) ;
@@ -165,7 +177,7 @@ end = struct
     match (String.lowercase s) with
     | \"huckel\" -> Huckel
     | \"hcore\"  -> HCore
-    | _ -> failwith (\"Wrong Guess type : \"^s)
+    | _ -> raise (Invalid_argument (\"Wrong Guess type : \"^s))
 
 end
 
@@ -189,7 +201,7 @@ end = struct
     | \"read\"  -> Read
     | \"write\" -> Write
     | \"none\"  -> None
-    | _ -> failwith (\"Wrong IO type : \"^s)
+    | _ -> raise (Invalid_argument (\"Wrong IO type : \"^s))
 
 end
 "
@@ -267,7 +279,9 @@ end = struct
       begin
         match max with
         | %s -> ()
-        | i  -> assert ( x <= i )
+        | i  ->
+          if ( x > i ) then
+            raise (Invalid_argument (Printf.sprintf \"%s: %%s\" (%s.to_string x) ))
       end ;
       x
     end
@@ -296,7 +310,7 @@ let parse_input_ezfio input=
         in
         Printf.sprintf ezfio_template 
           name typ typ typ typ typ typ typ typ (String.capitalize typ)
-          ezfio_func ezfio_func max min typ typ max msg min
+          ezfio_func ezfio_func max min typ typ max msg min name (String.capitalize typ)
       end
     | _ -> failwith "Error in input_ezfio"
   in

ocaml/test_gto.ml

@@ -1,13 +1,13 @@
-open Core.Std;;
-open Qptypes;;
+open Core.Std
+open Qptypes
 
 let test_prim () = 
   let p = 
-   { Primitive.sym  = Symmetry.P ; 
-     Primitive.expo = AO_expo.of_float 0.15} in
-  Primitive.to_string p
+   { GaussianPrimitive.sym  = Symmetry.P ; 
+     GaussianPrimitive.expo = AO_expo.of_float 0.15} in
+  GaussianPrimitive.to_string p
   |> print_string
-;;
+
   
 let test_gto_1 () =
   let in_channel = open_in "/home/scemama/quantum_package/data/basis/cc-pvdz" in
@@ -26,24 +26,23 @@ let test_gto_1 () =
     print_endline "gto3 = gto";
   if (gto3 = gto3) then
     print_endline "gto3 = gto3";
-  
-;;
+
 
 let test_gto_2 () =
   let in_channel = open_in "/home/scemama/quantum_package/data/basis/cc-pvdz" in
   ignore (input_line in_channel);
   let basis = Basis.read in_channel (Nucl_number.of_int 1) in
   List.iter basis ~f:(fun (x,n)-> Printf.printf "%d:%s\n" (Nucl_number.to_int n) (Gto.to_string x))
-;;
+
 
 let test_gto () =
   let in_channel = open_in "/home/scemama/quantum_package/data/basis/cc-pvdz" in
   let basis = Basis.read_element in_channel (Nucl_number.of_int 1) Element.C in
   List.iter basis ~f:(fun (x,n)-> Printf.printf "%d:%s\n" (Nucl_number.to_int n) (Gto.to_string x))
-;;
+
 
 let test_module () =
   test_gto_1()
-;;
 
-test_module ();;
+
+test_module ()

plugins/CAS_SD_ZMQ/selection_cassd_slave.irp.f

@@ -1,11 +1,12 @@
-program selection_slave
+program prog_selection_slave
   implicit none
   BEGIN_DOC
 ! Helper program to compute the PT2 in distributed mode.
   END_DOC
 
   read_wf = .False.
-  SOFT_TOUCH read_wf
+  distributed_davidson = .False.
+  SOFT_TOUCH read_wf distributed_davidson
   call provide_everything
   call switch_qp_run_to_master
   call run_wf
@@ -23,19 +24,21 @@ 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)
-  character*(64) :: states(1)
+  character*(64) :: states(4)
   integer :: rc, i
   
   call provide_everything
   
   zmq_context = f77_zmq_ctx_new ()
   states(1) = 'selection'
+  states(2) = 'davidson'
+  states(3) = 'pt2'
 
   zmq_to_qp_run_socket = new_zmq_to_qp_run_socket()
 
   do
 
-    call wait_for_states(states,zmq_state,1)
+    call wait_for_states(states,zmq_state,4)
 
     if(trim(zmq_state) == 'Stopped') then
 
@@ -51,43 +54,40 @@ subroutine run_wf
   
       !$OMP PARALLEL PRIVATE(i)
       i = omp_get_thread_num()
-      call selection_slave_tcp(i, energy)
+      call run_selection_slave(0, i, energy)
       !$OMP END PARALLEL
       print *,  'Selection done'
 
+    else if (trim(zmq_state) == 'davidson') then
+
+      ! Davidson
+      ! --------
+
+      print *,  'Davidson'
+      call zmq_get_psi(zmq_to_qp_run_socket,1,energy,N_states)
+      call omp_set_nested(.True.)
+      call davidson_slave_tcp(0)
+      call omp_set_nested(.False.)
+      print *,  'Davidson done'
+
+    else if (trim(zmq_state) == 'pt2') then
+
+      ! PT2
+      ! ---
+
+      print *,  'PT2'
+      call zmq_get_psi(zmq_to_qp_run_socket,1,energy,N_states)
+  
+      !$OMP PARALLEL PRIVATE(i)
+      i = omp_get_thread_num()
+      call run_selection_slave(0, i, energy)
+      !$OMP END PARALLEL
+      print *,  'PT2 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/Full_CI/jmmrpt2.irp.f

@@ -1,29 +0,0 @@
-program pouet
-  implicit none
-  integer                        :: i,k
-
-
-  double precision, allocatable  :: pt2(:), norm_pert(:), H_pert_diag(:)
-  integer                        :: N_st, degree
-  N_st = N_states
-  allocate (pt2(N_st), norm_pert(N_st),H_pert_diag(N_st))
-  character*(64)                 :: perturbation
-  double precision :: i_H_psi_array(N_states),diag_H_mat_elem,h,i_O1_psi_array(N_states)
-  double precision :: E_CI_before(N_states)
-  integer :: n_det_before
-  threshold_generators = threshold_generators_pt2
-  threshold_selectors = threshold_selectors_pt2
-  SOFT_TOUCH threshold_generators threshold_selectors
-  call H_apply_FCI_PT2_new(pt2, norm_pert, H_pert_diag,  N_st)
-
-  print *,  'Final step'
-  print *,  'N_det    = ', N_det
-  print *,  'N_states = ', N_states
-  print *,  'PT2      = ', pt2
-  print *,  'E        = ', CI_energy(1:N_states)
-  print *,  'E+PT2    = ', CI_energy(1:N_states)+pt2(1:N_states)
-  print *,  '-----'
-  call ezfio_set_full_ci_energy_pt2(CI_energy(1)+pt2(1))
-  deallocate(pt2,norm_pert)
-end
-

plugins/Full_CI_ZMQ/pt2_stoch_routines.irp.f

@@ -167,7 +167,7 @@ subroutine pt2_collector(E, b, tbc, comb, Ncomb, computed, pt2_detail, sumabove,
   double precision, allocatable :: val(:)
   integer(bit_kind), allocatable :: det(:,:,:)
   integer, allocatable :: task_id(:)
-  integer :: done, Nindex
+  integer :: Nindex
   integer, allocatable :: index(:)
   double precision, save :: time0 = -1.d0
   double precision :: time, timeLast, Nabove_old
@@ -249,11 +249,6 @@ subroutine pt2_collector(E, b, tbc, comb, Ncomb, computed, pt2_detail, sumabove,
       if(Nabove(1) < 5d0) cycle
       call get_first_tooth(actually_computed, tooth)
      
-      done = 0
-      do i=first_det_of_teeth(tooth), first_det_of_teeth(tooth+1)-1
-        if(actually_computed(i)) done = done + 1
-      end do
-
       E0 = sum(pt2_detail(1,:first_det_of_teeth(tooth)-1))
       if (tooth <= comb_teeth) then
         prop = ((1d0 - dfloat(comb_teeth - tooth + 1) * comb_step) - pt2_cweight(first_det_of_teeth(tooth)-1))
@@ -273,11 +268,9 @@ subroutine pt2_collector(E, b, tbc, comb, Ncomb, computed, pt2_detail, sumabove,
       else
         if (Nabove(tooth) > Nabove_old) then
           print '(G10.3, 2X, F16.10, 2X, G16.3, 2X, F16.4, A20)', Nabove(tooth), avg+E, eqt, time-time0, ''
-!print "(4(G23.13), 4(I9))", time - time0, avg, eqt, Nabove(tooth), tooth, first_det_of_teeth(tooth)-1, done, first_det_of_teeth(tooth+1)-first_det_of_teeth(tooth)
           Nabove_old = Nabove(tooth)
         endif
       endif
-!print "(4(G22.13), 4(I9))", time - time0, avg, eqt, Nabove(tooth), tooth, first_det_of_teeth(tooth)-1, done, first_det_of_teeth(tooth+1)-first_det_of_teeth(tooth)
     end if
   end do pullLoop
 
@@ -352,27 +345,6 @@ subroutine get_first_tooth(computed, first_teeth)
 end subroutine
 
 
-subroutine get_last_full_tooth(computed, last_tooth)
-  implicit none
-  logical, intent(in) :: computed(N_det_generators)
-  integer, intent(out) :: last_tooth
-  integer :: i, j, missing
-  
-  last_tooth = 0
-   combLoop : do i=comb_teeth, 1, -1
-     missing = 1+ ishft(first_det_of_teeth(i+1)-first_det_of_teeth(i),-4) ! /16
-     do j=first_det_of_teeth(i), first_det_of_teeth(i+1)-1
-       if(.not.computed(j)) then
-         missing -= 1
-         if(missing < 0) cycle combLoop
-       end if
-     end do
-     last_tooth = i
-     exit
-   end do combLoop
-end subroutine
-
-
 BEGIN_PROVIDER [ integer, size_tbc ]
   implicit none
   BEGIN_DOC
@@ -410,52 +382,6 @@ subroutine get_carlo_workbatch(computed, comb, Ncomb, tbc)
 end subroutine
 
 
-subroutine get_filling_teeth(computed, tbc)
-  implicit none
-  integer, intent(inout) :: tbc(0:size_tbc)
-  logical, intent(inout) :: computed(N_det_generators)
-  integer :: i, j, k, last_full, dets(comb_teeth)
- 
-  call get_last_full_tooth(computed, last_full)
-  if(last_full /= 0) then
-    if (tbc(0) > size(tbc) - first_det_of_teeth(last_full+1) -2) then
-      return
-    endif
-    k = tbc(0)+1
-    do j=1,first_det_of_teeth(last_full+1)-1
-      if(.not.(computed(j))) then
-        tbc(k) = j
-        k=k+1
-        computed(j) = .true.
-      end if
-    end do
-    tbc(0) = k-1
-  end if
-
-end subroutine
-
-
-subroutine reorder_tbc(tbc)
-  implicit none
-  integer, intent(inout) :: tbc(0:size_tbc)
-  logical, allocatable :: ltbc(:)
-  integer :: i, ci
-
-  allocate(ltbc(size_tbc))
-  ltbc(:) = .false.
-  do i=1,tbc(0)
-    ltbc(tbc(i)) = .true.
-  end do
-
-  ci = 0
-  do i=1,size_tbc
-    if(ltbc(i)) then
-      ci = ci+1
-      tbc(ci) = i
-    end if
-  end do
-end subroutine
-
 
 subroutine get_comb(stato, dets, ct)
   implicit none
@@ -545,6 +471,7 @@ end subroutine
     end if
     norm_left -= pt2_weight(i)
   end do
+  first_det_of_comb = max(1,first_det_of_comb)
   call write_int(6, first_det_of_comb-1, 'Size of deterministic set')
   
   comb_step =  (1d0 - pt2_cweight(first_det_of_comb-1)) * comb_step

plugins/Full_CI_ZMQ/selection.irp.f

@@ -31,16 +31,6 @@ double precision function integral8(i,j,k,l)
 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_det_sorted(1,1,i), psi_phasemask(1,1,i))
-  end do
-END_PROVIDER
-
 
 subroutine assert(cond, msg)
   character(*), intent(in) :: msg
@@ -56,19 +46,23 @@ 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(2,N_int*bit_kind_size)
-  integer :: s, ni, i
-  logical :: change
-
+  
+  integer(bit_kind), intent(in)  :: det(N_int, 2)
+  integer, intent(out)        :: phasemask(2,N_int*bit_kind_size)
+  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(s, (ni-1)*bit_kind_size + i + 1) = 1_1
+        if(BTEST(det(ni, s), i)) then
+          change = .not. change
+        endif
+        if(change) then
+          phasemask(s, ishft(ni-1,bit_kind_shift) + i + 1) = 1_1
+        endif
       end do
     end do
   end do
@@ -111,10 +105,10 @@ double precision function get_phase_bi(phasemask, s1, s2, h1, p1, h2, p2)
   use bitmasks
   implicit none
 
-  integer(1), intent(in) :: phasemask(2,*)
+  integer, intent(in) :: phasemask(2,*)
   integer, intent(in) :: s1, s2, h1, h2, p1, p2
   logical :: change
-  integer(1) :: np1
+  integer :: np1
   integer :: np
   double precision, save :: res(0:1) = (/1d0, -1d0/)
 
@@ -134,7 +128,7 @@ subroutine get_m2(gen, phasemask, bannedOrb, vect, mask, h, p, sp, coefs)
   implicit none
   
   integer(bit_kind), intent(in) :: gen(N_int, 2), mask(N_int, 2)
-  integer(1), intent(in) :: phasemask(2,N_int*bit_kind_size)
+  integer, intent(in) :: phasemask(2,N_int*bit_kind_size)
   logical, intent(in) :: bannedOrb(mo_tot_num)
   double precision, intent(in) :: coefs(N_states)
   double precision, intent(inout) :: vect(N_states, mo_tot_num)
@@ -193,7 +187,7 @@ subroutine get_m1(gen, phasemask, bannedOrb, vect, mask, h, p, sp, coefs)
   implicit none
   
   integer(bit_kind), intent(in)  :: gen(N_int, 2), mask(N_int, 2)
-  integer(1), intent(in)         :: phasemask(2,N_int*bit_kind_size)
+  integer, intent(in)         :: phasemask(2,N_int*bit_kind_size)
   logical, intent(in)            :: bannedOrb(mo_tot_num)
   double precision, intent(in)   :: coefs(N_states)
   double precision, intent(inout) :: vect(N_states, mo_tot_num)
@@ -225,32 +219,32 @@ subroutine get_m1(gen, phasemask, bannedOrb, vect, mask, h, p, sp, coefs)
       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
+      vect(1:N_states,i) += hij * coefs(1:N_states)
     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
+      vect(1:N_states,i) += hij * coefs(1:N_states)
     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
+    vect(1:N_states, p2) += hij * coefs(1:N_states)
   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
+      vect(1:N_states,i) += hij * coefs(1:N_states)
     end do
   end if
   deallocate(lbanned)
 
   call apply_particle(mask, sp, p1, det, ok,  N_int)
   call i_h_j(gen, det, N_int, hij)
-  vect(:, p1) += hij * coefs
+  vect(1:N_states, p1) += hij * coefs(1:N_states)
 end 
 
 
@@ -259,7 +253,7 @@ subroutine get_m0(gen, phasemask, bannedOrb, vect, mask, h, p, sp, coefs)
   implicit none
   
   integer(bit_kind), intent(in)  :: gen(N_int, 2), mask(N_int, 2)
-  integer(1), intent(in)         :: phasemask(2,N_int*bit_kind_size)
+  integer, intent(in)         :: phasemask(2,N_int*bit_kind_size)
   logical, intent(in)            :: bannedOrb(mo_tot_num)
   double precision, intent(in)   :: coefs(N_states)
   double precision, intent(inout) :: vect(N_states, mo_tot_num)
@@ -278,7 +272,7 @@ subroutine get_m0(gen, phasemask, bannedOrb, vect, mask, h, p, sp, coefs)
     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
+    vect(1:N_states, i) += hij * coefs(1:N_states)
   end do
   deallocate(lbanned)
 end 
@@ -312,6 +306,9 @@ subroutine select_singles_and_doubles(i_generator,hole_mask,particle_mask,fock_d
   logical :: monoAdo, monoBdo
   integer :: maskInd
 
+  integer(bit_kind), allocatable:: preinteresting_det(:,:,:)
+  allocate (preinteresting_det(N_int,2,N_det))
+
   PROVIDE fragment_count
 
   monoAdo = .true.
@@ -336,17 +333,18 @@ subroutine select_singles_and_doubles(i_generator,hole_mask,particle_mask,fock_d
   integer, allocatable :: indices(:), exc_degree(:), iorder(:)
   allocate (indices(N_det),  &
             exc_degree(max(N_det_alpha_unique,N_det_beta_unique)))
-  k=1
-  do i=1,N_det_alpha_unique
-    call get_excitation_degree_spin(psi_det_alpha_unique(1,i), &
-      psi_det_generators(1,1,i_generator), exc_degree(i), N_int)
-  enddo
 
   PROVIDE psi_bilinear_matrix_columns_loc psi_det_alpha_unique psi_det_beta_unique
   PROVIDE psi_bilinear_matrix_rows psi_det_sorted_order psi_bilinear_matrix_order
   PROVIDE psi_bilinear_matrix_transp_rows_loc psi_bilinear_matrix_transp_columns
   PROVIDE psi_bilinear_matrix_transp_order
 
+  k=1
+  do i=1,N_det_alpha_unique
+    call get_excitation_degree_spin(psi_det_alpha_unique(1,i), &
+      psi_det_generators(1,1,i_generator), exc_degree(i), N_int)
+  enddo
+
   do j=1,N_det_beta_unique
     call get_excitation_degree_spin(psi_det_beta_unique(1,j), &
       psi_det_generators(1,2,i_generator), nt, N_int)
@@ -415,6 +413,10 @@ subroutine select_singles_and_doubles(i_generator,hole_mask,particle_mask,fock_d
       if(i <= N_det_selectors) then
         preinteresting(0) += 1
         preinteresting(preinteresting(0)) = i
+        do j=1,N_int
+          preinteresting_det(j,1,preinteresting(0)) = psi_det_sorted(j,1,i)
+          preinteresting_det(j,2,preinteresting(0)) = psi_det_sorted(j,2,i)
+        enddo
       else if(nt <= 2) then
         prefullinteresting(0) += 1
         prefullinteresting(prefullinteresting(0)) = i
@@ -441,35 +443,36 @@ subroutine select_singles_and_doubles(i_generator,hole_mask,particle_mask,fock_d
       
       do ii=1,preinteresting(0)
         i = preinteresting(ii)
-        mobMask(1,1) = iand(negMask(1,1), psi_det_sorted(1,1,preinteresting(ii)))
-        mobMask(1,2) = iand(negMask(1,2), psi_det_sorted(1,2,preinteresting(ii)))
+        mobMask(1,1) = iand(negMask(1,1), preinteresting_det(1,1,ii))
+        mobMask(1,2) = iand(negMask(1,2), preinteresting_det(1,2,ii))
         nt = popcnt(mobMask(1, 1)) + popcnt(mobMask(1, 2))
         do j=2,N_int
-          mobMask(j,1) = iand(negMask(j,1), psi_det_sorted(1,1,preinteresting(ii)))
-          mobMask(j,2) = iand(negMask(j,2), psi_det_sorted(1,2,preinteresting(ii)))
+          mobMask(j,1) = iand(negMask(j,1), preinteresting_det(j,1,ii))
+          mobMask(j,2) = iand(negMask(j,2), preinteresting_det(j,2,ii))
           nt = nt+ popcnt(mobMask(j, 1)) + popcnt(mobMask(j, 2))
         end do
         
-        if(nt <= 4) then
-          interesting(0) += 1
-          interesting(interesting(0)) = i
-          minilist(1,1,interesting(0)) = psi_det_sorted(1,1,preinteresting(ii))
-          minilist(1,2,interesting(0)) = psi_det_sorted(1,2,preinteresting(ii))
-          do j=2,N_int
-            minilist(j,1,interesting(0)) = psi_det_sorted(1,1,preinteresting(ii))
-            minilist(j,2,interesting(0)) = psi_det_sorted(1,2,preinteresting(ii))
-          enddo
-          if(nt <= 2) then
-            fullinteresting(0) += 1
-            fullinteresting(fullinteresting(0)) = i
-            fullminilist(1,1,fullinteresting(0)) = psi_det_sorted(1,1,preinteresting(ii))
-            fullminilist(1,2,fullinteresting(0)) = psi_det_sorted(1,2,preinteresting(ii))
-            do j=2,N_int
-              fullminilist(j,1,fullinteresting(0)) = psi_det_sorted(1,1,preinteresting(ii))
-              fullminilist(j,2,fullinteresting(0)) = psi_det_sorted(1,2,preinteresting(ii))
-            enddo
-          end if
-        end if
+         if(nt <= 4) then
+           interesting(0) += 1
+           interesting(interesting(0)) = i
+          minilist(1,1,interesting(0)) = preinteresting_det(1,1,ii)
+          minilist(1,2,interesting(0)) = preinteresting_det(1,2,ii)
+           do j=2,N_int
+            minilist(j,1,interesting(0)) = preinteresting_det(j,1,ii)
+            minilist(j,2,interesting(0)) = preinteresting_det(j,2,ii)
+           enddo
+           if(nt <= 2) then
+             fullinteresting(0) += 1
+             fullinteresting(fullinteresting(0)) = i
+            fullminilist(1,1,fullinteresting(0)) = preinteresting_det(1,1,ii)
+            fullminilist(1,2,fullinteresting(0)) = preinteresting_det(1,2,ii)
+             do j=2,N_int
+              fullminilist(j,1,fullinteresting(0)) = preinteresting_det(j,1,ii)
+              fullminilist(j,2,fullinteresting(0)) = preinteresting_det(j,2,ii)
+             enddo
+           end if
+         end if
+
       end do
       
       do ii=1,prefullinteresting(0)
@@ -626,13 +629,14 @@ subroutine splash_pq(mask, sp, det, i_gen, N_sel, bannedOrb, banned, mat, intere
   integer(bit_kind),intent(in)   :: mask(N_int, 2), det(N_int, 2, N_sel)
   logical, intent(inout)         :: bannedOrb(mo_tot_num, 2), banned(mo_tot_num, mo_tot_num, 2)
   double precision, intent(inout) :: mat(N_states, mo_tot_num, mo_tot_num)
-
-  integer :: i, ii, j, k, l, h(0:2,2), p(0:4,2), nt
-  integer(bit_kind) :: perMask(N_int, 2), mobMask(N_int, 2), negMask(N_int, 2)
+  
+  integer                        :: i, ii, j, k, l, h(0:2,2), p(0:4,2), nt
+  integer(bit_kind)              :: perMask(N_int, 2), mobMask(N_int, 2), negMask(N_int, 2)
+  integer                     :: phasemask(2,N_int*bit_kind_size)
 !   logical :: bandon
 !   
 !   bandon = .false.
-  PROVIDE psi_phasemask psi_selectors_coef_transp
+  PROVIDE psi_selectors_coef_transp
   mat = 0d0
   
   do i=1,N_int
@@ -691,12 +695,13 @@ subroutine splash_pq(mask, sp, det, i_gen, N_sel, bannedOrb, banned, mat, intere
     call bitstring_to_list_in_selection(perMask(1,2), h(1,2), h(0,2), N_int)
 
     if (interesting(i) >= i_gen) then
+        call get_mask_phase(psi_det_sorted(1,1,interesting(i)), phasemask)
         if(nt == 4) then
-          call get_d2(det(1,1,i), psi_phasemask(1,1,interesting(i)), bannedOrb, banned, mat, mask, h, p, sp, psi_selectors_coef_transp(1, interesting(i)))
+          call get_d2(det(1,1,i), phasemask, bannedOrb, banned, mat, mask, h, p, sp, psi_selectors_coef_transp(1, interesting(i)))
         else if(nt == 3) then
-          call get_d1(det(1,1,i), psi_phasemask(1,1,interesting(i)), bannedOrb, banned, mat, mask, h, p, sp, psi_selectors_coef_transp(1, interesting(i)))
+          call get_d1(det(1,1,i), phasemask, bannedOrb, banned, mat, mask, h, p, sp, psi_selectors_coef_transp(1, interesting(i)))
         else
-          call get_d0(det(1,1,i), psi_phasemask(1,1,interesting(i)), bannedOrb, banned, mat, mask, h, p, sp, psi_selectors_coef_transp(1, interesting(i)))
+          call get_d0(det(1,1,i), phasemask, bannedOrb, banned, mat, mask, h, p, sp, psi_selectors_coef_transp(1, interesting(i)))
         end if
     else 
         if(nt == 4) call past_d2(banned, p, sp)
@@ -711,7 +716,7 @@ subroutine get_d2(gen, phasemask, bannedOrb, banned, mat, mask, h, p, sp, coefs)
   implicit none
 
   integer(bit_kind), intent(in) :: mask(N_int, 2), gen(N_int, 2)
-  integer(1), intent(in) :: phasemask(2,N_int*bit_kind_size)
+  integer, intent(in) :: phasemask(2,N_int*bit_kind_size)
   logical, intent(in) :: bannedOrb(mo_tot_num, 2), banned(mo_tot_num, mo_tot_num,2)
   double precision, intent(in) :: coefs(N_states)
   double precision, intent(inout) :: mat(N_states, mo_tot_num, mo_tot_num)
@@ -829,7 +834,7 @@ subroutine get_d1(gen, phasemask, bannedOrb, banned, mat, mask, h, p, sp, coefs)
   implicit none
 
   integer(bit_kind), intent(in)  :: mask(N_int, 2), gen(N_int, 2)
-  integer(1),intent(in)          :: phasemask(2,N_int*bit_kind_size)
+  integer,intent(in)          :: phasemask(2,N_int*bit_kind_size)
   logical, intent(in)            :: bannedOrb(mo_tot_num, 2), banned(mo_tot_num, mo_tot_num,2)
   integer(bit_kind)              :: det(N_int, 2)
   double precision, intent(in)   :: coefs(N_states)
@@ -1001,7 +1006,7 @@ subroutine get_d0(gen, phasemask, bannedOrb, banned, mat, mask, h, p, sp, coefs)
   implicit none
 
   integer(bit_kind), intent(in) :: gen(N_int, 2), mask(N_int, 2)
-  integer(1), intent(in) :: phasemask(2,N_int*bit_kind_size)
+  integer, intent(in) :: phasemask(2,N_int*bit_kind_size)
   logical, intent(in) :: bannedOrb(mo_tot_num, 2), banned(mo_tot_num, mo_tot_num,2)
   integer(bit_kind) :: det(N_int, 2)
   double precision, intent(in) :: coefs(N_states)

plugins/Full_CI_ZMQ/selection_davidson_slave.irp.f

@@ -19,13 +19,14 @@ 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(4)
-  integer :: rc, i
+  integer :: rc, i, ierr
   
   call provide_everything
   

plugins/Full_CI_ZMQ/selection_slave.irp.f

@@ -5,7 +5,8 @@ program selection_slave
   END_DOC
 
   read_wf = .False.
-  SOFT_TOUCH read_wf
+  distributed_davidson = .False.
+  SOFT_TOUCH read_wf distributed_davidson
   call provide_everything
   call switch_qp_run_to_master
   call run_wf
@@ -13,7 +14,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 fragment_count
+  PROVIDE pt2_e0_denominator mo_tot_num N_int fragment_count 
 end
 
 subroutine run_wf
@@ -23,19 +24,21 @@ 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)
-  character*(64) :: states(1)
+  character*(64) :: states(4)
   integer :: rc, i
   
   call provide_everything
   
   zmq_context = f77_zmq_ctx_new ()
   states(1) = 'selection'
+  states(2) = 'davidson'
+  states(3) = 'pt2'
 
   zmq_to_qp_run_socket = new_zmq_to_qp_run_socket()
 
   do
 
-    call wait_for_states(states,zmq_state,1)
+    call wait_for_states(states,zmq_state,3)
 
     if(trim(zmq_state) == 'Stopped') then
 
@@ -51,21 +54,30 @@ subroutine run_wf
   
       !$OMP PARALLEL PRIVATE(i)
       i = omp_get_thread_num()
-      call selection_slave_tcp(i, energy)
+      call run_selection_slave(0,i,energy)
       !$OMP END PARALLEL
       print *,  'Selection done'
 
+    else if (trim(zmq_state) == 'pt2') then
+
+      ! PT2
+      ! ---
+
+      print *,  'PT2'
+      call zmq_get_psi(zmq_to_qp_run_socket,1,energy,N_states)
+  
+      logical :: lstop
+      lstop = .False.
+      !$OMP PARALLEL PRIVATE(i)
+      i = omp_get_thread_num()
+      call run_pt2_slave(0,i,energy,lstop)
+      !$OMP END PARALLEL
+      print *,  'PT2 done'
+
     endif
 
   end do
 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/Full_CI_ZMQ/zmq_selection.irp.f

@@ -102,7 +102,7 @@ subroutine selection_collector(b, N, pt2)
 
   zmq_to_qp_run_socket = new_zmq_to_qp_run_socket()
   zmq_socket_pull = new_zmq_pull_socket()
-  call create_selection_buffer(N, N*8, b2)
+  call create_selection_buffer(N, N*2, b2)
   allocate(task_id(N_det_generators))
   more = 1
   pt2(:) = 0d0

plugins/Full_CI_ZMQ_MPI/NEEDED_CHILDREN_MODULES

@@ -0,0 +1 @@
+Full_CI_ZMQ MPI

plugins/Full_CI_ZMQ_MPI/README.rst

@@ -0,0 +1,14 @@
+===============
+Full_CI_ZMQ_MPI
+===============
+
+MPI Slave for Full_CI with ZMQ
+
+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/Full_CI_ZMQ_MPI/selection_davidson_slave_mpi.irp.f

@@ -0,0 +1,101 @@
+program selection_slave
+  implicit none
+  BEGIN_DOC
+! Helper program to compute the PT2 in distributed mode.
+  END_DOC
+
+  read_wf = .False.
+  distributed_davidson = .False.
+  SOFT_TOUCH read_wf distributed_davidson
+  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 fragment_count MPI_Initialized
+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(4)
+  integer :: rc, i, ierr
+  
+  call provide_everything
+  
+  zmq_context = f77_zmq_ctx_new ()
+  states(1) = 'selection'
+  states(2) = 'davidson'
+  states(3) = 'pt2'
+
+  zmq_to_qp_run_socket = new_zmq_to_qp_run_socket()
+
+  do
+
+    call wait_for_states(states,zmq_state,3)
+
+    if(trim(zmq_state) == 'Stopped') then
+
+      exit
+
+    else if (trim(zmq_state) == 'selection') then
+
+      ! Selection
+      ! ---------
+
+      print *,  'Selection'
+      if (is_mpi_master) then
+          call zmq_get_psi(zmq_to_qp_run_socket,1,energy,N_states)
+      endif
+      IRP_IF MIP
+        call MPI_BCAST(n,1,MPI_INTEGER,0,MPI_COMM_WORLD,ierr) 
+      IRP_ENDIF
+  
+      !$OMP PARALLEL PRIVATE(i)
+      i = omp_get_thread_num()
+      call run_selection_slave(0,i,energy)
+      !$OMP END PARALLEL
+      print *,  'Selection done'
+
+    else if (trim(zmq_state) == 'davidson') then
+
+      ! Davidson
+      ! --------
+
+      print *,  'Davidson'
+      call zmq_get_psi(zmq_to_qp_run_socket,1,energy,N_states)
+      call omp_set_nested(.True.)
+      call davidson_slave_tcp(0)
+      call omp_set_nested(.False.)
+      print *,  'Davidson done'
+
+    else if (trim(zmq_state) == 'pt2') then
+
+      ! PT2
+      ! ---
+
+      print *,  'PT2'
+      call zmq_get_psi(zmq_to_qp_run_socket,1,energy,N_states)
+  
+      logical :: lstop
+      lstop = .False.
+      !$OMP PARALLEL PRIVATE(i)
+      i = omp_get_thread_num()
+      call run_pt2_slave(0,i,energy,lstop)
+      !$OMP END PARALLEL
+      print *,  'PT2 done'
+
+    endif
+
+  end do
+end
+
+
+

plugins/Generators_CAS/generators.irp.f

@@ -14,9 +14,9 @@ BEGIN_PROVIDER [ integer, N_det_generators ]
       good = .True.
       do k=1,N_int
         good = good .and. (                                          &
-            iand(not(cas_bitmask(k,1,l)), psi_det(k,1,i)) ==         &
+            iand(not(cas_bitmask(k,1,l)), psi_det_sorted(k,1,i)) ==         &
             iand(not(cas_bitmask(k,1,l)), HF_bitmask(k,1)) ) .and. ( &
-            iand(not(cas_bitmask(k,2,l)), psi_det(k,2,i)) ==         &
+            iand(not(cas_bitmask(k,2,l)), psi_det_sorted(k,2,i)) ==         &
             iand(not(cas_bitmask(k,2,l)), HF_bitmask(k,2)) )
       enddo
       if (good) then
@@ -46,9 +46,9 @@ END_PROVIDER
       good = .True.
       do k=1,N_int
         good = good .and. (                                         &
-            iand(not(cas_bitmask(k,1,l)), psi_det(k,1,i)) ==         &
+            iand(not(cas_bitmask(k,1,l)), psi_det_sorted(k,1,i)) ==         &
             iand(not(cas_bitmask(k,1,l)), HF_bitmask(k,1)) .and. (   &
-            iand(not(cas_bitmask(k,2,l)), psi_det(k,2,i)) ==         &
+            iand(not(cas_bitmask(k,2,l)), psi_det_sorted(k,2,i)) ==         &
             iand(not(cas_bitmask(k,2,l)), HF_bitmask(k,2) )) )
       enddo
       if (good) then
@@ -58,8 +58,8 @@ END_PROVIDER
     if (good) then
       m = m+1
       do k=1,N_int
-        psi_det_generators(k,1,m) = psi_det(k,1,i)
-        psi_det_generators(k,2,m) = psi_det(k,2,i)
+        psi_det_generators(k,1,m) = psi_det_sorted(k,1,i)
+        psi_det_generators(k,2,m) = psi_det_sorted(k,2,i)
       enddo
       psi_coef_generators(m,:) = psi_coef(m,:)
     endif

plugins/Hartree_Fock/DIIS.irp.f

@@ -0,0 +1,196 @@
+BEGIN_PROVIDER [ double precision, threshold_DIIS_nonzero ]
+ implicit none
+ BEGIN_DOC
+ ! If threshold_DIIS is zero, choose sqrt(thresh_scf)
+ END_DOC
+ if (threshold_DIIS == 0.d0) then
+   threshold_DIIS_nonzero = dsqrt(thresh_scf)
+ else
+   threshold_DIIS_nonzero = threshold_DIIS
+ endif
+ ASSERT (threshold_DIIS_nonzero >= 0.d0)
+
+END_PROVIDER
+
+BEGIN_PROVIDER [double precision, FPS_SPF_Matrix_AO, (AO_num, AO_num)]
+  implicit none
+  BEGIN_DOC
+  !   Commutator FPS - SPF
+  END_DOC
+  double precision, allocatable  :: scratch(:,:)
+  allocate(                                                          &
+      scratch(AO_num_align, AO_num)                                  &
+      )
+  
+  ! Compute FP
+  
+  call dgemm('N','N',AO_num,AO_num,AO_num,                           &
+      1.d0,                                                          &
+      Fock_Matrix_AO,Size(Fock_Matrix_AO,1),                         &
+      HF_Density_Matrix_AO,Size(HF_Density_Matrix_AO,1),             &
+      0.d0,                                                          &
+      scratch,Size(scratch,1))
+  
+  ! Compute FPS
+  
+  call dgemm('N','N',AO_num,AO_num,AO_num,                           &
+      1.d0,                                                          &
+      scratch,Size(scratch,1),                                       &
+      AO_Overlap,Size(AO_Overlap,1),                                 &
+      0.d0,                                                          &
+      FPS_SPF_Matrix_AO,Size(FPS_SPF_Matrix_AO,1))
+  
+  ! Compute SP
+  
+  call dgemm('N','N',AO_num,AO_num,AO_num,                           &
+      1.d0,                                                          &
+      AO_Overlap,Size(AO_Overlap,1),                                 &
+      HF_Density_Matrix_AO,Size(HF_Density_Matrix_AO,1),             &
+      0.d0,                                                          &
+      scratch,Size(scratch,1))
+  
+  ! Compute FPS - SPF
+  
+  call dgemm('N','N',AO_num,AO_num,AO_num,                           &
+      -1.d0,                                                         &
+      scratch,Size(scratch,1),                                       &
+      Fock_Matrix_AO,Size(Fock_Matrix_AO,1),                         &
+      1.d0,                                                          &
+      FPS_SPF_Matrix_AO,Size(FPS_SPF_Matrix_AO,1))
+
+END_PROVIDER
+
+bEGIN_PROVIDER [double precision, FPS_SPF_Matrix_MO, (mo_tot_num, mo_tot_num)]
+  implicit none
+  begin_doc 
+!   Commutator FPS - SPF in MO basis
+  end_doc
+  call ao_to_mo(FPS_SPF_Matrix_AO, size(FPS_SPF_Matrix_AO,1), &
+     FPS_SPF_Matrix_MO, size(FPS_SPF_Matrix_MO,1))
+END_PROVIDER
+
+
+ BEGIN_PROVIDER [ double precision, eigenvalues_Fock_matrix_AO, (AO_num) ]
+&BEGIN_PROVIDER [ double precision, eigenvectors_Fock_matrix_AO, (AO_num_align,AO_num) ]
+
+   BEGIN_DOC
+   ! Eigenvalues and eigenvectors of the Fock matrix over the AO basis
+   END_DOC
+
+   implicit none
+   
+   double precision, allocatable  :: scratch(:,:),work(:),Xt(:,:)
+   integer                        :: lwork,info
+   integer                        :: i,j
+   
+   lwork = 3*AO_num - 1
+   allocate(                                                         &
+       scratch(AO_num_align,AO_num),                                 &
+       work(lwork),                                                  &
+       Xt(AO_num,AO_num)                                             &
+       )
+ 
+! Calculate Xt
+
+  do i=1,AO_num
+    do j=1,AO_num
+      Xt(i,j) = X_Matrix_AO(j,i)
+    enddo
+  enddo
+
+! Calculate Fock matrix in orthogonal basis: F' = Xt.F.X
+
+  call dgemm('N','N',AO_num,AO_num,AO_num,     &
+       1.d0,                                   &
+       Fock_matrix_AO,size(Fock_matrix_AO,1),  &
+       X_Matrix_AO,size(X_Matrix_AO,1),        &
+       0.d0,                                   &
+       eigenvectors_Fock_matrix_AO,size(eigenvectors_Fock_matrix_AO,1))       
+
+  call dgemm('N','N',AO_num,AO_num,AO_num,                              &
+       1.d0,                                                            &
+       Xt,size(Xt,1),                                                   &
+       eigenvectors_Fock_matrix_AO,size(eigenvectors_Fock_matrix_AO,1), &
+       0.d0,                                                            &
+       scratch,size(scratch,1))
+     
+! Diagonalize F' to obtain eigenvectors in orthogonal basis C' and eigenvalues
+  
+   call dsyev('V','U',AO_num,       &
+        scratch,size(scratch,1),    &
+        eigenvalues_Fock_matrix_AO, &
+        work,lwork,info)
+ 
+   if(info /= 0) then
+     print *,  irp_here//' failed : ', info
+     stop 1
+   endif
+
+! Back-transform eigenvectors: C =X.C'
+
+  call dgemm('N','N',AO_num,AO_num,AO_num,     &
+       1.d0,                                   &
+       X_matrix_AO,size(X_matrix_AO,1),        &
+       scratch,size(scratch,1),                &
+       0.d0,                                   &
+       eigenvectors_Fock_matrix_AO,size(eigenvectors_Fock_matrix_AO,1))       
+   
+END_PROVIDER
+
+BEGIN_PROVIDER [ double precision, X_matrix_AO, (AO_num_align,AO_num) ]
+
+  BEGIN_DOC
+!   Matrix X = S^{-1/2} obtained by SVD
+  END_DOC
+
+  implicit none
+  
+  integer                         :: num_linear_dependencies
+  integer                         :: LDA, LDC
+  double precision, allocatable   :: U(:,:),Vt(:,:), D(:)
+  integer                         :: info, i, j, k
+ 
+  LDA = size(AO_overlap,1)
+  LDC = size(X_matrix_AO,1)
+ 
+  allocate(         &
+    U(LDC,AO_num),  &
+    Vt(LDA,AO_num), &
+    D(AO_num))
+
+  call svd(            &
+       AO_overlap,LDA, &
+       U,LDC,          &
+       D,              &
+       Vt,LDA,         &
+       AO_num,AO_num)
+
+  num_linear_dependencies = 0
+  do i=1,AO_num
+    print*,D(i)
+    if(abs(D(i)) <= threshold_overlap_AO_eigenvalues) then
+      D(i) = 0.d0
+      num_linear_dependencies += 1
+    else
+      ASSERT (D(i) > 0.d0)
+      D(i) = 1.d0/sqrt(D(i))
+    endif
+    do j=1,AO_num
+      X_matrix_AO(j,i) = 0.d0
+    enddo
+  enddo
+  write(*,*) 'linear dependencies',num_linear_dependencies
+!  stop
+
+  do k=1,AO_num
+    if(D(k) /= 0.d0) then
+      do j=1,AO_num
+        do i=1,AO_num
+          X_matrix_AO(i,j) = X_matrix_AO(i,j) + U(i,k)*D(k)*Vt(k,j)
+        enddo
+      enddo
+    endif
+  enddo
+  
+
+END_PROVIDER

plugins/Hartree_Fock/EZFIO.cfg

@@ -1,6 +1,24 @@
+[threshold_overlap_ao_eigenvalues]
+type: Threshold
+doc: Threshold on the magnitude of the smallest eigenvalues of the overlap matrix in the AO basis
+interface: ezfio,provider,ocaml
+default: 1.e-6
+
+[max_dim_diis]
+type: integer
+doc: Maximum size of the DIIS extrapolation procedure
+interface: ezfio,provider,ocaml
+default: 15
+
+[threshold_diis]
+type: Threshold
+doc: Threshold on the convergence of the DIIS error vector during a Hartree-Fock calculation. If 0. is chosen, the square root of thresh_scf will be used.
+interface: ezfio,provider,ocaml
+default: 0.
+
 [thresh_scf]
 type: Threshold
-doc: Threshold on the convergence of the Hartree Fock energy
+doc: Threshold on the convergence of the Hartree Fock energy. 
 interface: ezfio,provider,ocaml
 default: 1.e-10
 
@@ -8,13 +26,19 @@ default: 1.e-10
 type: Strictly_positive_int
 doc: Maximum number of SCF iterations
 interface: ezfio,provider,ocaml
-default: 200
+default: 500
 
 [level_shift]
 type: Positive_float
 doc: Energy shift on the virtual MOs to improve SCF convergence
 interface: ezfio,provider,ocaml
-default: 0.5
+default: 0.0
+
+[scf_algorithm]
+type: character*(32)
+doc: Type of SCF algorithm used. Possible choices are [ Simple | DIIS]
+interface: ezfio,provider,ocaml
+default: DIIS
 
 [mo_guess_type]
 type: MO_guess

plugins/Hartree_Fock/Fock_matrix.irp.f

@@ -18,57 +18,57 @@
    END_DOC
    integer                        :: i,j,n
    if (elec_alpha_num == elec_beta_num) then
-     Fock_matrix_mo = Fock_matrix_alpha_mo
+     Fock_matrix_mo = Fock_matrix_mo_alpha
    else
      
      do j=1,elec_beta_num
        ! F-K
        do i=1,elec_beta_num
-         Fock_matrix_mo(i,j) = 0.5d0*(Fock_matrix_alpha_mo(i,j)+Fock_matrix_beta_mo(i,j))&
-             - (Fock_matrix_beta_mo(i,j) - Fock_matrix_alpha_mo(i,j))
+         Fock_matrix_mo(i,j) = 0.5d0*(Fock_matrix_mo_alpha(i,j)+Fock_matrix_mo_beta(i,j))&
+             - (Fock_matrix_mo_beta(i,j) - Fock_matrix_mo_alpha(i,j))
        enddo
        ! F+K/2
        do i=elec_beta_num+1,elec_alpha_num
-         Fock_matrix_mo(i,j) = 0.5d0*(Fock_matrix_alpha_mo(i,j)+Fock_matrix_beta_mo(i,j))&
-             + 0.5d0*(Fock_matrix_beta_mo(i,j) - Fock_matrix_alpha_mo(i,j))
+         Fock_matrix_mo(i,j) = 0.5d0*(Fock_matrix_mo_alpha(i,j)+Fock_matrix_mo_beta(i,j))&
+             + 0.5d0*(Fock_matrix_mo_beta(i,j) - Fock_matrix_mo_alpha(i,j))
        enddo
        ! F
        do i=elec_alpha_num+1, mo_tot_num
-         Fock_matrix_mo(i,j) = 0.5d0*(Fock_matrix_alpha_mo(i,j)+Fock_matrix_beta_mo(i,j))
+         Fock_matrix_mo(i,j) = 0.5d0*(Fock_matrix_mo_alpha(i,j)+Fock_matrix_mo_beta(i,j))
        enddo
      enddo
 
      do j=elec_beta_num+1,elec_alpha_num
        ! F+K/2
        do i=1,elec_beta_num
-         Fock_matrix_mo(i,j) = 0.5d0*(Fock_matrix_alpha_mo(i,j)+Fock_matrix_beta_mo(i,j))&
-             + 0.5d0*(Fock_matrix_beta_mo(i,j) - Fock_matrix_alpha_mo(i,j))
+         Fock_matrix_mo(i,j) = 0.5d0*(Fock_matrix_mo_alpha(i,j)+Fock_matrix_mo_beta(i,j))&
+             + 0.5d0*(Fock_matrix_mo_beta(i,j) - Fock_matrix_mo_alpha(i,j))
        enddo
        ! F
        do i=elec_beta_num+1,elec_alpha_num
-         Fock_matrix_mo(i,j) = 0.5d0*(Fock_matrix_alpha_mo(i,j)+Fock_matrix_beta_mo(i,j))
+         Fock_matrix_mo(i,j) = 0.5d0*(Fock_matrix_mo_alpha(i,j)+Fock_matrix_mo_beta(i,j))
        enddo
        ! F-K/2
        do i=elec_alpha_num+1, mo_tot_num
-         Fock_matrix_mo(i,j) = 0.5d0*(Fock_matrix_alpha_mo(i,j)+Fock_matrix_beta_mo(i,j))&
-             - 0.5d0*(Fock_matrix_beta_mo(i,j) - Fock_matrix_alpha_mo(i,j))
+         Fock_matrix_mo(i,j) = 0.5d0*(Fock_matrix_mo_alpha(i,j)+Fock_matrix_mo_beta(i,j))&
+             - 0.5d0*(Fock_matrix_mo_beta(i,j) - Fock_matrix_mo_alpha(i,j))
        enddo
      enddo
 
      do j=elec_alpha_num+1, mo_tot_num
        ! F
        do i=1,elec_beta_num
-         Fock_matrix_mo(i,j) = 0.5d0*(Fock_matrix_alpha_mo(i,j)+Fock_matrix_beta_mo(i,j))
+         Fock_matrix_mo(i,j) = 0.5d0*(Fock_matrix_mo_alpha(i,j)+Fock_matrix_mo_beta(i,j))
        enddo
        ! F-K/2
        do i=elec_beta_num+1,elec_alpha_num
-         Fock_matrix_mo(i,j) = 0.5d0*(Fock_matrix_alpha_mo(i,j)+Fock_matrix_beta_mo(i,j))&
-             - 0.5d0*(Fock_matrix_beta_mo(i,j) - Fock_matrix_alpha_mo(i,j))
+         Fock_matrix_mo(i,j) = 0.5d0*(Fock_matrix_mo_alpha(i,j)+Fock_matrix_mo_beta(i,j))&
+             - 0.5d0*(Fock_matrix_mo_beta(i,j) - Fock_matrix_mo_alpha(i,j))
        enddo
        ! F+K
        do i=elec_alpha_num+1,mo_tot_num
-         Fock_matrix_mo(i,j) = 0.5d0*(Fock_matrix_alpha_mo(i,j)+Fock_matrix_beta_mo(i,j)) &
-             + (Fock_matrix_beta_mo(i,j) - Fock_matrix_alpha_mo(i,j))
+         Fock_matrix_mo(i,j) = 0.5d0*(Fock_matrix_mo_alpha(i,j)+Fock_matrix_mo_beta(i,j)) &
+             + (Fock_matrix_mo_beta(i,j) - Fock_matrix_mo_alpha(i,j))
        enddo
      enddo
      
@@ -81,8 +81,8 @@ END_PROVIDER
  
  
  
- BEGIN_PROVIDER [ double precision, Fock_matrix_alpha_ao, (ao_num_align, ao_num) ]
-&BEGIN_PROVIDER [ double precision, Fock_matrix_beta_ao,  (ao_num_align, ao_num) ]
+ BEGIN_PROVIDER [ double precision, Fock_matrix_ao_alpha, (ao_num_align, ao_num) ]
+&BEGIN_PROVIDER [ double precision, Fock_matrix_ao_beta,  (ao_num_align, ao_num) ]
  implicit none
  BEGIN_DOC
  ! Alpha Fock matrix in AO basis set
@@ -92,8 +92,8 @@ END_PROVIDER
  do j=1,ao_num
    !DIR$ VECTOR ALIGNED
    do i=1,ao_num
-     Fock_matrix_alpha_ao(i,j) = ao_mono_elec_integral(i,j) + ao_bi_elec_integral_alpha(i,j)
-     Fock_matrix_beta_ao (i,j) = ao_mono_elec_integral(i,j) + ao_bi_elec_integral_beta (i,j)
+     Fock_matrix_ao_alpha(i,j) = ao_mono_elec_integral(i,j) + ao_bi_elec_integral_alpha(i,j)
+     Fock_matrix_ao_beta (i,j) = ao_mono_elec_integral(i,j) + ao_bi_elec_integral_beta (i,j)
    enddo
  enddo
 
@@ -261,12 +261,7 @@ END_PROVIDER
 
 END_PROVIDER
 
-
-
-
-
-
-BEGIN_PROVIDER [ double precision, Fock_matrix_alpha_mo, (mo_tot_num_align,mo_tot_num) ]
+BEGIN_PROVIDER [ double precision, Fock_matrix_mo_alpha, (mo_tot_num_align,mo_tot_num) ]
    implicit none
    BEGIN_DOC
    ! Fock matrix on the MO basis
@@ -275,18 +270,18 @@ BEGIN_PROVIDER [ double precision, Fock_matrix_alpha_mo, (mo_tot_num_align,mo_to
    allocate ( T(ao_num_align,mo_tot_num) )
    !DIR$ ATTRIBUTES ALIGN : $IRP_ALIGN :: T
    call dgemm('N','N', ao_num, mo_tot_num, ao_num,                   &
-       1.d0, Fock_matrix_alpha_ao,size(Fock_matrix_alpha_ao,1),      &
+       1.d0, Fock_matrix_ao_alpha,size(Fock_matrix_ao_alpha,1),      &
        mo_coef, size(mo_coef,1),                                     &
        0.d0, T, ao_num_align)
    call dgemm('T','N', mo_tot_num, mo_tot_num, ao_num,               &
        1.d0, mo_coef,size(mo_coef,1),                                &
        T, size(T,1),                                                 &
-       0.d0, Fock_matrix_alpha_mo, mo_tot_num_align)
+       0.d0, Fock_matrix_mo_alpha, mo_tot_num_align)
    deallocate(T)
 END_PROVIDER
  
  
-BEGIN_PROVIDER [ double precision, Fock_matrix_beta_mo, (mo_tot_num_align,mo_tot_num) ]
+BEGIN_PROVIDER [ double precision, Fock_matrix_mo_beta, (mo_tot_num_align,mo_tot_num) ]
    implicit none
    BEGIN_DOC
    ! Fock matrix on the MO basis
@@ -295,13 +290,13 @@ BEGIN_PROVIDER [ double precision, Fock_matrix_beta_mo, (mo_tot_num_align,mo_tot
    allocate ( T(ao_num_align,mo_tot_num) )
    !DIR$ ATTRIBUTES ALIGN : $IRP_ALIGN :: T
    call dgemm('N','N', ao_num, mo_tot_num, ao_num,                   &
-       1.d0, Fock_matrix_beta_ao,size(Fock_matrix_beta_ao,1),        &
+       1.d0, Fock_matrix_ao_beta,size(Fock_matrix_ao_beta,1),        &
        mo_coef, size(mo_coef,1),                                     &
        0.d0, T, ao_num_align)
    call dgemm('T','N', mo_tot_num, mo_tot_num, ao_num,               &
        1.d0, mo_coef,size(mo_coef,1),                                &
        T, size(T,1),                                                 &
-       0.d0, Fock_matrix_beta_mo, mo_tot_num_align)
+       0.d0, Fock_matrix_mo_beta, mo_tot_num_align)
    deallocate(T)
 END_PROVIDER
  
@@ -316,8 +311,8 @@ BEGIN_PROVIDER [ double precision, HF_energy ]
  do j=1,ao_num
    do i=1,ao_num
      HF_energy += 0.5d0 * (                                          &
-         (ao_mono_elec_integral(i,j) + Fock_matrix_alpha_ao(i,j) ) *  HF_density_matrix_ao_alpha(i,j) +&
-         (ao_mono_elec_integral(i,j) + Fock_matrix_beta_ao (i,j) ) *  HF_density_matrix_ao_beta (i,j) )
+         (ao_mono_elec_integral(i,j) + Fock_matrix_ao_alpha(i,j) ) *  HF_density_matrix_ao_alpha(i,j) +&
+         (ao_mono_elec_integral(i,j) + Fock_matrix_ao_beta (i,j) ) *  HF_density_matrix_ao_beta (i,j) )
    enddo
  enddo
   
@@ -337,7 +332,7 @@ BEGIN_PROVIDER [ double precision, Fock_matrix_ao, (ao_num_align, ao_num) ]
    do j=1,ao_num
      !DIR$ VECTOR ALIGNED
      do i=1,ao_num_align
-       Fock_matrix_ao(i,j) = Fock_matrix_alpha_ao(i,j)
+       Fock_matrix_ao(i,j) = Fock_matrix_ao_alpha(i,j)
      enddo
    enddo
  else

plugins/Hartree_Fock/HF_density_matrix_ao.irp.f

@@ -1,4 +1,4 @@
-BEGIN_PROVIDER [ double precision, HF_density_matrix_ao_alpha, (ao_num_align,ao_num) ]
+BEGIN_PROVIDER [double precision, HF_density_matrix_ao_alpha, (ao_num_align,ao_num) ]
    implicit none
    BEGIN_DOC
    ! S^-1 x Alpha density matrix in the AO basis x S^-1

plugins/Hartree_Fock/Roothaan_Hall_SCF.irp.f

@@ -0,0 +1,283 @@
+subroutine Roothaan_Hall_SCF
+
+BEGIN_DOC
+! Roothaan-Hall algorithm for SCF Hartree-Fock calculation
+END_DOC
+
+  implicit none
+
+  double precision               :: energy_SCF,energy_SCF_previous,Delta_energy_SCF
+  double precision               :: max_error_DIIS,max_error_DIIS_alpha,max_error_DIIS_beta
+  double precision, allocatable  :: Fock_matrix_DIIS(:,:,:),error_matrix_DIIS(:,:,:)
+
+  integer                        :: iteration_SCF,dim_DIIS,index_dim_DIIS
+ 
+  integer                        :: i,j
+  double precision, allocatable :: mo_coef_save(:,:)
+ 
+  allocate(mo_coef_save(ao_num,mo_tot_num),                          &
+      Fock_matrix_DIIS (ao_num,ao_num,max_dim_DIIS),                 &
+      error_matrix_DIIS(ao_num,ao_num,max_dim_DIIS)                  &
+      )
+
+  call write_time(output_hartree_fock)
+
+  write(output_hartree_fock,'(A4, 1X, A16, 1X, A16, 1X, A16)')  &
+    '====','================','================','================'
+  write(output_hartree_fock,'(A4, 1X, A16, 1X, A16, 1X, A16)')  &
+    '  N ', 'Energy  ', 'Energy diff  ', 'DIIS error  '
+  write(output_hartree_fock,'(A4, 1X, A16, 1X, A16, 1X, A16)')  &
+    '====','================','================','================'
+
+! Initialize energies and density matrices
+
+  energy_SCF_previous = HF_energy
+  Delta_energy_SCF    = 1.d0
+  iteration_SCF       = 0
+  dim_DIIS            = 0
+  max_error_DIIS      = 1.d0
+
+
+!
+! Start of main SCF loop
+!
+  do while(( (max_error_DIIS > threshold_DIIS_nonzero).or.(dabs(Delta_energy_SCF) > thresh_SCF) ) .and. (iteration_SCF < n_it_SCF_max))
+
+! Increment cycle number
+
+    iteration_SCF += 1
+
+! Current size of the DIIS space
+
+    dim_DIIS = min(dim_DIIS+1,max_dim_DIIS)
+ 
+    if (scf_algorithm == 'DIIS') then
+      
+      ! Store Fock and error matrices at each iteration
+      do j=1,ao_num
+        do i=1,ao_num
+          index_dim_DIIS = mod(dim_DIIS-1,max_dim_DIIS)+1
+          Fock_matrix_DIIS (i,j,index_dim_DIIS) = Fock_matrix_AO(i,j)
+          error_matrix_DIIS(i,j,index_dim_DIIS) = FPS_SPF_matrix_AO(i,j)
+        enddo
+      enddo
+      
+      ! Compute the extrapolated Fock matrix
+
+      call extrapolate_Fock_matrix(                                    &
+          error_matrix_DIIS,Fock_matrix_DIIS,                          &
+          Fock_matrix_AO,size(Fock_matrix_AO,1),                       &
+          iteration_SCF,dim_DIIS                                       &
+          )
+
+      Fock_matrix_AO_alpha = Fock_matrix_AO*0.5d0
+      Fock_matrix_AO_beta  = Fock_matrix_AO*0.5d0
+      TOUCH Fock_matrix_AO_alpha Fock_matrix_AO_beta
+
+    endif
+
+    MO_coef = eigenvectors_Fock_matrix_MO
+
+    TOUCH MO_coef
+
+!   Calculate error vectors
+
+    max_error_DIIS = maxval(Abs(FPS_SPF_Matrix_MO))
+
+!   SCF energy
+
+    energy_SCF = HF_energy
+    Delta_Energy_SCF = energy_SCF - energy_SCF_previous
+    if ( (SCF_algorithm == 'DIIS').and.(Delta_Energy_SCF > 0.d0) ) then
+      Fock_matrix_AO(1:ao_num,1:ao_num) = Fock_matrix_DIIS (1:ao_num,1:ao_num,index_dim_DIIS)
+      Fock_matrix_AO_alpha = Fock_matrix_AO*0.5d0
+      Fock_matrix_AO_beta  = Fock_matrix_AO*0.5d0
+      TOUCH Fock_matrix_AO_alpha Fock_matrix_AO_beta
+    endif
+
+    double precision :: level_shift_save
+    level_shift_save = level_shift
+    mo_coef_save(1:ao_num,1:mo_tot_num) = mo_coef(1:ao_num,1:mo_tot_num)
+    do while (Delta_Energy_SCF > 0.d0)
+      mo_coef(1:ao_num,1:mo_tot_num) = mo_coef_save
+      TOUCH mo_coef
+      level_shift = level_shift + 0.1d0
+      mo_coef(1:ao_num,1:mo_tot_num) = eigenvectors_Fock_matrix_MO(1:ao_num,1:mo_tot_num)
+      TOUCH mo_coef level_shift
+      Delta_Energy_SCF = HF_energy - energy_SCF_previous
+      energy_SCF = HF_energy
+      if (level_shift-level_shift_save > 1.d0) exit
+      dim_DIIS=0
+    enddo
+    level_shift = level_shift_save
+    SOFT_TOUCH level_shift
+    energy_SCF_previous = energy_SCF
+
+!   Print results at the end of each iteration
+
+    write(output_hartree_fock,'(I4, 1X, F16.10, 1X, F16.10, 1X, F16.10, 1X, I3)')  &
+      iteration_SCF, energy_SCF, Delta_energy_SCF, max_error_DIIS, dim_DIIS
+
+    if (Delta_energy_SCF < 0.d0) then
+      call save_mos
+    endif
+
+  enddo
+
+!
+! End of Main SCF loop
+!
+
+  write(output_hartree_fock,'(A4, 1X, A16, 1X, A16, 1X, A16)') &
+    '====','================','================','================'
+  write(output_hartree_fock,*)
+  
+  if(.not.no_oa_or_av_opt)then
+   call mo_as_eigvectors_of_mo_matrix(Fock_matrix_mo,size(Fock_matrix_mo,1),size(Fock_matrix_mo,2),mo_label,1)
+  endif
+
+  call write_double(output_hartree_fock, Energy_SCF, 'Hartree-Fock energy')
+  call ezfio_set_hartree_fock_energy(Energy_SCF)
+
+  call write_time(output_hartree_fock)
+
+end
+
+subroutine extrapolate_Fock_matrix(      &   
+  error_matrix_DIIS,Fock_matrix_DIIS,    &
+  Fock_matrix_AO_,size_Fock_matrix_AO,   &
+  iteration_SCF,dim_DIIS                 &
+)
+
+BEGIN_DOC
+! Compute the extrapolated Fock matrix using the DIIS procedure
+END_DOC
+
+  implicit none
+
+  double precision,intent(in)   :: Fock_matrix_DIIS(ao_num,ao_num,*),error_matrix_DIIS(ao_num,ao_num,*)
+  integer,intent(in)            :: iteration_SCF, size_Fock_matrix_AO
+  double precision,intent(inout):: Fock_matrix_AO_(size_Fock_matrix_AO,ao_num)
+  integer,intent(inout)         :: dim_DIIS
+
+  double precision,allocatable  :: B_matrix_DIIS(:,:),X_vector_DIIS(:)
+  double precision,allocatable  :: C_vector_DIIS(:)
+
+  double precision,allocatable  :: scratch(:,:)
+  integer                       :: i,j,k,i_DIIS,j_DIIS
+
+  allocate(                               &
+    B_matrix_DIIS(dim_DIIS+1,dim_DIIS+1), &
+    X_vector_DIIS(dim_DIIS+1),            &
+    C_vector_DIIS(dim_DIIS+1),            &
+    scratch(ao_num,ao_num)                &
+  )
+
+! Compute the matrices B and X
+  do j=1,dim_DIIS
+    do i=1,dim_DIIS
+
+      j_DIIS = mod(iteration_SCF-j,max_dim_DIIS)+1
+      i_DIIS = mod(iteration_SCF-i,max_dim_DIIS)+1
+
+! Compute product of two errors vectors
+
+      call dgemm('N','N',ao_num,ao_num,ao_num,                      &
+           1.d0,                                                    &
+           error_matrix_DIIS(1,1,i_DIIS),size(error_matrix_DIIS,1), &
+           error_matrix_DIIS(1,1,j_DIIS),size(error_matrix_DIIS,1), &
+           0.d0,                                                    &
+           scratch,size(scratch,1))                                                  
+
+! Compute Trace
+
+      B_matrix_DIIS(i,j) = 0.d0
+      do k=1,ao_num
+        B_matrix_DIIS(i,j) = B_matrix_DIIS(i,j) + scratch(k,k)
+      enddo
+    enddo
+  enddo
+
+! Pad B matrix and build the X matrix
+
+  do i=1,dim_DIIS
+    B_matrix_DIIS(i,dim_DIIS+1) = -1.d0
+    B_matrix_DIIS(dim_DIIS+1,i) = -1.d0
+    C_vector_DIIS(i) = 0.d0
+  enddo
+  B_matrix_DIIS(dim_DIIS+1,dim_DIIS+1) = 0.d0
+  C_vector_DIIS(dim_DIIS+1) = -1.d0
+
+! Solve the linear system C = B.X
+
+  integer              :: info
+  integer,allocatable  :: ipiv(:)
+
+  allocate(          &
+    ipiv(dim_DIIS+1) &
+  )
+
+  double precision, allocatable :: AF(:,:) 
+  allocate (AF(dim_DIIS+1,dim_DIIS+1))
+  double precision :: rcond, ferr, berr
+  integer :: iwork(dim_DIIS+1), lwork
+  
+  call dsysvx('N','U',dim_DIIS+1,1,      &
+    B_matrix_DIIS,size(B_matrix_DIIS,1), &
+    AF, size(AF,1),                      &
+    ipiv,                                &
+    C_vector_DIIS,size(C_vector_DIIS,1), &
+    X_vector_DIIS,size(X_vector_DIIS,1), &
+    rcond,                               &
+    ferr,                                &
+    berr,                                &
+    scratch,-1,                          &
+    iwork,                               &
+    info                                 &
+  )
+  lwork = int(scratch(1,1))
+  deallocate(scratch)
+  allocate(scratch(lwork,1))
+
+  call dsysvx('N','U',dim_DIIS+1,1,      &
+    B_matrix_DIIS,size(B_matrix_DIIS,1), &
+    AF, size(AF,1),                      &
+    ipiv,                                &
+    C_vector_DIIS,size(C_vector_DIIS,1), &
+    X_vector_DIIS,size(X_vector_DIIS,1), &
+    rcond,                               &
+    ferr,                                &
+    berr,                                &
+    scratch,size(scratch),               &
+    iwork,                               &
+    info                                 &
+  )
+
+ if(info < 0) then
+   stop 'bug in DIIS'
+ endif
+
+ if (rcond > 1.d-12) then
+   
+  ! Compute extrapolated Fock matrix
+
+
+      !$OMP PARALLEL DO PRIVATE(i,j,k) DEFAULT(SHARED)
+      do j=1,ao_num
+        do i=1,ao_num
+          Fock_matrix_AO_(i,j) = 0.d0
+        enddo
+        do k=1,dim_DIIS
+          do i=1,ao_num
+            Fock_matrix_AO_(i,j) = Fock_matrix_AO_(i,j) +            &
+                X_vector_DIIS(k)*Fock_matrix_DIIS(i,j,dim_DIIS-k+1)
+          enddo
+        enddo
+      enddo
+      !$OMP END PARALLEL DO
+
+  else
+    dim_DIIS = 0
+  endif
+
+end

plugins/Hartree_Fock/SCF.irp.f

@@ -13,7 +13,7 @@ end
 subroutine create_guess
   implicit none
   BEGIN_DOC
-! Create an MO guess if no MOs are present in the EZFIO directory
+!   Create a MO guess if no MOs are present in the EZFIO directory
   END_DOC
   logical                        :: exists
   PROVIDE ezfio_filename
@@ -34,21 +34,30 @@ subroutine create_guess
   endif
 end
 
+ao_to_mo
 
 subroutine run
 
+  BEGIN_DOC
+!   Run SCF calculation
+  END_DOC
+
   use bitmasks
   implicit none
-  BEGIN_DOC
-! Run SCF calculation
-  END_DOC
+
   double precision               :: SCF_energy_before,SCF_energy_after,diag_H_mat_elem
-  double precision               :: E0
+  double precision               :: EHF
   integer                        :: i_it, i, j, k
    
-  E0 = HF_energy 
+  EHF = HF_energy 
 
   mo_label = "Canonical"
-  call damping_SCF
+
+! Choose SCF algorithm
+
+!    call damping_SCF   ! Deprecated routine
+  call Roothaan_Hall_SCF
   
 end
+
+

plugins/Hartree_Fock/damping_SCF.irp.f

@@ -114,7 +114,6 @@ subroutine damping_SCF
     mo_coef = eigenvectors_fock_matrix_mo
     TOUCH mo_coef
 
-
   enddo
   write(output_hartree_fock,'(A4,1X,A16, 1X, A16, 1X, A16, 1X, A4 )')  '====','================','================','================', '===='
   write(output_hartree_fock,*)

plugins/Hartree_Fock/diagonalize_fock.irp.f

@@ -10,85 +10,95 @@
    integer, allocatable           :: iwork(:)
    double precision, allocatable  :: work(:), F(:,:), S(:,:)
    
-
-       allocate( F(mo_tot_num_align,mo_tot_num) )
-       do j=1,mo_tot_num
-         do i=1,mo_tot_num
-           F(i,j) = Fock_matrix_mo(i,j)
-         enddo
+   
+   allocate( F(mo_tot_num,mo_tot_num) )
+   do j=1,mo_tot_num
+     do i=1,mo_tot_num
+       F(i,j) = Fock_matrix_mo(i,j)
+     enddo
+   enddo
+   if(no_oa_or_av_opt)then
+     integer                        :: iorb,jorb
+     do i = 1, n_act_orb
+       iorb = list_act(i)
+       do j = 1, n_inact_orb
+         jorb = list_inact(j)
+         F(iorb,jorb) = 0.d0
+         F(jorb,iorb) = 0.d0
        enddo
-       if(no_oa_or_av_opt)then
-        integer :: iorb,jorb
-        do i = 1, n_act_orb
-         iorb = list_act(i)
-         do j = 1, n_inact_orb
-          jorb = list_inact(j)
-          F(iorb,jorb) = 0.d0
-          F(jorb,iorb) = 0.d0
-         enddo
-         do j = 1, n_virt_orb
-          jorb = list_virt(j)
-          F(iorb,jorb) = 0.d0
-          F(jorb,iorb) = 0.d0
-         enddo
-         do j = 1, n_core_orb
-          jorb = list_core(j)
-          F(iorb,jorb) = 0.d0
-          F(jorb,iorb) = 0.d0
-         enddo
-        enddo
-       endif
-
-  
-       
-
-       ! Insert level shift here
-       do i = elec_beta_num+1, elec_alpha_num
-         F(i,i) += 0.5d0*level_shift
+       do j = 1, n_virt_orb
+         jorb = list_virt(j)
+         F(iorb,jorb) = 0.d0
+         F(jorb,iorb) = 0.d0
        enddo
-
-       do i = elec_alpha_num+1, mo_tot_num
-         F(i,i) += level_shift
+       do j = 1, n_core_orb
+         jorb = list_core(j)
+         F(iorb,jorb) = 0.d0
+         F(jorb,iorb) = 0.d0
        enddo
+     enddo
+   endif
+   
+   
+   
+   
+   ! Insert level shift here
+   do i = elec_beta_num+1, elec_alpha_num
+     F(i,i) += 0.5d0*level_shift
+   enddo
+   
+   do i = elec_alpha_num+1, mo_tot_num
+     F(i,i) += level_shift
+   enddo
+   
+   n = mo_tot_num
+   lwork = 1+6*n + 2*n*n
+   liwork = 3 + 5*n
+   
+   allocate(work(lwork))
+   allocate(iwork(liwork) )
+   
+   lwork = -1
+   liwork = -1
+   
+   call dsyevd( 'V', 'U', mo_tot_num, F,                             &
+       size(F,1), diagonal_Fock_matrix_mo,                           &
+       work, lwork, iwork, liwork, info)
+   
+   if (info /= 0) then
+     print *,  irp_here//' DSYEVD failed : ', info
+     stop 1
+   endif
+   lwork = int(work(1))
+   liwork = iwork(1)
+   deallocate(iwork)
+   deallocate(work)
+   
+   allocate(work(lwork))
+   allocate(iwork(liwork) )
+   call dsyevd( 'V', 'U', mo_tot_num, F,                             &
+       size(F,1), diagonal_Fock_matrix_mo,                           &
+       work, lwork, iwork, liwork, info)
+   deallocate(iwork)
+   
+   
+   if (info /= 0) then
+     call dsyev( 'V', 'L', mo_tot_num, F,                            &
+         size(F,1), diagonal_Fock_matrix_mo,                         &
+         work, lwork, info)
+     
+     if (info /= 0) then
+       print *,  irp_here//' DSYEV failed : ', info
+       stop 1
+     endif
+   endif
+   
+   call dgemm('N','N',ao_num,mo_tot_num,mo_tot_num, 1.d0,            &
+       mo_coef, size(mo_coef,1), F, size(F,1),                       &
+       0.d0, eigenvectors_Fock_matrix_mo, size(eigenvectors_Fock_matrix_mo,1))
+   deallocate(work, F)
+   
 
-       n = mo_tot_num
-       lwork = 1+6*n + 2*n*n
-       liwork = 3 + 5*n
-       
-       allocate(work(lwork), iwork(liwork) )
-       
-       lwork = -1
-       liwork = -1
-       
-       call dsyevd( 'V', 'U', mo_tot_num, F,                         &
-           size(F,1), diagonal_Fock_matrix_mo,                       &
-           work, lwork, iwork, liwork, info)
-       
-       if (info /= 0) then
-         print *,  irp_here//' failed : ', info
-         stop 1
-       endif
-       lwork = int(work(1))
-       liwork = iwork(1)
-       deallocate(work,iwork)
-       allocate(work(lwork), iwork(liwork) )
-       
-       call dsyevd( 'V', 'U', mo_tot_num, F,                         &
-           size(F,1), diagonal_Fock_matrix_mo,                       &
-           work, lwork, iwork, liwork, info)
-       
-       if (info /= 0) then
-         print *,  irp_here//' failed : ', info
-         stop 1
-       endif
-
-       call dgemm('N','N',ao_num,mo_tot_num,mo_tot_num, 1.d0, &
-         mo_coef, size(mo_coef,1), F, size(F,1), &
-         0.d0, eigenvectors_Fock_matrix_mo, size(eigenvectors_Fock_matrix_mo,1))
-       deallocate(work, iwork, F)
-
-
-!  endif
 
 END_PROVIDER
  

plugins/Hartree_Fock/huckel.irp.f

@@ -22,7 +22,7 @@ subroutine huckel_guess
       Fock_matrix_ao(i,j) = c*ao_overlap(i,j)*(ao_mono_elec_integral_diag(i) + &
                                                  ao_mono_elec_integral_diag(j))
     enddo
-    Fock_matrix_ao(j,j) = Fock_matrix_alpha_ao(j,j)
+    Fock_matrix_ao(j,j) = Fock_matrix_ao_alpha(j,j)
   enddo
   TOUCH Fock_matrix_ao
   mo_coef = eigenvectors_fock_matrix_mo

plugins/Hartree_Fock_SlaterDressed/EZFIO.cfg

@@ -0,0 +1,14 @@
+[slater_expo_ezfio]
+type: double precision
+doc: Exponents of the additional Slater functions
+size: (nuclei.nucl_num)
+interface: ezfio, provider
+
+[slater_coef_ezfio]
+type: double precision
+doc: Exponents of the additional Slater functions
+size: (nuclei.nucl_num,mo_basis.mo_tot_num)
+interface: ezfio, provider
+
+
+

plugins/Hartree_Fock_SlaterDressed/LinearSystem.irp.f

@@ -0,0 +1,53 @@
+BEGIN_PROVIDER [ double precision, cusp_A, (nucl_num, nucl_num) ]
+   implicit none
+   BEGIN_DOC
+   ! Equations to solve : A.X = B
+   END_DOC
+   
+   integer                        :: mu, A, B
+
+   cusp_A = 0.d0
+   do A=1,nucl_num
+    cusp_A(A,A) = slater_expo(A)/nucl_charge(A) * slater_value_at_nucl(A,A) 
+    do B=1,nucl_num
+      cusp_A(A,B) -= slater_value_at_nucl(B,A)
+      ! Projector
+      do mu=1,mo_tot_num
+        cusp_A(A,B) += MOSlaOverlap_matrix(mu,B) * mo_value_at_nucl(mu,A)
+      enddo
+    enddo
+   enddo
+END_PROVIDER
+
+BEGIN_PROVIDER [ double precision, cusp_B, (nucl_num, mo_tot_num) ]
+   implicit none
+   BEGIN_DOC
+   ! Equations to solve : A.C = B
+   END_DOC
+   
+   integer                        :: i, A, info
+   
+   do i=1,mo_tot_num
+     do A=1,nucl_num
+       cusp_B(A,i) = mo_value_at_nucl(i,A)
+     enddo
+   enddo
+END_PROVIDER
+
+   
+BEGIN_PROVIDER [ double precision, cusp_C, (nucl_num, mo_tot_num) ]
+   implicit none
+   BEGIN_DOC
+   ! Equations to solve : A.C = B
+   END_DOC
+   
+   double precision, allocatable           :: AF(:,:)
+   integer :: info
+   allocate ( AF(nucl_num,nucl_num) )
+   
+   call get_pseudo_inverse(cusp_A,nucl_num,nucl_num,AF,size(AF,1))
+   call dgemm('N','N',nucl_num,mo_tot_num,nucl_num,1.d0, &
+     AF,size(AF,1), cusp_B, size(cusp_B,1), 0.d0, cusp_C, size(cusp_C,1))
+
+END_PROVIDER
+

plugins/Hartree_Fock_SlaterDressed/SCF_dressed.irp.f

@@ -0,0 +1,98 @@
+program scf
+  BEGIN_DOC
+! Produce `Hartree_Fock` MO orbital with Slater cusp dressing
+! output: mo_basis.mo_tot_num mo_basis.mo_label mo_basis.ao_md5 mo_basis.mo_coef mo_basis.mo_occ
+! output: hartree_fock.energy
+! optional: mo_basis.mo_coef
+  END_DOC
+  call check_mos
+  call debug
+  call run
+end
+
+subroutine check_mos
+  implicit none
+  BEGIN_DOC
+!   Create a MO guess if no MOs are present in the EZFIO directory
+  END_DOC
+  logical                        :: exists
+  PROVIDE ezfio_filename
+  call ezfio_has_mo_basis_mo_coef(exists)
+  if (.not.exists) then
+    print *,  'Please run SCF first'
+    stop
+  endif
+end
+
+subroutine debug
+  implicit none
+  integer                        :: i,j,k
+  print *,  'A'
+  do i=1,nucl_num
+    print *,  i, cusp_A(1:nucl_num, i)
+  enddo
+  print *,  'B'
+  do i=1,mo_tot_num
+    print *,  i, cusp_B(1:nucl_num, i)
+  enddo
+  print *,  'X'
+  do i=1,mo_tot_num
+    print *,  i, cusp_C(1:nucl_num, i)
+  enddo
+  print *,  '-----'
+  return
+  do k=-100,100
+    double precision :: x, y, z
+    x = 0.01d0 * k
+    y = 0.d0
+    do i=1,ao_num
+      z = 0.d0
+      do j=1,ao_prim_num(i)
+        z += ao_coef_normalized_ordered_transp(j,i) * dexp(-ao_expo_ordered_transp(j,i) * x**2)
+      enddo
+      y += mo_coef(i,1) * z
+      y += exp(-slater_expo(1)*dabs(x)) * slater_coef(1,1)
+      z = 0.d0
+      do j=1,ao_prim_num(i)
+        z += ao_coef_normalized_ordered_transp(j,i) * dexp(-ao_expo_ordered_transp(j,i) * x**2) 
+      enddo
+      y -= z * GauSlaOverlap_matrix(i,1)* slater_coef(1,1)
+    enddo
+    print *,  x, y
+  enddo
+  print *,  '-----'
+end
+
+subroutine run
+
+  BEGIN_DOC
+!   Run SCF calculation
+  END_DOC
+
+  use bitmasks
+  implicit none
+
+  double precision               :: SCF_energy_before,SCF_energy_after,diag_H_mat_elem
+  double precision               :: EHF
+  integer                        :: i_it, i, j, k
+   
+  mo_label = "CuspDressed"
+
+
+  print *,  HF_energy
+
+  call ezfio_set_Hartree_Fock_SlaterDressed_slater_coef_ezfio(cusp_C)
+
+  do i=1,ao_num
+    print *,  mo_coef(i,1), cusp_corrected_mos(i,1)
+  enddo
+  mo_coef(1:ao_num,1:mo_tot_num) = cusp_corrected_mos(1:ao_num,1:mo_tot_num)
+  TOUCH mo_coef
+
+  EHF = HF_energy 
+  print *,  HF_energy
+!  call Roothaan_Hall_SCF
+  
+end
+
+

plugins/Hartree_Fock_SlaterDressed/at_nucl.irp.f

@@ -0,0 +1,66 @@
+BEGIN_PROVIDER [ double precision , ao_value_at_nucl, (ao_num,nucl_num) ]
+  implicit none
+  BEGIN_DOC
+! Values of the atomic orbitals at the nucleus 
+  END_DOC
+  integer :: i,j,k
+  double precision :: x,y,z,expo,poly, r2
+
+  do k=1,nucl_num
+    do i=1,ao_num
+      x = nucl_coord(ao_nucl(i),1) - nucl_coord(k,1)
+      y = nucl_coord(ao_nucl(i),2) - nucl_coord(k,2)
+      z = nucl_coord(ao_nucl(i),3) - nucl_coord(k,3)
+      poly = x**(ao_power(i,1)) * y**(ao_power(i,2)) * z**(ao_power(i,3)) 
+      if (poly == 0.d0) cycle
+
+      r2 = (x*x) + (y*y) + (z*z)
+      ao_value_at_nucl(i,k) = 0.d0
+      do j=1,ao_prim_num(i)
+        expo = ao_expo_ordered_transp(j,i)*r2
+        if (expo > 40.d0) cycle
+        ao_value_at_nucl(i,k) = ao_value_at_nucl(i,k) +             &
+            ao_coef_normalized_ordered_transp(j,i) *                &
+            dexp(-expo)
+      enddo
+      ao_value_at_nucl(i,k) *= poly
+    enddo
+  enddo
+END_PROVIDER
+
+BEGIN_PROVIDER [ double precision, mo_value_at_nucl, (mo_tot_num,nucl_num) ]
+  implicit none
+  BEGIN_DOC
+! Values of the molecular orbitals at the nucleus 
+  END_DOC
+
+  call dgemm('N','N',mo_tot_num,nucl_num,ao_num,1.d0,                &
+      mo_coef_transp, size(mo_coef_transp,1),                        &
+      ao_value_at_nucl, size(ao_value_at_nucl,1),                    &
+      0.d0, mo_value_at_nucl, size(mo_value_at_nucl,1))
+END_PROVIDER
+
+
+BEGIN_PROVIDER [ double precision , slater_value_at_nucl, (nucl_num,nucl_num) ]
+  implicit none
+  BEGIN_DOC
+! Values of the Slater orbitals (1) at the nucleus (2)
+  END_DOC
+  integer :: i,j,k
+  double precision :: x,y,z,expo,poly, r
+
+  do k=1,nucl_num
+    do i=1,nucl_num
+      x = nucl_coord(i,1) - nucl_coord(k,1)
+      y = nucl_coord(i,2) - nucl_coord(k,2)
+      z = nucl_coord(i,3) - nucl_coord(k,3)
+
+!      expo = slater_expo(i)*slater_expo(i)*((x*x) + (y*y) + (z*z))
+!      if (expo > 160.d0) cycle
+!      expo = dsqrt(expo)
+      expo = slater_expo(i) * dsqrt((x*x) + (y*y) + (z*z))
+      slater_value_at_nucl(i,k) = dexp(-expo) * slater_normalization(i)
+    enddo
+  enddo
+END_PROVIDER
+

plugins/Hartree_Fock_SlaterDressed/integrals.irp.f

@@ -0,0 +1,624 @@
+!*****************************************************************************
+subroutine GauSlaOverlap(expGau,cGau,aGau,expSla,cSla,result)
+  implicit none
+
+  BEGIN_DOC
+  ! Compute the overlap integral between a Gaussian function
+  ! with arbitrary angular momemtum and a s-type Slater function
+  END_DOC
+
+! Input variables 
+  double precision,intent(in)   :: expGau,expSla
+  double precision,intent(in)   :: cGau(3),cSla(3)
+  integer,intent(in)            :: aGau(3)
+  double precision,intent(out)  :: result
+
+! Final value of the integrals
+  double precision              :: ss,ps,ds
+  double precision              :: pxs,pys,pzs
+  double precision              :: dxxs,dyys,dzzs,dxys,dxzs,dyzs
+
+  double precision              :: pi,E,AB,AxBx,AyBy,AzBz,t,u,k
+
+  pi = 4d0*atan(1d0)
+  
+! calculate the length AB between the two centers and other usful quantities
+
+  AB = (cGau(1)-cSla(1))**2 + (cGau(2)-cSla(2))**2 + (cGau(3)-cSla(3))**2
+  AB = dsqrt(AB)
+
+  AxBx = (cGau(1)-cSla(1))/2d0
+  AyBy = (cGau(2)-cSla(2))/2d0
+  AzBz = (cGau(3)-cSla(3))/2d0
+  ds = 0.d0
+
+! intermediate variables
+
+  t = expSla*dsqrt(0.25d0/expGau)
+  u = dsqrt(expGau)*AB
+
+  double precision :: d, et2
+  if(AB > 0d0) then 
+
+!   (s|s) 
+    ss = 0.d0
+
+    d = derfc(t+u)
+    if (dabs(d) > 1.d-30) then
+      ss  = (t+u)*d*dexp(2d0*t*(t+u)) 
+    endif
+
+    d = derfc(t-u)
+    if (dabs(d) > 1.d-30) then
+      ss -= (t-u)*d*dexp(2d0*t*(t-u))
+    endif
+
+!   (p|s)
+    ps = 0.d0
+    if (t*t-u*u > 300.d0) then
+      et2 = huge(1.0)
+    else
+      et2 = dexp(t*t-u*u)
+    endif
+    if (et2 /= 0.d0) then
+      d = derfc(t-u) 
+      if (d /= 0.d0) then
+        ps += dexp((t-u)**2)*(1d0+2d0*t*(t-u))*d
+      endif
+      d = derfc(t+u)
+      if (d /= 0.d0) then
+        ps += dexp((t+u)**2)*(1d0+2d0*t*(t+u))*d
+      endif
+      ps *= dsqrt(pi)
+      ps -= 4d0*t 
+      ps *= et2/dsqrt(pi)
+    endif
+
+!   (d|s)
+!    ds = 4d0*dexp(2d0*t*(t-u))*t*(-((1d0+t**2-t*u)*derfc(t-u))+dexp(4d0*t*u)*(1d0+t*(t+u))*derfc(t+u))
+    ds = 0.d0
+    d = derfc(t+u)
+    if (d /= 0.d0) then
+      ds  = dexp(4d0*t*u)*(1d0+t*(t+u))*d
+    endif
+    d = derfc(t-u)
+    if (d /= 0.d0) then
+      ds -= (1d0+t*t-t*u)*d
+    endif
+
+    if ( dabs(ds) > 1.d-100) then
+      ds *= 4d0*dexp(2d0*t*(t-u))*t
+    endif
+
+!   backward scaling
+    ds = 3d0*ss/u**5d0 - 3d0*ps/u**4d0 + ds/u**3d0
+    ps = ps/u**2-ss/u**3d0
+    ss = ss/u
+
+  else
+
+!   concentric case
+    d = derfc(t)
+    if (d /= 0.d0) then
+      et2 = dexp(t*t)
+      ss = 2d0*et2*((-2d0*t)/dsqrt(pi)+et2*(1d0+2d0*t*t)*d)
+      ps = (8d0*et2*t*(-2d0*(1d0+t*t)+et2*dsqrt(pi)*t*(3d0+2d0*t*t)*d))/(3d0*dsqrt(pi))
+    else
+      ss = 0.d0
+      ps = 0.d0
+    endif
+
+  endif
+
+  k = t**3d0*dexp(-t*t)*4d0*pi/expSla**(3d0/2d0)
+
+! (s|s) 
+  ss = k*ss
+
+! (p|s) 
+  ps = k*ps
+
+  pxs = AxBx*ps
+  pys = AyBy*ps
+  pzs = AzBz*ps
+
+! (d|s) 
+  ds = k*ds
+
+  dxxs = (2d0*ss+ps)/(4d0*expGau) + AxBx**2*ds
+  dyys = (2d0*ss+ps)/(4d0*expGau) + AyBy**2*ds
+  dzzs = (2d0*ss+ps)/(4d0*expGau) + AzBz**2*ds
+
+  dxys = AxBx*AyBy*ds
+  dxzs = AxBx*AzBz*ds
+  dyzs = AyBy*AzBz*ds
+
+  select case (sum(aGau))
+    case (0)
+      result = ss
+
+    case (1)
+      if (aGau(1) == 1) then
+        result = pxs
+      else if (aGau(2) == 1) then
+        result = pys
+      else if (aGau(3) == 1) then
+        result = pzs
+      endif
+
+    case (2)
+      if (aGau(1) == 2) then
+        result = dxxs
+      else if (aGau(2) == 2) then
+        result = dyys
+      else if (aGau(3) == 2) then
+        result = dzzs
+      else if (aGau(1)+aGau(2) == 2) then
+        result = dxys
+      else if (aGau(1)+aGau(3) == 2) then
+        result = dxzs
+      else if (aGau(2)+aGau(3) == 2) then
+        result = dyzs
+      endif
+
+    case default
+      stop 'GauSlaOverlap not implemented'
+
+  end select
+
+end
+!*****************************************************************************
+
+!*****************************************************************************
+subroutine GauSlaKinetic(expGau,cGau,aGau,expSla,cSla,result)
+
+  implicit none
+
+  BEGIN_DOC
+  ! Compute the kinetic energy integral between a Gaussian function
+  ! with arbitrary angular momemtum and a s-type Slater function
+  END_DOC
+
+! Input variables 
+  double precision,intent(in)   :: expGau,expSla
+  double precision,intent(in)   :: cGau(3),cSla(3)
+  integer,intent(in)            :: aGau(3)
+  double precision,intent(out)  :: result
+
+! Final value of the integrals
+  double precision              :: ss,ps,ds
+  double precision              :: pxs,pys,pzs
+  double precision              :: dxxs,dyys,dzzs,dxys,dxzs,dyzs
+
+  double precision              :: pi,E,AB,AxBx,AyBy,AzBz,t,u,k
+
+  pi = 4d0*atan(1d0)
+  
+! calculate the length AB between the two centers
+
+  AB = (cGau(1)-cSla(1))**2 + (cGau(2)-cSla(2))**2 + (cGau(3)-cSla(3))**2
+  AB = dsqrt(AB)
+
+  AxBx = (cGau(1)-cSla(1))/2d0
+  AyBy = (cGau(2)-cSla(2))/2d0
+  AzBz = (cGau(3)-cSla(3))/2d0
+
+! intermediate variables
+
+  t = expSla*dsqrt(0.25d0/expGau)
+  u = dsqrt(expGau)*AB
+
+  if(AB > 0d0) then 
+
+!   (s|s) 
+    ss = (1d0+t*(t-u))*derfc(t-u)*dexp(2d0*t*(t-u)) - (1d0+t*(t+u))*derfc(t+u)*dexp(2d0*t*(t+u))
+
+!   (p|s)
+    ps = (dexp(t**2-2d0*t*u-u**2)*(4d0*dexp(2d0*t*u)*(1d0+t**2)    & 
+       + dsqrt(pi)*t*(-(dexp(t**2+u**2)*(3d0+2d0*t*(t-u))*derfc(t-u)) & 
+       - dexp(2d0*t*u+(t+u)**2)*(3d0+2d0*t*(t+u))*derfc(t+u))))/dsqrt(pi)
+
+!   (d|s)
+    ds = (-8d0*dexp(t**2-u**2)*u+4d0*dexp(2d0*t*(t-u))*dsqrt(pi)*t**2*((2d0+t**2-t*u)*derfc(t-u) &
+       - dexp(4d0*t*u)*(2d0+t*(t+u))*derfc(t+u)))/dsqrt(pi)
+
+!   backward scaling
+    ds = 3d0*ss/u**5d0 - 3d0*ps/u**4d0 + ds/u**3d0
+    ps = ps/u**2-ss/u**3d0
+    ss = ss/u
+
+  else
+
+!   concentric case
+    ss = (4d0*dexp(t**2)*(1d0+t**2))/dsqrt(pi)-2d0*dexp(2d0*t**2)*t*(3d0+2d0*t**2)*derfc(t)
+    ps = (8d0*dexp(t**2)*(-1d0+4d0*t**2+2d0*t**4d0-dexp(t**2)*dsqrt(pi)*t**3d0*(5d0+2d0*t**2)*derfc(t)))/(3d0*dsqrt(pi))
+
+  endif
+
+  k = expSla*dsqrt(expGau)*t**3d0*dexp(-t*t)*4d0*pi/expSla**(3d0/2d0)
+
+! (s|s) 
+  ss = k*ss
+
+! (p|s) 
+  ps = k*ps
+
+  pxs = AxBx*ps
+  pys = AyBy*ps
+  pzs = AzBz*ps
+
+! (d|s) 
+  ds = k*ds
+
+  dxxs = (2d0*ss+ps)/(4d0*expGau) + AxBx**2*ds
+  dyys = (2d0*ss+ps)/(4d0*expGau) + AyBy**2*ds
+  dzzs = (2d0*ss+ps)/(4d0*expGau) + AzBz**2*ds
+
+  dxys = AxBx*AyBy*ds
+  dxzs = AxBx*AzBz*ds
+  dyzs = AyBy*AzBz*ds
+
+  select case (sum(aGau))
+    case (0)
+      result = ss
+
+    case (1)
+      if (aGau(1) == 1) then
+        result = pxs
+      else if (aGau(2) == 1) then
+        result = pys
+      else if (aGau(3) == 1) then
+        result = pzs
+      endif
+
+    case (2)
+      if (aGau(1) == 2) then
+        result = dxxs
+      else if (aGau(2) == 2) then
+        result = dyys
+      else if (aGau(3) == 2) then
+        result = dzzs
+      else if (aGau(1)+aGau(2) == 2) then
+        result = dxys
+      else if (aGau(1)+aGau(3) == 2) then
+        result = dxzs
+      else if (aGau(2)+aGau(3) == 2) then
+        result = dyzs
+      endif
+
+    case default
+      stop 'GauSlaOverlap not implemented'
+
+  end select
+
+end
+!*****************************************************************************
+
+
+
+!*****************************************************************************
+subroutine GauSlaNuclear(expGau,cGau,aGau,expSla,cSla,ZNuc,cNuc,result)
+
+  implicit none
+
+  BEGIN_DOC
+  ! Compute the nuclear attraction integral between a Gaussian function
+  ! with arbitrary angular momemtum and a s-type Slater function
+  END_DOC
+
+! Input variables 
+  double precision,intent(in)   :: expGau,expSla
+  double precision,intent(in)   :: cGau(3),cSla(3)
+  integer,intent(in)            :: aGau(3)
+  double precision,intent(in)   :: cNuc(3)
+  double precision,intent(in)   :: ZNuc
+  double precision,intent(out)  :: result
+
+! Final value of the overlap integral
+  double precision              :: ss,ps,ds,fs
+  double precision              :: pxs,pys,pzs
+
+  double precision              :: pi,E,AB,x,y,k
+
+  pi = 4d0*atan(1d0)
+  E = exp(1d0)
+  
+! calculate the length AB between the two centers
+
+  AB = (cGau(1)-cSla(1))**2 + (cGau(2)-cSla(2))**2 + (cGau(3)-cSla(3))**2
+  AB = dsqrt(AB)
+
+! intermediate variables
+
+  x = dsqrt(expSla**2/(4d0*expGau))
+  y = dsqrt(expGau)*AB
+
+  if(AB > 0d0) then 
+    ss = (1d0+x*(x+y))*derfc(x+y)*dexp(2d0*x*(x+y)) - (1d0+x*(x-y))*derfc(x-y)*dexp(2d0*x*(x-y))
+    ss = ss/y
+  else
+    ss = (4d0*E**x**2*(1d0+x**2))/dsqrt(Pi)-2d0*E**(2d0*x**2)*x*(3d0+2d0*x**2)*dErfc(x)
+  endif
+
+  k = expSla*dsqrt(expGau)*x**3d0*dexp(-x*x)*4d0*pi/expSla**(3d0/2d0)
+  ss = k*ss
+
+! Print result
+  write(*,*) ss
+  result = 0.d0
+
+end
+!*****************************************************************************
+
+double precision function BoysF0(t)
+  implicit none
+  double precision, intent(in)  :: t
+  double precision              :: pi
+
+  pi = 4d0*atan(1d0)
+
+  if(t > 0d0) then
+    BoysF0 = 0.5d0*dsqrt(pi/t)*derf(dsqrt(t))
+  else
+    BoysF0 = 1d0
+  endif
+
+end
+!*****************************************************************************
+
+!TODO
+subroutine GauSlaOverlap_write(expGau,cGau,aGau,expSla,cSla,result,iunit)
+  implicit none
+  double precision,intent(in)   :: expGau,expSla
+  double precision,intent(in)   :: cGau(3),cSla(3)
+  integer,intent(in)            :: aGau(3)
+  integer,intent(in)            :: iunit
+  double precision,intent(out)  :: result
+  write(iunit, *)  &
+  'SDrSla[ {',expGau,',{',cGau(1),',',cGau(2),',',cGau(3),'},{',aGau(1),',',aGau(2),',',aGau(3),'} },{', expSla,', {',cSla(1),',',cSla(2),',',cSla(3),'} } ],'
+  result = 0.d0
+end
+
+subroutine GauSlaOverlap_read(expGau,cGau,aGau,expSla,cSla,result,iunit)
+  implicit none
+  double precision,intent(in)   :: expGau,expSla
+  double precision,intent(in)   :: cGau(3),cSla(3)
+  integer,intent(in)            :: aGau(3)
+  integer,intent(in)            :: iunit
+  double precision,intent(out)  :: result
+  read(iunit, *)  result
+end
+
+subroutine GauSlaKinetic_write(expGau,cGau,aGau,expSla,cSla,result,iunit)
+  implicit none
+  double precision,intent(in)   :: expGau,expSla
+  double precision,intent(in)   :: cGau(3),cSla(3)
+  integer,intent(in)            :: aGau(3)
+  integer,intent(in)            :: iunit
+  double precision,intent(out)  :: result
+  write(iunit, *)  &
+  'TDrSla[ {',expGau,',{',cGau(1),',',cGau(2),',',cGau(3),'},{',aGau(1),',',aGau(2),',',aGau(3),'} },{', expSla,',{',cSla(1),',',cSla(2),',',cSla(3),'} } ],'
+  result = 0.d0
+end
+
+subroutine GauSlaKinetic_read(expGau,cGau,aGau,expSla,cSla,result,iunit)
+  implicit none
+  double precision,intent(in)   :: expGau,expSla
+  double precision,intent(in)   :: cGau(3),cSla(3)
+  integer,intent(in)            :: aGau(3)
+  integer,intent(in)            :: iunit
+  double precision,intent(out)  :: result
+  read(iunit, *)  result
+end
+
+subroutine GauSlaNuclear_write(expGau,cGau,aGau,expSla,cSla,ZNuc,cNuc,result,iunit)
+  implicit none
+  double precision,intent(in)   :: expGau,expSla
+  double precision,intent(in)   :: cGau(3),cSla(3)
+  integer,intent(in)            :: aGau(3)
+  double precision,intent(in)   :: cNuc(3)
+  double precision,intent(in)   :: ZNuc
+  integer,intent(in)            :: iunit
+  double precision,intent(out)  :: result
+  write(iunit, *)  &
+  'VDrSla[ {',expGau,',{',cGau(1),',',cGau(2),',',cGau(3),'},{',aGau(1),',',aGau(2),',',aGau(3),'} },{ ', expSla,',{',cSla(1),',',cSla(2),',',cSla(3),'} }, {', ZNuc, ',{', cNuc(1),',', cNuc(2),',', cNuc(3), '} } ],'
+  result = 0.d0
+end
+
+subroutine GauSlaNuclear_read(expGau,cGau,aGau,expSla,cSla,ZNuc,cNuc,result,iunit)
+  implicit none
+  double precision,intent(in)   :: expGau,expSla
+  double precision,intent(in)   :: cGau(3),cSla(3)
+  integer,intent(in)            :: aGau(3)
+  double precision,intent(in)   :: cNuc(3)
+  double precision,intent(in)   :: ZNuc
+  integer,intent(in)            :: iunit
+  double precision,intent(out)  :: result
+  read(iunit, *)  result
+end
+!TODO
+
+BEGIN_TEMPLATE
+
+BEGIN_PROVIDER [ double precision, GauSla$X_matrix, (ao_num, nucl_num) ]
+  implicit none
+  BEGIN_DOC
+  ! <Gaussian | Slater> overlap matrix
+  END_DOC
+  integer                        :: i,j,k
+  double precision               :: cGau(3)
+  double precision               :: cSla(3)
+  double precision               :: expSla, res, expGau
+  integer                        :: aGau(3)
+
+!TODO
+  logical :: read
+  integer :: iunit
+  integer :: getunitandopen
+
+  inquire(FILE=trim(ezfio_filename)//'/work/GauSla$X.dat',EXIST=read)
+  if (read) then
+    print *,  'READ $X'
+    iunit = getunitandopen(trim(ezfio_filename)//'/work/GauSla$X.dat','r')
+  else
+    print *,  'WRITE $X'
+    iunit = getunitandopen(trim(ezfio_filename)//'/work/GauSla$X.inp','w')
+    write(iunit,*) '{'
+  endif
+!TODO
+
+  do k=1,nucl_num
+    cSla(1:3) = nucl_coord_transp(1:3,k)
+    expSla    = slater_expo(k)
+
+    do i=1,ao_num
+      cGau(1:3) = nucl_coord_transp(1:3, ao_nucl(i))
+      aGau(1:3) = ao_power(i,1:3)
+      GauSla$X_matrix(i,k) = 0.d0
+
+      do j=1,ao_prim_num(i)
+        expGau = ao_expo_ordered_transp(j,i)
+!        call GauSla$X(expGau,cGau,aGau,expSla,cSla,res)
+        if (read) then
+          call GauSla$X_read(expGau,cGau,aGau,expSla,cSla,res,iunit)
+        else
+          call GauSla$X_write(expGau,cGau,aGau,expSla,cSla,res,iunit)
+        endif
+        GauSla$X_matrix(i,k) += ao_coef_normalized_ordered_transp(j,i) * res
+      enddo
+
+    enddo
+
+  enddo
+  if (.not.read) then
+    write(iunit,*) '0.}'
+  endif
+  close(iunit)
+  
+END_PROVIDER
+
+BEGIN_PROVIDER [ double precision, MOSla$X_matrix, (mo_tot_num, nucl_num) ]
+  implicit none
+  BEGIN_DOC
+! <MO | Slater>
+  END_DOC
+  call dgemm('N','N',mo_tot_num,nucl_num,ao_num,1.d0,                &
+      mo_coef_transp, size(mo_coef_transp,1),                        &
+      GauSla$X_matrix, size(GauSla$X_matrix,1),                    &
+      0.d0, MOSla$X_matrix, size(MOSla$X_matrix,1))
+END_PROVIDER
+
+BEGIN_PROVIDER [ double precision, AO_orthoSla$X_matrix, (ao_num, nucl_num) ]
+ implicit none
+ BEGIN_DOC
+ ! <AO_ortho | Slater>
+ END_DOC
+  call dgemm('T','N',ao_num,nucl_num,ao_num,1.d0,                &
+      ao_ortho_canonical_coef, size(ao_ortho_canonical_coef,1),      &
+      GauSla$X_matrix, size(GauSla$X_matrix,1),                      &
+      0.d0, AO_orthoSla$X_matrix, size(AO_orthoSla$X_matrix,1))
+ 
+END_PROVIDER
+
+SUBST [ X ]
+
+Overlap ;;
+Kinetic ;;
+
+END_TEMPLATE
+
+BEGIN_PROVIDER [ double precision, GauSlaNuclear_matrix, (ao_num, nucl_num) ]
+  implicit none
+  BEGIN_DOC
+  ! <Gaussian | Slater> overlap matrix
+  END_DOC
+  integer                        :: i,j,k,A
+  double precision               :: cGau(3)
+  double precision               :: cSla(3)
+  double precision               :: expSla, res, expGau, Znuc, cNuc(3)
+  integer                        :: aGau(3)
+
+!TODO
+  logical :: read
+  integer :: iunit
+  integer :: getunitandopen
+
+  inquire(FILE=trim(ezfio_filename)//'/work/GauSlaNuclear.dat',EXIST=read)
+  if (read) then
+    print *,  'READ Nuclear'
+    iunit = getunitandopen(trim(ezfio_filename)//'/work/GauSlaNuclear.dat','r')
+  else
+    print *,  'WRITE Nuclear'
+    iunit = getunitandopen(trim(ezfio_filename)//'/work/GauSlaNuclear.inp','w')
+    write(iunit,*)'{'
+  endif
+!TODO
+
+  do k=1,nucl_num
+    cSla(1:3) = nucl_coord_transp(1:3,k)
+    expSla    = slater_expo(k)
+
+    do i=1,ao_num
+      cGau(1:3) = nucl_coord_transp(1:3, ao_nucl(i))
+      aGau(1:3) = ao_power(i,1:3)
+      GauSlaNuclear_matrix(i,k) = 0.d0
+
+      do j=1,ao_prim_num(i)
+        expGau = ao_expo_ordered_transp(j,i)
+        do A=1,nucl_num
+          cNuc(1:3) = nucl_coord_transp(1:3,A)
+          Znuc = nucl_charge(A)
+!          call GauSlaNuclear(expGau,cGau,aGau,expSla,cSla,Znuc,cNuc,res)
+          if (read) then
+            call GauSlaNuclear_read(expGau,cGau,aGau,expSla,cSla,Znuc,cNuc,res,iunit)
+          else
+            call GauSlaNuclear_write(expGau,cGau,aGau,expSla,cSla,Znuc,cNuc,res,iunit)
+          endif
+          GauSlaNuclear_matrix(i,k) += ao_coef_normalized_ordered_transp(j,i) * res
+        enddo
+      enddo
+
+    enddo
+
+  enddo
+  if (.not.read) then
+    write(iunit,*) '0.}'
+  endif
+  close(iunit)
+  
+END_PROVIDER
+
+BEGIN_PROVIDER [ double precision, GauSlaH_matrix, (ao_num, nucl_num) ]
+ implicit none
+ BEGIN_DOC
+ ! Core hamiltonian in AO basis
+ END_DOC
+ GauSlaH_matrix(1:ao_num,1:nucl_num) =                               &
+     GauSlaKinetic_matrix(1:ao_num,1:nucl_num) +                     &
+     GauSlaNuclear_matrix(1:ao_num,1:nucl_num)
+
+END_PROVIDER
+
+
+BEGIN_PROVIDER [ double precision, MOSlaNuclear_matrix, (mo_tot_num, nucl_num) ]
+  implicit none
+  BEGIN_DOC
+! <MO | Slater>
+  END_DOC
+  call dgemm('N','N',mo_tot_num,nucl_num,ao_num,1.d0,                &
+      mo_coef_transp, size(mo_coef_transp,1),                        &
+      GauSlaNuclear_matrix, size(GauSlaNuclear_matrix,1),                    &
+      0.d0, MOSlaNuclear_matrix, size(MOSlaNuclear_matrix,1))
+END_PROVIDER
+
+BEGIN_PROVIDER [ double precision, AO_orthoSlaH_matrix, (ao_num, nucl_num) ]
+  implicit none
+  BEGIN_DOC
+! <AO ortho | Slater>
+  END_DOC
+  call dgemm('T','N',ao_num,nucl_num,ao_num,1.d0,                &
+      ao_ortho_canonical_coef, size(ao_ortho_canonical_coef,1),                        &
+      GauSlaH_matrix, size(GauSlaH_matrix,1),                        &
+      0.d0, AO_orthoSlaH_matrix, size(AO_orthoSlaH_matrix,1))
+END_PROVIDER
+

plugins/Hartree_Fock_SlaterDressed/slater.irp.f

@@ -0,0 +1,43 @@
+BEGIN_PROVIDER [ double precision, slater_expo, (nucl_num) ]
+ implicit none
+ BEGIN_DOC
+ ! Exponents of the Slater functions
+ END_DOC
+ logical :: exists
+ call ezfio_has_Hartree_Fock_SlaterDressed_slater_expo_ezfio(exists)
+ if (exists) then
+   slater_expo(1:nucl_num) = slater_expo_ezfio(1:nucl_num)
+ else
+   slater_expo(1:nucl_num) = nucl_charge(1:nucl_num)
+   call ezfio_set_Hartree_Fock_SlaterDressed_slater_expo_ezfio(slater_expo)
+ endif
+END_PROVIDER
+
+
+BEGIN_PROVIDER [ double precision, slater_coef, (nucl_num,mo_tot_num) ]
+ implicit none
+ BEGIN_DOC
+ ! Exponents of the Slater functions
+ END_DOC
+ logical :: exists
+ slater_coef = 0.d0
+ call ezfio_has_Hartree_Fock_SlaterDressed_slater_coef_ezfio(exists)
+ if (exists) then
+   slater_coef = slater_coef_ezfio
+ else
+   call ezfio_set_Hartree_Fock_SlaterDressed_slater_coef_ezfio(slater_coef)
+ endif
+END_PROVIDER
+
+BEGIN_PROVIDER [ double precision, slater_normalization, (nucl_num) ]
+ implicit none
+ BEGIN_DOC
+ ! Normalization of Slater functions : sqrt(expo^3/pi)
+ END_DOC
+ integer :: i
+ do i=1,nucl_num
+   slater_normalization(i) = dsqrt( slater_expo(i)**3/dacos(-1.d0) )
+ enddo
+
+END_PROVIDER
+

plugins/MP2/mp2_wf.irp.f

@@ -21,15 +21,22 @@ subroutine run
   selection_criterion_factor = 0.d0
   TOUCH selection_criterion_min selection_criterion selection_criterion_factor
   call H_apply_mp2_selection(pt2, norm_pert, H_pert_diag,  N_st)
+  touch N_det psi_det psi_coef
   psi_det = psi_det_sorted
   psi_coef = psi_coef_sorted
   touch N_det psi_det psi_coef
+  do i=N_det,1,-1
+    if (dabs(psi_coef(i,1)) <= 1.d-8) then
+      N_det -= 1
+    endif
+  enddo
   print*,'N_det = ',N_det
   print*,'-----'
   print *,  'PT2                          = ', pt2(1)
   print *,  'E                            = ', HF_energy
   print *,  'E_before     +PT2            = ', HF_energy+pt2(1)
   N_det = min(N_det,N_det_max)
+  touch N_det psi_det psi_coef
   call save_wavefunction
   call ezfio_set_mp2_energy(HF_energy+pt2(1))
   deallocate(pt2,norm_pert,H_pert_diag)

plugins/MPI/NEEDED_CHILDREN_MODULES

@@ -0,0 +1 @@
+

plugins/MPI/README.rst

@@ -0,0 +1,14 @@
+===
+MPI
+===
+
+Providers for MPI programs.
+
+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/MPI/bcast.irp.f

@@ -0,0 +1,46 @@
+subroutine mpi_bcast_psi()
+  use f77_zmq
+  implicit none
+  BEGIN_DOC
+! Put the wave function on the qp_run scheduler
+  END_DOC
+  integer(ZMQ_PTR), intent(in)   :: zmq_to_qp_run_socket
+  integer, intent(in)            :: worker_id
+  integer                        :: ierr
+  character*(256)                :: msg
+
+  IRP_IF MPI
+    call MPI_BCast(N_states,     1, MPI_INTEGER, 0, MPI_COMM_WORLD, ierr)
+    call MPI_BCast(N_det,        1, MPI_INTEGER, 0, MPI_COMM_WORLD, ierr)
+    call MPI_BCast(psi_det_size, 1, MPI_INTEGER, 0, MPI_COMM_WORLD, ierr)
+  
+    TOUCH psi_det_size N_det N_states
+
+    call MPI_BCast(psi_det,         N_det, MPI_INTEGER8, 0, MPI_COMM_WORLD, ierr)
+    call MPI_BCast(psi_coef, psi_det_size, MPI_DOUBLE_PRECISION* N_states, 0, MPI_COMM_WORLD, ierr)
+
+
+  rc8 = f77_zmq_recv8(zmq_to_qp_run_socket,psi_coef,int(psi_det_size*N_states*8_8,8),0)
+  if (rc8 /= psi_det_size*N_states*8_8) then
+    print *, '77_zmq_recv8(zmq_to_qp_run_socket,psi_coef,psi_det_size*N_states*8,ZMQ_SNDMORE)'
+    stop 'error'
+  endif
+  TOUCH psi_det psi_coef
+
+  rc = f77_zmq_recv(zmq_to_qp_run_socket,energy,size_energy*8,0)
+  if (rc /= size_energy*8) then
+    print *, '77_zmq_recv(zmq_to_qp_run_socket,energy,size_energy*8,0)'
+    stop 'error'
+  endif
+
+  if (N_det_generators_read > 0) then
+    N_det_generators = N_det_generators_read
+    TOUCH N_det_generators
+  endif
+  if (N_det_selectors_read > 0) then
+    N_det_selectors  = N_det_selectors_read
+    TOUCH N_det_selectors
+  endif
+
+end
+

plugins/MPI/utils.irp.f

@@ -0,0 +1,68 @@
+ BEGIN_PROVIDER [ logical, MPI_Initialized ]
+&BEGIN_PROVIDER [ logical, has_mpi ]
+  implicit none
+  BEGIN_DOC
+! This is true when MPI_Init has been called
+  END_DOC
+
+  IRP_IF MPI
+      integer :: ierr
+      call MPI_Init(ierr)
+      if (ierr /= 0) then
+         print *, ierr
+         print *, 'MPI failed to initialize'
+         stop -1
+      endif
+  IRP_ENDIF
+  MPI_Initialized = .True.
+END_PROVIDER
+
+
+ BEGIN_PROVIDER [ integer, MPI_rank ]
+&BEGIN_PROVIDER [ integer, MPI_size ]
+&BEGIN_PROVIDER [ logical, is_MPI_master ]
+ implicit none
+ BEGIN_DOC
+! Usual MPI variables
+ END_DOC
+
+ PROVIDE MPI_Initialized
+
+ IRP_IF MPI
+   integer :: ierr
+   call mpi_comm_size(MPI_COMM_WORLD, MPI_size, ierr)
+   if (ierr /= 0) then
+     print *, ierr
+     print *, 'Unable to get MPI_size'
+     stop -1
+   endif
+   call mpi_comm_rank(MPI_COMM_WORLD, MPI_rank, ierr)
+   if (ierr /= 0) then
+     print *, ierr
+     print *, 'Unable to get MPI_rank'
+     stop -1
+   endif
+   is_MPI_master = (MPI_rank == 0)
+ IRP_ELSE
+   MPI_rank = 0
+   MPI_size = 1
+   is_MPI_master = .True.
+ IRP_ENDIF
+
+
+END_PROVIDER
+
+subroutine qp_mpi_finalize()
+  implicit none
+  PROVIDE MPI_Initialized
+  IRP_IF MPI
+      integer :: ierr
+      call MPI_Finalize(ierr)
+      if (ierr /= 0) then
+         print *, ierr
+         print *, 'Unable to finalize MPI'
+         stop -1
+       endif
+  IRP_ENDIF
+end subroutine
+

plugins/MRPT/NEEDED_CHILDREN_MODULES

@@ -1 +1 @@
-MRPT_Utils Selectors_full Generators_full
+MRPT_Utils Selectors_full Generators_full 

plugins/MRPT/jm_mrpt2.irp.f

@@ -15,11 +15,17 @@ subroutine routine_3
  
  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)
+
+ integer :: i
+ do i=1,N_states
+  print *,  'State    = ', i
+  print *,  'PT2      = ', second_order_pt_new(i)
+  print *,  'E        = ', CI_energy(i)
+  print *,  'E+PT2    = ', CI_energy(i)+second_order_pt_new(i)
+  print *,  '-----------------------------'
+ enddo
  print *,'****** DIAGONALIZATION OF DRESSED MATRIX ******'
- print *,  'E dressed= ', CI_dressed_pt2_new_energy(1)
+ print *,  'E dressed= ', CI_dressed_pt2_new_energy(i)
 
 end
 

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_Utils/NEEDED_CHILDREN_MODULES

@@ -1 +1 @@
-Determinants Davidson
+Determinants Davidson Psiref_CAS

plugins/MRPT_Utils/density_matrix_based.irp.f

@@ -0,0 +1,193 @@
+subroutine contrib_1h2p_dm_based(accu)
+ implicit none
+ integer :: i_i,i_r,i_v,i_a,i_b
+ integer :: i,r,v,a,b
+ integer :: ispin,jspin
+ integer :: istate
+ double precision, intent(out) :: accu(N_states)
+ double precision :: active_int(n_act_orb,2)
+ double precision :: delta_e(n_act_orb,2,N_states)
+ double precision :: get_mo_bielec_integral
+ accu = 0.d0
+!do i_i = 1, 1
+ do i_i = 1, n_inact_orb
+  i = list_inact(i_i)
+! do i_r = 1, 1
+  do i_r = 1, n_virt_orb
+   r = list_virt(i_r)
+!  do i_v = 1, 1
+   do i_v = 1, n_virt_orb
+    v = list_virt(i_v)
+    do i_a = 1, n_act_orb
+     a = list_act(i_a)
+     active_int(i_a,1) = get_mo_bielec_integral(i,a,r,v,mo_integrals_map) ! direct
+     active_int(i_a,2) = get_mo_bielec_integral(i,a,v,r,mo_integrals_map) ! exchange
+     do istate = 1, N_states
+      do jspin=1, 2
+       delta_e(i_a,jspin,istate) = one_anhil(i_a,jspin,istate)                        &
+                                 - fock_virt_total_spin_trace(r,istate)               & 
+                                 - fock_virt_total_spin_trace(v,istate)               & 
+                                 + fock_core_inactive_total_spin_trace(i,istate)        
+       delta_e(i_a,jspin,istate) = 1.d0/delta_e(i_a,jspin,istate)  
+      enddo
+     enddo
+    enddo
+    do i_a = 1, n_act_orb
+     a = list_act(i_a)
+     do i_b = 1, n_act_orb
+!    do i_b = i_a, i_a
+      b = list_act(i_b)
+      do ispin = 1, 2 ! spin of (i --> r)
+       do jspin = 1, 2 ! spin of (a --> v)
+        if(ispin == jspin .and. r.le.v)cycle ! condition not to double count 
+        do istate = 1, N_states
+         if(ispin == jspin)then
+          accu(istate) += (active_int(i_a,1) - active_int(i_a,2)) * one_body_dm_mo_spin_index(a,b,istate,ispin)   &
+                                                          * (active_int(i_b,1) - active_int(i_b,2)) & 
+                                                          * delta_e(i_a,jspin,istate)
+         else 
+          accu(istate) += active_int(i_a,1)  * one_body_dm_mo_spin_index(a,b,istate,ispin) * delta_e(i_a,ispin,istate) & 
+                        * active_int(i_b,1) 
+         endif
+        enddo
+       enddo
+      enddo
+     enddo
+    enddo
+   enddo
+  enddo
+ enddo
+
+
+end
+
+subroutine contrib_2h1p_dm_based(accu)
+ implicit none
+ integer :: i_i,i_j,i_v,i_a,i_b
+ integer :: i,j,v,a,b
+ integer :: ispin,jspin
+ integer :: istate
+ double precision, intent(out) :: accu(N_states)
+ double precision :: active_int(n_act_orb,2)
+ double precision :: delta_e(n_act_orb,2,N_states)
+ double precision :: get_mo_bielec_integral
+ accu = 0.d0
+ do i_i = 1, n_inact_orb
+  i = list_inact(i_i)
+  do i_j = 1, n_inact_orb
+   j = list_inact(i_j)
+   do i_v = 1, n_virt_orb
+    v = list_virt(i_v)
+    do i_a = 1, n_act_orb
+     a = list_act(i_a)
+     active_int(i_a,1) = get_mo_bielec_integral(i,j,v,a,mo_integrals_map) ! direct
+     active_int(i_a,2) = get_mo_bielec_integral(i,j,a,v,mo_integrals_map) ! exchange
+     do istate = 1, N_states
+      do jspin=1, 2
+!      delta_e(i_a,jspin,istate) = 
+!                                
+       delta_e(i_a,jspin,istate) = one_creat(i_a,jspin,istate)  - fock_virt_total_spin_trace(v,istate)  &
+                                 + fock_core_inactive_total_spin_trace(i,istate)       &
+                                 + fock_core_inactive_total_spin_trace(j,istate)        
+       delta_e(i_a,jspin,istate) = 1.d0/delta_e(i_a,jspin,istate)  
+      enddo
+     enddo
+    enddo
+    do i_a = 1, n_act_orb
+     a = list_act(i_a)
+     do i_b = 1, n_act_orb
+!    do i_b = i_a, i_a
+      b = list_act(i_b)
+      do ispin = 1, 2 ! spin of (i --> v)
+       do jspin = 1, 2 ! spin of (j --> a)
+        if(ispin == jspin .and. i.le.j)cycle ! condition not to double count 
+        do istate = 1, N_states
+         if(ispin == jspin)then
+          accu(istate) += (active_int(i_a,1) - active_int(i_a,2)) * one_body_dm_dagger_mo_spin_index(a,b,istate,ispin)   &
+                                                          * (active_int(i_b,1) - active_int(i_b,2)) & 
+                                                          * delta_e(i_a,jspin,istate)
+         else 
+          accu(istate) += active_int(i_a,1)  * one_body_dm_dagger_mo_spin_index(a,b,istate,ispin) * delta_e(i_a,ispin,istate) & 
+                        * active_int(i_b,1) 
+         endif
+        enddo
+       enddo
+      enddo
+     enddo
+    enddo
+   enddo
+  enddo
+ enddo
+
+
+end
+
+
+!subroutine contrib_2p_dm_based(accu)
+!implicit none
+!integer :: i_r,i_v,i_a,i_b,i_c,i_d
+!integer :: r,v,a,b,c,d
+!integer :: ispin,jspin
+!integer :: istate
+!double precision, intent(out) :: accu(N_states)
+!double precision :: active_int(n_act_orb,n_act_orb,2)
+!double precision :: delta_e(n_act_orb,n_act_orb,2,2,N_states)
+!double precision :: get_mo_bielec_integral
+!accu = 0.d0
+!do i_r = 1, n_virt_orb
+! r = list_virt(i_r)
+! do i_v = 1, n_virt_orb
+!   v = list_virt(i_v)
+!   do i_a = 1, n_act_orb
+!    a = list_act(i_a)
+!    do i_b = 1, n_act_orb
+!     b = list_act(i_b)
+!     active_int(i_a,i_b,1) = get_mo_bielec_integral(a,b,r,v,mo_integrals_map) ! direct
+!     active_int(i_a,i_b,2) = get_mo_bielec_integral(a,b,v,r,mo_integrals_map) ! direct
+!     do istate = 1, N_states
+!      do jspin=1, 2 ! spin of i_a
+!       do ispin = 1, 2 ! spin of i_b
+!        delta_e(i_a,i_b,jspin,ispin,istate) = two_anhil(i_a,i_b,jspin,ispin,istate)    &
+!                                  - fock_virt_total_spin_trace(r,istate)               & 
+!                                  - fock_virt_total_spin_trace(v,istate)                 
+!        delta_e(i_a,i_b,jspin,ispin,istate) = 1.d0/delta_e(i_a,i_b,jspin,ispin,istate)  
+!       enddo
+!      enddo
+!     enddo
+!    enddo
+!   enddo
+!   ! diagonal terms 
+!   do i_a = 1, n_act_orb
+!    a = list_act(i_a)
+!    do i_b = 1, n_act_orb
+!     b = list_act(i_b)
+!     do ispin = 1, 2 ! spin of (a --> r)
+!      do jspin = 1, 2 ! spin of (b --> v)
+!       if(ispin == jspin .and. r.le.v)cycle ! condition not to double count 
+!       if(ispin == jspin .and. a.le.b)cycle ! condition not to double count 
+!       do istate = 1, N_states
+!        if(ispin == jspin)then
+!         double precision :: contrib_spin
+!         if(ispin == 1)then
+!          contrib_spin = two_body_dm_aa_diag_act(i_a,i_b)
+!         else
+!          contrib_spin = two_body_dm_bb_diag_act(i_a,i_b)
+!         endif
+!         accu(istate) += (active_int(i_a,i_b,1) - active_int(i_a,i_b,2)) * contrib_spin  &
+!                       * (active_int(i_a,i_b,1) - active_int(i_a,i_b,2)) & 
+!                       * delta_e(i_a,i_b,ispin,jspin,istate)
+!        else 
+!         accu(istate) += 0.5d0 * active_int(i_a,i_b,1)  * two_body_dm_ab_diag_act(i_a,i_b) * delta_e(i_a,i_b,ispin,jspin,istate) & 
+!                               * active_int(i_a,i_b,1) 
+!        endif
+!       enddo
+!      enddo
+!     enddo
+!    enddo
+!   enddo
+!  enddo
+! enddo
+
+
+!end
+

plugins/MRPT_Utils/energies_cas.irp.f

@@ -1,9 +1,9 @@
 BEGIN_PROVIDER [ double precision, energy_cas_dyall, (N_states)]
  implicit none
  integer :: i 
- double precision :: energies(N_states_diag)
+ double precision :: energies(N_states)
  do i = 1, N_states
-  call u0_H_dyall_u0(energies,psi_active,psi_coef,n_det,psi_det_size,psi_det_size,N_states_diag,i)
+  call u0_H_dyall_u0(energies,psi_active,psi_coef,n_det_ref,psi_det_size,psi_det_size,N_states,i)
   energy_cas_dyall(i) = energies(i)
   print*,  'energy_cas_dyall(i)',  energy_cas_dyall(i)
  enddo
@@ -13,9 +13,9 @@ END_PROVIDER
 BEGIN_PROVIDER [ double precision, energy_cas_dyall_no_exchange, (N_states)]
  implicit none
  integer :: i 
- double precision :: energies(N_states_diag)
+ double precision :: energies(N_states)
  do i = 1, N_states
-  call u0_H_dyall_u0_no_exchange(energies,psi_active,psi_coef,n_det,psi_det_size,psi_det_size,N_states_diag,i)
+  call u0_H_dyall_u0_no_exchange(energies,psi_active,psi_coef,n_det_ref,psi_det_size,psi_det_size,N_states,i)
   energy_cas_dyall_no_exchange(i) = energies(i)
   print*,  'energy_cas_dyall(i)_no_exchange',  energy_cas_dyall_no_exchange(i)
  enddo
@@ -28,22 +28,22 @@ BEGIN_PROVIDER [ double precision, one_creat, (n_act_orb,2,N_states)]
  integer :: i,j
  integer :: ispin
  integer :: orb, hole_particle,spin_exc
- double precision  :: norm_out(N_states_diag)
+ double precision  :: norm_out(N_states)
  integer(bit_kind), allocatable :: psi_in_out(:,:,:)
  double precision, allocatable :: psi_in_out_coef(:,:)
- allocate (psi_in_out(N_int,2,n_det),psi_in_out_coef(n_det,N_states_diag))
+ allocate (psi_in_out(N_int,2,n_det_ref),psi_in_out_coef(n_det_ref,N_states))
  use bitmasks
 
  integer :: iorb
  integer :: state_target
- double precision :: energies(n_states_diag)
+ double precision :: energies(n_states)
  do iorb = 1,n_act_orb
   do ispin = 1,2
    orb = list_act(iorb)
    hole_particle = 1
    spin_exc = ispin 
-   do i = 1, n_det
-    do j = 1, n_states_diag
+   do i = 1, n_det_ref
+    do j = 1, n_states
       psi_in_out_coef(i,j) = psi_coef(i,j)
     enddo
     do j = 1, N_int
@@ -53,8 +53,8 @@ BEGIN_PROVIDER [ double precision, one_creat, (n_act_orb,2,N_states)]
    enddo
     do  state_target = 1,N_states
      call apply_exc_to_psi(orb,hole_particle,spin_exc, & 
-             norm_out,psi_in_out,psi_in_out_coef, n_det,n_det,n_det,N_states_diag)
-     call u0_H_dyall_u0(energies,psi_in_out,psi_in_out_coef,n_det,n_det,n_det,N_states_diag,state_target)
+             norm_out,psi_in_out,psi_in_out_coef, n_det_ref,n_det_ref,n_det_ref,N_states)
+     call u0_H_dyall_u0(energies,psi_in_out,psi_in_out_coef,n_det_ref,n_det_ref,n_det_ref,N_states,state_target)
      one_creat(iorb,ispin,state_target) = energy_cas_dyall(state_target)  - energies(state_target)
     enddo
   enddo
@@ -68,22 +68,22 @@ BEGIN_PROVIDER [ double precision, one_anhil, (n_act_orb,2,N_states)]
  integer :: i,j
  integer :: ispin
  integer :: orb, hole_particle,spin_exc
- double precision  :: norm_out(N_states_diag)
+ double precision  :: norm_out(N_states)
  integer(bit_kind), allocatable :: psi_in_out(:,:,:)
  double precision, allocatable :: psi_in_out_coef(:,:)
  use bitmasks
- allocate (psi_in_out(N_int,2,n_det),psi_in_out_coef(n_det,N_states_diag))
+ allocate (psi_in_out(N_int,2,n_det_ref),psi_in_out_coef(n_det_ref,N_states))
 
  integer :: iorb
  integer :: state_target
- double precision :: energies(n_states_diag)
+ double precision :: energies(n_states)
  do iorb = 1,n_act_orb
   do ispin = 1,2
    orb = list_act(iorb)
    hole_particle = -1
    spin_exc = ispin 
-   do i = 1, n_det
-    do j = 1, n_states_diag
+   do i = 1, n_det_ref
+    do j = 1, n_states
       psi_in_out_coef(i,j) = psi_coef(i,j)
     enddo
     do j = 1, N_int
@@ -93,8 +93,8 @@ BEGIN_PROVIDER [ double precision, one_anhil, (n_act_orb,2,N_states)]
    enddo
    do state_target = 1, N_states
     call apply_exc_to_psi(orb,hole_particle,spin_exc, & 
-            norm_out,psi_in_out,psi_in_out_coef, n_det,n_det,n_det,N_states_diag)
-    call u0_H_dyall_u0(energies,psi_in_out,psi_in_out_coef,n_det,n_det,n_det,N_states_diag,state_target)
+            norm_out,psi_in_out,psi_in_out_coef, n_det_ref,n_det_ref,n_det_ref,N_states)
+    call u0_H_dyall_u0(energies,psi_in_out,psi_in_out_coef,n_det_ref,n_det_ref,n_det_ref,N_states,state_target)
     one_anhil(iorb,ispin,state_target) = energy_cas_dyall(state_target)  -  energies(state_target)
    enddo
   enddo
@@ -109,15 +109,15 @@ BEGIN_PROVIDER [ double precision, two_creat, (n_act_orb,n_act_orb,2,2,N_states)
  integer :: ispin,jspin
  integer :: orb_i, hole_particle_i,spin_exc_i
  integer :: orb_j, hole_particle_j,spin_exc_j
- double precision  :: norm_out(N_states_diag)
+ double precision  :: norm_out(N_states)
  integer(bit_kind), allocatable :: psi_in_out(:,:,:)
  double precision, allocatable :: psi_in_out_coef(:,:)
  use bitmasks
- allocate (psi_in_out(N_int,2,n_det),psi_in_out_coef(n_det,N_states_diag))
+ allocate (psi_in_out(N_int,2,n_det_ref),psi_in_out_coef(n_det_ref,N_states))
 
  integer :: iorb,jorb
  integer :: state_target
- double precision :: energies(n_states_diag)
+ double precision :: energies(n_states)
  do iorb = 1,n_act_orb
   do ispin = 1,2
    orb_i = list_act(iorb)
@@ -128,8 +128,8 @@ BEGIN_PROVIDER [ double precision, two_creat, (n_act_orb,n_act_orb,2,2,N_states)
      orb_j = list_act(jorb)
      hole_particle_j = 1
      spin_exc_j = jspin 
-     do i = 1, n_det
-      do j = 1, n_states_diag
+     do i = 1, n_det_ref
+      do j = 1, n_states
         psi_in_out_coef(i,j) = psi_coef(i,j)
       enddo
       do j = 1, N_int
@@ -139,10 +139,10 @@ BEGIN_PROVIDER [ double precision, two_creat, (n_act_orb,n_act_orb,2,2,N_states)
      enddo
      do state_target = 1 , N_states
       call apply_exc_to_psi(orb_i,hole_particle_i,spin_exc_i, & 
-              norm_out,psi_in_out,psi_in_out_coef, n_det,n_det,n_det,N_states_diag)
+              norm_out,psi_in_out,psi_in_out_coef, n_det_ref,n_det_ref,n_det_ref,N_states)
       call apply_exc_to_psi(orb_j,hole_particle_j,spin_exc_j, & 
-              norm_out,psi_in_out,psi_in_out_coef, n_det,n_det,n_det,N_states_diag)
-      call u0_H_dyall_u0(energies,psi_in_out,psi_in_out_coef,n_det,n_det,n_det,N_states_diag,state_target)
+              norm_out,psi_in_out,psi_in_out_coef, n_det_ref,n_det_ref,n_det_ref,N_states)
+      call u0_H_dyall_u0(energies,psi_in_out,psi_in_out_coef,n_det_ref,n_det_ref,n_det_ref,N_states,state_target)
       two_creat(iorb,jorb,ispin,jspin,state_target) = energy_cas_dyall(state_target)  -   energies(state_target)
      enddo
     enddo
@@ -159,16 +159,16 @@ BEGIN_PROVIDER [ double precision, two_anhil, (n_act_orb,n_act_orb,2,2,N_states)
  integer :: ispin,jspin
  integer :: orb_i, hole_particle_i,spin_exc_i
  integer :: orb_j, hole_particle_j,spin_exc_j
- double precision  :: norm_out(N_states_diag)
+ double precision  :: norm_out(N_states)
  integer(bit_kind), allocatable :: psi_in_out(:,:,:)
  double precision, allocatable :: psi_in_out_coef(:,:)
  use bitmasks
- allocate (psi_in_out(N_int,2,n_det),psi_in_out_coef(n_det,N_states_diag))
+ allocate (psi_in_out(N_int,2,n_det_ref),psi_in_out_coef(n_det_ref,N_states))
 
  integer :: iorb,jorb
  integer :: state_target
  state_target = 1
- double precision :: energies(n_states_diag)
+ double precision :: energies(n_states)
  do iorb = 1,n_act_orb
   do ispin = 1,2
    orb_i = list_act(iorb)
@@ -179,8 +179,8 @@ BEGIN_PROVIDER [ double precision, two_anhil, (n_act_orb,n_act_orb,2,2,N_states)
      orb_j = list_act(jorb)
      hole_particle_j = -1
      spin_exc_j = jspin 
-     do i = 1, n_det
-      do j = 1, n_states_diag
+     do i = 1, n_det_ref
+      do j = 1, n_states
         psi_in_out_coef(i,j) = psi_coef(i,j)
       enddo
       do j = 1, N_int
@@ -189,10 +189,10 @@ BEGIN_PROVIDER [ double precision, two_anhil, (n_act_orb,n_act_orb,2,2,N_states)
       enddo
      enddo
      call apply_exc_to_psi(orb_i,hole_particle_i,spin_exc_i, & 
-             norm_out,psi_in_out,psi_in_out_coef, n_det,n_det,n_det,N_states_diag)
+             norm_out,psi_in_out,psi_in_out_coef, n_det_ref,n_det_ref,n_det_ref,N_states)
      call apply_exc_to_psi(orb_j,hole_particle_j,spin_exc_j, & 
-             norm_out,psi_in_out,psi_in_out_coef, n_det,n_det,n_det,N_states_diag)
-     call u0_H_dyall_u0(energies,psi_in_out,psi_in_out_coef,n_det,n_det,n_det,N_states_diag,state_target)
+             norm_out,psi_in_out,psi_in_out_coef, n_det_ref,n_det_ref,n_det_ref,N_states)
+     call u0_H_dyall_u0(energies,psi_in_out,psi_in_out_coef,n_det_ref,n_det_ref,n_det_ref,N_states,state_target)
      two_anhil(iorb,jorb,ispin,jspin,state_target) = energy_cas_dyall(state_target)  -   energies(state_target)
     enddo
    enddo
@@ -208,15 +208,15 @@ BEGIN_PROVIDER [ double precision, one_anhil_one_creat, (n_act_orb,n_act_orb,2,2
  integer :: ispin,jspin
  integer :: orb_i, hole_particle_i,spin_exc_i
  integer :: orb_j, hole_particle_j,spin_exc_j
- double precision  :: norm_out(N_states_diag)
+ double precision  :: norm_out(N_states)
  integer(bit_kind), allocatable :: psi_in_out(:,:,:)
  double precision, allocatable :: psi_in_out_coef(:,:)
  use bitmasks
 
- allocate (psi_in_out(N_int,2,n_det),psi_in_out_coef(n_det,N_states_diag))
+ allocate (psi_in_out(N_int,2,n_det_ref),psi_in_out_coef(n_det_ref,N_states))
  integer :: iorb,jorb
  integer :: state_target
- double precision :: energies(n_states_diag)
+ double precision :: energies(n_states)
  do iorb = 1,n_act_orb
   do ispin = 1,2
    orb_i = list_act(iorb)
@@ -227,8 +227,8 @@ BEGIN_PROVIDER [ double precision, one_anhil_one_creat, (n_act_orb,n_act_orb,2,2
      orb_j = list_act(jorb)
      hole_particle_j = -1
      spin_exc_j = jspin 
-      do i = 1, n_det
-       do j = 1, n_states_diag
+      do i = 1, n_det_ref
+       do j = 1, n_states
          psi_in_out_coef(i,j) = psi_coef(i,j)
        enddo
        do j = 1, N_int
@@ -238,14 +238,14 @@ BEGIN_PROVIDER [ double precision, one_anhil_one_creat, (n_act_orb,n_act_orb,2,2
       enddo
       do state_target = 1, N_states
        call apply_exc_to_psi(orb_j,hole_particle_j,spin_exc_j, & 
-               norm_out,psi_in_out,psi_in_out_coef, n_det,n_det,n_det,N_states_diag)
+               norm_out,psi_in_out,psi_in_out_coef, n_det_ref,n_det_ref,n_det_ref,N_states)
        call apply_exc_to_psi(orb_i,hole_particle_i,spin_exc_i, & 
-               norm_out,psi_in_out,psi_in_out_coef, n_det,n_det,n_det,N_states_diag)
+               norm_out,psi_in_out,psi_in_out_coef, n_det_ref,n_det_ref,n_det_ref,N_states)
        if(orb_i == orb_j .and. ispin .ne. jspin)then  
-        call u0_H_dyall_u0_no_exchange(energies,psi_in_out,psi_in_out_coef,n_det,n_det,n_det,N_states_diag,state_target)
+        call u0_H_dyall_u0_no_exchange(energies,psi_in_out,psi_in_out_coef,n_det_ref,n_det_ref,n_det_ref,N_states,state_target)
         one_anhil_one_creat(iorb,jorb,ispin,jspin,state_target) = energy_cas_dyall_no_exchange(state_target)  -   energies(state_target)
        else
-        call u0_H_dyall_u0(energies,psi_in_out,psi_in_out_coef,n_det,n_det,n_det,N_states_diag,state_target)
+        call u0_H_dyall_u0(energies,psi_in_out,psi_in_out_coef,n_det_ref,n_det_ref,n_det_ref,N_states,state_target)
         one_anhil_one_creat(iorb,jorb,ispin,jspin,state_target) = energy_cas_dyall(state_target)  -   energies(state_target)
        endif
       enddo
@@ -264,16 +264,16 @@ BEGIN_PROVIDER [ double precision, two_anhil_one_creat, (n_act_orb,n_act_orb,n_a
  integer :: orb_i, hole_particle_i,spin_exc_i
  integer :: orb_j, hole_particle_j,spin_exc_j
  integer :: orb_k, hole_particle_k,spin_exc_k
- double precision  :: norm_out(N_states_diag)
+ double precision  :: norm_out(N_states)
  integer(bit_kind), allocatable :: psi_in_out(:,:,:)
  double precision, allocatable :: psi_in_out_coef(:,:)
  use bitmasks
- allocate (psi_in_out(N_int,2,n_det),psi_in_out_coef(n_det,N_states_diag))
+ allocate (psi_in_out(N_int,2,n_det_ref),psi_in_out_coef(n_det_ref,N_states))
 
  integer :: iorb,jorb
  integer :: korb
  integer :: state_target
- double precision :: energies(n_states_diag)
+ double precision :: energies(n_states)
  do iorb = 1,n_act_orb
   do ispin = 1,2
    orb_i = list_act(iorb)
@@ -289,8 +289,8 @@ BEGIN_PROVIDER [ double precision, two_anhil_one_creat, (n_act_orb,n_act_orb,n_a
        orb_k = list_act(korb)
        hole_particle_k = -1
        spin_exc_k = kspin 
-       do i = 1, n_det
-        do j = 1, n_states_diag
+       do i = 1, n_det_ref
+        do j = 1, n_states
           psi_in_out_coef(i,j) = psi_coef(i,j)
         enddo
         do j = 1, N_int
@@ -301,12 +301,12 @@ BEGIN_PROVIDER [ double precision, two_anhil_one_creat, (n_act_orb,n_act_orb,n_a
 
        do state_target = 1, N_states 
         call apply_exc_to_psi(orb_j,hole_particle_j,spin_exc_j, & 
-                norm_out,psi_in_out,psi_in_out_coef, n_det,n_det,n_det,N_states_diag)
+                norm_out,psi_in_out,psi_in_out_coef, n_det_ref,n_det_ref,n_det_ref,N_states)
         call apply_exc_to_psi(orb_k,hole_particle_k,spin_exc_k, & 
-                norm_out,psi_in_out,psi_in_out_coef, n_det,n_det,n_det,N_states_diag)
+                norm_out,psi_in_out,psi_in_out_coef, n_det_ref,n_det_ref,n_det_ref,N_states)
         call apply_exc_to_psi(orb_i,hole_particle_i,spin_exc_i, & 
-                norm_out,psi_in_out,psi_in_out_coef, n_det,n_det,n_det,N_states_diag)
-        call u0_H_dyall_u0(energies,psi_in_out,psi_in_out_coef,n_det,n_det,n_det,N_states_diag,state_target)
+                norm_out,psi_in_out,psi_in_out_coef, n_det_ref,n_det_ref,n_det_ref,N_states)
+        call u0_H_dyall_u0(energies,psi_in_out,psi_in_out_coef,n_det_ref,n_det_ref,n_det_ref,N_states,state_target)
         two_anhil_one_creat(iorb,jorb,korb,ispin,jspin,kspin,state_target) = energy_cas_dyall(state_target)  -  energies(state_target)
        enddo
       enddo
@@ -326,16 +326,16 @@ BEGIN_PROVIDER [ double precision, two_creat_one_anhil, (n_act_orb,n_act_orb,n_a
  integer :: orb_i, hole_particle_i,spin_exc_i
  integer :: orb_j, hole_particle_j,spin_exc_j
  integer :: orb_k, hole_particle_k,spin_exc_k
- double precision  :: norm_out(N_states_diag)
+ double precision  :: norm_out(N_states)
  integer(bit_kind), allocatable :: psi_in_out(:,:,:)
  double precision, allocatable :: psi_in_out_coef(:,:)
  use bitmasks
- allocate (psi_in_out(N_int,2,n_det),psi_in_out_coef(n_det,N_states_diag))
+ allocate (psi_in_out(N_int,2,n_det_ref),psi_in_out_coef(n_det_ref,N_states))
 
  integer :: iorb,jorb
  integer :: korb
  integer :: state_target
- double precision :: energies(n_states_diag)
+ double precision :: energies(n_states)
  do iorb = 1,n_act_orb
   do ispin = 1,2
    orb_i = list_act(iorb)
@@ -351,8 +351,8 @@ BEGIN_PROVIDER [ double precision, two_creat_one_anhil, (n_act_orb,n_act_orb,n_a
        orb_k = list_act(korb)
        hole_particle_k = -1
        spin_exc_k = kspin 
-       do i = 1, n_det
-        do j = 1, n_states_diag
+       do i = 1, n_det_ref
+        do j = 1, n_states
           psi_in_out_coef(i,j) = psi_coef(i,j)
         enddo
         do j = 1, N_int
@@ -362,12 +362,12 @@ BEGIN_PROVIDER [ double precision, two_creat_one_anhil, (n_act_orb,n_act_orb,n_a
        enddo
        do state_target = 1, N_states
         call apply_exc_to_psi(orb_k,hole_particle_k,spin_exc_k, & 
-                norm_out,psi_in_out,psi_in_out_coef, n_det,n_det,n_det,N_states_diag)
+                norm_out,psi_in_out,psi_in_out_coef, n_det_ref,n_det_ref,n_det_ref,N_states)
         call apply_exc_to_psi(orb_i,hole_particle_i,spin_exc_i, & 
-                norm_out,psi_in_out,psi_in_out_coef, n_det,n_det,n_det,N_states_diag)
+                norm_out,psi_in_out,psi_in_out_coef, n_det_ref,n_det_ref,n_det_ref,N_states)
         call apply_exc_to_psi(orb_j,hole_particle_j,spin_exc_j, & 
-                norm_out,psi_in_out,psi_in_out_coef, n_det,n_det,n_det,N_states_diag)
-        call u0_H_dyall_u0(energies,psi_in_out,psi_in_out_coef,n_det,n_det,n_det,N_states_diag,state_target)
+                norm_out,psi_in_out,psi_in_out_coef, n_det_ref,n_det_ref,n_det_ref,N_states)
+        call u0_H_dyall_u0(energies,psi_in_out,psi_in_out_coef,n_det_ref,n_det_ref,n_det_ref,N_states,state_target)
         two_creat_one_anhil(iorb,jorb,korb,ispin,jspin,kspin,state_target) = energy_cas_dyall(state_target)  -  energies(state_target)
        enddo
       enddo
@@ -387,16 +387,16 @@ BEGIN_PROVIDER [ double precision, three_creat, (n_act_orb,n_act_orb,n_act_orb,2
  integer :: orb_i, hole_particle_i,spin_exc_i
  integer :: orb_j, hole_particle_j,spin_exc_j
  integer :: orb_k, hole_particle_k,spin_exc_k
- double precision  :: norm_out(N_states_diag)
+ double precision  :: norm_out(N_states)
  integer(bit_kind), allocatable :: psi_in_out(:,:,:)
  double precision, allocatable :: psi_in_out_coef(:,:)
  use bitmasks
- allocate (psi_in_out(N_int,2,n_det),psi_in_out_coef(n_det,N_states_diag))
+ allocate (psi_in_out(N_int,2,n_det_ref),psi_in_out_coef(n_det_ref,N_states))
 
  integer :: iorb,jorb
  integer :: korb
  integer :: state_target
- double precision :: energies(n_states_diag)
+ double precision :: energies(n_states)
  do iorb = 1,n_act_orb
   do ispin = 1,2
    orb_i = list_act(iorb)
@@ -412,8 +412,8 @@ BEGIN_PROVIDER [ double precision, three_creat, (n_act_orb,n_act_orb,n_act_orb,2
        orb_k = list_act(korb)
        hole_particle_k =  1
        spin_exc_k = kspin 
-       do i = 1, n_det
-        do j = 1, n_states_diag
+       do i = 1, n_det_ref
+        do j = 1, n_states
           psi_in_out_coef(i,j) = psi_coef(i,j)
         enddo
         do j = 1, N_int
@@ -423,12 +423,12 @@ BEGIN_PROVIDER [ double precision, three_creat, (n_act_orb,n_act_orb,n_act_orb,2
        enddo
        do state_target = 1, N_states
         call apply_exc_to_psi(orb_i,hole_particle_i,spin_exc_i, & 
-                norm_out,psi_in_out,psi_in_out_coef, n_det,n_det,n_det,N_states_diag)
+                norm_out,psi_in_out,psi_in_out_coef, n_det_ref,n_det_ref,n_det_ref,N_states)
         call apply_exc_to_psi(orb_j,hole_particle_j,spin_exc_j, & 
-                norm_out,psi_in_out,psi_in_out_coef, n_det,n_det,n_det,N_states_diag)
+                norm_out,psi_in_out,psi_in_out_coef, n_det_ref,n_det_ref,n_det_ref,N_states)
         call apply_exc_to_psi(orb_k,hole_particle_k,spin_exc_k, & 
-                norm_out,psi_in_out,psi_in_out_coef, n_det,n_det,n_det,N_states_diag)
-        call u0_H_dyall_u0(energies,psi_in_out,psi_in_out_coef,n_det,n_det,n_det,N_states_diag,state_target)
+                norm_out,psi_in_out,psi_in_out_coef, n_det_ref,n_det_ref,n_det_ref,N_states)
+        call u0_H_dyall_u0(energies,psi_in_out,psi_in_out_coef,n_det_ref,n_det_ref,n_det_ref,N_states,state_target)
         three_creat(iorb,jorb,korb,ispin,jspin,kspin,state_target) = energy_cas_dyall(state_target)  -  energies(state_target)
        enddo
       enddo
@@ -448,16 +448,16 @@ BEGIN_PROVIDER [ double precision, three_anhil, (n_act_orb,n_act_orb,n_act_orb,2
  integer :: orb_i, hole_particle_i,spin_exc_i
  integer :: orb_j, hole_particle_j,spin_exc_j
  integer :: orb_k, hole_particle_k,spin_exc_k
- double precision  :: norm_out(N_states_diag)
+ double precision  :: norm_out(N_states)
  integer(bit_kind), allocatable :: psi_in_out(:,:,:)
  double precision, allocatable :: psi_in_out_coef(:,:)
  use bitmasks
- allocate (psi_in_out(N_int,2,n_det),psi_in_out_coef(n_det,N_states_diag))
+ allocate (psi_in_out(N_int,2,n_det_ref),psi_in_out_coef(n_det_ref,N_states))
 
  integer :: iorb,jorb
  integer :: korb
  integer :: state_target
- double precision :: energies(n_states_diag)
+ double precision :: energies(n_states)
  do iorb = 1,n_act_orb
   do ispin = 1,2
    orb_i = list_act(iorb)
@@ -473,8 +473,8 @@ BEGIN_PROVIDER [ double precision, three_anhil, (n_act_orb,n_act_orb,n_act_orb,2
        orb_k = list_act(korb)
        hole_particle_k = -1
        spin_exc_k = kspin 
-       do i = 1, n_det
-        do j = 1, n_states_diag
+       do i = 1, n_det_ref
+        do j = 1, n_states
           psi_in_out_coef(i,j) = psi_coef(i,j)
         enddo
         do j = 1, N_int
@@ -484,12 +484,12 @@ BEGIN_PROVIDER [ double precision, three_anhil, (n_act_orb,n_act_orb,n_act_orb,2
        enddo
        do state_target = 1, N_states
         call apply_exc_to_psi(orb_i,hole_particle_i,spin_exc_i, & 
-                norm_out,psi_in_out,psi_in_out_coef, n_det,n_det,n_det,N_states_diag)
+                norm_out,psi_in_out,psi_in_out_coef, n_det_ref,n_det_ref,n_det_ref,N_states)
         call apply_exc_to_psi(orb_j,hole_particle_j,spin_exc_j, & 
-                norm_out,psi_in_out,psi_in_out_coef, n_det,n_det,n_det,N_states_diag)
+                norm_out,psi_in_out,psi_in_out_coef, n_det_ref,n_det_ref,n_det_ref,N_states)
         call apply_exc_to_psi(orb_k,hole_particle_k,spin_exc_k, & 
-                norm_out,psi_in_out,psi_in_out_coef, n_det,n_det,n_det,N_states_diag)
-        call u0_H_dyall_u0(energies,psi_in_out,psi_in_out_coef,n_det,n_det,n_det,N_states_diag,state_target)
+                norm_out,psi_in_out,psi_in_out_coef, n_det_ref,n_det_ref,n_det_ref,N_states)
+        call u0_H_dyall_u0(energies,psi_in_out,psi_in_out_coef,n_det_ref,n_det_ref,n_det_ref,N_states,state_target)
         three_anhil(iorb,jorb,korb,ispin,jspin,kspin,state_target) = energy_cas_dyall(state_target)  -  energies(state_target)
        enddo
       enddo
@@ -511,15 +511,15 @@ END_PROVIDER
  integer :: ispin,jspin
  integer :: orb_i, hole_particle_i
  integer :: orb_v
- double precision  :: norm_out(N_states_diag)
+ double precision  :: norm_out(N_states)
  integer(bit_kind), allocatable :: psi_in_out(:,:,:)
  double precision, allocatable :: psi_in_out_coef(:,:)
  use bitmasks
- allocate (psi_in_out(N_int,2,n_det),psi_in_out_coef(n_det,N_states_diag))
+ allocate (psi_in_out(N_int,2,n_det_ref),psi_in_out_coef(n_det_ref,N_states))
 
  integer :: iorb,jorb,i_ok
  integer :: state_target
- double precision :: energies(n_states_diag)
+ double precision :: energies(n_states)
  double precision :: hij
  double precision :: norm(N_states,2),norm_no_inv(N_states,2),norm_bis(N_states,2)
  double precision :: energies_alpha_beta(N_states,2)
@@ -541,10 +541,10 @@ END_PROVIDER
      do state_target  =1 , N_states
       one_anhil_one_creat_inact_virt_norm(iorb,vorb,state_target,ispin) = 0.d0
      enddo
-     do i = 1, n_det
+     do i = 1, n_det_ref
       do j = 1, N_int
-       psi_in_out(j,1,i) =  psi_det(j,1,i) 
-       psi_in_out(j,2,i) =  psi_det(j,2,i) 
+       psi_in_out(j,1,i) =  psi_ref(j,1,i) 
+       psi_in_out(j,2,i) =  psi_ref(j,2,i) 
       enddo
       call do_mono_excitation(psi_in_out(1,1,i),orb_i,orb_v,ispin,i_ok)
       if(i_ok.ne.1)then
@@ -552,7 +552,7 @@ END_PROVIDER
        call debug_det(psi_in_out,N_int)
        print*, 'pb, i_ok ne 0 !!!'
       endif
-      call i_H_j(psi_in_out(1,1,i),psi_det(1,1,i),N_int,hij)
+      call i_H_j(psi_in_out(1,1,i),psi_ref(1,1,i),N_int,hij)
       do j = 1, n_states
         double precision ::  coef,contrib
         coef = psi_coef(i,j) !* psi_coef(i,j)
@@ -585,7 +585,7 @@ END_PROVIDER
       energies_alpha_beta(state_target, ispin) = - mo_bielec_integral_jj_exchange(orb_i,orb_v)
 !     energies_alpha_beta(state_target, ispin) = 0.d0
       if(norm(state_target,ispin) .ne. 0.d0 .and. dabs(norm_no_inv(state_target,ispin)) .gt. thresh_norm)then
-       call u0_H_dyall_u0(energies,psi_in_out,psi_in_out_coef,n_det,n_det,n_det,N_states_diag,state_target)
+       call u0_H_dyall_u0(energies,psi_in_out,psi_in_out_coef,n_det_ref,n_det_ref,n_det_ref,N_states,state_target)
        energies_alpha_beta(state_target, ispin) +=  energies(state_target) 
       endif
      enddo
@@ -616,15 +616,15 @@ BEGIN_PROVIDER [ double precision, one_anhil_inact, (n_inact_orb,n_act_orb,N_Sta
  integer :: i,iorb,j
  integer :: ispin,jspin
  integer :: orb_i, hole_particle_i
- double precision  :: norm_out(N_states_diag)
+ double precision  :: norm_out(N_states)
  integer(bit_kind), allocatable :: psi_in_out(:,:,:)
  double precision, allocatable :: psi_in_out_coef(:,:)
  use bitmasks
- allocate (psi_in_out(N_int,2,n_det),psi_in_out_coef(n_det,N_states_diag))
+ allocate (psi_in_out(N_int,2,n_det_ref),psi_in_out_coef(n_det_ref,N_states))
 
  integer :: jorb,i_ok,aorb,orb_a
  integer :: state_target
- double precision :: energies(n_states_diag)
+ double precision :: energies(n_states)
  double precision :: hij
  double precision :: norm(N_states,2),norm_no_inv(N_states,2)
  double precision :: energies_alpha_beta(N_states,2)
@@ -645,10 +645,10 @@ BEGIN_PROVIDER [ double precision, one_anhil_inact, (n_inact_orb,n_act_orb,N_Sta
     norm = 0.d0
     norm_bis = 0.d0
     do ispin = 1,2
-     do i = 1, n_det
+     do i = 1, n_det_ref
       do j = 1, N_int
-       psi_in_out(j,1,i) =  psi_det(j,1,i) 
-       psi_in_out(j,2,i) =  psi_det(j,2,i) 
+       psi_in_out(j,1,i) =  psi_ref(j,1,i) 
+       psi_in_out(j,2,i) =  psi_ref(j,2,i) 
       enddo
       call do_mono_excitation(psi_in_out(1,1,i),orb_i,orb_a,ispin,i_ok)
       if(i_ok.ne.1)then
@@ -656,7 +656,7 @@ BEGIN_PROVIDER [ double precision, one_anhil_inact, (n_inact_orb,n_act_orb,N_Sta
          psi_in_out_coef(i,j) = 0.d0
        enddo
       else
-       call i_H_j(psi_in_out(1,1,i),psi_det(1,1,i),N_int,hij)
+       call i_H_j(psi_in_out(1,1,i),psi_ref(1,1,i),N_int,hij)
        do j = 1, n_states
          double precision ::  coef,contrib
          coef = psi_coef(i,j) !* psi_coef(i,j)
@@ -688,7 +688,7 @@ BEGIN_PROVIDER [ double precision, one_anhil_inact, (n_inact_orb,n_act_orb,N_Sta
      do state_target = 1, N_states
       energies_alpha_beta(state_target, ispin) = 0.d0
       if(norm(state_target,ispin) .ne. 0.d0 .and. dabs(norm_no_inv(state_target,ispin)) .gt. thresh_norm)then
-       call u0_H_dyall_u0(energies,psi_in_out,psi_in_out_coef,n_det,n_det,n_det,N_states_diag,state_target)
+       call u0_H_dyall_u0(energies,psi_in_out,psi_in_out_coef,n_det_ref,n_det_ref,n_det_ref,N_states,state_target)
        energies_alpha_beta(state_target, ispin) +=  energies(state_target) 
       endif
      enddo
@@ -701,11 +701,6 @@ BEGIN_PROVIDER [ double precision, one_anhil_inact, (n_inact_orb,n_act_orb,N_Sta
     else  
      one_anhil_inact(iorb,aorb,state_target) = 0.d0
     endif
-!   print*, '********'
-!   print*, energies_alpha_beta(state_target,1) , energies_alpha_beta(state_target,2)
-!   print*, norm_bis(state_target,1) ,  norm_bis(state_target,2)
-!   print*, one_anhil_inact(iorb,aorb,state_target)
-!   print*, one_creat(aorb,1,state_target)
    enddo
   enddo
  enddo
@@ -719,15 +714,15 @@ BEGIN_PROVIDER [ double precision, one_creat_virt, (n_act_orb,n_virt_orb,N_State
  integer :: ispin,jspin
  integer :: orb_i, hole_particle_i
  integer :: orb_v
- double precision  :: norm_out(N_states_diag)
+ double precision  :: norm_out(N_states)
  integer(bit_kind), allocatable :: psi_in_out(:,:,:)
  double precision, allocatable :: psi_in_out_coef(:,:)
  use bitmasks
- allocate (psi_in_out(N_int,2,n_det),psi_in_out_coef(n_det,N_states_diag))
+ allocate (psi_in_out(N_int,2,n_det_ref),psi_in_out_coef(n_det_ref,N_states))
 
  integer :: iorb,jorb,i_ok,aorb,orb_a
  integer :: state_target
- double precision :: energies(n_states_diag)
+ double precision :: energies(n_states)
  double precision :: hij
  double precision :: norm(N_states,2),norm_no_inv(N_states,2)
  double precision :: energies_alpha_beta(N_states,2)
@@ -748,10 +743,10 @@ BEGIN_PROVIDER [ double precision, one_creat_virt, (n_act_orb,n_virt_orb,N_State
     norm = 0.d0
     norm_bis = 0.d0
     do ispin = 1,2
-     do i = 1, n_det
+     do i = 1, n_det_ref
       do j = 1, N_int
-       psi_in_out(j,1,i) =  psi_det(j,1,i) 
-       psi_in_out(j,2,i) =  psi_det(j,2,i) 
+       psi_in_out(j,1,i) =  psi_ref(j,1,i) 
+       psi_in_out(j,2,i) =  psi_ref(j,2,i) 
       enddo
       call do_mono_excitation(psi_in_out(1,1,i),orb_a,orb_v,ispin,i_ok)
       if(i_ok.ne.1)then
@@ -759,7 +754,7 @@ BEGIN_PROVIDER [ double precision, one_creat_virt, (n_act_orb,n_virt_orb,N_State
          psi_in_out_coef(i,j) = 0.d0
        enddo
       else
-       call i_H_j(psi_in_out(1,1,i),psi_det(1,1,i),N_int,hij)
+       call i_H_j(psi_in_out(1,1,i),psi_ref(1,1,i),N_int,hij)
        do j = 1, n_states
          double precision ::  coef,contrib
          coef = psi_coef(i,j) !* psi_coef(i,j)
@@ -791,7 +786,7 @@ BEGIN_PROVIDER [ double precision, one_creat_virt, (n_act_orb,n_virt_orb,N_State
      do state_target = 1, N_states
       energies_alpha_beta(state_target, ispin) = 0.d0
       if(norm(state_target,ispin) .ne. 0.d0 .and. dabs(norm_no_inv(state_target,ispin)) .gt. thresh_norm)then
-       call u0_H_dyall_u0(energies,psi_in_out,psi_in_out_coef,n_det,n_det,n_det,N_states_diag,state_target)
+       call u0_H_dyall_u0(energies,psi_in_out,psi_in_out_coef,n_det_ref,n_det_ref,n_det_ref,N_states,state_target)
 !      print*,  energies(state_target)
        energies_alpha_beta(state_target, ispin) +=  energies(state_target) 
       endif
@@ -825,19 +820,19 @@ END_PROVIDER
  integer :: ispin,jspin
  integer :: orb_i, hole_particle_i
  integer :: orb_v
- double precision  :: norm_out(N_states_diag),diag_elem(N_det),interact_psi0(N_det)
+ double precision  :: norm_out(N_states),diag_elem(N_det),interact_psi0(N_det)
  double precision  :: delta_e_inact_virt(N_states)
  integer(bit_kind), allocatable :: psi_in_out(:,:,:)
  double precision, allocatable :: psi_in_out_coef(:,:)
  double precision, allocatable :: H_matrix(:,:),eigenvectors(:,:),eigenvalues(:)
  use bitmasks
- allocate (psi_in_out(N_int,2,n_det),psi_in_out_coef(n_det,N_states_diag),H_matrix(N_det+1,N_det+1))
+ allocate (psi_in_out(N_int,2,n_det_ref),psi_in_out_coef(n_det_ref,N_states),H_matrix(N_det+1,N_det+1))
  allocate (eigenvectors(size(H_matrix,1),N_det+1))
  allocate (eigenvalues(N_det+1))
 
  integer :: iorb,jorb,i_ok
  integer :: state_target
- double precision :: energies(n_states_diag)
+ double precision :: energies(n_states)
  double precision :: hij
  double precision :: energies_alpha_beta(N_states,2)
 
@@ -857,10 +852,10 @@ END_PROVIDER
                            - fock_virt_total_spin_trace(orb_v,j) 
     enddo
     do ispin = 1,2
-     do i = 1, n_det
+     do i = 1, n_det_ref
       do j = 1, N_int
-       psi_in_out(j,1,i) =  psi_det(j,1,i) 
-       psi_in_out(j,2,i) =  psi_det(j,2,i) 
+       psi_in_out(j,1,i) =  psi_ref(j,1,i) 
+       psi_in_out(j,2,i) =  psi_ref(j,2,i) 
       enddo
       call do_mono_excitation(psi_in_out(1,1,i),orb_i,orb_v,ispin,i_ok)
       if(i_ok.ne.1)then
@@ -870,7 +865,7 @@ END_PROVIDER
       endif
       interact_psi0(i) = 0.d0
       do j = 1 , N_det
-       call i_H_j(psi_in_out(1,1,i),psi_det(1,1,j),N_int,hij)
+       call i_H_j(psi_in_out(1,1,i),psi_ref(1,1,j),N_int,hij)
        interact_psi0(i) += hij * psi_coef(j,1)
       enddo
       do j = 1, N_int
@@ -973,21 +968,21 @@ subroutine give_singles_and_partial_doubles_1h1p_contrib(matrix_1h1p,e_corr_from
  integer :: ispin,jspin
  integer :: orb_i, hole_particle_i
  integer :: orb_v
- double precision  :: norm_out(N_states_diag),diag_elem(N_det),interact_psi0(N_det)
+ double precision  :: norm_out(N_states),diag_elem(N_det),interact_psi0(N_det)
  double precision  :: delta_e_inact_virt(N_states)
  integer(bit_kind), allocatable :: psi_in_out(:,:,:)
  double precision, allocatable :: psi_in_out_coef(:,:)
  double precision, allocatable :: H_matrix(:,:),eigenvectors(:,:),eigenvalues(:),interact_cas(:,:)
  double precision, allocatable :: delta_e_det(:,:)
  use bitmasks
- allocate (psi_in_out(N_int,2,n_det),psi_in_out_coef(n_det,N_states_diag),H_matrix(N_det+1,N_det+1))
+ allocate (psi_in_out(N_int,2,n_det_ref),psi_in_out_coef(n_det_ref,N_states),H_matrix(N_det+1,N_det+1))
  allocate (eigenvectors(size(H_matrix,1),N_det+1))
  allocate (eigenvalues(N_det+1),interact_cas(N_det,N_det))
  allocate (delta_e_det(N_det,N_det))
 
  integer :: iorb,jorb,i_ok
  integer :: state_target
- double precision :: energies(n_states_diag)
+ double precision :: energies(n_states)
  double precision :: hij
  double precision :: energies_alpha_beta(N_states,2)
  double precision :: lamda_pt2(N_det)
@@ -1009,10 +1004,10 @@ subroutine give_singles_and_partial_doubles_1h1p_contrib(matrix_1h1p,e_corr_from
                            - fock_virt_total_spin_trace(orb_v,j) 
     enddo
     do ispin = 1,2
-     do i = 1, n_det
+     do i = 1, n_det_ref
       do j = 1, N_int
-       psi_in_out(j,1,i) =  psi_det(j,1,i) 
-       psi_in_out(j,2,i) =  psi_det(j,2,i) 
+       psi_in_out(j,1,i) =  psi_ref(j,1,i) 
+       psi_in_out(j,2,i) =  psi_ref(j,2,i) 
       enddo
       call do_mono_excitation(psi_in_out(1,1,i),orb_i,orb_v,ispin,i_ok)
       if(i_ok.ne.1)then
@@ -1022,8 +1017,8 @@ subroutine give_singles_and_partial_doubles_1h1p_contrib(matrix_1h1p,e_corr_from
       endif
       interact_psi0(i) = 0.d0
       do j = 1 , N_det
-       call i_H_j(psi_in_out(1,1,i),psi_det(1,1,j),N_int,hij)
-       call get_delta_e_dyall(psi_det(1,1,j),psi_in_out(1,1,i),coef_array,hij,delta_e_det(i,j))
+       call i_H_j(psi_in_out(1,1,i),psi_ref(1,1,j),N_int,hij)
+       call get_delta_e_dyall(psi_ref(1,1,j),psi_in_out(1,1,i),delta_e_det(i,j))
        interact_cas(i,j) = hij
        interact_psi0(i) += hij * psi_coef(j,1)
       enddo

plugins/MRPT_Utils/mrpt_dress.irp.f

@@ -62,7 +62,7 @@ subroutine mrpt_dress(delta_ij_,  Ndet,i_generator,n_selected,det_buffer,Nint,ip
   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)
+    call create_minilist(key_mask, psi_ref, miniList, idx_miniList, N_det, N_minilist, Nint)
   end if
   
   
@@ -79,14 +79,15 @@ subroutine mrpt_dress(delta_ij_,  Ndet,i_generator,n_selected,det_buffer,Nint,ip
     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)
+      call i_h_j(tq(1,1,i_alpha),psi_ref(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)
+      call get_delta_e_dyall(psi_ref(1,1,index_i),tq(1,1,i_alpha),delta_e)
+!     call get_delta_e_dyall_general_mp(psi_ref(1,1,index_i),tq(1,1,i_alpha),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)
+      call get_excitation(psi_ref(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)
@@ -99,12 +100,12 @@ subroutine mrpt_dress(delta_ij_,  Ndet,i_generator,n_selected,det_buffer,Nint,ip
       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)
+!      call get_excitation(psi_ref(1,1,index_i),psi_ref(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(psi_ref(1,1,index_i),N_int)
+!        call debug_det(psi_ref(1,1,index_j),N_int)
 !        call debug_det(tq(1,1,i_alpha),N_int)
 !        stop
 !       endif
@@ -122,14 +123,14 @@ 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)
+ BEGIN_PROVIDER [ integer(bit_kind), gen_det_ref_sorted,  (N_int,2,N_det_generators,2) ]
+&BEGIN_PROVIDER [ integer, gen_det_ref_shortcut, (0:N_det_generators,2) ]
+&BEGIN_PROVIDER [ integer, gen_det_ref_version, (N_int, N_det_generators,2) ]
+&BEGIN_PROVIDER [ integer, gen_det_ref_idx, (N_det_generators,2) ]
+  gen_det_ref_sorted(:,:,:,1) = psi_det_generators(:,:,:N_det_generators)
+  gen_det_ref_sorted(:,:,:,2) = psi_det_generators(:,:,:N_det_generators)
+  call sort_dets_ab_v(gen_det_ref_sorted(:,:,:,1), gen_det_ref_idx(:,1), gen_det_ref_shortcut(0:,1), gen_det_ref_version(:,:,1), N_det_generators, N_int)
+  call sort_dets_ba_v(gen_det_ref_sorted(:,:,:,2), gen_det_ref_idx(:,2), gen_det_ref_shortcut(0:,2), gen_det_ref_version(:,:,2), N_det_generators, N_int)
 END_PROVIDER
 
 

plugins/MRPT_Utils/mrpt_utils.irp.f

@@ -58,8 +58,6 @@
  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
@@ -121,7 +119,7 @@
 
  ! 1h2p   
  delta_ij_tmp = 0.d0
-!call give_1h2p_contrib(delta_ij_tmp)
+ 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
@@ -137,7 +135,7 @@
 
  ! 2h1p   
  delta_ij_tmp = 0.d0
-!call give_2h1p_contrib(delta_ij_tmp)
+ 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
@@ -223,9 +221,9 @@ END_PROVIDER
  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_PROVIDER [ double precision, CI_electronic_dressed_pt2_new_energy, (N_states) ]
+ &BEGIN_PROVIDER [ double precision, CI_dressed_pt2_new_eigenvectors, (N_det,N_states) ]
+ &BEGIN_PROVIDER [ double precision, CI_dressed_pt2_new_eigenvectors_s2, (N_states) ]
   BEGIN_DOC
   ! Eigenvectors/values of the CI matrix
   END_DOC
@@ -244,14 +242,14 @@ END_PROVIDER
   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)
+  ! Guess values for the "N_states" states of the CI_dressed_pt2_new_eigenvectors 
+  do j=1,min(N_states,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 j=N_det+1,N_states
     do i=1,N_det
       CI_dressed_pt2_new_eigenvectors(i,j) = 0.d0
     enddo
@@ -267,14 +265,14 @@ END_PROVIDER
      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
+         Hmatrix_dressed_pt2_new_symmetrized(1,1,1),size(H_matrix_all_dets,1),N_det)
+     CI_electronic_dressed_pt2_new_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,&
+       call u_0_S2_u_0(s2_eigvalues,eigenvectors,N_det,psi_ref,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"
@@ -291,54 +289,54 @@ END_PROVIDER
          ! 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))
+             CI_dressed_pt2_new_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))
+           CI_electronic_dressed_pt2_new_energy(j) = eigenvalues(index_good_state_array(j))
+           CI_dressed_pt2_new_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
+           if(i_state+i_other_state.gt.n_states)then
              exit
            endif
            do i=1,N_det
-             CI_eigenvectors(i,i_state+i_other_state) = eigenvectors(i,j)
+             CI_dressed_pt2_new_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)
+           CI_electronic_dressed_pt2_new_energy(i_state+i_other_state) = eigenvalues(j)
+           CI_dressed_pt2_new_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*,'  and the ',N_states,'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*,'  as the CI_dressed_pt2_new_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 j=1,min(N_states,N_det)
            do i=1,N_det
-             CI_eigenvectors(i,j) = eigenvectors(i,j)
+             CI_dressed_pt2_new_eigenvectors(i,j) = eigenvectors(i,j)
            enddo
-           CI_electronic_energy(j) = eigenvalues(j)
-           CI_eigenvectors_s2(j) = s2_eigvalues(j)
+           CI_electronic_dressed_pt2_new_energy(j) = eigenvalues(j)
+           CI_dressed_pt2_new_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)
+       call u_0_S2_u_0(CI_dressed_pt2_new_eigenvectors_s2,eigenvectors,N_det,psi_ref,N_int,&
+          min(N_det,N_states),size(eigenvectors,1))
+       ! Select the "N_states" states of lowest energy
+       do j=1,min(N_det,N_states)
          do i=1,N_det
-           CI_eigenvectors(i,j) = eigenvectors(i,j)
+           CI_dressed_pt2_new_eigenvectors(i,j) = eigenvectors(i,j)
          enddo
-         CI_electronic_energy(j) = eigenvalues(j)
+         CI_electronic_dressed_pt2_new_energy(j) = eigenvalues(j)
        enddo
      endif
      deallocate(eigenvectors,eigenvalues)
@@ -348,7 +346,7 @@ END_PROVIDER
 END_PROVIDER
  
 
-BEGIN_PROVIDER [ double precision, CI_dressed_pt2_new_energy, (N_states_diag) ]
+BEGIN_PROVIDER [ double precision, CI_dressed_pt2_new_energy, (N_states) ]
   implicit none
   BEGIN_DOC
   ! N_states lowest eigenvalues of the CI matrix
@@ -357,11 +355,11 @@ BEGIN_PROVIDER [ double precision, CI_dressed_pt2_new_energy, (N_states_diag) ]
   integer                        :: j
   character*(8)                  :: st
   call write_time(output_determinants)
-  do j=1,N_states_diag
+  do j=1,N_states
     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))
+    call write_double(output_determinants,CI_dressed_pt2_new_eigenvectors_s2(j),'S^2 of state '//trim(st))
   enddo
 
 END_PROVIDER

plugins/MRPT_Utils/new_way.irp.f

@@ -22,8 +22,8 @@ subroutine give_2h1p_contrib(matrix_2h1p)
  
  elec_num_tab_local = 0
  do inint = 1, N_int
-  elec_num_tab_local(1) += popcnt(psi_det(inint,1,1))
-  elec_num_tab_local(2) += popcnt(psi_det(inint,2,1))
+  elec_num_tab_local(1) += popcnt(psi_ref(inint,1,1))
+  elec_num_tab_local(2) += popcnt(psi_ref(inint,2,1))
  enddo
  do i = 1, n_inact_orb  ! First inactive 
   iorb = list_inact(i)
@@ -45,7 +45,7 @@ subroutine give_2h1p_contrib(matrix_2h1p)
   integer :: index_orb_act_mono(N_det,3)
 
       do idet = 1, N_det
-        call get_excitation_degree_vector_mono(psi_det,psi_det(1,1,idet),degree,N_int,N_det,idx)
+        call get_excitation_degree_vector_mono(psi_ref,psi_ref(1,1,idet),degree,N_int,N_det,idx)
    !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! Precomputation of matrix elements 
         do ispin = 1, 2  ! spin of the couple a-a^dagger (i,r)
          do jspin = 1, 2   ! spin of the couple z-a^dagger (j,a)
@@ -53,8 +53,8 @@ subroutine give_2h1p_contrib(matrix_2h1p)
            do a = 1, n_act_orb      ! First active 
             aorb = list_act(a)
             do inint = 1, N_int
-             det_tmp(inint,1) = psi_det(inint,1,idet)
-             det_tmp(inint,2) = psi_det(inint,2,idet)
+             det_tmp(inint,1) = psi_ref(inint,1,idet)
+             det_tmp(inint,2) = psi_ref(inint,2,idet)
             enddo
            ! Do the excitation  inactive -- > virtual
            call clear_bit_to_integer(iorb,det_tmp(1,ispin),N_int)  ! hole in "iorb" of spin Ispin
@@ -64,7 +64,7 @@ subroutine give_2h1p_contrib(matrix_2h1p)
            call clear_bit_to_integer(jorb,det_tmp(1,jspin),N_int)  ! hole in "jorb" of spin Jspin
            call set_bit_to_integer(aorb,det_tmp(1,jspin),N_int) ! particle in "aorb" of spin Jspin
 
-           ! Check if the excitation is possible or not on psi_det(idet)
+           ! Check if the excitation is possible or not on psi_ref(idet)
            accu_elec= 0
            do inint = 1, N_int
             accu_elec+= popcnt(det_tmp(inint,jspin))
@@ -81,7 +81,7 @@ subroutine give_2h1p_contrib(matrix_2h1p)
             perturb_dets(inint,1,a,jspin,ispin) = det_tmp(inint,1) 
             perturb_dets(inint,2,a,jspin,ispin) = det_tmp(inint,2) 
            enddo
-           call get_double_excitation(psi_det(1,1,idet),det_tmp,exc,phase,N_int)
+           call get_double_excitation(psi_ref(1,1,idet),det_tmp,exc,phase,N_int)
            perturb_dets_phase(a,jspin,ispin) = phase
            do istate = 1, N_states
             delta_e(a,jspin,istate) = one_creat(a,jspin,istate)                                                          &
@@ -109,7 +109,7 @@ subroutine give_2h1p_contrib(matrix_2h1p)
 !!!!!!!!!!!!!!!!!!!!!!!!!!!! <Jdet | a_{b} a^{\dagger}_a | Idet> 
        do jdet = 1, idx(0)
          if(idx(jdet).ne.idet)then
-          call get_mono_excitation(psi_det(1,1,idet),psi_det(1,1,idx(jdet)),exc,phase,N_int)
+          call get_mono_excitation(psi_ref(1,1,idet),psi_ref(1,1,idx(jdet)),exc,phase,N_int)
           if (exc(0,1,1) == 1) then
             ! Mono alpha
             index_orb_act_mono(idx(jdet),1) = list_act_reverse(exc(1,2,1))   !!! a^{\dagger}_a 
@@ -150,7 +150,7 @@ subroutine give_2h1p_contrib(matrix_2h1p)
           ! you determine the interaction between the excited determinant and the other parent | Jdet >
           ! | det_tmp > = a^{\dagger}_{rorb,ispin} a^{\dagger}_{borb,kspin} a_{jorb,kspin} a_{iorb,ispin} | Jdet >
           ! hja = < det_tmp | H | Jdet >
-          call get_double_excitation(psi_det(1,1,idx(jdet)),det_tmp,exc,phase,N_int)
+          call get_double_excitation(psi_ref(1,1,idx(jdet)),det_tmp,exc,phase,N_int)
           if(kspin == ispin)then
            hja = phase * (active_int(borb,2) - active_int(borb,1) )
           else
@@ -216,8 +216,8 @@ subroutine give_1h2p_contrib(matrix_1h2p)
  
  elec_num_tab_local = 0
  do inint = 1, N_int
-  elec_num_tab_local(1) += popcnt(psi_det(inint,1,1))
-  elec_num_tab_local(2) += popcnt(psi_det(inint,2,1))
+  elec_num_tab_local(1) += popcnt(psi_ref(inint,1,1))
+  elec_num_tab_local(2) += popcnt(psi_ref(inint,2,1))
  enddo
  do i = 1, n_inact_orb  ! First inactive 
   iorb = list_inact(i)
@@ -239,7 +239,7 @@ subroutine give_1h2p_contrib(matrix_1h2p)
   integer :: index_orb_act_mono(N_det,3)
 
       do idet = 1, N_det
-        call get_excitation_degree_vector_mono(psi_det,psi_det(1,1,idet),degree,N_int,N_det,idx)
+        call get_excitation_degree_vector_mono(psi_ref,psi_ref(1,1,idet),degree,N_int,N_det,idx)
    !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! Precomputation of matrix elements 
         do ispin = 1, 2  ! spin of the couple a-a^dagger (iorb,rorb)
          do jspin = 1, 2   ! spin of the couple a-a^dagger (aorb,vorb)
@@ -247,8 +247,8 @@ subroutine give_1h2p_contrib(matrix_1h2p)
             aorb = list_act(a)
             if(ispin == jspin .and. vorb.le.rorb)cycle ! condition not to double count 
             do inint = 1, N_int
-             det_tmp(inint,1) = psi_det(inint,1,idet)
-             det_tmp(inint,2) = psi_det(inint,2,idet)
+             det_tmp(inint,1) = psi_ref(inint,1,idet)
+             det_tmp(inint,2) = psi_ref(inint,2,idet)
             enddo
            ! Do the excitation  inactive -- > virtual
            call clear_bit_to_integer(iorb,det_tmp(1,ispin),N_int)  ! hole in "iorb" of spin Ispin
@@ -258,7 +258,7 @@ subroutine give_1h2p_contrib(matrix_1h2p)
            call clear_bit_to_integer(aorb,det_tmp(1,jspin),N_int)  ! hole in "aorb" of spin Jspin
            call set_bit_to_integer(vorb,det_tmp(1,jspin),N_int)    ! particle in "vorb" of spin Jspin
 
-           ! Check if the excitation is possible or not on psi_det(idet)
+           ! Check if the excitation is possible or not on psi_ref(idet)
            accu_elec= 0
            do inint = 1, N_int
             accu_elec+= popcnt(det_tmp(inint,jspin))
@@ -280,7 +280,7 @@ subroutine give_1h2p_contrib(matrix_1h2p)
             det_tmp(inint,2) = perturb_dets(inint,2,a,jspin,ispin) 
            enddo
             
-           call get_double_excitation(psi_det(1,1,idet),det_tmp,exc,phase,N_int)
+           call get_double_excitation(psi_ref(1,1,idet),det_tmp,exc,phase,N_int)
            perturb_dets_phase(a,jspin,ispin) = phase
            do istate = 1, N_states
             delta_e(a,jspin,istate) = one_anhil(a,jspin,istate)                                                          &
@@ -308,7 +308,7 @@ subroutine give_1h2p_contrib(matrix_1h2p)
 !!!!!!!!!!!!!!!!!!!!!!!!!!!! <Jdet | a^{\dagger}_b a_{a}  | Idet> 
        do jdet = 1, idx(0)
          if(idx(jdet).ne.idet)then
-          call get_mono_excitation(psi_det(1,1,idet),psi_det(1,1,idx(jdet)),exc,phase,N_int)
+          call get_mono_excitation(psi_ref(1,1,idet),psi_ref(1,1,idx(jdet)),exc,phase,N_int)
           if (exc(0,1,1) == 1) then
             ! Mono alpha
             index_orb_act_mono(idx(jdet),1) = list_act_reverse(exc(1,1,1))   !!!  a_a
@@ -350,7 +350,7 @@ subroutine give_1h2p_contrib(matrix_1h2p)
           ! | det_tmp > = a^{\dagger}_{rorb,ispin} a^{\dagger}_{vorb,kspin} a_{borb,kspin} a_{iorb,ispin} | Jdet >
           ! hja = < det_tmp | H | Jdet >
 
-          call get_double_excitation(psi_det(1,1,idx(jdet)),det_tmp,exc,phase,N_int)
+          call get_double_excitation(psi_ref(1,1,idx(jdet)),det_tmp,exc,phase,N_int)
           if(kspin == ispin)then
            hja = phase * (active_int(borb,1) - active_int(borb,2) )
           else
@@ -418,8 +418,8 @@ subroutine give_1h1p_contrib(matrix_1h1p)
  
  elec_num_tab_local = 0
  do inint = 1, N_int
-  elec_num_tab_local(1) += popcnt(psi_det(inint,1,1))
-  elec_num_tab_local(2) += popcnt(psi_det(inint,2,1))
+  elec_num_tab_local(1) += popcnt(psi_ref(inint,1,1))
+  elec_num_tab_local(2) += popcnt(psi_ref(inint,2,1))
  enddo
  do i = 1, n_inact_orb  ! First inactive 
   iorb = list_inact(i)
@@ -430,20 +430,20 @@ subroutine give_1h1p_contrib(matrix_1h1p)
                             - fock_virt_total_spin_trace(rorb,j) 
      enddo
       do idet = 1, N_det
-        call get_excitation_degree_vector_mono(psi_det,psi_det(1,1,idet),degree,N_int,N_det,idx)
+        call get_excitation_degree_vector_mono(psi_ref,psi_ref(1,1,idet),degree,N_int,N_det,idx)
    !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! Precomputation of matrix elements 
    !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! Case of the mono excitations
            do jdet = 1, idx(0)
             do ispin = 1, 2  ! spin of the couple a-a^dagger (i,r)
                do inint = 1, N_int
-                det_tmp(inint,1) = psi_det(inint,1,idet)
-                det_tmp(inint,2) = psi_det(inint,2,idet)
+                det_tmp(inint,1) = psi_ref(inint,1,idet)
+                det_tmp(inint,2) = psi_ref(inint,2,idet)
                enddo
                ! Do the excitation  inactive -- > virtual
                double precision :: himono,delta_e(N_states),coef_mono(N_states)
                call clear_bit_to_integer(iorb,det_tmp(1,ispin),N_int)  ! hole in "iorb" of spin Ispin
                call set_bit_to_integer(rorb,det_tmp(1,ispin),N_int)    ! particle in "rorb" of spin Ispin
-               call  i_H_j(psi_det(1,1,idet),det_tmp,N_int,himono)
+               call  i_H_j(psi_ref(1,1,idet),det_tmp,N_int,himono)
                
                do state_target = 1, N_states
 !               delta_e(state_target) = one_anhil_one_creat_inact_virt(i,r,state_target) + delta_e_inact_virt(state_target)
@@ -451,7 +451,7 @@ subroutine give_1h1p_contrib(matrix_1h1p)
                 coef_mono(state_target) = himono / delta_e(state_target)
                enddo
                if(idx(jdet).ne.idet)then
-                call get_mono_excitation(psi_det(1,1,idet),psi_det(1,1,idx(jdet)),exc,phase,N_int)
+                call get_mono_excitation(psi_ref(1,1,idet),psi_ref(1,1,idx(jdet)),exc,phase,N_int)
                 if (exc(0,1,1) == 1) then
                   ! Mono alpha
                   aorb  = (exc(1,2,1))   !!! a^{\dagger}_a 
@@ -464,15 +464,15 @@ subroutine give_1h1p_contrib(matrix_1h1p)
                   jspin = 2
                 endif
                 
-                call get_excitation_degree(psi_det(1,1,idx(jdet)),det_tmp,degree_scalar,N_int)
+                call get_excitation_degree(psi_ref(1,1,idx(jdet)),det_tmp,degree_scalar,N_int)
                 if(degree_scalar .ne. 2)then
                  print*, 'pb !!!'
                  print*, degree_scalar
-                 call debug_det(psi_det(1,1,idx(jdet)),N_int)
+                 call debug_det(psi_ref(1,1,idx(jdet)),N_int)
                  call debug_det(det_tmp,N_int)
                  stop
                 endif
-                call get_double_excitation(psi_det(1,1,idx(jdet)),det_tmp,exc,phase,N_int)
+                call get_double_excitation(psi_ref(1,1,idx(jdet)),det_tmp,exc,phase,N_int)
                 if(ispin == jspin )then 
                  hij = -get_mo_bielec_integral(iorb,aorb,rorb,borb,mo_integrals_map) & 
                      +  get_mo_bielec_integral(iorb,aorb,borb,rorb,mo_integrals_map)
@@ -482,17 +482,17 @@ subroutine give_1h1p_contrib(matrix_1h1p)
                 hij = hij * phase
                 double precision :: hij_test
                 integer  :: state_target
-                call  i_H_j(psi_det(1,1,idx(jdet)),det_tmp,N_int,hij_test)
+                call  i_H_j(psi_ref(1,1,idx(jdet)),det_tmp,N_int,hij_test)
                 if(dabs(hij - hij_test).gt.1.d-10)then
                  print*, 'ahah pb !!'
                  print*, 'hij .ne. hij_test'
                  print*, hij,hij_test
-                 call debug_det(psi_det(1,1,idx(jdet)),N_int)
+                 call debug_det(psi_ref(1,1,idx(jdet)),N_int)
                  call debug_det(det_tmp,N_int)
                  print*, ispin, jspin
                  print*,iorb,borb,rorb,aorb 
                 print*, phase
-                call  i_H_j_verbose(psi_det(1,1,idx(jdet)),det_tmp,N_int,hij_test)
+                call  i_H_j_verbose(psi_ref(1,1,idx(jdet)),det_tmp,N_int,hij_test)
                  stop
                 endif
                 do state_target = 1, N_states
@@ -542,13 +542,13 @@ subroutine give_1h1p_sec_order_singles_contrib(matrix_1h1p)
  
  elec_num_tab_local = 0
  do inint = 1, N_int
-  elec_num_tab_local(1) += popcnt(psi_det(inint,1,1))
-  elec_num_tab_local(2) += popcnt(psi_det(inint,2,1))
+  elec_num_tab_local(1) += popcnt(psi_ref(inint,1,1))
+  elec_num_tab_local(2) += popcnt(psi_ref(inint,2,1))
  enddo
  double precision :: himono,delta_e(N_states),coef_mono(N_states)
  integer  :: state_target
  do idet = 1, N_det
-    call get_excitation_degree_vector_mono(psi_det,psi_det(1,1,idet),degree,N_int,N_det,idx)
+    call get_excitation_degree_vector_mono(psi_ref,psi_ref(1,1,idet),degree,N_int,N_det,idx)
     do i = 1, n_inact_orb  ! First inactive 
      iorb = list_inact(i)
       do r = 1, n_virt_orb    ! First virtual
@@ -563,13 +563,13 @@ subroutine give_1h1p_sec_order_singles_contrib(matrix_1h1p)
                                - fock_virt_total_spin_trace(rorb,j) 
         enddo
         do inint = 1, N_int
-         det_tmp(inint,1) = psi_det(inint,1,idet)
-         det_tmp(inint,2) = psi_det(inint,2,idet)
+         det_tmp(inint,1) = psi_ref(inint,1,idet)
+         det_tmp(inint,2) = psi_ref(inint,2,idet)
         enddo
         ! Do the excitation  inactive -- > virtual
         call clear_bit_to_integer(iorb,det_tmp(1,ispin),N_int)  ! hole in "iorb" of spin Ispin
         call set_bit_to_integer(rorb,det_tmp(1,ispin),N_int)    ! particle in "rorb" of spin Ispin
-        call  i_H_j(psi_det(1,1,idet),det_tmp,N_int,himono)
+        call  i_H_j(psi_ref(1,1,idet),det_tmp,N_int,himono)
         do inint = 1, N_int
          det_pert(inint,1,i,r,ispin) = det_tmp(inint,1)
          det_pert(inint,2,i,r,ispin) = det_tmp(inint,2)
@@ -630,7 +630,7 @@ subroutine give_1h1p_sec_order_singles_contrib(matrix_1h1p)
         do jdet = 1, idx(0)
 !      
          if(idx(jdet).ne.idet)then
-          call get_mono_excitation(psi_det(1,1,idet),psi_det(1,1,idx(jdet)),exc,phase,N_int)
+          call get_mono_excitation(psi_ref(1,1,idet),psi_ref(1,1,idx(jdet)),exc,phase,N_int)
           if (exc(0,1,1) == 1) then
             ! Mono alpha
             aorb  = (exc(1,2,1))   !!! a^{\dagger}_a 
@@ -642,24 +642,24 @@ subroutine give_1h1p_sec_order_singles_contrib(matrix_1h1p)
             jspin = 2
           endif
           
-          call get_excitation_degree(psi_det(1,1,idx(jdet)),det_tmp,degree_scalar,N_int)
+          call get_excitation_degree(psi_ref(1,1,idx(jdet)),det_tmp,degree_scalar,N_int)
           if(degree_scalar .ne. 2)then
            print*, 'pb !!!'
            print*, degree_scalar
-           call debug_det(psi_det(1,1,idx(jdet)),N_int)
+           call debug_det(psi_ref(1,1,idx(jdet)),N_int)
            call debug_det(det_tmp,N_int)
            stop
           endif
-          call get_double_excitation(psi_det(1,1,idx(jdet)),det_tmp,exc,phase,N_int)
+          call get_double_excitation(psi_ref(1,1,idx(jdet)),det_tmp,exc,phase,N_int)
           double precision :: hij_test
           hij_test = 0.d0
-          call  i_H_j(psi_det(1,1,idx(jdet)),det_tmp,N_int,hij_test)
+          call  i_H_j(psi_ref(1,1,idx(jdet)),det_tmp,N_int,hij_test)
           do state_target = 1, N_states
            matrix_1h1p(idx(jdet),idet,state_target) += hij_test* coef_det_pert(i,r,ispin,state_target,2)
           enddo
          else
           hij_test = 0.d0
-          call  i_H_j(psi_det(1,1,idet),det_tmp,N_int,hij_test)
+          call  i_H_j(psi_ref(1,1,idet),det_tmp,N_int,hij_test)
           do state_target = 1, N_states
            matrix_1h1p(idet,idet,state_target) += hij_test* coef_det_pert(i,r,ispin,state_target,2)
           enddo
@@ -701,13 +701,13 @@ subroutine give_1p_sec_order_singles_contrib(matrix_1p)
  
  elec_num_tab_local = 0
  do inint = 1, N_int
-  elec_num_tab_local(1) += popcnt(psi_det(inint,1,1))
-  elec_num_tab_local(2) += popcnt(psi_det(inint,2,1))
+  elec_num_tab_local(1) += popcnt(psi_ref(inint,1,1))
+  elec_num_tab_local(2) += popcnt(psi_ref(inint,2,1))
  enddo
  double precision :: himono,delta_e(N_states),coef_mono(N_states)
  integer  :: state_target
  do idet = 1, N_det
-    call get_excitation_degree_vector_mono(psi_det,psi_det(1,1,idet),degree,N_int,N_det,idx)
+    call get_excitation_degree_vector_mono(psi_ref,psi_ref(1,1,idet),degree,N_int,N_det,idx)
     do i = 1, n_act_orb  ! First active 
      iorb = list_act(i)
       do r = 1, n_virt_orb    ! First virtual
@@ -721,8 +721,8 @@ subroutine give_1p_sec_order_singles_contrib(matrix_1p)
          delta_e_act_virt(j) = - fock_virt_total_spin_trace(rorb,j) 
         enddo
         do inint = 1, N_int
-         det_tmp(inint,1) = psi_det(inint,1,idet)
-         det_tmp(inint,2) = psi_det(inint,2,idet)
+         det_tmp(inint,1) = psi_ref(inint,1,idet)
+         det_tmp(inint,2) = psi_ref(inint,2,idet)
         enddo
         ! Do the excitation  active -- > virtual
         call do_mono_excitation(det_tmp,iorb,rorb,ispin,i_ok)
@@ -739,7 +739,7 @@ subroutine give_1p_sec_order_singles_contrib(matrix_1p)
          enddo
          cycle
         endif
-        call  i_H_j(psi_det(1,1,idet),det_tmp,N_int,himono)
+        call  i_H_j(psi_ref(1,1,idet),det_tmp,N_int,himono)
         do inint = 1, N_int
          det_pert(inint,1,i,r,ispin) = det_tmp(inint,1)
          det_pert(inint,2,i,r,ispin) = det_tmp(inint,2)
@@ -803,8 +803,8 @@ subroutine give_1p_sec_order_singles_contrib(matrix_1p)
         enddo
         do jdet = 1,N_det
          double precision :: coef_array(N_states),hij_test
-         call  i_H_j(det_tmp,psi_det(1,1,jdet),N_int,himono)
-         call get_delta_e_dyall(psi_det(1,1,jdet),det_tmp,coef_array,hij_test,delta_e)
+         call  i_H_j(det_tmp,psi_ref(1,1,jdet),N_int,himono)
+         call get_delta_e_dyall(psi_ref(1,1,jdet),det_tmp,delta_e)
          do state_target = 1, N_states
 !         matrix_1p(idet,jdet,state_target) += himono * coef_det_pert(i,r,ispin,state_target,1)
           matrix_1p(idet,jdet,state_target) += himono * hij_det_pert(i,r,ispin) / delta_e(state_target)
@@ -850,8 +850,8 @@ subroutine give_1h1p_only_doubles_spin_cross(matrix_1h1p)
  
  elec_num_tab_local = 0
  do inint = 1, N_int
-  elec_num_tab_local(1) += popcnt(psi_det(inint,1,1))
-  elec_num_tab_local(2) += popcnt(psi_det(inint,2,1))
+  elec_num_tab_local(1) += popcnt(psi_ref(inint,1,1))
+  elec_num_tab_local(2) += popcnt(psi_ref(inint,2,1))
  enddo
  do i = 1, n_inact_orb  ! First inactive 
   iorb = list_inact(i)
@@ -862,7 +862,7 @@ subroutine give_1h1p_only_doubles_spin_cross(matrix_1h1p)
                             - fock_virt_total_spin_trace(rorb,j) 
      enddo
       do idet = 1, N_det
-        call get_excitation_degree_vector_double_alpha_beta(psi_det,psi_det(1,1,idet),degree,N_int,N_det,idx)
+        call get_excitation_degree_vector_double_alpha_beta(psi_ref,psi_ref(1,1,idet),degree,N_int,N_det,idx)
    !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! Precomputation of matrix elements 
    !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! Case of the mono excitations
            do ispin = 1, 2 
@@ -872,8 +872,8 @@ subroutine give_1h1p_only_doubles_spin_cross(matrix_1h1p)
              do b = 1, n_act_orb
               borb = list_act(b)
                do inint = 1, N_int
-                det_tmp(inint,1) = psi_det(inint,1,idet)
-                det_tmp(inint,2) = psi_det(inint,2,idet)
+                det_tmp(inint,1) = psi_ref(inint,1,idet)
+                det_tmp(inint,2) = psi_ref(inint,2,idet)
                enddo
                ! Do the excitation  (i-->a)(ispin)  + (b-->r)(other_spin(ispin))
                integer :: i_ok,corb,dorb
@@ -904,7 +904,7 @@ subroutine give_1h1p_only_doubles_spin_cross(matrix_1h1p)
                 pert_det(inint,2,a,b,ispin) = det_tmp(inint,2)
                enddo
 
-               call  i_H_j(psi_det(1,1,idet),det_tmp,N_int,hidouble)
+               call  i_H_j(psi_ref(1,1,idet),det_tmp,N_int,hidouble)
                do state_target = 1, N_states
                 delta_e(state_target) = one_anhil_one_creat(a,b,ispin,jspin,state_target) +  delta_e_inact_virt(state_target)
                 pert_det_coef(a,b,ispin,state_target) = hidouble / delta_e(state_target) 
@@ -915,7 +915,7 @@ subroutine give_1h1p_only_doubles_spin_cross(matrix_1h1p)
            enddo
            do jdet = 1, idx(0)
                if(idx(jdet).ne.idet)then
-                call get_double_excitation(psi_det(1,1,idet),psi_det(1,1,idx(jdet)),exc,phase,N_int)
+                call get_double_excitation(psi_ref(1,1,idet),psi_ref(1,1,idx(jdet)),exc,phase,N_int)
                 integer :: c,d,state_target
                 integer(bit_kind) :: det_tmp_bis(N_int,2)
                 ! excitation from I --> J 
@@ -935,8 +935,8 @@ subroutine give_1h1p_only_doubles_spin_cross(matrix_1h1p)
                  det_tmp_bis(inint,2) = pert_det(inint,2,c,d,2)
                 enddo
                 double precision :: hjdouble_1,hjdouble_2
-                call  i_H_j(psi_det(1,1,idx(jdet)),det_tmp,N_int,hjdouble_1)
-                call  i_H_j(psi_det(1,1,idx(jdet)),det_tmp_bis,N_int,hjdouble_2)
+                call  i_H_j(psi_ref(1,1,idx(jdet)),det_tmp,N_int,hjdouble_1)
+                call  i_H_j(psi_ref(1,1,idx(jdet)),det_tmp_bis,N_int,hjdouble_2)
                 do state_target = 1, N_states
                  matrix_1h1p(idx(jdet),idet,state_target) += (pert_det_coef(c,d,1,state_target) * hjdouble_1 + pert_det_coef(c,d,2,state_target) * hjdouble_2 ) 
                 enddo

plugins/MRPT_Utils/new_way_second_order_coef.irp.f

@@ -24,8 +24,8 @@ subroutine give_2h1p_contrib_sec_order(matrix_2h1p)
  
  elec_num_tab_local = 0
  do inint = 1, N_int
-  elec_num_tab_local(1) += popcnt(psi_det(inint,1,1))
-  elec_num_tab_local(2) += popcnt(psi_det(inint,2,1))
+  elec_num_tab_local(1) += popcnt(psi_ref(inint,1,1))
+  elec_num_tab_local(2) += popcnt(psi_ref(inint,2,1))
  enddo
  do i = 1, n_inact_orb  ! First inactive 
   iorb = list_inact(i)
@@ -50,9 +50,9 @@ subroutine give_2h1p_contrib_sec_order(matrix_2h1p)
   integer :: istate
 
       do idet = 1, N_det
-        call get_excitation_degree_vector_mono_or_exchange(psi_det,psi_det(1,1,idet),degree,N_int,N_det,idx)
+        call get_excitation_degree_vector_mono_or_exchange(psi_ref,psi_ref(1,1,idet),degree,N_int,N_det,idx)
 !       if(idet == 81)then
-!       call get_excitation_degree_vector_mono_or_exchange_verbose(psi_det(1,1,1),psi_det(1,1,idet),degree,N_int,N_det,idx)
+!       call get_excitation_degree_vector_mono_or_exchange_verbose(psi_ref(1,1,1),psi_ref(1,1,idet),degree,N_int,N_det,idx)
 !       endif
    !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! Precomputation of matrix elements 
         do ispin = 1, 2  ! spin of the couple a-a^dagger (i,r)
@@ -61,8 +61,8 @@ subroutine give_2h1p_contrib_sec_order(matrix_2h1p)
            do a = 1, n_act_orb      ! First active 
             aorb = list_act(a)
             do inint = 1, N_int
-             det_tmp(inint,1) = psi_det(inint,1,idet)
-             det_tmp(inint,2) = psi_det(inint,2,idet)
+             det_tmp(inint,1) = psi_ref(inint,1,idet)
+             det_tmp(inint,2) = psi_ref(inint,2,idet)
             enddo
            ! Do the excitation  inactive -- > virtual
            call clear_bit_to_integer(iorb,det_tmp(1,ispin),N_int)  ! hole in "iorb" of spin Ispin
@@ -72,7 +72,7 @@ subroutine give_2h1p_contrib_sec_order(matrix_2h1p)
            call clear_bit_to_integer(jorb,det_tmp(1,jspin),N_int)  ! hole in "jorb" of spin Jspin
            call set_bit_to_integer(aorb,det_tmp(1,jspin),N_int) ! particle in "aorb" of spin Jspin
 
-           ! Check if the excitation is possible or not on psi_det(idet)
+           ! Check if the excitation is possible or not on psi_ref(idet)
            accu_elec= 0
            do inint = 1, N_int
             accu_elec+= popcnt(det_tmp(inint,jspin))
@@ -90,7 +90,7 @@ subroutine give_2h1p_contrib_sec_order(matrix_2h1p)
             perturb_dets(inint,1,a,jspin,ispin) = det_tmp(inint,1) 
             perturb_dets(inint,2,a,jspin,ispin) = det_tmp(inint,2) 
            enddo
-           call get_double_excitation(psi_det(1,1,idet),det_tmp,exc,phase,N_int)
+           call get_double_excitation(psi_ref(1,1,idet),det_tmp,exc,phase,N_int)
            perturb_dets_phase(a,jspin,ispin) = phase
            do istate = 1, N_states
             delta_e(a,jspin,istate) = one_creat(a,jspin,istate)                                                          &
@@ -124,7 +124,7 @@ subroutine give_2h1p_contrib_sec_order(matrix_2h1p)
        do jdet = 1, idx(0)
          if(idx(jdet).ne.idet)then
           if(degree(jdet)==1)then
-           call get_mono_excitation(psi_det(1,1,idet),psi_det(1,1,idx(jdet)),exc,phase,N_int)
+           call get_mono_excitation(psi_ref(1,1,idet),psi_ref(1,1,idx(jdet)),exc,phase,N_int)
            if (exc(0,1,1) == 1) then
              ! Mono alpha
              i_hole = list_act_reverse(exc(1,1,1))   !!!  a_a
@@ -149,7 +149,7 @@ subroutine give_2h1p_contrib_sec_order(matrix_2h1p)
              fock_operator_local(i_part,i_hole,kspin) = hij * phase ! phase less fock operator 
            endif
           else if(degree(jdet)==2)then
-           call get_double_excitation(psi_det(1,1,idet),psi_det(1,1,idx(jdet)),exc,phase,N_int)
+           call get_double_excitation(psi_ref(1,1,idet),psi_ref(1,1,idx(jdet)),exc,phase,N_int)
              ! Mono alpha
              index_orb_act_mono(idx(jdet),1) = list_act_reverse(exc(1,1,1))   !!!  a_a
              index_orb_act_mono(idx(jdet),2) = list_act_reverse(exc(1,2,1))   !!!  a^{\dagger}_{b}
@@ -196,7 +196,7 @@ subroutine give_2h1p_contrib_sec_order(matrix_2h1p)
                   det_tmp_bis(inint,2)  = perturb_dets(inint,2,corb,jspin,ispin) 
                  enddo
        !         ! < idet | H | det_tmp > = phase * (ir|cv)
-                 call get_double_excitation(psi_det(1,1,idet),det_tmp,exc,phase,N_int)
+                 call get_double_excitation(psi_ref(1,1,idet),det_tmp,exc,phase,N_int)
                  if(ispin == jspin)then
                   hib= phase * (active_int(corb,1) - active_int(corb,2)) 
                  else
@@ -215,7 +215,7 @@ subroutine give_2h1p_contrib_sec_order(matrix_2h1p)
              stop
             endif
                  ! < jdet | H | det_tmp_bis > = phase * (ir|cv)
-                 call get_double_excitation(det_tmp_bis,psi_det(1,1,idx(jdet)),exc,phase,N_int)
+                 call get_double_excitation(det_tmp_bis,psi_ref(1,1,idx(jdet)),exc,phase,N_int)
                  if(ispin == jspin)then
                   hja= phase * (active_int(corb,1) - active_int(corb,2)) 
                  else 
@@ -243,7 +243,7 @@ subroutine give_2h1p_contrib_sec_order(matrix_2h1p)
                   det_tmp_bis(inint,2)  = perturb_dets(inint,2,corb,jspin,ispin) 
                  enddo
                  ! < idet | H | det_tmp > = phase * ( (ir|cv) - (iv|cr) )
-                 call get_double_excitation(psi_det(1,1,idet),det_tmp,exc,phase,N_int)
+                 call get_double_excitation(psi_ref(1,1,idet),det_tmp,exc,phase,N_int)
                  if(ispin == jspin)then
                   hib= phase * (active_int(corb,1) - active_int(corb,2)) 
                  else
@@ -260,7 +260,7 @@ subroutine give_2h1p_contrib_sec_order(matrix_2h1p)
              stop
             endif
                  ! < jdet | H | det_tmp_bis > = phase * ( (ir|cv) - (iv|cr) )
-                 call get_double_excitation(det_tmp_bis,psi_det(1,1,idx(jdet)),exc,phase,N_int)
+                 call get_double_excitation(det_tmp_bis,psi_ref(1,1,idx(jdet)),exc,phase,N_int)
                  if(ispin == jspin)then
                   hja= phase * (active_int(corb,1) - active_int(corb,2)) 
                  else 
@@ -296,7 +296,7 @@ subroutine give_2h1p_contrib_sec_order(matrix_2h1p)
                det_tmp_bis(inint,2)  = perturb_dets(inint,2,aorb,jspin,ispin) 
               enddo
               ! | det_tmp > = a^{\dagger}_{aorb,beta} | Idet > 
-              call get_double_excitation(det_tmp,psi_det(1,1,idet),exc,phase,N_int)
+              call get_double_excitation(det_tmp,psi_ref(1,1,idet),exc,phase,N_int)
               if(ispin == jspin)then
                hib= phase * (active_int(aorb,1) - active_int(aorb,2)) 
               else 
@@ -312,15 +312,15 @@ subroutine give_2h1p_contrib_sec_order(matrix_2h1p)
            else if(index_orb_act_mono(idx(jdet),1) == index_orb_act_mono(idx(jdet),4))then !! closed shell double excitation
              
            else 
-            call get_excitation(psi_det(1,1,idet),psi_det(1,1,idx(jdet)),exc,degree_scalar,phase,N_int) 
+            call get_excitation(psi_ref(1,1,idet),psi_ref(1,1,idx(jdet)),exc,degree_scalar,phase,N_int) 
             integer :: h1,h2,p1,p2,s1,s2 , degree_scalar
             call decode_exc(exc,degree,h1,p1,h2,p2,s1,s2)
             print*, h1,p1,h2,p2,s1,s2
-            call debug_det(psi_det(1,1,idet),N_int)
-            call debug_det(psi_det(1,1,idx(jdet)),N_int)
+            call debug_det(psi_ref(1,1,idet),N_int)
+            call debug_det(psi_ref(1,1,idx(jdet)),N_int)
             print*, idet,idx(jdet)
             print*, 'pb !!!!!!!!!!!!!'
-            call get_excitation_degree_vector_mono_or_exchange_verbose(psi_det(1,1,1),psi_det(1,1,idet),degree,N_int,N_det,idx)
+            call get_excitation_degree_vector_mono_or_exchange_verbose(psi_ref(1,1,1),psi_ref(1,1,idet),degree,N_int,N_det,idx)
             stop
            endif
           endif
@@ -398,8 +398,8 @@ subroutine give_1h2p_contrib_sec_order(matrix_1h2p)
  
  elec_num_tab_local = 0
  do inint = 1, N_int
-  elec_num_tab_local(1) += popcnt(psi_det(inint,1,1))
-  elec_num_tab_local(2) += popcnt(psi_det(inint,2,1))
+  elec_num_tab_local(1) += popcnt(psi_ref(inint,1,1))
+  elec_num_tab_local(2) += popcnt(psi_ref(inint,2,1))
  enddo
  do i = 1, n_inact_orb  ! First inactive 
   iorb = list_inact(i)
@@ -430,7 +430,7 @@ subroutine give_1h2p_contrib_sec_order(matrix_1h2p)
                                     + fock_core_inactive_total_spin_trace(iorb,istate)        
       enddo
       do idet = 1, N_det
-        call get_excitation_degree_vector_mono_or_exchange(psi_det,psi_det(1,1,idet),degree,N_int,N_det,idx)
+        call get_excitation_degree_vector_mono_or_exchange(psi_ref,psi_ref(1,1,idet),degree,N_int,N_det,idx)
    !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! Precomputation of matrix elements 
         do ispin = 1, 2  ! spin of the couple a-a^dagger (iorb,rorb)
          do jspin = 1, 2   ! spin of the couple a-a^dagger (aorb,vorb)
@@ -443,8 +443,8 @@ subroutine give_1h2p_contrib_sec_order(matrix_1h2p)
             enddo
             if(ispin == jspin .and. vorb.le.rorb)cycle ! condition not to double count 
             do inint = 1, N_int
-             det_tmp(inint,1) = psi_det(inint,1,idet)
-             det_tmp(inint,2) = psi_det(inint,2,idet)
+             det_tmp(inint,1) = psi_ref(inint,1,idet)
+             det_tmp(inint,2) = psi_ref(inint,2,idet)
             enddo
            ! Do the excitation  inactive -- > virtual
            call clear_bit_to_integer(iorb,det_tmp(1,ispin),N_int)  ! hole in "iorb" of spin Ispin
@@ -454,7 +454,7 @@ subroutine give_1h2p_contrib_sec_order(matrix_1h2p)
            call clear_bit_to_integer(aorb,det_tmp(1,jspin),N_int)  ! hole in "aorb" of spin Jspin
            call set_bit_to_integer(vorb,det_tmp(1,jspin),N_int)    ! particle in "vorb" of spin Jspin
 
-           ! Check if the excitation is possible or not on psi_det(idet)
+           ! Check if the excitation is possible or not on psi_ref(idet)
            accu_elec= 0
            do inint = 1, N_int
             accu_elec+= popcnt(det_tmp(inint,jspin))
@@ -477,7 +477,7 @@ subroutine give_1h2p_contrib_sec_order(matrix_1h2p)
             det_tmp(inint,2) = perturb_dets(inint,2,a,jspin,ispin) 
            enddo
             
-           call get_double_excitation(psi_det(1,1,idet),det_tmp,exc,phase,N_int)
+           call get_double_excitation(psi_ref(1,1,idet),det_tmp,exc,phase,N_int)
            perturb_dets_phase(a,jspin,ispin) = phase
            
            do istate = 1, N_states
@@ -501,7 +501,7 @@ subroutine give_1h2p_contrib_sec_order(matrix_1h2p)
        do jdet = 1, idx(0)
          if(idx(jdet).ne.idet)then
           if(degree(jdet)==1)then
-           call get_mono_excitation(psi_det(1,1,idet),psi_det(1,1,idx(jdet)),exc,phase,N_int)
+           call get_mono_excitation(psi_ref(1,1,idet),psi_ref(1,1,idx(jdet)),exc,phase,N_int)
            if (exc(0,1,1) == 1) then
              ! Mono alpha
              i_hole = list_act_reverse(exc(1,1,1))   !!!  a_a
@@ -526,7 +526,7 @@ subroutine give_1h2p_contrib_sec_order(matrix_1h2p)
              fock_operator_local(i_part,i_hole,kspin) = hij * phase ! phase less fock operator 
            endif
           else if(degree(jdet)==2)then
-           call get_double_excitation(psi_det(1,1,idet),psi_det(1,1,idx(jdet)),exc,phase,N_int)
+           call get_double_excitation(psi_ref(1,1,idet),psi_ref(1,1,idx(jdet)),exc,phase,N_int)
              ! Mono alpha
              index_orb_act_mono(idx(jdet),1) = list_act_reverse(exc(1,1,1))   !!!  a_a
              index_orb_act_mono(idx(jdet),2) = list_act_reverse(exc(1,2,1))   !!!  a^{\dagger}_{b}
@@ -575,7 +575,7 @@ subroutine give_1h2p_contrib_sec_order(matrix_1h2p)
                   det_tmp_bis(inint,2)  = perturb_dets(inint,2,corb,jspin,ispin) 
                  enddo
                  ! < idet | H | det_tmp > = phase * (ir|cv)
-                 call get_double_excitation(psi_det(1,1,idet),det_tmp,exc,phase,N_int)
+                 call get_double_excitation(psi_ref(1,1,idet),det_tmp,exc,phase,N_int)
                  if(ispin == jspin)then
                   hib= phase * (active_int(corb,1) - active_int(corb,2)) 
                  else
@@ -590,7 +590,7 @@ subroutine give_1h2p_contrib_sec_order(matrix_1h2p)
                  ! < det_tmp     | H | det_tmp_bis >  = F_{aorb,borb}
                  hab = (fock_operator_local(aorb,borb,kspin) ) * phase  
                  ! < jdet | H | det_tmp_bis > = phase * (ir|cv)
-                 call get_double_excitation(det_tmp_bis,psi_det(1,1,idx(jdet)),exc,phase,N_int)
+                 call get_double_excitation(det_tmp_bis,psi_ref(1,1,idx(jdet)),exc,phase,N_int)
                  if(ispin == jspin)then
                   hja= phase * (active_int(corb,1) - active_int(corb,2)) 
                  else 
@@ -617,7 +617,7 @@ subroutine give_1h2p_contrib_sec_order(matrix_1h2p)
                   det_tmp_bis(inint,2)  = perturb_dets(inint,2,corb,jspin,ispin) 
                  enddo
                  ! < idet | H | det_tmp > = phase * ( (ir|cv) - (iv|cr) )
-                 call get_double_excitation(psi_det(1,1,idet),det_tmp,exc,phase,N_int)
+                 call get_double_excitation(psi_ref(1,1,idet),det_tmp,exc,phase,N_int)
                  if(ispin == jspin)then
                   hib= phase * (active_int(corb,1) - active_int(corb,2)) 
                  else
@@ -630,7 +630,7 @@ subroutine give_1h2p_contrib_sec_order(matrix_1h2p)
 !                ! < det_tmp | H | det_tmp_bis >  = F_{aorb,borb}
                  hab = fock_operator_local(aorb,borb,kspin) * phase  
                  ! < jdet | H | det_tmp_bis > = phase * ( (ir|cv) - (iv|cr) )
-                 call get_double_excitation(det_tmp_bis,psi_det(1,1,idx(jdet)),exc,phase,N_int)
+                 call get_double_excitation(det_tmp_bis,psi_ref(1,1,idx(jdet)),exc,phase,N_int)
                  if(ispin == jspin)then
                   hja= phase * (active_int(corb,1) - active_int(corb,2)) 
                  else 
@@ -665,7 +665,7 @@ subroutine give_1h2p_contrib_sec_order(matrix_1h2p)
              det_tmp_bis(inint,1)  = perturb_dets(inint,1,aorb,jspin,ispin) 
              det_tmp_bis(inint,2)  = perturb_dets(inint,2,aorb,jspin,ispin) 
             enddo
-            call get_double_excitation(det_tmp,psi_det(1,1,idet),exc,phase,N_int)
+            call get_double_excitation(det_tmp,psi_ref(1,1,idet),exc,phase,N_int)
             if(ispin == jspin)then
              hib= phase * (active_int(borb,1) - active_int(borb,2)) 
             else 
@@ -674,8 +674,8 @@ subroutine give_1h2p_contrib_sec_order(matrix_1h2p)
             if(      index_orb_act_mono(idx(jdet),1) == index_orb_act_mono(idx(jdet),5))then
              call do_mono_excitation(det_tmp_bis,list_act(borb),list_act(aorb),1,i_ok)
              if(i_ok .ne. 1)then
-              call debug_det(psi_det(1,1,idet),N_int)
-              call debug_det(psi_det(1,1,idx(jdet)),N_int)
+              call debug_det(psi_ref(1,1,idet),N_int)
+              call debug_det(psi_ref(1,1,idx(jdet)),N_int)
               print*, aorb, borb
               call debug_det(det_tmp,N_int)
               stop
@@ -692,7 +692,7 @@ subroutine give_1h2p_contrib_sec_order(matrix_1h2p)
              stop
             endif
             hab = fock_operator_local(aorb,borb,1) * phase  
-            call get_double_excitation(det_tmp_bis,psi_det(1,1,idx(jdet)),exc,phase,N_int)
+            call get_double_excitation(det_tmp_bis,psi_ref(1,1,idx(jdet)),exc,phase,N_int)
             if(ispin == jspin)then
              hja= phase * (active_int(borb,1) - active_int(borb,2)) 
             else 
@@ -716,7 +716,7 @@ subroutine give_1h2p_contrib_sec_order(matrix_1h2p)
              det_tmp_bis(inint,1)  = perturb_dets(inint,1,aorb,jspin,ispin) 
              det_tmp_bis(inint,2)  = perturb_dets(inint,2,aorb,jspin,ispin) 
             enddo
-            call get_double_excitation(det_tmp,psi_det(1,1,idet),exc,phase,N_int)
+            call get_double_excitation(det_tmp,psi_ref(1,1,idet),exc,phase,N_int)
             if(ispin == jspin)then
              hib= phase * (active_int(borb,1) - active_int(borb,2)) 
             else 
@@ -725,8 +725,8 @@ subroutine give_1h2p_contrib_sec_order(matrix_1h2p)
             if(      index_orb_act_mono(idx(jdet),1) == index_orb_act_mono(idx(jdet),5))then
              call do_mono_excitation(det_tmp_bis,list_act(borb),list_act(aorb),2,i_ok)
              if(i_ok .ne. 1)then
-              call debug_det(psi_det(1,1,idet),N_int)
-              call debug_det(psi_det(1,1,idx(jdet)),N_int)
+              call debug_det(psi_ref(1,1,idet),N_int)
+              call debug_det(psi_ref(1,1,idx(jdet)),N_int)
               print*, aorb, borb
               call debug_det(det_tmp,N_int)
               stop
@@ -739,7 +739,7 @@ subroutine give_1h2p_contrib_sec_order(matrix_1h2p)
             call get_mono_excitation(det_tmp,det_tmp_bis,exc,phase,N_int)
             ! < det_tmp     | H | det_tmp_bis >  = F_{aorb,borb}
             hab = fock_operator_local(aorb,borb,2) * phase  
-            call get_double_excitation(det_tmp_bis,psi_det(1,1,idx(jdet)),exc,phase,N_int)
+            call get_double_excitation(det_tmp_bis,psi_ref(1,1,idx(jdet)),exc,phase,N_int)
             if(ispin == jspin)then
              hja= phase * (active_int(borb,1) - active_int(borb,2)) 
             else 

plugins/MRPT_Utils/psi_active_prov.irp.f

@@ -11,8 +11,8 @@ BEGIN_PROVIDER [integer(bit_kind), psi_active, (N_int,2,psi_det_size)]
 !print*, 'psi_active '
  do i = 1, N_det
   do j = 1, N_int
-   psi_active(j,1,i) = iand(psi_det(j,1,i),cas_bitmask(j,1,1))
-   psi_active(j,2,i) = iand(psi_det(j,2,i),cas_bitmask(j,1,1))
+   psi_active(j,1,i) = iand(psi_ref(j,1,i),cas_bitmask(j,1,1))
+   psi_active(j,2,i) = iand(psi_ref(j,2,i),cas_bitmask(j,1,1))
   enddo
  enddo
 END_PROVIDER
@@ -152,7 +152,7 @@ subroutine give_particles_in_virt_space(det_1,n_particles_spin,n_particles,parti
 
 end
 
-subroutine get_delta_e_dyall(det_1,det_2,coef_array,hij,delta_e_final)
+subroutine get_delta_e_dyall(det_1,det_2,delta_e_final)
  BEGIN_DOC
  ! routine that returns the delta_e with the Moller Plesset and Dyall operators
  !
@@ -170,7 +170,6 @@ subroutine get_delta_e_dyall(det_1,det_2,coef_array,hij,delta_e_final)
   use bitmasks
  double precision, intent(out) :: delta_e_final(N_states)
  integer(bit_kind), intent(in) :: det_1(N_int,2),det_2(N_int,2)
- double precision, intent(in) :: coef_array(N_states),hij
  integer :: i,j,k,l
  integer :: i_state
  
@@ -293,20 +292,9 @@ subroutine get_delta_e_dyall(det_1,det_2,coef_array,hij,delta_e_final)
  if      (n_holes_act == 0 .and. n_particles_act == 1) then
   ispin = particle_list_practical(1,1)
   i_particle_act =  particle_list_practical(2,1)
-! call get_excitation_degree(det_1,det_2,degree,N_int)
-! if(degree == 1)then
-!  call get_excitation(det_1,det_2,exc,degree,phase,N_int)
-!  call decode_exc(exc,degree,h1,p1,h2,p2,s1,s2)
-!  i_hole =  list_inact_reverse(h1)
-!  i_part =  list_act_reverse(p1)
-!  do i_state = 1, N_states
-!   delta_e_act(i_state) += one_anhil_inact(i_hole,i_part,i_state)
-!  enddo
-! else if (degree == 2)then
    do i_state = 1, N_states
     delta_e_act(i_state) += one_creat(i_particle_act,ispin,i_state)
    enddo
-! endif
 
  else if (n_holes_act == 1 .and. n_particles_act == 0) then
   ispin = hole_list_practical(1,1)
@@ -433,3 +421,159 @@ subroutine get_delta_e_dyall(det_1,det_2,coef_array,hij,delta_e_final)
 
 end
 
+
+
+subroutine get_delta_e_dyall_general_mp(det_1,det_2,delta_e_final)
+ BEGIN_DOC
+ ! routine that returns the delta_e with the Moller Plesset and Dyall operators
+ !
+ ! with det_1 being a determinant from the cas, and det_2 being a perturber
+ !
+ ! Delta_e(det_1,det_2) = sum (hole) epsilon(hole) + sum(part) espilon(part) + delta_e(act)
+ !
+ ! where hole is necessary in the inactive, part necessary in the virtuals
+ ! 
+ ! and delta_e(act) is obtained as the sum of energies of excitations a la MP
+ !
+ END_DOC
+ implicit none
+  use bitmasks
+ double precision, intent(out) :: delta_e_final(N_states)
+ integer(bit_kind), intent(in) :: det_1(N_int,2),det_2(N_int,2)
+ integer :: i,j,k,l
+ integer :: i_state
+ 
+ integer :: n_holes_spin(2)
+ integer :: n_holes
+ integer :: holes_list(N_int*bit_kind_size,2)
+
+
+ double precision :: delta_e_inactive(N_states)
+ integer :: i_hole_inact
+
+
+ call give_holes_in_inactive_space(det_2,n_holes_spin,n_holes,holes_list)
+ delta_e_inactive = 0.d0
+ do i = 1, n_holes_spin(1)
+  i_hole_inact = holes_list(i,1)
+  do i_state = 1, N_states
+   delta_e_inactive += fock_core_inactive_total_spin_trace(i_hole_inact,i_state)
+  enddo
+ enddo
+
+ do i = 1, n_holes_spin(2)
+  i_hole_inact = holes_list(i,2)
+  do i_state = 1, N_states
+   delta_e_inactive(i_state) += fock_core_inactive_total_spin_trace(i_hole_inact,i_state)
+  enddo
+ enddo
+
+ double precision :: delta_e_virt(N_states)
+ integer :: i_part_virt
+ integer :: n_particles_spin(2)
+ integer :: n_particles
+ integer :: particles_list(N_int*bit_kind_size,2)
+ 
+ call give_particles_in_virt_space(det_2,n_particles_spin,n_particles,particles_list)
+ delta_e_virt = 0.d0
+ do i = 1, n_particles_spin(1)
+  i_part_virt = particles_list(i,1)
+  do i_state = 1, N_states
+   delta_e_virt += fock_virt_total_spin_trace(i_part_virt,i_state)
+  enddo
+ enddo
+
+ do i = 1, n_particles_spin(2)
+  i_part_virt = particles_list(i,2)
+  do i_state = 1, N_states
+   delta_e_virt += fock_virt_total_spin_trace(i_part_virt,i_state)
+  enddo
+ enddo
+
+
+ integer :: n_holes_spin_act(2),n_particles_spin_act(2)
+ integer :: n_holes_act,n_particles_act
+ integer :: holes_active_list(2*n_act_orb,2)
+ integer :: holes_active_list_spin_traced(4*n_act_orb)
+ integer :: particles_active_list(2*n_act_orb,2)
+ integer :: particles_active_list_spin_traced(4*n_act_orb)
+ double precision :: delta_e_act(N_states)
+ delta_e_act = 0.d0
+ call give_holes_and_particles_in_active_space(det_1,det_2,n_holes_spin_act,n_particles_spin_act, &
+                                               n_holes_act,n_particles_act,holes_active_list,particles_active_list)
+ integer :: icount,icountbis
+ integer :: hole_list_practical(2,elec_num_tab(1)+elec_num_tab(2)), particle_list_practical(2,elec_num_tab(1)+elec_num_tab(2))
+ icount = 0
+ icountbis = 0
+ do i = 1, n_holes_spin_act(1)
+  icount += 1
+  icountbis += 1
+  hole_list_practical(1,icountbis) = 1  ! spin 
+  hole_list_practical(2,icountbis) =  holes_active_list(i,1) ! index of active orb
+  holes_active_list_spin_traced(icount) = holes_active_list(i,1)
+ enddo
+ do i = 1, n_holes_spin_act(2)
+  icount += 1
+  icountbis += 1
+  hole_list_practical(1,icountbis) = 2
+  hole_list_practical(2,icountbis) =  holes_active_list(i,2)
+  holes_active_list_spin_traced(icount) = holes_active_list(i,2)
+ enddo
+ if(icount .ne. n_holes_act) then
+  print*,''
+  print*, icount, n_holes_act
+  print * , 'pb in holes_active_list_spin_traced !!' 
+  stop
+ endif
+
+ icount = 0
+ icountbis = 0
+ do i = 1, n_particles_spin_act(1)
+  icount += 1
+  icountbis += 1
+  particle_list_practical(1,icountbis) = 1
+  particle_list_practical(2,icountbis) =  particles_active_list(i,1)
+  particles_active_list_spin_traced(icount) = particles_active_list(i,1)
+ enddo
+ do i = 1, n_particles_spin_act(2)
+  icount += 1
+  icountbis += 1
+  particle_list_practical(1,icountbis) = 2
+  particle_list_practical(2,icountbis) =  particles_active_list(i,2)
+  particles_active_list_spin_traced(icount) = particles_active_list(i,2)
+ enddo
+ if(icount .ne. n_particles_act) then
+  print*, icount, n_particles_act
+  print * , 'pb in particles_active_list_spin_traced !!' 
+  stop
+ endif
+
+
+ integer :: i_hole_act, j_hole_act, k_hole_act
+ integer :: i_particle_act, j_particle_act, k_particle_act
+ 
+
+ integer :: ispin,jspin,kspin
+
+ do i = 1, n_holes_act 
+  ispin = hole_list_practical(1,i)
+  i_hole_act =  hole_list_practical(2,i)
+  do i_state = 1, N_states
+   delta_e_act(i_state) += one_anhil(i_hole_act , ispin,i_state)
+  enddo
+ enddo
+
+ do i = 1, n_particles_act
+  ispin = particle_list_practical(1,i)
+  i_particle_act =  particle_list_practical(2,i)
+  do i_state = 1, N_states
+   delta_e_act(i_state) += one_creat(i_particle_act, ispin,i_state)
+  enddo
+ enddo
+
+ do i_state = 1, n_states
+  delta_e_final(i_state) = delta_e_act(i_state)  + delta_e_inactive(i_state) - delta_e_virt(i_state)
+ enddo
+
+end
+

plugins/MRPT_Utils/second_order_new.irp.f

@@ -51,8 +51,8 @@ subroutine give_1h2p_new(matrix_1h2p)
  
  elec_num_tab_local = 0
  do inint = 1, N_int
-  elec_num_tab_local(1) += popcnt(psi_det(inint,1,1))
-  elec_num_tab_local(2) += popcnt(psi_det(inint,2,1))
+  elec_num_tab_local(1) += popcnt(psi_ref(inint,1,1))
+  elec_num_tab_local(2) += popcnt(psi_ref(inint,2,1))
  enddo
  do i = 1, n_inact_orb  ! First inactive 
   iorb = list_inact(i)
@@ -79,7 +79,7 @@ subroutine give_1h2p_new(matrix_1h2p)
                                     + fock_core_inactive_total_spin_trace(iorb,istate)        
       enddo
       do idet = 1, N_det
-        call get_excitation_degree_vector_mono_or_exchange(psi_det,psi_det(1,1,idet),degree,N_int,N_det,idx)
+        call get_excitation_degree_vector_mono_or_exchange(psi_ref,psi_ref(1,1,idet),degree,N_int,N_det,idx)
    !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! Precomputation of matrix elements 
         do ispin = 1, 2  ! spin of the couple a-a^dagger (iorb,rorb)
          do jspin = 1, 2   ! spin of the couple a-a^dagger (aorb,vorb)
@@ -90,8 +90,8 @@ subroutine give_1h2p_new(matrix_1h2p)
             enddo
             if(ispin == jspin .and. vorb.le.rorb)cycle ! condition not to double count 
             do inint = 1, N_int
-             det_tmp(inint,1) = psi_det(inint,1,idet)
-             det_tmp(inint,2) = psi_det(inint,2,idet)
+             det_tmp(inint,1) = psi_ref(inint,1,idet)
+             det_tmp(inint,2) = psi_ref(inint,2,idet)
             enddo
            ! Do the excitation  inactive -- > virtual
            call clear_bit_to_integer(iorb,det_tmp(1,ispin),N_int)  ! hole in "iorb" of spin Ispin
@@ -101,7 +101,7 @@ subroutine give_1h2p_new(matrix_1h2p)
            call clear_bit_to_integer(aorb,det_tmp(1,jspin),N_int)  ! hole in "aorb" of spin Jspin
            call set_bit_to_integer(vorb,det_tmp(1,jspin),N_int)    ! particle in "vorb" of spin Jspin
 
-           ! Check if the excitation is possible or not on psi_det(idet)
+           ! Check if the excitation is possible or not on psi_ref(idet)
            accu_elec= 0
            do inint = 1, N_int
             accu_elec+= popcnt(det_tmp(inint,jspin))
@@ -116,7 +116,7 @@ subroutine give_1h2p_new(matrix_1h2p)
             perturb_dets(inint,2,a,jspin,ispin) = det_tmp(inint,2) 
            enddo
             
-           call get_double_excitation(psi_det(1,1,idet),det_tmp,exc,phase,N_int)
+           call get_double_excitation(psi_ref(1,1,idet),det_tmp,exc,phase,N_int)
            perturb_dets_phase(a,jspin,ispin) = phase
            
            do istate = 1, N_states
@@ -138,7 +138,7 @@ subroutine give_1h2p_new(matrix_1h2p)
 !!!!!!!!!!!!!!!!!!!!!!!!!!!! <Jdet | K_{ab}               | Idet>
        do jdet = 1, idx(0)
           if(degree(jdet)==1)then
-           call get_mono_excitation(psi_det(1,1,idet),psi_det(1,1,idx(jdet)),exc,phase,N_int)
+           call get_mono_excitation(psi_ref(1,1,idet),psi_ref(1,1,idx(jdet)),exc,phase,N_int)
            if (exc(0,1,1) == 1) then
              ! Mono alpha
              i_hole = list_act_reverse(exc(1,1,1))   !!!  a_a
@@ -163,7 +163,7 @@ subroutine give_1h2p_new(matrix_1h2p)
              fock_operator_local(i_part,i_hole,kspin) = hij * phase ! phase less fock operator 
            endif
           else if(degree(jdet)==2)then
-           call get_double_excitation(psi_det(1,1,idet),psi_det(1,1,idx(jdet)),exc,phase,N_int)
+           call get_double_excitation(psi_ref(1,1,idet),psi_ref(1,1,idx(jdet)),exc,phase,N_int)
              ! Mono alpha
              index_orb_act_mono(idx(jdet),1) = list_act_reverse(exc(1,1,1))   !!!  a_a ALPHA 
              index_orb_act_mono(idx(jdet),2) = list_act_reverse(exc(1,2,1))   !!!  a^{\dagger}_{b} ALPHA 
@@ -209,13 +209,13 @@ subroutine give_1h2p_new(matrix_1h2p)
               det_tmp(inint,1)  = perturb_dets(inint,1,aorb,kspin,ispin) 
               det_tmp(inint,2)  = perturb_dets(inint,2,aorb,kspin,ispin) 
              enddo
-             call get_double_excitation(psi_det(1,1,idet),det_tmp,exc,phase,N_int)
+             call get_double_excitation(psi_ref(1,1,idet),det_tmp,exc,phase,N_int)
              if(kspin == ispin)then
               hia = phase * (active_int(aorb,1) - active_int(aorb,2) )
              else
               hia = phase * active_int(aorb,1)  
              endif
-             call get_double_excitation(psi_det(1,1,idx(jdet)),det_tmp,exc,phase,N_int)
+             call get_double_excitation(psi_ref(1,1,idx(jdet)),det_tmp,exc,phase,N_int)
              if(kspin == ispin)then
               hja = phase * (active_int(borb,1) - active_int(borb,2) )
              else
@@ -254,7 +254,7 @@ subroutine give_1h2p_new(matrix_1h2p)
                if(dabs(hia).le.1.d-12)cycle
                if(dabs(hab).le.1.d-12)cycle
  
-               call get_double_excitation(psi_det(1,1,idx(jdet)),det_tmp_bis,exc,phase,N_int)
+               call get_double_excitation(psi_ref(1,1,idx(jdet)),det_tmp_bis,exc,phase,N_int)
                if(jspin == ispin)then
                 hjb = phase * (active_int(corb,1) - active_int(corb,2) )
                else
@@ -307,7 +307,7 @@ subroutine give_1h2p_new(matrix_1h2p)
              hab = fock_operator_local(aorb,borb,1) * phase
 
              if(dabs(hab).le.1.d-12)cycle
-             call get_double_excitation(psi_det(1,1,idx(jdet)),det_tmp_bis,exc,phase,N_int)
+             call get_double_excitation(psi_ref(1,1,idx(jdet)),det_tmp_bis,exc,phase,N_int)
              if(ispin == 2)then
               hjb = phase * (active_int(aorb,1) - active_int(aorb,2) )
              else if (ispin == 1)then
@@ -341,7 +341,7 @@ subroutine give_1h2p_new(matrix_1h2p)
              hab = fock_operator_local(aorb,borb,2) * phase
 
              if(dabs(hab).le.1.d-12)cycle
-             call get_double_excitation(psi_det(1,1,idx(jdet)),det_tmp_bis,exc,phase,N_int)
+             call get_double_excitation(psi_ref(1,1,idx(jdet)),det_tmp_bis,exc,phase,N_int)
              if(ispin == 1)then
               hjb = phase * (active_int(borb,1) - active_int(borb,2) )
              else if (ispin == 2)then
@@ -380,7 +380,7 @@ subroutine give_1h2p_new(matrix_1h2p)
              hab = fock_operator_local(aorb,borb,1) * phase
 
              if(dabs(hab).le.1.d-12)cycle
-             call get_double_excitation(psi_det(1,1,idx(jdet)),det_tmp_bis,exc,phase,N_int)
+             call get_double_excitation(psi_ref(1,1,idx(jdet)),det_tmp_bis,exc,phase,N_int)
              if(ispin == 2)then
               hjb = phase * (active_int(borb,1) - active_int(borb,2) )
              else if (ispin == 1)then
@@ -415,7 +415,7 @@ subroutine give_1h2p_new(matrix_1h2p)
              hab = fock_operator_local(aorb,borb,2) * phase
 
              if(dabs(hab).le.1.d-12)cycle
-             call get_double_excitation(psi_det(1,1,idx(jdet)),det_tmp_bis,exc,phase,N_int)
+             call get_double_excitation(psi_ref(1,1,idx(jdet)),det_tmp_bis,exc,phase,N_int)
              if(ispin == 1)then
               hjb = phase * (active_int(borb,1) - active_int(borb,2) )
              else if (ispin == 2)then
@@ -433,9 +433,9 @@ subroutine give_1h2p_new(matrix_1h2p)
 
            else 
            ! one should not fall in this case ...
-            call debug_det(psi_det(1,1,i),N_int)
-            call debug_det(psi_det(1,1,idx(jdet)),N_int)
-            call get_double_excitation(psi_det(1,1,idet),psi_det(1,1,idx(jdet)),exc,phase,N_int)
+            call debug_det(psi_ref(1,1,i),N_int)
+            call debug_det(psi_ref(1,1,idx(jdet)),N_int)
+            call get_double_excitation(psi_ref(1,1,idet),psi_ref(1,1,idx(jdet)),exc,phase,N_int)
             call decode_exc(exc,2,h1,p1,h2,p2,s1,s2)
             integer                        :: h1, p1, h2, p2, s1, s2
             print*, h1, p1, h2, p2, s1, s2
@@ -519,8 +519,8 @@ subroutine give_2h1p_new(matrix_2h1p)
  
  elec_num_tab_local = 0
  do inint = 1, N_int
-  elec_num_tab_local(1) += popcnt(psi_det(inint,1,1))
-  elec_num_tab_local(2) += popcnt(psi_det(inint,2,1))
+  elec_num_tab_local(1) += popcnt(psi_ref(inint,1,1))
+  elec_num_tab_local(2) += popcnt(psi_ref(inint,2,1))
  enddo
  do i = 1, n_inact_orb  ! First inactive 
   iorb = list_inact(i)
@@ -547,7 +547,7 @@ subroutine give_2h1p_new(matrix_2h1p)
      enddo
 
       do idet = 1, N_det
-       call get_excitation_degree_vector_mono(psi_det,psi_det(1,1,idet),degree,N_int,N_det,idx)
+       call get_excitation_degree_vector_mono(psi_ref,psi_ref(1,1,idet),degree,N_int,N_det,idx)
    !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! Precomputation of matrix elements 
         do ispin = 1, 2  ! spin of the couple a-a^dagger (i,r)
          do jspin = 1, 2   ! spin of the couple z-a^dagger (j,a)
@@ -555,8 +555,8 @@ subroutine give_2h1p_new(matrix_2h1p)
            do a = 1, n_act_orb      ! First active 
             aorb = list_act(a)
             do inint = 1, N_int
-             det_tmp(inint,1) = psi_det(inint,1,idet)
-             det_tmp(inint,2) = psi_det(inint,2,idet)
+             det_tmp(inint,1) = psi_ref(inint,1,idet)
+             det_tmp(inint,2) = psi_ref(inint,2,idet)
             enddo
            ! Do the excitation  inactive -- > virtual
            call clear_bit_to_integer(iorb,det_tmp(1,ispin),N_int)  ! hole in "iorb" of spin Ispin
@@ -566,7 +566,7 @@ subroutine give_2h1p_new(matrix_2h1p)
            call clear_bit_to_integer(jorb,det_tmp(1,jspin),N_int)  ! hole in "jorb" of spin Jspin
            call set_bit_to_integer(aorb,det_tmp(1,jspin),N_int) ! particle in "aorb" of spin Jspin
 
-           ! Check if the excitation is possible or not on psi_det(idet)
+           ! Check if the excitation is possible or not on psi_ref(idet)
            accu_elec= 0
            do inint = 1, N_int
             accu_elec+= popcnt(det_tmp(inint,jspin))
@@ -580,7 +580,7 @@ subroutine give_2h1p_new(matrix_2h1p)
             perturb_dets(inint,1,a,jspin,ispin) = det_tmp(inint,1) 
             perturb_dets(inint,2,a,jspin,ispin) = det_tmp(inint,2) 
            enddo
-           call get_double_excitation(psi_det(1,1,idet),det_tmp,exc,phase,N_int)
+           call get_double_excitation(psi_ref(1,1,idet),det_tmp,exc,phase,N_int)
            perturb_dets_phase(a,jspin,ispin) = phase
            do istate = 1, N_states
             delta_e(a,jspin,istate) = one_creat(a,jspin,istate)   + delta_e_inactive_virt(istate)
@@ -602,7 +602,7 @@ subroutine give_2h1p_new(matrix_2h1p)
 !!!!!!!!!!!!!!!!!!!!!!!!!!!! <Jdet | a_{b} a^{\dagger}_a | Idet> 
        do jdet = 1, idx(0)
          if(degree(jdet)==1)then
-           call get_mono_excitation(psi_det(1,1,idet),psi_det(1,1,idx(jdet)),exc,phase,N_int)
+           call get_mono_excitation(psi_ref(1,1,idet),psi_ref(1,1,idx(jdet)),exc,phase,N_int)
             if (exc(0,1,1) == 1) then
               ! Mono alpha
               i_part = list_act_reverse(exc(1,2,1))    !  a^{\dagger}_{aorb}
@@ -658,7 +658,7 @@ subroutine give_2h1p_new(matrix_2h1p)
            ! you determine the interaction between the excited determinant and the other parent | Jdet >
            ! | det_tmp > = a^{\dagger}_{rorb,ispin} a^{\dagger}_{borb,kspin} a_{jorb,kspin} a_{iorb,ispin} | Jdet >
            ! hja = < det_tmp | H | Jdet >
-           call get_double_excitation(psi_det(1,1,idx(jdet)),det_tmp,exc,phase,N_int)
+           call get_double_excitation(psi_ref(1,1,idx(jdet)),det_tmp,exc,phase,N_int)
            if(kspin == ispin)then
             hja = phase * (active_int(borb,1) - active_int(borb,2) )
            else
@@ -698,7 +698,7 @@ subroutine give_2h1p_new(matrix_2h1p)
                hab = fock_operator_local(borb,aorb,kspin) * phase
                if(dabs(hab).le.1.d-10)cycle
               
-               call get_double_excitation(psi_det(1,1,idx(jdet)),det_tmp_bis,exc,phase,N_int)
+               call get_double_excitation(psi_ref(1,1,idx(jdet)),det_tmp_bis,exc,phase,N_int)
                if(jspin == ispin)then
                 hjb = phase * (active_int(corb,1) - active_int(corb,2) )
                else

plugins/MRPT_Utils/second_order_new_2p.irp.f

@@ -50,8 +50,8 @@ subroutine give_2p_new(matrix_2p)
  
  elec_num_tab_local = 0
  do inint = 1, N_int
-  elec_num_tab_local(1) += popcnt(psi_det(inint,1,1))
-  elec_num_tab_local(2) += popcnt(psi_det(inint,2,1))
+  elec_num_tab_local(1) += popcnt(psi_ref(inint,1,1))
+  elec_num_tab_local(2) += popcnt(psi_ref(inint,2,1))
  enddo
    do v = 1, n_virt_orb  ! First virtual 
     vorb = list_virt(v)
@@ -82,8 +82,8 @@ subroutine give_2p_new(matrix_2p)
                                     - fock_virt_total_spin_trace(vorb,istate)                 
       enddo
       do idet = 1, N_det
-!       call get_excitation_degree_vector_mono(psi_det,psi_det(1,1,idet),degree,N_int,N_det,idx)
-        call get_excitation_degree_vector(psi_det,psi_det(1,1,idet),degree,N_int,N_det,idx)
+!       call get_excitation_degree_vector_mono(psi_ref,psi_ref(1,1,idet),degree,N_int,N_det,idx)
+        call get_excitation_degree_vector(psi_ref,psi_ref(1,1,idet),degree,N_int,N_det,idx)
    !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! Precomputation of matrix elements 
         do ispin = 1, 2  ! spin of the couple a-a^dagger (aorb,rorb)
          do jspin = 1, 2   ! spin of the couple a-a^dagger (borb,vorb)
@@ -108,8 +108,8 @@ subroutine give_2p_new(matrix_2p)
               cycle ! condition not to double count 
              endif
              do inint = 1, N_int
-              det_tmp(inint,1) = psi_det(inint,1,idet)
-              det_tmp(inint,2) = psi_det(inint,2,idet)
+              det_tmp(inint,1) = psi_ref(inint,1,idet)
+              det_tmp(inint,2) = psi_ref(inint,2,idet)
              enddo
             ! Do the excitation  (aorb,ispin) --> (rorb,ispin)
             call clear_bit_to_integer(aorb,det_tmp(1,ispin),N_int)  ! hole in "aorb" of spin Ispin
@@ -119,7 +119,7 @@ subroutine give_2p_new(matrix_2p)
             call clear_bit_to_integer(borb,det_tmp(1,jspin),N_int)  ! hole in "borb" of spin Jspin
             call set_bit_to_integer(vorb,det_tmp(1,jspin),N_int)    ! particle in "vorb" of spin Jspin
             
-            ! Check if the excitation is possible or not on psi_det(idet)
+            ! Check if the excitation is possible or not on psi_ref(idet)
             accu_elec= 0
             do inint = 1, N_int
              accu_elec+= popcnt(det_tmp(inint,1)) + popcnt(det_tmp(inint,2))
@@ -134,7 +134,7 @@ subroutine give_2p_new(matrix_2p)
              perturb_dets(inint,2,a,b,ispin,jspin) = det_tmp(inint,2) 
             enddo
              
-            call get_double_excitation(psi_det(1,1,idet),det_tmp,exc,phase,N_int)
+            call get_double_excitation(psi_ref(1,1,idet),det_tmp,exc,phase,N_int)
             perturb_dets_phase(a,b,ispin,jspin) = phase
             
             do istate = 1, N_states
@@ -146,16 +146,16 @@ subroutine give_2p_new(matrix_2p)
             else 
              perturb_dets_hij(a,b,ispin,jspin) = phase * active_int(a,b,1) 
             endif
-            call i_H_j(psi_det(1,1,idet),det_tmp,N_int,hij)
+            call i_H_j(psi_ref(1,1,idet),det_tmp,N_int,hij)
             if(hij.ne.perturb_dets_hij(a,b,ispin,jspin))then
              print*, active_int(a,b,1) , active_int(b,a,1) 
              double precision :: hmono,hdouble
-             call i_H_j_verbose(psi_det(1,1,idet),det_tmp,N_int,hij,hmono,hdouble)
+             call i_H_j_verbose(psi_ref(1,1,idet),det_tmp,N_int,hij,hmono,hdouble)
              print*,  'pb !! hij.ne.perturb_dets_hij(a,b,ispin,jspin)'
              print*, ispin,jspin
              print*, aorb,rorb,borb,vorb
              print*, hij,perturb_dets_hij(a,b,ispin,jspin)
-             call debug_det(psi_det(1,1,idet),N_int)
+             call debug_det(psi_ref(1,1,idet),N_int)
              call debug_det(det_tmp,N_int)
              stop
             endif
@@ -170,7 +170,7 @@ subroutine give_2p_new(matrix_2p)
 !!!!!!!!!!!!!!!!!!!!!!!!!!!! <Jdet | K_{ab}               | Idet>
        do jdet = 1, idx(0)
           if(degree(jdet)==1)then
-           call get_mono_excitation(psi_det(1,1,idet),psi_det(1,1,idx(jdet)),exc,phase,N_int)
+           call get_mono_excitation(psi_ref(1,1,idet),psi_ref(1,1,idx(jdet)),exc,phase,N_int)
            if (exc(0,1,1) == 1) then
              ! Mono alpha
              i_hole = list_act_reverse(exc(1,1,1))   !!!  a_a
@@ -195,7 +195,7 @@ subroutine give_2p_new(matrix_2p)
              fock_operator_local(i_part,i_hole,kspin) = hij * phase ! phase less fock operator 
            endif
           else if(degree(jdet)==2)then
-           call get_double_excitation(psi_det(1,1,idet),psi_det(1,1,idx(jdet)),exc,phase,N_int)
+           call get_double_excitation(psi_ref(1,1,idet),psi_ref(1,1,idx(jdet)),exc,phase,N_int)
            if (exc(0,1,1) == 1) then
              ! Mono alpha
              index_orb_act_mono(idx(jdet),1) = list_act_reverse(exc(1,1,1))   !!!  a_a ALPHA 
@@ -262,7 +262,7 @@ subroutine give_2p_new(matrix_2p)
                   do jdet = 1, idx(0)
 !                  if(idx(jdet).gt.idet)cycle
                    do istate = 1, N_states
-                    call i_H_j(psi_det(1,1,idx(jdet)),det_tmp,N_int,hij)
+                    call i_H_j(psi_ref(1,1,idx(jdet)),det_tmp,N_int,hij)
                     matrix_2p(idx(jdet),idet,istate) += hij * perturb_dets_hij(a,b,ispin,jspin) * delta_e_inv(a,b,ispin,jspin,istate)
                    enddo
                   enddo ! jdet

plugins/Perturbation/pt2_equations.irp.f

@@ -226,18 +226,15 @@ subroutine pt2_moller_plesset ($arguments)
     call decode_exc(exc,degree,h1,p1,h2,p2,s1,s2)
     delta_e = (Fock_matrix_diag_mo(h1) - Fock_matrix_diag_mo(p1)) + &
               (Fock_matrix_diag_mo(h2) - Fock_matrix_diag_mo(p2))
-    delta_e = 1.d0/delta_e
-!   print*,'h1,p1',h1,p1
-!   print*,'h2,p2',h2,p2
   else if (degree == 1) then
     call decode_exc(exc,degree,h1,p1,h2,p2,s1,s2)
     delta_e = Fock_matrix_diag_mo(h1) - Fock_matrix_diag_mo(p1) 
-    delta_e = 1.d0/delta_e
   else
     delta_e = 0.d0
   endif
 
-  if (delta_e /= 0.d0) then
+  if (dabs(delta_e) > 1.d-10) then
+        delta_e = 1.d0/delta_e
     call i_H_psi_minilist(det_pert,minilist,idx_minilist,N_minilist,psi_selectors_coef,Nint,N_minilist,psi_selectors_size,N_st,i_H_psi_array)
     h = diag_H_mat_elem_fock(det_ref,det_pert,fock_diag_tmp,Nint)
   else
@@ -246,11 +243,6 @@ subroutine pt2_moller_plesset ($arguments)
   endif
   do i =1,N_st
     H_pert_diag(i) = h
-!   if(dabs(i_H_psi_array(i)).gt.1.d-8)then
-!   print*, i_H_psi_array(i)
-!    call debug_det(det_pert,N_int)
-!    print*, h1,p1,h2,p2,s1,s2
-!   endif
     c_pert(i) = i_H_psi_array(i) *delta_e
     e_2_pert(i) = c_pert(i) * i_H_psi_array(i)
   enddo

plugins/Selectors_CASSD/selectors.irp.f

@@ -30,7 +30,7 @@ END_PROVIDER
     enddo
   enddo
   do k=1,N_states
-    do i=1,N_det_selectors
+    do i=1,N_det_generators
       psi_selectors_coef(i,k) = psi_coef_generators(i,k)
     enddo
   enddo

plugins/Selectors_CASSD/zmq.irp.f

@@ -9,6 +9,7 @@ subroutine zmq_put_psi(zmq_to_qp_run_socket,worker_id, energy, size_energy)
   integer, intent(in)            :: size_energy
   double precision, intent(out)  :: energy(size_energy)
   integer                        :: rc
+  integer*8                      :: rc8
   character*(256)                :: msg
 
   write(msg,*) 'put_psi ', worker_id, N_states, N_det, psi_det_size, n_det_generators, n_det_selectors
@@ -19,15 +20,15 @@ subroutine zmq_put_psi(zmq_to_qp_run_socket,worker_id, energy, size_energy)
     stop 'error'
   endif
 
-  rc = f77_zmq_send(zmq_to_qp_run_socket,psi_det,N_int*2*N_det*bit_kind,ZMQ_SNDMORE)
-  if (rc /= N_int*2*N_det*bit_kind) then
-    print *, 'f77_zmq_send(zmq_to_qp_run_socket,psi_det,N_int*2*N_det*bit_kind,ZMQ_SNDMORE)'
+  rc8 = f77_zmq_send8(zmq_to_qp_run_socket,psi_det,N_int*2_8*N_det*bit_kind,ZMQ_SNDMORE)
+  if (rc8 /= N_int*2_8*N_det*bit_kind) then
+    print *, 'f77_zmq_send8(zmq_to_qp_run_socket,psi_det,N_int*2_8*N_det*bit_kind,ZMQ_SNDMORE)'
     stop 'error'
   endif
 
-  rc = f77_zmq_send(zmq_to_qp_run_socket,psi_coef,psi_det_size*N_states*8,ZMQ_SNDMORE)
-  if (rc /= psi_det_size*N_states*8) then
-    print *, 'f77_zmq_send(zmq_to_qp_run_socket,psi_coef,psi_det_size*N_states*8,ZMQ_SNDMORE)'
+  rc8 = f77_zmq_send8(zmq_to_qp_run_socket,psi_coef,psi_det_size*N_states*8_8,ZMQ_SNDMORE)
+  if (rc8 /= psi_det_size*N_states*8_8) then
+    print *, 'f77_zmq_send8(zmq_to_qp_run_socket,psi_coef,psi_det_size*N_states*8_8,ZMQ_SNDMORE)'
     stop 'error'
   endif
 
@@ -59,6 +60,7 @@ subroutine zmq_get_psi(zmq_to_qp_run_socket, worker_id, energy, size_energy)
   integer, intent(in)            :: size_energy
   double precision, intent(out)  :: energy(size_energy)
   integer                        :: rc
+  integer*8                      :: rc8
   character*(64)                 :: msg
 
   write(msg,*) 'get_psi ', worker_id
@@ -78,33 +80,30 @@ subroutine zmq_get_psi(zmq_to_qp_run_socket, worker_id, energy, size_energy)
   
   integer :: N_states_read, N_det_read, psi_det_size_read
   integer :: N_det_selectors_read, N_det_generators_read
-  read(msg(14:rc),*) rc, N_states_read, N_det_read, psi_det_size_read, &
+  read(msg(14:rc),*) N_states_read, N_det_read, psi_det_size_read, &
     N_det_generators_read, N_det_selectors_read
-  if (rc /= worker_id) then
-    print *,  'Wrong worker ID'
-    stop 'error'
-  endif
 
   N_states = N_states_read
   N_det    = N_det_read
   psi_det_size = psi_det_size_read
+  TOUCH psi_det_size N_det N_states
 
-  rc = f77_zmq_recv(zmq_to_qp_run_socket,psi_det,N_int*2*N_det*bit_kind,ZMQ_SNDMORE)
-  if (rc /= N_int*2*N_det*bit_kind) then
+  rc8 = f77_zmq_recv8(zmq_to_qp_run_socket,psi_det,N_int*2_8*N_det*bit_kind,0)
+  if (rc8 /= N_int*2_8*N_det*bit_kind) then
     print *, 'f77_zmq_recv(zmq_to_qp_run_socket,psi_det,N_int*2*N_det*bit_kind,ZMQ_SNDMORE)'
     stop 'error'
   endif
 
-  rc = f77_zmq_recv(zmq_to_qp_run_socket,psi_coef,psi_det_size*N_states*8,ZMQ_SNDMORE)
-  if (rc /= psi_det_size*N_states*8) then
-    print *, '77_zmq_recv(zmq_to_qp_run_socket,psi_coef,psi_det_size*N_states*8,ZMQ_SNDMORE)'
+  rc8 = f77_zmq_recv8(zmq_to_qp_run_socket,psi_coef,psi_det_size*N_states*8_8,0)
+  if (rc8 /= psi_det_size*N_states*8_8) then
+    print *, '77_zmq_recv8(zmq_to_qp_run_socket,psi_coef,psi_det_size*N_states*8_8,ZMQ_SNDMORE)'
     stop 'error'
   endif
-  TOUCH psi_det_size N_det N_states psi_det psi_coef
+  TOUCH psi_det psi_coef
 
   rc = f77_zmq_recv(zmq_to_qp_run_socket,energy,size_energy*8,0)
   if (rc /= size_energy*8) then
-    print *, 'f77_zmq_recv(zmq_to_qp_run_socket,energy,size_energy*8,0)'
+    print *, '77_zmq_recv(zmq_to_qp_run_socket,energy,size_energy*8,0)'
     stop 'error'
   endif
 

plugins/Selectors_full/zmq.irp.f

@@ -9,6 +9,7 @@ subroutine zmq_put_psi(zmq_to_qp_run_socket,worker_id, energy, size_energy)
   integer, intent(in)            :: size_energy
   double precision, intent(out)  :: energy(size_energy)
   integer                        :: rc
+  integer*8                      :: rc8
   character*(256)                :: msg
 
   write(msg,*) 'put_psi ', worker_id, N_states, N_det, psi_det_size, n_det_generators, n_det_selectors
@@ -19,15 +20,15 @@ subroutine zmq_put_psi(zmq_to_qp_run_socket,worker_id, energy, size_energy)
     stop 'error'
   endif
 
-  rc = f77_zmq_send(zmq_to_qp_run_socket,psi_det,N_int*2*N_det*bit_kind,ZMQ_SNDMORE)
-  if (rc /= N_int*2*N_det*bit_kind) then
-    print *, 'f77_zmq_send(zmq_to_qp_run_socket,psi_det,N_int*2*N_det*bit_kind,ZMQ_SNDMORE)'
+  rc8 = f77_zmq_send8(zmq_to_qp_run_socket,psi_det,N_int*2_8*N_det*bit_kind,ZMQ_SNDMORE)
+  if (rc8 /= N_int*2_8*N_det*bit_kind) then
+    print *, 'f77_zmq_send8(zmq_to_qp_run_socket,psi_det,N_int*2_8*N_det*bit_kind,ZMQ_SNDMORE)'
     stop 'error'
   endif
 
-  rc = f77_zmq_send(zmq_to_qp_run_socket,psi_coef,psi_det_size*N_states*8,ZMQ_SNDMORE)
-  if (rc /= psi_det_size*N_states*8) then
-    print *, 'f77_zmq_send(zmq_to_qp_run_socket,psi_coef,psi_det_size*N_states*8,ZMQ_SNDMORE)'
+  rc8 = f77_zmq_send8(zmq_to_qp_run_socket,psi_coef,psi_det_size*N_states*8_8,ZMQ_SNDMORE)
+  if (rc8 /= psi_det_size*N_states*8_8) then
+    print *, 'f77_zmq_send8(zmq_to_qp_run_socket,psi_coef,psi_det_size*N_states*8_8,ZMQ_SNDMORE)'
     stop 'error'
   endif
 
@@ -59,6 +60,7 @@ subroutine zmq_get_psi(zmq_to_qp_run_socket, worker_id, energy, size_energy)
   integer, intent(in)            :: size_energy
   double precision, intent(out)  :: energy(size_energy)
   integer                        :: rc
+  integer*8                      :: rc8
   character*(64)                 :: msg
 
   write(msg,*) 'get_psi ', worker_id
@@ -78,27 +80,23 @@ subroutine zmq_get_psi(zmq_to_qp_run_socket, worker_id, energy, size_energy)
   
   integer :: N_states_read, N_det_read, psi_det_size_read
   integer :: N_det_selectors_read, N_det_generators_read
-  read(msg(14:rc),*) rc, N_states_read, N_det_read, psi_det_size_read, &
+  read(msg(14:rc),*) N_states_read, N_det_read, psi_det_size_read, &
     N_det_generators_read, N_det_selectors_read
-  if (rc /= worker_id) then
-    print *,  'Wrong worker ID'
-    stop 'error'
-  endif
 
   N_states = N_states_read
   N_det    = N_det_read
   psi_det_size = psi_det_size_read
   TOUCH psi_det_size N_det N_states
 
-  rc = f77_zmq_recv(zmq_to_qp_run_socket,psi_det,N_int*2*N_det*bit_kind,0)
-  if (rc /= N_int*2*N_det*bit_kind) then
-    print *, 'f77_zmq_recv(zmq_to_qp_run_socket,psi_det,N_int*2*N_det*bit_kind,ZMQ_SNDMORE)'
+  rc8 = f77_zmq_recv8(zmq_to_qp_run_socket,psi_det,int(N_int*2_8*N_det*bit_kind,8),0)
+  if (rc8 /= N_int*2_8*N_det*bit_kind) then
+    print *, 'f77_zmq_recv8(zmq_to_qp_run_socket,psi_det,N_int*2*N_det*bit_kind,ZMQ_SNDMORE)'
     stop 'error'
   endif
 
-  rc = f77_zmq_recv(zmq_to_qp_run_socket,psi_coef,psi_det_size*N_states*8,0)
-  if (rc /= psi_det_size*N_states*8) then
-    print *, '77_zmq_recv(zmq_to_qp_run_socket,psi_coef,psi_det_size*N_states*8,ZMQ_SNDMORE)'
+  rc8 = f77_zmq_recv8(zmq_to_qp_run_socket,psi_coef,int(psi_det_size*N_states*8_8,8),0)
+  if (rc8 /= psi_det_size*N_states*8_8) then
+    print *, '77_zmq_recv8(zmq_to_qp_run_socket,psi_coef,psi_det_size*N_states*8,ZMQ_SNDMORE)'
     stop 'error'
   endif
   TOUCH psi_det psi_coef

plugins/mrcepa0/dressing.irp.f

@@ -98,19 +98,18 @@ subroutine mrcc_part_dress(delta_ij_, delta_ii_,delta_ij_s2_, delta_ii_s2_,i_gen
   integer :: mobiles(2), smallerlist
   logical, external :: detEq, is_generable
   !double precision, external :: get_dij, get_dij_index
+  double precision :: Delta_E_inv(N_states)
   
+  if (perturbative_triples) then
+    PROVIDE one_anhil fock_virt_total fock_core_inactive_total one_creat
+  endif
 
 
   leng = max(N_det_generators, N_det_non_ref)
   allocate(miniList(Nint, 2, leng), tq(Nint,2,n_selected), idx_minilist(leng), hij_cache(N_det_non_ref), sij_cache(N_det_non_ref))
   allocate(idx_alpha(0:psi_det_size), degree_alpha(psi_det_size))
-  !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
-  
   allocate(ptr_microlist(0:mo_tot_num*2+1),  &
       N_microlist(0:mo_tot_num*2) )
   allocate(   microlist(Nint,2,N_minilist*4),               &
@@ -138,7 +137,7 @@ subroutine mrcc_part_dress(delta_ij_, delta_ii_,delta_ij_s2_, delta_ii_s2_,i_gen
     if(N_minilist == 0) return
     
     
-    if(key_mask(1,1) /= 0) then !!!!!!!!!!! PAS GENERAL !!!!!!!!!
+    if(sum(abs(key_mask(1:N_int,1))) /= 0) then
       allocate(microlist_zero(Nint,2,N_minilist), idx_microlist_zero(N_minilist))
       
       allocate(   microlist(Nint,2,N_minilist*4),               &
@@ -191,14 +190,6 @@ subroutine mrcc_part_dress(delta_ij_, delta_ii_,delta_ij_s2_, delta_ii_s2_,i_gen
       end do
     end if
     
-    if (perturbative_triples) then
-      double precision :: Delta_E_inv(N_states)
-      double precision, external :: diag_H_mat_elem
-      do i_state=1,N_states
-        Delta_E_inv(i_state) = 1.d0 / (psi_ref_energy_diagonalized(i_state) - diag_H_mat_elem(tq(1,1,i_alpha),N_int) )
-      enddo
-    endif
-    
     do l_sd=1,idx_alpha(0)
       k_sd = idx_alpha(l_sd)
       call i_h_j(tq(1,1,i_alpha),psi_non_ref(1,1,idx_alpha(l_sd)),Nint,hij_cache(k_sd))
@@ -236,9 +227,6 @@ subroutine mrcc_part_dress(delta_ij_, delta_ii_,delta_ij_s2_, delta_ii_s2_,i_gen
         enddo
         logical :: ok
         call apply_excitation(psi_ref(1,1,i_I), exc, tmp_det, ok, Nint)
-        if (perturbative_triples) then
-          ok = ok .and. ( (degree2 /= 1).and.(degree /=1) )
-        endif
         
         do i_state=1,N_states
           dIK(i_state) = dij(i_I, idx_alpha(k_sd), i_state)
@@ -262,11 +250,30 @@ subroutine mrcc_part_dress(delta_ij_, delta_ii_,delta_ij_s2_, delta_ii_s2_,i_gen
           enddo
 
         else if (perturbative_triples) then
+           ! Linked
 
-          hka = hij_cache(idx_alpha(k_sd))
-          do i_state=1,N_states
-            dka(i_state) = hka * Delta_E_inv(i_state)
-          enddo
+            hka = hij_cache(idx_alpha(k_sd))
+            if (dabs(hka) > 1.d-12) then
+              call get_delta_e_dyall_general_mp(psi_ref(1,1,i_I),tq(1,1,i_alpha),Delta_E_inv)
+
+              do i_state=1,N_states
+                ASSERT (Delta_E_inv(i_state) < 0.d0)
+                dka(i_state) = hka / Delta_E_inv(i_state)
+              enddo
+            endif
+
+        endif
+
+        if (perturbative_triples.and. (degree2 == 1) ) then
+            call i_h_j(psi_ref(1,1,i_I),tmp_det,Nint,hka)
+            hka = hij_cache(idx_alpha(k_sd)) - hka
+            if (dabs(hka) > 1.d-12) then
+              call get_delta_e_dyall_general_mp(psi_ref(1,1,i_I),tq(1,1,i_alpha),Delta_E_inv)
+              do i_state=1,N_states
+                ASSERT (Delta_E_inv(i_state) < 0.d0)
+                dka(i_state) = hka / Delta_E_inv(i_state)
+              enddo
+            endif
 
         endif
 

plugins/mrcepa0/mrcepa0_general.irp.f

@@ -47,6 +47,9 @@ subroutine run(N_st,energy)
       enddo
       call diagonalize_ci_dressed(lambda)
       E_new = sum(ci_energy_dressed(1:N_states))
+!  if (.true.) then
+!    provide delta_ij_mrcc_pouet
+!  endif
       delta_E = (E_new - E_old)/dble(N_states)
       print *,  ''
       call write_double(6,thresh_mrcc,"thresh_mrcc")

plugins/read_integral/read_integrals_mo.irp.f

@@ -1,4 +1,7 @@
 program read_integrals
+
+  PROVIDE ezfio_filename
+  call ezfio_set_integrals_monoelec_disk_access_mo_one_integrals("None")
   call run
 end
 
@@ -18,9 +21,10 @@ subroutine run
   real(integral_kind), allocatable :: buffer_values(:)
   integer(key_kind)  :: key
    
-  call ezfio_set_mo_basis_mo_tot_num(mo_tot_num)
+  call ezfio_get_mo_basis_mo_tot_num(mo_tot_num)
 
   allocate (A(mo_tot_num_align,mo_tot_num))
+  A = 0.d0
   
   iunit = getunitandopen('kinetic_mo','r')
   do 
@@ -41,6 +45,10 @@ subroutine run
   close(iunit)
   call write_one_e_integrals('mo_ne_integral', A, size(A,1), size(A,2))
 
+  call write_one_e_integrals('mo_pseudo_integral', mo_pseudo_integral,&
+        size(mo_pseudo_integral,1), size(mo_pseudo_integral,2))
+
+
   call ezfio_set_integrals_monoelec_disk_access_mo_one_integrals("Read")
 
   allocate(buffer_i(mo_tot_num**4), buffer_values(mo_tot_num**4))
@@ -56,7 +64,7 @@ subroutine run
   13 continue
   close(iunit)
   
-  call insert_into_mo_integrals_map(n_integrals,buffer_i,buffer_values, 0.d0)
+  call insert_into_mo_integrals_map(n_integrals,buffer_i,buffer_values,0.d0)
 
   call map_sort(mo_integrals_map)
 

scripts/ezfio_interface/ei_handler.py

@@ -183,6 +183,8 @@ def get_type_dict():
                                           str_ocaml_type,
                                           str_fortran_type)
 
+    fancy_type["MO_class"] = Type("MO_class", "MO_class", "character*(32)")
+
     # ~#~#~#~#~#~#~#~ #
     # F i n a l i z e #
     # ~#~#~#~#~#~#~#~ #

scripts/ezfio_interface/qp_convert_output_to_ezfio.py

@@ -3,7 +3,7 @@
 convert output of gamess/GAU$$IAN to ezfio
 
 Usage:
-    qp_convert_output_to_ezfio.py <file.out> [--ezfio=<folder.ezfio>]
+    qp_convert_output_to_ezfio.py <file.out> [--ezfio=<ezfio_directory>]
 
 Option:
     file.out is the file to check (like gamess.out)
@@ -20,18 +20,17 @@ from functools import reduce
 # Add to the path #
 # ~#~#~#~#~#~#~#~ #
 
+
 try:
     QP_ROOT = os.environ["QP_ROOT"]
 except:
     print "Error: QP_ROOT environment variable not found."
     sys.exit(1)
 else:
-
     sys.path = [ QP_ROOT + "/install/EZFIO/Python", 
                  QP_ROOT + "/resultsFile", 
                  QP_ROOT + "/scripts"] + sys.path
 
-
 # ~#~#~#~#~#~ #
 # I m p o r t #
 # ~#~#~#~#~#~ #
@@ -280,12 +279,13 @@ def write_ezfio(res, filename):
     #                {% for coef,n,zeta for l_param}
     #                    {coef,n, zeta}
 
+
     # OUTPUT
 
     # Local are 1 array padded by max(n_max_block) when l == 0  (output:k_loc_max)
     # v_k[n-2][atom] = value
 
-    #No Local are 2 array padded with max of lmax_block when l!=0 (output:lmax+1)  and max(n_max_block)whem l !=0 (kmax)
+    #Non Local are 2 array padded with max of lmax_block when l!=0 (output:lmax+1)  and max(n_max_block)whem l !=0 (kmax)
     # v_kl[l][n-2][atom] = value
 
     def pad(array, size, value=0):
@@ -309,8 +309,16 @@ def write_ezfio(res, filename):
             array_l_max_block.append(l_max_block)
             array_z_remove.append(z_remove)
 
-            matrix.append([[coef_n_zeta.split()[1:] for coef_n_zeta in l.split('\n')] for l in array_party[1:]])
-
+            x = [[ filter(None,coef_n_zeta.split()) for coef_n_zeta in l.split('\n')] \
+               for l in array_party[1:] ]
+#            x = []
+#            for l in array_party[1:]:
+#              y = []
+#              for coef_n_zeta in l.split('\n'):
+#                z = coef_n_zeta.split()
+#                if z : y.append(z)
+#              x.append(y)
+#            matrix.append(x)
         return (matrix, array_l_max_block, array_z_remove)
 
     def get_local_stuff(matrix):
@@ -319,7 +327,6 @@ def write_ezfio(res, filename):
         k_loc_max = max(len(i) for i in matrix_local_unpad)
 
         matrix_local = [ pad(ll, k_loc_max, [0., 2, 0.]) for ll in matrix_local_unpad]
-
         m_coef = [[float(i[0]) for i in atom] for atom in matrix_local]
         m_n = [[int(i[1]) - 2 for i in atom] for atom in matrix_local]
         m_zeta = [[float(i[2]) for i in atom] for atom in matrix_local]
@@ -343,26 +350,42 @@ def write_ezfio(res, filename):
         return (l_max_block, k_max, m_coef_noloc, m_n_noloc, m_zeta_noloc)
 
     try:
-        pseudo_str = res_file.get_pseudo()
+        pseudo_str = []
+        label = ezfio.get_nuclei_nucl_label()
+        for ecp in res.pseudo:
+          pseudo_str += [ "%(label)s GEN %(zcore)d %(lmax)d" % { "label": label[ ecp["atom"]-1 ],
+                "zcore": ecp["zcore"], "lmax": ecp["lmax"] } ]
+          lmax = ecp["lmax"]
+          for l in [lmax] + list(range(0,lmax)):
+            pseudo_str += [ "%d"%len(ecp[str(l)]) ]
+            for t in ecp[str(l)]:
+              pseudo_str += [ "%f  %d  %f"%t ]
+          pseudo_str += [""]
+        pseudo_str = "\n".join(pseudo_str)
+             
         matrix, array_l_max_block, array_z_remove = parse_str(pseudo_str)
-
+        array_z_remove = map(float,array_z_remove)
     except:
         ezfio.set_pseudo_do_pseudo(False)
     else:
         ezfio.set_pseudo_do_pseudo(True)
-
+        
         # ~#~#~#~#~#~#~#~#~#~#~#~#~#~#~#~#~#~#~#~#~ #
         # Z _ e f f , a l p h a / b e t a _ e l e c #
         # ~#~#~#~#~#~#~#~#~#~#~#~#~#~#~#~#~#~#~#~#~ #
 
-        ezfio.pseudo_charge_remove = array_z_remove
-        ezfio.nuclei_nucl_charge = [i - j for i, j in zip(ezfio.nuclei_nucl_charge, array_z_remove)]
+        ezfio.set_pseudo_nucl_charge_remove(array_z_remove)
+        charge = ezfio.get_nuclei_nucl_charge()
+        charge = [ i - j for i, j in zip(charge, array_z_remove) ] 
+        ezfio.set_nuclei_nucl_charge (charge)
 
         import math
-        num_elec = sum(ezfio.nuclei_nucl_charge)
+        num_elec_diff = sum(array_z_remove)/2
+        nalpha = ezfio.get_electrons_elec_alpha_num() - num_elec_diff
+        nbeta  = ezfio.get_electrons_elec_beta_num() - num_elec_diff
 
-        ezfio.electrons_elec_alpha_num = int(math.ceil(num_elec / 2.))
-        ezfio.electrons_elec_beta_num = int(math.floor(num_elec / 2.))
+        ezfio.set_electrons_elec_alpha_num(nalpha)
+        ezfio.set_electrons_elec_beta_num( nbeta )
 
         # Change all the array 'cause EZFIO
         #   v_kl (v, l) => v_kl(l,v)
@@ -421,3 +444,12 @@ if __name__ == '__main__':
         print file_, 'recognized as', str(res_file).split('.')[-1].split()[0]
 
     write_ezfio(res_file, ezfio_file)
+    if os.system("qp_run save_ortho_mos "+ezfio_file) != 0:
+      print """Warning: You need to run 
+
+         qp_run save_ortho_mos """+ezfio_file+"""
+
+to be sure your MOs will be orthogonal, which is not the case when
+the MOs are read from output files (not enough precision in output)."""
+
+

src/Davidson/davidson_parallel.irp.f

@@ -71,6 +71,7 @@ subroutine davidson_slave_work(zmq_to_qp_run_socket, zmq_socket_push, N_st, sze,
   ! -----------------------
 
   integer                        :: rc
+  integer*8                      :: rc8
   integer                        :: N_states_read, N_det_read, psi_det_size_read
   integer                        :: N_det_selectors_read, N_det_generators_read
   double precision               :: energy(N_st)
@@ -90,14 +91,9 @@ subroutine davidson_slave_work(zmq_to_qp_run_socket, zmq_socket_push, N_st, sze,
     stop 'error'
   endif
 
-  read(msg(14:rc),*) rc, N_states_read, N_det_read, psi_det_size_read,        &
+  read(msg(14:rc),*) N_states_read, N_det_read, psi_det_size_read,        &
       N_det_generators_read, N_det_selectors_read
 
-  if (rc /= worker_id) then
-    print *,  'Wrong worker ID'
-    stop 'error'
-  endif
-  
   if (N_states_read /= N_st) then
     print *, N_st
     stop 'error : N_st'
@@ -110,16 +106,16 @@ subroutine davidson_slave_work(zmq_to_qp_run_socket, zmq_socket_push, N_st, sze,
 
   allocate(u_t(N_st,N_det_read))
 
-  rc = f77_zmq_recv(zmq_to_qp_run_socket,psi_det,N_int*2*N_det_read*bit_kind,0)
-  if (rc /= N_int*2*N_det_read*bit_kind) then
-    print *, 'f77_zmq_recv(zmq_to_qp_run_socket,psi_det,N_int*2*N_det_read*bit_kind,0)'
+  rc8 = f77_zmq_recv8(zmq_to_qp_run_socket,psi_det,N_int*2_8*N_det_read*bit_kind,0)
+  if (rc8 /= N_int*2_8*N_det_read*bit_kind) then
+    print *, 'f77_zmq_recv8(zmq_to_qp_run_socket,psi_det,N_int*2_8*N_det_read*bit_kind,0)'
     stop 'error'
   endif
 
-  rc = f77_zmq_recv(zmq_to_qp_run_socket,u_t,size(u_t)*8,0)
-  if (rc /= size(u_t)*8) then
+  rc8 = f77_zmq_recv8(zmq_to_qp_run_socket,u_t,size(u_t)*8_8,0)
+  if (rc8 /= size(u_t)*8_8) then
     print *,  rc, size(u_t)*8
-    print *, 'f77_zmq_recv(zmq_to_qp_run_socket,u_t,size(u_t)*8,0)'
+    print *, 'f77_zmq_recv8(zmq_to_qp_run_socket,u_t,size(u_t)*8_8,0)'
     stop 'error'
   endif
 
@@ -159,6 +155,7 @@ subroutine davidson_push_results(zmq_socket_push, v_t, s_t, imin, imax, task_id)
   double precision    ,intent(in)    :: v_t(N_states_diag,N_det)
   double precision    ,intent(in)    :: s_t(N_states_diag,N_det)
   integer                            :: rc, sz
+  integer*8                          :: rc8
 
   sz = (imax-imin+1)*N_states_diag
 
@@ -171,11 +168,11 @@ subroutine davidson_push_results(zmq_socket_push, v_t, s_t, imin, imax, task_id)
   rc = f77_zmq_send( zmq_socket_push, imax, 4, ZMQ_SNDMORE)
   if(rc /= 4) stop "davidson_push_results failed to push imax"
 
-  rc = f77_zmq_send( zmq_socket_push, v_t(1,imin), 8*sz, ZMQ_SNDMORE)
-  if(rc /= 8*sz) stop "davidson_push_results failed to push vt"
+  rc8 = f77_zmq_send8( zmq_socket_push, v_t(1,imin), 8_8*sz, ZMQ_SNDMORE)
+  if(rc8 /= 8_8*sz) stop "davidson_push_results failed to push vt"
 
-  rc = f77_zmq_send( zmq_socket_push, s_t(1,imin), 8*sz, 0)
-  if(rc /= 8*sz) stop "davidson_push_results failed to push st"
+  rc8 = f77_zmq_send8( zmq_socket_push, s_t(1,imin), 8_8*sz, 0)
+  if(rc8 /= 8_8*sz) stop "davidson_push_results failed to push st"
 
 ! Activate is zmq_socket_push is a REQ
 IRP_IF ZMQ_PUSH
@@ -202,6 +199,7 @@ subroutine davidson_pull_results(zmq_socket_pull, v_t, s_t, imin, imax, task_id)
   double precision    ,intent(out)    :: s_t(N_states_diag,N_det)
 
   integer                            :: rc, sz
+  integer*8                          :: rc8
 
   rc = f77_zmq_recv( zmq_socket_pull, task_id, 4, 0)
   if(rc /= 4) stop "davidson_pull_results failed to pull task_id"
@@ -214,11 +212,11 @@ subroutine davidson_pull_results(zmq_socket_pull, v_t, s_t, imin, imax, task_id)
 
   sz = (imax-imin+1)*N_states_diag
 
-  rc = f77_zmq_recv( zmq_socket_pull, v_t(1,imin), 8*sz, 0)
-  if(rc /= 8*sz) stop "davidson_pull_results failed to pull v_t"
+  rc8 = f77_zmq_recv8( zmq_socket_pull, v_t(1,imin), 8_8*sz, 0)
+  if(rc8 /= 8*sz) stop "davidson_pull_results failed to pull v_t"
 
-  rc = f77_zmq_recv( zmq_socket_pull, s_t(1,imin), 8*sz, 0)
-  if(rc /= 8*sz) stop "davidson_pull_results failed to pull s_t"
+  rc8 = f77_zmq_recv8( zmq_socket_pull, s_t(1,imin), 8_8*sz, 0)
+  if(rc8 /= 8*sz) stop "davidson_pull_results failed to pull s_t"
 
 ! Activate if zmq_socket_pull is a REP
 IRP_IF ZMQ_PUSH
@@ -322,6 +320,7 @@ subroutine H_S2_u_0_nstates_zmq(v_0,s_0,u_0,N_st,sze)
   
   character*(512) :: task
   integer :: rc
+  integer*8 :: rc8
   double precision :: energy(N_st)
   energy = 0.d0
 
@@ -329,25 +328,25 @@ subroutine H_S2_u_0_nstates_zmq(v_0,s_0,u_0,N_st,sze)
   write(task,*) 'put_psi ', 1, N_st, N_det, N_det
   rc = f77_zmq_send(zmq_to_qp_run_socket,trim(task),len(trim(task)),ZMQ_SNDMORE)
   if (rc /= len(trim(task))) then
-    print *, 'f77_zmq_send(zmq_to_qp_run_socket,trim(task),len(trim(task)),ZMQ_SNDMORE)'
+    print *, 'f77_zmq_send8(zmq_to_qp_run_socket,trim(task),len(trim(task)),ZMQ_SNDMORE)'
     stop 'error'
   endif
 
-  rc = f77_zmq_send(zmq_to_qp_run_socket,psi_det,N_int*2*N_det*bit_kind,ZMQ_SNDMORE)
-  if (rc /= N_int*2*N_det*bit_kind) then
-    print *, 'f77_zmq_send(zmq_to_qp_run_socket,psi_det,N_int*2*N_det*bit_kind,ZMQ_SNDMORE)'
+  rc8 = f77_zmq_send8(zmq_to_qp_run_socket,psi_det,N_int*2_8*N_det*bit_kind,ZMQ_SNDMORE)
+  if (rc8 /= N_int*2_8*N_det*bit_kind) then
+    print *, 'f77_zmq_send8(zmq_to_qp_run_socket,psi_det,N_int*2*N_det*bit_kind,ZMQ_SNDMORE)'
     stop 'error'
   endif
 
-  rc = f77_zmq_send(zmq_to_qp_run_socket,u_t,size(u_t)*8,ZMQ_SNDMORE)
-  if (rc /= size(u_t)*8) then
-    print *,  'f77_zmq_send(zmq_to_qp_run_socket,u_t,size(u_t)*8,ZMQ_SNDMORE)'
+  rc8 = f77_zmq_send8(zmq_to_qp_run_socket,u_t,size(u_t)*8_8,ZMQ_SNDMORE)
+  if (rc8 /= size(u_t)*8_8) then
+    print *,  'f77_zmq_send8(zmq_to_qp_run_socket,u_t,int(size(u_t)*8,8),ZMQ_SNDMORE)'
     stop 'error'
   endif
 
   rc = f77_zmq_send(zmq_to_qp_run_socket,energy,N_st*8,0)
   if (rc /= N_st*8) then
-    print *, 'f77_zmq_send(zmq_to_qp_run_socket,energy,size_energy*8,0)'
+    print *, 'f77_zmq_send8(zmq_to_qp_run_socket,energy,int(size_energy*8,8),0)'
     stop 'error'
   endif
 
@@ -415,3 +414,18 @@ subroutine H_S2_u_0_nstates_zmq(v_0,s_0,u_0,N_st,sze)
   enddo
 end
 
+
+BEGIN_PROVIDER [ integer, nthreads_davidson ]
+ implicit none
+ BEGIN_DOC
+ ! Number of threads for Davdison
+ END_DOC
+ nthreads_davidson = nproc
+ character*(32) :: env
+ call getenv('NTHREADS_DAVIDSON',env)
+ if (trim(env) /= '') then
+   read(env,*) nthreads_davidson
+ endif
+ call write_int(6,nthreads_davidson,'Number of threads for Diagonalization')
+END_PROVIDER
+

src/Davidson/diagonalization_hs2.irp.f

@@ -139,7 +139,7 @@ subroutine davidson_diag_hjj_sjj(dets_in,u_in,H_jj,s2_out,energies,dim_in,sze,N_
   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 = '===== '

src/Davidson/diagonalize_CI.irp.f

@@ -40,7 +40,7 @@ END_PROVIDER
    double precision, allocatable  :: e_array(:)
    integer, allocatable           :: iorder(:)
    
-   PROVIDE threshold_davidson
+   PROVIDE threshold_davidson nthreads_davidson
    ! Guess values for the "N_states" states of the CI_eigenvectors
    do j=1,min(N_states,N_det)
      do i=1,N_det

src/Davidson/u0Hu0.irp.f

@@ -134,8 +134,8 @@ subroutine H_S2_u_0_nstates_openmp_work_$N_int(v_t,s_t,u_t,N_st,sze,istart,iend,
   ! Prepare the array of all alpha single excitations
   ! -------------------------------------------------
 
-  PROVIDE N_int
-  !$OMP PARALLEL DEFAULT(NONE)                                       &
+  PROVIDE N_int nthreads_davidson
+  !$OMP PARALLEL DEFAULT(NONE) NUM_THREADS(nthreads_davidson)        &
       !$OMP   SHARED(psi_bilinear_matrix_rows, N_det,                &
       !$OMP          psi_bilinear_matrix_columns,                    &
       !$OMP          psi_det_alpha_unique, psi_det_beta_unique,      &

src/Determinants/H_apply.irp.f

@@ -76,7 +76,8 @@ subroutine resize_H_apply_buffer(new_size,iproc)
   allocate ( buffer_det(N_int,2,new_size),                           &
       buffer_coef(new_size,N_states),                                &
       buffer_e2(new_size,N_states) )
-  
+  buffer_coef = 0.d0 
+  buffer_e2 = 0.d0 
   do i=1,min(new_size,H_apply_buffer(iproc)%N_det)
     do k=1,N_int
       buffer_det(k,1,i) = H_apply_buffer(iproc)%det(k,1,i)

src/Determinants/density_matrix.irp.f

@@ -15,6 +15,57 @@
    enddo
 END_PROVIDER
 
+ BEGIN_PROVIDER [ double precision, one_body_dm_mo_spin_index, (mo_tot_num_align,mo_tot_num,N_states,2) ]
+ implicit none 
+ integer :: i,j,ispin,istate
+ ispin = 1
+  do istate = 1, N_states
+   do j = 1, mo_tot_num
+    do i = 1, mo_tot_num
+     one_body_dm_mo_spin_index(i,j,istate,ispin) = one_body_dm_mo_alpha(i,j,istate)
+    enddo
+   enddo
+  enddo
+
+ ispin = 2
+  do istate = 1, N_states
+   do j = 1, mo_tot_num
+    do i = 1, mo_tot_num
+     one_body_dm_mo_spin_index(i,j,istate,ispin) = one_body_dm_mo_beta(i,j,istate)
+    enddo
+   enddo
+  enddo
+
+ END_PROVIDER
+
+
+ BEGIN_PROVIDER [ double precision, one_body_dm_dagger_mo_spin_index, (mo_tot_num_align,mo_tot_num,N_states,2) ]
+ implicit none 
+ integer :: i,j,ispin,istate
+ ispin = 1
+  do istate = 1, N_states
+   do j = 1, mo_tot_num
+    one_body_dm_dagger_mo_spin_index(j,j,istate,ispin) = 1 - one_body_dm_mo_alpha(j,j,istate)
+    do i = j+1, mo_tot_num
+     one_body_dm_dagger_mo_spin_index(i,j,istate,ispin) = -one_body_dm_mo_alpha(i,j,istate)
+     one_body_dm_dagger_mo_spin_index(j,i,istate,ispin) = -one_body_dm_mo_alpha(i,j,istate)
+    enddo
+   enddo
+  enddo
+
+ ispin = 2
+  do istate = 1, N_states
+   do j = 1, mo_tot_num
+    one_body_dm_dagger_mo_spin_index(j,j,istate,ispin) = 1 - one_body_dm_mo_beta(j,j,istate)
+    do i = j+1, mo_tot_num
+     one_body_dm_dagger_mo_spin_index(i,j,istate,ispin) = -one_body_dm_mo_beta(i,j,istate)
+     one_body_dm_dagger_mo_spin_index(j,i,istate,ispin) = -one_body_dm_mo_beta(i,j,istate)
+    enddo
+   enddo
+  enddo
+
+ END_PROVIDER
+
  BEGIN_PROVIDER [ double precision, one_body_dm_mo_alpha, (mo_tot_num_align,mo_tot_num,N_states) ]
 &BEGIN_PROVIDER [ double precision, one_body_dm_mo_beta, (mo_tot_num_align,mo_tot_num,N_states) ]
    implicit none
@@ -285,6 +336,8 @@ END_PROVIDER
 
  BEGIN_PROVIDER [ double precision, one_body_dm_ao_alpha, (ao_num_align,ao_num) ]
 &BEGIN_PROVIDER [ double precision, one_body_dm_ao_beta, (ao_num_align,ao_num) ]
+&BEGIN_PROVIDER [ double precision, one_body_dm_ao_alpha_no_align, (ao_num,ao_num) ]
+&BEGIN_PROVIDER [ double precision, one_body_dm_ao_beta_no_align, (ao_num,ao_num) ]
  BEGIN_DOC
 ! one body density matrix on the AO basis : rho_AO(alpha) , rho_AO(beta)
  END_DOC
@@ -303,11 +356,16 @@ END_PROVIDER
 !    if(dabs(dm_mo).le.1.d-10)cycle
      one_body_dm_ao_alpha(l,k) += mo_coef(k,i) * mo_coef(l,j) *  mo_alpha
      one_body_dm_ao_beta(l,k) += mo_coef(k,i) * mo_coef(l,j)  *  mo_beta        
-
     enddo
    enddo
   enddo
  enddo
+ do i = 1, ao_num
+  do j = 1, ao_num
+   one_body_dm_ao_alpha_no_align(j,i) = one_body_dm_ao_alpha(j,i)
+   one_body_dm_ao_beta_no_align(j,i) = one_body_dm_ao_beta(j,i)
+  enddo
+ enddo
 
 END_PROVIDER
 

src/Determinants/slater_rules.irp.f

@@ -1977,7 +1977,7 @@ subroutine ac_operator(iorb,ispin,key,hjj,Nint,na,nb)
   !DIR$ FORCEINLINE
   call bitstring_to_list_ab(key, occ, tmp, Nint)
   ASSERT (tmp(1) == elec_alpha_num)
-  ASSERT (tmp(2) == elec_alpha_num)
+  ASSERT (tmp(2) == elec_beta_num)
   
   k = ishft(iorb-1,-bit_kind_shift)+1
   ASSERT (k >0)

src/Integrals_Bielec/map_integrals.irp.f

@@ -294,7 +294,7 @@ BEGIN_PROVIDER [ type(map_type), mo_integrals_map ]
   call bielec_integrals_index(mo_tot_num,mo_tot_num,mo_tot_num,mo_tot_num,key_max)
   sze = key_max
   call map_init(mo_integrals_map,sze)
-  print*, 'MO map initialized'
+  print*, 'MO map initialized: ', sze
 END_PROVIDER
 
 subroutine insert_into_ao_integrals_map(n_integrals,buffer_i, buffer_values)

src/MOGuess/mo_ortho_lowdin.irp.f

@@ -6,7 +6,9 @@ BEGIN_PROVIDER [double precision, ao_ortho_lowdin_coef, (ao_num_align,ao_num)]
 ! ao_ortho_lowdin_coef(i,j) = coefficient of the ith ao on the jth ao_ortho_lowdin orbital
   END_DOC
   integer                        :: i,j,k,l
-  double precision               :: tmp_matrix(ao_num_align,ao_num),accu
+  double precision               :: accu
+  double precision, allocatable  :: tmp_matrix(:,:)
+  allocate (tmp_matrix(ao_num_align,ao_num))
   tmp_matrix(:,:) = 0.d0
   do j=1, ao_num
     tmp_matrix(j,j) = 1.d0
@@ -17,6 +19,7 @@ BEGIN_PROVIDER [double precision, ao_ortho_lowdin_coef, (ao_num_align,ao_num)]
       ao_ortho_lowdin_coef(j,i) = tmp_matrix(i,j)
     enddo
   enddo
+  deallocate(tmp_matrix)
 END_PROVIDER
 
 BEGIN_PROVIDER [double precision, ao_ortho_lowdin_overlap, (ao_num_align,ao_num)]

src/MO_Basis/EZFIO.cfg

@@ -21,8 +21,8 @@ interface: ezfio
 size: (mo_basis.mo_tot_num)
 
 [mo_class]
-type: character*(32)
-doc: c: core, i: inactive, a: active, v: virtual, d: deleted
+type: MO_class
+doc: Core|Inactive|Active|Virtual|Deleted
 interface: ezfio, provider
 size: (mo_basis.mo_tot_num)
 

src/MO_Basis/ao_ortho_canonical.irp.f

@@ -82,6 +82,15 @@ END_PROVIDER
 
 
 
+BEGIN_PROVIDER [ double precision, ao_ortho_canonical_coef_inv, (ao_num,ao_num)]
+ implicit none
+ BEGIN_DOC
+! ao_ortho_canonical_coef^(-1)
+ END_DOC
+ call get_pseudo_inverse(ao_ortho_canonical_coef,ao_num,ao_num, &
+   ao_ortho_canonical_coef_inv, size(ao_ortho_canonical_coef,1))
+END_PROVIDER
+
  BEGIN_PROVIDER [ double precision, ao_ortho_canonical_coef, (ao_num_align,ao_num)]
 &BEGIN_PROVIDER [ integer, ao_ortho_canonical_num ]
   implicit none

src/MO_Basis/mos.irp.f

@@ -68,6 +68,18 @@ END_PROVIDER
   endif
 END_PROVIDER
 
+BEGIN_PROVIDER [ double precision, mo_coef_in_ao_ortho_basis, (ao_num_align, mo_tot_num) ]
+ implicit none
+ BEGIN_DOC
+ ! MO coefficients in orthogonalized AO basis
+ END_DOC
+ call dgemm('T','N',ao_num,mo_tot_num,ao_num,1.d0,                   &
+     ao_ortho_canonical_coef_inv, size(ao_ortho_canonical_coef_inv,1),&
+     mo_coef, size(mo_coef,1), 0.d0,                                 &
+     mo_coef_in_ao_ortho_basis, size(mo_coef_in_ao_ortho_basis,1))
+
+END_PROVIDER
+
 BEGIN_PROVIDER [ character*(64), mo_label ]
   implicit none
   BEGIN_DOC
@@ -139,8 +151,6 @@ BEGIN_PROVIDER [ double precision, mo_occ, (mo_tot_num) ]
   endif
 END_PROVIDER
 
-
-
 subroutine ao_to_mo(A_ao,LDA_ao,A_mo,LDA_mo)
   implicit none
   BEGIN_DOC
@@ -259,3 +269,62 @@ subroutine mix_mo_jk(j,k)
 
 end
 
+subroutine ao_ortho_cano_to_ao(A_ao,LDA_ao,A,LDA)
+  implicit none
+  BEGIN_DOC
+  ! Transform A from the AO basis to the orthogonal AO basis
+  END_DOC
+  integer, intent(in)            :: LDA_ao,LDA
+  double precision, intent(in)   :: A_ao(LDA_ao,*)
+  double precision, intent(out)  :: A(LDA,*)
+  double precision, allocatable  :: T(:,:)
+  
+  allocate ( T(ao_num_align,ao_num) )
+  !DIR$ ATTRIBUTES ALIGN : $IRP_ALIGN :: T
+  
+  call dgemm('T','N', ao_num, ao_num, ao_num,                    &
+      1.d0,                                                          &
+      ao_ortho_canonical_coef_inv, size(ao_ortho_canonical_coef_inv,1),  &
+      A_ao,LDA_ao,                                                   &
+      0.d0, T, ao_num_align)
+  
+  call dgemm('N','N', ao_num, ao_num, ao_num, 1.d0,          &
+      T, size(T,1),                                               &
+      ao_ortho_canonical_coef_inv,size(ao_ortho_canonical_coef_inv,1),&
+      0.d0, A, LDA)
+  
+  deallocate(T)
+end
+
+subroutine mo_to_ao_ortho_cano(A_mo,LDA_mo,A_ao,LDA_ao)
+  implicit none
+  BEGIN_DOC
+  ! Transform A from the AO orthogonal basis to the AO basis
+  END_DOC
+  integer, intent(in)            :: LDA_ao,LDA_mo
+  double precision, intent(in)   :: A_mo(LDA_mo)
+  double precision, intent(out)  :: A_ao(LDA_ao)
+  double precision, allocatable  :: T(:,:), SC(:,:)
+  
+  allocate ( SC(ao_num_align,mo_tot_num) )
+  allocate ( T(mo_tot_num_align,ao_num) )
+  !DIR$ ATTRIBUTES ALIGN : $IRP_ALIGN :: T
+  
+  call dgemm('N','N', ao_num, mo_tot_num, ao_num,                    &
+      1.d0, ao_overlap,size(ao_overlap,1),                           &
+      ao_ortho_canonical_coef, size(ao_ortho_canonical_coef,1),                                      &
+      0.d0, SC, ao_num_align)
+  
+  call dgemm('N','T', mo_tot_num, ao_num, mo_tot_num,                &
+      1.d0, A_mo,LDA_mo,                                             &
+      SC, size(SC,1),                                      &
+      0.d0, T, mo_tot_num_align)
+  
+  call dgemm('N','N', ao_num, ao_num, mo_tot_num,                    &
+      1.d0, SC,size(SC,1),                                 &
+      T, mo_tot_num_align,                                           &
+      0.d0, A_ao, LDA_ao)
+  
+  deallocate(T,SC)
+end
+

src/Utils/LinearAlgebra.irp.f

@@ -72,6 +72,8 @@ subroutine ortho_canonical(overlap,LDA,N,C,LDC,m)
   double precision, allocatable  :: S_half(:,:)
   !DEC$ ATTRIBUTES ALIGN : 64    :: U, Vt, D
   integer                        :: info, i, j
+!call ortho_lowdin(overlap,LDA,N,C,LDC,m)
+!return
   
   if (n < 2) then
     return
@@ -200,7 +202,7 @@ subroutine ortho_lowdin(overlap,LDA,N,C,LDC,m)
   !
   ! LDC : leftmost dimension of C
   !
-  ! m : Coefficients matrix is MxN, ( array is (LDC,N) )
+  ! M : Coefficients matrix is MxN, ( array is (LDC,N) )
   !
   END_DOC
   
@@ -211,7 +213,6 @@ subroutine ortho_lowdin(overlap,LDA,N,C,LDC,m)
   double precision, allocatable  :: Vt(:,:)
   double precision, allocatable  :: D(:)
   double precision, allocatable  :: S_half(:,:)
-  !DEC$ ATTRIBUTES ALIGN : 64    :: U, Vt, D
   integer                        :: info, i, j, k
   
   if (n < 2) then
@@ -298,12 +299,12 @@ subroutine get_pseudo_inverse(A,m,n,C,LDA)
   allocate(work(lwork))
   call dgesvd('S','A', m, n, A_tmp, m,D,U,m,Vt,n,work,lwork,info)
   if (info /= 0) then
-    print *,  info, ': SVD failed'
+    print *,  info, ':: SVD failed'
     stop 1
   endif
   
   do i=1,n
-    if (abs(D(i)) > 1.d-6) then
+    if (dabs(D(i)) > 1.d-6) then
       D(i) = 1.d0/D(i)
     else
       D(i) = 0.d0

tests/bats/pseudo.bats

@@ -14,7 +14,7 @@ function run_HF() {
   test_exe SCF || skip
   qp_edit -c $1
   ezfio set_file $1
-  ezfio set hartree_fock thresh_scf 1.e-11
+  ezfio set hartree_fock thresh_scf 1.e-8
   qp_run SCF $1
   energy="$(ezfio get hartree_fock energy)"
   eq $energy $2 $thresh