LCPQ/QCaml
10
1
Fork 0
mirror of https://gitlab.com/scemama/QCaml.git synced 2024-12-31 16:45:41 +01:00
Code Releases Activity

Added Bitstring

Browse Source
This commit is contained in:
Anthony Scemama 2019-03-25 19:28:38 +01:00
parent 99f5fe0aef
commit b28212a959
9 changed files with 366 additions and 90 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

12
CI/CI.ml
View File

@ -639,28 +639,28 @@ let second_order_sum2 { det_space ; m_H ; m_S2 ; eigensystem ; n_states }
let is_internal det_space =
let m l =
List.fold_left (fun accu i ->
let j = i-1 in Z.(logor accu (shift_left one j))
) Z.zero l
let j = i-1 in Bitstring.(logor accu (shift_left_one j))
) Bitstring.zero l
in
let mo_class = DeterminantSpace.mo_class det_space in
let active_mask = m (MOClass.active_mos mo_class) in
let occ_mask = m (MOClass.core_mos mo_class) in
let inactive_mask = m (MOClass.inactive_mos mo_class) in
let occ_mask = Z.logor occ_mask inactive_mask in
let neg_active_mask = Z.lognot active_mask in
let occ_mask = Bitstring.logor occ_mask inactive_mask in
let neg_active_mask = Bitstring.lognot active_mask in
fun a ->
let alfa =
Determinant.alfa a
|> Spindeterminant.bitstring
in
if Z.logand neg_active_mask alfa <> occ_mask then
if Bitstring.logand neg_active_mask alfa <> occ_mask then
false
else
let beta =
Determinant.beta a
|> Spindeterminant.bitstring
in
Z.logand neg_active_mask beta = occ_mask
Bitstring.logand neg_active_mask beta = occ_mask
let _pt2_en ci =

10
CI/CIMatrixElement.ml
View File

@ -145,13 +145,9 @@ let make_s2 ki kj =
else 0.
| 0, 0 ->
let ba = Sp.bitstring kia and bb = Sp.bitstring kib in
let tmp = Z.(logxor ba bb) in
let popcount x =
if x = Z.zero then 0 else
Z.popcount x
in
let n_a = Z.(logand ba tmp) |> popcount in
let n_b = Z.(logand bb tmp) |> popcount in
let tmp = Bitstring.logxor ba bb in
let n_a = Bitstring.logand ba tmp |> Bitstring.popcount in
let n_b = Bitstring.logand bb tmp |> Bitstring.popcount in
let s_z = 0.5 *. float_of_int (n_a - n_b) in
float_of_int n_a +. s_z *. (s_z -. 1.)
| _ -> 0.

18
CI/Excitation.ml
View File

