Reimplemented arbitrary space

CI/CI.ml

@@ -55,7 +55,7 @@ let create_matrix_arbitrary f det_space =
   lazy (
     let det = 
       match Ds.determinants det_space with
-      | Ds.Arbitrary a -> a
+      | Ds.Arbitrary _ -> Ds.determinants_array det_space
       | _ -> assert false
     in
 

CI/Determinant_space.ml

@@ -1,37 +1,88 @@
+(** Data structures for storing the determinant space.
+
+If the space is built as the outer product of all {% $\alpha$ %} and {%
+$\beta$ %} determinants, the storage is of type [Spin]. It is sufficient
+to have the arrays of {% $\alpha$ %} and {% $\beta$ %} spindeterminants.
+
+Otherwise, the space is of type [Arbitrary]. 
+
+*)
+
+type arbitrary_space =
+  { 
+    det         : int array array ;
+    det_alfa    : Spindeterminant.t array ;
+    det_beta    : Spindeterminant.t array ;
+    index_start : int array;
+  }
+
+
 type determinant_storage =
-| Arbitrary of Determinant.t array
-| Spin      of (Spindeterminant.t array * Spindeterminant.t array)
+  | Arbitrary of arbitrary_space
+  | Spin      of (Spindeterminant.t array * Spindeterminant.t array)
+
 
 type t = 
-{
-  n_alfa       : int ;
-  n_beta       : int ;
-  mo_class     : MOClass.t ;
-  mo_basis     : MOBasis.t ;
-  determinants : determinant_storage;
-}
+  {
+    n_alfa       : int ;
+    n_beta       : int ;
+    mo_class     : MOClass.t ;
+    mo_basis     : MOBasis.t ;
+    determinants : determinant_storage;
+  }
 
 
 module Ss = Spindeterminant_space
 
-let n_alfa t = t.n_alfa
-let n_beta t = t.n_beta
+let n_alfa   t = t.n_alfa
+let n_beta   t = t.n_beta
 let mo_class t = t.mo_class
 let mo_basis t = t.mo_basis
 
 
 let size t = 
   match t.determinants with
-  | Arbitrary a -> Array.length a
   | Spin (a,b)  ->  (Array.length a) * (Array.length b)
+  | Arbitrary a ->  
+     let ndet_a = Array.length a.det_alfa in
+      a.index_start.(ndet_a - 1) + Array.length a.det.(ndet_a - 1)
  
 
 let determinant_stream t =
-  let imax = size t in
   match t.determinants with
   | Arbitrary a -> 
-      Stream.from (fun i ->
-          if i < imax then Some a.(i) else None)
+    let det_beta = a.det_beta
+    and det_alfa = a.det_alfa
+    and det = a.det in
+    let n_alfa = Array.length det_alfa in
+    let alfa = ref det_alfa.(0)
+    and det_i_alfa = ref det.(0) in
+    let i_alfa = ref 0
+    and k_beta = ref 0
+    in
+    Stream.from (fun _ ->
+        if !i_alfa = n_alfa then None else
+          begin
+            let i_beta = (!det_i_alfa).(!k_beta) in
+            let beta = det_beta.(i_beta) in
+            let result = 
+              Some (Determinant.of_spindeterminants (!alfa) beta)
+            in
+            incr k_beta;
+            if !k_beta = Array.length !det_i_alfa then
+              begin
+                k_beta := 0;
+                incr i_alfa;
+                if !i_alfa < n_alfa then 
+                  begin
+                    alfa := det_alfa.(!i_alfa);
+                    det_i_alfa := det.(!i_alfa)
+                  end
+              end;
+            result
+          end
+        )
+
   | Spin (a,b) -> 
     let na = Array.length a
     and nb = Array.length b in
@@ -53,31 +104,35 @@ let determinants t = t.determinants
 
 
 let determinants_array t =
-  match t.determinants with
-  | Arbitrary a -> a
-  | Spin (a,b)  -> 
-      let s = determinant_stream t in
-      Array.init (Array.length a * Array.length b) (fun _ ->
-        Stream.next s)
-      (*
-    Array.to_list b
-    |> List.map (fun det_b ->
-        Array.map (fun det_a ->
-            Determinant.of_spindeterminants det_a det_b
-          ) a
-        )
-    |> Array.concat
-    *)
+  let s = determinant_stream t in
+  Array.init (size t) (fun _ -> Stream.next s)
 
 
 let determinant t i =
-  match t.determinants with
-  | Arbitrary a -> a.(i)
-  | Spin (a,b) ->
-    let nb = Array.length b in
-    let k = i / nb in
-    let j = i - k * nb in
-    Determinant.of_spindeterminants a.(j) b.(k)
+  let alfa, beta =
+    match t.determinants with
+    | Arbitrary a ->
+      let i_alfa =
+        let index_start = a.index_start in
+        let rec loop i_alfa =
+          if index_start.(i_alfa) <= i then
+            loop (i_alfa+1) 
+          else i_alfa
+        in loop 0
+      in
+      let i_beta = i - a.index_start.(i_alfa) in
+      let alfa = a.det_alfa.(i_alfa) in
+      let beta = a.det_beta.(i_beta) in
+      alfa, beta
+
+    | Spin (a,b) ->
+      let nb = Array.length b in
+      let k = i / nb in
+      let j = i - k * nb in
+      a.(j), b.(k)
+
+    in
+    Determinant.of_spindeterminants alfa beta
 
 
 let fci_of_mo_basis ?(frozen_core=true) mo_basis =
@@ -92,9 +147,18 @@ let fci_of_mo_basis ?(frozen_core=true) mo_basis =
   in
   let mo_class = Ss.mo_class det_a in
   let determinants =
-    let a = Ss.spin_determinants det_a
-    and b = Ss.spin_determinants det_b
-    in Spin (a,b)
+    let det_alfa = Ss.spin_determinants det_a 
+    and det_beta = Ss.spin_determinants det_b
+    in
+    (*
+    in Spin (det_alfa, det_beta)
+    *)
+    let n_det_beta = Array.length det_beta in
+    Arbitrary {
+      det_alfa ; det_beta ;
+      det = Array.make (Array.length det_alfa) (Array.init (Array.length det_beta) (fun i -> i));
+      index_start = Array.mapi (fun i _ -> i*n_det_beta) det_alfa;
+    }
   in
   { n_alfa ; n_beta ; mo_class ; mo_basis ; determinants }
 

CI/Determinant_space.mli

@@ -4,9 +4,19 @@ The determinant space in which we solve the Schrodinger equation.
 
 type t
 
+type arbitrary_space =
+  {
+    det         : int array array ;
+    det_alfa    : Spindeterminant.t array ;
+    det_beta    : Spindeterminant.t array ;
+    index_start : int array;
+  }
+
+
 type determinant_storage =
-| Arbitrary of Determinant.t array
-| Spin      of (Spindeterminant.t array * Spindeterminant.t array)
+  | Arbitrary of arbitrary_space
+  | Spin      of (Spindeterminant.t array * Spindeterminant.t array)
+
 
 (** {1 Accessors} *)
 

Utils/Util.ml

@@ -16,7 +16,23 @@ external erfc_float : float -> float = "erfc_float_bytecode" "erfc_float"
 external gamma_float : float -> float = "gamma_float_bytecode" "gamma_float"
   [@@unboxed] [@@noalloc]
 
+external popcnt : int64 -> int32 = "popcnt_bytecode" "popcnt"
+  [@@unboxed] [@@noalloc]
+  (** popcnt instruction *)
 
+let popcnt i = popcnt i |> Int32.to_int 
+
+external trailz : int64 -> int32 = "trailz_bytecode" "trailz"
+  [@@unboxed] [@@noalloc]
+  (** ctz instruction *)
+
+let trailz i = trailz i |> Int32.to_int 
+
+external leadz : int64 -> int32 = "leadz_bytecode" "leadz"
+  [@@unboxed] [@@noalloc]
+  (** bsf instruction *)
+
+let leadz i = leadz i |> Int32.to_int 
 
 
 
@@ -399,3 +415,27 @@ let sym_matrix_of_file filename =
     done;
   done;
   result
+
+
+
+let test_case () =
+
+  let test_external () =
+     Alcotest.(check (float 1.e-15)) "erf" 0.842700792949715 (erf_float 1.0);
+     Alcotest.(check (float 1.e-15)) "erf" 0.112462916018285 (erf_float 0.1);
+     Alcotest.(check (float 1.e-15)) "erf" (-0.112462916018285) (erf_float (-0.1));
+     Alcotest.(check (float 1.e-15)) "erfc" 0.157299207050285 (erfc_float 1.0);
+     Alcotest.(check (float 1.e-15)) "erfc" 0.887537083981715 (erfc_float 0.1);
+     Alcotest.(check (float 1.e-15)) "erfc" (1.112462916018285) (erfc_float (-0.1));
+     Alcotest.(check (float 1.e-14)) "gamma" (1.77245385090552) (gamma_float 0.5);
+     Alcotest.(check (float 1.e-14)) "gamma" (9.51350769866873) (gamma_float (0.1));
+     Alcotest.(check (float 1.e-14)) "gamma" (-3.54490770181103) (gamma_float (-0.5));
+     Alcotest.(check int) "popcnt" 6 (popcnt @@ Int64.of_int 63);
+     Alcotest.(check int) "popcnt" 8 (popcnt @@ Int64.of_int 299605);
+     Alcotest.(check int) "popcnt" 1 (popcnt @@ Int64.of_int 65536);
+     Alcotest.(check int) "popcnt" 0 (popcnt @@ Int64.of_int 0);
+  in
+  [
+    "External", `Quick, test_external;
+  ]
+

Utils/Util.mli

@@ -16,6 +16,22 @@ external gamma_float : float -> float = "gamma_float_bytecode" "gamma_float"
   [@@unboxed] [@@noalloc]
   (** Gamma function [gamma] from [libm] *)
 
+(*
+external popcnt : int64 -> int32 = "popcnt_bytecode" "popcnt"
+  [@@unboxed] [@@noalloc]
+  (** popcnt instruction *)
+
+external trailz : int64 -> int32 = "trailz_bytecode" "trailz"
+  [@@unboxed] [@@noalloc]
+  (** ctz instruction *)
+*)
+
+val popcnt : int64 -> int
+(** popcnt instruction *)
+
+val trailz : int64 -> int
+(** ctz instruction *)
+
 
 
 (** {2 General functions} *)
@@ -187,3 +203,8 @@ val pp_bitstring : int -> Format.formatter -> Z.t -> unit
 
 val pp_matrix : Format.formatter -> Mat.t -> unit
 
+
+(** {1 Unit tests} *)
+
+val test_case : unit -> (string * [> `Quick ] * (unit -> unit)) list                                   
+

