diff --git a/CI/CI.ml b/CI/CI.ml index 8661b59..5380175 100644 --- a/CI/CI.ml +++ b/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 diff --git a/CI/Determinant_space.ml b/CI/Determinant_space.ml index 6fcee7c..6de4d7c 100644 --- a/CI/Determinant_space.ml +++ b/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 } diff --git a/CI/Determinant_space.mli b/CI/Determinant_space.mli index bd7b42a..e8e6280 100644 --- a/CI/Determinant_space.mli +++ b/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} *) diff --git a/Utils/Util.ml b/Utils/Util.ml index ddfd69c..afe94fa 100644 --- a/Utils/Util.ml +++ b/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; + ] + diff --git a/Utils/Util.mli b/Utils/Util.mli index 4971412..6f275e2 100644 --- a/Utils/Util.mli +++ b/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 + diff --git a/Utils/math_functions.c b/Utils/math_functions.c index 1ee4939..10a4928 100644 --- a/Utils/math_functions.c +++ b/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)); +} + diff --git a/run_tests.ml b/run_tests.ml index 534c347..9e66476 100644 --- a/run_tests.ml +++ b/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 ();