Revert "merge with main branch"

README.md

@@ -82,11 +82,11 @@ If you have set the `--developement` flag you can go in any module directory and
 
 ### 4) Compiling the OCaml
 
-    make -C $QP_ROOT/ocaml
+    make -C ocaml
 
 ### 5) Testing if all is ok
 
-    cd tests ; ./run_tests.sh
+    cd tests ; bats bats/qp.bats 
 
 
 
@@ -137,6 +137,10 @@ interface: ezfio
 
 #FAQ
 
+### Opam error: cryptokit
+
+You need to install `gmp-dev`.
+
 ### Error: ezfio_* is already defined.
 
 #### Why ?
@@ -162,5 +166,5 @@ It's caused when we call the DGEMM routine of LAPACK.
 
 ##### Fix
 
-Set `ulimit -s unlimited`, before runing `qp_run`. It seems to fix the problem.
+Set `ulimit -s unlimited`, before runing `qp_run`. It seem to fix the problem.
 

config/gfortran.cfg

@@ -35,14 +35,14 @@ OPENMP  : 1          ; Append OpenMP flags
 #                           -ffast-math and the Fortran-specific
 #                           -fno-protect-parens and -fstack-arrays.
 [OPT]
-FCFLAGS : 
+FCFLAGS : -Ofast
 
 # Profiling flags
 #################
 #
 [PROFILE]
 FC      : -p -g
-FCFLAGS : 
+FCFLAGS : -Ofast 
 
 # Debugging flags
 #################

config/gfortran_avx.cfg

@@ -10,7 +10,7 @@
 #
 #
 [COMMON]
-FC           : gfortran -ffree-line-length-none -I . -mavx -g 
+FC           : gfortran -ffree-line-length-none -I . -mavx -g
 LAPACK_LIB   : -llapack -lblas
 IRPF90       : irpf90
 IRPF90_FLAGS : --ninja --align=32
@@ -35,7 +35,7 @@ OPENMP  : 1          ; Append OpenMP flags
 #                           -ffast-math and the Fortran-specific
 #                           -fno-protect-parens and -fstack-arrays.
 [OPT]
-FCFLAGS : -Ofast -march=native
+FCFLAGS : -Ofast 
 
 # Profiling flags
 #################

config/gfortran_debug.cfg

@@ -51,7 +51,7 @@ FCFLAGS : -Ofast
 # -g           : Extra debugging information
 #
 [DEBUG]
-FCFLAGS : -g -msse4.2  -fcheck=all -Waliasing -Wampersand -Wconversion -Wsurprising -Wintrinsics-std -Wno-tabs -Wintrinsic-shadow -Wline-truncation -Wreal-q-constant 
+FCFLAGS : -g -msse4.2 
 
 # OpenMP flags
 #################

config/ifort.cfg

@@ -58,6 +58,6 @@ FCFLAGS : -xSSE2 -C -fpe0
 #################
 #
 [OPENMP]
-FC           : -openmp
+FC           : -qopenmp
 IRPF90_FLAGS : --openmp
 

configure

@@ -102,7 +102,7 @@ curl = Info(
     default_path=join(QP_ROOT_BIN, "curl"))
 
 zlib = Info(
-    url='http://www.zlib.net/fossils/zlib-1.2.10.tar.gz',
+    url='http://www.zlib.net/zlib-1.2.11.tar.gz',
     description=' zlib',
     default_path=join(QP_ROOT_LIB, "libz.a"))
 

ocaml/Basis.ml

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

ocaml/Basis.mli

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

ocaml/Input_determinants_by_hand.ml

@@ -7,7 +7,6 @@ module Determinants_by_hand : sig
     { n_int                  : N_int_number.t;
       bit_kind               : Bit_kind.t;
       n_det                  : Det_number.t;
-      n_states               : States_number.t;
       expected_s2            : Positive_float.t;
       psi_coef               : Det_coef.t array;
       psi_det                : Determinant.t array;
@@ -19,14 +18,11 @@ module Determinants_by_hand : sig
   val to_rst : t -> Rst_string.t
   val of_rst : Rst_string.t -> t option
   val read_n_int : unit -> N_int_number.t
-  val update_ndet : Det_number.t -> unit
-  val extract_state : States_number.t -> unit
 end = struct
   type t = 
     { n_int                  : N_int_number.t;
       bit_kind               : Bit_kind.t;
       n_det                  : Det_number.t;
-      n_states               : States_number.t;
       expected_s2            : Positive_float.t;
       psi_coef               : Det_coef.t array;
       psi_det                : Determinant.t array;
@@ -133,12 +129,12 @@ end = struct
     |> Array.map ~f:Det_coef.of_float
   ;;
 
-  let write_psi_coef ~n_det ~n_states c =
+  let write_psi_coef ~n_det c =
     let n_det = Det_number.to_int n_det
     and c = Array.to_list c
             |> List.map ~f:Det_coef.to_float
     and n_states = 
-      States_number.to_int n_states
+      read_n_states () |> States_number.to_int
     in
     Ezfio.ezfio_array_of_list ~rank:2 ~dim:[| n_det ; n_states |] ~data:c
     |> Ezfio.set_determinants_psi_coef 
@@ -204,7 +200,6 @@ end = struct
           expected_s2            = read_expected_s2 ()          ;
           psi_coef               = read_psi_coef ()             ;
           psi_det                = read_psi_det ()              ;
-          n_states               = read_n_states ()             ;
         }
     else
       failwith "No molecular orbitals, so no determinants"
@@ -227,14 +222,12 @@ end = struct
               expected_s2          ;
               psi_coef             ;
               psi_det              ;
-              n_states             ;
             } =
      write_n_int n_int ;
      write_bit_kind bit_kind;
      write_n_det n_det;
-     write_n_states n_states;
      write_expected_s2 expected_s2;
-     write_psi_coef ~n_det:n_det ~n_states:n_states psi_coef ;
+     write_psi_coef ~n_det:n_det psi_coef ;
      write_psi_det ~n_int:n_int ~n_det:n_det psi_det;
   ;;
 
@@ -305,7 +298,6 @@ Determinants ::
 n_int                  = %s
 bit_kind               = %s
 n_det                  = %s
-n_states               = %s
 expected_s2            = %s
 psi_coef               = %s
 psi_det                = %s
@@ -313,7 +305,6 @@ psi_det                = %s
      (b.n_int         |> N_int_number.to_string)
      (b.bit_kind      |> Bit_kind.to_string)
      (b.n_det         |> Det_number.to_string)
-     (b.n_states      |> States_number.to_string)
      (b.expected_s2   |> Positive_float.to_string)
      (b.psi_coef  |> Array.to_list |> List.map ~f:Det_coef.to_string
       |> String.concat ~sep:", ")
@@ -442,83 +433,14 @@ psi_det                = %s
       |> Bit_kind.to_int)
     and n_int =
       Printf.sprintf "(n_int %d)" (N_int_number.get_max ())
-    and n_states =
-      Printf.sprintf "(n_states %d)" (States_number.to_int @@ read_n_states ())
     in
     let s = 
-       String.concat [ header ; bitkind ; n_int ; n_states ; psi_coef ; psi_det]
+       String.concat [ header ; bitkind ; n_int ; psi_coef ; psi_det]
     in
 
-
-
-
     Generic_input_of_rst.evaluate_sexp t_of_sexp s
   ;;
 
-  let update_ndet n_det_new =
-    Printf.printf "Reducing n_det to %d\n" (Det_number.to_int n_det_new);
-    let n_det_new =
-      Det_number.to_int n_det_new
-    in
-    let det =
-      read ()
-    in
-    let n_det_old, n_states =
-      Det_number.to_int det.n_det,
-      States_number.to_int det.n_states
-    in
-    if n_det_new = n_det_old then
-      ()
-    ;
-    if n_det_new > n_det_new then
-      failwith @@ Printf.sprintf "Requested n_det should be less than %d" n_det_old
-    ;
-    for j=0 to (n_states-1) do
-      let ishift_old, ishift_new =
-        j*n_det_old,
-        j*n_det_new
-      in
-      for i=0 to (n_det_new-1) do
-        det.psi_coef.(i+ishift_new) <- det.psi_coef.(i+ishift_old)
-      done
-    done
-    ;
-    let new_det =
-      { det with n_det = (Det_number.of_int n_det_new) }
-    in
-    write new_det
-  ;;
-
-  let extract_state istate =
-    Printf.printf "Extracting state %d\n" (States_number.to_int istate);
-    let det =
-      read ()
-    in
-    let n_det, n_states =
-      Det_number.to_int det.n_det,
-      States_number.to_int det.n_states
-    in
-    if (States_number.to_int istate) > n_states then
-      failwith "State to extract should not be greater than n_states"
-    ;
-    let j =
-      (States_number.to_int istate) - 1
-    in
-    begin
-      if (j>0) then
-        let ishift =
-          j*n_det
-        in
-        for i=0 to (n_det-1) do
-          det.psi_coef.(i) <- det.psi_coef.(i+ishift)
-        done
-    end;
-    let new_det =
-      { det with n_states = (States_number.of_int 1) }
-    in
-    write new_det
-  ;;
-
 end
 
 

ocaml/Makefile

@@ -13,7 +13,6 @@ LIBS=
 PKGS=
 OCAMLCFLAGS="-g -warn-error A"
 OCAMLBUILD=ocamlbuild -j 0 -syntax camlp4o -cflags $(OCAMLCFLAGS) -lflags $(OCAMLCFLAGS) 
-MLLFILES=$(wildcard *.mll) 
 MLFILES=$(wildcard *.ml) ezfio.ml Qptypes.ml Input_auto_generated.ml qp_edit.ml 
 MLIFILES=$(wildcard *.mli) git
 ALL_TESTS=$(patsubst %.ml,%.byte,$(wildcard test_*.ml))

ocaml/Message.ml

@@ -110,7 +110,7 @@ module Disconnect_msg : sig
   { client_id: Id.Client.t ;
     state: State.t ;
   }
-  val create : state:string -> client_id:int -> t
+  val create : state:string -> client_id:string -> t
   val to_string : t -> string
 end = struct
   type t = 
@@ -118,7 +118,7 @@ end = struct
     state: State.t ;
   }
   let create ~state ~client_id = 
-    { client_id = Id.Client.of_int client_id ; state = State.of_string state }
+    { client_id = Id.Client.of_string client_id ; state = State.of_string state }
   let to_string x =
     Printf.sprintf "disconnect %s %d"
       (State.to_string x.state)
@@ -150,18 +150,18 @@ end
 module AddTask_msg : sig
   type t = 
   { state: State.t;
-    tasks:  string list;
+    task:  string;
   }
-  val create : state:string -> tasks:string list -> t
+  val create : state:string -> task:string -> t
   val to_string : t -> string
 end = struct
   type t = 
   { state: State.t;
-    tasks:  string list;
+    task:  string;
   }
-  let create ~state ~tasks = { state = State.of_string state ; tasks }
+  let create ~state ~task = { state = State.of_string state ; task }
   let to_string x =
-    Printf.sprintf "add_task %s %s" (State.to_string x.state) (String.concat ~sep:"|" x.tasks)
+    Printf.sprintf "add_task %s %s" (State.to_string x.state) x.task 
 end
 
 
@@ -182,44 +182,44 @@ end
 module DelTask_msg : sig
   type t = 
   { state:  State.t;
-    task_ids:  Id.Task.t list
+    task_id:  Id.Task.t
   }
-  val create : state:string -> task_ids:int list -> t
+  val create : state:string -> task_id:string -> t
   val to_string : t -> string
 end = struct
   type t = 
   { state:  State.t;
-    task_ids:  Id.Task.t list
+    task_id:  Id.Task.t
   }
-  let create ~state ~task_ids =
+  let create ~state ~task_id =
     { state = State.of_string state ; 
-      task_ids = List.map ~f:Id.Task.of_int task_ids
+      task_id = Id.Task.of_string task_id
     }
   let to_string x =
-    Printf.sprintf "del_task %s %s" 
+    Printf.sprintf "del_task %s %d" 
       (State.to_string x.state)
-      (String.concat ~sep:"|" @@ List.map ~f:Id.Task.to_string x.task_ids)
+      (Id.Task.to_int x.task_id)
 end
 
 
 (** DelTaskReply : Reply to the DelTask message *)
 module DelTaskReply_msg : sig
   type t  
-  val create : task_ids:Id.Task.t list -> more:bool -> t
+  val create : task_id:Id.Task.t -> more:bool -> t
   val to_string : t -> string
 end = struct
   type t = {
-    task_ids : Id.Task.t list;
+    task_id : Id.Task.t ;
     more    : bool;
   }
-  let create ~task_ids ~more = { task_ids ; more }
+  let create ~task_id ~more = { task_id ; more }
   let to_string x =
     let more = 
       if x.more then "more"
       else "done"
     in
-    Printf.sprintf "del_task_reply %s %s" 
+    Printf.sprintf "del_task_reply %s %d" 
-     more (String.concat ~sep:"|" @@ List.map ~f:Id.Task.to_string x.task_ids) 
+     more (Id.Task.to_int x.task_id) 
 end
 
 
@@ -230,7 +230,7 @@ module GetTask_msg : sig
   { client_id: Id.Client.t ;
     state: State.t ;
   }
-  val create : state:string -> client_id:int -> t
+  val create : state:string -> client_id:string -> t
   val to_string : t -> string
 end = struct
   type t = 
@@ -238,7 +238,7 @@ end = struct
     state: State.t ;
   }
   let create ~state ~client_id = 
-    { client_id = Id.Client.of_int client_id ; state = State.of_string state }
+    { client_id = Id.Client.of_string client_id ; state = State.of_string state }
   let to_string x =
     Printf.sprintf "get_task %s %d"
       (State.to_string x.state)
@@ -269,14 +269,14 @@ module GetPsi_msg : sig
   type t = 
   { client_id: Id.Client.t ;
   }
-  val create : client_id:int -> t
+  val create : client_id:string -> t
   val to_string : t -> string
 end = struct
   type t = 
   { client_id: Id.Client.t ;
   }
   let create ~client_id = 
-    { client_id = Id.Client.of_int client_id }
+    { client_id = Id.Client.of_string client_id }
   let to_string x =
     Printf.sprintf "get_psi %d"
       (Id.Client.to_int x.client_id)
@@ -365,14 +365,14 @@ module PutPsi_msg : sig
     n_det_selectors  : Strictly_positive_int.t option;
     psi       :  Psi.t option }
   val create : 
-     client_id:int ->
+     client_id:string ->
-     n_state:int ->
+     n_state:string ->
-     n_det:int ->
+     n_det:string ->
-     psi_det_size:int ->
+     psi_det_size:string ->
      psi_det:string option ->
      psi_coef:string option ->
-     n_det_generators: int option -> 
+     n_det_generators: string option -> 
-     n_det_selectors:int option ->
+     n_det_selectors:string option ->
      energy:string option -> t
   val to_string_list : t -> string list
   val to_string : t -> string 
@@ -388,17 +388,20 @@ end = struct
   let create ~client_id ~n_state ~n_det ~psi_det_size ~psi_det ~psi_coef 
     ~n_det_generators ~n_det_selectors ~energy =
     let n_state, n_det, psi_det_size = 
-       Strictly_positive_int.of_int n_state,
+       Int.of_string n_state 
-       Strictly_positive_int.of_int n_det,
+       |> Strictly_positive_int.of_int ,
-       Strictly_positive_int.of_int psi_det_size
+       Int.of_string n_det
+       |> Strictly_positive_int.of_int ,
+       Int.of_string psi_det_size
+       |> Strictly_positive_int.of_int
     in
     assert (Strictly_positive_int.to_int psi_det_size >=
       Strictly_positive_int.to_int n_det);
     let n_det_generators, n_det_selectors  =
       match n_det_generators, n_det_selectors  with
       | Some x, Some y -> 
-         Some (Strictly_positive_int.of_int x), 
+         Some (Strictly_positive_int.of_int @@ Int.of_string x), 
-         Some (Strictly_positive_int.of_int y)
+         Some (Strictly_positive_int.of_int @@ Int.of_string y)
       | _ -> None, None
     in
     let psi =
@@ -408,7 +411,7 @@ end = struct
           ~psi_coef ~n_det_generators ~n_det_selectors ~energy)
       | _ -> None
     in
-    { client_id = Id.Client.of_int client_id ;
+    { client_id = Id.Client.of_string client_id ;
       n_state ; n_det ; psi_det_size ; n_det_generators ;
       n_det_selectors ; psi }
 
@@ -460,48 +463,48 @@ module TaskDone_msg : sig
   type t =
     { client_id: Id.Client.t ;
       state:     State.t ;
-      task_ids:  Id.Task.t list ;
+      task_id:   Id.Task.t ;
     }
-  val create : state:string -> client_id:int -> task_ids:int list -> t
+  val create : state:string -> client_id:string -> task_id:string -> t
   val to_string : t -> string
 end = struct
   type t =
   { client_id: Id.Client.t ;
     state: State.t ;
-    task_ids:  Id.Task.t list;
+    task_id:  Id.Task.t;
   }
-  let create ~state ~client_id ~task_ids = 
+  let create ~state ~client_id ~task_id = 
-    { client_id = Id.Client.of_int client_id ; 
+    { client_id = Id.Client.of_string client_id ; 
       state = State.of_string state ;
-      task_ids  = List.map ~f:Id.Task.of_int task_ids;
+      task_id  = Id.Task.of_string task_id;
     }
 
   let to_string x =
-    Printf.sprintf "task_done %s %d %s"
+    Printf.sprintf "task_done %s %d %d"
       (State.to_string x.state)
       (Id.Client.to_int x.client_id)
-      (String.concat ~sep:"|" @@ List.map ~f:Id.Task.to_string x.task_ids)
+      (Id.Task.to_int x.task_id)
 end
 
 (** Terminate *)
 module Terminate_msg : sig
   type t 
-  val create : t
+  val create : unit -> t
   val to_string : t -> string
 end = struct
   type t = Terminate
-  let create = Terminate
+  let create () = Terminate
   let to_string x = "terminate"
 end
 
 (** OK *)
 module Ok_msg : sig
   type t 
-  val create : t
+  val create : unit -> t
   val to_string : t -> string
 end = struct
   type t = Ok
-  let create = Ok
+  let create () = Ok
   let to_string x = "ok"
 end
 
@@ -548,45 +551,45 @@ type t =
 
 
 let of_string s = 
-  let open Message_lexer in
+  let l =
-    match parse s with
+    String.split ~on:' ' s
-    | AddTask_  { state ; tasks } -> 
+    |> List.filter ~f:(fun x -> (String.strip x) <> "")
-        AddTask (AddTask_msg.create ~state ~tasks)
+    |> List.map ~f:String.lowercase
-    | DelTask_  { state ; task_ids } ->
+  in
-        DelTask (DelTask_msg.create ~state ~task_ids)
+  match l with
-    | GetTask_  { state ; client_id } ->
+  | "add_task"   :: state :: task ->
-        GetTask (GetTask_msg.create ~state ~client_id)
+       AddTask (AddTask_msg.create ~state ~task:(String.concat ~sep:" " task) )
-    | TaskDone_ { state ; task_ids ; client_id } ->
+  | "del_task"   :: state :: task_id :: [] ->
-        TaskDone (TaskDone_msg.create ~state ~client_id ~task_ids)
+       DelTask (DelTask_msg.create ~state ~task_id)
-    | Disconnect_ { state ; client_id } ->
+  | "get_task"   :: state :: client_id :: [] ->
-        Disconnect (Disconnect_msg.create ~state ~client_id)
+       GetTask (GetTask_msg.create ~state ~client_id)
-    | Connect_ socket ->
+  | "task_done"  :: state :: client_id :: task_id :: [] ->
-        Connect (Connect_msg.create socket)
+       TaskDone (TaskDone_msg.create ~state ~client_id ~task_id)
-    | NewJob_ { state ; push_address_tcp ; push_address_inproc } ->
+  | "disconnect" :: state :: client_id :: [] ->
-        Newjob (Newjob_msg.create push_address_tcp push_address_inproc state)
+       Disconnect (Disconnect_msg.create ~state ~client_id)
-    | EndJob_ state  ->
+  | "connect"    :: t :: [] -> 
-        Endjob (Endjob_msg.create state)
+       Connect (Connect_msg.create t)
-    | GetPsi_ client_id ->
+  | "new_job"    :: state :: push_address_tcp :: push_address_inproc :: [] -> 
-        GetPsi (GetPsi_msg.create ~client_id)
+       Newjob (Newjob_msg.create push_address_tcp push_address_inproc state)
-    | PutPsi_ { client_id ; n_state ; n_det ; psi_det_size ; n_det_generators ; n_det_selectors } ->
+  | "end_job"    :: state :: [] -> 
-      begin
+       Endjob (Endjob_msg.create state)
-        match n_det_selectors, n_det_generators with
+  | "terminate"  :: [] ->
-        | Some s, Some g -> 
+       Terminate (Terminate_msg.create () )
-            PutPsi (PutPsi_msg.create ~client_id ~n_state ~n_det ~psi_det_size
+  | "get_psi"    :: client_id :: [] ->
-                  ~n_det_generators:(Some g) ~n_det_selectors:(Some s)
+       GetPsi   (GetPsi_msg.create ~client_id)
-                  ~psi_det:None ~psi_coef:None ~energy:None )
+  | "put_psi"    :: client_id :: n_state :: n_det :: psi_det_size :: n_det_generators :: n_det_selectors :: [] ->
-        | _ ->
+       PutPsi   (PutPsi_msg.create ~client_id ~n_state ~n_det ~psi_det_size
-            PutPsi (PutPsi_msg.create ~client_id ~n_state ~n_det ~psi_det_size
+                 ~n_det_generators:(Some n_det_generators) ~n_det_selectors:(Some n_det_selectors)
-                  ~n_det_generators:None ~n_det_selectors:None
+                 ~psi_det:None ~psi_coef:None ~energy:None )
-                  ~psi_det:None ~psi_coef:None ~energy:None )
+  | "put_psi"    :: client_id :: n_state :: n_det :: psi_det_size :: [] ->
-      end
+       PutPsi   (PutPsi_msg.create ~client_id ~n_state ~n_det ~psi_det_size ~n_det_generators:None
-    | Terminate_  -> Terminate (Terminate_msg.create )
+                ~n_det_selectors:None ~psi_det:None ~psi_coef:None ~energy:None)
-    | SetWaiting_ -> SetWaiting
+  | "ok"         :: [] -> Ok (Ok_msg.create ())
-    | SetStopped_ -> SetStopped
+  | "error"      :: rest -> Error (Error_msg.create (String.concat ~sep:" " rest))
-    | SetRunning_ -> SetRunning
+  | "set_stopped"       :: [] -> SetStopped
-    | Ok_ -> Ok (Ok_msg.create)
+  | "set_running"       :: [] -> SetRunning 
-    | Error_ m -> Error (Error_msg.create m)
+  | "set_waiting"       :: [] -> SetWaiting
-  
+  | _ -> failwith "Message not understood"
     
 
 let to_string = function

ocaml/Message_lexer.mll

@@ -1,265 +0,0 @@
-{
-
-type kw_type = 
-    | TEXT     of string
-    | WORD     of string
-    | INTEGER  of int
-    | FLOAT    of float
-    | NONE
-    | ADD_TASK 
-    | DEL_TASK 
-    | GET_TASK 
-    | TASK_DONE
-    | DISCONNECT
-    | CONNECT
-    | NEW_JOB
-    | END_JOB
-    | TERMINATE
-    | GET_PSI
-    | PUT_PSI
-    | OK
-    | ERROR
-    | SET_STOPPED
-    | SET_RUNNING
-    | SET_WAITING
-
-type state_tasks            = { state : string ; tasks            : string list ; }
-type state_taskids          = { state : string ; task_ids         : int list   ; }
-type state_taskids_clientid = { state : string ; task_ids         : int list   ; client_id : int    ; }
-type state_clientid         = { state : string ; client_id        : int    ; }
-type state_tcp_inproc       = { state : string ; push_address_tcp : string ; push_address_inproc : string ; }
-type psi = { client_id: int ; n_state: int ; n_det: int ; psi_det_size: int ; 
-  n_det_generators: int option ; n_det_selectors: int option }
-
-type msg =
-    | AddTask_    of state_tasks
-    | DelTask_    of state_taskids
-    | GetTask_    of state_clientid
-    | TaskDone_   of state_taskids_clientid
-    | Disconnect_ of state_clientid
-    | Connect_    of string
-    | NewJob_     of state_tcp_inproc
-    | EndJob_     of string
-    | Terminate_
-    | GetPsi_     of int
-    | PutPsi_     of psi
-    | Ok_
-    | Error_      of string 
-    | SetStopped_
-    | SetRunning_ 
-    | SetWaiting_ 
-}
-
-let word = [^' ' '\t' '\n']+
-let text = [^ ' ' '|']+[^ '|']+
-let integer  = ['0'-'9']+ 
-let real = '-'? integer '.' integer (['e' 'E'] '-'? integer)? 
-
-let white = [' ' '\t']+
-
-
-rule get_text = parse
-  | text    as t   { TEXT t }
-  | eof            { TERMINATE }
-  | _              { NONE }
-
-and get_int = parse
-  | integer as i   { INTEGER (int_of_string i) }
-  | eof            { TERMINATE }
-  | _              { NONE }
-
-and get_word = parse
-  | word    as w   { WORD w }
-  | eof            { TERMINATE }
-  | _              { NONE }
-
-and kw = parse
-  | "add_task"     { ADD_TASK }
-  | "del_task"     { DEL_TASK }
-  | "get_task"     { GET_TASK }
-  | "task_done"    { TASK_DONE }
-  | "disconnect"   { DISCONNECT }
-  | "connect"      { CONNECT }
-  | "new_job"      { NEW_JOB }
-  | "end_job"      { END_JOB }
-  | "terminate"    { TERMINATE }
-  | "get_psi"      { GET_PSI }
-  | "put_psi"      { PUT_PSI }
-  | "ok"           { OK }
-  | "error"        { ERROR }
-  | "set_stopped"  { SET_STOPPED }
-  | "set_running"  { SET_RUNNING }
-  | "set_waiting"  { SET_WAITING }
-  | _              { NONE }
-
-
-{
-  let rec read_text ?(accu=[]) lexbuf =
-    let token =
-      get_text lexbuf
-    in
-    match token with
-    | TEXT t -> read_text ~accu:(t::accu) lexbuf
-    | TERMINATE -> List.rev accu 
-    | NONE -> read_text ~accu lexbuf
-    | _ -> failwith "Error in MessageLexer (2)"
-
-  and read_word lexbuf =
-    let token =
-      get_word lexbuf
-    in
-    match token with
-    | WORD w -> w
-    | NONE -> read_word lexbuf
-    | _ -> failwith "Error in MessageLexer (3)"
-
-  and read_int lexbuf =
-    let token =
-      get_int lexbuf
-    in
-    match token with
-    | INTEGER i -> i
-    | NONE -> read_int lexbuf
-    | _ -> failwith "Error in MessageLexer (4)"
-
-  and read_ints ?(accu=[]) lexbuf =
-    let token =
-      get_int lexbuf
-    in
-    match token with
-    | INTEGER i -> read_ints ~accu:(i::accu) lexbuf
-    | TERMINATE -> List.rev accu
-    | NONE -> read_ints ~accu lexbuf
-    | _ -> failwith "Error in MessageLexer (4)"
-
-  and parse_rec lexbuf =
-    let token =
-      kw lexbuf
-    in
-    match token with
-    | ADD_TASK -> 
-        let state = read_word lexbuf in
-        let tasks  = read_text lexbuf in
-        AddTask_ { state ; tasks }
-
-    | DEL_TASK ->
-        let state    = read_word lexbuf in  
-        let task_ids = read_ints lexbuf in
-        DelTask_ { state ; task_ids }
- 
-    | GET_TASK ->
-        let state   = read_word lexbuf in  
-        let client_id = read_int lexbuf in
-        GetTask_ { state ; client_id }
- 
-    | TASK_DONE ->
-        let state     = read_word lexbuf in  
-        let client_id = read_int  lexbuf in
-        let task_ids  = read_ints lexbuf in
-        TaskDone_ { state ; task_ids ; client_id }
- 
-    | DISCONNECT ->
-        let state     = read_word lexbuf in  
-        let client_id = read_int lexbuf in
-        Disconnect_ { state ; client_id }
- 
-    | GET_PSI ->
-        let client_id = read_int lexbuf in
-        GetPsi_ client_id
- 
-    | PUT_PSI ->
-        let client_id    = read_int lexbuf in
-        let n_state      = read_int lexbuf in
-        let n_det        = read_int lexbuf in
-        let psi_det_size = read_int lexbuf in
-        let n_det_generators, n_det_selectors = 
-          try
-            (Some (read_int lexbuf), Some (read_int lexbuf))
-          with (Failure _) -> (None, None)
-        in
-        PutPsi_ { client_id ; n_state ; n_det ; psi_det_size ; n_det_generators ; n_det_selectors }
- 
-    | CONNECT ->
-        let socket    = read_word lexbuf in  
-        Connect_ socket
- 
-    | NEW_JOB ->
-        let state               = read_word lexbuf in
-        let push_address_tcp    = read_word lexbuf in
-        let push_address_inproc = read_word lexbuf in
-        NewJob_ { state ; push_address_tcp ; push_address_inproc }
- 
-    | END_JOB ->
-        let state  = read_word lexbuf in  
-        EndJob_ state
- 
-    | ERROR       ->
-        let message = List.hd (read_text lexbuf) in
-        Error_ message
-
-    | OK          -> Ok_
-    | SET_WAITING -> SetWaiting_
-    | SET_RUNNING -> SetRunning_
-    | SET_STOPPED -> SetStopped_
-    | TERMINATE   -> Terminate_
-    | NONE        -> parse_rec lexbuf
-    | _ -> failwith "Error in MessageLexer"
-
-  let parse message = 
-    let lexbuf =
-      Lexing.from_string message
-    in
-    parse_rec lexbuf
-
-
-  let debug () =
-    let l = [
-      "add_task  state_pouet  Task pouet zob" ;
-      "add_task  state_pouet  Task pouet zob |Task2 zob | Task3 prout" ;
-      "del_task  state_pouet  12345" ;
-      "del_task  state_pouet  12345 | 6789 | 10 | 11" ;
-      "get_task  state_pouet  12" ;
-      "task_done state_pouet  12 12345";
-      "task_done state_pouet  12 12345 | 678 | 91011";
-      "connect tcp";
-      "disconnect state_pouet 12";
-      "new_job state_pouet tcp://test.com:12345 ipc:///dev/shm/x.socket";
-      "end_job state_pouet";
-      "terminate" ;
-      "set_running" ;
-      "set_stopped" ;
-      "set_waiting" ;
-      "ok" ;
-      "error my_error" ;
-      "get_psi 12" ;
-      "put_psi 12 2 1000 10000 800 900" ;
-      "put_psi 12 2 1000 10000"
-      ]
-      |> List.map parse 
-    in
-    List.map (function
-      | AddTask_  { state ; tasks   } -> Printf.sprintf "ADD_TASK state:\"%s\" tasks:{\"%s\"}" state (String.concat "\"}|{\"" tasks)
-      | DelTask_  { state ; task_ids } -> Printf.sprintf "DEL_TASK state:\"%s\" task_ids:{%s}" state (String.concat "|" @@ List.map string_of_int task_ids)
-      | GetTask_  { state ; client_id } -> Printf.sprintf "GET_TASK state:\"%s\" task_id:%d" state client_id
-      | TaskDone_ { state ; task_ids ; client_id } -> Printf.sprintf "TASK_DONE state:\"%s\" task_ids:{%s} client_id:%d" state (String.concat "|" @@ List.map string_of_int task_ids) client_id
-      | Disconnect_ { state ; client_id } -> Printf.sprintf "DISCONNECT state:\"%s\" client_id:%d" state client_id
-      | Connect_ socket -> Printf.sprintf "CONNECT socket:\"%s\"" socket
-      | NewJob_ { state ; push_address_tcp ; push_address_inproc } -> Printf.sprintf "NEW_JOB state:\"%s\" tcp:\"%s\" inproc:\"%s\"" state push_address_tcp push_address_inproc
-      | EndJob_ state  -> Printf.sprintf "END_JOB state:\"%s\"" state
-      | GetPsi_ client_id -> Printf.sprintf "GET_PSI client_id:%d" client_id
-      | PutPsi_ { client_id ; n_state ; n_det ; psi_det_size ; n_det_generators ; n_det_selectors } ->
-        begin 
-          match n_det_selectors, n_det_generators with
-          | Some s, Some g ->  Printf.sprintf "PUT_PSI client_id:%d n_state:%d n_det:%d psi_det_size:%d n_det_generators:%d n_det_selectors:%d" client_id n_state n_det psi_det_size g s
-          | _ -> Printf.sprintf "PUT_PSI client_id:%d n_state:%d n_det:%d psi_det_size:%d" client_id n_state n_det psi_det_size 
-        end
-      | Terminate_ ->  "TERMINATE"
-      | SetWaiting_ ->  "SET_WAITING"
-      | SetStopped_ ->  "SET_STOPPED"
-      | SetRunning_ ->  "SET_RUNNING"
-      | Ok_ ->  "OK"
-      | Error_ s ->  Printf.sprintf "ERROR: \"%s\"" s
-    ) l
-    |> List.iter print_endline
-
-}

ocaml/Symmetry.ml

@@ -85,7 +85,7 @@ module Xyz = struct
   let of_string s =
     let flush state accu number =
       let n = 
-        if (number = "") then 1
+        if (number = "") then 0
         else (Int.of_string number) 
       in
       match state with

ocaml/TaskServer.ml

@@ -47,14 +47,6 @@ let debug str =
 let zmq_context =
   ZMQ.Context.create ()
 
-let () =
-  let nproc =
-    match Sys.getenv "OMP_NUM_THREADS" with
-    | Some m -> int_of_string m
-    | None -> 2
-  in
-  ZMQ.Context.set_io_threads zmq_context nproc
-
 
 let bind_socket ~socket_type ~socket ~port =
   let rec loop = function
@@ -70,15 +62,7 @@ let bind_socket ~socket_type ~socket ~port =
       | Unix.Unix_error _ -> (Time.pause @@ Time.Span.of_float 1. ; loop (i-1) )
       | other_exception -> raise other_exception
   in loop 60;
-  let filename =
+  ZMQ.Socket.bind socket @@ Printf.sprintf "ipc:///tmp/qp_run:%d" port
-    Printf.sprintf "/tmp/qp_run:%d" port
-  in
-  begin
-    match Sys.file_exists filename with
-    | `Yes -> Sys.remove filename
-    | _ -> ()
-  end;
-  ZMQ.Socket.bind socket ("ipc://"^filename)
 
 
 let hostname = lazy (
@@ -115,7 +99,7 @@ let ip_address = lazy (
 
 
 let reply_ok rep_socket =
-    Message.Ok_msg.create 
+    Message.Ok_msg.create ()
     |> Message.Ok_msg.to_string
     |> ZMQ.Socket.send rep_socket 
 
@@ -137,7 +121,7 @@ let stop ~port =
     ZMQ.Socket.set_linger_period req_socket 1_000_000;
     ZMQ.Socket.connect req_socket address;
 
-    Message.Terminate (Message.Terminate_msg.create)
+    Message.Terminate (Message.Terminate_msg.create ())
     |> Message.to_string
     |> ZMQ.Socket.send req_socket ;
 
@@ -305,9 +289,9 @@ let disconnect msg program_state rep_socket =
     
 let del_task msg program_state rep_socket =
 
-    let state, task_ids =
+    let state, task_id =
       msg.Message.DelTask_msg.state, 
-      msg.Message.DelTask_msg.task_ids
+      msg.Message.DelTask_msg.task_id
     in
 
     let failure () =
@@ -318,14 +302,13 @@ let del_task msg program_state rep_socket =
 
         let new_program_state = 
             { program_state with
-              queue = List.fold ~f:(fun queue task_id -> Queuing_system.del_task ~task_id queue)
+              queue = Queuing_system.del_task ~task_id program_state.queue
-                      ~init:program_state.queue task_ids
             }
         in
         let more = 
             (Queuing_system.number_of_tasks new_program_state.queue > 0)
         in
-        Message.DelTaskReply (Message.DelTaskReply_msg.create ~task_ids ~more)
+        Message.DelTaskReply (Message.DelTaskReply_msg.create ~task_id ~more)
         |> Message.to_string
         |> ZMQ.Socket.send ~block:true rep_socket ; (** /!\ Has to be blocking *)
         new_program_state
@@ -346,9 +329,9 @@ let del_task msg program_state rep_socket =
 
 let add_task msg program_state rep_socket =
 
-    let state, tasks =
+    let state, task =
         msg.Message.AddTask_msg.state,
-        msg.Message.AddTask_msg.tasks
+        msg.Message.AddTask_msg.task
     in
 
     let increment_progress_bar = function
@@ -356,17 +339,59 @@ let add_task msg program_state rep_socket =
       | None -> None
     in
 
+    let rec add_task_triangle program_state imax = function
+      | 0 -> program_state
+      | i -> 
+          let task = 
+             Printf.sprintf "%d %d" i imax
+          in
+          let new_program_state =
+             { program_state with
+               queue = Queuing_system.add_task ~task program_state.queue ;
+               progress_bar = increment_progress_bar program_state.progress_bar ;
+             }
+          in
+          add_task_triangle new_program_state imax (i-1)
+    in
+    
+    let rec add_task_range program_state i = function
+      | j when (j < i) -> program_state
+      | j -> 
+          let task = 
+             Printf.sprintf "%d" j
+          in
+          let new_program_state =
+             { program_state with
+               queue = Queuing_system.add_task ~task program_state.queue ;
+               progress_bar = increment_progress_bar program_state.progress_bar ;
+             }
+          in
+          add_task_range new_program_state i (j-1)
+    in
+    
+    let new_program_state = function
+      | "triangle" :: i_str :: [] ->
+          let imax = 
+              Int.of_string i_str
+          in
+          add_task_triangle program_state imax imax
+      | "range" :: i_str :: j_str :: [] ->
+          let i, j = 
+              Int.of_string i_str,
+              Int.of_string j_str
+          in
+          add_task_range program_state i j
+      | _ -> 
+          { program_state with
+            queue = Queuing_system.add_task ~task program_state.queue ;
+            progress_bar = increment_progress_bar program_state.progress_bar ;
+          }
+    in 
+
     let result = 
-        let new_queue, new_bar = 
+        String.split ~on:' ' task
-          List.fold ~f:(fun (queue, bar) task ->
+        |> List.filter ~f:(fun x -> x <> "")
-              Queuing_system.add_task ~task queue,
+        |> new_program_state 
-              increment_progress_bar bar)
-            ~init:(program_state.queue, program_state.progress_bar) tasks 
-        in
-        { program_state with
-          queue = new_queue;
-          progress_bar = new_bar
-        }
     in
     reply_ok rep_socket;
     result
@@ -423,10 +448,10 @@ let get_task msg program_state rep_socket pair_socket =
 
 let task_done msg program_state rep_socket =
 
-    let state, client_id, task_ids =
+    let state, client_id, task_id =
         msg.Message.TaskDone_msg.state,
         msg.Message.TaskDone_msg.client_id,
-        msg.Message.TaskDone_msg.task_ids
+        msg.Message.TaskDone_msg.task_id
     in
 
     let increment_progress_bar = function
@@ -439,16 +464,10 @@ let task_done msg program_state rep_socket =
         program_state
     
     and success () = 
-        let new_queue, new_bar = 
-          List.fold ~f:(fun (queue, bar) task_id -> 
-              Queuing_system.end_task ~task_id ~client_id queue,
-              increment_progress_bar bar)
-            ~init:(program_state.queue, program_state.progress_bar) task_ids 
-        in
         let result = 
           { program_state with
-            queue = new_queue;
+            queue = Queuing_system.end_task ~task_id ~client_id program_state.queue ;
-            progress_bar = new_bar
+            progress_bar = increment_progress_bar program_state.progress_bar ;
           }
         in
         reply_ok rep_socket;

ocaml/qp_create_ezfio_from_xyz.ml

@@ -21,9 +21,6 @@ let spec =
      ~doc:" Compute AOs in the Cartesian basis set (6d, 10f, ...)"
   +> anon ("(xyz_file|zmt_file)" %: file )
 
-type element =
-| Element of Element.t
-| Int_elem of (Nucl_number.t * Element.t)
 
 (** Handle dummy atoms placed on bonds *)
 let dummy_centers ~threshold ~molecule ~nuclei =
@@ -118,14 +115,17 @@ let run ?o b c d m p cart xyz_file =
   (* Open basis set channels *)
   let basis_channel element =
     let key =
-      match element with
+      Element.to_string element
-      | Element e -> Element.to_string e
-      | Int_elem (i,e) -> Printf.sprintf "%d,%s" (Nucl_number.to_int i)  (Element.to_string e)
     in
     match Hashtbl.find basis_table key with
     | Some in_channel -> 
         in_channel
-    | None -> raise Not_found
+    | None -> 
+         let msg = 
+           Printf.sprintf "%s is not defined in basis %s.%!"
+           (Element.to_long_string element) b ;
+         in
+         failwith msg
   in
   
   let temp_filename =
@@ -189,21 +189,12 @@ let run ?o b c d m p cart xyz_file =
       | Some (key, basis) -> (*Aux basis *)
         begin
           let elem  = 
-            try
+            Element.of_string key
-              Element (Element.of_string key)
-            with Element.ElementError _ ->
-              let result = 
-                match (String.split ~on:',' key) with
-                | i :: k :: [] -> (Nucl_number.of_int @@ int_of_string i, Element.of_string k)
-                | _ -> failwith "Expected format is int,Element:basis"
-              in Int_elem result
           and basis =
             String.lowercase basis
           in
           let key = 
-             match elem with
+             Element.to_string elem
-             | Element e -> Element.to_string e
-             | Int_elem (i,e) -> Printf.sprintf "%d,%s" (Nucl_number.to_int i) (Element.to_string e)
           in
           let new_channel =
             fetch_channel basis
@@ -211,13 +202,7 @@ let run ?o b c d m p cart xyz_file =
           begin
             match Hashtbl.add basis_table ~key:key ~data:new_channel with
             | `Ok -> ()
-            | `Duplicate ->
+            | `Duplicate -> failwith ("Duplicate definition of basis for "^(Element.to_long_string elem))
-              let e = 
-                match elem with
-                | Element e -> e
-                | Int_elem (_,e) -> e
-              in
-              failwith ("Duplicate definition of basis for "^(Element.to_long_string e))
           end
        end
     end;
@@ -552,20 +537,7 @@ let run ?o b c d m p cart xyz_file =
               | Element.X -> Element.H
               | e -> e
             in
-            let key =
+            Basis.read_element (basis_channel x.Atom.element) i e
-              Int_elem (i,x.Atom.element)
-            in
-            try
-              Basis.read_element (basis_channel key) i e
-            with Not_found ->
-              let key =
-                Element x.Atom.element
-              in
-              try
-                Basis.read_element (basis_channel key) i e
-              with Not_found ->
-                failwith (Printf.sprintf "Basis not found for atom %d (%s)" (Nucl_number.to_int i)
-                 (Element.to_string x.Atom.element) )
           with
           | End_of_file -> failwith
                 ("Element "^(Element.to_string x.Atom.element)^" not found in basis set.")
@@ -675,7 +647,6 @@ atoms are taken from the same basis set, otherwise specific elements can be
 defined as follows:
 
  -b \"cc-pcvdz | H:cc-pvdz | C:6-31g\"
- -b \"cc-pvtz | 1,H:sto-3g | 3,H:6-31g\"
 
 If a file with the same name as the basis set exists, this file will be read.
 Otherwise, the basis set is obtained from the database.

ocaml/qptypes_generator.ml

@@ -42,8 +42,8 @@ let input_data = "
 
 * Det_number_max : int 
   assert (x > 0) ; 
-  if (x > 10000000000) then
+  if (x > 100000000) then
-    warning \"More than 10 billion determinants\";
+    warning \"More than 100 million determinants\";
 
 * States_number : int 
   assert (x > 0) ; 
@@ -140,8 +140,8 @@ let input_ezfio = "
 
 * Det_number : int
   determinants_n_det
-  1 : 10000000000
+  1 : 100000000
-  More than 10 billion of determinants
+  More than 100 million of determinants
 
 "
 ;;

plugins/CAS_SD_ZMQ/EZFIO.cfg

@@ -1,15 +1,10 @@
 [energy]
 type: double precision
-doc: Calculated CAS-SD energy
+doc: "Calculated CAS-SD energy"
 interface: ezfio
 
 [energy_pt2]
 type: double precision
-doc: Calculated selected CAS-SD energy with PT2 correction
+doc: "Calculated selected CAS-SD energy with PT2 correction"
 interface: ezfio
 
-[do_ddci]
-type: logical
-doc: If true, remove purely inactive double excitations
-interface: ezfio,provider,ocaml
-default: False

plugins/CAS_SD_ZMQ/cassd_zmq.irp.f

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

plugins/CAS_SD_ZMQ/ezfio_interface.irp.f

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

plugins/CAS_SD_ZMQ/run_selection_slave.irp.f

@@ -41,8 +41,8 @@ subroutine run_selection_slave(thread,iproc,energy)
     if (done) then
       ctask = ctask - 1
     else
-      integer :: i_generator, N
+      integer :: i_generator, i_generator_start, i_generator_max, step, N
-      read (task,*) i_generator, N
+      read (task,*) i_generator_start, i_generator_max, step, N
       if(buf%N == 0) then
         ! Only first time 
         call create_selection_buffer(N, N*2, buf)
@@ -50,7 +50,11 @@ subroutine run_selection_slave(thread,iproc,energy)
       else
         if(N /= buf%N) stop "N changed... wtf man??"
       end if
-      call select_connected(i_generator,energy,pt2,buf)
+      !print *, "psi_selectors_coef ", psi_selectors_coef(N_det_selectors-5:N_det_selectors, 1)
+      !call debug_det(psi_selectors(1,1,N_det_selectors), N_int)
+      do i_generator=i_generator_start,i_generator_max,step
+        call select_connected(i_generator,energy,pt2,buf)
+      enddo
     endif
 
     if(done .or. ctask == size(task_id)) then
@@ -111,7 +115,7 @@ subroutine push_selection_results(zmq_socket_push, pt2, b, task_id, ntask)
   if(rc /= 4*ntask) stop "push"
 
 ! Activate is zmq_socket_push is a REQ
-  rc = f77_zmq_recv( zmq_socket_push, task_id(1), ntask*4, 0)
+!  rc = f77_zmq_recv( zmq_socket_push, task_id(1), ntask*4, 0)
 end subroutine
 
 
@@ -145,7 +149,7 @@ subroutine pull_selection_results(zmq_socket_pull, pt2, val, det, N, task_id, nt
   if(rc /= 4*ntask) stop "pull"
 
 ! Activate is zmq_socket_pull is a REP
-  rc = f77_zmq_send( zmq_socket_pull, task_id(1), ntask*4, 0)
+!  rc = f77_zmq_send( zmq_socket_pull, task_id(1), ntask*4, 0)
 end subroutine
  
  

plugins/CAS_SD_ZMQ/target_pt2_ratio_cassd.irp.f

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

plugins/DDCI_selected/NEEDED_CHILDREN_MODULES

@@ -1 +1 @@
-Perturbation Selectors_full Generators_CAS Davidson Psiref_CAS
+Perturbation Selectors_full Generators_CAS Davidson

plugins/DDCI_selected/ddci.irp.f

@@ -5,7 +5,7 @@ program ddci
   
   double precision, allocatable  :: pt2(:), norm_pert(:), H_pert_diag(:),E_before(:)
   integer                        :: N_st, degree
-  N_st = N_states
+  N_st = N_states_diag
   allocate (pt2(N_st), norm_pert(N_st),H_pert_diag(N_st),E_before(N_st))
   character*(64)                 :: perturbation
   

plugins/DFT_Utils/EZFIO.cfg

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

plugins/DFT_Utils/functional.irp.f

@@ -1,54 +0,0 @@
-subroutine ex_lda(rho_a,rho_b,ex,vx_a,vx_b)
- include 'constants.include.F'
- implicit none
- double precision, intent(in) :: rho_a,rho_b
- double precision, intent(out) :: ex,vx_a,vx_b
- double precision :: tmp_a,tmp_b
- tmp_a = rho_a**(c_1_3)
- tmp_b = rho_b**(c_1_3)
- ex = cst_lda * (tmp_a*tmp_a*tmp_a*tmp_a + tmp_b*tmp_b*tmp_b*tmp_b)
- vx_a = cst_lda * c_4_3 * tmp_a
- vx_b = cst_lda * c_4_3 * tmp_b
-
-end
-
- BEGIN_PROVIDER [double precision, lda_exchange, (N_states)]
-&BEGIN_PROVIDER [double precision, lda_ex_potential_alpha_ao,(ao_num_align,ao_num,N_states)]
-&BEGIN_PROVIDER [double precision, lda_ex_potential_beta_ao,(ao_num_align,ao_num,N_states)]
-
- implicit none
- integer :: i,j,k,l
- integer :: m,n
- double precision :: aos_array(ao_num)
- double precision :: r(3)
- lda_ex_potential_alpha_ao = 0.d0
- lda_ex_potential_beta_ao = 0.d0
- do l = 1, N_states
-  lda_exchange(l) = 0.d0
-  do j = 1, nucl_num
-   do i = 1, n_points_radial_grid 
-    do k = 1, n_points_integration_angular
-     double precision :: rho_a,rho_b,ex
-     double precision :: vx_a,vx_b
-     rho_a = one_body_dm_mo_alpha_at_grid_points(k,i,j,l)
-     rho_b = one_body_dm_mo_beta_at_grid_points(k,i,j,l)
-     call ex_lda(rho_a,rho_b,ex,vx_a,vx_b) 
-     lda_exchange(l) += final_weight_functions_at_grid_points(k,i,j) * ex
-     r(1) = grid_points_per_atom(1,k,i,j) 
-     r(2) = grid_points_per_atom(2,k,i,j) 
-     r(3) = grid_points_per_atom(3,k,i,j) 
-     call give_all_aos_at_r(r,aos_array)
-     do m = 1, ao_num
-!     lda_ex_potential_ao(m,m,l) += (vx_a + vx_b) * aos_array(m)*aos_array(m)
-      do n = 1, ao_num
-       lda_ex_potential_alpha_ao(m,n,l) += (vx_a ) * aos_array(m)*aos_array(n) * final_weight_functions_at_grid_points(k,i,j)
-       lda_ex_potential_beta_ao(m,n,l) += (vx_b) * aos_array(m)*aos_array(n) * final_weight_functions_at_grid_points(k,i,j)
-      enddo
-     enddo
-    enddo
-   enddo
-  enddo
- enddo
-
-END_PROVIDER 
-

plugins/DFT_Utils/grid_density.irp.f

@@ -1,60 +1,42 @@
- BEGIN_PROVIDER [integer, n_points_integration_angular]
+BEGIN_PROVIDER [integer, n_points_angular_grid]
  implicit none
- n_points_integration_angular = 110
+ n_points_angular_grid = 50
- END_PROVIDER 
+END_PROVIDER 
 
 BEGIN_PROVIDER [integer, n_points_radial_grid]
  implicit none
- n_points_radial_grid = 100
+ n_points_radial_grid = 10000
 END_PROVIDER 
 
 
- BEGIN_PROVIDER [double precision, angular_quadrature_points, (n_points_integration_angular,3) ]
+ BEGIN_PROVIDER [double precision, angular_quadrature_points, (n_points_angular_grid,3) ]
-&BEGIN_PROVIDER [double precision, weights_angular_points, (n_points_integration_angular)]
+&BEGIN_PROVIDER [double precision, weights_angular_points, (n_points_angular_grid)]
  implicit none
  BEGIN_DOC
 ! weights and grid points for the integration on the angular variables on 
 ! the unit sphere centered on (0,0,0)
 ! According to the LEBEDEV scheme
  END_DOC
- angular_quadrature_points = 0.d0
+ call cal_quad(n_points_angular_grid, angular_quadrature_points,weights_angular_points)
- weights_angular_points = 0.d0
-!call cal_quad(n_points_integration_angular, angular_quadrature_points,weights_angular_points)
  include 'constants.include.F'
- integer :: i,n
+ integer :: i
  double precision :: accu
  double precision :: degre_rad
- degre_rad = pi/180.d0
+!degre_rad = 180.d0/pi
- accu = 0.d0
+!accu = 0.d0
- double precision :: x(n_points_integration_angular),y(n_points_integration_angular),z(n_points_integration_angular),w(n_points_integration_angular)
+!do i = 1, n_points_integration_angular_lebedev
- call LD0110(X,Y,Z,W,N)
- do i = 1, n_points_integration_angular
-  angular_quadrature_points(i,1) = x(i)
-  angular_quadrature_points(i,2) = y(i)
-  angular_quadrature_points(i,3) = z(i)
-  weights_angular_points(i) = w(i) * 4.d0 * pi
-  accu += w(i)
- enddo
-!do i = 1, n_points_integration_angular
 ! accu += weights_angular_integration_lebedev(i)
-! weights_angular_points(i) = weights_angular_integration_lebedev(i) * 4.d0 * pi
+! weights_angular_points(i) = weights_angular_integration_lebedev(i) * 2.d0 * pi
 ! angular_quadrature_points(i,1) = dcos ( degre_rad *  theta_angular_integration_lebedev(i)) & 
 !                                * dsin ( degre_rad *  phi_angular_integration_lebedev(i))
 ! angular_quadrature_points(i,2) = dsin ( degre_rad *  theta_angular_integration_lebedev(i)) & 
 !                                * dsin ( degre_rad *  phi_angular_integration_lebedev(i))
 ! angular_quadrature_points(i,3) = dcos ( degre_rad *  phi_angular_integration_lebedev(i))   
-
-!!weights_angular_points(i) = weights_angular_integration_lebedev(i)
-!!angular_quadrature_points(i,1) = dcos ( degre_rad *  phi_angular_integration_lebedev(i)) & 
-!!                               * dsin ( degre_rad *  theta_angular_integration_lebedev(i))
-!!angular_quadrature_points(i,2) = dsin ( degre_rad *  phi_angular_integration_lebedev(i)) & 
-!!                               * dsin ( degre_rad *  theta_angular_integration_lebedev(i))
-!!angular_quadrature_points(i,3) = dcos ( degre_rad *  theta_angular_integration_lebedev(i))   
 !enddo
- print*,'ANGULAR'
+!print*,'ANGULAR'
- print*,''
+!print*,''
- print*,'accu = ',accu
+!print*,'accu = ',accu
- ASSERT( dabs(accu - 1.D0) < 1.d-10)
+!ASSERT( dabs(accu - 1.D0) < 1.d-10)
 
 END_PROVIDER 
 
@@ -81,7 +63,7 @@ END_PROVIDER
 
 END_PROVIDER 
 
-BEGIN_PROVIDER [double precision, grid_points_per_atom, (3,n_points_integration_angular,n_points_radial_grid,nucl_num)]
+BEGIN_PROVIDER [double precision, grid_points_per_atom, (3,n_points_angular_grid,n_points_radial_grid,nucl_num)]
  BEGIN_DOC
 ! points for integration over space
  END_DOC
@@ -97,7 +79,7 @@ BEGIN_PROVIDER [double precision, grid_points_per_atom, (3,n_points_integration_
    double precision :: x,r
    x = grid_points_radial(j) ! x value for the mapping of the [0, +\infty] to [0,1]
    r = knowles_function(alpha_knowles(int(nucl_charge(i))),m_knowles,x) ! value of the radial coordinate for the integration 
-   do k = 1, n_points_integration_angular  ! explicit values of the grid points centered around each atom 
+   do k = 1, n_points_angular_grid  ! explicit values of the grid points centered around each atom 
     grid_points_per_atom(1,k,j,i) = x_ref + angular_quadrature_points(k,1) * r
     grid_points_per_atom(2,k,j,i) = y_ref + angular_quadrature_points(k,2) * r
     grid_points_per_atom(3,k,j,i) = z_ref + angular_quadrature_points(k,3) * r
@@ -106,7 +88,7 @@ BEGIN_PROVIDER [double precision, grid_points_per_atom, (3,n_points_integration_
  enddo
 END_PROVIDER 
 
-BEGIN_PROVIDER [double precision, weight_functions_at_grid_points, (n_points_integration_angular,n_points_radial_grid,nucl_num) ]
+BEGIN_PROVIDER [double precision, weight_functions_at_grid_points, (n_points_angular_grid,n_points_radial_grid,nucl_num) ]
  BEGIN_DOC 
 ! Weight function at grid points : w_n(r) according to the equation (22) of Becke original paper (JCP, 88, 1988)
 ! the "n" discrete variable represents the nucleis which in this array is represented by the last dimension 
@@ -120,7 +102,7 @@ BEGIN_PROVIDER [double precision, weight_functions_at_grid_points, (n_points_int
  ! run over all points in space
   do j = 1, nucl_num  ! that are referred to each atom 
    do k = 1, n_points_radial_grid -1  !for each radial grid attached to the "jth" atom
-    do l = 1, n_points_integration_angular ! for each angular point attached to the "jth" atom
+    do l = 1, n_points_angular_grid ! for each angular point attached to the "jth" atom
      r(1) = grid_points_per_atom(1,l,k,j)
      r(2) = grid_points_per_atom(2,l,k,j)
      r(3) = grid_points_per_atom(3,l,k,j)
@@ -133,6 +115,7 @@ BEGIN_PROVIDER [double precision, weight_functions_at_grid_points, (n_points_int
      enddo
      accu = 1.d0/accu
      weight_functions_at_grid_points(l,k,j) = tmp_array(j) * accu 
+!    print*,weight_functions_at_grid_points(l,k,j)
     enddo
    enddo
   enddo
@@ -140,65 +123,43 @@ BEGIN_PROVIDER [double precision, weight_functions_at_grid_points, (n_points_int
 
 END_PROVIDER 
 
-BEGIN_PROVIDER [double precision, final_weight_functions_at_grid_points, (n_points_integration_angular,n_points_radial_grid,nucl_num) ]
+ BEGIN_PROVIDER [double precision, one_body_dm_mo_alpha_at_grid_points, (n_points_angular_grid,n_points_radial_grid,nucl_num) ]
- BEGIN_DOC 
+&BEGIN_PROVIDER [double precision, one_body_dm_mo_beta_at_grid_points, (n_points_angular_grid,n_points_radial_grid,nucl_num) ]
-! Weight function at grid points : w_n(r) according to the equation (22) of Becke original paper (JCP, 88, 1988)
-! the "n" discrete variable represents the nucleis which in this array is represented by the last dimension 
-! and the points are labelled by the other dimensions
- END_DOC
  implicit none
  integer :: i,j,k,l,m
- double precision :: r(3)
- double precision :: accu,cell_function_becke
- double precision :: tmp_array(nucl_num)
- double precision :: contrib_integration,x
- double precision :: derivative_knowles_function,knowles_function
- ! run over all points in space
-  do j = 1, nucl_num  ! that are referred to each atom 
-   do i = 1, n_points_radial_grid -1  !for each radial grid attached to the "jth" atom
-    x = grid_points_radial(i) ! x value for the mapping of the [0, +\infty] to [0,1]
-    do k = 1, n_points_integration_angular ! for each angular point attached to the "jth" atom
-     contrib_integration = derivative_knowles_function(alpha_knowles(int(nucl_charge(j))),m_knowles,x) & 
-                          *knowles_function(alpha_knowles(int(nucl_charge(j))),m_knowles,x)**2          
-     final_weight_functions_at_grid_points(k,i,j) = weights_angular_points(k)  * weight_functions_at_grid_points(k,i,j) * contrib_integration * dr_radial_integral
-    enddo
-   enddo
-  enddo
-
-END_PROVIDER 
-
-
- BEGIN_PROVIDER [double precision, one_body_dm_mo_alpha_at_grid_points, (n_points_integration_angular,n_points_radial_grid,nucl_num,N_states) ]
-&BEGIN_PROVIDER [double precision, one_body_dm_mo_beta_at_grid_points, (n_points_integration_angular,n_points_radial_grid,nucl_num,N_states) ]
- implicit none
- integer :: i,j,k,l,m,i_state
  double precision :: contrib
  double precision :: r(3)
  double precision :: aos_array(ao_num),mos_array(mo_tot_num)
- do i_state = 1, N_states
   do j = 1, nucl_num
-   do k = 1, n_points_radial_grid 
+   do k = 1, n_points_radial_grid -1
-    do l = 1, n_points_integration_angular
+    do l = 1, n_points_angular_grid
-     one_body_dm_mo_alpha_at_grid_points(l,k,j,i_state) = 0.d0
+     one_body_dm_mo_alpha_at_grid_points(l,k,j) = 0.d0
-     one_body_dm_mo_beta_at_grid_points(l,k,j,i_state) = 0.d0
+     one_body_dm_mo_beta_at_grid_points(l,k,j) = 0.d0
      r(1) = grid_points_per_atom(1,l,k,j)
      r(2) = grid_points_per_atom(2,l,k,j)
      r(3) = grid_points_per_atom(3,l,k,j)
 
+!    call give_all_aos_at_r(r,aos_array)
+!    do i = 1, ao_num
+!      do m = 1, ao_num
+!       contrib = aos_array(i) * aos_array(m)
+!       one_body_dm_mo_alpha_at_grid_points(l,k,j) +=  one_body_dm_ao_alpha(i,m) * contrib
+!       one_body_dm_mo_beta_at_grid_points(l,k,j) +=  one_body_dm_ao_beta(i,m)  * contrib
+!      enddo
+!    enddo
+
      call give_all_mos_at_r(r,mos_array)
-     do m = 1, mo_tot_num
+     do i = 1, mo_tot_num
-      do i = 1, mo_tot_num
+      do m = 1, mo_tot_num
-       if(dabs(one_body_dm_mo_alpha(i,m,i_state)).lt.1.d-10)cycle
        contrib = mos_array(i) * mos_array(m)
-       one_body_dm_mo_alpha_at_grid_points(l,k,j,i_state) += one_body_dm_mo_alpha(i,m,i_state) * contrib
+       one_body_dm_mo_alpha_at_grid_points(l,k,j) += one_body_dm_mo_alpha(i,m) * contrib
-       one_body_dm_mo_beta_at_grid_points(l,k,j,i_state) += one_body_dm_mo_beta(i,m,i_state) * contrib
+       one_body_dm_mo_beta_at_grid_points(l,k,j) += one_body_dm_mo_beta(i,m) * contrib
       enddo
      enddo
 
     enddo
    enddo
   enddo
- enddo
 
 END_PROVIDER 
 

plugins/DFT_Utils/integration_3d.irp.f

@@ -4,11 +4,18 @@ double precision function step_function_becke(x)
  double precision :: f_function_becke
  integer :: i,n_max_becke
 
+!if(x.lt.-1.d0)then
+! step_function_becke = 0.d0
+!else if (x .gt.1)then
+! step_function_becke = 0.d0
+!else 
   step_function_becke = f_function_becke(x)
-  do i = 1,5
+!!n_max_becke = 1
+  do i = 1, 4
    step_function_becke = f_function_becke(step_function_becke)
   enddo
   step_function_becke = 0.5d0*(1.d0 - step_function_becke)
+!endif
 end
 
 double precision function f_function_becke(x)

plugins/DFT_Utils/integration_radial.irp.f

@@ -4,7 +4,7 @@
  double precision :: accu
  integer :: i,j,k,l
  double precision :: x
- double precision :: integrand(n_points_integration_angular), weights(n_points_integration_angular)
+ double precision :: integrand(n_points_angular_grid), weights(n_points_angular_grid)
  double precision :: f_average_angular_alpha,f_average_angular_beta
  double precision :: derivative_knowles_function,knowles_function
 
@@ -12,7 +12,7 @@
  ! according ot equation (6) of the paper of Becke (JCP, (88), 1988)
  ! Here the m index is referred to the w_m(r) weight functions of equation (22)
    ! Run over all points of integrations : there are  
-   ! n_points_radial_grid (i) * n_points_integration_angular (k) 
+   ! n_points_radial_grid (i) * n_points_angular_grid (k) 
    do j = 1, nucl_num 
     integral_density_alpha_knowles_becke_per_atom(j) = 0.d0
     integral_density_beta_knowles_becke_per_atom(j) = 0.d0
@@ -20,13 +20,14 @@
      ! Angular integration over the solid angle Omega for a FIXED angular coordinate "r"
      f_average_angular_alpha = 0.d0
      f_average_angular_beta = 0.d0
-     do k = 1, n_points_integration_angular
+     do k = 1, n_points_angular_grid
-      f_average_angular_alpha += weights_angular_points(k) * one_body_dm_mo_alpha_at_grid_points(k,i,j,1) * weight_functions_at_grid_points(k,i,j)
+      f_average_angular_alpha += weights_angular_points(k) * one_body_dm_mo_alpha_at_grid_points(k,i,j) * weight_functions_at_grid_points(k,i,j)
-      f_average_angular_beta  += weights_angular_points(k) * one_body_dm_mo_beta_at_grid_points(k,i,j,1)  * weight_functions_at_grid_points(k,i,j)
+      f_average_angular_beta  += weights_angular_points(k) * one_body_dm_mo_beta_at_grid_points(k,i,j)  * weight_functions_at_grid_points(k,i,j)
      enddo
      ! 
      x = grid_points_radial(i) ! x value for the mapping of the [0, +\infty] to [0,1]
      double precision ::  contrib_integration
+!    print*,m_knowles
      contrib_integration = derivative_knowles_function(alpha_knowles(int(nucl_charge(j))),m_knowles,x) & 
                           *knowles_function(alpha_knowles(int(nucl_charge(j))),m_knowles,x)**2          
      integral_density_alpha_knowles_becke_per_atom(j) += contrib_integration *f_average_angular_alpha

plugins/DFT_Utils/test_integration_3d_density.irp.f

@@ -4,55 +4,13 @@ program pouet
  touch read_wf
  print*,'m_knowles = ',m_knowles
  call routine
- call routine3
 
 end
-
-
-
-subroutine routine3
- implicit none
- integer :: i,j,k,l
- double precision :: accu
- accu = 0.d0
-  do j = 1, nucl_num  ! that are referred to each atom 
-   do i = 1, n_points_radial_grid -1  !for each radial grid attached to the "jth" atom
-    do k = 1, n_points_integration_angular ! for each angular point attached to the "jth" atom
-     accu += final_weight_functions_at_grid_points(k,i,j) * one_body_dm_mo_alpha_at_grid_points(k,i,j,1)
-    enddo
-   enddo
-  enddo
-  print*, accu
- print*, 'lda_exchange',lda_exchange
-
-end
-subroutine routine2
- implicit none
- integer :: i,j,k,l
- double precision :: x,y,z
- double precision :: r
- double precision :: accu 
- accu = 0.d0
- r = 1.d0
- do k = 1, n_points_integration_angular 
-  x  =  angular_quadrature_points(k,1) * r
-  y  =  angular_quadrature_points(k,2) * r
-  z  =  angular_quadrature_points(k,3) * r
-  accu += weights_angular_points(k) * (x**2 + y**2 + z**2)
- enddo
- print*, accu
-
-end
-
-
 subroutine routine
  implicit none
  integer :: i
  double precision :: accu(2)
  accu = 0.d0
- do i = 1, N_det
-  call debug_det(psi_det(1,1,i),N_int)
- enddo
  do i = 1, nucl_num
   accu(1) += integral_density_alpha_knowles_becke_per_atom(i)
   accu(2) += integral_density_beta_knowles_becke_per_atom(i)
@@ -61,18 +19,6 @@ subroutine routine
  print*,'Nalpha  = ',elec_alpha_num
  print*,'accu(2) = ',accu(2)
  print*,'Nalpha  = ',elec_beta_num
- 
- accu = 0.d0
- do i = 1, mo_tot_num
-  accu(1) += one_body_dm_mo_alpha_average(i,i)
-  accu(2) += one_body_dm_mo_beta_average(i,i)
- enddo
-
- 
- print*,'          '
- print*,'          '
- print*,'accu(1) = ',accu(1)
- print*,'accu(2) = ',accu(2)
 
 
 end

plugins/FCIdump/NEEDED_CHILDREN_MODULES

@@ -1 +1 @@
-Determinants Davidson core_integrals
+Determinants Davidson

plugins/FCIdump/fcidump.irp.f

@@ -1,25 +1,21 @@
 program fcidump
   implicit none
-  character*(128) :: output
-  integer :: i_unit_output,getUnitAndOpen
-  output=trim(ezfio_filename)//'.FCIDUMP'
-  i_unit_output = getUnitAndOpen(output,'w')
 
   integer :: i,j,k,l
-  integer :: i1,j1,k1,l1
+  integer :: ii(8), jj(8), kk(8),ll(8)
-  integer :: i2,j2,k2,l2
   integer*8 :: m
   character*(2), allocatable :: A(:)
 
-  write(i_unit_output,*) '&FCI NORB=', n_act_orb, ', NELEC=', elec_num-n_core_orb*2, &
+  print *, '&FCI NORB=', mo_tot_num, ', NELEC=', elec_num, &
    ', MS2=', (elec_alpha_num-elec_beta_num), ','
-  allocate (A(n_act_orb))
+  allocate (A(mo_tot_num))
   A = '1,'
-  write(i_unit_output,*) 'ORBSYM=', (A(i), i=1,n_act_orb) 
+  print *, 'ORBSYM=', (A(i), i=1,mo_tot_num) 
-  write(i_unit_output,*) 'ISYM=0,'
+  print *,'ISYM=0,'
-  write(i_unit_output,*) '/'
+  print *,'/'
   deallocate(A)
   
+  integer*8 :: i8, k1
   integer(key_kind), allocatable :: keys(:)
   double precision, allocatable  :: values(:)
   integer(cache_map_size_kind)   :: n_elements, n_elements_max
@@ -27,18 +23,14 @@ program fcidump
 
   double precision :: get_mo_bielec_integral, integral
 
-  do l=1,n_act_orb
+  do l=1,mo_tot_num
-   l1 = list_act(l)
+   do k=1,mo_tot_num
-   do k=1,n_act_orb
+    do j=l,mo_tot_num
-    k1 = list_act(k)
+     do i=k,mo_tot_num
-    do j=l,n_act_orb
+       if (i>=j) then
-     j1 = list_act(j)
+          integral = get_mo_bielec_integral(i,j,k,l,mo_integrals_map)
-     do i=k,n_act_orb
-      i1 = list_act(i)
-       if (i1>=j1) then
-          integral = get_mo_bielec_integral(i1,j1,k1,l1,mo_integrals_map)
           if (dabs(integral) > mo_integrals_threshold) then 
-            write(i_unit_output,*) integral, i,k,j,l
+            print *, integral, i,k,j,l
           endif
        end if
      enddo
@@ -46,15 +38,13 @@ program fcidump
    enddo
   enddo
 
-  do j=1,n_act_orb
+  do j=1,mo_tot_num
-   j1 = list_act(j)
+   do i=j,mo_tot_num
-   do i=j,n_act_orb
+      integral = mo_mono_elec_integral(i,j)
-    i1 = list_act(i)
-      integral = mo_mono_elec_integral(i1,j1) + core_fock_operator(i1,j1)
       if (dabs(integral) > mo_integrals_threshold) then 
-        write(i_unit_output,*) integral, i,j,0,0
+        print *, integral, i,j,0,0
       endif
    enddo
   enddo
-  write(i_unit_output,*) core_energy, 0, 0, 0, 0
+  print *, 0.d0, 0, 0, 0, 0
 end

plugins/FOBOCI/NEEDED_CHILDREN_MODULES

@@ -1 +1 @@
-Perturbation Selectors_no_sorted SCF_density Davidson CISD
+Perturbation Selectors_no_sorted Hartree_Fock Davidson CISD

plugins/FOBOCI/SC2_1h1p.irp.f

@@ -356,7 +356,7 @@ subroutine dressing_1h1p_by_2h2p(dets_in,u_in,diag_H_elements,dim_in,sze,N_st,Ni
   c_ref = 1.d0/u_in(index_hf,1)
   do k = 1, n_singles
    l = index_singles(k)
-   diag_H_elements(1) -= diag_H_elements(l)
+   diag_H_elements(0) -= diag_H_elements(l)
   enddo
 ! do k = 1, n_doubles
 !  l = index_doubles(k)

plugins/FOBOCI/all_singles.irp.f

@@ -48,7 +48,6 @@ subroutine all_single(e_pt2)
     print*,'-----------------------'
     print*,'i = ',i
     call H_apply_just_mono(pt2, norm_pert, H_pert_diag,  N_st)
-    call make_s2_eigenfunction_first_order
     call diagonalize_CI
     print*,'N_det = ',N_det
     print*,'E        = ',CI_energy(1)

plugins/FOBOCI/create_1h_or_1p.irp.f

@@ -29,13 +29,21 @@ subroutine create_restart_and_1h(i_hole)
     enddo
    enddo
   enddo
- 
 
  integer :: N_det_old
  N_det_old = N_det
-
+ N_det += n_new_det
- logical, allocatable :: duplicate(:)
+ allocate (new_det(N_int,2,n_new_det))
- allocate (new_det(N_int,2,n_new_det),duplicate(n_new_det))
+ if (psi_det_size < N_det) then
+   psi_det_size = N_det
+   TOUCH psi_det_size
+ endif
+ do i = 1, N_det_old 
+  do k = 1, N_int
+   psi_det(k,1,i) = old_psi_det(k,1,i)
+   psi_det(k,2,i) = old_psi_det(k,2,i)
+  enddo
+ enddo
 
  n_new_det = 0
   do j = 1, n_act_orb
@@ -50,56 +58,19 @@ subroutine create_restart_and_1h(i_hole)
      if(i_ok .ne. 1)cycle
      n_new_det +=1
      do k = 1, N_int
-      new_det(k,1,n_new_det) = key_tmp(k,1) 
+      psi_det(k,1,n_det_old+n_new_det) = key_tmp(k,1) 
-      new_det(k,2,n_new_det) = key_tmp(k,2) 
+      psi_det(k,2,n_det_old+n_new_det) = key_tmp(k,2) 
      enddo
+     psi_coef(n_det_old+n_new_det,:) = 0.d0
     enddo
    enddo
   enddo
 
- integer :: i_test
- duplicate = .False. 
- do i = 1, n_new_det
-  if(duplicate(i))cycle
-  do j = i+1, n_new_det
-   i_test = 0
-   do ispin =1 ,2
-    do k = 1, N_int
-     i_test += popcnt(xor(new_det(k,ispin,i),new_det(k,ispin,j)))
-    enddo
-   enddo
-   if(i_test.eq.0)then
-    duplicate(j) = .True.
-   endif
-  enddo
- enddo
-
- integer :: n_new_det_unique
- n_new_det_unique = 0
- print*, 'uniq det'
- do i = 1, n_new_det
-  if(.not.duplicate(i))then
-   n_new_det_unique += 1
-  endif
- enddo
- print*, n_new_det_unique
- N_det += n_new_det_unique
- if (psi_det_size < N_det) then
-   psi_det_size = N_det
-   TOUCH psi_det_size
- endif
- do i = 1, n_new_det_unique
-  do ispin = 1, 2
-   do k = 1, N_int
-    psi_det(k,ispin,N_det_old+i) = new_det(k,ispin,i)
-   enddo
-  enddo
-  psi_coef(N_det_old+i,:) = 0.d0
- enddo
-
-
   SOFT_TOUCH N_det psi_det psi_coef
-  deallocate (new_det,duplicate)
+  logical :: found_duplicates
+  if(n_act_orb.gt.1)then
+  call remove_duplicates_in_psi_det(found_duplicates)
+  endif
 end
 
 subroutine create_restart_and_1p(i_particle)
@@ -136,8 +107,18 @@ subroutine create_restart_and_1p(i_particle)
 
  integer :: N_det_old
  N_det_old = N_det
- logical, allocatable :: duplicate(:)
+ N_det += n_new_det
- allocate (new_det(N_int,2,n_new_det),duplicate(n_new_det))
+ allocate (new_det(N_int,2,n_new_det))
+ if (psi_det_size < N_det) then
+   psi_det_size = N_det
+   TOUCH psi_det_size
+ endif
+ do i = 1, N_det_old 
+  do k = 1, N_int
+   psi_det(k,1,i) = old_psi_det(k,1,i)
+   psi_det(k,2,i) = old_psi_det(k,2,i)
+  enddo
+ enddo
 
  n_new_det = 0
   do j = 1, n_act_orb
@@ -152,59 +133,17 @@ subroutine create_restart_and_1p(i_particle)
      if(i_ok .ne. 1)cycle
      n_new_det +=1
      do k = 1, N_int
-      new_det(k,1,n_new_det) = key_tmp(k,1) 
+      psi_det(k,1,n_det_old+n_new_det) = key_tmp(k,1) 
-      new_Det(k,2,n_new_det) = key_tmp(k,2) 
+      psi_det(k,2,n_det_old+n_new_det) = key_tmp(k,2) 
      enddo
+     psi_coef(n_det_old+n_new_det,:) = 0.d0
     enddo
    enddo
   enddo
 
- integer :: i_test
- duplicate = .False. 
- do i = 1, n_new_det
-  if(duplicate(i))cycle
-  call debug_det(new_det(1,1,i),N_int)
-  do j = i+1, n_new_det
-   i_test = 0
-   call debug_det(new_det(1,1,j),N_int)
-   do ispin =1 ,2
-    do k = 1, N_int
-     i_test += popcnt(xor(new_det(k,ispin,i),new_det(k,ispin,j)))
-    enddo
-   enddo
-   if(i_test.eq.0)then
-    duplicate(j) = .True.
-   endif
-  enddo
- enddo
-
- integer :: n_new_det_unique
- n_new_det_unique = 0
- print*, 'uniq det'
- do i = 1, n_new_det
-  if(.not.duplicate(i))then
-   n_new_det_unique += 1
-  endif
- enddo
- print*, n_new_det_unique
-
- N_det += n_new_det_unique
- if (psi_det_size < N_det) then
-   psi_det_size = N_det
-   TOUCH psi_det_size
- endif
- do i = 1, n_new_det_unique
-  do ispin = 1, 2
-   do k = 1, N_int
-    psi_det(k,ispin,N_det_old+i) = new_det(k,ispin,i)
-   enddo
-  enddo
-  psi_coef(N_det_old+i,:) = 0.d0
- enddo
-
   SOFT_TOUCH N_det psi_det psi_coef
-  deallocate (new_det,duplicate)
+  logical :: found_duplicates
-
+  call remove_duplicates_in_psi_det(found_duplicates)
 end
 
 subroutine create_restart_1h_1p(i_hole,i_part)

plugins/FOBOCI/density.irp.f

@@ -1,16 +0,0 @@
-BEGIN_PROVIDER [double precision, mo_general_density_alpha, (mo_tot_num_align,mo_tot_num)]
- implicit none
- integer  :: i,j,k,l
- mo_general_density_alpha =  one_body_dm_mo_alpha_generators_restart
-
-END_PROVIDER
-
-
-BEGIN_PROVIDER [double precision, mo_general_density_beta, (mo_tot_num_align,mo_tot_num)]
- implicit none
- integer  :: i,j,k,l
- mo_general_density_beta =  one_body_dm_mo_beta_generators_restart
-
-END_PROVIDER
-
-

plugins/FOBOCI/density_matrix.irp.f

@@ -1,12 +1,12 @@
  BEGIN_PROVIDER [ double precision, one_body_dm_mo_alpha_generators_restart, (mo_tot_num_align,mo_tot_num) ]
 &BEGIN_PROVIDER [ double precision, one_body_dm_mo_beta_generators_restart, (mo_tot_num_align,mo_tot_num) ]
-&BEGIN_PROVIDER [ double precision, norm_generators_restart, (N_states)]
+&BEGIN_PROVIDER [ double precision, norm_generators_restart]
    implicit none
    BEGIN_DOC
    ! Alpha and beta one-body density matrix for the generators restart
    END_DOC
 
-   integer                        :: j,k,l,m,istate
+   integer                        :: j,k,l,m
    integer                        :: occ(N_int*bit_kind_size,2)
    double precision               :: ck, cl, ckl
    double precision               :: phase
@@ -14,37 +14,23 @@
    integer                        :: exc(0:2,2,2),n_occ_alpha
    double precision, allocatable  :: tmp_a(:,:), tmp_b(:,:)
    integer :: degree_respect_to_HF_k
-   integer :: degree_respect_to_HF_l,index_ref_generators_restart(N_states)
+   integer :: degree_respect_to_HF_l,index_ref_generators_restart
-   double precision :: inv_coef_ref_generators_restart(N_states)
+   double precision :: inv_coef_ref_generators_restart
    integer :: i
-   print*, 'providing the one_body_dm_mo_alpha_generators_restart'
 
-   do istate = 1, N_states
+   do i = 1, N_det_generators_restart
-    do i = 1, N_det_generators_restart
+    ! Find the reference determinant for intermediate normalization
-     ! Find the reference determinant for intermediate normalization
+    call get_excitation_degree(ref_generators_restart,psi_det_generators_restart(1,1,i),degree,N_int)   
-     call get_excitation_degree(ref_generators_restart(1,1,istate),psi_det_generators_restart(1,1,i),degree,N_int)   
+    if(degree == 0)then
-     if(degree == 0)then
+     index_ref_generators_restart = i
-      index_ref_generators_restart(istate) = i
+     inv_coef_ref_generators_restart = 1.d0/psi_coef_generators_restart(i,1)
-      inv_coef_ref_generators_restart(istate) = 1.d0/psi_coef_generators_restart(i,istate)
+     exit
-      exit
+    endif
-     endif
-    enddo
    enddo
    norm_generators_restart = 0.d0
-   do istate = 1, N_states
+   do i = 1, N_det_generators_restart
-    do i = 1, N_det_generators_restart
+    psi_coef_generators_restart(i,1) = psi_coef_generators_restart(i,1) * inv_coef_ref_generators_restart
-     psi_coef_generators_restart(i,istate) = psi_coef_generators_restart(i,istate) * inv_coef_ref_generators_restart(istate)
+    norm_generators_restart += psi_coef_generators_restart(i,1)**2
-     norm_generators_restart(istate) += psi_coef_generators_restart(i,istate)**2
-    enddo
-   enddo
-   double precision :: inv_norm(N_States)
-   do istate = 1, N_states
-    inv_norm(istate) = 1.d0/dsqrt(norm_generators_restart(istate))
-   enddo
-   do istate = 1, N_states
-    do i = 1, N_det_generators_restart
-     psi_coef_generators_restart(i,istate) = psi_coef_generators_restart(i,istate)  * inv_norm(istate)
-    enddo
    enddo
 
 

plugins/FOBOCI/dress_simple.irp.f

@@ -107,6 +107,7 @@ subroutine is_a_good_candidate(threshold,is_ok,e_pt2,verbose,exit_loop,is_ok_per
 !enddo
 !soft_touch psi_selectors psi_selectors_coef 
 !if(do_it_perturbative)then
+   print*, 'is_ok_perturbative',is_ok_perturbative
   if(is_ok.or.is_ok_perturbative)then
    N_det = N_det_generators
    do m = 1, N_states
@@ -116,6 +117,7 @@ subroutine is_a_good_candidate(threshold,is_ok,e_pt2,verbose,exit_loop,is_ok_per
        psi_det(l,2,k) = psi_det_generators_input(l,2,k) 
      enddo
      psi_coef(k,m) = psi_coef_diagonalized_tmp(k,m)
+     print*, 'psi_coef(k,m)',psi_coef(k,m)
     enddo
    enddo
    soft_touch psi_det psi_coef  N_det
@@ -148,7 +150,7 @@ subroutine dress_H_matrix_from_psi_det_input(psi_det_generators_input,Ndet_gener
  double precision, intent(inout) :: dressed_H_matrix(Ndet_generators, Ndet_generators)
 
  
- integer :: i,j,degree,index_ref_generators_restart(N_states),i_count,k,i_det_no_ref
+ integer :: i,j,degree,index_ref_generators_restart,i_count,k,i_det_no_ref
  double precision :: eigvalues(Ndet_generators), eigvectors(Ndet_generators,Ndet_generators),hij
  double precision :: psi_coef_ref(Ndet_generators,N_states),diag_h_mat_average,diag_h_mat_no_ref_average
  logical :: is_a_ref_det(Ndet_generators)
@@ -166,17 +168,11 @@ subroutine dress_H_matrix_from_psi_det_input(psi_det_generators_input,Ndet_gener
  enddo
 
 
- integer :: istate
- do istate = 1, N_states
-  do i = 1, Ndet_generators 
-   call get_excitation_degree(ref_generators_restart(1,1,istate),psi_det_generators_input(1,1,i),degree,N_int)
-   if(degree == 0)then
-    index_ref_generators_restart(istate) = i
-    exit
-   endif
-  enddo
- enddo
  do i = 1, Ndet_generators 
+  call get_excitation_degree(ref_generators_restart,psi_det_generators_input(1,1,i),degree,N_int)
+  if(degree == 0)then
+   index_ref_generators_restart = i
+  endif
   do j = 1, Ndet_generators
    call i_h_j(psi_det_generators_input(1,1,j),psi_det_generators_input(1,1,i),N_int,hij)  ! Fill the zeroth order H matrix
    dressed_H_matrix(i,j) = hij
@@ -189,21 +185,15 @@ subroutine dress_H_matrix_from_psi_det_input(psi_det_generators_input,Ndet_gener
   i_det_no_ref +=1
   diag_h_mat_average+=dressed_H_matrix(i,i)
  enddo
- double precision :: average_ref_h_mat
- average_ref_h_mat = 0.d0
- do istate = 1, N_states
-  average_ref_h_mat += dressed_H_matrix(index_ref_generators_restart(istate),index_ref_generators_restart(istate))
- enddo
- average_ref_h_mat = 1.d0/dble(N_states)
  diag_h_mat_average = diag_h_mat_average/dble(i_det_no_ref)
  print*,'diag_h_mat_average = ',diag_h_mat_average
- print*,'ref  h_mat average = ',average_ref_h_mat
+ print*,'ref  h_mat         = ',dressed_H_matrix(index_ref_generators_restart,index_ref_generators_restart)
  integer :: number_of_particles, number_of_holes 
  ! Filter the the MLCT that are higher than 27.2 eV in energy with respect to the reference determinant
  do i = 1, Ndet_generators 
   if(is_a_ref_det(i))cycle
   if(number_of_holes(psi_det_generators_input(1,1,i)).eq.0 .and. number_of_particles(psi_det_generators_input(1,1,i)).eq.1)then
-   if(diag_h_mat_average - average_ref_h_mat .gt.2.d0)then
+   if(diag_h_mat_average - dressed_H_matrix(index_ref_generators_restart,index_ref_generators_restart) .gt.2.d0)then
     is_ok = .False.
     exit_loop = .True.
     return
@@ -212,7 +202,7 @@ subroutine dress_H_matrix_from_psi_det_input(psi_det_generators_input,Ndet_gener
  
   ! Filter the the LMCT that are higher than 54.4 eV in energy with respect to the reference determinant
   if(number_of_holes(psi_det_generators_input(1,1,i)).eq.1 .and. number_of_particles(psi_det_generators_input(1,1,i)).eq.0)then
-   if(diag_h_mat_average - average_ref_h_mat .gt.1.d0)then
+   if(diag_h_mat_average - dressed_H_matrix(index_ref_generators_restart,index_ref_generators_restart) .gt.2.d0)then
     is_ok = .False.
     return
    endif
@@ -220,7 +210,7 @@ subroutine dress_H_matrix_from_psi_det_input(psi_det_generators_input,Ndet_gener
   exit
  enddo
 
- call lapack_diagd(eigvalues,eigvectors,dressed_H_matrix,Ndet_generators,Ndet_generators)  ! Diagonalize the naked matrix
+ call lapack_diagd(eigvalues,eigvectors,dressed_H_matrix,Ndet_generators,Ndet_generators)  ! Diagonalize the Dressed_H_matrix
  
  double precision :: s2(N_det_generators),E_ref(N_states)
  integer :: i_state(N_states)
@@ -246,10 +236,15 @@ subroutine dress_H_matrix_from_psi_det_input(psi_det_generators_input,Ndet_gener
    E_ref(i) = eigvalues(i)
   enddo
  endif
+ do i = 1,N_states
+  print*,'i_state = ',i_state(i)
+ enddo
  do k = 1, N_states
+  print*,'state ',k
   do i = 1, Ndet_generators
-   psi_coef_diagonalized_tmp(i,k) = eigvectors(i,i_state(k)) / eigvectors(index_ref_generators_restart(k),i_state(k))
+   psi_coef_diagonalized_tmp(i,k) = eigvectors(i,i_state(k)) / eigvectors(index_ref_generators_restart,i_state(k))
    psi_coef_ref(i,k) = eigvectors(i,i_state(k))
+   print*,'psi_coef_ref(i) = ',psi_coef_ref(i,k)
   enddo
  enddo
  if(verbose)then
@@ -262,7 +257,7 @@ subroutine dress_H_matrix_from_psi_det_input(psi_det_generators_input,Ndet_gener
   do k = 1, N_states
    print*,'state ',k
    do i = 1, Ndet_generators
-    print*,'coef, <I|H|I> = ',psi_coef_diagonalized_tmp(i,k),dressed_H_matrix(i,i)-dressed_H_matrix(index_ref_generators_restart(k),index_ref_generators_restart(k)),is_a_ref_det(i)
+    print*,'coef, <I|H|I> = ',psi_coef_diagonalized_tmp(i,k),dressed_H_matrix(i,i)-dressed_H_matrix(index_ref_generators_restart,index_ref_generators_restart),is_a_ref_det(i)
    enddo
   enddo
  endif
@@ -283,20 +278,18 @@ subroutine dress_H_matrix_from_psi_det_input(psi_det_generators_input,Ndet_gener
  call lapack_diagd(eigvalues,eigvectors,dressed_H_matrix,Ndet_generators,Ndet_generators)  ! Diagonalize the Dressed_H_matrix
  integer :: i_good_state(0:N_states)
  i_good_state(0) = 0
-  do k = 1, N_states 
+  do i = 1, Ndet_generators
-!  print*,'state',k
-   do i = 1, Ndet_generators
     ! State following
+    do k = 1, N_states 
      accu = 0.d0
      do j =1, Ndet_generators
+      print*,'',eigvectors(j,i) , psi_coef_ref(j,k)
       accu += eigvectors(j,i) * psi_coef_ref(j,k)
      enddo
-!    print*,i,accu
+     print*,'accu = ',accu
-     if(dabs(accu).ge.0.60d0)then
+     if(dabs(accu).ge.0.72d0)then
       i_good_state(0) +=1
       i_good_state(i_good_state(0)) = i
-      print*, 'state, ovrlap',k,i,accu
-      exit
      endif
     enddo
     if(i_good_state(0)==N_states)then
@@ -311,14 +304,14 @@ subroutine dress_H_matrix_from_psi_det_input(psi_det_generators_input,Ndet_gener
  accu = 0.d0
  do k = 1, N_states
   do i = 1, Ndet_generators
-   psi_coef_diagonalized_tmp(i,k) = eigvectors(i,i_state(k)) / eigvectors(index_ref_generators_restart(k),i_state(k))
+   psi_coef_diagonalized_tmp(i,k) = eigvectors(i,i_state(k)) / eigvectors(index_ref_generators_restart,i_state(k))
   enddo
  enddo
  if(verbose)then
   do k = 1, N_states
    print*,'state ',k
    do i = 1, Ndet_generators
-    print*,'coef, <I|H+Delta H|I> = ',psi_coef_diagonalized_tmp(i,k),dressed_H_matrix(i,i)-dressed_H_matrix(index_ref_generators_restart(k),index_ref_generators_restart(k)),is_a_ref_det(i)
+    print*,'coef, <I|H+Delta H|I> = ',psi_coef_diagonalized_tmp(i,k),dressed_H_matrix(i,i)-dressed_H_matrix(index_ref_generators_restart,index_ref_generators_restart),is_a_ref_det(i)
    enddo
   enddo
  endif
@@ -340,7 +333,7 @@ subroutine dress_H_matrix_from_psi_det_input(psi_det_generators_input,Ndet_gener
   do i = 1, Ndet_generators
    if(is_a_ref_det(i))cycle
    do k = 1, N_states
-!   print*, psi_coef_diagonalized_tmp(i,k),threshold_perturbative
+    print*, psi_coef_diagonalized_tmp(i,k),threshold_perturbative
     if(dabs(psi_coef_diagonalized_tmp(i,k)) .gt.threshold_perturbative)then
      is_ok_perturbative = .False.
      exit

plugins/FOBOCI/fobo_scf.irp.f

@@ -15,6 +15,8 @@ end
 
 subroutine run_prepare
  implicit none
+! no_oa_or_av_opt = .False.
+! touch no_oa_or_av_opt
   call damping_SCF
   call diag_inactive_virt_and_update_mos
 end
@@ -26,8 +28,7 @@ subroutine routine_fobo_scf
  print*,''
  character*(64) :: label
  label = "Natural"
- do i = 1, 10
+ do i = 1, 5
-  call initialize_mo_coef_begin_iteration
   print*,'*******************************************************************************'
   print*,'*******************************************************************************'
   print*,'FOBO-SCF Iteration ',i
@@ -55,8 +56,6 @@ subroutine routine_fobo_scf
   call save_osoci_natural_mos
   call damping_SCF
   call diag_inactive_virt_and_update_mos
-  call reorder_active_orb
-  call save_mos
   call clear_mo_map
   call provide_properties
  enddo

plugins/FOBOCI/foboci_lmct_mlct_threshold_old.irp.f

@@ -40,13 +40,11 @@ subroutine FOBOCI_lmct_mlct_old_thr(iter)
  logical :: lmct
  double precision, allocatable :: psi_singles_coef(:,:)
  logical :: exit_loop
- call update_generators_restart_coef
  allocate( zero_bitmask(N_int,2) )
   do i = 1, n_inact_orb
    lmct = .True.
    integer :: i_hole_osoci
    i_hole_osoci = list_inact(i)
-!  if(i_hole_osoci.ne.26)cycle
    print*,'--------------------------'
    ! First set the current generators to the one of restart
    call check_symetry(i_hole_osoci,thr,test_sym)
@@ -56,6 +54,7 @@ subroutine FOBOCI_lmct_mlct_old_thr(iter)
    print*,'i_hole_osoci = ',i_hole_osoci
    call create_restart_and_1h(i_hole_osoci)
    call set_generators_to_psi_det
+   print*,'Passed set generators'
    call set_bitmask_particl_as_input(reunion_of_bitmask)
    call set_bitmask_hole_as_input(reunion_of_bitmask)
    double precision :: e_pt2
@@ -83,10 +82,10 @@ subroutine FOBOCI_lmct_mlct_old_thr(iter)
      call set_bitmask_particl_as_input(reunion_of_bitmask)
      call set_bitmask_hole_as_input(reunion_of_bitmask)
      call all_single(e_pt2)
-!    call make_s2_eigenfunction_first_order
+     call make_s2_eigenfunction_first_order
-!    threshold_davidson = 1.d-6
+     threshold_davidson = 1.d-6
-!    soft_touch threshold_davidson davidson_criterion
+     soft_touch threshold_davidson davidson_criterion
-!    call diagonalize_ci
+     call diagonalize_ci
     double precision :: hkl
     call provide_matrix_dressing(dressing_matrix,n_det_generators,psi_det_generators)
     hkl = dressing_matrix(1,1)
@@ -119,7 +118,6 @@ subroutine FOBOCI_lmct_mlct_old_thr(iter)
    do i = 1, n_virt_orb
     integer :: i_particl_osoci
     i_particl_osoci = list_virt(i)
-!   cycle
 
     print*,'--------------------------'
     ! First set the current generators to the one of restart
@@ -154,11 +152,11 @@ subroutine FOBOCI_lmct_mlct_old_thr(iter)
        enddo
       enddo
       call all_single(e_pt2)
-!     call make_s2_eigenfunction_first_order
+      call make_s2_eigenfunction_first_order
-!     threshold_davidson = 1.d-6
+      threshold_davidson = 1.d-6
-!     soft_touch threshold_davidson davidson_criterion
+      soft_touch threshold_davidson davidson_criterion
-!    
+     
-!     call diagonalize_ci
+      call diagonalize_ci
       deallocate(dressing_matrix)
     else
      if(exit_loop)then
@@ -543,6 +541,7 @@ subroutine FOBOCI_lmct_mlct_old_thr_restart(iter)
      call print_generators_bitmasks_holes
      ! Impose that only the active part can be reached 
      call set_bitmask_hole_as_input(unpaired_bitmask)
+!!!  call all_single_h_core
      call create_restart_and_1p(i_particl_osoci)
 !!!  ! Update the generators 
      call set_generators_to_psi_det

plugins/FOBOCI/generators_restart_save.irp.f

@@ -21,19 +21,23 @@ END_PROVIDER
 
 
  BEGIN_PROVIDER [ integer(bit_kind), psi_det_generators_restart, (N_int,2,N_det_generators_restart) ]
-&BEGIN_PROVIDER [ integer(bit_kind), ref_generators_restart, (N_int,2,N_states) ]
+&BEGIN_PROVIDER [ integer(bit_kind), ref_generators_restart, (N_int,2) ]
 &BEGIN_PROVIDER [ double precision, psi_coef_generators_restart, (N_det_generators_restart,N_states) ]
  implicit none
  BEGIN_DOC
  ! read wf
  ! 
  END_DOC
- integer                        :: i, k,j
+ integer                        :: i, k
  integer, save :: ifirst = 0
  double precision, allocatable  :: psi_coef_read(:,:)
  print*, ' Providing psi_det_generators_restart'
  if(ifirst == 0)then
   call read_dets(psi_det_generators_restart,N_int,N_det_generators_restart)
+   do k = 1, N_int
+    ref_generators_restart(k,1) = psi_det_generators_restart(k,1,1)
+    ref_generators_restart(k,2) = psi_det_generators_restart(k,2,1)
+   enddo
    allocate (psi_coef_read(N_det_generators_restart,N_states))
    call ezfio_get_determinants_psi_coef(psi_coef_read)
    do k = 1, N_states
@@ -41,18 +45,6 @@ END_PROVIDER
      psi_coef_generators_restart(i,k) = psi_coef_read(i,k)
     enddo
    enddo
-   do k = 1, N_states
-    do i = 1, N_det_generators_restart
-     if(dabs(psi_coef_generators_restart(i,k)).gt.0.5d0)then
-      do j = 1, N_int
-       ref_generators_restart(j,1,k) = psi_det_generators_restart(j,1,i)
-       ref_generators_restart(j,2,k) = psi_det_generators_restart(j,2,i)
-      enddo
-      exit
-     endif
-    enddo
-    call debug_det(ref_generators_restart(1,1,k),N_int)
-   enddo
   ifirst = 1
   deallocate(psi_coef_read)
  else 
@@ -82,18 +74,3 @@ END_PROVIDER
 &BEGIN_PROVIDER [ double precision, psi_coef_generators, (10000,N_states) ]
 
 END_PROVIDER
-
-subroutine update_generators_restart_coef
- implicit none 
- call set_generators_to_generators_restart
- call set_psi_det_to_generators
- call diagonalize_CI
- integer :: i,j,k,l
- do i = 1, N_det_generators_restart
-   do j = 1, N_states
-    psi_coef_generators_restart(i,j) = psi_coef(i,j)
-   enddo
- enddo
- soft_touch psi_coef_generators_restart
- provide one_body_dm_mo_alpha_generators_restart
-end

plugins/FOBOCI/routines_foboci.irp.f

@@ -2,7 +2,7 @@ subroutine set_intermediate_normalization_lmct_old(norm,i_hole)
  implicit none
  integer, intent(in) :: i_hole
  double precision, intent(out) :: norm(N_states)
- integer :: i,j,degree,index_ref_generators_restart(N_states),k
+ integer :: i,j,degree,index_ref_generators_restart,k
  integer::  number_of_holes,n_h, number_of_particles,n_p
  integer, allocatable :: index_one_hole(:),index_one_hole_one_p(:),index_two_hole_one_p(:),index_two_hole(:)
  integer, allocatable :: index_one_p(:)
@@ -13,8 +13,6 @@ subroutine set_intermediate_normalization_lmct_old(norm,i_hole)
  integer :: n_good_hole
  logical,allocatable :: is_a_ref_det(:)
  allocate(index_one_hole(n_det),index_one_hole_one_p(n_det),index_two_hole_one_p(N_det),index_two_hole(N_det),index_one_p(N_det),is_a_ref_det(N_det))
- double precision, allocatable :: local_norm(:)
- allocate(local_norm(N_states))
  
  n_one_hole = 0
  n_one_hole_one_p = 0
@@ -24,18 +22,17 @@ subroutine set_intermediate_normalization_lmct_old(norm,i_hole)
  n_good_hole = 0
  ! Find the one holes and one hole one particle
  is_a_ref_det = .False.
- integer :: istate
- do istate = 1, N_States
-  do i = 1, N_det
-   ! Find the reference determinant for intermediate normalization
-   call get_excitation_degree(ref_generators_restart(1,1,istate),psi_det(1,1,i),degree,N_int)   
-   if(degree == 0)then
-    index_ref_generators_restart(istate) = i
-    inv_coef_ref_generators_restart(istate) = 1.d0/psi_coef(i,istate)
-   endif
-  enddo
- enddo
  do i = 1, N_det
+  ! Find the reference determinant for intermediate normalization
+  call get_excitation_degree(ref_generators_restart,psi_det(1,1,i),degree,N_int)   
+  if(degree == 0)then
+   index_ref_generators_restart = i
+   do k = 1, N_states
+    inv_coef_ref_generators_restart(k) = 1.d0/psi_coef(i,k)
+   enddo
+!  cycle
+  endif
+  
   ! Find all the determinants present in the reference wave function
   do j = 1, N_det_generators_restart
    call get_excitation_degree(psi_det(1,1,i),psi_det_generators_restart(1,1,j),degree,N_int)  
@@ -62,48 +59,40 @@ subroutine set_intermediate_normalization_lmct_old(norm,i_hole)
    enddo
   endif
  enddo
-
+!do k = 1, N_det
-
+! call debug_det(psi_det(1,1,k),N_int)
+! print*,'k,coef = ',k,psi_coef(k,1)/psi_coef(index_ref_generators_restart,1)
+!enddo
  print*,''
  print*,'n_good_hole = ',n_good_hole
  do k = 1,N_states
   print*,'state ',k
   do i = 1, n_good_hole
-   print*,'psi_coef(index_good_hole) = ',psi_coef(index_good_hole(i),k)/psi_coef(index_ref_generators_restart(k),k)
+   print*,'psi_coef(index_good_hole) = ',psi_coef(index_good_hole(i),k)/psi_coef(index_ref_generators_restart,k)
   enddo
   print*,''
  enddo
+ norm = 0.d0
 
- ! Set the wave function to the intermediate normalization 
+ ! Set the wave function to the intermediate normalization
  do k = 1, N_states
   do i = 1, N_det
    psi_coef(i,k) = psi_coef(i,k) * inv_coef_ref_generators_restart(k)
   enddo
  enddo
-
-
- norm = 0.d0
  do k = 1,N_states
   print*,'state ',k
   do i = 1, N_det
+!!  print*,'psi_coef(i_ref) = ',psi_coef(i,1)
    if (is_a_ref_det(i))then
     print*,'i,psi_coef_ref = ',psi_coef(i,k)
+    cycle
    endif
    norm(k) += psi_coef(i,k) * psi_coef(i,k)
   enddo
   print*,'norm = ',norm(k)
  enddo
- do k =1, N_states
-  local_norm(k) = 1.d0 / dsqrt(norm(k))
- enddo
- do k = 1,N_states
-  do i = 1, N_det
-   psi_coef(i,k) = psi_coef(i,k) * local_norm(k)
-  enddo
- enddo
- 
  deallocate(index_one_hole,index_one_hole_one_p,index_two_hole_one_p,index_two_hole,index_one_p,is_a_ref_det)
- deallocate(local_norm)
  soft_touch psi_coef
 end
 
@@ -112,7 +101,7 @@ subroutine set_intermediate_normalization_mlct_old(norm,i_particl)
  implicit none
  integer, intent(in) :: i_particl
  double precision, intent(out) :: norm(N_states)
- integer :: i,j,degree,index_ref_generators_restart(N_states),k
+ integer :: i,j,degree,index_ref_generators_restart,k
  integer::  number_of_holes,n_h, number_of_particles,n_p
  integer, allocatable :: index_one_hole(:),index_one_hole_one_p(:),index_two_hole_one_p(:),index_two_hole(:)
  integer, allocatable :: index_one_p(:),index_one_hole_two_p(:)
@@ -128,8 +117,6 @@ subroutine set_intermediate_normalization_mlct_old(norm,i_particl)
  integer :: i_count
  allocate(index_one_hole(n_det),index_one_hole_one_p(n_det),index_two_hole_one_p(N_det),index_two_hole(N_det),index_one_p(N_det),is_a_ref_det(N_det))
  allocate(index_one_hole_two_p(n_det))
- double precision, allocatable :: local_norm(:)
- allocate(local_norm(N_states))
  
  n_one_hole = 0
  n_one_hole_one_p = 0
@@ -141,18 +128,16 @@ subroutine set_intermediate_normalization_mlct_old(norm,i_particl)
  ! Find the one holes and one hole one particle
  i_count = 0
  is_a_ref_det = .False.
- integer :: istate
- do istate = 1, N_states
-  do i = 1, N_det
-   call get_excitation_degree(ref_generators_restart(1,1,istate),psi_det(1,1,i),degree,N_int)
-   if(degree == 0)then
-    index_ref_generators_restart(istate) = i
-    inv_coef_ref_generators_restart(istate) = 1.d0/psi_coef(i,istate)
-   endif
-  enddo
- enddo
-
  do i = 1, N_det
+  call get_excitation_degree(ref_generators_restart,psi_det(1,1,i),degree,N_int)
+  if(degree == 0)then
+   index_ref_generators_restart = i
+   do k = 1, N_states
+    inv_coef_ref_generators_restart(k) = 1.d0/psi_coef(i,k)
+   enddo
+!  cycle
+  endif
+
   ! Find all the determinants present in the reference wave function
   do j = 1, N_det_generators_restart
    call get_excitation_degree(psi_det(1,1,i),psi_det_generators_restart(1,1,j),degree,N_int)  
@@ -188,7 +173,7 @@ subroutine set_intermediate_normalization_mlct_old(norm,i_particl)
  do k = 1, N_states
    print*,'state ',k
    do i = 1, n_good_particl
-    print*,'psi_coef(index_good_particl,1) = ',psi_coef(index_good_particl(i),k)/psi_coef(index_ref_generators_restart(k),k)
+    print*,'psi_coef(index_good_particl,1) = ',psi_coef(index_good_particl(i),k)/psi_coef(index_ref_generators_restart,k)
    enddo
    print*,''
  enddo
@@ -200,29 +185,20 @@ subroutine set_intermediate_normalization_mlct_old(norm,i_particl)
    psi_coef(i,k) = psi_coef(i,k) * inv_coef_ref_generators_restart(k)
   enddo
  enddo
-
+ do k = 1, N_states
- norm = 0.d0
- do k = 1,N_states
   print*,'state ',k
   do i = 1, N_det
+!! print*,'i = ',i, psi_coef(i,1)
    if (is_a_ref_det(i))then
     print*,'i,psi_coef_ref = ',psi_coef(i,k)
+    cycle
    endif
    norm(k) += psi_coef(i,k) * psi_coef(i,k)
   enddo
-  print*,'norm = ',norm(k)
+  print*,'norm = ',norm
- enddo
- do k =1, N_states
-  local_norm(k) = 1.d0 / dsqrt(norm(k))
- enddo
- do k = 1,N_states
-  do i = 1, N_det
-   psi_coef(i,k) = psi_coef(i,k) * local_norm(k)
-  enddo
  enddo
  soft_touch psi_coef
  deallocate(index_one_hole,index_one_hole_one_p,index_two_hole_one_p,index_two_hole,index_one_p,is_a_ref_det)
- deallocate(local_norm)
 end
 
 
@@ -234,60 +210,12 @@ subroutine update_density_matrix_osoci
  END_DOC
  integer :: i,j
  integer :: iorb,jorb
- ! active <--> inactive block
  do i = 1, mo_tot_num
   do j = 1, mo_tot_num
-   one_body_dm_mo_alpha_osoci(i,j) += one_body_dm_mo_alpha_average(i,j) - one_body_dm_mo_alpha_generators_restart(i,j)
+   one_body_dm_mo_alpha_osoci(i,j) = one_body_dm_mo_alpha_osoci(i,j) + (one_body_dm_mo_alpha_average(i,j) - one_body_dm_mo_alpha_generators_restart(i,j))
-   one_body_dm_mo_beta_osoci(i,j) += one_body_dm_mo_beta_average(i,j) - one_body_dm_mo_beta_generators_restart(i,j)
+   one_body_dm_mo_beta_osoci(i,j) = one_body_dm_mo_beta_osoci(i,j) + (one_body_dm_mo_beta_average(i,j) - one_body_dm_mo_beta_generators_restart(i,j))
   enddo
  enddo
-!do i = 1, n_act_orb
-! iorb = list_act(i)
-! do j = 1, n_inact_orb
-!  jorb = list_inact(j)
-!  one_body_dm_mo_alpha_osoci(iorb,jorb)+= one_body_dm_mo_alpha_average(iorb,jorb)
-!  one_body_dm_mo_alpha_osoci(jorb,iorb)+= one_body_dm_mo_alpha_average(jorb,iorb)
-!  one_body_dm_mo_beta_osoci(iorb,jorb) += one_body_dm_mo_beta_average(iorb,jorb) 
-!  one_body_dm_mo_beta_osoci(jorb,iorb) += one_body_dm_mo_beta_average(jorb,iorb) 
-! enddo
-!enddo
-
-!! active <--> virt block
-!do i = 1, n_act_orb
-! iorb = list_act(i)
-! do j = 1, n_virt_orb
-!  jorb = list_virt(j)
-!  one_body_dm_mo_alpha_osoci(iorb,jorb)+= one_body_dm_mo_alpha_average(iorb,jorb)
-!  one_body_dm_mo_alpha_osoci(jorb,iorb)+= one_body_dm_mo_alpha_average(jorb,iorb)
-!  one_body_dm_mo_beta_osoci(iorb,jorb) += one_body_dm_mo_beta_average(iorb,jorb) 
-!  one_body_dm_mo_beta_osoci(jorb,iorb) += one_body_dm_mo_beta_average(jorb,iorb) 
-! enddo
-!enddo
-
-!! virt <--> virt block
-!do j = 1, n_virt_orb
-!  jorb = list_virt(j)
-!  one_body_dm_mo_alpha_osoci(jorb,jorb)+= one_body_dm_mo_alpha_average(jorb,jorb)
-!  one_body_dm_mo_beta_osoci(jorb,jorb) += one_body_dm_mo_beta_average(jorb,jorb) 
-!enddo
-
-!! inact <--> inact block
-!do j = 1, n_inact_orb
-!  jorb = list_inact(j)
-!  one_body_dm_mo_alpha_osoci(jorb,jorb) -= one_body_dm_mo_alpha_average(jorb,jorb)
-!  one_body_dm_mo_beta_osoci(jorb,jorb)  -= one_body_dm_mo_beta_average(jorb,jorb) 
-!enddo
- double precision :: accu_alpha, accu_beta
- accu_alpha = 0.d0
- accu_beta = 0.d0
- do i = 1, mo_tot_num
-  accu_alpha += one_body_dm_mo_alpha_osoci(i,i) 
-  accu_beta += one_body_dm_mo_beta_osoci(i,i) 
-! write(*,'(I3,X,100(F16.10,X))') i,one_body_dm_mo_alpha_osoci(i,i),one_body_dm_mo_beta_osoci(i,i),one_body_dm_mo_alpha_osoci(i,i)+one_body_dm_mo_beta_osoci(i,i)
- enddo 
- print*, 'accu_alpha/beta',accu_alpha,accu_beta
- 
- 
 
 
 end
@@ -333,18 +261,8 @@ end
 
 subroutine initialize_density_matrix_osoci
  implicit none
- call set_generators_to_generators_restart
- call set_psi_det_to_generators
- call diagonalize_CI
- 
  one_body_dm_mo_alpha_osoci = one_body_dm_mo_alpha_generators_restart
  one_body_dm_mo_beta_osoci  = one_body_dm_mo_beta_generators_restart
- integer :: i
- print*, '8*********************'
-  print*, 'initialize_density_matrix_osoci'
- do i = 1, mo_tot_num
-  print*,one_body_dm_mo_alpha_osoci(i,i),one_body_dm_mo_alpha_generators_restart(i,i)
- enddo
 end
 
 subroutine rescale_density_matrix_osoci(norm)
@@ -520,10 +438,6 @@ subroutine save_osoci_natural_mos
    endif
   enddo
  enddo
- print*, 'test'
- print*, 'test'
- print*, 'test'
- print*, 'test'
  do i = 1, mo_tot_num
   do j = i+1, mo_tot_num
    if(dabs(tmp(i,j)).le.threshold_fobo_dm)then
@@ -531,9 +445,7 @@ subroutine save_osoci_natural_mos
       tmp(j,i) = 0.d0
    endif
   enddo
-  print*, tmp(i,i)
  enddo
- 
 
  label = "Natural"
  

plugins/FOBOCI/track_orb.irp.f

@@ -1,57 +0,0 @@
- BEGIN_PROVIDER [ double precision, mo_coef_begin_iteration, (ao_num_align,mo_tot_num) ]
-   implicit none
-   BEGIN_DOC
-   ! Alpha and beta one-body density matrix that will be used for the 1h1p approach
-   END_DOC
-END_PROVIDER
-
-subroutine initialize_mo_coef_begin_iteration
- implicit none
- mo_coef_begin_iteration = mo_coef
-
-end
-
-subroutine reorder_active_orb
- implicit none
- integer :: i,j,iorb
- integer :: k,l
- double precision, allocatable :: accu(:)
- integer, allocatable :: index_active_orb(:),iorder(:)
- double precision, allocatable :: mo_coef_tmp(:,:)
- allocate(accu(mo_tot_num),index_active_orb(n_act_orb),iorder(mo_tot_num))
- allocate(mo_coef_tmp(ao_num_align,mo_Tot_num))
- 
- 
- do i = 1, n_act_orb
-  iorb = list_act(i)
-  do j = 1, mo_tot_num
-   accu(j) = 0.d0
-   iorder(j) = j
-   do k = 1, ao_num
-    do l = 1, ao_num
-     accu(j) += mo_coef_begin_iteration(k,iorb) * mo_coef(l,j) * ao_overlap(k,l)
-    enddo
-   enddo
-   accu(j) = -dabs(accu(j))
-  enddo
-  call dsort(accu,iorder,mo_tot_num)
-  index_active_orb(i) = iorder(1) 
- enddo
-
- double precision :: x
- integer :: i1,i2
- print*, 'swapping the active MOs'
- do j = 1, n_act_orb
-  i1 = list_act(j)
-  i2 = index_active_orb(j)
-  print*, i1,i2
-  do i=1,ao_num_align
-    x = mo_coef(i,i1)
-    mo_coef(i,i1) = mo_coef(i,i2)
-    mo_coef(i,i2) = x
-  enddo
- enddo
-
- deallocate(accu,index_active_orb, iorder)
-end
-

plugins/Full_CI/H_apply.irp.f

@@ -12,6 +12,11 @@ s.set_perturbation("epstein_nesbet_2x2")
 s.unset_openmp()
 print s
 
+s = H_apply("FCI_PT2_new")
+s.set_perturbation("decontracted")
+s.unset_openmp()
+print s
+
 
 s = H_apply("FCI_no_skip")
 s.set_selection_pt2("epstein_nesbet_2x2")

plugins/Full_CI/NEEDED_CHILDREN_MODULES

@@ -1 +1 @@
-Perturbation Selectors_full Generators_full Davidson 
+Perturbation Selectors_full Generators_full Davidson

plugins/Full_CI_ZMQ/energy.irp.f

@@ -1,23 +1,11 @@
-BEGIN_PROVIDER [ logical, initialize_pt2_E0_denominator ]
- implicit none
- BEGIN_DOC
- ! If true, initialize pt2_E0_denominator
- END_DOC
- initialize_pt2_E0_denominator = .True.
-END_PROVIDER
-
 BEGIN_PROVIDER [ double precision, pt2_E0_denominator, (N_states) ]
  implicit none
  BEGIN_DOC
  ! E0 in the denominator of the PT2
  END_DOC
- if (initialize_pt2_E0_denominator) then
+ pt2_E0_denominator(1:N_states) = CI_electronic_energy(1:N_states)
-  pt2_E0_denominator(1:N_states) = psi_energy(1:N_states)
 ! pt2_E0_denominator(1:N_states) = HF_energy - nuclear_repulsion
 ! pt2_E0_denominator(1:N_states) = barycentric_electronic_energy(1:N_states)
-  call write_double(6,pt2_E0_denominator(1)+nuclear_repulsion, 'PT2 Energy denominator')
+ call write_double(6,pt2_E0_denominator(1)+nuclear_repulsion, 'PT2 Energy denominator')
- else
-   pt2_E0_denominator = -huge(1.d0)
- endif
 END_PROVIDER
 

plugins/Full_CI_ZMQ/fci_zmq.irp.f

@@ -68,8 +68,8 @@ program fci_zmq
     call ezfio_set_full_ci_zmq_energy(CI_energy(1))
 
     n_det_before = N_det
-    to_select = N_det
+    to_select = 2*N_det
-    to_select = max(N_det, to_select)
+    to_select = max(64-to_select, to_select)
     to_select = min(to_select, N_det_max-n_det_before)
     call ZMQ_selection(to_select, pt2)
     
@@ -96,17 +96,11 @@ program fci_zmq
 
   if(do_pt2_end)then
     print*,'Last iteration only to compute the PT2'
-    !threshold_selectors = max(threshold_selectors,threshold_selectors_pt2)
+    threshold_selectors = max(threshold_selectors,threshold_selectors_pt2)
-    !threshold_generators = max(threshold_generators,threshold_generators_pt2)
+    threshold_generators = max(threshold_generators,threshold_generators_pt2)
-    !TOUCH threshold_selectors threshold_generators
+    TOUCH threshold_selectors threshold_generators
-    threshold_selectors = 1.d0
-    threshold_generators = 1d0 
     E_CI_before(1:N_states) = CI_energy(1:N_states)
-    double precision :: relative_error
+    call ZMQ_selection(0, pt2)
-    relative_error=1.d-3
-    pt2 = 0.d0
-    call ZMQ_pt2(pt2,relative_error)
-    !call ZMQ_selection(0, pt2)! pour non-stochastic
     print *,  'Final step'
     print *,  'N_det    = ', N_det
     print *,  'N_states = ', N_states
@@ -125,3 +119,122 @@ program fci_zmq
 end
 
 
+
+
+subroutine ZMQ_selection(N_in, pt2)
+  use f77_zmq
+  use selection_types
+  
+  implicit none
+  
+  character*(512)                :: task 
+  integer(ZMQ_PTR)               :: zmq_to_qp_run_socket 
+  integer, intent(in)            :: N_in
+  type(selection_buffer)         :: b
+  integer                        :: i, N
+  integer, external              :: omp_get_thread_num
+  double precision, intent(out)  :: pt2(N_states)
+  
+  
+  if (.True.) then
+    PROVIDE pt2_e0_denominator
+    N = max(N_in,1)
+    provide nproc
+    call new_parallel_job(zmq_to_qp_run_socket,"selection")
+    call zmq_put_psi(zmq_to_qp_run_socket,1,pt2_e0_denominator,size(pt2_e0_denominator))
+    call zmq_set_running(zmq_to_qp_run_socket)
+    call create_selection_buffer(N, N*2, b)
+  endif
+
+  integer :: i_generator, i_generator_start, i_generator_max, step
+!  step = int(max(1.,10*elec_num/mo_tot_num)
+
+  step = int(5000000.d0 / dble(N_int * N_states * elec_num * elec_num * mo_tot_num * mo_tot_num ))
+  step = max(1,step)
+  do i= 1, N_det_generators,step
+    i_generator_start = i
+    i_generator_max = min(i+step-1,N_det_generators)
+    write(task,*) i_generator_start, i_generator_max, 1, N
+    call add_task_to_taskserver(zmq_to_qp_run_socket,task)
+  end do
+
+  !$OMP PARALLEL DEFAULT(shared)  SHARED(b, pt2)  PRIVATE(i) NUM_THREADS(nproc+1)
+  i = omp_get_thread_num()
+  if (i==0) then
+    call selection_collector(b, pt2)
+  else
+    call selection_slave_inproc(i)
+  endif
+  !$OMP END PARALLEL
+  call end_parallel_job(zmq_to_qp_run_socket, 'selection')
+  if (N_in > 0) then
+    call fill_H_apply_buffer_no_selection(b%cur,b%det,N_int,0) !!! PAS DE ROBIN
+    call copy_H_apply_buffer_to_wf()
+    if (s2_eig) then
+      call make_s2_eigenfunction
+    endif
+  endif
+end subroutine
+
+
+subroutine selection_slave_inproc(i)
+  implicit none
+  integer, intent(in)            :: i
+
+  call run_selection_slave(1,i,pt2_e0_denominator)
+end
+
+subroutine selection_collector(b, pt2)
+  use f77_zmq
+  use selection_types
+  use bitmasks
+  implicit none
+
+
+  type(selection_buffer), intent(inout) :: b
+  double precision, intent(out)       :: pt2(N_states)
+  double precision                   :: pt2_mwen(N_states)
+  integer(ZMQ_PTR),external      :: new_zmq_to_qp_run_socket
+  integer(ZMQ_PTR)               :: zmq_to_qp_run_socket
+
+  integer(ZMQ_PTR), external     :: new_zmq_pull_socket
+  integer(ZMQ_PTR)               :: zmq_socket_pull
+
+  integer :: msg_size, rc, more
+  integer :: acc, i, j, robin, N, ntask
+  double precision, allocatable :: val(:)
+  integer(bit_kind), allocatable :: det(:,:,:)
+  integer, allocatable :: task_id(:)
+  integer :: done
+  real :: time, time0
+  zmq_to_qp_run_socket = new_zmq_to_qp_run_socket()
+  zmq_socket_pull = new_zmq_pull_socket()
+  allocate(val(b%N), det(N_int, 2, b%N), task_id(N_det))
+  done = 0
+  more = 1
+  pt2(:) = 0d0
+  call CPU_TIME(time0)
+  do while (more == 1)
+    call pull_selection_results(zmq_socket_pull, pt2_mwen, val(1), det(1,1,1), N, task_id, ntask)
+    pt2 += pt2_mwen
+    do i=1, N
+      call add_to_selection_buffer(b, det(1,1,i), val(i))
+    end do
+
+    do i=1, ntask
+      if(task_id(i) == 0) then
+          print *,  "Error in collector"
+      endif
+      call zmq_delete_task(zmq_to_qp_run_socket,zmq_socket_pull,task_id(i),more)
+    end do
+    done += ntask
+    call CPU_TIME(time)
+!    print *, "DONE" , done, time - time0
+  end do
+
+
+  call end_zmq_to_qp_run_socket(zmq_to_qp_run_socket)
+  call end_zmq_pull_socket(zmq_socket_pull)
+  call sort_selection_buffer(b)
+end subroutine
+

plugins/Full_CI_ZMQ/pt2_slave.irp.f

@@ -1,70 +0,0 @@
-program pt2_slave
-  implicit none
-  BEGIN_DOC
-! Helper program to compute the PT2 in distributed mode.
-  END_DOC
-
-  read_wf = .False.
-  SOFT_TOUCH read_wf
-  call provide_everything
-  call switch_qp_run_to_master
-  call run_wf
-end
-
-subroutine provide_everything
-  PROVIDE H_apply_buffer_allocated mo_bielec_integrals_in_map psi_det_generators psi_coef_generators psi_det_sorted_bit psi_selectors n_det_generators n_states generators_bitmask zmq_context
-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_diag)
-  character*(64) :: states(1)
-  integer :: rc, i
-  
-  call provide_everything
-  
-  zmq_context = f77_zmq_ctx_new ()
-  states(1) = 'pt2'
-
-  zmq_to_qp_run_socket = new_zmq_to_qp_run_socket()
-
-  do
-
-    call wait_for_states(states,zmq_state,1)
-
-    if(trim(zmq_state) == 'Stopped') then
-
-      exit
-
-    else if (trim(zmq_state) == 'pt2') then
-
-      ! Selection
-      ! ---------
-
-      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 pt2_slave_tcp(i, energy)
-      !$OMP END PARALLEL
-      print *,  'PT2 done'
-
-    endif
-
-  end do
-end
-
-subroutine pt2_slave_tcp(i,energy)
-  implicit none
-  double precision, intent(in) :: energy(N_states_diag)
-  integer, intent(in)            :: i
-  logical :: lstop
-  lstop = .False.
-  call run_pt2_slave(0,i,energy,lstop)
-end
-

plugins/Full_CI_ZMQ/pt2_stoch.irp.f

@@ -1,38 +0,0 @@
-program pt2_stoch
-  implicit none
-  read_wf = .True.
-  SOFT_TOUCH read_wf
-  PROVIDE mo_bielec_integrals_in_map
-  call run
-end
-
-subroutine run
-  implicit none
-  integer                        :: i,j,k
-  logical, external              :: detEq
-  
-  double precision, allocatable  :: pt2(:)
-  integer                        :: degree
-  integer                        :: n_det_before, to_select
-  double precision               :: threshold_davidson_in
-
-  double precision               :: E_CI_before, relative_error
-
-  allocate (pt2(N_states))
-  pt2 = 0.d0
-  
-  E_CI_before = pt2_E0_denominator(1) + nuclear_repulsion
-  threshold_selectors = 1.d0
-  threshold_generators = 1d0 
-  relative_error = 1.d-3
-  call ZMQ_pt2(pt2, relative_error)
-  print *,  'Final step'
-  print *,  'N_det    = ', N_det
-  print *,  'PT2      = ', pt2
-  print *,  'E        = ', E_CI_before
-  print *,  'E+PT2    = ', E_CI_before+pt2
-  print *,  '-----'
-  call ezfio_set_full_ci_zmq_energy_pt2(E_CI_before+pt2(1))
-end
-
-

plugins/Full_CI_ZMQ/pt2_stoch_routines.irp.f

@@ -1,579 +0,0 @@
-BEGIN_PROVIDER [ integer, fragment_first ]
-  implicit none
-  fragment_first = first_det_of_teeth(1)
-END_PROVIDER
-
-subroutine ZMQ_pt2(pt2,relative_error)
-  use f77_zmq
-  use selection_types
-  
-  implicit none
-  
-  character(len=64000)           :: task 
-  integer(ZMQ_PTR)               :: zmq_to_qp_run_socket, zmq_to_qp_run_socket2
-  type(selection_buffer)         :: b
-  integer, external              :: omp_get_thread_num
-  double precision, intent(in)   :: relative_error
-  double precision, intent(out)  :: pt2(N_states)
-
-  
-  double precision, allocatable :: pt2_detail(:,:), comb(:)
-  logical, allocatable :: computed(:)
-  integer, allocatable :: tbc(:)
-  integer :: i, j, k, Ncomb, generator_per_task, i_generator_end
-  integer, external :: pt2_find
-  
-  double precision :: sumabove(comb_teeth), sum2above(comb_teeth), Nabove(comb_teeth)
-  double precision, external :: omp_get_wtime 
-  double precision :: time0, time
-
-  allocate(pt2_detail(N_states, N_det_generators), comb(N_det_generators/2), computed(N_det_generators), tbc(0:size_tbc))
-  sumabove = 0d0
-  sum2above = 0d0
-  Nabove = 0d0
-
-  provide nproc fragment_first fragment_count mo_bielec_integrals_in_map mo_mono_elec_integral pt2_weight
-
-  !call random_seed()
-  
-  computed = .false.
-
-  tbc(0) = first_det_of_comb - 1
-  do i=1, tbc(0)
-    tbc(i) = i
-    computed(i) = .true.
-  end do
-  
-  pt2_detail = 0d0
-  time0 = omp_get_wtime()
-  print *, "time - avg - err - n_combs"
-  generator_per_task = 1
-  do while(.true.)
-    
-    call write_time(6)
-    call new_parallel_job(zmq_to_qp_run_socket,"pt2")
-    call zmq_put_psi(zmq_to_qp_run_socket,1,pt2_e0_denominator,size(pt2_e0_denominator))
-    call create_selection_buffer(1, 1*2, b)
-    
-    Ncomb=size(comb)
-    call get_carlo_workbatch(computed, comb, Ncomb, tbc)
-
-    call write_time(6)
-
-
-    integer(ZMQ_PTR), external :: new_zmq_to_qp_run_socket
-    integer :: ipos
-    logical :: tasks
-    tasks = .False.
-    ipos=1
-
-    do i=1,tbc(0)
-      if(tbc(i) > fragment_first) then
-        write(task(ipos:ipos+20),'(I9,1X,I9,''|'')') 0, tbc(i)
-        ipos += 20
-        if (ipos > 63980) then
-          call add_task_to_taskserver(zmq_to_qp_run_socket,trim(task(1:ipos-20)))
-          ipos=1
-          tasks = .True.
-        endif
-      else
-        do j=1,fragment_count
-          write(task(ipos:ipos+20),'(I9,1X,I9,''|'')') j, tbc(i)
-          ipos += 20
-          if (ipos > 63980) then
-            call add_task_to_taskserver(zmq_to_qp_run_socket,trim(task(1:ipos-20)))
-            ipos=1
-            tasks = .True.
-          endif
-        end do
-      end if
-    end do
-    if (ipos > 1) then
-      call add_task_to_taskserver(zmq_to_qp_run_socket,trim(task(1:ipos-20)))
-      tasks = .True.
-    endif
-
-    if (tasks) then
-      call zmq_set_running(zmq_to_qp_run_socket)
-
-      !$OMP PARALLEL DEFAULT(shared) NUM_THREADS(nproc+1) &
-      !$OMP  PRIVATE(i)
-        i = omp_get_thread_num()
-        if (i==0) then
-          call pt2_collector(b, tbc, comb, Ncomb, computed, pt2_detail, sumabove, sum2above, Nabove, relative_error, pt2)
-        else
-          call pt2_slave_inproc(i)
-        endif
-      !$OMP END PARALLEL
-      call end_parallel_job(zmq_to_qp_run_socket, 'pt2')
-
-    else
-       pt2 = 0.d0
-       do i=1,N_det_generators
-         do k=1,N_states
-            pt2(k) = pt2(k) + pt2_detail(k,i)
-         enddo
-       enddo
-    endif
-
-    tbc(0) = 0
-    if (pt2(1) /= 0.d0) then
-      exit
-    endif
-  end do
-
-  deallocate(pt2_detail, comb, computed, tbc)
-
-end subroutine
-
-
-subroutine do_carlo(tbc, Ncomb, comb, pt2_detail, computed, sumabove, sum2above, Nabove)
-  integer, intent(in) :: tbc(0:size_tbc), Ncomb
-  logical, intent(in) :: computed(N_det_generators)
-  double precision, intent(in) :: comb(Ncomb), pt2_detail(N_states, N_det_generators)
-  double precision, intent(inout) :: sumabove(comb_teeth), sum2above(comb_teeth), Nabove(comb_teeth)
-  integer :: i, dets(comb_teeth)
-  double precision :: myVal, myVal2
-
-  mainLoop : do i=1,Ncomb
-    call get_comb(comb(i), dets, comb_teeth)
-    do j=1,comb_teeth
-      if(.not.(computed(dets(j)))) then
-        exit mainLoop
-      end if
-    end do
-    
-    myVal = 0d0
-    myVal2 = 0d0
-    do j=comb_teeth,1,-1
-      myVal += pt2_detail(1, dets(j)) * pt2_weight_inv(dets(j)) * comb_step
-      sumabove(j) += myVal
-      sum2above(j) += myVal*myVal
-      Nabove(j) += 1
-    end do
-  end do mainLoop
-end subroutine
-
-
-subroutine pt2_slave_inproc(i)
-  implicit none
-  integer, intent(in)            :: i
-
-  call run_pt2_slave(1,i,pt2_e0_denominator)
-end
-
-subroutine pt2_collector(b, tbc, comb, Ncomb, computed, pt2_detail, sumabove, sum2above, Nabove, relative_error, pt2)
-  use f77_zmq
-  use selection_types
-  use bitmasks
-  implicit none
-
-  
-  integer, intent(in) :: Ncomb
-  double precision, intent(inout) :: pt2_detail(N_states, N_det_generators)
-  double precision, intent(in) :: comb(Ncomb), relative_error
-  logical, intent(inout) :: computed(N_det_generators)
-  integer, intent(in) :: tbc(0:size_tbc)
-  double precision, intent(inout) :: sumabove(comb_teeth), sum2above(comb_teeth), Nabove(comb_teeth)
-  double precision, intent(out)  :: pt2(N_states)
-
-
-  type(selection_buffer), intent(inout) :: b
-  double precision, allocatable      :: pt2_mwen(:,:)
-  integer(ZMQ_PTR),external      :: new_zmq_to_qp_run_socket
-  integer(ZMQ_PTR)               :: zmq_to_qp_run_socket
-
-  integer(ZMQ_PTR), external     :: new_zmq_pull_socket
-  integer(ZMQ_PTR)               :: zmq_socket_pull
-
-  integer :: msg_size, rc, more
-  integer :: acc, i, j, robin, N, ntask
-  double precision, allocatable :: val(:)
-  integer(bit_kind), allocatable :: det(:,:,:)
-  integer, allocatable :: task_id(:)
-  integer :: done, Nindex
-  integer, allocatable :: index(:)
-  double precision, save :: time0 = -1.d0
-  double precision :: time, timeLast
-  double precision, external :: omp_get_wtime
-  integer :: tooth, firstTBDcomb, orgTBDcomb
-  integer, allocatable :: parts_to_get(:)
-  logical, allocatable :: actually_computed(:)
-  
-  allocate(actually_computed(N_det_generators), parts_to_get(N_det_generators), &
-    pt2_mwen(N_states, N_det_generators) )
-  do i=1,N_det_generators
-    actually_computed(i) = computed(i)
-  enddo
-  
-  parts_to_get(:) = 1
-  if(fragment_first > 0) then
-    do i=1,fragment_first
-      parts_to_get(i) = fragment_count
-    enddo
-  endif
-
-  do i=1,tbc(0)
-    actually_computed(tbc(i)) = .false.
-  end do
-  
-  orgTBDcomb = Nabove(1)
-  firstTBDcomb = 1
-
-  zmq_to_qp_run_socket = new_zmq_to_qp_run_socket()
-  zmq_socket_pull = new_zmq_pull_socket()
-  allocate(val(b%N), det(N_int, 2, b%N), task_id(N_det_generators), index(1))
-  more = 1
-  if (time0 < 0.d0) then
-      time0 = omp_get_wtime()
-  endif
-  timeLast = time0
-  
-  print *, 'N_deterministic = ', first_det_of_teeth(1)-1
-  pullLoop : do while (more == 1)
-    call pull_pt2_results(zmq_socket_pull, Nindex, index, pt2_mwen, task_id, ntask)
-    do i=1,Nindex
-      pt2_detail(1:N_states, index(i)) += pt2_mwen(1:N_states,i)
-      parts_to_get(index(i)) -= 1
-      if(parts_to_get(index(i)) < 0) then 
-        print *, i, index(i), parts_to_get(index(i)), Nindex
-        print *, "PARTS ??"
-        print *, parts_to_get
-        stop "PARTS ??"
-      end if
-      if(parts_to_get(index(i)) == 0) actually_computed(index(i)) = .true.
-    end do
-
-    do i=1, ntask
-      if(task_id(i) == 0) then
-          print *,  "Error in collector"
-      endif
-      call zmq_delete_task(zmq_to_qp_run_socket,zmq_socket_pull,task_id(i),more)
-    end do
-
-    time = omp_get_wtime()
-  
-    if(time - timeLast > 1d1 .or. more /= 1) then
-      timeLast = time
-      do i=1, first_det_of_teeth(1)-1
-        if(.not.(actually_computed(i))) then
-          print *, "PT2 : deterministic part not finished"
-          cycle pullLoop
-        end if
-      end do
-      
-      double precision :: E0, avg, eqt, prop
-      call do_carlo(tbc, Ncomb+1-firstTBDcomb, comb(firstTBDcomb), pt2_detail, actually_computed, sumabove, sum2above, Nabove)
-      firstTBDcomb = Nabove(1) - orgTBDcomb + 1
-      if(Nabove(1) < 2d0) 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))
-      prop = ((1d0 - dfloat(comb_teeth - tooth + 1) * comb_step) - pt2_cweight(first_det_of_teeth(tooth)-1))
-      prop = prop * pt2_weight_inv(first_det_of_teeth(tooth))
-      E0 += pt2_detail(1,first_det_of_teeth(tooth)) * prop
-      avg = E0 + (sumabove(tooth) / Nabove(tooth))
-      eqt = sqrt(1d0 / (Nabove(tooth)-1) * abs(sum2above(tooth) / Nabove(tooth) - (sumabove(tooth)/Nabove(tooth))**2))
-      time = omp_get_wtime()
-      if (dabs(eqt/avg) < relative_error) then
-        pt2(1) = avg
-!        exit pullLoop
-      else
-        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)
-      endif
-    end if
-  end do pullLoop
-
-  call end_zmq_to_qp_run_socket(zmq_to_qp_run_socket)
-  call end_zmq_pull_socket(zmq_socket_pull)
-  call sort_selection_buffer(b)
-end subroutine
-
-integer function pt2_find(v, w, sze, imin, imax)
-  implicit none
-  integer, intent(in) :: sze, imin, imax
-  double precision, intent(in) :: v, w(sze)
-  integer :: i,l,h
-  integer, parameter :: block=64
-
-  l = imin
-  h = imax-1
-
-  do while(h-l >= block)
-    i = ishft(h+l,-1)
-    if(w(i+1) > v) then
-      h = i-1
-    else
-      l = i+1
-    end if
-  end do
-  !DIR$ LOOP COUNT (64)
-  do pt2_find=l,h
-    if(w(pt2_find) >= v) then
-      exit
-    end if
-  end do
-end function
-
-
-BEGIN_PROVIDER [ integer, comb_teeth ]
-  implicit none
-  comb_teeth = 100
-END_PROVIDER
-
-
-
-subroutine get_first_tooth(computed, first_teeth)
-  implicit none
-  logical, intent(in) :: computed(N_det_generators)
-  integer, intent(out) :: first_teeth
-  integer :: i, first_det
-
-  first_det = 1
-  first_teeth = 1
-  do i=first_det_of_comb, N_det_generators
-    if(.not.(computed(i))) then
-      first_det = i
-      exit
-    end if
-  end do
-  
-  do i=comb_teeth, 1, -1
-    if(first_det_of_teeth(i) < first_det) then
-      first_teeth = i
-      exit
-    end if
-  end do
-
-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),-12) ! /4096
-     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
-! Size of the tbc array
-  END_DOC
-  size_tbc = N_det_generators + fragment_count*fragment_first
-END_PROVIDER
-
-subroutine get_carlo_workbatch(computed, comb, Ncomb, tbc)
-  implicit none
-  integer, intent(inout) :: Ncomb
-  double precision, intent(out) :: comb(Ncomb)
-  integer, intent(inout) :: tbc(0:size_tbc)
-  logical, intent(inout) :: computed(N_det_generators)
-  integer :: i, j, last_full, dets(comb_teeth), tbc_save
-  integer :: icount, n
-  n = tbc(0)
-  icount = 0 
-  call RANDOM_NUMBER(comb)
-  do i=1,size(comb)
-      comb(i) = comb(i) * comb_step
-      tbc_save = tbc(0)
-      !DIR$ FORCEINLINE
-      call add_comb(comb(i), computed, tbc, size_tbc, comb_teeth)
-      if (tbc(0) < size(tbc)) then
-         Ncomb = i
-      else
-         tbc(0) = tbc_save
-         return
-      endif
-      icount = icount + tbc(0) - tbc_save
-      if (icount > n) then
-        call get_filling_teeth(computed, tbc)
-        icount = 0
-        n = ishft(tbc_save,-4)
-      endif
-  enddo
-
-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
-  integer, intent(in) :: ct
-  double precision, intent(in) :: stato
-  integer, intent(out) :: dets(ct)
-  double precision :: curs
-  integer :: j
-  integer, external :: pt2_find
-
-  curs = 1d0 - stato
-  do j = comb_teeth, 1, -1
-    !DIR$ FORCEINLINE
-    dets(j) = pt2_find(curs, pt2_cweight,size(pt2_cweight), first_det_of_teeth(j), first_det_of_teeth(j+1))
-    curs -= comb_step
-  end do
-end subroutine
-
-
-subroutine add_comb(comb, computed, tbc, stbc, ct)
-  implicit none
-  integer, intent(in) :: stbc, ct
-  double precision, intent(in) :: comb
-  logical, intent(inout) :: computed(N_det_generators)
-  integer, intent(inout) :: tbc(0:stbc)
-  integer :: i, k, l, dets(ct)
-  
-  !DIR$ FORCEINLINE
-  call get_comb(comb, dets, ct)
-  
-  k=tbc(0)+1
-  do i = 1, ct
-    l = dets(i)
-    if(.not.(computed(l))) then
-      tbc(k) = l
-      k = k+1
-      computed(l) = .true.
-    end if
-  end do
-  tbc(0) = k-1
-end subroutine
-
-
-
- BEGIN_PROVIDER [ double precision, pt2_weight, (N_det_generators) ]
-&BEGIN_PROVIDER [ double precision, pt2_cweight, (N_det_generators) ]
-&BEGIN_PROVIDER [ double precision, pt2_cweight_cache, (N_det_generators) ]
-&BEGIN_PROVIDER [ double precision, comb_step ]
-&BEGIN_PROVIDER [ integer, first_det_of_teeth, (comb_teeth+1) ]
-&BEGIN_PROVIDER [ integer, first_det_of_comb ]
-  implicit none
-  integer :: i
-  double precision :: norm_left, stato
-  integer, external :: pt2_find  
-
-  pt2_weight(1) = psi_coef_generators(1,1)**2
-  pt2_cweight(1) = psi_coef_generators(1,1)**2
-  
-  do i=2,N_det_generators
-    pt2_weight(i) = psi_coef_generators(i,1)**2
-    pt2_cweight(i) = pt2_cweight(i-1) + psi_coef_generators(i,1)**2
-  end do
-  
-  do i=1,N_det_generators
-    pt2_weight(i)  = pt2_weight(i) / pt2_cweight(N_det_generators)
-    pt2_cweight(i) = pt2_cweight(i) / pt2_cweight(N_det_generators)
-  enddo
-  
-  norm_left = 1d0
-  
-  comb_step = 1d0/dfloat(comb_teeth)
-  first_det_of_comb = 1
-  do i=1,N_det_generators
-    if(pt2_weight(i)/norm_left < comb_step*.5d0) then
-      first_det_of_comb = i
-      exit
-    end if
-    norm_left -= pt2_weight(i)
-  end do
-  
-  comb_step =  (1d0 - pt2_cweight(first_det_of_comb-1)) * comb_step
-  
-  stato = 1d0 - comb_step
-  iloc = N_det_generators
-  do i=comb_teeth, 1, -1
-    integer :: iloc
-    iloc = pt2_find(stato, pt2_cweight, N_det_generators, 1, iloc)
-    first_det_of_teeth(i) = iloc
-    stato -= comb_step
-  end do
-  first_det_of_teeth(comb_teeth+1) = N_det_generators + 1
-  first_det_of_teeth(1) = first_det_of_comb
-  if(first_det_of_teeth(1) /= first_det_of_comb) then
-     print *, 'Error in ', irp_here
-     stop "comb provider"
-  endif
-  
-END_PROVIDER
-
-BEGIN_PROVIDER [ double precision, pt2_weight_inv, (N_det_generators) ]
-  implicit none
-  BEGIN_DOC
-!  Inverse of pt2_weight array
-  END_DOC
-  integer :: i
-  do i=1,N_det_generators
-    pt2_weight_inv(i) = 1.d0/pt2_weight(i)
-  enddo
-
-END_PROVIDER
-
-
-
-
-
-

plugins/Full_CI_ZMQ/run_pt2_slave.irp.f

@@ -1,172 +0,0 @@
-
-subroutine run_pt2_slave(thread,iproc,energy)
-  use f77_zmq
-  use selection_types
-  implicit none
-
-  double precision, intent(in)    :: energy(N_states_diag)
-  integer,  intent(in)            :: thread, iproc
-  integer                        :: rc, i
-
-  integer                        :: worker_id, task_id(1), ctask, ltask
-  character*(512)                :: task
-
-  integer(ZMQ_PTR),external      :: new_zmq_to_qp_run_socket
-  integer(ZMQ_PTR)               :: zmq_to_qp_run_socket
-
-  integer(ZMQ_PTR), external     :: new_zmq_push_socket
-  integer(ZMQ_PTR)               :: zmq_socket_push
-
-  type(selection_buffer) :: buf, buf2
-  logical :: done
-
-  double precision :: pt2(N_states)
-  double precision,allocatable :: pt2_detail(:,:)
-  integer :: index
-  integer :: Nindex
-
-  allocate(pt2_detail(N_states, N_det_generators))
-  zmq_to_qp_run_socket = new_zmq_to_qp_run_socket()
-  zmq_socket_push      = new_zmq_push_socket(thread)
-  call connect_to_taskserver(zmq_to_qp_run_socket,worker_id,thread)
-  if(worker_id == -1) then
-    print *, "WORKER -1"
-    call end_zmq_to_qp_run_socket(zmq_to_qp_run_socket)
-    call end_zmq_push_socket(zmq_socket_push,thread)
-    return
-  end if
-  buf%N = 0
-  ctask = 1
-  Nindex=1
-  pt2 = 0d0
-  pt2_detail = 0d0
-  do
-    call get_task_from_taskserver(zmq_to_qp_run_socket,worker_id, task_id(ctask), task)
-
-    done = task_id(ctask) == 0 
-    if (done) then
-      ctask = ctask - 1
-    else
-      integer :: i_generator, i_i_generator, N, subset
-      read (task,*) subset, index
-      
-      !!!!!
-      N=1
-      !!!!!
-      if(buf%N == 0) then
-        ! Only first time 
-        call create_selection_buffer(N, N*2, buf)
-        call create_selection_buffer(N, N*3, buf2)
-      else
-        if(N /= buf%N) stop "N changed... wtf man??"
-      end if
-      do i_i_generator=1, Nindex
-        i_generator = index
-        call select_connected(i_generator,energy,pt2_detail(1, i_i_generator),buf,subset)
-        pt2(:) += pt2_detail(:, i_generator)
-      enddo
-    endif
-
-    if(done .or. ctask == size(task_id)) then
-      if(buf%N == 0 .and. ctask > 0) stop "uninitialized selection_buffer"
-      do i=1, ctask
-         call task_done_to_taskserver(zmq_to_qp_run_socket,worker_id,task_id(i))
-      end do
-      if(ctask > 0) then
-        call push_pt2_results(zmq_socket_push, Nindex, index, pt2_detail, task_id(1), ctask)
-        do i=1,buf%cur
-          call add_to_selection_buffer(buf2, buf%det(1,1,i), buf%val(i))
-        enddo
-        call sort_selection_buffer(buf2)
-        buf%mini = buf2%mini
-        pt2 = 0d0
-        pt2_detail(:,:Nindex) = 0d0
-        buf%cur = 0
-      end if
-      ctask = 0
-    end if
-
-    if(done) exit
-    ctask = ctask + 1
-  end do
-  call disconnect_from_taskserver(zmq_to_qp_run_socket,zmq_socket_push,worker_id)
-  call end_zmq_to_qp_run_socket(zmq_to_qp_run_socket)
-  call end_zmq_push_socket(zmq_socket_push,thread)
-end subroutine
-
-
-subroutine push_pt2_results(zmq_socket_push, N, index, pt2_detail, task_id, ntask)
-  use f77_zmq
-  use selection_types
-  implicit none
-
-  integer(ZMQ_PTR), intent(in)   :: zmq_socket_push
-  double precision, intent(in)   :: pt2_detail(N_states, N_det_generators)
-  integer, intent(in) :: ntask, N, index, task_id(*)
-  integer :: rc
-
-
-  rc = f77_zmq_send( zmq_socket_push, N, 4, ZMQ_SNDMORE)
-  if(rc /= 4) stop "push"
-
-  rc = f77_zmq_send( zmq_socket_push, index, 4, ZMQ_SNDMORE)
-  if(rc /= 4*N) stop "push"
-
-
-  rc = f77_zmq_send( zmq_socket_push, pt2_detail, 8*N_states*N, ZMQ_SNDMORE)
-  if(rc /= 8*N_states*N) stop "push"
-
-  rc = f77_zmq_send( zmq_socket_push, ntask, 4, ZMQ_SNDMORE)
-  if(rc /= 4) stop "push"
-
-  rc = f77_zmq_send( zmq_socket_push, task_id, ntask*4, 0)
-  if(rc /= 4*ntask) stop "push"
-
-! Activate is zmq_socket_push is a REQ
-  character*(2) :: ok
-  rc = f77_zmq_recv( zmq_socket_push, ok, 2, 0)
-end subroutine
-
-
-subroutine pull_pt2_results(zmq_socket_pull, N, index, pt2_detail, task_id, ntask)
-  use f77_zmq
-  use selection_types
-  implicit none
-  integer(ZMQ_PTR), intent(in)   :: zmq_socket_pull
-  double precision, intent(inout) :: pt2_detail(N_states, N_det_generators)
-  integer, intent(out) :: index
-  integer, intent(out) :: N, ntask, task_id(*)
-  integer :: rc, rn, i
-
-  rc = f77_zmq_recv( zmq_socket_pull, N, 4, 0)
-  if(rc /= 4) stop "pull"
-
-  rc = f77_zmq_recv( zmq_socket_pull, index, 4, 0)
-  if(rc /= 4*N) stop "pull"
-
-  rc = f77_zmq_recv( zmq_socket_pull, pt2_detail, N_states*8*N, 0)
-  if(rc /= 8*N_states*N) stop "pull"
-
-  rc = f77_zmq_recv( zmq_socket_pull, ntask, 4, 0)
-  if(rc /= 4) stop "pull"
-
-  rc = f77_zmq_recv( zmq_socket_pull, task_id, ntask*4, 0)
-  if(rc /= 4*ntask) stop "pull"
-
-! Activate is zmq_socket_pull is a REP
-  rc = f77_zmq_send( zmq_socket_pull, 'ok', 2, 0)
-
-  do i=N+1,N_det_generators
-    pt2_detail(1:N_states,i) = 0.d0
-  enddo
-end subroutine
- 
- 
-BEGIN_PROVIDER [ double precision, pt2_workload, (N_det_generators) ]
-  integer :: i
-  do i=1,N_det_generators
-    pt2_workload(i) = dfloat(N_det_generators - i + 1)**2
-  end do
-  pt2_workload = pt2_workload / sum(pt2_workload)
-END_PROVIDER
-            

plugins/Full_CI_ZMQ/run_selection_slave.irp.f

@@ -26,6 +26,7 @@ subroutine run_selection_slave(thread,iproc,energy)
   call connect_to_taskserver(zmq_to_qp_run_socket,worker_id,thread)
   if(worker_id == -1) then
     print *, "WORKER -1"
+    !call disconnect_from_taskserver(zmq_to_qp_run_socket,zmq_socket_push,worker_id)
     call end_zmq_to_qp_run_socket(zmq_to_qp_run_socket)
     call end_zmq_push_socket(zmq_socket_push,thread)
     return
@@ -40,8 +41,8 @@ subroutine run_selection_slave(thread,iproc,energy)
     if (done) then
       ctask = ctask - 1
     else
-      integer :: i_generator, N
+      integer :: i_generator, i_generator_start, i_generator_max, step, N
-      read(task,*) i_generator, N
+      read (task,*) i_generator_start, i_generator_max, step, N
       if(buf%N == 0) then
         ! Only first time 
         call create_selection_buffer(N, N*2, buf)
@@ -49,7 +50,11 @@ subroutine run_selection_slave(thread,iproc,energy)
       else
         if(N /= buf%N) stop "N changed... wtf man??"
       end if
-      call select_connected(i_generator,energy,pt2,buf,0)
+      !print *, "psi_selectors_coef ", psi_selectors_coef(N_det_selectors-5:N_det_selectors, 1)
+      !call debug_det(psi_selectors(1,1,N_det_selectors), N_int)
+      do i_generator=i_generator_start,i_generator_max,step
+        call select_connected(i_generator,energy,pt2,buf)
+      enddo
     endif
 
     if(done .or. ctask == size(task_id)) then
@@ -110,7 +115,7 @@ subroutine push_selection_results(zmq_socket_push, pt2, b, task_id, ntask)
   if(rc /= 4*ntask) stop "push"
 
 ! Activate is zmq_socket_push is a REQ
-  rc = f77_zmq_recv( zmq_socket_push, task_id(1), ntask*4, 0)
+!  rc = f77_zmq_recv( zmq_socket_push, task_id(1), ntask*4, 0)
 end subroutine
 
 
@@ -144,7 +149,7 @@ subroutine pull_selection_results(zmq_socket_pull, pt2, val, det, N, task_id, nt
   if(rc /= 4*ntask) stop "pull"
 
 ! Activate is zmq_socket_pull is a REP
-  rc = f77_zmq_send( zmq_socket_pull, task_id(1), ntask*4, 0)
+!  rc = f77_zmq_send( zmq_socket_pull, task_id(1), ntask*4, 0)
 end subroutine
  
  

plugins/Full_CI_ZMQ/selection_buffer.irp.f

@@ -27,7 +27,7 @@ subroutine add_to_selection_buffer(b, det, val)
 
   if(dabs(val) >= b%mini) then
     b%cur += 1
-    b%det(1:N_int,1:2,b%cur) = det(1:N_int,1:2)
+    b%det(:,:,b%cur) = det(:,:)
     b%val(b%cur) = val
     if(b%cur == size(b%val)) then
       call sort_selection_buffer(b)
@@ -41,33 +41,29 @@ subroutine sort_selection_buffer(b)
   implicit none
 
   type(selection_buffer), intent(inout) :: b
-  double precision, allocatable::  absval(:)
+  double precision, allocatable :: vals(:), absval(:)
   integer, allocatable :: iorder(:)
-  double precision, pointer :: vals(:)
+  integer(bit_kind), allocatable :: detmp(:,:,:)
-  integer(bit_kind), pointer :: detmp(:,:,:)
   integer :: i, nmwen
   logical, external :: detEq
   nmwen = min(b%N, b%cur)
 
 
-  allocate(iorder(b%cur), detmp(N_int, 2, size(b%det,3)), absval(b%cur), vals(size(b%val)))
+  allocate(iorder(b%cur), detmp(N_int, 2, nmwen), absval(b%cur), vals(nmwen))
   absval = -dabs(b%val(:b%cur))
   do i=1,b%cur
     iorder(i) = i
   end do
-  ! Optimal for almost sorted data
+  call dsort(absval, iorder, b%cur)
-  call insertion_dsort(absval, iorder, b%cur)
+
   do i=1, nmwen
-    detmp(1:N_int,1,i) = b%det(1:N_int,1,iorder(i))
+    detmp(:,:,i) = b%det(:,:,iorder(i))
-    detmp(1:N_int,2,i) = b%det(1:N_int,2,iorder(i))
     vals(i) = b%val(iorder(i))
   end do
-  do i=nmwen+1, size(vals)
+  b%det(:,:,:nmwen) = detmp(:,:,:)
-    vals(i) = 0.d0
+  b%det(:,:,nmwen+1:) = 0_bit_kind
-  enddo
+  b%val(:nmwen) = vals(:)
-  deallocate(b%det, b%val)
+  b%val(nmwen+1:) = 0d0
-  b%det => detmp
-  b%val => vals
   b%mini = max(b%mini,dabs(b%val(b%N)))
   b%cur = nmwen
 end subroutine

plugins/Full_CI_ZMQ/selection_davidson_slave.irp.f

@@ -12,8 +12,8 @@ program selection_slave
 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 H_apply_buffer_allocated mo_bielec_integrals_in_map psi_det_generators psi_coef_generators psi_det_sorted_bit psi_selectors n_det_generators n_states generators_bitmask zmq_context mo_mono_elec_integral
-   PROVIDE pt2_e0_denominator mo_tot_num N_int fragment_count
+!   PROVIDE pt2_e0_denominator mo_tot_num N_int
 end
 
 subroutine run_wf
@@ -23,19 +23,16 @@ 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(4)
+  character*(64) :: states(2)
   integer :: rc, i
-  logical :: force_update
   
   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()
-  force_update = .True.
 
   do
 
@@ -55,7 +52,7 @@ subroutine run_wf
   
       !$OMP PARALLEL PRIVATE(i)
       i = omp_get_thread_num()
-      call run_selection_slave(0,i,energy)
+      call selection_slave_tcp(i, energy)
       !$OMP END PARALLEL
       print *,  'Selection done'
 
@@ -65,34 +62,46 @@ subroutine run_wf
       ! --------
 
       print *,  'Davidson'
-      call davidson_miniserver_get(force_update)
+      call davidson_miniserver_get()
-      force_update = .False.
       !$OMP PARALLEL PRIVATE(i)
       i = omp_get_thread_num()
       call davidson_slave_tcp(i)
       !$OMP END PARALLEL
       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
 
+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_ZMQ/selection_slave.irp.f

@@ -13,7 +13,7 @@ end
 
 subroutine provide_everything
   PROVIDE H_apply_buffer_allocated mo_bielec_integrals_in_map psi_det_generators psi_coef_generators psi_det_sorted_bit psi_selectors n_det_generators n_states generators_bitmask zmq_context
-   PROVIDE pt2_e0_denominator mo_tot_num N_int fragment_count
+   PROVIDE pt2_e0_denominator mo_tot_num N_int
 end
 
 subroutine run_wf
@@ -60,6 +60,28 @@ subroutine run_wf
   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

plugins/Full_CI_ZMQ/selection_types.f90

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

plugins/Full_CI_ZMQ/target_pt2_ratio_zmq.irp.f

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

plugins/Full_CI_ZMQ/target_pt2_zmq.irp.f

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

plugins/Full_CI_ZMQ/zmq_selection.irp.f

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

plugins/Generators_CAS/Generators_full/.gitignore

@@ -1,25 +0,0 @@
-# Automatically created by /home/razoa/quantum_package/scripts/module/module_handler.py 
-IRPF90_temp
-IRPF90_man
-irpf90_entities
-tags
-irpf90.make
-Makefile
-Makefile.depend
-build.ninja
-.ninja_log
-.ninja_deps
-ezfio_interface.irp.f
-Ezfio_files
-Determinants
-Integrals_Monoelec
-MO_Basis
-Utils
-Pseudo
-Bitmask
-AO_Basis
-Electrons
-MOGuess
-Nuclei
-Hartree_Fock
-Integrals_Bielec

plugins/Generators_CAS/Generators_full/NEEDED_CHILDREN_MODULES

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

plugins/Generators_CAS/Generators_full/README.rst

@@ -1,61 +0,0 @@
-======================
-Generators_full Module
-======================
-
-All the determinants of the wave function are generators. In this way, the Full CI
-space is explored.
-
-Needed Modules
-==============
-
-.. Do not edit this section It was auto-generated
-.. by the `update_README.py` script.
-
-.. image:: tree_dependency.png
-
-* `Determinants <http://github.com/LCPQ/quantum_package/tree/master/src/Determinants>`_
-* `Hartree_Fock <http://github.com/LCPQ/quantum_package/tree/master/src/Hartree_Fock>`_
-
-Needed Modules
-==============
-.. Do not edit this section It was auto-generated
-.. by the `update_README.py` script.
-
-
-.. image:: tree_dependency.png
-
-* `Determinants <http://github.com/LCPQ/quantum_package/tree/master/src/Determinants>`_
-* `Hartree_Fock <http://github.com/LCPQ/quantum_package/tree/master/plugins/Hartree_Fock>`_
-
-Documentation
-=============
-.. Do not edit this section It was auto-generated
-.. by the `update_README.py` script.
-
-
-`degree_max_generators <http://github.com/LCPQ/quantum_package/tree/master/plugins/Generators_full/generators.irp.f#L43>`_
-  Max degree of excitation (respect to HF) of the generators
-
-
-`n_det_generators <http://github.com/LCPQ/quantum_package/tree/master/plugins/Generators_full/generators.irp.f#L3>`_
-  For Single reference wave functions, the number of generators is 1 : the
-  Hartree-Fock determinant
-
-
-`psi_coef_generators <http://github.com/LCPQ/quantum_package/tree/master/plugins/Generators_full/generators.irp.f#L26>`_
-  For Single reference wave functions, the generator is the
-  Hartree-Fock determinant
-
-
-`psi_det_generators <http://github.com/LCPQ/quantum_package/tree/master/plugins/Generators_full/generators.irp.f#L25>`_
-  For Single reference wave functions, the generator is the
-  Hartree-Fock determinant
-
-
-`select_max <http://github.com/LCPQ/quantum_package/tree/master/plugins/Generators_full/generators.irp.f#L66>`_
-  Memo to skip useless selectors
-
-
-`size_select_max <http://github.com/LCPQ/quantum_package/tree/master/plugins/Generators_full/generators.irp.f#L58>`_
-  Size of the select_max array
-

plugins/Generators_CAS/Generators_full/generators.irp.f

@@ -1,75 +0,0 @@
-use bitmasks
-
-BEGIN_PROVIDER [ integer, N_det_generators ]
- implicit none
- BEGIN_DOC
- ! For Single reference wave functions, the number of generators is 1 : the
- ! Hartree-Fock determinant
- END_DOC
- integer :: i
- double precision :: norm
- call write_time(output_determinants)
- norm = 0.d0
- N_det_generators = N_det
- do i=1,N_det
-   norm = norm + psi_average_norm_contrib_sorted(i)
-   if (norm >= threshold_generators) then
-     N_det_generators = i
-     exit
-   endif
- enddo
- N_det_generators = max(N_det_generators,1)
- call write_int(output_determinants,N_det_generators,'Number of generators')
-END_PROVIDER
-
- BEGIN_PROVIDER [ integer(bit_kind), psi_det_generators, (N_int,2,psi_det_size) ]
-&BEGIN_PROVIDER [ double precision, psi_coef_generators, (psi_det_size,N_states) ]
- implicit none
- BEGIN_DOC
- ! For Single reference wave functions, the generator is the
- ! Hartree-Fock determinant
- END_DOC
- integer                        :: i, k
- psi_coef_generators = 0.d0
- psi_det_generators  = 0_bit_kind
- do i=1,N_det_generators
-   do k=1,N_int
-     psi_det_generators(k,1,i) = psi_det_sorted(k,1,i)
-     psi_det_generators(k,2,i) = psi_det_sorted(k,2,i)
-   enddo
-   psi_coef_generators(i,:) = psi_coef_sorted(i,:)
- enddo
-
-END_PROVIDER
-
-BEGIN_PROVIDER [integer, degree_max_generators]
- implicit none
- BEGIN_DOC
-! Max degree of excitation (respect to HF) of the generators
- END_DOC
- integer :: i,degree
-  degree_max_generators = 0
-  do i = 1, N_det_generators
-   call get_excitation_degree(HF_bitmask,psi_det_generators(1,1,i),degree,N_int)
-   if(degree .gt. degree_max_generators)then
-    degree_max_generators = degree
-   endif
-  enddo
-END_PROVIDER 
-
-BEGIN_PROVIDER [ integer, size_select_max]
- implicit none
- BEGIN_DOC
- ! Size of the select_max array
- END_DOC
- size_select_max = 10000
-END_PROVIDER
-
-BEGIN_PROVIDER [ double precision, select_max, (size_select_max) ]
- implicit none
- BEGIN_DOC
- ! Memo to skip useless selectors
- END_DOC
- select_max = huge(1.d0)
-END_PROVIDER
-

plugins/Generators_CAS/generators.irp.f

@@ -9,14 +9,14 @@ BEGIN_PROVIDER [ integer, N_det_generators ]
   logical                        :: good
   call write_time(output_determinants)
   N_det_generators = 0
-  do i=1,N_det_ref
+  do i=1,N_det
     do l=1,n_cas_bitmask
       good = .True.
       do k=1,N_int
         good = good .and. (                                          &
-            iand(not(cas_bitmask(k,1,l)), psi_ref(k,1,i)) ==         &
+            iand(not(cas_bitmask(k,1,l)), psi_det(k,1,i)) ==         &
             iand(not(cas_bitmask(k,1,l)), HF_bitmask(k,1)) ) .and. ( &
-            iand(not(cas_bitmask(k,2,l)), psi_ref(k,2,i)) ==         &
+            iand(not(cas_bitmask(k,2,l)), psi_det(k,2,i)) ==         &
             iand(not(cas_bitmask(k,2,l)), HF_bitmask(k,2)) )
       enddo
       if (good) then
@@ -41,14 +41,14 @@ END_PROVIDER
   integer                        :: i, k, l, m
   logical                        :: good
   m=0
-  do i=1,N_det_ref
+  do i=1,N_det
     do l=1,n_cas_bitmask
       good = .True.
       do k=1,N_int
         good = good .and. (                                         &
-            iand(not(cas_bitmask(k,1,l)), psi_ref(k,1,i)) ==         &
+            iand(not(cas_bitmask(k,1,l)), psi_det(k,1,i)) ==         &
             iand(not(cas_bitmask(k,1,l)), HF_bitmask(k,1)) .and. (   &
-            iand(not(cas_bitmask(k,2,l)), psi_ref(k,2,i)) ==         &
+            iand(not(cas_bitmask(k,2,l)), psi_det(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_ref(k,1,i)
+        psi_det_generators(k,1,m) = psi_det(k,1,i)
-        psi_det_generators(k,2,m) = psi_ref(k,2,i)
+        psi_det_generators(k,2,m) = psi_det(k,2,i)
       enddo
       psi_coef_generators(m,:) = psi_coef(m,:)
     endif

plugins/Hartree_Fock/localize_mos.irp.f

@@ -1,75 +0,0 @@
-program localize_mos
-  implicit none
-  integer :: rank, i,j,k
-  double precision, allocatable :: W(:,:)
-  double precision :: f, f_incr
-
-  allocate (W(ao_num,ao_num))
-
-  W = 0.d0
-  do k=1,elec_beta_num
-    do j=1,ao_num
-      do i=1,ao_num
-        W(i,j) = W(i,j) + mo_coef(i,k) * mo_coef(j,k)
-      enddo
-    enddo
-  enddo
-
-!  call svd_mo(ao_num,elec_beta_num,W, size(W,1), &
-!    mo_coef(1,1),size(mo_coef,1))
-  call cholesky_mo(ao_num,elec_beta_num,W, size(W,1), &
-    mo_coef(1,1),size(mo_coef,1),1.d-6,rank)
-  print *,  rank
-
-  if (elec_alpha_num>elec_alpha_num) then
-    W = 0.d0
-    do k=elec_beta_num+1,elec_alpha_num
-      do j=1,ao_num
-        do i=1,ao_num
-          W(i,j) = W(i,j) + mo_coef(i,k) * mo_coef(j,k)
-        enddo
-      enddo
-    enddo
-
-!    call svd_mo(ao_num,elec_alpha_num-elec_beta_num,W, size(W,1), &
-!    mo_coef(1,1),size(mo_coef,1))
-    call cholesky_mo(ao_num,elec_alpha_num-elec_beta_num,W, size(W,1), &
-      mo_coef(1,elec_beta_num+1),size(mo_coef,1),1.d-6,rank)
-    print *,  rank
-  endif
-
-  W = 0.d0
-  do k=elec_alpha_num+1,mo_tot_num
-    do j=1,ao_num
-      do i=1,ao_num
-        W(i,j) = W(i,j) + mo_coef(i,k) * mo_coef(j,k)
-      enddo
-    enddo
-  enddo
-
-!  call svd_mo(ao_num,mo_tot_num-elec_alpha_num,W, size(W,1), &
-!    mo_coef(1,1),size(mo_coef,1))
-  call cholesky_mo(ao_num,mo_tot_num-elec_alpha_num,W, size(W,1), &
-    mo_coef(1,elec_alpha_num+1),size(mo_coef,1),1.d-6,rank)
-  print *,  rank
-  mo_label = "Localized"
-
-  TOUCH mo_coef
-
-  W(1:ao_num,1:mo_tot_num) = mo_coef(1:ao_num,1:mo_tot_num)
-  integer :: iorder(mo_tot_num)
-  double precision :: s(mo_tot_num), swap(ao_num)
-  do k=1,mo_tot_num
-    iorder(k) = k
-    s(k) = Fock_matrix_diag_mo(k)
-  enddo
-  call dsort(s(1),iorder(1),elec_beta_num)
-  call dsort(s(elec_beta_num+1),iorder(elec_beta_num+1),elec_alpha_num-elec_beta_num)
-  call dsort(s(elec_alpha_num+1),iorder(elec_alpha_num+1),mo_tot_num-elec_alpha_num)
-  do k=1,mo_tot_num
-    mo_coef(1:ao_num,k) = W(1:ao_num,iorder(k))
-    print *,  k, s(k)
-  enddo
-  call save_mos
-
-end

plugins/Integrals_erf/EZFIO.cfg

@@ -1,34 +0,0 @@
-[disk_access_ao_integrals_erf]
-type: Disk_access
-doc: Read/Write AO integrals with the long range interaction from/to disk [ Write | Read | None ] 
-interface: ezfio,provider,ocaml
-default: None
-
-
-[disk_access_mo_integrals_erf]
-type: Disk_access
-doc: Read/Write MO integrals with the long range interaction from/to disk [ Write | Read | None ] 
-interface: ezfio,provider,ocaml
-default: None
-
-[ao_integrals_threshold]
-type: Threshold
-doc: If |<pq|rs>| < ao_integrals_threshold then <pq|rs> is zero
-interface: ezfio,provider,ocaml
-default: 1.e-15
-ezfio_name: threshold_ao
-
-[mo_integrals_threshold]
-type: Threshold
-doc: If |<ij|kl>| < ao_integrals_threshold then <pq|rs> is zero
-interface: ezfio,provider,ocaml
-default: 1.e-15
-ezfio_name: threshold_mo
-
-[mu_erf]
-type: double precision
-doc: cutting of the interaction in the range separated model
-interface: ezfio,provider,ocaml
-default: 0.5
-ezfio_name: mu_erf
-

plugins/Integrals_erf/NEEDED_CHILDREN_MODULES

@@ -1 +0,0 @@
-Pseudo Bitmask ZMQ Integrals_Bielec

plugins/Integrals_erf/ao_bi_integrals_erf.irp.f

@@ -1,570 +0,0 @@
-double precision function ao_bielec_integral_erf(i,j,k,l)
-  implicit none
-  BEGIN_DOC
-  !  integral of the AO basis <ik|jl> or (ij|kl)
-  !     i(r1) j(r1) 1/r12 k(r2) l(r2)
-  END_DOC
-
-  integer,intent(in)             :: i,j,k,l
-  integer                        :: p,q,r,s
-  double precision               :: I_center(3),J_center(3),K_center(3),L_center(3)
-  integer                        :: num_i,num_j,num_k,num_l,dim1,I_power(3),J_power(3),K_power(3),L_power(3)
-  double precision               :: integral
-  include 'Utils/constants.include.F'
-  double precision               :: P_new(0:max_dim,3),P_center(3),fact_p,pp
-  double precision               :: Q_new(0:max_dim,3),Q_center(3),fact_q,qq
-  integer                        :: iorder_p(3), iorder_q(3)
-  double precision               :: ao_bielec_integral_schwartz_accel_erf
-  
-   if (ao_prim_num(i) * ao_prim_num(j) * ao_prim_num(k) * ao_prim_num(l) > 1024 ) then
-     ao_bielec_integral_erf = ao_bielec_integral_schwartz_accel_erf(i,j,k,l)
-     return
-   endif
-
-  dim1 = n_pt_max_integrals
-  
-  num_i = ao_nucl(i)
-  num_j = ao_nucl(j)
-  num_k = ao_nucl(k)
-  num_l = ao_nucl(l)
-  ao_bielec_integral_erf = 0.d0
-  
-  if (num_i /= num_j .or. num_k /= num_l .or. num_j /= num_k)then
-    do p = 1, 3
-      I_power(p) = ao_power(i,p)
-      J_power(p) = ao_power(j,p)
-      K_power(p) = ao_power(k,p)
-      L_power(p) = ao_power(l,p)
-      I_center(p) = nucl_coord(num_i,p)
-      J_center(p) = nucl_coord(num_j,p)
-      K_center(p) = nucl_coord(num_k,p)
-      L_center(p) = nucl_coord(num_l,p)
-    enddo
-    
-    double precision               :: coef1, coef2, coef3, coef4
-    double precision               :: p_inv,q_inv
-    double precision               :: general_primitive_integral_erf
-
-    do p = 1, ao_prim_num(i)
-      coef1 = ao_coef_normalized_ordered_transp(p,i)
-      do q = 1, ao_prim_num(j)
-        coef2 = coef1*ao_coef_normalized_ordered_transp(q,j)
-        call give_explicit_poly_and_gaussian(P_new,P_center,pp,fact_p,iorder_p,&
-            ao_expo_ordered_transp(p,i),ao_expo_ordered_transp(q,j),                 &
-            I_power,J_power,I_center,J_center,dim1)
-        p_inv = 1.d0/pp
-        do r = 1, ao_prim_num(k)
-          coef3 = coef2*ao_coef_normalized_ordered_transp(r,k)
-          do s = 1, ao_prim_num(l)
-            coef4 = coef3*ao_coef_normalized_ordered_transp(s,l)
-            call give_explicit_poly_and_gaussian(Q_new,Q_center,qq,fact_q,iorder_q,&
-                ao_expo_ordered_transp(r,k),ao_expo_ordered_transp(s,l),             &
-                K_power,L_power,K_center,L_center,dim1)
-            q_inv = 1.d0/qq
-            integral = general_primitive_integral_erf(dim1,              &
-                P_new,P_center,fact_p,pp,p_inv,iorder_p,             &
-                Q_new,Q_center,fact_q,qq,q_inv,iorder_q)
-            ao_bielec_integral_erf = ao_bielec_integral_erf +  coef4 * integral
-          enddo ! s
-        enddo  ! r
-      enddo   ! q
-    enddo    ! p
-    
-  else
-    
-    do p = 1, 3
-      I_power(p) = ao_power(i,p)
-      J_power(p) = ao_power(j,p)
-      K_power(p) = ao_power(k,p)
-      L_power(p) = ao_power(l,p)
-    enddo
-    double  precision              :: ERI_erf
-
-    do p = 1, ao_prim_num(i)
-      coef1 = ao_coef_normalized_ordered_transp(p,i)
-      do q = 1, ao_prim_num(j)
-        coef2 = coef1*ao_coef_normalized_ordered_transp(q,j)
-        do r = 1, ao_prim_num(k)
-          coef3 = coef2*ao_coef_normalized_ordered_transp(r,k)
-          do s = 1, ao_prim_num(l)
-            coef4 = coef3*ao_coef_normalized_ordered_transp(s,l)
-            integral = ERI_erf(                                          &
-                ao_expo_ordered_transp(p,i),ao_expo_ordered_transp(q,j),ao_expo_ordered_transp(r,k),ao_expo_ordered_transp(s,l),&
-                I_power(1),J_power(1),K_power(1),L_power(1),         &
-                I_power(2),J_power(2),K_power(2),L_power(2),         &
-                I_power(3),J_power(3),K_power(3),L_power(3))
-            ao_bielec_integral_erf = ao_bielec_integral_erf + coef4 * integral
-          enddo ! s
-        enddo  ! r
-      enddo   ! q
-    enddo    ! p
-    
-  endif
-  
-end
-
-double precision function ao_bielec_integral_schwartz_accel_erf(i,j,k,l)
-  implicit none
-  BEGIN_DOC
-  !  integral of the AO basis <ik|jl> or (ij|kl)
-  !     i(r1) j(r1) 1/r12 k(r2) l(r2)
-  END_DOC
-  integer,intent(in)             :: i,j,k,l
-  integer                        :: p,q,r,s
-  double precision               :: I_center(3),J_center(3),K_center(3),L_center(3)
-  integer                        :: num_i,num_j,num_k,num_l,dim1,I_power(3),J_power(3),K_power(3),L_power(3)
-  double precision               :: integral
-  include 'Utils/constants.include.F'
-  double precision               :: P_new(0:max_dim,3),P_center(3),fact_p,pp
-  double precision               :: Q_new(0:max_dim,3),Q_center(3),fact_q,qq
-  integer                        :: iorder_p(3), iorder_q(3)
-  double precision, allocatable  :: schwartz_kl(:,:)
-  double precision               :: schwartz_ij
-  
-  dim1 = n_pt_max_integrals
-  
-  num_i = ao_nucl(i)
-  num_j = ao_nucl(j)
-  num_k = ao_nucl(k)
-  num_l = ao_nucl(l)
-  ao_bielec_integral_schwartz_accel_erf = 0.d0
-  double precision               :: thr
-  thr = ao_integrals_threshold*ao_integrals_threshold
-  
-  allocate(schwartz_kl(0:ao_prim_num(l),0:ao_prim_num(k)))
-
-
-  if (num_i /= num_j .or. num_k /= num_l .or. num_j /= num_k)then
-    do p = 1, 3
-      I_power(p) = ao_power(i,p)
-      J_power(p) = ao_power(j,p)
-      K_power(p) = ao_power(k,p)
-      L_power(p) = ao_power(l,p)
-      I_center(p) = nucl_coord(num_i,p)
-      J_center(p) = nucl_coord(num_j,p)
-      K_center(p) = nucl_coord(num_k,p)
-      L_center(p) = nucl_coord(num_l,p)
-    enddo
-    
-    schwartz_kl(0,0) = 0.d0
-    do r = 1, ao_prim_num(k)
-      coef1 = ao_coef_normalized_ordered_transp(r,k)*ao_coef_normalized_ordered_transp(r,k)
-      schwartz_kl(0,r) = 0.d0
-      do s = 1, ao_prim_num(l)
-        coef2 = coef1 * ao_coef_normalized_ordered_transp(s,l) * ao_coef_normalized_ordered_transp(s,l)
-        call give_explicit_poly_and_gaussian(Q_new,Q_center,qq,fact_q,iorder_q,&
-            ao_expo_ordered_transp(r,k),ao_expo_ordered_transp(s,l),                 &
-            K_power,L_power,K_center,L_center,dim1)
-        q_inv = 1.d0/qq
-        schwartz_kl(s,r) = general_primitive_integral_erf(dim1,          &
-            Q_new,Q_center,fact_q,qq,q_inv,iorder_q,                 &
-            Q_new,Q_center,fact_q,qq,q_inv,iorder_q)      &
-            * coef2 
-        schwartz_kl(0,r) = max(schwartz_kl(0,r),schwartz_kl(s,r))
-      enddo
-      schwartz_kl(0,0) = max(schwartz_kl(0,r),schwartz_kl(0,0))
-    enddo
-
-    do p = 1, ao_prim_num(i)
-      double precision               :: coef1
-      coef1 = ao_coef_normalized_ordered_transp(p,i)
-      do q = 1, ao_prim_num(j)
-        double precision               :: coef2
-        coef2 = coef1*ao_coef_normalized_ordered_transp(q,j)
-        double precision               :: p_inv,q_inv
-        call give_explicit_poly_and_gaussian(P_new,P_center,pp,fact_p,iorder_p,&
-            ao_expo_ordered_transp(p,i),ao_expo_ordered_transp(q,j),                 &
-            I_power,J_power,I_center,J_center,dim1)
-        p_inv = 1.d0/pp
-        schwartz_ij = general_primitive_integral_erf(dim1,               &
-            P_new,P_center,fact_p,pp,p_inv,iorder_p,                 &
-            P_new,P_center,fact_p,pp,p_inv,iorder_p) *               &
-            coef2*coef2
-        if (schwartz_kl(0,0)*schwartz_ij < thr) then
-           cycle
-        endif
-        do r = 1, ao_prim_num(k)
-          if (schwartz_kl(0,r)*schwartz_ij < thr) then
-             cycle
-          endif
-          double precision               :: coef3
-          coef3 = coef2*ao_coef_normalized_ordered_transp(r,k)
-          do s = 1, ao_prim_num(l)
-            double precision               :: coef4
-            if (schwartz_kl(s,r)*schwartz_ij < thr) then
-               cycle
-            endif
-            coef4 = coef3*ao_coef_normalized_ordered_transp(s,l)
-            double precision               :: general_primitive_integral_erf
-            call give_explicit_poly_and_gaussian(Q_new,Q_center,qq,fact_q,iorder_q,&
-                ao_expo_ordered_transp(r,k),ao_expo_ordered_transp(s,l),             &
-                K_power,L_power,K_center,L_center,dim1)
-            q_inv = 1.d0/qq
-            integral = general_primitive_integral_erf(dim1,              &
-                P_new,P_center,fact_p,pp,p_inv,iorder_p,             &
-                Q_new,Q_center,fact_q,qq,q_inv,iorder_q)
-            ao_bielec_integral_schwartz_accel_erf = ao_bielec_integral_schwartz_accel_erf + coef4 * integral
-          enddo ! s
-        enddo  ! r
-      enddo   ! q
-    enddo    ! p
-    
-  else
-    
-    do p = 1, 3
-      I_power(p) = ao_power(i,p)
-      J_power(p) = ao_power(j,p)
-      K_power(p) = ao_power(k,p)
-      L_power(p) = ao_power(l,p)
-    enddo
-    double  precision              :: ERI_erf
-
-    schwartz_kl(0,0) = 0.d0
-    do r = 1, ao_prim_num(k)
-      coef1 = ao_coef_normalized_ordered_transp(r,k)*ao_coef_normalized_ordered_transp(r,k)
-      schwartz_kl(0,r) = 0.d0
-      do s = 1, ao_prim_num(l)
-        coef2 = coef1*ao_coef_normalized_ordered_transp(s,l)*ao_coef_normalized_ordered_transp(s,l)
-        schwartz_kl(s,r) = ERI_erf(                                      &
-            ao_expo_ordered_transp(r,k),ao_expo_ordered_transp(s,l),ao_expo_ordered_transp(r,k),ao_expo_ordered_transp(s,l),&
-            K_power(1),L_power(1),K_power(1),L_power(1),             &
-            K_power(2),L_power(2),K_power(2),L_power(2),             &
-            K_power(3),L_power(3),K_power(3),L_power(3)) * &
-            coef2
-        schwartz_kl(0,r) = max(schwartz_kl(0,r),schwartz_kl(s,r))
-      enddo
-      schwartz_kl(0,0) = max(schwartz_kl(0,r),schwartz_kl(0,0))
-    enddo
-
-    do p = 1, ao_prim_num(i)
-      coef1 = ao_coef_normalized_ordered_transp(p,i)
-      do q = 1, ao_prim_num(j)
-        coef2 = coef1*ao_coef_normalized_ordered_transp(q,j)
-        schwartz_ij = ERI_erf(                                          &
-                ao_expo_ordered_transp(p,i),ao_expo_ordered_transp(q,j),ao_expo_ordered_transp(p,i),ao_expo_ordered_transp(q,j),&
-                I_power(1),J_power(1),I_power(1),J_power(1),         &
-                I_power(2),J_power(2),I_power(2),J_power(2),         &
-                I_power(3),J_power(3),I_power(3),J_power(3))*coef2*coef2
-        if (schwartz_kl(0,0)*schwartz_ij < thr) then
-           cycle
-        endif
-        do r = 1, ao_prim_num(k)
-          if (schwartz_kl(0,r)*schwartz_ij < thr) then
-             cycle
-          endif
-          coef3 = coef2*ao_coef_normalized_ordered_transp(r,k)
-          do s = 1, ao_prim_num(l)
-            if (schwartz_kl(s,r)*schwartz_ij < thr) then
-               cycle
-            endif
-            coef4 = coef3*ao_coef_normalized_ordered_transp(s,l)
-            integral = ERI_erf(                                          &
-                ao_expo_ordered_transp(p,i),ao_expo_ordered_transp(q,j),ao_expo_ordered_transp(r,k),ao_expo_ordered_transp(s,l),&
-                I_power(1),J_power(1),K_power(1),L_power(1),         &
-                I_power(2),J_power(2),K_power(2),L_power(2),         &
-                I_power(3),J_power(3),K_power(3),L_power(3))
-            ao_bielec_integral_schwartz_accel_erf = ao_bielec_integral_schwartz_accel_erf +  coef4 * integral
-          enddo ! s
-        enddo  ! r
-      enddo   ! q
-    enddo    ! p
-    
-  endif
-  deallocate (schwartz_kl)
-  
-end
-
-
-subroutine compute_ao_bielec_integrals_erf(j,k,l,sze,buffer_value)
-  implicit none
-  use map_module
-  
-  BEGIN_DOC
-  ! Compute AO 1/r12 integrals for all i and fixed j,k,l
-  END_DOC
-  
-  include 'Utils/constants.include.F'
-  integer, intent(in)            :: j,k,l,sze
-  real(integral_kind), intent(out) :: buffer_value(sze)
-  double precision               :: ao_bielec_integral_erf
-  
-  integer                        :: i
-  
-  if (ao_overlap_abs(j,l) < thresh) then
-    buffer_value = 0._integral_kind
-    return
-  endif
-  if (ao_bielec_integral_erf_schwartz(j,l) < thresh ) then
-    buffer_value = 0._integral_kind
-    return
-  endif
-  
-  do i = 1, ao_num
-    if (ao_overlap_abs(i,k)*ao_overlap_abs(j,l) < thresh) then
-      buffer_value(i) = 0._integral_kind
-      cycle
-    endif
-    if (ao_bielec_integral_erf_schwartz(i,k)*ao_bielec_integral_erf_schwartz(j,l) < thresh ) then
-      buffer_value(i) = 0._integral_kind
-      cycle
-    endif
-    !DIR$ FORCEINLINE
-    buffer_value(i) = ao_bielec_integral_erf(i,k,j,l)
-  enddo
-  
-end
-
-double precision function general_primitive_integral_erf(dim,            &
-      P_new,P_center,fact_p,p,p_inv,iorder_p,                        &
-      Q_new,Q_center,fact_q,q,q_inv,iorder_q)
-  implicit none
-  BEGIN_DOC
-  ! Computes the integral <pq|rs> where p,q,r,s are Gaussian primitives
-  END_DOC
-  integer,intent(in)             :: dim
-  include 'Utils/constants.include.F'
-  double precision, intent(in)   :: P_new(0:max_dim,3),P_center(3),fact_p,p,p_inv
-  double precision, intent(in)   :: Q_new(0:max_dim,3),Q_center(3),fact_q,q,q_inv
-  integer, intent(in)            :: iorder_p(3)
-  integer, intent(in)            :: iorder_q(3)
-  
-  double precision               :: r_cut,gama_r_cut,rho,dist
-  double precision               :: dx(0:max_dim),Ix_pol(0:max_dim),dy(0:max_dim),Iy_pol(0:max_dim),dz(0:max_dim),Iz_pol(0:max_dim)
-  integer                        :: n_Ix,n_Iy,n_Iz,nx,ny,nz
-  double precision               :: bla
-  integer                        :: ix,iy,iz,jx,jy,jz,i
-  double precision               :: a,b,c,d,e,f,accu,pq,const
-  double precision               :: pq_inv, p10_1, p10_2, p01_1, p01_2,pq_inv_2
-  integer                        :: n_pt_tmp,n_pt_out, iorder
-  double precision               :: d1(0:max_dim),d_poly(0:max_dim),rint,d1_screened(0:max_dim)
-  
-  general_primitive_integral_erf = 0.d0
-  
-  !DIR$ ATTRIBUTES ALIGN : $IRP_ALIGN :: dx,Ix_pol,dy,Iy_pol,dz,Iz_pol
-  !DIR$ ATTRIBUTES ALIGN : $IRP_ALIGN :: d1, d_poly
-  
-  ! Gaussian Product
-  ! ----------------
-  double precision :: p_plus_q
-  p_plus_q = (p+q) * ((p*q)/(p+q) + mu_erf*mu_erf)/(mu_erf*mu_erf)
-  pq = p_inv*0.5d0*q_inv
-  
-  pq_inv = 0.5d0/p_plus_q
-  p10_1 = q*pq  ! 1/(2p)
-  p01_1 = p*pq  ! 1/(2q)
-  pq_inv_2 = pq_inv+pq_inv
-  p10_2 = pq_inv_2 * p10_1*q !0.5d0*q/(pq + p*p)
-  p01_2 = pq_inv_2 * p01_1*p !0.5d0*p/(q*q + pq)
-  
-  
-  accu = 0.d0
-  iorder = iorder_p(1)+iorder_q(1)+iorder_p(1)+iorder_q(1)
-  !DIR$ VECTOR ALIGNED
-  do ix=0,iorder
-    Ix_pol(ix) = 0.d0
-  enddo
-  n_Ix = 0
-  do ix = 0, iorder_p(1)
-    if (abs(P_new(ix,1)) < thresh) cycle
-    a = P_new(ix,1)
-    do jx = 0, iorder_q(1)
-      d = a*Q_new(jx,1)
-      if (abs(d) < thresh) cycle
-      !DEC$ FORCEINLINE
-      call give_polynom_mult_center_x(P_center(1),Q_center(1),ix,jx,p,q,iorder,pq_inv,pq_inv_2,p10_1,p01_1,p10_2,p01_2,dx,nx)
-      !DEC$ FORCEINLINE
-      call add_poly_multiply(dx,nx,d,Ix_pol,n_Ix)
-    enddo
-  enddo
-  if (n_Ix == -1) then
-    return
-  endif
-  iorder = iorder_p(2)+iorder_q(2)+iorder_p(2)+iorder_q(2)
-  !DIR$ VECTOR ALIGNED
-  do ix=0, iorder
-    Iy_pol(ix) = 0.d0
-  enddo
-  n_Iy = 0
-  do iy = 0, iorder_p(2)
-    if (abs(P_new(iy,2)) > thresh) then
-      b = P_new(iy,2)
-      do jy = 0, iorder_q(2)
-        e = b*Q_new(jy,2)
-        if (abs(e) < thresh) cycle
-        !DEC$ FORCEINLINE
-        call   give_polynom_mult_center_x(P_center(2),Q_center(2),iy,jy,p,q,iorder,pq_inv,pq_inv_2,p10_1,p01_1,p10_2,p01_2,dy,ny)
-        !DEC$ FORCEINLINE
-        call add_poly_multiply(dy,ny,e,Iy_pol,n_Iy)
-      enddo
-    endif
-  enddo
-  if (n_Iy == -1) then
-    return
-  endif
-  
-  iorder = iorder_p(3)+iorder_q(3)+iorder_p(3)+iorder_q(3)
-  do ix=0,iorder
-    Iz_pol(ix) = 0.d0
-  enddo
-  n_Iz = 0
-  do iz = 0, iorder_p(3)
-    if (abs(P_new(iz,3)) > thresh) then
-      c = P_new(iz,3)
-      do jz = 0, iorder_q(3)
-        f = c*Q_new(jz,3)
-        if (abs(f) < thresh) cycle
-        !DEC$ FORCEINLINE
-        call   give_polynom_mult_center_x(P_center(3),Q_center(3),iz,jz,p,q,iorder,pq_inv,pq_inv_2,p10_1,p01_1,p10_2,p01_2,dz,nz)
-        !DEC$ FORCEINLINE
-        call add_poly_multiply(dz,nz,f,Iz_pol,n_Iz)
-      enddo
-    endif
-  enddo
-  if (n_Iz == -1) then
-    return
-  endif
-  
-  rho = p*q *pq_inv_2  ! le rho qui va bien
-  dist =  (P_center(1) - Q_center(1))*(P_center(1) - Q_center(1)) +  &
-      (P_center(2) - Q_center(2))*(P_center(2) - Q_center(2)) +      &
-      (P_center(3) - Q_center(3))*(P_center(3) - Q_center(3))
-  const = dist*rho
-  
-  n_pt_tmp = n_Ix+n_Iy
-  do i=0,n_pt_tmp
-    d_poly(i)=0.d0
-  enddo
-  
-  !DEC$ FORCEINLINE
-  call multiply_poly(Ix_pol,n_Ix,Iy_pol,n_Iy,d_poly,n_pt_tmp)
-  if (n_pt_tmp == -1) then
-    return
-  endif
-  n_pt_out = n_pt_tmp+n_Iz
-  do i=0,n_pt_out
-    d1(i)=0.d0
-  enddo
-  
-  !DEC$ FORCEINLINE
-  call multiply_poly(d_poly ,n_pt_tmp ,Iz_pol,n_Iz,d1,n_pt_out)
-  double precision               :: rint_sum
-  accu = accu + rint_sum(n_pt_out,const,d1)
-  
-  ! change p+q in dsqrt
-  general_primitive_integral_erf = fact_p * fact_q * accu *pi_5_2*p_inv*q_inv/dsqrt(p_plus_q)
-end
-
-
-double precision function ERI_erf(alpha,beta,delta,gama,a_x,b_x,c_x,d_x,a_y,b_y,c_y,d_y,a_z,b_z,c_z,d_z)
-  implicit none
-  BEGIN_DOC
-  !  ATOMIC PRIMTIVE bielectronic integral between the 4 primitives :: 
-  !         primitive_1 = x1**(a_x) y1**(a_y) z1**(a_z) exp(-alpha * r1**2)
-  !         primitive_2 = x1**(b_x) y1**(b_y) z1**(b_z) exp(- beta * r1**2)
-  !         primitive_3 = x2**(c_x) y2**(c_y) z2**(c_z) exp(-delta * r2**2)
-  !         primitive_4 = x2**(d_x) y2**(d_y) z2**(d_z) exp(- gama * r2**2)
-  END_DOC
-  double precision, intent(in)   :: delta,gama,alpha,beta
-  integer, intent(in)            :: a_x,b_x,c_x,d_x,a_y,b_y,c_y,d_y,a_z,b_z,c_z,d_z
-  integer                        :: a_x_2,b_x_2,c_x_2,d_x_2,a_y_2,b_y_2,c_y_2,d_y_2,a_z_2,b_z_2,c_z_2,d_z_2
-  integer                        :: i,j,k,l,n_pt
-  integer                        :: n_pt_sup
-  double precision               :: p,q,denom,coeff
-  double precision               :: I_f
-  integer                        :: nx,ny,nz
-  include 'Utils/constants.include.F'
-  nx = a_x+b_x+c_x+d_x
-  if(iand(nx,1) == 1) then
-    ERI_erf = 0.d0
-    return
-  endif
-
-  ny = a_y+b_y+c_y+d_y
-  if(iand(ny,1) == 1) then
-    ERI_erf = 0.d0
-    return
-  endif
-
-  nz = a_z+b_z+c_z+d_z
-  if(iand(nz,1) == 1) then
-    ERI_erf = 0.d0
-    return
-  endif
-    
-  ASSERT (alpha >= 0.d0)
-  ASSERT (beta >= 0.d0)
-  ASSERT (delta >= 0.d0)
-  ASSERT (gama >= 0.d0)
-  p = alpha + beta
-  q = delta + gama
-  double precision :: p_plus_q
-   p_plus_q = (p+q) * ((p*q)/(p+q) + mu_erf*mu_erf)/(mu_erf*mu_erf)
-  ASSERT (p+q >= 0.d0)
-  n_pt =  ishft( nx+ny+nz,1 )
-  
-  coeff = pi_5_2 / (p * q * dsqrt(p_plus_q))
-  if (n_pt == 0) then
-    ERI_erf = coeff
-    return
-  endif
-  
-  call integrale_new(I_f,a_x,b_x,c_x,d_x,a_y,b_y,c_y,d_y,a_z,b_z,c_z,d_z,p,q,n_pt)
-  
-  ERI_erf = I_f * coeff
-end
-
-
-  
-
-subroutine compute_ao_integrals_erf_jl(j,l,n_integrals,buffer_i,buffer_value)
-  implicit none
-  use map_module
-  BEGIN_DOC
-  !  Parallel client for AO integrals
-  END_DOC
-  
-  integer, intent(in)            :: j,l
-  integer,intent(out)            :: n_integrals
-  integer(key_kind),intent(out)  :: buffer_i(ao_num*ao_num)
-  real(integral_kind),intent(out) :: buffer_value(ao_num*ao_num)
-
-  integer                        :: i,k
-  double precision               :: ao_bielec_integral_erf,cpu_1,cpu_2, wall_1, wall_2
-  double precision               :: integral, wall_0
-  double precision               :: thr
-  integer                        :: kk, m, j1, i1
-
-  thr = ao_integrals_threshold
-  
-  n_integrals = 0
-  
-  j1 = j+ishft(l*l-l,-1)
-  do k = 1, ao_num           ! r1
-    i1 = ishft(k*k-k,-1)
-    if (i1 > j1) then
-      exit
-    endif
-    do i = 1, k
-      i1 += 1
-      if (i1 > j1) then
-        exit
-      endif
-      if (ao_overlap_abs(i,k)*ao_overlap_abs(j,l) < thr) then
-        cycle
-      endif
-      if (ao_bielec_integral_erf_schwartz(i,k)*ao_bielec_integral_erf_schwartz(j,l) < thr ) then
-        cycle
-      endif
-      !DIR$ FORCEINLINE
-      integral = ao_bielec_integral_erf(i,k,j,l)  ! i,k : r1    j,l : r2
-      if (abs(integral) < thr) then
-        cycle
-      endif
-      n_integrals += 1
-      !DIR$ FORCEINLINE
-      call bielec_integrals_index(i,j,k,l,buffer_i(n_integrals))
-      buffer_value(n_integrals) = integral
-    enddo
-  enddo
-    
-end

plugins/Integrals_erf/ao_bielec_integrals_erf_in_map_slave.irp.f

@@ -1,175 +0,0 @@
-subroutine ao_bielec_integrals_erf_in_map_slave_tcp(i)
-  implicit none
-  integer, intent(in)            :: i
-  BEGIN_DOC
-! Computes a buffer of integrals. i is the ID of the current thread.
-  END_DOC
-  call ao_bielec_integrals_erf_in_map_slave(0,i)
-end
-
-
-subroutine ao_bielec_integrals_erf_in_map_slave_inproc(i)
-  implicit none
-  integer, intent(in)            :: i
-  BEGIN_DOC
-! Computes a buffer of integrals. i is the ID of the current thread.
-  END_DOC
-  call ao_bielec_integrals_erf_in_map_slave(1,i)
-end
-
-
-
-subroutine ao_bielec_integrals_erf_in_map_slave(thread,iproc)
-  use map_module
-  use f77_zmq
-  implicit none
-  BEGIN_DOC
-! Computes a buffer of integrals
-  END_DOC
-
-  integer, intent(in)            :: thread, iproc
-
-  integer                        :: j,l,n_integrals
-  integer                        :: rc
-  real(integral_kind), allocatable :: buffer_value(:)
-  integer(key_kind), allocatable :: buffer_i(:)
-  
-  integer                        :: worker_id, task_id
-  character*(512)                :: task
-
-  integer(ZMQ_PTR),external      :: new_zmq_to_qp_run_socket
-  integer(ZMQ_PTR)               :: zmq_to_qp_run_socket
-
-  integer(ZMQ_PTR), external     :: new_zmq_push_socket
-  integer(ZMQ_PTR)               :: zmq_socket_push
-
-  character*(64)                 :: state
-
-  zmq_to_qp_run_socket = new_zmq_to_qp_run_socket()
-  zmq_socket_push      = new_zmq_push_socket(thread)
-
-  allocate ( buffer_i(ao_num*ao_num), buffer_value(ao_num*ao_num) )
-
-  call connect_to_taskserver(zmq_to_qp_run_socket,worker_id,thread)
-
-  do 
-    call get_task_from_taskserver(zmq_to_qp_run_socket,worker_id, task_id, task)
-    if (task_id == 0) exit
-    read(task,*) j, l
-    call compute_ao_integrals_erf_jl(j,l,n_integrals,buffer_i,buffer_value) 
-    call task_done_to_taskserver(zmq_to_qp_run_socket,worker_id,task_id)
-    call push_integrals(zmq_socket_push, n_integrals, buffer_i, buffer_value, task_id)
-  enddo
-
-
-  call disconnect_from_taskserver(zmq_to_qp_run_socket,zmq_socket_push,worker_id)
-  deallocate( buffer_i, buffer_value )
-  call end_zmq_to_qp_run_socket(zmq_to_qp_run_socket)
-  call end_zmq_push_socket(zmq_socket_push,thread)
-
-end
-
-
-subroutine ao_bielec_integrals_erf_in_map_collector
-  use map_module
-  use f77_zmq
-  implicit none
-  BEGIN_DOC
-! Collects results from the AO integral calculation
-  END_DOC
-
-  integer                        :: j,l,n_integrals
-  integer                        :: rc
-  
-  real(integral_kind), allocatable :: buffer_value(:)
-  integer(key_kind), allocatable :: buffer_i(:)
-  
-  integer(ZMQ_PTR),external      :: new_zmq_to_qp_run_socket
-  integer(ZMQ_PTR)               :: zmq_to_qp_run_socket
-  
-  integer(ZMQ_PTR), external     :: new_zmq_pull_socket
-  integer(ZMQ_PTR)               :: zmq_socket_pull
-  
-  integer*8                      :: control, accu
-  integer                        :: task_id, more, sze
-
-  zmq_to_qp_run_socket = new_zmq_to_qp_run_socket()
-  zmq_socket_pull = new_zmq_pull_socket()
-
-  sze = ao_num*ao_num
-  allocate ( buffer_i(sze), buffer_value(sze) )
-
-  accu = 0_8
-  more = 1
-  do while (more == 1)
-    
-    rc = f77_zmq_recv( zmq_socket_pull, n_integrals, 4, 0)
-    if (rc == -1) then
-      n_integrals = 0
-      return
-    endif
-    if (rc /= 4) then
-      print *, irp_here,  ': f77_zmq_recv( zmq_socket_pull, n_integrals, 4, 0)'
-      stop 'error'
-    endif
-    
-    if (n_integrals >= 0) then
-      
-      if (n_integrals > sze) then
-        deallocate (buffer_value, buffer_i)
-        sze = n_integrals
-        allocate (buffer_value(sze), buffer_i(sze))
-      endif
-
-      rc = f77_zmq_recv( zmq_socket_pull, buffer_i, key_kind*n_integrals, 0)
-      if (rc /= key_kind*n_integrals) then
-        print *,  rc, key_kind, n_integrals
-        print *, irp_here,  ': f77_zmq_recv( zmq_socket_pull, buffer_i, key_kind*n_integrals, 0)'
-        stop 'error'
-      endif
-      
-      rc = f77_zmq_recv( zmq_socket_pull, buffer_value, integral_kind*n_integrals, 0)
-      if (rc /= integral_kind*n_integrals) then
-        print *, irp_here,  ': f77_zmq_recv( zmq_socket_pull, buffer_value, integral_kind*n_integrals, 0)'
-        stop 'error'
-      endif
-
-      rc = f77_zmq_recv( zmq_socket_pull, task_id, 4, 0)
-
-! Activate if zmq_socket_pull is a REP
-      rc = f77_zmq_send( zmq_socket_pull, 0, 4, 0)
-      if (rc /= 4) then
-        print *,  irp_here, ' : f77_zmq_send (zmq_socket_pull,...'
-        stop 'error'
-      endif
-
-      
-      call insert_into_ao_integrals_erf_map(n_integrals,buffer_i,buffer_value)
-      accu += n_integrals
-      if (task_id /= 0) then
-        call zmq_delete_task(zmq_to_qp_run_socket,zmq_socket_pull,task_id,more)
-      endif
-    endif
-
-  enddo
-
-  deallocate( buffer_i, buffer_value )
-
-  integer (map_size_kind) :: get_ao_erf_map_size 
-  control = get_ao_erf_map_size(ao_integrals_erf_map)
-
-  if (control /= accu) then
-      print *, ''
-      print *, irp_here
-      print *, 'Control : ', control
-      print *, 'Accu    : ', accu
-      print *, 'Some integrals were lost during the parallel computation.'
-      print *, 'Try to reduce the number of threads.'
-      stop
-  endif
-
-  call end_zmq_to_qp_run_socket(zmq_to_qp_run_socket)
-  call end_zmq_pull_socket(zmq_socket_pull)
-
-end
-

plugins/Integrals_erf/integrals_3_index_erf.irp.f

@@ -1,22 +0,0 @@
- BEGIN_PROVIDER [double precision, big_array_coulomb_integrals_erf, (mo_tot_num_align,mo_tot_num, mo_tot_num)]
-&BEGIN_PROVIDER [double precision, big_array_exchange_integrals_erf,(mo_tot_num_align,mo_tot_num, mo_tot_num)]
- implicit none
- integer :: i,j,k,l
- double precision :: get_mo_bielec_integral_erf
- double precision :: integral
-
- do k = 1, mo_tot_num
-  do i = 1, mo_tot_num
-   do j = 1, mo_tot_num
-     l = j
-     integral = get_mo_bielec_integral_erf(i,j,k,l,mo_integrals_erf_map)
-     big_array_coulomb_integrals_erf(j,i,k) = integral
-     l = j
-     integral = get_mo_bielec_integral_erf(i,j,l,k,mo_integrals_erf_map)
-     big_array_exchange_integrals_erf(j,i,k) = integral
-   enddo
-  enddo
- enddo
-
-
-END_PROVIDER 

plugins/Integrals_erf/map_integrals_erf.irp.f

@@ -1,626 +0,0 @@
-use map_module
-
-!! AO Map
-!! ======
-
-BEGIN_PROVIDER [ type(map_type), ao_integrals_erf_map ]
-  implicit none
-  BEGIN_DOC
-  ! AO integrals
-  END_DOC
-  integer(key_kind)              :: key_max
-  integer(map_size_kind)         :: sze
-  call bielec_integrals_index(ao_num,ao_num,ao_num,ao_num,key_max)
-  sze = key_max
-  call map_init(ao_integrals_erf_map,sze)
-  print*,  'AO map initialized : ', sze
-END_PROVIDER
-
- BEGIN_PROVIDER [ integer, ao_integrals_erf_cache_min ]
-&BEGIN_PROVIDER [ integer, ao_integrals_erf_cache_max ]
- implicit none
- BEGIN_DOC
- ! Min and max values of the AOs for which the integrals are in the cache
- END_DOC
- ao_integrals_erf_cache_min = max(1,ao_num - 63)
- ao_integrals_erf_cache_max = ao_num
-
-END_PROVIDER
-
-BEGIN_PROVIDER [ double precision, ao_integrals_erf_cache, (0:64*64*64*64) ]
-  use map_module
- implicit none
- BEGIN_DOC
- ! Cache of AO integrals for fast access
- END_DOC
- PROVIDE ao_bielec_integrals_erf_in_map
- integer                        :: i,j,k,l,ii
- integer(key_kind)              :: idx
- real(integral_kind)            :: integral
- !$OMP PARALLEL DO PRIVATE (i,j,k,l,idx,ii,integral)
- do l=ao_integrals_erf_cache_min,ao_integrals_erf_cache_max
-   do k=ao_integrals_erf_cache_min,ao_integrals_erf_cache_max
-     do j=ao_integrals_erf_cache_min,ao_integrals_erf_cache_max
-       do i=ao_integrals_erf_cache_min,ao_integrals_erf_cache_max
-         !DIR$ FORCEINLINE
-         call bielec_integrals_index(i,j,k,l,idx)
-         !DIR$ FORCEINLINE
-         call map_get(ao_integrals_erf_map,idx,integral)
-         ii = l-ao_integrals_erf_cache_min
-         ii = ior( ishft(ii,6), k-ao_integrals_erf_cache_min)
-         ii = ior( ishft(ii,6), j-ao_integrals_erf_cache_min)
-         ii = ior( ishft(ii,6), i-ao_integrals_erf_cache_min)
-         ao_integrals_erf_cache(ii) = integral
-       enddo
-     enddo
-   enddo
- enddo
- !$OMP END PARALLEL DO
-
-END_PROVIDER
-
-
-double precision function get_ao_bielec_integral_erf(i,j,k,l,map) result(result)
-  use map_module
-  implicit none
-  BEGIN_DOC
-  ! Gets one AO bi-electronic integral from the AO map
-  END_DOC
-  integer, intent(in)            :: i,j,k,l
-  integer(key_kind)              :: idx
-  type(map_type), intent(inout)  :: map
-  integer                        :: ii
-  real(integral_kind)            :: tmp
-  PROVIDE ao_bielec_integrals_erf_in_map ao_integrals_erf_cache ao_integrals_erf_cache_min
-  !DIR$ FORCEINLINE
-  if (ao_overlap_abs(i,k)*ao_overlap_abs(j,l) < ao_integrals_threshold ) then
-    tmp = 0.d0
-  else if (ao_bielec_integral_erf_schwartz(i,k)*ao_bielec_integral_erf_schwartz(j,l) < ao_integrals_threshold) then
-    tmp = 0.d0
-  else
-    ii = l-ao_integrals_erf_cache_min
-    ii = ior(ii, k-ao_integrals_erf_cache_min)
-    ii = ior(ii, j-ao_integrals_erf_cache_min)
-    ii = ior(ii, i-ao_integrals_erf_cache_min)
-    if (iand(ii, -64) /= 0) then
-      !DIR$ FORCEINLINE
-      call bielec_integrals_index(i,j,k,l,idx)
-      !DIR$ FORCEINLINE
-      call map_get(map,idx,tmp)
-      tmp = tmp
-    else
-      ii = l-ao_integrals_erf_cache_min
-      ii = ior( ishft(ii,6), k-ao_integrals_erf_cache_min)
-      ii = ior( ishft(ii,6), j-ao_integrals_erf_cache_min)
-      ii = ior( ishft(ii,6), i-ao_integrals_erf_cache_min)
-      tmp = ao_integrals_erf_cache(ii)
-    endif
-  endif
-  result = tmp
-end
-
-
-subroutine get_ao_bielec_integrals_erf(j,k,l,sze,out_val)
-  use map_module
-  BEGIN_DOC
-  ! Gets multiple AO bi-electronic integral from the AO map .
-  ! All i are retrieved for j,k,l fixed.
-  END_DOC
-  implicit none
-  integer, intent(in)            :: j,k,l, sze
-  real(integral_kind), intent(out) :: out_val(sze)
-  
-  integer                        :: i
-  integer(key_kind)              :: hash
-  double precision               :: thresh
-  PROVIDE ao_bielec_integrals_erf_in_map ao_integrals_erf_map
-  thresh = ao_integrals_threshold
-  
-  if (ao_overlap_abs(j,l) < thresh) then
-    out_val = 0.d0
-    return
-  endif
-  
-  double precision :: get_ao_bielec_integral_erf
-  do i=1,sze
-    out_val(i) = get_ao_bielec_integral_erf(i,j,k,l,ao_integrals_erf_map)
-  enddo
-  
-end
-
-subroutine get_ao_bielec_integrals_erf_non_zero(j,k,l,sze,out_val,out_val_index,non_zero_int)
-  use map_module
-  implicit none
-  BEGIN_DOC
-  ! Gets multiple AO bi-electronic integral from the AO map .
-  ! All non-zero i are retrieved for j,k,l fixed.
-  END_DOC
-  integer, intent(in)            :: j,k,l, sze
-  real(integral_kind), intent(out) :: out_val(sze)
-  integer, intent(out)           :: out_val_index(sze),non_zero_int
-  
-  integer                        :: i
-  integer(key_kind)              :: hash
-  double precision               :: thresh,tmp
-  PROVIDE ao_bielec_integrals_erf_in_map
-  thresh = ao_integrals_threshold
-  
-  non_zero_int = 0
-  if (ao_overlap_abs(j,l) < thresh) then
-    out_val = 0.d0
-    return
-  endif
- 
-  non_zero_int = 0
-  do i=1,sze
-    integer, external :: ao_l4
-    double precision, external :: ao_bielec_integral_erf
-    !DIR$ FORCEINLINE
-    if (ao_bielec_integral_erf_schwartz(i,k)*ao_bielec_integral_erf_schwartz(j,l) < thresh) then
-      cycle
-    endif
-    call bielec_integrals_index(i,j,k,l,hash)
-    call map_get(ao_integrals_erf_map, hash,tmp)
-    if (dabs(tmp) < thresh ) cycle
-    non_zero_int = non_zero_int+1
-    out_val_index(non_zero_int) = i
-    out_val(non_zero_int) = tmp
-  enddo
-  
-end
-
-
-function get_ao_erf_map_size()
-  implicit none
-  integer (map_size_kind) :: get_ao_erf_map_size
-  BEGIN_DOC
-  ! Returns the number of elements in the AO map
-  END_DOC
-  get_ao_erf_map_size = ao_integrals_erf_map % n_elements
-end
-
-subroutine clear_ao_erf_map
-  implicit none
-  BEGIN_DOC
-  ! Frees the memory of the AO map
-  END_DOC
-  call map_deinit(ao_integrals_erf_map)
-  FREE ao_integrals_erf_map
-end
-
-
-
-BEGIN_TEMPLATE
-
-subroutine dump_$ao_integrals(filename)
-  use map_module
-  implicit none
-  BEGIN_DOC
-  ! Save to disk the $ao integrals
-  END_DOC
-  character*(*), intent(in)      :: filename
-  integer(cache_key_kind), pointer :: key(:)
-  real(integral_kind), pointer   :: val(:)
-  integer*8                      :: i,j, n
-  call ezfio_set_work_empty(.False.)
-  open(unit=66,file=filename,FORM='unformatted')
-  write(66) integral_kind, key_kind
-  write(66) $ao_integrals_map%sorted, $ao_integrals_map%map_size,    &
-      $ao_integrals_map%n_elements
-  do i=0_8,$ao_integrals_map%map_size
-    write(66) $ao_integrals_map%map(i)%sorted, $ao_integrals_map%map(i)%map_size,&
-        $ao_integrals_map%map(i)%n_elements
-  enddo
-  do i=0_8,$ao_integrals_map%map_size
-    key => $ao_integrals_map%map(i)%key
-    val => $ao_integrals_map%map(i)%value
-    n = $ao_integrals_map%map(i)%n_elements
-    write(66) (key(j), j=1,n), (val(j), j=1,n)
-  enddo
-  close(66)
-  
-end
-
-IRP_IF COARRAY
-subroutine communicate_$ao_integrals()
-  use map_module
-  implicit none
-  BEGIN_DOC
-  ! Communicate the $ao integrals with co-array
-  END_DOC
-  integer(cache_key_kind), pointer :: key(:)
-  real(integral_kind), pointer   :: val(:)
-  integer*8                      :: i,j, k, nmax
-  integer*8, save                :: n[*]
-  integer                        :: copy_n
-
-  real(integral_kind), allocatable            :: buffer_val(:)[:]
-  integer(cache_key_kind), allocatable        :: buffer_key(:)[:]
-  real(integral_kind), allocatable            :: copy_val(:)
-  integer(key_kind), allocatable              :: copy_key(:)
-
-  n = 0_8
-  do i=0_8,$ao_integrals_map%map_size
-    n = max(n,$ao_integrals_map%map(i)%n_elements)
-  enddo
-  sync all
-  nmax = 0_8
-  do j=1,num_images()
-    nmax = max(nmax,n[j])
-  enddo
-  allocate( buffer_key(nmax)[*], buffer_val(nmax)[*])
-  allocate( copy_key(nmax), copy_val(nmax))
-  do i=0_8,$ao_integrals_map%map_size
-    key => $ao_integrals_map%map(i)%key
-    val => $ao_integrals_map%map(i)%value
-    n = $ao_integrals_map%map(i)%n_elements
-    do j=1,n
-      buffer_key(j) = key(j)
-      buffer_val(j) = val(j)
-    enddo
-    sync all
-    do j=1,num_images()
-      if (j /= this_image()) then
-        copy_n = n[j]
-        do k=1,copy_n
-          copy_val(k) = buffer_val(k)[j]
-          copy_key(k) = buffer_key(k)[j]
-          copy_key(k) = copy_key(k)+ishft(i,-map_shift)
-        enddo
-        call map_append($ao_integrals_map, copy_key, copy_val, copy_n )
-      endif
-    enddo
-    sync all
-  enddo
-  deallocate( buffer_key, buffer_val, copy_val, copy_key)
-  
-end
-IRP_ENDIF 
-
-
-integer function load_$ao_integrals(filename)
-  implicit none
-  BEGIN_DOC
-  ! Read from disk the $ao integrals
-  END_DOC
-  character*(*), intent(in)      :: filename
-  integer*8                      :: i
-  integer(cache_key_kind), pointer :: key(:)
-  real(integral_kind), pointer   :: val(:)
-  integer                        :: iknd, kknd
-  integer*8                      :: n, j
-  load_$ao_integrals = 1
-  open(unit=66,file=filename,FORM='unformatted',STATUS='UNKNOWN')
-  read(66,err=98,end=98) iknd, kknd
-  if (iknd /= integral_kind) then
-    print *,  'Wrong integrals kind in file :', iknd
-    stop 1
-  endif
-  if (kknd /= key_kind) then
-    print *,  'Wrong key kind in file :', kknd
-    stop 1
-  endif
-  read(66,err=98,end=98) $ao_integrals_map%sorted, $ao_integrals_map%map_size,&
-      $ao_integrals_map%n_elements
-  do i=0_8, $ao_integrals_map%map_size
-    read(66,err=99,end=99) $ao_integrals_map%map(i)%sorted,          &
-        $ao_integrals_map%map(i)%map_size, $ao_integrals_map%map(i)%n_elements
-    call cache_map_reallocate($ao_integrals_map%map(i),$ao_integrals_map%map(i)%map_size)
-  enddo
-  do i=0_8, $ao_integrals_map%map_size
-    key => $ao_integrals_map%map(i)%key
-    val => $ao_integrals_map%map(i)%value
-    n = $ao_integrals_map%map(i)%n_elements
-    read(66,err=99,end=99) (key(j), j=1,n), (val(j), j=1,n)
-  enddo
-  call map_sort($ao_integrals_map)
-  load_$ao_integrals = 0
-  return
-  99 continue
-  call map_deinit($ao_integrals_map)
-  98 continue
-  stop 'Problem reading $ao_integrals_map file in work/'
-  
-end
-
-SUBST [ ao_integrals_map, ao_integrals, ao_num ]
-ao_integrals_erf_map ; ao_integrals_erf ; ao_num ;;
-mo_integrals_erf_map ; mo_integrals_erf ; mo_tot_num;;
-END_TEMPLATE
-
-
-
-
-BEGIN_PROVIDER [ type(map_type), mo_integrals_erf_map ]
-  implicit none
-  BEGIN_DOC
-  ! MO integrals
-  END_DOC
-  integer(key_kind)              :: key_max
-  integer(map_size_kind)         :: sze
-  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_erf_map,sze)
-  print*, 'MO map initialized'
-END_PROVIDER
-
-subroutine insert_into_ao_integrals_erf_map(n_integrals,buffer_i, buffer_values)
-  use map_module
-  implicit none
-  BEGIN_DOC
-  ! Create new entry into AO map
-  END_DOC
-  
-  integer, intent(in)                :: n_integrals
-  integer(key_kind), intent(inout)   :: buffer_i(n_integrals)
-  real(integral_kind), intent(inout) :: buffer_values(n_integrals)
-  
-  call map_append(ao_integrals_erf_map, buffer_i, buffer_values, n_integrals)
-end
-
-subroutine insert_into_mo_integrals_erf_map(n_integrals,                 &
-      buffer_i, buffer_values, thr)
-  use map_module
-  implicit none
-  
-  BEGIN_DOC
-  ! Create new entry into MO map, or accumulate in an existing entry
-  END_DOC
-  
-  integer, intent(in)                :: n_integrals
-  integer(key_kind), intent(inout)   :: buffer_i(n_integrals)
-  real(integral_kind), intent(inout) :: buffer_values(n_integrals)
-  real(integral_kind), intent(in)    :: thr
-  call map_update(mo_integrals_erf_map, buffer_i, buffer_values, n_integrals, thr)
-end
-
- BEGIN_PROVIDER [ integer, mo_integrals_erf_cache_min ]
-&BEGIN_PROVIDER [ integer, mo_integrals_erf_cache_max ]
- implicit none
- BEGIN_DOC
- ! Min and max values of the MOs for which the integrals are in the cache
- END_DOC
- mo_integrals_erf_cache_min = max(1,elec_alpha_num - 31)
- mo_integrals_erf_cache_max = min(mo_tot_num,mo_integrals_erf_cache_min+63)
-
-END_PROVIDER
-
-BEGIN_PROVIDER [ double precision, mo_integrals_erf_cache, (0:64*64*64*64) ]
- implicit none
- BEGIN_DOC
- ! Cache of MO integrals for fast access
- END_DOC
- PROVIDE mo_bielec_integrals_erf_in_map
- integer                        :: i,j,k,l
- integer                        :: ii
- integer(key_kind)              :: idx
- real(integral_kind)            :: integral
- FREE ao_integrals_erf_cache
- !$OMP PARALLEL DO PRIVATE (i,j,k,l,idx,ii,integral)
- do l=mo_integrals_erf_cache_min,mo_integrals_erf_cache_max
-   do k=mo_integrals_erf_cache_min,mo_integrals_erf_cache_max
-     do j=mo_integrals_erf_cache_min,mo_integrals_erf_cache_max
-       do i=mo_integrals_erf_cache_min,mo_integrals_erf_cache_max
-         !DIR$ FORCEINLINE
-         call bielec_integrals_index(i,j,k,l,idx)
-         !DIR$ FORCEINLINE
-         call map_get(mo_integrals_erf_map,idx,integral)
-         ii = l-mo_integrals_erf_cache_min
-         ii = ior( ishft(ii,6), k-mo_integrals_erf_cache_min)
-         ii = ior( ishft(ii,6), j-mo_integrals_erf_cache_min)
-         ii = ior( ishft(ii,6), i-mo_integrals_erf_cache_min)
-         mo_integrals_erf_cache(ii) = integral
-       enddo
-     enddo
-   enddo
- enddo
- !$OMP END PARALLEL DO
-
-END_PROVIDER
-
-
-double precision function get_mo_bielec_integral_erf(i,j,k,l,map)
-  use map_module
-  implicit none
-  BEGIN_DOC
-  ! Returns one integral <ij|kl> in the MO basis
-  END_DOC
-  integer, intent(in)            :: i,j,k,l
-  integer(key_kind)              :: idx
-  integer                        :: ii
-  type(map_type), intent(inout)  :: map
-  real(integral_kind)            :: tmp
-  PROVIDE mo_bielec_integrals_erf_in_map mo_integrals_erf_cache
-  ii = l-mo_integrals_erf_cache_min
-  ii = ior(ii, k-mo_integrals_erf_cache_min)
-  ii = ior(ii, j-mo_integrals_erf_cache_min)
-  ii = ior(ii, i-mo_integrals_erf_cache_min)
-  if (iand(ii, -64) /= 0) then
-    !DIR$ FORCEINLINE
-    call bielec_integrals_index(i,j,k,l,idx)
-    !DIR$ FORCEINLINE
-    call map_get(map,idx,tmp)
-    get_mo_bielec_integral_erf = dble(tmp)
-  else
-    ii = l-mo_integrals_erf_cache_min
-    ii = ior( ishft(ii,6), k-mo_integrals_erf_cache_min)
-    ii = ior( ishft(ii,6), j-mo_integrals_erf_cache_min)
-    ii = ior( ishft(ii,6), i-mo_integrals_erf_cache_min)
-    get_mo_bielec_integral_erf = mo_integrals_erf_cache(ii)
-  endif
-end
-
-
-double precision function mo_bielec_integral_erf(i,j,k,l)
-  implicit none
-  BEGIN_DOC
-  ! Returns one integral <ij|kl> in the MO basis
-  END_DOC
-  integer, intent(in)            :: i,j,k,l
-  double precision               :: get_mo_bielec_integral_erf
-  PROVIDE mo_bielec_integrals_erf_in_map mo_integrals_erf_cache
-  !DIR$ FORCEINLINE
-  PROVIDE mo_bielec_integrals_erf_in_map
-  mo_bielec_integral_erf = get_mo_bielec_integral_erf(i,j,k,l,mo_integrals_erf_map)
-  return
-end
-
-subroutine get_mo_bielec_integrals_erf(j,k,l,sze,out_val,map)
-  use map_module
-  implicit none
-  BEGIN_DOC
-  ! Returns multiple integrals <ij|kl> in the MO basis, all
-  ! i for j,k,l fixed.
-  END_DOC
-  integer, intent(in)            :: j,k,l, sze
-  double precision, intent(out)  :: out_val(sze)
-  type(map_type), intent(inout)  :: map
-  integer                        :: i
-  integer(key_kind)              :: hash(sze)
-  real(integral_kind)            :: tmp_val(sze)
-  PROVIDE mo_bielec_integrals_erf_in_map
-  
-  do i=1,sze
-    !DIR$ FORCEINLINE
-    call bielec_integrals_index(i,j,k,l,hash(i))
-  enddo
-  
-  if (key_kind == 8) then
-    call map_get_many(map, hash, out_val, sze)
-  else
-    call map_get_many(map, hash, tmp_val, sze)
-    ! Conversion to double precision 
-    do i=1,sze
-      out_val(i) = dble(tmp_val(i))
-    enddo
-  endif
-end
-
-subroutine get_mo_bielec_integrals_erf_ij(k,l,sze,out_array,map)
-  use map_module
-  implicit none
-  BEGIN_DOC
-  ! Returns multiple integrals <ij|kl> in the MO basis, all
-  ! i(1)j(2) 1/r12 k(1)l(2)
-  ! i, j for k,l fixed.
-  END_DOC
-  integer, intent(in)            :: k,l, sze
-  double precision, intent(out)  :: out_array(sze,sze)
-  type(map_type), intent(inout)  :: map
-  integer                        :: i,j,kk,ll,m
-  integer(key_kind),allocatable  :: hash(:)
-  integer  ,allocatable          :: pairs(:,:), iorder(:)
-  real(integral_kind), allocatable :: tmp_val(:)
-
-  PROVIDE mo_bielec_integrals_erf_in_map
-  allocate (hash(sze*sze), pairs(2,sze*sze),iorder(sze*sze), &
-  tmp_val(sze*sze))
-  
-  kk=0
-  out_array = 0.d0
-  do j=1,sze
-   do i=1,sze
-    kk += 1
-    !DIR$ FORCEINLINE
-    call bielec_integrals_index(i,j,k,l,hash(kk))
-    pairs(1,kk) = i
-    pairs(2,kk) = j
-    iorder(kk) = kk
-   enddo
-  enddo
-
-  logical :: integral_is_in_map
-  if (key_kind == 8) then
-    call i8radix_sort(hash,iorder,kk,-1)
-  else if (key_kind == 4) then
-    call iradix_sort(hash,iorder,kk,-1)
-  else if (key_kind == 2) then
-    call i2radix_sort(hash,iorder,kk,-1)
-  endif
-
-  call map_get_many(mo_integrals_erf_map, hash, tmp_val, kk)
-
-  do ll=1,kk
-    m = iorder(ll)
-    i=pairs(1,m)
-    j=pairs(2,m)
-    out_array(i,j) = tmp_val(ll)
-  enddo  
-
-  deallocate(pairs,hash,iorder,tmp_val)
-end
-
-subroutine get_mo_bielec_integrals_erf_coulomb_ii(k,l,sze,out_val,map)
-  use map_module
-  implicit none
-  BEGIN_DOC
-  ! Returns multiple integrals <ki|li> 
-  ! k(1)i(2) 1/r12 l(1)i(2) :: out_val(i1)
-  ! for k,l fixed.
-  END_DOC
-  integer, intent(in)            :: k,l, sze
-  double precision, intent(out)  :: out_val(sze)
-  type(map_type), intent(inout)  :: map
-  integer                        :: i
-  integer(key_kind)              :: hash(sze)
-  real(integral_kind)            :: tmp_val(sze)
-  PROVIDE mo_bielec_integrals_erf_in_map
-  
-  integer :: kk
-  do i=1,sze
-    !DIR$ FORCEINLINE
-    call bielec_integrals_index(k,i,l,i,hash(i))
-  enddo
-  
-  if (key_kind == 8) then
-    call map_get_many(map, hash, out_val, sze)
-  else
-    call map_get_many(map, hash, tmp_val, sze)
-    ! Conversion to double precision 
-    do i=1,sze
-      out_val(i) = dble(tmp_val(i))
-    enddo
-  endif
-end
-
-subroutine get_mo_bielec_integrals_erf_exch_ii(k,l,sze,out_val,map)
-  use map_module
-  implicit none
-  BEGIN_DOC
-  ! Returns multiple integrals <ki|il> 
-  ! k(1)i(2) 1/r12 i(1)l(2) :: out_val(i1)
-  ! for k,l fixed.
-  END_DOC
-  integer, intent(in)            :: k,l, sze
-  double precision, intent(out)  :: out_val(sze)
-  type(map_type), intent(inout)  :: map
-  integer                        :: i
-  integer(key_kind)              :: hash(sze)
-  real(integral_kind)            :: tmp_val(sze)
-  PROVIDE mo_bielec_integrals_erf_in_map
-  
-  integer :: kk
-  do i=1,sze
-    !DIR$ FORCEINLINE
-    call bielec_integrals_index(k,i,i,l,hash(i))
-  enddo
-  
-  if (key_kind == 8) then
-    call map_get_many(map, hash, out_val, sze)
-  else
-    call map_get_many(map, hash, tmp_val, sze)
-    ! Conversion to double precision 
-    do i=1,sze
-      out_val(i) = dble(tmp_val(i))
-    enddo
-  endif
-end
-
-
-integer*8 function get_mo_erf_map_size()
-  implicit none
-  BEGIN_DOC
-  ! Return the number of elements in the MO map
-  END_DOC
-  get_mo_erf_map_size = mo_integrals_erf_map % n_elements
-end

plugins/Integrals_erf/mo_bi_integrals_erf.irp.f

@@ -1,616 +0,0 @@
-subroutine mo_bielec_integrals_erf_index(i,j,k,l,i1)
-  use map_module
-  implicit none
-  BEGIN_DOC
-  ! Computes an unique index for i,j,k,l integrals
-  END_DOC
-  integer, intent(in)            :: i,j,k,l
-  integer(key_kind), intent(out) :: i1
-  integer(key_kind)              :: p,q,r,s,i2
-  p = min(i,k)
-  r = max(i,k)
-  p = p+ishft(r*r-r,-1)
-  q = min(j,l)
-  s = max(j,l)
-  q = q+ishft(s*s-s,-1)
-  i1 = min(p,q)
-  i2 = max(p,q)
-  i1 = i1+ishft(i2*i2-i2,-1)
-end
-
-
-BEGIN_PROVIDER [ logical, mo_bielec_integrals_erf_in_map ]
-  use map_module
-  implicit none
-  integer(bit_kind)              :: mask_ijkl(N_int,4)
-  integer(bit_kind)              :: mask_ijk(N_int,3)
-  
-  BEGIN_DOC
-  ! If True, the map of MO bielectronic integrals is provided
-  END_DOC
-  
-  mo_bielec_integrals_erf_in_map = .True.
-  if (read_mo_integrals_erf) then
-    print*,'Reading the MO integrals_erf'
-    call map_load_from_disk(trim(ezfio_filename)//'/work/mo_ints_erf',mo_integrals_erf_map)
-    print*, 'MO integrals_erf provided'
-    return
-  else
-    PROVIDE ao_bielec_integrals_erf_in_map
-  endif
-  
- !if(no_vvvv_integrals)then
- !  integer                        :: i,j,k,l
- !  !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!  I I I I !!!!!!!!!!!!!!!!!!!!
- !  ! (core+inact+act) ^ 4
- !  ! <ii|ii>
- !  print*, ''
- !  print*, '<ii|ii>'
- !  do i = 1,N_int
- !    mask_ijkl(i,1) =  core_inact_act_bitmask_4(i,1)
- !    mask_ijkl(i,2) =  core_inact_act_bitmask_4(i,1)
- !    mask_ijkl(i,3) =  core_inact_act_bitmask_4(i,1)
- !    mask_ijkl(i,4) =  core_inact_act_bitmask_4(i,1)
- !  enddo
- !  call add_integrals_to_map(mask_ijkl)
- !  !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!  I I V V !!!!!!!!!!!!!!!!!!!!
- !  ! (core+inact+act) ^ 2  (virt) ^2
- !  ! <iv|iv>  = J_iv
- !  print*, ''
- !  print*, '<iv|iv>'
- !  do i = 1,N_int
- !    mask_ijkl(i,1) =  core_inact_act_bitmask_4(i,1)
- !    mask_ijkl(i,2) =  virt_bitmask(i,1)
- !    mask_ijkl(i,3) =  core_inact_act_bitmask_4(i,1)
- !    mask_ijkl(i,4) =  virt_bitmask(i,1)
- !  enddo
- !  call add_integrals_to_map(mask_ijkl)
- !  
- !  ! (core+inact+act) ^ 2  (virt) ^2
- !  ! <ii|vv> = (iv|iv)
- !  print*, ''
- !  print*, '<ii|vv>'
- !  do i = 1,N_int
- !    mask_ijkl(i,1) = core_inact_act_bitmask_4(i,1)
- !    mask_ijkl(i,2) = core_inact_act_bitmask_4(i,1)
- !    mask_ijkl(i,3) = virt_bitmask(i,1)
- !    mask_ijkl(i,4) = virt_bitmask(i,1)
- !  enddo
- !  call add_integrals_to_map(mask_ijkl)
- !  !!!!!!!!!!!!!!!!!!!!!!!!!!!!!! V V V !!!!!!!!!!!!!!!!!!!!!!!
- !  if(.not.no_vvv_integrals)then
- !    print*, ''
- !    print*, '<rv|sv> and <rv|vs>'
- !    do i = 1,N_int
- !      mask_ijk(i,1) =  virt_bitmask(i,1)
- !      mask_ijk(i,2) =  virt_bitmask(i,1)
- !      mask_ijk(i,3) =  virt_bitmask(i,1)
- !    enddo
- !    call add_integrals_to_map_three_indices(mask_ijk)
- !  endif
- !  
- !  !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!  I I I V !!!!!!!!!!!!!!!!!!!!
- !  ! (core+inact+act) ^ 3  (virt) ^1
- !  ! <iv|ii>
- !  print*, ''
- !  print*, '<iv|ii>'
- !  do i = 1,N_int
- !    mask_ijkl(i,1) =  core_inact_act_bitmask_4(i,1)
- !    mask_ijkl(i,2) =  core_inact_act_bitmask_4(i,1)
- !    mask_ijkl(i,3) =  core_inact_act_bitmask_4(i,1)
- !    mask_ijkl(i,4) =  virt_bitmask(i,1)
- !  enddo
- !  call add_integrals_to_map(mask_ijkl)
- !  !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!  I V V V !!!!!!!!!!!!!!!!!!!!
- !  ! (core+inact+act) ^ 1  (virt) ^3
- !  ! <iv|vv>
- !  if(.not.no_ivvv_integrals)then
- !    print*, ''
- !    print*, '<iv|vv>'
- !    do i = 1,N_int
- !      mask_ijkl(i,1) =  core_inact_act_bitmask_4(i,1)
- !      mask_ijkl(i,2) =  virt_bitmask(i,1)
- !      mask_ijkl(i,3) =  virt_bitmask(i,1)
- !      mask_ijkl(i,4) =  virt_bitmask(i,1)
- !    enddo
- !    call add_integrals_to_map_no_exit_34(mask_ijkl)
- !  endif
- !  
- !else
-    call add_integrals_erf_to_map(full_ijkl_bitmask_4)
- !endif
-  if (write_mo_integrals_erf) then
-    call ezfio_set_work_empty(.False.)
-    call map_save_to_disk(trim(ezfio_filename)//'/work/mo_ints_erf',mo_integrals_erf_map)
-    call ezfio_set_integrals_erf_disk_access_mo_integrals_erf("Read")
-  endif
-  
-END_PROVIDER
-
-subroutine add_integrals_erf_to_map(mask_ijkl)
-  use bitmasks
-  implicit none
-  
-  BEGIN_DOC
-  ! Adds integrals to tha MO map according to some bitmask
-  END_DOC
-  
-  integer(bit_kind), intent(in)  :: mask_ijkl(N_int,4)
-  
-  integer                        :: i,j,k,l
-  integer                        :: i0,j0,k0,l0
-  double precision               :: c, cpu_1, cpu_2, wall_1, wall_2, wall_0
-  
-  integer, allocatable           :: list_ijkl(:,:)
-  integer                        :: n_i, n_j, n_k, n_l
-  integer, allocatable           :: bielec_tmp_0_idx(:)
-  real(integral_kind), allocatable :: bielec_tmp_0(:,:)
-  double precision, allocatable  :: bielec_tmp_1(:)
-  double precision, allocatable  :: bielec_tmp_2(:,:)
-  double precision, allocatable  :: bielec_tmp_3(:,:,:)
-  !DEC$ ATTRIBUTES ALIGN : 64    :: bielec_tmp_1, bielec_tmp_2, bielec_tmp_3
-  
-  integer                        :: n_integrals
-  integer                        :: size_buffer
-  integer(key_kind),allocatable  :: buffer_i(:)
-  real(integral_kind),allocatable :: buffer_value(:)
-  real                           :: map_mb
-  
-  integer                        :: i1,j1,k1,l1, ii1, kmax, thread_num
-  integer                        :: i2,i3,i4
-  double precision,parameter     :: thr_coef = 1.d-10
-  
-  PROVIDE ao_bielec_integrals_erf_in_map  mo_coef
-  
-  !Get list of MOs for i,j,k and l
-  !-------------------------------
-  
-  allocate(list_ijkl(mo_tot_num,4))
-  call bitstring_to_list( mask_ijkl(1,1), list_ijkl(1,1), n_i, N_int )
-  call bitstring_to_list( mask_ijkl(1,2), list_ijkl(1,2), n_j, N_int )
-  call bitstring_to_list( mask_ijkl(1,3), list_ijkl(1,3), n_k, N_int )
-  call bitstring_to_list( mask_ijkl(1,4), list_ijkl(1,4), n_l, N_int )
-  character*(2048)               :: output(1)
-  print*, 'i'
-  call bitstring_to_str( output(1), mask_ijkl(1,1), N_int )
-  print *,  trim(output(1))
-  j = 0
-  do i = 1, N_int
-    j += popcnt(mask_ijkl(i,1))
-  enddo
-  if(j==0)then
-    return
-  endif
-  
-  print*, 'j'
-  call bitstring_to_str( output(1), mask_ijkl(1,2), N_int )
-  print *,  trim(output(1))
-  j = 0
-  do i = 1, N_int
-    j += popcnt(mask_ijkl(i,2))
-  enddo
-  if(j==0)then
-    return
-  endif
-  
-  print*, 'k'
-  call bitstring_to_str( output(1), mask_ijkl(1,3), N_int )
-  print *,  trim(output(1))
-  j = 0
-  do i = 1, N_int
-    j += popcnt(mask_ijkl(i,3))
-  enddo
-  if(j==0)then
-    return
-  endif
-  
-  print*, 'l'
-  call bitstring_to_str( output(1), mask_ijkl(1,4), N_int )
-  print *,  trim(output(1))
-  j = 0
-  do i = 1, N_int
-    j += popcnt(mask_ijkl(i,4))
-  enddo
-  if(j==0)then
-    return
-  endif
-  
-  size_buffer = min(ao_num*ao_num*ao_num,16000000)
-  print*, 'Providing the molecular integrals '
-  print*, 'Buffers : ', 8.*(mo_tot_num_align*(n_j)*(n_k+1) + mo_tot_num_align +&
-      ao_num+ao_num*ao_num+ size_buffer*3)/(1024*1024), 'MB / core'
-  
-  call wall_time(wall_1)
-  call cpu_time(cpu_1)
-  double precision               :: accu_bis
-  accu_bis = 0.d0
-  
-  !$OMP PARALLEL PRIVATE(l1,k1,j1,i1,i2,i3,i4,i,j,k,l,c, ii1,kmax,   &
-      !$OMP  bielec_tmp_0_idx, bielec_tmp_0, bielec_tmp_1,bielec_tmp_2,bielec_tmp_3,&
-      !$OMP  buffer_i,buffer_value,n_integrals,wall_2,i0,j0,k0,l0,   &
-      !$OMP  wall_0,thread_num,accu_bis)                             &
-      !$OMP  DEFAULT(NONE)                                           &
-      !$OMP  SHARED(size_buffer,ao_num,mo_tot_num,n_i,n_j,n_k,n_l,mo_tot_num_align,&
-      !$OMP  mo_coef_transp,                                         &
-      !$OMP  mo_coef_transp_is_built, list_ijkl,                     &
-      !$OMP  mo_coef_is_built, wall_1,                               &
-      !$OMP  mo_coef,mo_integrals_threshold,mo_integrals_erf_map)
-  n_integrals = 0
-  wall_0 = wall_1
-  allocate(bielec_tmp_3(mo_tot_num_align, n_j, n_k),                 &
-      bielec_tmp_1(mo_tot_num_align),                                &
-      bielec_tmp_0(ao_num,ao_num),                                   &
-      bielec_tmp_0_idx(ao_num),                                      &
-      bielec_tmp_2(mo_tot_num_align, n_j),                           &
-      buffer_i(size_buffer),                                         &
-      buffer_value(size_buffer) )
-  
-  thread_num = 0
-  !$  thread_num = omp_get_thread_num()
-  !$OMP DO SCHEDULE(guided)
-  do l1 = 1,ao_num
-    !DEC$ VECTOR ALIGNED
-    bielec_tmp_3 = 0.d0
-    do k1 = 1,ao_num
-      !DEC$ VECTOR ALIGNED
-      bielec_tmp_2 = 0.d0
-      do j1 = 1,ao_num
-        call get_ao_bielec_integrals_erf(j1,k1,l1,ao_num,bielec_tmp_0(1,j1))
-        ! call compute_ao_bielec_integrals(j1,k1,l1,ao_num,bielec_tmp_0(1,j1))
-      enddo
-      do j1 = 1,ao_num
-        kmax = 0
-        do i1 = 1,ao_num
-          c = bielec_tmp_0(i1,j1)
-          if (c == 0.d0) then
-            cycle
-          endif
-          kmax += 1
-          bielec_tmp_0(kmax,j1) = c
-          bielec_tmp_0_idx(kmax) = i1
-        enddo
-        
-        if (kmax==0) then
-          cycle
-        endif
-        
-        !DEC$ VECTOR ALIGNED
-        bielec_tmp_1 = 0.d0
-        ii1=1
-        do ii1 = 1,kmax-4,4
-          i1 = bielec_tmp_0_idx(ii1)
-          i2 = bielec_tmp_0_idx(ii1+1)
-          i3 = bielec_tmp_0_idx(ii1+2)
-          i4 = bielec_tmp_0_idx(ii1+3)
-          do i = list_ijkl(1,1), list_ijkl(n_i,1)
-            bielec_tmp_1(i)  =  bielec_tmp_1(i) +                    &
-                mo_coef_transp(i,i1) * bielec_tmp_0(ii1,j1) +        &
-                mo_coef_transp(i,i2) * bielec_tmp_0(ii1+1,j1) +      &
-                mo_coef_transp(i,i3) * bielec_tmp_0(ii1+2,j1) +      &
-                mo_coef_transp(i,i4) * bielec_tmp_0(ii1+3,j1)
-          enddo ! i
-        enddo  ! ii1
-        
-        i2 = ii1
-        do ii1 = i2,kmax
-          i1 = bielec_tmp_0_idx(ii1)
-          do i = list_ijkl(1,1), list_ijkl(n_i,1)
-            bielec_tmp_1(i) = bielec_tmp_1(i) + mo_coef_transp(i,i1) * bielec_tmp_0(ii1,j1)
-          enddo ! i
-        enddo  ! ii1
-        c = 0.d0
-        
-        do i = list_ijkl(1,1), list_ijkl(n_i,1)
-          c = max(c,abs(bielec_tmp_1(i)))
-          if (c>mo_integrals_threshold) exit
-        enddo
-        if ( c < mo_integrals_threshold ) then
-          cycle
-        endif
-        
-        do j0 = 1, n_j
-          j = list_ijkl(j0,2)
-          c = mo_coef_transp(j,j1)
-          if (abs(c) < thr_coef) then
-            cycle
-          endif
-          do i = list_ijkl(1,1), list_ijkl(n_i,1)
-            bielec_tmp_2(i,j0)  = bielec_tmp_2(i,j0) + c * bielec_tmp_1(i)
-          enddo ! i
-        enddo  ! j
-      enddo !j1
-      if ( maxval(abs(bielec_tmp_2)) < mo_integrals_threshold ) then
-        cycle
-      endif
-      
-      
-      do k0 = 1, n_k
-        k = list_ijkl(k0,3)
-        c = mo_coef_transp(k,k1)
-        if (abs(c) < thr_coef) then
-          cycle
-        endif
-        
-        do j0 = 1, n_j
-          j = list_ijkl(j0,2)
-          do i = list_ijkl(1,1), k
-            bielec_tmp_3(i,j0,k0) = bielec_tmp_3(i,j0,k0) + c* bielec_tmp_2(i,j0)
-          enddo!i
-        enddo !j
-        
-      enddo  !k
-    enddo   !k1
-    
-    
-    
-    do l0 = 1,n_l
-      l = list_ijkl(l0,4)
-      c = mo_coef_transp(l,l1)
-      if (abs(c) < thr_coef) then
-        cycle
-      endif
-      j1 = ishft((l*l-l),-1)
-      do j0 = 1, n_j
-        j = list_ijkl(j0,2)
-        if (j > l)  then
-          exit
-        endif
-        j1 += 1
-        do k0 = 1, n_k
-          k = list_ijkl(k0,3)
-          i1 = ishft((k*k-k),-1)
-          if (i1<=j1) then
-            continue
-          else
-            exit
-          endif
-          bielec_tmp_1 = 0.d0
-          do i0 = 1, n_i
-            i = list_ijkl(i0,1)
-            if (i>k) then
-              exit
-            endif
-            bielec_tmp_1(i) = c*bielec_tmp_3(i,j0,k0)
-            !           i1+=1
-          enddo
-          
-          do i0 = 1, n_i
-            i = list_ijkl(i0,1)
-            if(i> min(k,j1-i1+list_ijkl(1,1)-1))then
-              exit
-            endif
-            if (abs(bielec_tmp_1(i)) < mo_integrals_threshold) then
-              cycle
-            endif
-            n_integrals += 1
-            buffer_value(n_integrals) = bielec_tmp_1(i)
-            !DEC$ FORCEINLINE
-            call mo_bielec_integrals_erf_index(i,j,k,l,buffer_i(n_integrals))
-            if (n_integrals == size_buffer) then
-              call insert_into_mo_integrals_erf_map(n_integrals,buffer_i,buffer_value,&
-                  real(mo_integrals_threshold,integral_kind))
-              n_integrals = 0
-            endif
-          enddo
-        enddo
-      enddo
-    enddo
-    
-    call wall_time(wall_2)
-    if (thread_num == 0) then
-      if (wall_2 - wall_0 > 1.d0) then
-        wall_0 = wall_2
-        print*, 100.*float(l1)/float(ao_num), '% in ',               &
-            wall_2-wall_1, 's', map_mb(mo_integrals_erf_map) ,'MB'
-      endif
-    endif
-  enddo
-  !$OMP END DO NOWAIT
-  deallocate (bielec_tmp_1,bielec_tmp_2,bielec_tmp_3)
-  
-  integer                        :: index_needed
-  
-  call insert_into_mo_integrals_erf_map(n_integrals,buffer_i,buffer_value,&
-      real(mo_integrals_threshold,integral_kind))
-  deallocate(buffer_i, buffer_value)
-  !$OMP END PARALLEL
-  call map_unique(mo_integrals_erf_map)
-  
-  call wall_time(wall_2)
-  call cpu_time(cpu_2)
-  integer*8                      :: get_mo_erf_map_size, mo_erf_map_size
-  mo_erf_map_size = get_mo_erf_map_size()
-  
-  deallocate(list_ijkl)
-  
-  
-  print*,'Molecular integrals provided:'
-  print*,' Size of MO map           ', map_mb(mo_integrals_erf_map) ,'MB'
-  print*,' Number of MO integrals: ',  mo_erf_map_size
-  print*,' cpu  time :',cpu_2 - cpu_1, 's'
-  print*,' wall time :',wall_2 - wall_1, 's  ( x ', (cpu_2-cpu_1)/(wall_2-wall_1), ')'
-  
-end
-
-
-
- BEGIN_PROVIDER [ double precision, mo_bielec_integral_erf_jj_from_ao, (mo_tot_num_align,mo_tot_num) ]
-&BEGIN_PROVIDER [ double precision, mo_bielec_integral_erf_jj_exchange_from_ao, (mo_tot_num_align,mo_tot_num) ]
-&BEGIN_PROVIDER [ double precision, mo_bielec_integral_erf_jj_anti_from_ao, (mo_tot_num_align,mo_tot_num) ]
-  BEGIN_DOC
-  ! mo_bielec_integral_jj_from_ao(i,j) = J_ij
-  ! mo_bielec_integral_jj_exchange_from_ao(i,j) = J_ij
-  ! mo_bielec_integral_jj_anti_from_ao(i,j) = J_ij - K_ij
-  END_DOC
-  implicit none
-  integer                        :: i,j,p,q,r,s
-  double precision               :: c
-  real(integral_kind)            :: integral
-  integer                        :: n, pp
-  real(integral_kind), allocatable :: int_value(:)
-  integer, allocatable           :: int_idx(:)
-  
-  double precision, allocatable  :: iqrs(:,:), iqsr(:,:), iqis(:), iqri(:)
-  
-  if (.not.do_direct_integrals) then
-    PROVIDE ao_bielec_integrals_erf_in_map mo_coef
-  endif
-  
-  mo_bielec_integral_erf_jj_from_ao = 0.d0
-  mo_bielec_integral_erf_jj_exchange_from_ao = 0.d0
-  
-  !DIR$ ATTRIBUTES ALIGN : $IRP_ALIGN :: iqrs, iqsr
-  
-  
-  !$OMP PARALLEL DEFAULT(NONE)                                       &
-      !$OMP PRIVATE (i,j,p,q,r,s,integral,c,n,pp,int_value,int_idx,  &
-      !$OMP  iqrs, iqsr,iqri,iqis)                                   &
-      !$OMP SHARED(mo_tot_num,mo_coef_transp,mo_tot_num_align,ao_num,&
-      !$OMP  ao_integrals_threshold,do_direct_integrals)             &
-      !$OMP REDUCTION(+:mo_bielec_integral_erf_jj_from_ao,mo_bielec_integral_erf_jj_exchange_from_ao)
-  
-  allocate( int_value(ao_num), int_idx(ao_num),                      &
-      iqrs(mo_tot_num_align,ao_num), iqis(mo_tot_num), iqri(mo_tot_num),&
-      iqsr(mo_tot_num_align,ao_num) )
-  
-  !$OMP DO SCHEDULE (guided)
-  do s=1,ao_num
-    do q=1,ao_num
-      
-      do j=1,ao_num
-        !DIR$ VECTOR ALIGNED
-        do i=1,mo_tot_num
-          iqrs(i,j) = 0.d0
-          iqsr(i,j) = 0.d0
-        enddo
-      enddo
-      
-      if (do_direct_integrals) then
-        double precision               :: ao_bielec_integral_erf
-        do r=1,ao_num
-          call compute_ao_bielec_integrals_erf(q,r,s,ao_num,int_value)
-          do p=1,ao_num
-            integral = int_value(p)
-            if (abs(integral) > ao_integrals_threshold) then
-              !DIR$ VECTOR ALIGNED
-              do i=1,mo_tot_num
-                iqrs(i,r) += mo_coef_transp(i,p) * integral
-              enddo
-            endif
-          enddo
-          call compute_ao_bielec_integrals_erf(q,s,r,ao_num,int_value)
-          do p=1,ao_num
-            integral = int_value(p)
-            if (abs(integral) > ao_integrals_threshold) then
-              !DIR$ VECTOR ALIGNED
-              do i=1,mo_tot_num
-                iqsr(i,r) += mo_coef_transp(i,p) * integral
-              enddo
-            endif
-          enddo
-        enddo
-        
-      else
-        
-        do r=1,ao_num
-          call get_ao_bielec_integrals_erf_non_zero(q,r,s,ao_num,int_value,int_idx,n)
-          do pp=1,n
-            p = int_idx(pp)
-            integral = int_value(pp)
-            if (abs(integral) > ao_integrals_threshold) then
-              !DIR$ VECTOR ALIGNED
-              do i=1,mo_tot_num
-                iqrs(i,r) += mo_coef_transp(i,p) * integral
-              enddo
-            endif
-          enddo
-          call get_ao_bielec_integrals_erf_non_zero(q,s,r,ao_num,int_value,int_idx,n)
-          do pp=1,n
-            p = int_idx(pp)
-            integral = int_value(pp)
-            if (abs(integral) > ao_integrals_threshold) then
-              !DIR$ VECTOR ALIGNED
-              do i=1,mo_tot_num
-                iqsr(i,r) += mo_coef_transp(i,p) * integral
-              enddo
-            endif
-          enddo
-        enddo
-      endif
-      iqis = 0.d0
-      iqri = 0.d0
-      do r=1,ao_num
-        !DIR$ VECTOR ALIGNED
-        do i=1,mo_tot_num
-          iqis(i) += mo_coef_transp(i,r) * iqrs(i,r)
-          iqri(i) += mo_coef_transp(i,r) * iqsr(i,r)
-        enddo
-      enddo
-      do i=1,mo_tot_num
-        !DIR$ VECTOR ALIGNED
-        do j=1,mo_tot_num
-          c = mo_coef_transp(j,q)*mo_coef_transp(j,s)
-          mo_bielec_integral_erf_jj_from_ao(j,i) += c * iqis(i)
-          mo_bielec_integral_erf_jj_exchange_from_ao(j,i) += c * iqri(i)
-        enddo
-      enddo
-      
-    enddo
-  enddo
-  !$OMP END DO NOWAIT
-  deallocate(iqrs,iqsr,int_value,int_idx)
-  !$OMP END PARALLEL
-  
-  mo_bielec_integral_erf_jj_anti_from_ao = mo_bielec_integral_erf_jj_from_ao - mo_bielec_integral_erf_jj_exchange_from_ao
-  
-  
-! end
-END_PROVIDER 
-
-
- BEGIN_PROVIDER [ double precision, mo_bielec_integral_erf_jj, (mo_tot_num_align,mo_tot_num) ]
-&BEGIN_PROVIDER [ double precision, mo_bielec_integral_erf_jj_exchange, (mo_tot_num_align,mo_tot_num) ]
-&BEGIN_PROVIDER [ double precision, mo_bielec_integral_erf_jj_anti, (mo_tot_num_align,mo_tot_num) ]
-  implicit none
-  BEGIN_DOC
-  ! mo_bielec_integral_jj(i,j) = J_ij
-  ! mo_bielec_integral_jj_exchange(i,j) = K_ij
-  ! mo_bielec_integral_jj_anti(i,j) = J_ij - K_ij
-  END_DOC
-  
-  integer                        :: i,j
-  double precision               :: get_mo_bielec_integral_erf
-  
-  PROVIDE mo_bielec_integrals_erf_in_map
-  mo_bielec_integral_erf_jj = 0.d0
-  mo_bielec_integral_erf_jj_exchange = 0.d0
-  
-  do j=1,mo_tot_num
-    do i=1,mo_tot_num
-      mo_bielec_integral_erf_jj(i,j) = get_mo_bielec_integral_erf(i,j,i,j,mo_integrals_erf_map)
-      mo_bielec_integral_erf_jj_exchange(i,j) = get_mo_bielec_integral_erf(i,j,j,i,mo_integrals_erf_map)
-      mo_bielec_integral_erf_jj_anti(i,j) = mo_bielec_integral_erf_jj(i,j) - mo_bielec_integral_erf_jj_exchange(i,j)
-    enddo
-  enddo
-  
-END_PROVIDER
-
-
-subroutine clear_mo_erf_map
-  implicit none
-  BEGIN_DOC
-  ! Frees the memory of the MO map
-  END_DOC
-  call map_deinit(mo_integrals_erf_map)
-  FREE mo_integrals_erf_map mo_bielec_integral_erf_jj mo_bielec_integral_erf_jj_anti
-  FREE mo_bielec_integral_Erf_jj_exchange mo_bielec_integrals_erf_in_map
-  
-  
-end
-
-subroutine provide_all_mo_integrals_erf
-  implicit none
-  provide mo_integrals_erf_map mo_bielec_integral_erf_jj mo_bielec_integral_erf_jj_anti
-  provide mo_bielec_integral_erf_jj_exchange mo_bielec_integrals_erf_in_map
-  
-end

plugins/Integrals_erf/providers_ao_erf.irp.f

@@ -1,119 +0,0 @@
-
-BEGIN_PROVIDER [ logical, ao_bielec_integrals_erf_in_map ]
-  implicit none
-  use f77_zmq
-  use map_module
-  BEGIN_DOC
-  !  Map of Atomic integrals
-  !     i(r1) j(r2) 1/r12 k(r1) l(r2)
-  END_DOC
-  
-  integer                        :: i,j,k,l
-  double precision               :: ao_bielec_integral_erf,cpu_1,cpu_2, wall_1, wall_2
-  double precision               :: integral, wall_0
-  include 'Utils/constants.include.F'
-  
-  ! For integrals file
-  integer(key_kind),allocatable  :: buffer_i(:)
-  integer,parameter              :: size_buffer = 1024*64
-  real(integral_kind),allocatable :: buffer_value(:)
-  
-  integer                        :: n_integrals, rc
-  integer                        :: kk, m, j1, i1, lmax
-  character*(64)                 :: fmt
-  
-  integral = ao_bielec_integral_erf(1,1,1,1)
-  
-  real                           :: map_mb
-  PROVIDE read_ao_integrals_erf disk_access_ao_integrals_erf
-  if (read_ao_integrals_erf) then
-    print*,'Reading the AO integrals_erf'
-      call map_load_from_disk(trim(ezfio_filename)//'/work/ao_ints_erf',ao_integrals_erf_map)
-      print*, 'AO integrals_erf provided'
-      ao_bielec_integrals_erf_in_map = .True.
-      return
-  endif
-  
-  print*, 'Providing the AO integrals_erf'
-  call wall_time(wall_0)
-  call wall_time(wall_1)
-  call cpu_time(cpu_1)
-
-  integer(ZMQ_PTR) :: zmq_to_qp_run_socket
-  call new_parallel_job(zmq_to_qp_run_socket,'ao_integrals_erf')
-
-  character(len=:), allocatable :: task
-  allocate(character(len=ao_num*12) :: task)
-  write(fmt,*) '(', ao_num, '(I5,X,I5,''|''))'
-  do l=1,ao_num
-    write(task,fmt) (i,l, i=1,l)
-    call add_task_to_taskserver(zmq_to_qp_run_socket,trim(task))
-  enddo
-  deallocate(task)
-  
-  call zmq_set_running(zmq_to_qp_run_socket)
-
-  PROVIDE nproc
-  !$OMP PARALLEL DEFAULT(private) num_threads(nproc+1)
-      i = omp_get_thread_num()
-      if (i==0) then
-        call ao_bielec_integrals_erf_in_map_collector(i)
-      else
-        call ao_bielec_integrals_erf_in_map_slave_inproc(i)
-      endif
-  !$OMP END PARALLEL
-
-  call end_parallel_job(zmq_to_qp_run_socket, 'ao_integrals_erf')
-
-
-  print*, 'Sorting the map'
-  call map_sort(ao_integrals_erf_map)
-  call cpu_time(cpu_2)
-  call wall_time(wall_2)
-  integer(map_size_kind)         :: get_ao_erf_map_size, ao_erf_map_size
-  ao_erf_map_size = get_ao_erf_map_size()
-  
-  print*, 'AO integrals provided:'
-  print*, ' Size of AO map :         ', map_mb(ao_integrals_erf_map) ,'MB'
-  print*, ' Number of AO integrals :', ao_erf_map_size
-  print*, ' cpu  time :',cpu_2 - cpu_1, 's'
-  print*, ' wall time :',wall_2 - wall_1, 's  ( x ', (cpu_2-cpu_1)/(wall_2-wall_1+tiny(1.d0)), ' )'
-  
-  ao_bielec_integrals_erf_in_map = .True.
-
-  if (write_ao_integrals_erf) then
-    call ezfio_set_work_empty(.False.)
-    call map_save_to_disk(trim(ezfio_filename)//'/work/ao_ints_erf',ao_integrals_erf_map)
-    call ezfio_set_integrals_erf_disk_access_ao_integrals_erf("Read")
-  endif
-  
-END_PROVIDER
- 
-
-
-
-BEGIN_PROVIDER [ double precision, ao_bielec_integral_erf_schwartz,(ao_num,ao_num)  ]
-  implicit none
-  BEGIN_DOC
-  !  Needed to compute Schwartz inequalities
-  END_DOC
-  
-  integer                        :: i,k
-  double precision               :: ao_bielec_integral_erf,cpu_1,cpu_2, wall_1, wall_2
-  
-  ao_bielec_integral_erf_schwartz(1,1) = ao_bielec_integral_erf(1,1,1,1)
-  !$OMP PARALLEL DO PRIVATE(i,k)                                     &
-      !$OMP DEFAULT(NONE)                                            &
-      !$OMP SHARED (ao_num,ao_bielec_integral_erf_schwartz)              &
-      !$OMP SCHEDULE(dynamic)
-  do i=1,ao_num
-    do k=1,i
-      ao_bielec_integral_erf_schwartz(i,k) = dsqrt(ao_bielec_integral_erf(i,k,i,k))
-      ao_bielec_integral_erf_schwartz(k,i) = ao_bielec_integral_erf_schwartz(i,k)
-    enddo
-  enddo
-  !$OMP END PARALLEL DO
-  
-END_PROVIDER
-
-

plugins/Integrals_erf/qp_ao_erf_ints.irp.f

@@ -1,32 +0,0 @@
-program qp_ao_ints
-  use omp_lib
-  implicit none
-  BEGIN_DOC
-! Increments a running calculation to compute AO integral_erfs
-  END_DOC
-  integer :: i
-
-  call switch_qp_run_to_master
-
-  zmq_context = f77_zmq_ctx_new ()
-
-  ! Set the state of the ZMQ
-  zmq_state = 'ao_integral_erfs'
-
-  ! Provide everything needed
-  double precision :: integral_erf, ao_bielec_integral_erf
-  integral_erf = ao_bielec_integral_erf(1,1,1,1)
-
-  character*(64) :: state
-  call wait_for_state(zmq_state,state)
-  do while (state /= 'Stopped')
-    !$OMP PARALLEL DEFAULT(PRIVATE) PRIVATE(i)
-    i = omp_get_thread_num()
-    call ao_bielec_integrals_erf_in_map_slave_tcp(i)
-    !$OMP END PARALLEL
-    call wait_for_state(zmq_state,state)
-  enddo
-
-  print *,  'Done'
-end
-

plugins/Integrals_erf/read_write.irp.f

@@ -1,47 +0,0 @@
-BEGIN_PROVIDER [ logical, read_ao_integrals_erf ]
-&BEGIN_PROVIDER [ logical, read_mo_integrals_erf ]
-&BEGIN_PROVIDER [ logical, write_ao_integrals_erf ]
-&BEGIN_PROVIDER [ logical, write_mo_integrals_erf ]
-
- BEGIN_DOC
-! One level of abstraction for disk_access_ao_integrals_erf and disk_access_mo_integrals_erf
- END_DOC
-implicit none
-
-    if (disk_access_ao_integrals_erf.EQ.'Read') then
-        read_ao_integrals_erf =  .True.
-        write_ao_integrals_erf = .False.
-
-    else if  (disk_access_ao_integrals_erf.EQ.'Write') then
-        read_ao_integrals_erf = .False.
-        write_ao_integrals_erf =  .True.
-    
-    else if (disk_access_ao_integrals_erf.EQ.'None') then
-        read_ao_integrals_erf = .False.
-        write_ao_integrals_erf = .False.
-
-    else
-        print *, 'bielec_integrals_erf/disk_access_ao_integrals_erf has a wrong type'
-        stop 1
-
-    endif
-
-    if (disk_access_mo_integrals_erf.EQ.'Read') then
-        read_mo_integrals_erf =  .True.
-        write_mo_integrals_erf = .False.
-
-    else if  (disk_access_mo_integrals_erf.EQ.'Write') then
-        read_mo_integrals_erf = .False.
-        write_mo_integrals_erf =  .True.
-
-    else if (disk_access_mo_integrals_erf.EQ.'None') then
-        read_mo_integrals_erf = .False.
-        write_mo_integrals_erf = .False.
-
-    else
-        print *, 'bielec_integrals_erf/disk_access_mo_integrals_erf has a wrong type'
-        stop 1
-
-    endif
-
-END_PROVIDER

plugins/Integrals_restart_DFT/NEEDED_CHILDREN_MODULES

@@ -1 +0,0 @@
-Integrals_Monoelec Integrals_erf Determinants DFT_Utils

plugins/Integrals_restart_DFT/README.rst

@@ -1,12 +0,0 @@
-==============
-core_integrals
-==============
-
-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/Integrals_restart_DFT/short_range_coulomb.irp.f

@@ -1,79 +0,0 @@
-BEGIN_PROVIDER [double precision, density_matrix_read, (mo_tot_num, mo_tot_num)]
- implicit none
- integer :: i,j,k,l
- logical                        :: exists
- call ezfio_has_determinants_density_matrix_mo_disk(exists)
- if(exists)then
-  print*, 'reading the density matrix from input'
-  call ezfio_get_determinants_density_matrix_mo_disk(exists)
-  print*, 'reading done'
- else 
-  print*, 'no density matrix found in EZFIO file ...'
-  print*, 'stopping ..'
-  stop
- endif
-
-END_PROVIDER
-
-
-BEGIN_PROVIDER [double precision, effective_short_range_operator, (mo_tot_num,mo_tot_num)]
- implicit none
- integer :: i,j,k,l,m,n
- double precision :: get_mo_bielec_integral,get_mo_bielec_integral_erf
- double precision :: integral, integral_erf
- effective_short_range_operator = 0.d0
- do i = 1, mo_tot_num
-  do j = 1, mo_tot_num
-   if(dabs(one_body_dm_mo(i,j)).le.1.d-10)cycle
-   do k = 1, mo_tot_num
-    do l = 1, mo_tot_num
-     integral = get_mo_bielec_integral(i,k,j,l,mo_integrals_map)
-!    integral_erf = get_mo_bielec_integral_erf(i,k,j,l,mo_integrals_erf_map)
-     effective_short_range_operator(l,k) += one_body_dm_mo(i,j) * integral
-    enddo
-   enddo
-  enddo
- enddo
-END_PROVIDER
-
-
-BEGIN_PROVIDER [double precision, effective_one_e_potential, (mo_tot_num_align, mo_tot_num,N_states)]
- implicit none
- integer :: i,j,i_state
- effective_one_e_potential = 0.d0
- do i_state = 1, N_states
-  do i = 1, mo_tot_num
-   do j = 1, mo_tot_num
-    effective_one_e_potential(i,j,i_state) = effective_short_range_operator(i,j) + mo_nucl_elec_integral(i,j) + mo_kinetic_integral(i,j) & 
-                                   + 0.5d0 * (lda_ex_potential_alpha_ao(i,j,i_state) + lda_ex_potential_beta_ao(i,j,i_state))
-   enddo
-  enddo
- enddo
-
-END_PROVIDER 
-
-subroutine save_one_e_effective_potential  
- implicit none
- double precision, allocatable :: tmp(:,:)
- allocate(tmp(size(effective_one_e_potential,1),size(effective_one_e_potential,2)))
- integer :: i,j
- do i = 1, mo_tot_num
-  do j = 1, mo_tot_num
-   tmp(i,j) = effective_one_e_potential(i,j,1)
-  enddo
- enddo
- call write_one_e_integrals('mo_one_integral', tmp,      &
-      size(tmp,1), size(tmp,2))
- call ezfio_set_integrals_monoelec_disk_access_only_mo_one_integrals("Read")
- deallocate(tmp)
-
-end
-
-subroutine save_erf_bi_elec_integrals
- implicit none
- integer :: i,j,k,l
- PROVIDE mo_bielec_integrals_erf_in_map
- call ezfio_set_work_empty(.False.)
- call map_save_to_disk(trim(ezfio_filename)//'/work/mo_ints',mo_integrals_erf_map)
- call ezfio_set_integrals_bielec_disk_access_mo_integrals("Read")
-end

plugins/Integrals_restart_DFT/write_integrals_restart_dft.irp.f

@@ -1,18 +0,0 @@
-program write_integrals
- implicit none
- read_wf = .true.
- touch read_wf
- disk_access_only_mo_one_integrals = "None"
- touch disk_access_only_mo_one_integrals
- disk_access_mo_integrals = "None"
- touch disk_access_mo_integrals
- call routine
-
-end
-
-subroutine routine
- implicit none
- call save_one_e_effective_potential
- call save_erf_bi_elec_integrals
-
-end

plugins/Kohn_Sham/EZFIO.cfg

@@ -1,54 +0,0 @@
-[thresh_scf]
-type: Threshold
-doc: Threshold on the convergence of the Hartree Fock energy
-interface: ezfio,provider,ocaml
-default: 1.e-10
-
-[exchange_functional]
-type: character*(256)
-doc: name of the exchange functional
-interface: ezfio, provider, ocaml
-default: "LDA"
-
-
-[correlation_functional]
-type: character*(256)
-doc: name of the correlation functional
-interface: ezfio, provider, ocaml
-default: "LDA"
-
-[HF_exchange]
-type: double precision
-doc: Percentage of HF exchange in the DFT model
-interface: ezfio,provider,ocaml
-default: 0.
-
-[n_it_scf_max]
-type: Strictly_positive_int
-doc: Maximum number of SCF iterations
-interface: ezfio,provider,ocaml
-default: 200
-
-[level_shift]
-type: Positive_float
-doc: Energy shift on the virtual MOs to improve SCF convergence
-interface: ezfio,provider,ocaml
-default: 0.5
-
-[mo_guess_type]
-type: MO_guess
-doc: Initial MO guess. Can be [ Huckel | HCore ]
-interface: ezfio,provider,ocaml
-default: Huckel
-
-[energy]
-type: double precision
-doc: Calculated HF energy
-interface: ezfio
-
-[no_oa_or_av_opt]
-type: logical
-doc: If true, skip the (inactive+core) --> (active) and the (active) --> (virtual) orbital rotations within the SCF procedure
-interface: ezfio,provider,ocaml
-default: False
-

plugins/Kohn_Sham/Fock_matrix.irp.f

@@ -1,468 +0,0 @@
- BEGIN_PROVIDER [ double precision, Fock_matrix_mo, (mo_tot_num_align,mo_tot_num) ]
-&BEGIN_PROVIDER [ double precision, Fock_matrix_diag_mo, (mo_tot_num)]
-   implicit none
-   BEGIN_DOC
-   ! Fock matrix on the MO basis.
-   ! For open shells, the ROHF Fock Matrix is
-   !
-   !  |   F-K    |  F + K/2  |    F     |
-   !  |---------------------------------|
-   !  | F + K/2  |     F     |  F - K/2 |
-   !  |---------------------------------|
-   !  |    F     |  F - K/2  |  F + K   |
-   !
-   ! F = 1/2 (Fa + Fb)
-   !
-   ! K = Fb - Fa
-   !
-   END_DOC
-   integer                        :: i,j,n
-   if (elec_alpha_num == elec_beta_num) then
-     Fock_matrix_mo = Fock_matrix_alpha_mo
-   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))
-       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))
-       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))
-       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))
-       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))
-       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))
-       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))
-       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))
-       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))
-       enddo
-     enddo
-     
-   endif
-
-   do i = 1, mo_tot_num
-     Fock_matrix_diag_mo(i) = Fock_matrix_mo(i,i) 
-   enddo
-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) ]
- implicit none
- BEGIN_DOC
- ! Alpha Fock matrix in AO basis set
- END_DOC
- 
- integer                        :: i,j
- do j=1,ao_num
-   !DIR$ VECTOR ALIGNED
-   do i=1,ao_num
-     Fock_matrix_alpha_ao(i,j) = Fock_matrix_alpha_no_xc_ao(i,j) + ao_potential_alpha_xc(i,j)
-     Fock_matrix_beta_ao (i,j) = Fock_matrix_beta_no_xc_ao(i,j)  + ao_potential_beta_xc(i,j)
-   enddo
- enddo
-
-END_PROVIDER
-
-
- BEGIN_PROVIDER [ double precision, Fock_matrix_alpha_no_xc_ao, (ao_num_align, ao_num) ]
-&BEGIN_PROVIDER [ double precision, Fock_matrix_beta_no_xc_ao,  (ao_num_align, ao_num) ]
- implicit none
- BEGIN_DOC
- ! Mono electronic an Coulomb matrix in AO basis set
- END_DOC
- 
- integer                        :: i,j
- do j=1,ao_num
-   !DIR$ VECTOR ALIGNED
-   do i=1,ao_num
-     Fock_matrix_alpha_no_xc_ao(i,j) = ao_mono_elec_integral(i,j) + ao_bi_elec_integral_alpha(i,j) 
-     Fock_matrix_beta_no_xc_ao(i,j) = ao_mono_elec_integral(i,j) + ao_bi_elec_integral_beta (i,j) 
-   enddo
- enddo
-
-END_PROVIDER
-
-
-
- BEGIN_PROVIDER [ double precision, ao_bi_elec_integral_alpha, (ao_num_align, ao_num) ]
-&BEGIN_PROVIDER [ double precision, ao_bi_elec_integral_beta ,  (ao_num_align, ao_num) ]
- use map_module
- implicit none
- BEGIN_DOC
- ! Alpha Fock matrix in AO basis set
- END_DOC
- 
- integer                        :: i,j,k,l,k1,r,s
- integer                        :: i0,j0,k0,l0
- integer*8                      :: p,q
- double precision               :: integral, c0, c1, c2
- double precision               :: ao_bielec_integral, local_threshold
- double precision, allocatable  :: ao_bi_elec_integral_alpha_tmp(:,:)
- double precision, allocatable  :: ao_bi_elec_integral_beta_tmp(:,:)
- !DIR$ ATTRIBUTES ALIGN : $IRP_ALIGN :: ao_bi_elec_integral_beta_tmp
- !DIR$ ATTRIBUTES ALIGN : $IRP_ALIGN :: ao_bi_elec_integral_alpha_tmp
-
- ao_bi_elec_integral_alpha = 0.d0
- ao_bi_elec_integral_beta  = 0.d0
- if (do_direct_integrals) then
-
-   !$OMP PARALLEL DEFAULT(NONE)                                      &
-       !$OMP PRIVATE(i,j,l,k1,k,integral,ii,jj,kk,ll,i8,keys,values,p,q,r,s,i0,j0,k0,l0, &
-       !$OMP ao_bi_elec_integral_alpha_tmp,ao_bi_elec_integral_beta_tmp, c0, c1, c2, &
-       !$OMP local_threshold)&
-       !$OMP SHARED(ao_num,ao_num_align,HF_density_matrix_ao_alpha,HF_density_matrix_ao_beta,&
-       !$OMP ao_integrals_map,ao_integrals_threshold, ao_bielec_integral_schwartz, &
-       !$OMP ao_overlap_abs, ao_bi_elec_integral_alpha, ao_bi_elec_integral_beta)
-
-   allocate(keys(1), values(1))
-   allocate(ao_bi_elec_integral_alpha_tmp(ao_num_align,ao_num), &
-            ao_bi_elec_integral_beta_tmp(ao_num_align,ao_num))
-   ao_bi_elec_integral_alpha_tmp = 0.d0
-   ao_bi_elec_integral_beta_tmp  = 0.d0
-
-   q = ao_num*ao_num*ao_num*ao_num
-   !$OMP DO SCHEDULE(dynamic)
-   do p=1_8,q
-           call bielec_integrals_index_reverse(kk,ii,ll,jj,p)
-           if ( (kk(1)>ao_num).or. &
-                (ii(1)>ao_num).or. &
-                (jj(1)>ao_num).or. &
-                (ll(1)>ao_num) ) then
-                cycle
-           endif
-           k = kk(1)
-           i = ii(1)
-           l = ll(1)
-           j = jj(1)
-
-           if (ao_overlap_abs(k,l)*ao_overlap_abs(i,j)  &
-              < ao_integrals_threshold) then
-             cycle
-           endif
-           local_threshold = ao_bielec_integral_schwartz(k,l)*ao_bielec_integral_schwartz(i,j)
-           if (local_threshold < ao_integrals_threshold) then
-             cycle
-           endif
-           i0 = i
-           j0 = j
-           k0 = k
-           l0 = l
-           values(1) = 0.d0
-           local_threshold = ao_integrals_threshold/local_threshold
-           do k2=1,8
-             if (kk(k2)==0) then
-               cycle
-             endif
-             i = ii(k2)
-             j = jj(k2)
-             k = kk(k2)
-             l = ll(k2)
-             c0 = HF_density_matrix_ao_alpha(k,l)+HF_density_matrix_ao_beta(k,l)
-             c1 = HF_density_matrix_ao_alpha(k,i)
-             c2 = HF_density_matrix_ao_beta(k,i)
-             if ( dabs(c0)+dabs(c1)+dabs(c2) < local_threshold) then
-               cycle
-             endif
-             if (values(1) == 0.d0) then
-               values(1) = ao_bielec_integral(k0,l0,i0,j0)
-             endif
-             integral = c0 * values(1)
-             ao_bi_elec_integral_alpha_tmp(i,j) += integral
-             ao_bi_elec_integral_beta_tmp (i,j) += integral
-             integral = values(1)
-             ao_bi_elec_integral_alpha_tmp(l,j) -= c1 * integral
-             ao_bi_elec_integral_beta_tmp (l,j) -= c2 * integral
-           enddo
-   enddo
-   !$OMP END DO NOWAIT
-   !$OMP CRITICAL
-   ao_bi_elec_integral_alpha += ao_bi_elec_integral_alpha_tmp
-   !$OMP END CRITICAL
-   !$OMP CRITICAL
-   ao_bi_elec_integral_beta  += ao_bi_elec_integral_beta_tmp
-   !$OMP END CRITICAL
-   deallocate(keys,values,ao_bi_elec_integral_alpha_tmp,ao_bi_elec_integral_beta_tmp)
-   !$OMP END PARALLEL
- else
-   PROVIDE ao_bielec_integrals_in_map 
-           
-   integer(omp_lock_kind) :: lck(ao_num)
-   integer*8                      :: i8
-   integer                        :: ii(8), jj(8), kk(8), ll(8), k2
-   integer(cache_map_size_kind)   :: n_elements_max, n_elements
-   integer(key_kind), allocatable :: keys(:)
-   double precision, allocatable  :: values(:)
-
-!  !$OMP PARALLEL DEFAULT(NONE)                                      &
-!      !$OMP PRIVATE(i,j,l,k1,k,integral,ii,jj,kk,ll,i8,keys,values,n_elements_max, &
-!      !$OMP  n_elements,ao_bi_elec_integral_alpha_tmp,ao_bi_elec_integral_beta_tmp)&
-!      !$OMP SHARED(ao_num,ao_num_align,HF_density_matrix_ao_alpha,HF_density_matrix_ao_beta,&
-!      !$OMP  ao_integrals_map, ao_bi_elec_integral_alpha, ao_bi_elec_integral_beta,HF_exchange) 
-
-   call get_cache_map_n_elements_max(ao_integrals_map,n_elements_max)
-   allocate(keys(n_elements_max), values(n_elements_max))
-   allocate(ao_bi_elec_integral_alpha_tmp(ao_num_align,ao_num), &
-            ao_bi_elec_integral_beta_tmp(ao_num_align,ao_num))
-   ao_bi_elec_integral_alpha_tmp = 0.d0
-   ao_bi_elec_integral_beta_tmp  = 0.d0
-
-!  !OMP DO SCHEDULE(dynamic)
-!  !DIR$ NOVECTOR
-   do i8=0_8,ao_integrals_map%map_size
-     n_elements = n_elements_max
-     call get_cache_map(ao_integrals_map,i8,keys,values,n_elements)
-     do k1=1,n_elements
-       call bielec_integrals_index_reverse(kk,ii,ll,jj,keys(k1))
-
-       do k2=1,8
-         if (kk(k2)==0) then
-           cycle
-         endif
-         i = ii(k2)
-         j = jj(k2)
-         k = kk(k2)
-         l = ll(k2)
-         integral = (HF_density_matrix_ao_alpha(k,l)+HF_density_matrix_ao_beta(k,l)) * values(k1)
-         ao_bi_elec_integral_alpha_tmp(i,j) += integral
-         ao_bi_elec_integral_beta_tmp (i,j) += integral
-         integral = values(k1)
-         ao_bi_elec_integral_alpha_tmp(l,j) -= HF_exchange * (HF_density_matrix_ao_alpha(k,i) * integral)
-         ao_bi_elec_integral_beta_tmp (l,j) -= HF_exchange * (HF_density_matrix_ao_beta (k,i) * integral)
-       enddo
-     enddo
-   enddo
-!  !$OMP END DO NOWAIT
-!  !$OMP CRITICAL
-   ao_bi_elec_integral_alpha += ao_bi_elec_integral_alpha_tmp
-!  !$OMP END CRITICAL
-!  !$OMP CRITICAL
-   ao_bi_elec_integral_beta  += ao_bi_elec_integral_beta_tmp
-!  !$OMP END CRITICAL
-   deallocate(keys,values,ao_bi_elec_integral_alpha_tmp,ao_bi_elec_integral_beta_tmp)
-!  !$OMP END PARALLEL
-
- endif
-
-END_PROVIDER
-
-
-
-
-
-
-BEGIN_PROVIDER [ double precision, Fock_matrix_alpha_mo, (mo_tot_num_align,mo_tot_num) ]
-   implicit none
-   BEGIN_DOC
-   ! Fock matrix on the MO basis
-   END_DOC
-   double precision, allocatable  :: T(:,:)
-   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),      &
-       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)
-   deallocate(T)
-END_PROVIDER
- 
- 
-BEGIN_PROVIDER [ double precision, Fock_matrix_beta_mo, (mo_tot_num_align,mo_tot_num) ]
-   implicit none
-   BEGIN_DOC
-   ! Fock matrix on the MO basis
-   END_DOC
-   double precision, allocatable  :: T(:,:)
-   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),        &
-       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)
-   deallocate(T)
-END_PROVIDER
- 
- BEGIN_PROVIDER [ double precision, HF_energy ]
-&BEGIN_PROVIDER [ double precision, two_electron_energy]
-&BEGIN_PROVIDER [ double precision, one_electron_energy]
- implicit none
- BEGIN_DOC
- ! Hartree-Fock energy
- END_DOC
- HF_energy = nuclear_repulsion
- 
- integer                        :: i,j
- double precision :: accu_mono,accu_fock
- one_electron_energy = 0.d0
- two_electron_energy = 0.d0
- do j=1,ao_num
-   do i=1,ao_num
-    two_electron_energy += 0.5d0 * ( ao_bi_elec_integral_alpha(i,j) * HF_density_matrix_ao_alpha(i,j) & 
-                +ao_bi_elec_integral_beta(i,j) * HF_density_matrix_ao_beta(i,j) ) 
-    one_electron_energy += ao_mono_elec_integral(i,j) * (HF_density_matrix_ao_alpha(i,j) + HF_density_matrix_ao_beta (i,j) )
-   enddo
- enddo
- print*, 'one_electron_energy = ',one_electron_energy
- print*, 'two_electron_energy = ',two_electron_energy
- print*, 'e_exchange_dft      = ',(1.d0 - HF_exchange) * e_exchange_dft
-!print*, 'accu_cor  = ',e_correlation_dft
- HF_energy += (1.d0 - HF_exchange) * e_exchange_dft + e_correlation_dft + one_electron_energy + two_electron_energy
-!print*, 'HF_energy '
-  
-END_PROVIDER
-
-
-BEGIN_PROVIDER [ double precision, Fock_matrix_ao, (ao_num_align, ao_num) ]
- implicit none
- BEGIN_DOC
- ! Fock matrix in AO basis set
- END_DOC
- 
- if ( (elec_alpha_num == elec_beta_num).and. &
-      (level_shift == 0.) ) &
- then
-   integer                        :: i,j
-   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)
-     enddo
-   enddo
- else
-   double precision, allocatable  :: T(:,:), M(:,:)
-   integer                        :: ierr
-   ! F_ao = S C F_mo C^t S
-   allocate (T(ao_num_align,ao_num),M(ao_num_align,ao_num),stat=ierr)
-   if (ierr /=0 ) then
-      print *,  irp_here, ' : allocation failed'
-   endif
-
-!  ao_overlap (ao_num,ao_num) . mo_coef (ao_num,mo_tot_num)
-!  -> M(ao_num,mo_tot_num)
-   call dgemm('N','N', ao_num,mo_tot_num,ao_num, 1.d0,               &
-       ao_overlap, size(ao_overlap,1),                               &
-       mo_coef, size(mo_coef,1),                                     &
-       0.d0,                                                         &
-       M, size(M,1))
-
-!  M(ao_num,mo_tot_num) . Fock_matrix_mo (mo_tot_num,mo_tot_num)
-!  -> T(ao_num,mo_tot_num)
-   call dgemm('N','N', ao_num,mo_tot_num,mo_tot_num, 1.d0,           &
-       M, size(M,1),                                                 &
-       Fock_matrix_mo, size(Fock_matrix_mo,1),                       &
-       0.d0,                                                         &
-       T, size(T,1))
-
-!  T(ao_num,mo_tot_num) . mo_coef^T (mo_tot_num,ao_num)
-!  -> M(ao_num,ao_num)
-   call dgemm('N','T', ao_num,ao_num,mo_tot_num, 1.d0,           &
-       T, size(T,1),                                                 &
-       mo_coef, size(mo_coef,1),                                     &
-       0.d0,                                                         &
-       M, size(M,1))
-
-!  M(ao_num,ao_num) . ao_overlap (ao_num,ao_num)
-!  -> Fock_matrix_ao(ao_num,ao_num)
-   call dgemm('N','N', ao_num,ao_num,ao_num, 1.d0,                   &
-       M, size(M,1),                                                 &
-       ao_overlap, size(ao_overlap,1),                               &
-       0.d0,                                                         &
-       Fock_matrix_ao, size(Fock_matrix_ao,1))
-
-
-   deallocate(T)
- endif
-END_PROVIDER
-
-subroutine Fock_mo_to_ao(FMO,LDFMO,FAO,LDFAO)
-  implicit none
-  integer, intent(in)            :: LDFMO ! size(FMO,1)
-  integer, intent(in)            :: LDFAO ! size(FAO,1)
-  double precision, intent(in)   :: FMO(LDFMO,*)
-  double precision, intent(out)  :: FAO(LDFAO,*)
-  
-  double precision, allocatable  :: T(:,:), M(:,:)
-  integer                        :: ierr
-  ! F_ao = S C F_mo C^t S
-  allocate (T(ao_num_align,ao_num),M(ao_num_align,ao_num),stat=ierr)
-  if (ierr /=0 ) then
-     print *,  irp_here, ' : allocation failed'
-  endif
-
-!  ao_overlap (ao_num,ao_num) . mo_coef (ao_num,mo_tot_num)
-!  -> M(ao_num,mo_tot_num)
-  call dgemm('N','N', ao_num,mo_tot_num,ao_num, 1.d0,                    &
-      ao_overlap, size(ao_overlap,1),                                &
-      mo_coef, size(mo_coef,1),                                      &
-      0.d0,                                                          &
-      M, size(M,1))
-
-!  M(ao_num,mo_tot_num) . FMO (mo_tot_num,mo_tot_num)
-!  -> T(ao_num,mo_tot_num)
-  call dgemm('N','N', ao_num,mo_tot_num,mo_tot_num, 1.d0,            &
-      M, size(M,1),                                                  &
-      FMO, size(FMO,1),                                              &
-      0.d0,                                                          &
-      T, size(T,1))
-
-!  T(ao_num,mo_tot_num) . mo_coef^T (mo_tot_num,ao_num)
-!  -> M(ao_num,ao_num)
-  call dgemm('N','T', ao_num,ao_num,mo_tot_num, 1.d0,            &
-      T, size(T,1),                                                  &
-      mo_coef, size(mo_coef,1),                                      &
-      0.d0,                                                          &
-      M, size(M,1))
-
-!  M(ao_num,ao_num) . ao_overlap (ao_num,ao_num)
-!  -> Fock_matrix_ao(ao_num,ao_num)
-  call dgemm('N','N', ao_num,ao_num,ao_num, 1.d0,                    &
-      M, size(M,1),                                                  &
-      ao_overlap, size(ao_overlap,1),                                &
-      0.d0,                                                          &
-      FAO, size(FAO,1))
-  deallocate(T,M)
-end
-

plugins/Kohn_Sham/HF_density_matrix_ao.irp.f

@@ -1,41 +0,0 @@
-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
-   END_DOC
-   
-   call dgemm('N','T',ao_num,ao_num,elec_alpha_num,1.d0, &
-        mo_coef, size(mo_coef,1), &
-        mo_coef, size(mo_coef,1), 0.d0, &
-        HF_density_matrix_ao_alpha, size(HF_density_matrix_ao_alpha,1))
-
-END_PROVIDER
-
-BEGIN_PROVIDER [ double precision, HF_density_matrix_ao_beta,  (ao_num_align,ao_num) ]
-   implicit none
-   BEGIN_DOC
-   ! S^-1 Beta density matrix in the AO basis x S^-1
-   END_DOC
-   
-   call dgemm('N','T',ao_num,ao_num,elec_beta_num,1.d0, &
-        mo_coef, size(mo_coef,1), &
-        mo_coef, size(mo_coef,1), 0.d0, &
-        HF_density_matrix_ao_beta, size(HF_density_matrix_ao_beta,1))
-
-END_PROVIDER
- 
-BEGIN_PROVIDER [ double precision, HF_density_matrix_ao, (ao_num_align,ao_num) ]
-   implicit none
-   BEGIN_DOC
-   ! S^-1 Density matrix in the AO basis S^-1
-   END_DOC
-   ASSERT (size(HF_density_matrix_ao,1) == size(HF_density_matrix_ao_alpha,1))
-   if (elec_alpha_num== elec_beta_num) then
-     HF_density_matrix_ao = HF_density_matrix_ao_alpha + HF_density_matrix_ao_alpha
-   else
-     ASSERT (size(HF_density_matrix_ao,1) == size(HF_density_matrix_ao_beta ,1))
-     HF_density_matrix_ao = HF_density_matrix_ao_alpha + HF_density_matrix_ao_beta
-   endif
-   
-END_PROVIDER
- 

plugins/Kohn_Sham/KS_SCF.irp.f

@@ -1,54 +0,0 @@
-program scf
-  BEGIN_DOC
-! Produce `Hartree_Fock` MO orbital 
-! 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 create_guess
-  call orthonormalize_mos
-  call run
-end
-
-subroutine create_guess
-  implicit none
-  BEGIN_DOC
-! Create an 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
-    if (mo_guess_type == "HCore") then
-      mo_coef = ao_ortho_lowdin_coef
-      TOUCH mo_coef
-      mo_label = 'Guess'
-      call mo_as_eigvectors_of_mo_matrix(mo_mono_elec_integral,size(mo_mono_elec_integral,1),size(mo_mono_elec_integral,2),mo_label)
-      SOFT_TOUCH mo_coef mo_label
-    else if (mo_guess_type == "Huckel") then
-      call huckel_guess
-    else
-      print *,  'Unrecognized MO guess type : '//mo_guess_type
-      stop 1
-    endif
-  endif
-end
-
-
-subroutine run
-
-  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
-  integer                        :: i_it, i, j, k
-   
-  E0 = HF_energy 
-
-  mo_label = "Canonical"
-  call damping_SCF
-  
-end

plugins/Kohn_Sham/NEEDED_CHILDREN_MODULES

@@ -1 +0,0 @@
-Integrals_Bielec MOGuess Bitmask DFT_Utils

plugins/Kohn_Sham/damping_SCF.irp.f

@@ -1,132 +0,0 @@
-subroutine damping_SCF
-  implicit none
-  double precision               :: E
-  double precision, allocatable  :: D_alpha(:,:), D_beta(:,:)
-  double precision               :: E_new
-  double precision, allocatable  :: D_new_alpha(:,:), D_new_beta(:,:), F_new(:,:)
-  double precision, allocatable  :: delta_alpha(:,:), delta_beta(:,:)
-  double precision               :: lambda, E_half, a, b, delta_D, delta_E, E_min
-  
-  integer                        :: i,j,k
-  logical                        :: saving
-  character                      :: save_char
-
-  allocate(                                                          &
-      D_alpha( ao_num_align, ao_num ),                               &
-      D_beta( ao_num_align, ao_num ),                                &
-      F_new( ao_num_align, ao_num ),                                 &
-      D_new_alpha( ao_num_align, ao_num ),                           &
-      D_new_beta( ao_num_align, ao_num ),                            &
-      delta_alpha( ao_num_align, ao_num ),                           &
-      delta_beta( ao_num_align, ao_num ))
-  
-  do j=1,ao_num
-    do i=1,ao_num
-      D_alpha(i,j) = HF_density_matrix_ao_alpha(i,j)
-      D_beta (i,j) = HF_density_matrix_ao_beta (i,j)
-    enddo
-  enddo
-  
-  
-  call write_time(output_hartree_fock)
-
-  write(output_hartree_fock,'(A4,1X,A16, 1X, A16, 1X, A16, 1X, A4 )')  &
-    '====','================','================','================', '===='
-  write(output_hartree_fock,'(A4,1X,A16, 1X, A16, 1X, A16, 1X, A4 )')  &
-    '  N ', 'Energy  ', 'Energy diff  ', 'Density diff  ', 'Save'
-  write(output_hartree_fock,'(A4,1X,A16, 1X, A16, 1X, A16, 1X, A4 )')  &
-    '====','================','================','================', '===='
-
-  E = HF_energy + 1.d0
-  E_min = HF_energy
-  delta_D = 0.d0
-  do k=1,n_it_scf_max
-    
-    delta_E = HF_energy - E
-    E = HF_energy
-    
-    if ( (delta_E < 0.d0).and.(dabs(delta_E) < thresh_scf) ) then
-      exit
-    endif
-
-    saving = E < E_min
-    if (saving) then
-      call save_mos
-      save_char = 'X'
-      E_min = E
-    else
-      save_char = ' '
-    endif
-
-    write(output_hartree_fock,'(I4,1X,F16.10, 1X, F16.10, 1X, F16.10, 3X, A )')  &
-      k, E, delta_E, delta_D, save_char
-    
-    D_alpha = HF_density_matrix_ao_alpha
-    D_beta  = HF_density_matrix_ao_beta 
-    mo_coef = eigenvectors_fock_matrix_mo
-    TOUCH mo_coef
-    
-    D_new_alpha = HF_density_matrix_ao_alpha
-    D_new_beta  = HF_density_matrix_ao_beta 
-    F_new = Fock_matrix_ao
-    E_new = HF_energy
-
-    delta_alpha = D_new_alpha - D_alpha
-    delta_beta  = D_new_beta  - D_beta 
-    
-    lambda = .5d0
-    E_half = 0.d0
-    do while (E_half > E)
-      HF_density_matrix_ao_alpha = D_alpha + lambda * delta_alpha
-      HF_density_matrix_ao_beta  = D_beta  + lambda * delta_beta
-      TOUCH HF_density_matrix_ao_alpha HF_density_matrix_ao_beta
-      mo_coef = eigenvectors_fock_matrix_mo
-      TOUCH mo_coef
-      E_half = HF_energy
-      if ((E_half > E).and.(E_new < E)) then
-        lambda = 1.d0
-        exit
-      else if ((E_half > E).and.(lambda > 5.d-4)) then
-        lambda = 0.5d0 * lambda
-        E_new = E_half
-      else
-        exit
-      endif
-    enddo
-
-    a = (E_new + E - 2.d0*E_half)*2.d0
-    b = -E_new - 3.d0*E + 4.d0*E_half
-    lambda = -lambda*b/(a+1.d-16)
-    D_alpha = (1.d0-lambda) * D_alpha + lambda * D_new_alpha
-    D_beta  = (1.d0-lambda) * D_beta  + lambda * D_new_beta 
-    delta_E = HF_energy - E
-    do j=1,ao_num
-      do i=1,ao_num
-        delta_D = delta_D + &
-        (D_alpha(i,j) - HF_density_matrix_ao_alpha(i,j))*(D_alpha(i,j) - HF_density_matrix_ao_alpha(i,j)) + &
-        (D_beta (i,j) - HF_density_matrix_ao_beta (i,j))*(D_beta (i,j) - HF_density_matrix_ao_beta (i,j))
-      enddo
-    enddo
-    delta_D = dsqrt(delta_D/dble(ao_num)**2)
-    HF_density_matrix_ao_alpha = D_alpha
-    HF_density_matrix_ao_beta  = D_beta
-    TOUCH HF_density_matrix_ao_alpha HF_density_matrix_ao_beta
-    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,*)
-  
-  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, E_min, 'Hartree-Fock energy')
-  call ezfio_set_hartree_fock_energy(E_min)
-
-  call write_time(output_hartree_fock)
-
-  deallocate(D_alpha,D_beta,F_new,D_new_alpha,D_new_beta,delta_alpha,delta_beta)
-end

plugins/Kohn_Sham/diagonalize_fock.irp.f

@@ -1,119 +0,0 @@
- BEGIN_PROVIDER [ double precision, diagonal_Fock_matrix_mo, (ao_num) ]
-&BEGIN_PROVIDER [ double precision, eigenvectors_Fock_matrix_mo, (ao_num_align,mo_tot_num) ]
-   implicit none
-   BEGIN_DOC
-   ! Diagonal Fock matrix in the MO basis
-   END_DOC
-   
-   integer                        :: i,j
-   integer                        :: liwork, lwork, n, info
-   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
-       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
-       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), 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
- 
-BEGIN_PROVIDER [double precision, diagonal_Fock_matrix_mo_sum, (mo_tot_num)]
- implicit none
- BEGIN_DOC
- ! diagonal element of the fock matrix calculated as the sum over all the interactions 
- ! with all the electrons in the RHF determinant
- ! diagonal_Fock_matrix_mo_sum(i) = sum_{j=1, N_elec} 2 J_ij -K_ij 
- END_DOC
- integer :: i,j
- double precision :: accu
- do j = 1,elec_alpha_num
-  accu = 0.d0
-  do i = 1, elec_alpha_num
-   accu += 2.d0 * mo_bielec_integral_jj_from_ao(i,j) - mo_bielec_integral_jj_exchange_from_ao(i,j)
-  enddo
-  diagonal_Fock_matrix_mo_sum(j) = accu + mo_mono_elec_integral(j,j)
- enddo
- do j = elec_alpha_num+1,mo_tot_num
-  accu = 0.d0
-  do i = 1, elec_alpha_num
-   accu += 2.d0 * mo_bielec_integral_jj_from_ao(i,j) - mo_bielec_integral_jj_exchange_from_ao(i,j)
-  enddo
-  diagonal_Fock_matrix_mo_sum(j) = accu + mo_mono_elec_integral(j,j)
- enddo
-
-END_PROVIDER

plugins/Kohn_Sham/potential_functional.irp.f

@@ -1,31 +0,0 @@
- BEGIN_PROVIDER [double precision, ao_potential_alpha_xc, (ao_num_align, ao_num)] 
-&BEGIN_PROVIDER [double precision, ao_potential_beta_xc, (ao_num_align, ao_num)] 
- implicit none
- integer :: i,j,k,l
- ao_potential_alpha_xc = 0.d0
- ao_potential_beta_xc = 0.d0
-!if(exchange_functional == "LDA")then
-  do i = 1, ao_num
-   do j = 1, ao_num
-    ao_potential_alpha_xc(i,j) = (1.d0 - HF_exchange) * lda_ex_potential_alpha_ao(i,j,1)
-    ao_potential_beta_xc(i,j) =  (1.d0 - HF_exchange) * lda_ex_potential_beta_ao(i,j,1)
-   enddo
-  enddo
-!endif
-END_PROVIDER 
-
-BEGIN_PROVIDER [double precision, e_exchange_dft]
- implicit none
-!if(exchange_functional == "LDA")then
-  e_exchange_dft = lda_exchange(1)
-!endif
- 
-END_PROVIDER 
-
-BEGIN_PROVIDER [double precision, e_correlation_dft]
- implicit none
-!if(correlation_functional == "LDA")then
-  e_correlation_dft = 0.d0
-!endif
- 
-END_PROVIDER 

plugins/MRCC_Utils/H_apply.irp.f

@@ -31,7 +31,7 @@ s.set_perturbation("epstein_nesbet_2x2")
 s.unset_openmp()
 print s
 
-s = H_apply("mrcepa_PT2")
+s = H_apply_zmq("mrcepa_PT2")
 s.energy = "psi_energy"
 s.set_perturbation("epstein_nesbet_2x2")
 s.unset_openmp()

plugins/MRCC_Utils/NEEDED_CHILDREN_MODULES

@@ -1 +1 @@
-Perturbation Selectors_full Generators_full Psiref_Utils Psiref_CAS MRPT_Utils
+Perturbation Selectors_full Generators_full Psiref_Utils Psiref_CAS 

plugins/MRCC_Utils/amplitudes.irp.f

@@ -23,39 +23,33 @@
  allocate(pathTo(N_det_non_ref))
 
  pathTo(:) = 0
- is_active_exc(:) = .True. 
+ is_active_exc(:) = .false.
  n_exc_active = 0
 
-! do hh = 1, hh_shortcut(0)
+ do hh = 1, hh_shortcut(0)
-!   do pp = hh_shortcut(hh), hh_shortcut(hh+1)-1
+   do pp = hh_shortcut(hh), hh_shortcut(hh+1)-1
-!     do II = 1, N_det_ref
+     do II = 1, N_det_ref
-!
-!       call apply_hole_local(psi_ref(1,1,II), hh_exists(1, hh), myMask, ok, N_int)
-!       if(.not. ok) cycle
-!
-!       call apply_particle_local(myMask, pp_exists(1, pp), myDet, ok, N_int)
-!       if(.not. ok) cycle
-!
-!       ind = searchDet(psi_non_ref_sorted(1,1,1), myDet(1,1), N_det_non_ref, N_int)
-!       if(ind == -1) cycle
-!
-!       logical, external :: is_a_two_holes_two_particles
-!       if (is_a_two_holes_two_particles(myDet)) then
-!         is_active_exc(pp) = .False.
-!       endif
 
-!       ind = psi_non_ref_sorted_idx(ind)
+       call apply_hole_local(psi_ref(1,1,II), hh_exists(1, hh), myMask, ok, N_int)
-!       if(pathTo(ind) == 0) then
+       if(.not. ok) cycle
-!         pathTo(ind) = pp
-!       else
-!         is_active_exc(pp) = .true.
-!         is_active_exc(pathTo(ind)) = .true.
-!       end if
 
-!     end do
+       call apply_particle_local(myMask, pp_exists(1, pp), myDet, ok, N_int)
-!   end do
+       if(.not. ok) cycle
-! end do
 
+       ind = searchDet(psi_non_ref_sorted(1,1,1), myDet(1,1), N_det_non_ref, N_int)
+       if(ind == -1) cycle
+
+       ind = psi_non_ref_sorted_idx(ind)
+       if(pathTo(ind) == 0) then
+         pathTo(ind) = pp
+       else
+         is_active_exc(pp) = .true.
+         is_active_exc(pathTo(ind)) = .true.
+       end if
+     end do
+   end do
+ end do
+!is_active_exc=.true.
  do hh = 1, hh_shortcut(0)
   do pp = hh_shortcut(hh), hh_shortcut(hh+1)-1
     if(is_active_exc(pp)) then
@@ -72,32 +66,6 @@
 
 END_PROVIDER
 
-BEGIN_PROVIDER [ logical, has_a_unique_parent, (N_det_non_ref) ]
- implicit none
- BEGIN_DOC
- ! True if the determinant in the non-reference has a unique parent
- END_DOC
- integer :: i,j,n
- integer :: degree
- do j=1,N_det_non_ref
-  has_a_unique_parent(j) = .True. 
-  n=0
-  do i=1,N_det_ref
-   call get_excitation_degree(psi_ref(1,1,i), psi_non_ref(1,1,j), degree, N_int)
-   if (degree < 2) then
-     n = n+1
-     if (n > 1) then
-       has_a_unique_parent(j) = .False.
-       exit
-     endif
-   endif
-  enddo
- enddo
-
-END_PROVIDER
-
-
-
 BEGIN_PROVIDER [ integer, n_exc_active_sze ]
  implicit none
  BEGIN_DOC
@@ -128,7 +96,7 @@ END_PROVIDER
      !$OMP   active_excitation_to_determinants_val, active_excitation_to_determinants_idx)&
      !$OMP shared(hh_shortcut, psi_ref_coef, N_det_non_ref, psi_non_ref_sorted, &
      !$OMP   psi_non_ref_sorted_idx, psi_ref, N_det_ref, N_states)&
-     !$OMP shared(active_hh_idx, active_pp_idx, n_exc_active)&
+     !$OMP shared(is_active_exc, active_hh_idx, active_pp_idx, n_exc_active)&
      !$OMP private(lref, pp, II, ok, myMask, myDet, ind, phase, wk, ppp, hh, s)
  allocate(lref(N_det_non_ref))
  !$OMP DO schedule(dynamic)

plugins/MRCC_Utils/davidson.irp.f

@@ -35,20 +35,21 @@ subroutine davidson_diag_mrcc(dets_in,u_in,energies,dim_in,sze,N_st,N_st_diag,Ni
   PROVIDE mo_bielec_integrals_in_map
   allocate(H_jj(sze))
   
-  H_jj(1) = diag_h_mat_elem(dets_in(1,1,1),Nint) 
   !$OMP PARALLEL DEFAULT(NONE)                                       &
       !$OMP  SHARED(sze,H_jj,N_det_ref,dets_in,Nint,istate,delta_ii,idx_ref)           &
       !$OMP  PRIVATE(i)
-  !$OMP DO 
+  !$OMP DO SCHEDULE(guided)
-  do i=2,sze
+  do i=1,sze
     H_jj(i) = diag_h_mat_elem(dets_in(1,1,i),Nint) 
   enddo
   !$OMP END DO 
+  !$OMP DO SCHEDULE(guided)
+  do i=1,N_det_ref
+    H_jj(idx_ref(i)) +=  delta_ii(istate,i)
+  enddo
+  !$OMP END DO 
   !$OMP END PARALLEL
 
-  do i=1,N_det_ref
-    H_jj(idx_ref(i)) +=  delta_ii(istate,i)
-  enddo
   call davidson_diag_hjj_mrcc(dets_in,u_in,H_jj,energies,dim_in,sze,N_st,N_st_diag,Nint,iunit,istate)
   deallocate (H_jj)
 end
@@ -223,6 +224,17 @@ subroutine davidson_diag_hjj_mrcc(dets_in,u_in,H_jj,energies,dim_in,sze,N_st,N_s
           W(i,k,iter+1) = 0.d0
         enddo
       enddo
+!      do k=1,N_st_diag
+!         do iter2=1,iter
+!          do l=1,N_st_diag
+!            do i=1,sze
+!              U(i,k,iter+1) = U(i,k,iter+1) + U(i,l,iter2)*y(l,iter2,k,1)
+!              W(i,k,iter+1) = W(i,k,iter+1) + W(i,l,iter2)*y(l,iter2,k,1)
+!            enddo
+!          enddo
+!        enddo
+!      enddo
+!
 !
       call dgemm('N','N', sze, N_st_diag, N_st_diag*iter,            &
           1.d0, U, size(U,1), y, size(y,1)*size(y,2), 0.d0, U(1,1,iter+1), size(U,1))
@@ -264,11 +276,27 @@ subroutine davidson_diag_hjj_mrcc(dets_in,u_in,H_jj,energies,dim_in,sze,N_st,N_s
       
       do k=1,N_st_diag
 
+!        do iter2=1,iter
+!          do l=1,N_st_diag
+!            c(1) = u_dot_v(U(1,k,iter+1),U(1,l,iter2),sze)
+!            do i=1,sze
+!              U(i,k,iter+1) = U(i,k,iter+1) - c(1) * U(i,l,iter2)
+!            enddo
+!          enddo
+!        enddo
+!
         call dgemv('T',sze,N_st_diag*iter,1.d0,U,size(U,1),  &
               U(1,k,iter+1),1,0.d0,c,1)
         call dgemv('N',sze,N_st_diag*iter,-1.d0,U,size(U,1), &
               c,1,1.d0,U(1,k,iter+1),1)
-
+!
+!        do l=1,k-1
+!          c(1) = u_dot_v(U(1,k,iter+1),U(1,l,iter+1),sze)
+!          do i=1,sze
+!            U(i,k,iter+1) = U(i,k,iter+1) - c(1) * U(i,l,iter+1)
+!          enddo
+!        enddo
+!
         call dgemv('T',sze,k-1,1.d0,U(1,1,iter+1),size(U,1),   &
             U(1,k,iter+1),1,0.d0,c,1)
         call dgemv('N',sze,k-1,-1.d0,U(1,1,iter+1),size(U,1),        &
@@ -401,7 +429,7 @@ subroutine H_u_0_mrcc_nstates(v_0,u_0,H_jj,n,keys_tmp,Nint,istate_in,N_st,sze_8)
   allocate(vt(sze_8,N_st))
   Vt = 0.d0
   
-  !$OMP DO SCHEDULE(static,1)
+  !$OMP DO SCHEDULE(dynamic)
   do sh=1,shortcut(0,1)
     do sh2=sh,shortcut(0,1)
       exa = 0
@@ -440,9 +468,9 @@ subroutine H_u_0_mrcc_nstates(v_0,u_0,H_jj,n,keys_tmp,Nint,istate_in,N_st,sze_8)
       enddo
     enddo
   enddo
-  !$OMP END DO 
+  !$OMP END DO NOWAIT
   
-  !$OMP DO SCHEDULE(static,1)
+  !$OMP DO SCHEDULE(dynamic)
   do sh=1,shortcut(0,2)
     do i=shortcut(sh,2),shortcut(sh+1,2)-1
       org_i = sort_idx(i,2)
@@ -462,7 +490,7 @@ subroutine H_u_0_mrcc_nstates(v_0,u_0,H_jj,n,keys_tmp,Nint,istate_in,N_st,sze_8)
       end do
     end do
   enddo
-  !$OMP END DO
+  !$OMP END DO NOWAIT
   
   !$OMP DO 
   do ii=1,n_det_ref
@@ -477,12 +505,13 @@ subroutine H_u_0_mrcc_nstates(v_0,u_0,H_jj,n,keys_tmp,Nint,istate_in,N_st,sze_8)
   enddo
   !$OMP END DO
 
+  !$OMP CRITICAL
   do istate=1,N_st
     do i=n,1,-1
-      !$OMP ATOMIC
       v_0(i,istate) = v_0(i,istate) + vt(i,istate)
     enddo
   enddo
+  !$OMP END CRITICAL
 
   deallocate(vt)
   !$OMP END PARALLEL
@@ -530,26 +559,25 @@ subroutine davidson_diag_mrcc_hs2(dets_in,u_in,dim_in,energies,sze,N_st,N_st_dia
   ASSERT (sze > 0)
   ASSERT (Nint > 0)
   ASSERT (Nint == N_int)
-  PROVIDE mo_bielec_integrals_in_map 
+  PROVIDE mo_bielec_integrals_in_map
   allocate(H_jj(sze), S2_jj(sze))
   
-  H_jj(1) = diag_h_mat_elem(dets_in(1,1,1),Nint)
-  call get_s2(dets_in(1,1,1),dets_in(1,1,1),Nint,S2_jj(1))
   !$OMP PARALLEL DEFAULT(NONE)                                       &
       !$OMP  SHARED(sze,H_jj,S2_jj, dets_in,Nint,N_det_ref,delta_ii, &
       !$OMP  idx_ref, istate)  &
       !$OMP  PRIVATE(i)
-  !$OMP DO 
+  !$OMP DO SCHEDULE(guided)
-  do i=2,sze
+  do i=1,sze
     H_jj(i) = diag_h_mat_elem(dets_in(1,1,i),Nint)
     call get_s2(dets_in(1,1,i),dets_in(1,1,i),Nint,S2_jj(i))
   enddo
   !$OMP END DO 
-  !$OMP END PARALLEL
+  !$OMP DO SCHEDULE(guided)
-
   do i=1,N_det_ref
     H_jj(idx_ref(i)) +=  delta_ii(istate,i)
   enddo
+  !$OMP END DO 
+  !$OMP END PARALLEL
 
   call davidson_diag_hjj_sjj_mrcc(dets_in,u_in,H_jj,S2_jj,energies,dim_in,sze,N_st,N_st_diag,Nint,iunit,istate)
   deallocate (H_jj,S2_jj)
@@ -1066,7 +1094,6 @@ subroutine H_S2_u_0_mrcc_nstates(v_0,s_0,u_0,H_jj,S2_jj,n,keys_tmp,Nint,istate_i
     enddo
   enddo
   !$OMP END DO
-
   !$OMP DO SCHEDULE(guided)
   do sh=1,shortcut(0,2)
     do i=shortcut(sh,2),shortcut(sh+1,2)-1
@@ -1115,14 +1142,14 @@ subroutine H_S2_u_0_mrcc_nstates(v_0,s_0,u_0,H_jj,S2_jj,n,keys_tmp,Nint,istate_i
 ! End Specific to dressing
 ! ------------------------
 
+  !$OMP CRITICAL
   do istate=1,N_st
     do i=n,1,-1
-      !$OMP ATOMIC
       v_0(i,istate) = v_0(i,istate) + vt(istate,i)
-      !$OMP ATOMIC
       s_0(i,istate) = s_0(i,istate) + st(istate,i)
     enddo
   enddo
+  !$OMP END CRITICAL
 
   deallocate(vt,st)
   !$OMP END PARALLEL

plugins/MRCC_Utils/mrcc_utils.irp.f

@@ -5,7 +5,6 @@ use bitmasks
 END_PROVIDER
  
  
-
  BEGIN_PROVIDER [ double precision, lambda_mrcc, (N_states, N_det_non_ref) ]
 &BEGIN_PROVIDER [ integer, lambda_mrcc_pt2, (0:psi_det_size) ]
 &BEGIN_PROVIDER [ integer, lambda_mrcc_kept, (0:psi_det_size) ]
@@ -63,65 +62,6 @@ END_PROVIDER
 
 END_PROVIDER
 
-! BEGIN_PROVIDER [ double precision, lambda_mrcc, (N_states, N_det_non_ref) ]
-!&BEGIN_PROVIDER [ integer, lambda_mrcc_pt2, (0:psi_det_size) ]
-!&BEGIN_PROVIDER [ integer, lambda_mrcc_kept, (0:psi_det_size) ]
-!&BEGIN_PROVIDER [ double precision, lambda_pert, (N_states, N_det_non_ref) ] 
-!  implicit none
-!  BEGIN_DOC
-!  ! cm/<Psi_0|H|D_m> or perturbative 1/Delta_E(m)
-!  END_DOC
-!  integer :: i,k
-!  double precision               :: ihpsi_current(N_states)
-!  integer                        :: i_pert_count
-!  double precision               :: hii, E2(N_states), E2var(N_states)
-!  integer                        :: N_lambda_mrcc_pt2, N_lambda_mrcc_pt3
-!  
-!  i_pert_count = 0
-!  lambda_mrcc = 0.d0
-!  N_lambda_mrcc_pt2 = 0
-!  N_lambda_mrcc_pt3 = 0
-!  lambda_mrcc_pt2(0) = 0
-!  lambda_mrcc_kept(0) = 0
-!
-!  E2 = 0.d0
-!  E2var = 0.d0
-!  do i=1,N_det_non_ref
-!    call i_h_psi(psi_non_ref(1,1,i), psi_ref, psi_ref_coef, N_int, N_det_ref,&
-!        size(psi_ref_coef,1), N_states,ihpsi_current)
-!    call i_H_j(psi_non_ref(1,1,i),psi_non_ref(1,1,i),N_int,hii)
-!    do k=1,N_states
-!      if (ihpsi_current(k) == 0.d0) then
-!        ihpsi_current(k) = 1.d-32
-!      endif
-!      lambda_mrcc(k,i) = psi_non_ref_coef(i,k)/ihpsi_current(k) 
-!      lambda_pert(k,i) = 1.d0 / (psi_ref_energy_diagonalized(k)-hii)
-!      E2(k) += ihpsi_current(k)*ihpsi_current(k) / (psi_ref_energy_diagonalized(k)-hii)
-!      E2var(k) += ihpsi_current(k) * psi_non_ref_coef(i,k)
-!    enddo
-!  enddo
-!
-!  do i=1,N_det_non_ref
-!    call i_h_psi(psi_non_ref(1,1,i), psi_ref, psi_ref_coef, N_int, N_det_ref,&
-!        size(psi_ref_coef,1), N_states,ihpsi_current)
-!    call i_H_j(psi_non_ref(1,1,i),psi_non_ref(1,1,i),N_int,hii)
-!    do k=1,N_states
-!      if (ihpsi_current(k) == 0.d0) then
-!        ihpsi_current(k) = 1.d-32
-!      endif
-!      lambda_mrcc(k,i) = psi_non_ref_coef(i,k)/ihpsi_current(k) 
-!      lambda_pert(k,i) = 1.d0 / (psi_ref_energy_diagonalized(k)-hii) * E2var(k)/E2(k)
-!    enddo
-!  enddo
-!  lambda_mrcc_pt2(0) = N_lambda_mrcc_pt2
-!  lambda_mrcc_kept(0) = N_lambda_mrcc_pt3
-!  print*,'N_det_non_ref = ',N_det_non_ref
-!  print*,'psi_coef_ref_ratio = ',psi_ref_coef(2,1)/psi_ref_coef(1,1)
-!  print*,'lambda max = ',maxval(dabs(lambda_mrcc))
-!  print*,'Number of ignored determinants = ',i_pert_count  
-!
-!END_PROVIDER
-
 
 
 BEGIN_PROVIDER [ double precision, hij_mrcc, (N_det_non_ref,N_det_ref) ]
@@ -351,11 +291,11 @@ logical function is_generable(det1, det2, Nint)
   integer, intent(in) :: Nint
   integer(bit_kind) :: det1(Nint, 2), det2(Nint, 2)
   integer :: degree, f, exc(0:2, 2, 2), t
-  integer :: h1, h2, p1, p2, s1, s2
+  integer*2 :: h1, h2, p1, p2, s1, s2
   integer, external :: searchExc
   logical, external :: excEq
   double precision :: phase
-  integer :: tmp_array(4)
+  integer*2 :: tmp_array(4)
   
   is_generable = .false.
   call get_excitation(det1, det2, exc, degree, phase, Nint)
@@ -366,7 +306,7 @@ logical function is_generable(det1, det2, Nint)
   end if
   if(degree > 2) stop "?22??"
   
-  call decode_exc(exc,degree,h1,p1,h2,p2,s1,s2)
+  call decode_exc_int2(exc,degree,h1,p1,h2,p2,s1,s2)
   
   if(degree == 1) then
     h2 = h1
@@ -454,7 +394,7 @@ integer function searchExc(excs, exc, n)
   use bitmasks
   
   integer, intent(in) :: n
-  integer,intent(in) :: excs(4,n), exc(4)
+  integer*2,intent(in) :: excs(4,n), exc(4)
   integer :: l, h, c
   integer, external :: excCmp
   logical, external :: excEq
@@ -519,8 +459,8 @@ subroutine sort_exc(key, N_key)
   
 
   integer, intent(in)                   :: N_key
-  integer,intent(inout)       :: key(4,N_key)
+  integer*2,intent(inout)       :: key(4,N_key)
-  integer                     :: tmp(4)
+  integer*2                     :: tmp(4)
   integer                               :: i,ni
   
   
@@ -542,7 +482,7 @@ end subroutine
 
 logical function exc_inf(exc1, exc2)
   implicit none
-  integer,intent(in) :: exc1(4), exc2(4)
+  integer*2,intent(in) :: exc1(4), exc2(4)
   integer :: i
   exc_inf = .false.
   do i=1,4
@@ -564,9 +504,9 @@ subroutine tamise_exc(key, no, n, N_key)
 ! Uncodumented : TODO
   END_DOC
   integer,intent(in)            :: no, n, N_key
-  integer,intent(inout)       :: key(4, N_key)
+  integer*2,intent(inout)       :: key(4, N_key)
   integer                       :: k,j
-  integer                     :: tmp(4)
+  integer*2                     :: tmp(4)
   logical                       :: exc_inf
   integer                       :: ni
   
@@ -595,9 +535,8 @@ end subroutine
 
 subroutine dec_exc(exc, h1, h2, p1, p2)
   implicit none
-  integer, intent(in)            :: exc(0:2,2,2)
+  integer :: exc(0:2,2,2), s1, s2, degree
-  integer, intent(out)           :: h1, h2, p1, p2
+  integer*2, intent(out) :: h1, h2, p1, p2
-  integer                        :: degree, s1, s2
   
   degree = exc(0,1,1) + exc(0,1,2)
   
@@ -608,7 +547,7 @@ subroutine dec_exc(exc, h1, h2, p1, p2)
     
   if(degree == 0) return
   
-  call decode_exc(exc, degree, h1, p1, h2, p2, s1, s2)
+  call decode_exc_int2(exc, degree, h1, p1, h2, p2, s1, s2)
   
   h1 += mo_tot_num * (s1-1)
   p1 += mo_tot_num * (s1-1)
@@ -640,7 +579,7 @@ end subroutine
 &BEGIN_PROVIDER [ integer, N_ex_exists ]
   implicit none
   integer :: exc(0:2, 2, 2), degree, n, on, s, l, i
-  integer :: h1, h2, p1, p2
+  integer*2 :: h1, h2, p1, p2
   double precision :: phase
   logical,allocatable :: hh(:,:) , pp(:,:)
   
@@ -678,53 +617,6 @@ END_PROVIDER
   call sort_det(psi_non_ref_sorted, psi_non_ref_sorted_idx, N_det_non_ref, N_int)
 END_PROVIDER
 
- BEGIN_PROVIDER [ double precision, rho_mrpt, (N_det_non_ref, N_states) ]
-  implicit none
-  integer :: i, j, k
-  double precision :: coef_mrpt(N_States),coef_array(N_states),hij,delta_e(N_states)
-  double precision :: hij_array(N_det_Ref),delta_e_array(N_det_ref,N_states)
-  integer :: number_of_holes, number_of_particles,nh,np
-  do i = 1, N_det_non_ref
-   print*,'i',i
-   nh =  number_of_holes(psi_non_ref(1,1,i))
-   np =  number_of_particles(psi_non_ref(1,1,i))
-   do j = 1, N_det_ref
-    do k = 1, N_States 
-     coef_array(k) = psi_ref_coef(j,k)
-    enddo
-    call i_h_j(psi_ref(1,1,j), psi_non_ref(1,1,i), N_int, Hij_array(j))
-    call get_delta_e_dyall(psi_ref(1,1,j),psi_non_ref(1,1,i),coef_array,hij_array(j),delta_e)
-!   write(*,'(A7,x,100(F16.10,x))')'delta_e',delta_e(:)
-    do k = 1, N_states
-     delta_e_Array(j,k) = delta_e(k)
-    enddo
-   enddo
-   coef_mrpt = 0.d0
-   do k = 1, N_states
-    do j = 1, N_det_Ref
-     coef_mrpt(k) += psi_ref_coef(j,k) * hij_array(j) / delta_e_array(j,k) 
-    enddo
-   enddo
-
-   write(*,'(A7,X,100(F16.10,x))')'coef   ',psi_non_ref_coef(i,1) , coef_mrpt(1),psi_non_ref_coef(i,2) , coef_mrpt(2)
-   print*, nh,np
-   do k = 1, N_States
-    if(dabs(coef_mrpt(k)) .le.1.d-10)then
-     rho_mrpt(i,k) = 0.d0
-     exit
-    endif
-    if(psi_non_ref_coef(i,k) / coef_mrpt(k) .lt.0d0)then
-     rho_mrpt(i,k) = 1.d0
-    else 
-     rho_mrpt(i,k) = psi_non_ref_coef(i,k) / coef_mrpt(k)
-    endif
-   enddo
-    print*,'rho',rho_mrpt(i,:)
-    write(33,*)i,rho_mrpt(i,:)
-  enddo
-
- END_PROVIDER 
-
 
  BEGIN_PROVIDER [ double precision, dIj_unique, (hh_nex, N_states) ]
 &BEGIN_PROVIDER [ double precision, rho_mrcc, (N_det_non_ref, N_states) ]
@@ -740,12 +632,12 @@ END_PROVIDER
   double precision               :: phase
   
   
-  double precision, allocatable :: rho_mrcc_inact(:)
+  double precision, allocatable :: rho_mrcc_init(:)
   integer                        :: a_coll, at_roww
   
   print *, "TI", hh_nex, N_det_non_ref
 
-  allocate(rho_mrcc_inact(N_det_non_ref))
+  allocate(rho_mrcc_init(N_det_non_ref))
   allocate(x_new(hh_nex))
   allocate(x(hh_nex), AtB(hh_nex))
 
@@ -757,7 +649,7 @@ END_PROVIDER
         !$OMP private(at_row, a_col, i, j, r1, r2, wk, A_ind_mwen, A_val_mwen, a_coll, at_roww)&
         !$OMP shared(N_states,mrcc_col_shortcut, mrcc_N_col, AtB, mrcc_AtA_val, mrcc_AtA_ind, s, n_exc_active, active_pp_idx)
     
-    !$OMP DO schedule(static, 100)
+    !$OMP DO schedule(dynamic, 100)
     do at_roww = 1, n_exc_active ! hh_nex
       at_row = active_pp_idx(at_roww)
       do i=1,active_excitation_to_determinants_idx(0,at_roww)
@@ -776,7 +668,7 @@ END_PROVIDER
       X(a_col) = AtB(a_col)
     end do
     
-    rho_mrcc_inact(:) = 0d0
+    rho_mrcc_init = 0d0
     
     allocate(lref(N_det_ref))
     do hh = 1, hh_shortcut(0)
@@ -800,23 +692,29 @@ END_PROVIDER
         X(pp) =  AtB(pp) 
         do II=1,N_det_ref
           if(lref(II) > 0) then
-            rho_mrcc_inact(lref(II)) = psi_ref_coef(II,s) * X(pp)
+            rho_mrcc_init(lref(II)) = psi_ref_coef(II,s) * X(pp)
           else if(lref(II) < 0) then
-            rho_mrcc_inact(-lref(II)) = -psi_ref_coef(II,s) * X(pp)
+            rho_mrcc_init(-lref(II)) = -psi_ref_coef(II,s) * X(pp)
           end if
         end do
       end do
     end do
     deallocate(lref)
 
+    do i=1,N_det_non_ref
+      rho_mrcc(i,s) = rho_mrcc_init(i) 
+    enddo
+
     x_new = x
     
     double precision               :: factor, resold
     factor = 1.d0
     resold = huge(1.d0)
 
-    do k=0,hh_nex/4
+    do k=0,10*hh_nex
       res = 0.d0
+      !$OMP PARALLEL default(shared) private(cx, i, a_col, a_coll) reduction(+:res)
+      !$OMP DO
       do a_coll = 1, n_exc_active
         a_col = active_pp_idx(a_coll)
         cx = 0.d0
@@ -827,108 +725,102 @@ END_PROVIDER
         res = res + (X_new(a_col) - X(a_col))*(X_new(a_col) - X(a_col))
         X(a_col) = X_new(a_col)
       end do
+      !$OMP END DO
+      !$OMP END PARALLEL
       
       if (res > resold) then
         factor = factor * 0.5d0
       endif
-      
-      if(iand(k, 127) == 0) then
-        print *, k, res, 1.d0 - res/resold
-      endif
-      
-      if ( res < 1d-10 ) then
-        exit
-      endif
-      if ( (res/resold > 0.99d0) ) then
-        exit
-      endif
       resold = res
-
+      
+      if(iand(k, 4095) == 0) then
+        print *, "res ", k, res
+      end if
+      
+      if(res < 1d-10) exit
     end do
     dIj_unique(1:size(X), s) = X(1:size(X))
-    print *, k, res, 1.d0 - res/resold
 
+  enddo
 
-    do i=1,N_det_non_ref
+  do s=1,N_states
-      rho_mrcc(i,s) = 0.d0
-    enddo
 
     do a_coll=1,n_exc_active
       a_col = active_pp_idx(a_coll)
       do j=1,N_det_non_ref
         i = active_excitation_to_determinants_idx(j,a_coll)
         if (i==0) exit
-        if (rho_mrcc_inact(i) /= 0.d0) then
-          call debug_det(psi_non_ref(1,1,i),N_int)
-          stop
-        endif
         rho_mrcc(i,s) = rho_mrcc(i,s) + active_excitation_to_determinants_val(s,j,a_coll) * dIj_unique(a_col,s)
       enddo
     end do
 
-    double precision :: norm2_ref, norm2_inact, a, b, c, Delta
+    norm = 0.d0
-    ! Psi = Psi_ref + Psi_inactive + f*Psi_active
+    do i=1,N_det_non_ref
-    ! Find f to normalize Psi
+      norm = norm + rho_mrcc(i,s)*rho_mrcc(i,s)
-
+    enddo
-    norm2_ref = 0.d0
+    ! Norm now contains the norm of A.X
+    
     do i=1,N_det_ref
-      norm2_ref = norm2_ref + psi_ref_coef(i,s)*psi_ref_coef(i,s)
+      norm = norm + psi_ref_coef(i,s)*psi_ref_coef(i,s)
     enddo
-
+    ! Norm now contains the norm of Psi + A.X
-    a = 0.d0
+    
-    do i=1,N_det_non_ref
-      a = a + rho_mrcc(i,s)*rho_mrcc(i,s)
-    enddo
-
-    norm = a + norm2_ref
     print *, "norm : ", sqrt(norm)
-
+   enddo
-    norm = sqrt((1.d0-norm2_ref)/a)
-
-    ! Renormalize Psi+A.X
-    do i=1,N_det_non_ref
-      rho_mrcc(i,s) = rho_mrcc(i,s) * norm 
-    enddo
-
-!norm = norm2_ref
-!do i=1,N_det_non_ref
-!  norm = norm + rho_mrcc(i,s)**2
-!enddo
-!print *,  'check', norm
-!stop
-
      
         
+   do s=1,N_states
      norm = 0.d0
-     double precision               :: f, g, gmax
+     double precision               :: f
-     gmax = maxval(dabs(psi_non_ref_coef(:,s)))
      do i=1,N_det_non_ref
+       if (rho_mrcc(i,s) == 0.d0) then
+         rho_mrcc(i,s) = 1.d-32
+       endif
+
        if (lambda_type == 2) then
          f = 1.d0
        else
-        if (rho_mrcc(i,s) == 0.d0) then
-          cycle
-        endif
         ! f is such that f.\tilde{c_i} = c_i
         f = psi_non_ref_coef(i,s) / rho_mrcc(i,s)
 
         ! Avoid numerical instabilities
-        g = 2.d0+100.d0*exp(-20.d0*dabs(psi_non_ref_coef(i,s)/gmax))
+        f = min(f,2.d0)
-        f = min(f, g)
+        f = max(f,-2.d0)
-        f = max(f,-g)
-
       endif
 
-       norm = norm + (rho_mrcc(i,s)*f)**2
+       norm = norm + f*f *rho_mrcc(i,s)*rho_mrcc(i,s)
        rho_mrcc(i,s) = f
      enddo
-     ! rho_mrcc now contains the mu_i factors
+     ! norm now contains the norm of |T.Psi_0>
+     ! rho_mrcc now contains the f factors
 
+     f = 1.d0/norm
+     ! f now contains 1/ <T.Psi_0|T.Psi_0>
+
+     norm = 1.d0
+     do i=1,N_det_ref
+       norm = norm - psi_ref_coef(i,s)*psi_ref_coef(i,s)
+     enddo
+     ! norm now contains <Psi_SD|Psi_SD>
+     f = dsqrt(f*norm)
+     ! f normalises T.Psi_0 such that (1+T)|Psi> is normalized
+
+     norm = norm*f
      print *,  'norm of |T Psi_0> = ', dsqrt(norm)
-     if (norm > 1.d0) then
+     if (dsqrt(norm) > 1.d0) then
        stop 'Error : Norm of the SD larger than the norm of the reference.'
      endif
 
+     do i=1,N_det_ref
+       norm = norm + psi_ref_coef(i,s)*psi_ref_coef(i,s)
+     enddo
+
+     do i=1,N_det_non_ref
+       rho_mrcc(i,s) = rho_mrcc(i,s) * f
+     enddo
+     ! rho_mrcc now contains the product of the scaling factors and the
+     ! normalization constant
+    
   end do
 
 END_PROVIDER
@@ -953,58 +845,11 @@ END_PROVIDER
 
 
 
-!double precision function f_fit(x)
-!  implicit none
-!  double precision :: x
-!  f_fit = 0.d0
-!  return
-!  if (x < 0.d0) then
-!    f_fit = 0.d0
-!  else if (x < 1.d0) then
-!    f_fit = 1.d0/0.367879441171442 * ( x**2 * exp(-x**2))
-!  else
-!    f_fit = 1.d0
-!  endif
-!end
-!
-!double precision function get_dij_index(II, i, s, Nint)
-!  integer, intent(in) :: II, i, s, Nint
-!  double precision, external :: get_dij
-!  double precision :: HIi, phase, c, a, b, d
-!
-!  call i_h_j(psi_ref(1,1,II), psi_non_ref(1,1,i), Nint, HIi)
-!  call get_phase(psi_ref(1,1,II), psi_non_ref(1,1,i), phase, N_int)
-!
-!  a = lambda_pert(s,i)
-!  b = lambda_mrcc(s,i)
-!  c = f_fit(a/b)
-!
-!  d = get_dij(psi_ref(1,1,II), psi_non_ref(1,1,i), s, Nint) * phase* rho_mrcc(i,s)
-!
-!  c = f_fit(a*HIi/d)
-!
-!  get_dij_index = HIi * a * c + (1.d0 - c) * d
-!  get_dij_index = d
-!  return
-!
-!  if(lambda_type == 0) then
-!    call get_phase(psi_ref(1,1,II), psi_non_ref(1,1,i), phase, N_int)
-!    get_dij_index = get_dij(psi_ref(1,1,II), psi_non_ref(1,1,i), s, Nint) * phase
-!    get_dij_index = get_dij_index * rho_mrcc(i,s) 
-!  else if(lambda_type == 1) then
-!    call i_h_j(psi_ref(1,1,II), psi_non_ref(1,1,i), Nint, HIi)
-!    get_dij_index = HIi * lambda_mrcc(s, i)
-!  else if(lambda_type == 2) then
-!    call get_phase(psi_ref(1,1,II), psi_non_ref(1,1,i), phase, N_int)
-!    get_dij_index = get_dij(psi_ref(1,1,II), psi_non_ref(1,1,i), s, Nint) * phase
-!    get_dij_index = get_dij_index * rho_mrcc(i,s) 
-!  end if
-!end function
 
 double precision function get_dij_index(II, i, s, Nint)
   integer, intent(in) :: II, i, s, Nint
   double precision, external :: get_dij
-  double precision :: HIi, phase,delta_e_final(N_states) 
+  double precision :: HIi, phase
 
   if(lambda_type == 0) then
     call get_phase(psi_ref(1,1,II), psi_non_ref(1,1,i), phase, N_int)
@@ -1016,11 +861,7 @@ double precision function get_dij_index(II, i, s, Nint)
   else if(lambda_type == 2) then
     call get_phase(psi_ref(1,1,II), psi_non_ref(1,1,i), phase, N_int)
     get_dij_index = get_dij(psi_ref(1,1,II), psi_non_ref(1,1,i), s, Nint) * phase
-    get_dij_index = get_dij_index 
+    get_dij_index = get_dij_index * rho_mrcc(i,s) 
-  else if(lambda_type == 3) then
-    call i_h_j(psi_ref(1,1,II), psi_non_ref(1,1,i), Nint, HIi)
-    call get_delta_e_dyall(psi_ref(1,1,II),psi_non_ref(1,1,i),delta_e_final)
-    get_dij_index = HIi * rho_mrpt(i, s) / delta_e_final(s)
   end if
 end function
 
@@ -1031,11 +872,11 @@ double precision function get_dij(det1, det2, s, Nint)
   integer, intent(in) :: s, Nint
   integer(bit_kind) :: det1(Nint, 2), det2(Nint, 2)
   integer :: degree, f, exc(0:2, 2, 2), t
-  integer :: h1, h2, p1, p2, s1, s2
+  integer*2 :: h1, h2, p1, p2, s1, s2
   integer, external :: searchExc
   logical, external :: excEq
   double precision :: phase
-  integer :: tmp_array(4)
+  integer*2 :: tmp_array(4)
   
   get_dij = 0d0
   call get_excitation(det1, det2, exc, degree, phase, Nint)
@@ -1044,7 +885,7 @@ double precision function get_dij(det1, det2, s, Nint)
     stop "get_dij"
   end if
   
-  call decode_exc(exc,degree,h1,p1,h2,p2,s1,s2)
+  call decode_exc_int2(exc,degree,h1,p1,h2,p2,s1,s2)
   
   if(degree == 1) then
     h2 = h1
@@ -1077,8 +918,8 @@ double precision function get_dij(det1, det2, s, Nint)
 end function
 
 
- BEGIN_PROVIDER [ integer, hh_exists, (4, N_hh_exists) ]
+ BEGIN_PROVIDER [ integer*2, hh_exists, (4, N_hh_exists) ]
-&BEGIN_PROVIDER [ integer, pp_exists, (4, N_pp_exists) ]
+&BEGIN_PROVIDER [ integer*2, pp_exists, (4, N_pp_exists) ]
 &BEGIN_PROVIDER [ integer, hh_shortcut, (0:N_hh_exists + 1) ]
 &BEGIN_PROVIDER [ integer, hh_nex ]
   implicit none
@@ -1093,9 +934,9 @@ end function
   ! hh_nex : Total number of excitation operators
   !
   END_DOC
-  integer,allocatable :: num(:,:)
+  integer*2,allocatable :: num(:,:)
   integer :: exc(0:2, 2, 2), degree, n, on, s, l, i
-  integer :: h1, h2, p1, p2
+  integer*2 :: h1, h2, p1, p2
   double precision :: phase
   logical, external :: excEq
   
@@ -1121,40 +962,24 @@ end function
   
   hh_shortcut(0) = 1
   hh_shortcut(1) = 1
-  hh_exists(:,1) = (/1, num(1,1), 1, num(2,1)/)
+  hh_exists(:,1) = (/1_2, num(1,1), 1_2, num(2,1)/)
-  pp_exists(:,1) = (/1, num(3,1), 1, num(4,1)/)
+  pp_exists(:,1) = (/1_2, num(3,1), 1_2, num(4,1)/)
   s = 1
   do i=2,n
     if(.not. excEq(num(1,i), num(1,s))) then
       s += 1
       num(:, s) = num(:, i)
-      pp_exists(:,s) = (/1, num(3,s), 1, num(4,s)/)
+      pp_exists(:,s) = (/1_2, num(3,s), 1_2, num(4,s)/)
       if(hh_exists(2, hh_shortcut(0)) /= num(1,s) .or. &
             hh_exists(4, hh_shortcut(0)) /= num(2,s)) then
         hh_shortcut(0) += 1
         hh_shortcut(hh_shortcut(0)) = s
-        hh_exists(:,hh_shortcut(0)) = (/1, num(1,s), 1, num(2,s)/)
+        hh_exists(:,hh_shortcut(0)) = (/1_2, num(1,s), 1_2, num(2,s)/)
       end if
     end if
   end do
   hh_shortcut(hh_shortcut(0)+1) = s+1
   
-  if (hh_shortcut(0) > N_hh_exists) then
-    print *,  'Error in ', irp_here
-    print *,  'hh_shortcut(0) :', hh_shortcut(0)
-    print *,  'N_hh_exists : ', N_hh_exists
-    print *,  'Is your active space defined?'
-    stop
-  endif
-
-  if (hh_shortcut(hh_shortcut(0)+1)-1 > N_pp_exists) then
-    print *,  'Error 1 in ', irp_here
-    print *,  'hh_shortcut(hh_shortcut(0)+1)-1 :', hh_shortcut(hh_shortcut(0)+1)-1 
-    print *,  'N_pp_exists : ', N_pp_exists
-    print *,  'Is your active space defined?'
-    stop
-  endif
-
   do s=2,4,2
     do i=1,hh_shortcut(0)
       if(hh_exists(s, i) == 0) then
@@ -1165,7 +990,6 @@ end function
       end if
     end do
     
-
     do i=1,hh_shortcut(hh_shortcut(0)+1)-1
       if(pp_exists(s, i) == 0) then
         pp_exists(s-1, i) = 0
@@ -1181,7 +1005,7 @@ END_PROVIDER
 
 logical function excEq(exc1, exc2)
   implicit none
-  integer, intent(in) :: exc1(4), exc2(4)
+  integer*2, intent(in) :: exc1(4), exc2(4)
   integer :: i
   excEq = .false.
   do i=1, 4
@@ -1193,7 +1017,7 @@ end function
 
 integer function excCmp(exc1, exc2)
   implicit none
-  integer, intent(in) :: exc1(4), exc2(4)
+  integer*2, intent(in) :: exc1(4), exc2(4)
   integer :: i
   excCmp = 0
   do i=1, 4
@@ -1212,8 +1036,8 @@ subroutine apply_hole_local(det, exc, res, ok, Nint)
   use bitmasks
   implicit none
   integer, intent(in) :: Nint
-  integer, intent(in) :: exc(4)
+  integer*2, intent(in) :: exc(4)
-  integer :: s1, s2, h1, h2
+  integer*2 :: s1, s2, h1, h2
   integer(bit_kind),intent(in) :: det(Nint, 2)
   integer(bit_kind),intent(out) :: res(Nint, 2)
   logical, intent(out) :: ok
@@ -1249,8 +1073,8 @@ subroutine apply_particle_local(det, exc, res, ok, Nint)
   use bitmasks
   implicit none
   integer, intent(in) :: Nint
-  integer, intent(in) :: exc(4)
+  integer*2, intent(in) :: exc(4)
-  integer :: s1, s2, p1, p2
+  integer*2 :: s1, s2, p1, p2
   integer(bit_kind),intent(in) :: det(Nint, 2)
   integer(bit_kind),intent(out) :: res(Nint, 2)
   logical, intent(out) :: ok

plugins/MRPT/MRPT_Utils.main.irp.f

@@ -10,42 +10,34 @@ end
 
 subroutine routine_3
  implicit none
- integer :: i,j
 !provide fock_virt_total_spin_trace
  provide delta_ij 
  
  print *,  'N_det    = ', N_det
  print *,  'N_states = ', N_states
- do i = 1, N_States
+ print *,  'PT2      = ', second_order_pt_new(1)
-  print*,'State',i
+ print *,  'E        = ', CI_energy(1)
-  write(*,'(A12,X,I3,A3,XX,F20.16)')    '  PT2       ', i,' = ', second_order_pt_new(i)
+ print *,  'E+PT2    = ', CI_energy(1)+second_order_pt_new(1)
-  write(*,'(A12,X,I3,A3,XX,F22.16)')    '  E         ', i,' = ', psi_ref_average_value(i)
+ print *,'****** DIAGONALIZATION OF DRESSED MATRIX ******'
-  write(*,'(A12,X,I3,A3,XX,F22.16)')    '  E+PT2     ', i,' = ', psi_ref_average_value(i)+second_order_pt_new(i)
+ print *,  'E dressed= ', CI_dressed_pt2_new_energy(1)
-  write(*,'(A12,X,I3,A3,XX,F22.16)')    '  E dressed ', i,' = ', CI_dressed_pt2_new_energy(i)
-  write(*,'(A12,X,I3,A3,XX,F20.16)')    '  S^2       ', i,' = ', CI_dressed_pt2_new_eigenvectors_s2(i)
-  print*,'coef before and after'
-  do j = 1, N_det_ref
-   print*,psi_ref_coef(j,i),CI_dressed_pt2_new_eigenvectors(j,i)
-  enddo
- enddo 
- if(save_heff_eigenvectors)then
-  call save_wavefunction_general(N_det_ref,N_states,psi_ref,N_det_ref,CI_dressed_pt2_new_eigenvectors)
- endif
- if(N_states.gt.1)then
-  print*, 'Energy differences : E(i) - E(0)'
-  do i = 2, N_States
-   print*,'State',i
-   write(*,'(A12,X,I3,A3,XX,F20.16)')    '  S^2       ', i,' = ', CI_dressed_pt2_new_eigenvectors_s2(i)
-   write(*,'(A12,X,I3,A3,XX,F20.16)')    'Variational ', i,' = ', -(psi_ref_average_value(1) - psi_ref_average_value(i))
-   write(*,'(A12,X,I3,A3,XX,F20.16)')    'Perturbative', i,' = ', -(psi_ref_average_value(1)+second_order_pt_new(1) - (psi_ref_average_value(i)+second_order_pt_new(i)))
-   write(*,'(A12,X,I3,A3,XX,F20.16)')    'Dressed     ', i,' = ', -( CI_dressed_pt2_new_energy(1) - CI_dressed_pt2_new_energy(i) )
-  enddo
- endif
 
 end
 
 subroutine routine_2
  implicit none
- provide electronic_psi_ref_average_value
+ integer :: i
+ do i = 1, n_core_inact_orb
+  print*,fock_core_inactive_total(i,1,1),fock_core_inactive(i)
+ enddo
+ double precision :: accu
+ accu = 0.d0
+ do i = 1, n_act_orb
+  integer :: j_act_orb
+  j_act_orb = list_act(i)
+  accu += one_body_dm_mo_alpha(j_act_orb,j_act_orb,1)
+  print*,one_body_dm_mo_alpha(j_act_orb,j_act_orb,1),one_body_dm_mo_beta(j_act_orb,j_act_orb,1) 
+ enddo
+ print*,'accu = ',accu
+
 end
 

plugins/MRPT/NEEDED_CHILDREN_MODULES

@@ -1 +1 @@
-MRPT_Utils Selectors_full Psiref_CAS Generators_CAS
+MRPT_Utils Selectors_full Generators_full

plugins/MRPT/print_1h2p.irp.f

@@ -6,53 +6,46 @@ program print_1h2p
 end
 
 subroutine routine
- implicit none
- provide one_anhil_one_creat_inact_virt
-
-end
-
-subroutine routine_2
- implicit none
- integer :: i,j,degree
- double precision :: hij
- do i =1, n_core_inact_orb 
-  write(*,'(I3,x,100(F16.10,X))')list_core_inact(i),fock_core_inactive_total_spin_trace(list_core_inact(i),1)
- enddo
- print*,''
- do i =1, n_virt_orb
-  write(*,'(I3,x,100(F16.10,X))')list_virt(i),fock_virt_total_spin_trace(list_virt(i),1)
- enddo
- stop
- do i = 1, n_virt_orb
-  do j = 1, n_inact_orb 
-  if(dabs(one_anhil_one_creat_inact_virt(j,i,1)) .lt. 1.d-10)cycle
-  write(*,'(I3,x,I3,X,100(F16.10,X))')list_virt(i),list_inact(j),one_anhil_one_creat_inact_virt(j,i,1)
-  enddo
- enddo
-
-
-end
-
-subroutine routine_3
  implicit none
  double precision,allocatable :: matrix_1h2p(:,:,:) 
- double precision :: accu(2)
+ allocate (matrix_1h2p(N_det,N_det,N_states))
- allocate (matrix_1h2p(N_det_ref,N_det_ref,N_states))
  integer :: i,j,istate
- accu = 0.d0
+ do i = 1, N_det
- matrix_1h2p = 0.d0
+  do j = 1, N_det
-!call H_apply_mrpt_1h2p(matrix_1h2p,N_det_ref)
+   do istate = 1, N_states
- call give_1h2p_contrib(matrix_1h2p)
+    matrix_1h2p(i,j,istate) = 0.d0
- do istate = 1, N_states
-  do i = 1, N_det
-   do j = 1, N_det 
-    accu(istate) += matrix_1h2p(i,j,istate) * psi_coef(i,istate) * psi_coef(j,istate)
    enddo
   enddo
-  print*,accu(istate)
  enddo
- call contrib_1h2p_dm_based(accu)
+ if(.False.)then
- print*,accu(:)
+ call give_1h2p_contrib(matrix_1h2p)
+ double precision :: accu
+ accu = 0.d0
+ do i = 1, N_det
+  do j = 1, N_det 
+   accu += matrix_1h2p(i,j,1) * psi_coef(i,1) * psi_coef(j,1)
+  enddo
+ enddo
+ print*, 'second order ', accu
+ endif
+
+ if(.True.)then
+ do i = 1, N_det
+  do j = 1, N_det
+   do istate = 1, N_states
+    matrix_1h2p(i,j,istate) = 0.d0
+   enddo
+  enddo
+ enddo
+ call give_1h2p_new(matrix_1h2p)
+ accu = 0.d0
+ do i = 1, N_det
+  do j = 1, N_det 
+   accu += matrix_1h2p(i,j,1) * psi_coef(i,1) * psi_coef(j,1)
+  enddo
+ enddo
+ endif
+ print*, 'third  order ', accu
 
  deallocate (matrix_1h2p)
 end

plugins/MRPT_Utils/EZFIO.cfg

@@ -5,10 +5,3 @@ interface: ezfio,provider,ocaml
 default: True
 
 
-[save_heff_eigenvectors]
-type: logical
-doc: If true, save the eigenvectors of the dressed matrix at the end of the MRPT calculation
-interface: ezfio,provider,ocaml
-default: False
-
-