Utils/math_functions.c

@@ -30,8 +30,44 @@ CAMLprim value gamma_float_bytecode(value x)
   return copy_double(tgamma(Double_val(x)));
 }  
 
+
 CAMLprim double gamma_float(double x)
 {
   return tgamma(x);
 }
 
+
+CAMLprim int32_t popcnt(int64_t i)
+{
+  return __builtin_popcountll (i);
+}
+
+
+CAMLprim value popcnt_bytecode(value i)
+{
+  return copy_int32(__builtin_popcountll (i));
+}
+
+
+CAMLprim int32_t trailz(int64_t i)
+{
+  return __builtin_ctzll (i);
+}
+
+
+CAMLprim value trailz_bytecode(value i)
+{
+  return copy_int32(__builtin_ctzll (i));
+}
+
+CAMLprim int32_t leadz(int64_t i)
+{
+  return __builtin_clzll(i);
+}
+
+
+CAMLprim value leadz_bytecode(value i)
+{
+  return copy_int32(__builtin_clzll (i));
+}
+

run_tests.ml

@@ -13,6 +13,7 @@ let test_water_dz () =
     Simulation.ao_basis simulation_closed_shell
   in
   Alcotest.run "Unit tests" [
+    "Util", Util.test_case ();
     "Spindeterminant", Spindeterminant.test_case ();
     "Determinant", Determinant.test_case ();
     "Excitation", Excitation.test_case ();