@ -17,12 +17,12 @@ let single_of_spindet t t' =
let d = Spindeterminant.bitstring t
and d' = Spindeterminant.bitstring t'
in
let tmp = Z.logxor d d' in
let hole_z = Z.logand (Spindeterminant.bitstring t ) tmp
and particle_z = Z.logand (Spindeterminant.bitstring t') tmp
let tmp = Bitstring.logxor d d' in
let hole_z = Bitstring.logand (Spindeterminant.bitstring t ) tmp
and particle_z = Bitstring.logand (Spindeterminant.bitstring t') tmp
in
let hole = 1 + Z.trailing_zeros hole_z
and particle = 1 + Z.trailing_zeros particle_z
let hole = 1 + Bitstring.trailing_zeros hole_z
and particle = 1 + Bitstring.trailing_zeros particle_z
in
(* Phase calculation *)
let low, high =
@ -32,13 +32,13 @@ let single_of_spindet t t' =
let mask =
let h = high-1 in
let l = low in
let mask_up = Z.(shift_left one h - one)
and mask_dn = Z.(lognot (shift_left one l) + one)
in Z.logand mask_up mask_dn
let mask_up = Bitstring.shift_left_one h |> Bitstring.minus_one
and mask_dn = Bitstring.plus_one @@ Bitstring.lognot (Bitstring.shift_left_one l)
in Bitstring.logand mask_up mask_dn
in
let phase =
Phase.add (Phase.add (Spindeterminant.phase t) (Spindeterminant.phase t'))
(Phase.of_nperm (Z.(popcount @@ logand d mask )))
(Phase.of_nperm (Bitstring.popcount @@ Bitstring.logand d mask ))
in
(hole, particle, phase)

47
CI/F12CI.ml
View File

@ -66,8 +66,8 @@ let f_ij mo_basis ki kj =
let is_internal det_space =
let m l =
List.fold_left (fun accu i ->
let j = i-1 in Z.(logor accu (shift_left one j))
) Z.zero l
let j = i-1 in Bitstring.(logor accu (shift_left_one j))
) Bitstring.zero l
in
let mo_class = DeterminantSpace.mo_class det_space in
let aux_mask = m (MOClass.auxiliary_mos mo_class) in
@ -76,14 +76,14 @@ let is_internal det_space =
Determinant.alfa a
|> Spindeterminant.bitstring
in
if Z.logand aux_mask alfa <> Z.zero then
if not (Bitstring.logand aux_mask alfa |> Bitstring.is_zero ) then
false
else
let beta =
Determinant.beta a
|> Spindeterminant.bitstring
in
Z.logand aux_mask beta = Z.zero
Bitstring.logand aux_mask beta |> Bitstring.is_zero
let dressing_vector gamma ~frozen_core aux_basis f12_amplitudes ci =
@ -158,10 +158,43 @@ let dressing_vector gamma ~frozen_core aux_basis f12_amplitudes ci =
let m_HF =
gemm m_H_aux m_F_aux ~transb:`T
in
(*
let m_HF =
let in_dets =
DeterminantSpace.determinants_array ci.CI.det_space
in
let fci_space = DeterminantSpace.fci_of_mo_basis ~frozen_core aux_basis in
Array.mapi (fun i ki ->
Printf.printf "%d / %d\r%!" i (Array.length in_dets);
Array.map (fun kj ->
match Determinant.degrees ki kj with
| (0,0) | (0,1) | (0,2) | (0,3) | (0,4)
| (1,0) | (2,0) | (3,0) | (4,0)
| (1,1) | (2,1) | (3,1)
| (1,2) | (1,3)
| (2,2) ->
( let x = ref 0. in
DeterminantSpace.determinant_stream fci_space
|> Stream.iter (fun k_alfa ->
if not (is_internal ci.CI.det_space ki) then
let f = f_ij aux_basis k_alfa kj in
if f <> 0. then
let h = h_ij aux_basis ki k_alfa in
x := !x +. f *. h
);
!x )
| _ -> 0.
) in_dets
) in_dets
|> Mat.of_array
in
*)
Printf.printf "Done\n%!";
Printf.printf "%d %d %d %d %d %d\n" (Mat.dim1 m_H_aux) (Mat.dim2 m_H_aux)
(Mat.dim1 m_F_aux) (Mat.dim2 m_F_aux)
(Mat.dim1 m_HF) (Mat.dim2 m_HF);
gemm m_HF f12_amplitudes
|> Matrix.sparse_of_mat

62
CI/Spindeterminant.ml
View File

@ -1,6 +1,6 @@
type s =
{
bitstring : Z.t ;
bitstring : Bitstring.t;
phase : Phase.t ;
}
@ -24,22 +24,23 @@ let bitstring = function
let vac =
Some { bitstring = Z.zero;
Some { bitstring = Bitstring.zero;
phase = Phase.Pos; }
let creation p = function
| None -> None
| Some spindet ->
let i = pred p in
if Z.testbit spindet.bitstring i then
if Bitstring.testbit spindet.bitstring i then
None
else
begin
let x = Z.(shift_left one i) in
let bitstring = Z.logor spindet.bitstring x in
let mask = Z.(x-one) in
let r = Z.logand bitstring mask in
let phase = Phase.add_nperm spindet.phase (Z.popcount r) in
let x = Bitstring.shift_left_one i in
let bitstring = Bitstring.logor spindet.bitstring x in
let mask = Bitstring.minus_one x in
let r = Bitstring.logand bitstring mask in
let phase = Phase.add_nperm spindet.phase (Bitstring.popcount r) in
Some { bitstring ; phase }
end
@ -48,15 +49,15 @@ let annihilation h = function
| None -> None
| Some spindet ->
let i = pred h in
if not (Z.testbit spindet.bitstring i) then
if not (Bitstring.testbit spindet.bitstring i) then
None
else
begin
let x = Z.(shift_left one i) in
let mask = Z.(x-one) in
let r = Z.logand spindet.bitstring mask in
let phase = Phase.add_nperm spindet.phase (Z.popcount r) in
let bitstring = Z.logand spindet.bitstring (Z.lognot x) in
let x = Bitstring.shift_left_one i in
let mask = Bitstring.minus_one x in
let r = Bitstring.logand spindet.bitstring mask in
let phase = Phase.add_nperm spindet.phase (Bitstring.popcount r) in
let bitstring = Bitstring.logand spindet.bitstring (Bitstring.lognot x) in
Some { bitstring ; phase }
end
@ -73,29 +74,23 @@ let double_excitation_reference h' p' h p spindet =
let double_excitation h' p' h p =
double_excitation_reference h' p' h p
let rec bits_to_list accu = function
| t when (t = Z.zero) -> List.rev accu
| t -> let newlist =
(Z.trailing_zeros t + 1)::accu
in
bits_to_list newlist Z.(logand t (t-one))
let degree t =
let bt = bitstring t in
fun t' -> Z.hamdist bt (bitstring t') / 2
fun t' -> Bitstring.hamdist bt (bitstring t') / 2
let holes_of t t' =
Z.logand (bitstring t) (Z.logxor (bitstring t) (bitstring t'))
|> bits_to_list []
Bitstring.logand (bitstring t) (Bitstring.logxor (bitstring t) (bitstring t'))
|> Bitstring.to_list []
let particles_of t t' =
Z.logand (bitstring t') (Z.logxor (bitstring t) (bitstring t'))
|> bits_to_list []
Bitstring.logand (bitstring t') (Bitstring.logxor (bitstring t) (bitstring t'))
|> Bitstring.to_list []
let holes_particles_of t t' =
let x = Z.logxor (bitstring t) (bitstring t') in
let holes = Z.logand (bitstring t) x |> bits_to_list []
and particles = Z.logand (bitstring t') x |> bits_to_list []
let x = Bitstring.logxor (bitstring t) (bitstring t') in
let holes = Bitstring.logand (bitstring t) x |> Bitstring.to_list []
and particles = Bitstring.logand (bitstring t') x |> Bitstring.to_list []
in
List.map2 (fun h p -> (h,p)) holes particles
@ -117,22 +112,23 @@ let rec to_list = function
| None -> []
| Some spindet ->
let rec aux accu z =
if z <> Z.zero then
let element = (Z.(trailing_zeros z)+1) in
aux (element::accu) Z.(z land (pred z))
if not (Bitstring.is_zero z) then
let element = ((Bitstring.trailing_zeros z)+1) in
aux (element::accu) (Bitstring.logand z (Bitstring.minus_one z) )
else List.rev accu
in aux [] spindet.bitstring
let n_electrons = function
| Some t -> Z.popcount t.bitstring
| Some t -> Bitstring.popcount t.bitstring
| None -> 0
let pp_spindet n ppf = function
| None -> Format.fprintf ppf "@[<h>None@]"
| Some s ->
Format.fprintf ppf "@[<h>%a %a@]" Phase.pp_phase s.phase (Util.pp_bitstring n) s.bitstring
Format.fprintf ppf "@[<h>%a %a@]" Phase.pp_phase s.phase (Bitstring.pp_bitstring n)
s.bitstring

4
CI/Spindeterminant.mli
View File

@ -15,7 +15,7 @@ val phase : t -> Phase.t
@raise Invalid_argument if the spin-determinant is [None].
*)
val bitstring : t -> Z.t
val bitstring : t -> Bitstring.t
(** Bit string.
@raise Invalid_argument if the spin-determinant is [None].
*)
@ -63,7 +63,7 @@ val n_electrons : t -> int
(** {1 Creation} *)
val of_bitstring : ?phase:Phase.t -> Z.t -> t
val of_bitstring : ?phase:Phase.t -> Bitstring.t -> t
(** Creates from a bitstring and an optional phase.*)
val of_list : int list -> t

22
CI/SpindeterminantSpace.ml
View File

@ -17,18 +17,18 @@ let fci_of_mo_basis ~frozen_core mo_basis elec_num =
let mo_num = MOBasis.size mo_basis in
let mo_class = MOClass.fci ~frozen_core mo_basis in
let m l =
List.fold_left (fun accu i -> let j = i-1 in Z.(logor accu (shift_left one j))
) Z.zero l
List.fold_left (fun accu i -> let j = i-1 in Bitstring.(logor accu (shift_left_one j))
) Bitstring.zero l
in
let occ_mask = m (MOClass.core_mos mo_class)
and active_mask = m (MOClass.active_mos mo_class)
in
let neg_active_mask = Z.lognot active_mask in
let neg_active_mask = Bitstring.lognot active_mask in
(* Here we generate the FCI space and filter out unwanted determinants
with excitations involving the core electrons. This should be improved. *)
let spin_determinants =
Util.bit_permtutations elec_num mo_num
|> List.filter (fun b -> Z.logand neg_active_mask b = occ_mask)
Bitstring.permtutations elec_num mo_num
|> List.filter (fun b -> Bitstring.logand neg_active_mask b = occ_mask)
|> List.map (fun b -> Spindeterminant.of_bitstring b)
|> Array.of_list
in
@ -39,19 +39,19 @@ let cas_of_mo_basis mo_basis ~frozen_core elec_num n m =
let mo_num = MOBasis.size mo_basis in
let mo_class = MOClass.cas_sd ~frozen_core mo_basis n m in
let m l =
List.fold_left (fun accu i -> let j = i-1 in Z.(logor accu (shift_left one j))
) Z.zero l
List.fold_left (fun accu i -> let j = i-1 in Bitstring.(logor accu (Bitstring.shift_left_one j))
) Bitstring.zero l
in
let active_mask = m (MOClass.active_mos mo_class) in
let occ_mask = m (MOClass.core_mos mo_class) in
let inactive_mask = m (MOClass.inactive_mos mo_class) in
let occ_mask = Z.logor occ_mask inactive_mask in
let neg_active_mask = Z.lognot active_mask in
let occ_mask = Bitstring.logor occ_mask inactive_mask in
let neg_active_mask = Bitstring.lognot active_mask in
(* Here we generate the FCI space and filter out all the unwanted determinants.
This should be improved. *)
let spin_determinants =
Util.bit_permtutations elec_num mo_num
|> List.filter (fun b -> Z.logand neg_active_mask b = occ_mask)
Bitstring.permtutations elec_num mo_num
|> List.filter (fun b -> Bitstring.logand neg_active_mask b = occ_mask)
|> List.map (fun b -> Spindeterminant.of_bitstring b)
|> Array.of_list
in

266
Utils/Bitstring.ml Normal file
View File

@ -0,0 +1,266 @@
type t =
| One of int
| Many of Z.t
(*
let of_int x = One x
*)
let of_int x = Many (Z.of_int x)
let of_z x = if (Z.lt x (Z.of_int max_int)) then One (Z.to_int x) else Many x
(*
let zero = One 0
*)
let zero = Many Z.zero
let is_zero = function
| One x -> assert false (* x = 0 *)
| Many x -> x = Z.zero
let shift_left x i =
match x with
| One x -> assert false (*
let y = x lsl i in
if y lsr i = x then
One y
else
Many (Z.shift_left (Z.of_int x) i)
*)
| Many x -> Many (Z.shift_left x i)
let shift_right x i =
match x with
| One x -> assert false (* One (x lsr i) *)
| Many x -> Z.shift_right x i |> of_z
let shift_left_one =
let memo =
Array.init 512 (fun i ->
(*
if i < 63 then
One (1 lsl i)
else
*)
Many (Z.(shift_left one i)))
in
fun i ->
if i < 512 then
memo.(i)
else
Many (Z.(shift_left one i))
let testbit bs i =
match bs with
| One one -> assert false (* (one lsr i) land 1 = 1 *)
| Many z -> Z.testbit z i
let logor a b =
match a,b with
| One a, One b -> assert false (* One (a lor b) *)
| One a, Many b -> Many (Z.logor (Z.of_int a) b)
| Many a, One b -> Many (Z.logor a (Z.of_int b))
| Many a, Many b -> Many (Z.logor a b)
let logxor a b =
match a,b with
| One a, One b -> assert false (* One (a lxor b) *)
| One a, Many b -> Many (Z.logxor (Z.of_int a) b)
| Many a, One b -> Many (Z.logxor a (Z.of_int b))
| Many a, Many b -> Many (Z.logxor a b)
let logand a b =
match a,b with
| One a, One b -> assert false (* One (a land b) *)
| One a, Many b -> Many (Z.logand (Z.of_int a) b)
| Many a, One b -> Many (Z.logand a (Z.of_int b))
| Many a, Many b -> Many (Z.logand a b)
let lognot = function
| One a -> Many ( Z.(lognot @@ of_int a) )
| Many a -> Many ( Z.lognot a )
let minus_one = function
| One a -> assert false (* One ( a-1 ) *)
| Many a -> Many ( Z.(a-one) )
let plus_one = function
| One a -> assert false (* One ( a+1 ) *)
| Many a -> Many ( Z.(a+one) )
let popcount = function
| One r -> assert false (* Util.popcnt (Int64.of_int r) *)
| Many r when r = Z.zero -> 0
| Many r -> Z.popcount r
let trailing_zeros = function
| One r -> assert false (* Util.trailz (Int64.of_int r) *)
| Many r -> Z.trailing_zeros r
let hamdist a b =
match a,b with
| One a, One b -> assert false (* a lxor b |> Int64.of_int |> Util.popcnt *)
| One a, Many b -> Z.hamdist (Z.of_int a) b
| Many a, One b -> Z.hamdist a (Z.of_int b)
| Many a, Many b -> Z.hamdist a b
let rec to_list accu = function
| t when (t = Many Z.zero || t = One 0) -> List.rev accu
| t -> let newlist =
(trailing_zeros t + 1)::accu
in
to_list newlist (logand t (minus_one t))
(** [permtutations m n] generates the list of all possible [n]-bit
strings with [m] bits set to 1.
Algorithm adapted from
{{:https://graphics.stanford.edu/~seander/bithacks.html#NextBitPermutation}
Bit twiddling hacks}.
Example:
{[
bit_permtutations 2 4 = [ 0011 ; 0101 ; 0110 ; 1001 ; 1010 ; 1100 ]
]}
*)
let permtutations m n =
let rec aux k u rest =
if k=1 then
List.rev (u :: rest)
else
let t = (logor u (minus_one u)) in
let t' = plus_one t in
let t'' = shift_right (minus_one (logand (lognot t) t')) (trailing_zeros u + 1) in
aux (k-1) (logor t' t'') (u :: rest)
in
aux (Util.binom n m) (minus_one (shift_left_one m)) []
let pp_bitstring n ppf s =
Format.fprintf ppf "@[%a@]" (Util.pp_bitstring n) (
match s with
| Many b -> b
| One b -> Z.of_int b )
(*-----------------------------------------------------------------------------------*)
(* TODO
let test_case () =
let test_creation () =
let l_a = [ 1 ; 2 ; 3 ; 5 ] in
let det = of_list l_a in
Alcotest.(check (list int )) "bitstring 1" l_a (to_list det);
Alcotest.(check bool) "phase 2" true (phase det = Phase.Pos);
let l_b = [ 1 ; 3 ; 2 ; 5 ] in
let det = of_list l_b in
Alcotest.(check (list int )) "bitstring 2" l_a (to_list det);
Alcotest.(check bool) "phase 2" true (phase det = Phase.Neg);
in
let test_a_operators () =
let det =
creation 5 @@ creation 2 @@ creation 2 @@ creation 1 @@ vac
in
Alcotest.(check bool) "none 1" true (is_none det);
let det =
creation 5 @@ creation 3 @@ creation 2 @@ creation 1 @@ vac
in
let l_a = [ 1 ; 2 ; 3 ; 5 ] in
Alcotest.(check (list int )) "bitstring 1" l_a (to_list det);
Alcotest.(check bool) "phase 1" true (phase det = Phase.Pos);
let det =
creation 1 @@ creation 3 @@ creation 2 @@ creation 5 @@ vac
in
Alcotest.(check (list int )) "bitstring 2" l_a (to_list det);
Alcotest.(check bool) "phase 2" true (phase det = Phase.Neg);
let l_b = [ 1 ; 3 ; 2 ; 5 ] in
let det = of_list l_b in
Alcotest.(check (list int )) "bitstring 3" l_a (to_list det);
Alcotest.(check bool) "phase 3" true (phase det = Phase.Neg);
Alcotest.(check bool) "none 1" true (annihilation 4 det |> is_none);
let det =
annihilation 1 det
in
Alcotest.(check (list int )) "bitstring 4" (List.tl l_a) (to_list det);
Alcotest.(check bool) "phase 4" true (phase det = Phase.Neg);
let det =
annihilation 3 det
in
Alcotest.(check (list int )) "bitstring 5" [ 2 ; 5 ] (to_list det);
Alcotest.(check bool) "phase 5" true (phase det = Phase.Pos);
let det =
annihilation 5 @@ annihilation 2 det
in
Alcotest.(check (list int )) "bitstring 6" [] (to_list det);
Alcotest.(check bool) "phase 6" true (phase det = Phase.Pos);
in
let test_exc_operators () =
let l_a = [ 1 ; 2 ; 3 ; 5 ] in
let det = of_list l_a in
let l_b = [ 1 ; 7 ; 3 ; 5 ] in
let det2 = of_list l_b in
Alcotest.(check bool) "single 1" true (single_excitation_reference 2 7 det = det2);
Alcotest.(check bool) "single 2" true (single_excitation 2 7 det = single_excitation_reference 2 7 det);
Alcotest.(check bool) "single 3" true (single_excitation_reference 4 7 det |> is_none);
Alcotest.(check bool) "single 4" true (single_excitation 4 7 det |> is_none);
let l_c = [ 1 ; 7 ; 6 ; 5 ] in
let det3 = of_list l_c in
Alcotest.(check bool) "double 1" true (double_excitation_reference 2 7 3 6 det = det3);
Alcotest.(check bool) "double 2" true (double_excitation 2 7 3 6 det = double_excitation_reference 2 7 3 6 det);
Alcotest.(check bool) "double 3" true (double_excitation_reference 4 7 3 6 det |> is_none);
Alcotest.(check bool) "double 4" true (double_excitation 4 7 3 6 det |> is_none);
in
let test_exc_spindet () =
let l_a = [ 1 ; 2 ; 3 ; 5 ] in
let det = of_list l_a in
let l_b = [ 1 ; 7 ; 3 ; 5 ] in
let det2 = of_list l_b in
Alcotest.(check int) "single" 1 (degree det det2);
Alcotest.(check (list int)) "holes" [2] (holes_of det det2);
Alcotest.(check (list int)) "particles" [7] (particles_of det det2);
let l_b = [ 1 ; 7 ; 3 ; 6 ] in
let det2 = of_list l_b in
Alcotest.(check int) "double" 2 (degree det det2);
Alcotest.(check (list int)) "holes" [2 ; 5] (holes_of det det2);
Alcotest.(check (list int)) "particles" [6 ; 7] (particles_of det det2);
in
[
"Creation", `Quick, test_creation;
"Creation/Annihilation Operators", `Quick, test_a_operators;
"Excitation Operators", `Quick, test_exc_operators;
"Excitation of spindet", `Quick, test_exc_spindet;
]
*)

15
Utils/Util.mli
View File

@ -153,21 +153,6 @@ val sym_matrix_of_file : string -> Mat.t
[i, j, A.{i,j}]. *)
(** {2 Bitstring functions} *)
val bit_permtutations : int -> int -> Z.t list
(** [bit_permtutations m n] generates the list of all possible [n]-bit
strings with [m] bits set to 1.
Algorithm adapted from
{{:https://graphics.stanford.edu/~seander/bithacks.html#NextBitPermutation}
Bit twiddling hacks}.
Example:
{[
bit_permtutations 2 4 = [ 0011 ; 0101 ; 0110 ; 1001 ; 1010 ; 1100 ]
]}
*)
(** {2 Printers} *)
val pp_float_array_size : Format.formatter -> float array -> unit
(** Example: