LCPQ/QCaml
10
1
Fork 0
mirror of https://gitlab.com/scemama/QCaml.git synced 2024-11-07 14:43:41 +01:00
Code Releases Activity

Implemented fast f12 in native code

Browse Source
This commit is contained in:
Anthony Scemama 2020-01-11 23:46:04 +01:00
parent 85a4425a6e
commit a20ec08125
4 changed files with 870 additions and 596 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

1
CI/CI.ml
View File

@ -290,6 +290,7 @@ let create_matrix_spin ?(nmax=2) f det_space =
let singles = let singles =
List.filter (fun (i,d,det_j) -> d < 2) doubles List.filter (fun (i,d,det_j) -> d < 2) doubles
in in
let triples = let triples =
List.map (fun (i,_,det_j) -> (i,det_j)) triples List.map (fun (i,_,det_j) -> (i,det_j)) triples
in in

147
CI/CIMatrixElementF12.ml
View File

@ -1,147 +0,0 @@
open Lacaml.D
module De = Determinant
module Ex = Excitation
module Sp = Spindeterminant
type t = float list
let non_zero integrals degree_a degree_b ki kj =
let kia = De.alfa ki and kib = De.beta ki
and kja = De.alfa kj and kjb = De.beta kj
in
let diag_element =
let mo_a = Sp.to_list kia
and mo_b = Sp.to_list kib
in
fun one_e two_e ->
let one =
(List.fold_left (fun accu i -> accu +. one_e i i Spin.Alfa) 0. mo_a)
+.
(List.fold_left (fun accu i -> accu +. one_e i i Spin.Beta) 0. mo_b)
in
let two =
let rec aux_same spin accu = function
| [] -> accu
| i :: rest ->
let new_accu =
List.fold_left (fun accu j -> accu +. two_e i j i j spin spin) accu rest
in
(aux_same [@tailcall]) spin new_accu rest
in
let rec aux_opposite accu other = function
| [] -> accu
| i :: rest ->
let new_accu =
List.fold_left (fun accu j -> accu +. two_e i j i j Spin.Alfa Spin.Beta) accu other
in
(aux_opposite [@tailcall]) new_accu other rest
in
(aux_same Spin.Alfa 0. mo_a) +. (aux_same Spin.Beta 0. mo_b) +.
(aux_opposite 0. mo_a mo_b)
in
one +. two
in
let result =
match degree_a, degree_b with
| 1, 1 -> (* alpha-beta double *)
begin
let ha, pa, phase_a = Ex.single_of_spindet kia kja in
let hb, pb, phase_b = Ex.single_of_spindet kib kjb in
let s1 =
match phase_a, phase_b with
| Phase.Pos, Phase.Pos
| Phase.Neg, Phase.Neg -> fun _ two_e -> two_e ha hb pa pb Spin.Alfa Spin.Beta
| Phase.Neg, Phase.Pos
| Phase.Pos, Phase.Neg -> fun _ two_e -> -. two_e ha hb pa pb Spin.Alfa Spin.Beta
in
let kk = Determinant.double_excitation Spin.Alfa ha pb Spin.Beta hb pa ki in
let kka = De.alfa kk and kkb = De.beta kk in
match Spindeterminant.(degree kia kka, degree kib kkb) with
| (1,1) ->
let s2 =
begin
let ha, pa, phase_a = Ex.single_of_spindet kia kka in
let hb, pb, phase_b = Ex.single_of_spindet kib kkb in
match phase_a, phase_b with
| Phase.Pos, Phase.Pos
| Phase.Neg, Phase.Neg -> fun _ two_e -> two_e ha hb pa pb Spin.Alfa Spin.Beta
| Phase.Neg, Phase.Pos
| Phase.Pos, Phase.Neg -> fun _ two_e -> -. two_e ha hb pa pb Spin.Alfa Spin.Beta
end
in fun x two_e -> 0.75 *. (s1 x two_e) +. 0.25 *. (s2 x two_e)
| _ -> fun x two_e -> 0.
end
| 2, 0 -> (* alpha double *)
begin
let h1, p1, h2, p2, phase = Ex.double_of_spindet kia kja in
match phase with
| Phase.Pos -> fun _ two_e -> two_e h1 h2 p1 p2 Spin.Alfa Spin.Alfa
| Phase.Neg -> fun _ two_e -> -. two_e h1 h2 p1 p2 Spin.Alfa Spin.Alfa
end
| 0, 2 -> (* beta double *)
begin
let h1, p1, h2, p2, phase = Ex.double_of_spindet kib kjb in
match phase with
| Phase.Pos -> fun _ two_e -> two_e h1 h2 p1 p2 Spin.Beta Spin.Beta
| Phase.Neg -> fun _ two_e -> -. two_e h1 h2 p1 p2 Spin.Beta Spin.Beta
end
| 1, 0 (* alpha single *)
| 0, 1 (* beta single *)
-> fun _ _ -> 0.
| 0, 0 -> (* diagonal element *)
diag_element
| _ -> assert false
in
List.map (fun (one_e, two_e) -> result one_e two_e) integrals
let make integrals ki kj =
let degree_a, degree_b =
De.degrees ki kj
in
if degree_a+degree_b > 2 then
List.map (fun _ -> 0.) integrals
else
non_zero integrals degree_a degree_b ki kj
let make_s2 ki kj =
let degree_a = De.degree_alfa ki kj in
let kia = De.alfa ki in
let kja = De.alfa kj in
if degree_a > 1 then 0.
else
let degree_b = De.degree_beta ki kj in
let kib = De.beta ki in
let kjb = De.beta kj in
match degree_a, degree_b with
| 1, 1 -> (* alpha-beta double *)
let ha, pa, phase_a = Ex.single_of_spindet kia kja in
let hb, pb, phase_b = Ex.single_of_spindet kib kjb in
if ha = pb && hb = pa then
begin
match phase_a, phase_b with
| Phase.Pos, Phase.Pos
| Phase.Neg, Phase.Neg -> -1.
| Phase.Neg, Phase.Pos
| Phase.Pos, Phase.Neg -> 1.
end
else 0.
| 0, 0 ->
let ba = Sp.bitstring kia and bb = Sp.bitstring kib 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.

329
CI/F12CI.ml
View File

@ -20,269 +20,89 @@ let mo_class t = Ds.mo_class @@ det_space t
let eigensystem t = Lazy.force t.eigensystem let eigensystem t = Lazy.force t.eigensystem
(*
let single_matrices hf12_integrals density =
let nocc = Mat.dim1 density in
let nvir = Mat.dim2 density in
let { HF12.
simulation ; aux_basis ;
hf12 ; hf12_anti ;
hf12_single ; hf12_single_anti } = hf12_integrals
in
let f12 = MOBasis.f12_ints aux_basis in
let eri = MOBasis.two_e_ints aux_basis in
let d = Mat.as_vec density in let dressing_vector ~frozen_core hf12_integrals f12_amplitudes ci =
let v_s = Mat.create nocc nvir in
let v_o = Mat.create nocc nvir in if Parallel.master then
let h_o, h_s, f_o, f_s = Printf.printf "Building matrix\n%!";
Mat.create nocc nvir , let det_space =
Mat.create nocc nvir , ci.CI.det_space
Mat.create nocc nvir , in
Mat.create nocc nvir ,
let { HF12.
simulation ; aux_basis ;
f_0 ; f_1 ; f_2 ; f_3 } = hf12_integrals
in
let m_HF =
let f =
match Ds.determinants det_space with
| Ds.Arbitrary _ -> CI.create_matrix_arbitrary
| Ds.Spin _ -> CI.create_matrix_spin_computed ~nmax:3
in in
for a=1 to nvir do f (fun deg_a deg_b ki kj ->
for m=1 to occ do match deg_a + deg_b with
for u=1 to nocc do | 0 -> f_0 ki
for t=1 to nocc do | 1 -> f_1 ki kj
let hmtau = ERI.get_phys eri m t a u | 2 -> f_2 ki kj
and hmtua = ERI.get_phys eri m t u a | 3 -> f_3 ki kj
in | _ -> assert false
v_o.{t,u} <- hmtau; ) det_space
v_s.{t,u} <- hmtau -. hmtua;
done in
done;
h_o.{m,a} <- dot d_o @@ Mat.as_vec v_o; Matrix.mm (Lazy.force m_HF) (Matrix.dense_of_mat f12_amplitudes)
h_s.{m,a} <- dot d_s @@ Mat.as_vec v_s
for u=1 to nocc do
for t=1 to nocc do let sum l f = List.fold_left (fun accu i -> accu +. f i) 0. l
let fmtau = ERI.get_phys f12 m t a u
and fmtua = ERI.get_phys f12 m t u a let array_3_init d1 d2 d3 f =
in let result =
v_o.{t,u} <- 0.375 *. fmtau +. 0.125 *. fmtua; Bigarray.(Array3.create Float64 fortran_layout) d1 d2 d3
v_s.{t,u} <- 0.25 *, (fmtau -. fmtua); in
done for k=1 to d3 do
done; for j=1 to d2 do
f_o.{m,a} <- dot d_o @@ Mat.as_vec v_o; for i=1 to d1 do
f_s.{m,a} <- dot d_s @@ Mat.as_vec v_s result.{i,j,k} <- f i j k
done
done done
done; done;
*) result
(*--- let array_4_init d1 d2 d3 d4 f =
let hf_ij_non_zero mo_basis hf12_integrals deg_a deg_b ki kj = let result =
let integrals = [ Bigarray.(Genarray.create Float64 fortran_layout) [| d1;d2;d3;d4 |]
let { HF12.
simulation ; aux_basis ;
hf12 ; hf12_anti ;
hf12_single ; hf12_single_anti } = hf12_integrals
in
let kia = De.alfa ki and kib = De.beta ki in
let kja = De.alfa kj and kjb = De.beta kj in
let mo_a =
Bitstring.logand (Sp.bitstring kia) (Sp.bitstring kja)
|> Bitstring.to_list
|> Array.of_list
and mo_b =
Bitstring.logand (Sp.bitstring kib) (Sp.bitstring kjb)
|> Bitstring.to_list
|> Array.of_list
in
let aux_mos =
Util.list_range (MOBasis.size mo_basis) (MOBasis.size aux_basis)
|> Array.of_list
in
let one_e _ _ _ = 0. in
let h = MOBasis.ee_ints aux_basis in
let two_e_h i j k l s s' =
if s' <> s then
ERI.get_phys h i j k l
else
(ERI.get_phys h i j k l) -. (ERI.get_phys h i j l k)
in
let f = MOBasis.f12_ints aux_basis in
let two_e_f i j k l s s' =
let fijkl = F12.get_phys f i j k l
and fijlk = F12.get_phys f i j l k
in
if s' <> s then
0.325 *. fijkl +. 0.125 *. fijlk
else
0.25 *. (fijkl -. fijlk)
in
(*
let mo_of_s = function
| Spin.Alfa -> mo_a
| Spin.Beta -> mo_b
in
*)
let two_e i j k l s s' =
(
if s = s' then
hf12_anti.{i,j,k,l} -. (
(Array.fold_left (fun accu m -> accu +. hf12_single_anti.{m,i,j,k,l}) 0. mo_a) +.
(Array.fold_left (fun accu m -> accu +. hf12_single_anti.{m,j,i,l,k}) 0. mo_b) )
else
hf12.{i,j,k,l} -. (
(Array.fold_left (fun accu m -> accu +. hf12_single.{m,i,j,k,l}) 0. mo_a) +.
(Array.fold_left (fun accu m -> accu +. hf12_single.{m,j,i,l,k}) 0. mo_b) )
)
(*
+. Array.fold_left ( fun accu a -> accu +.
(Array.fold_left ( fun accu m -> accu +. two_e_h m i m a s s) 0. (mo_of_s s) +.
Array.fold_left ( fun accu m -> accu +. two_e_h m i m a s s) 0. (mo_of_s @@ Spin.other s) )
*. (two_e_f a j k l s s') ) 0. aux_mos
*)
in
let three_e i j k l m n s s' s'' =
Array.fold_left (fun accu a -> accu +. two_e_h i j l a s s' *. two_e_f a k m n s' s'') 0. aux_mos
-. Array.fold_left (fun accu a -> accu +. two_e_h j i m a s' s *. two_e_f a k l n s s'') 0. aux_mos
+. Array.fold_left (fun accu a -> accu +. two_e_h j k m a s' s'' *. two_e_f a i n l s'' s ) 0. aux_mos
-. Array.fold_left (fun accu a -> accu +. two_e_h k j n a s'' s' *. two_e_f a i m l s' s ) 0. aux_mos
+. Array.fold_left (fun accu a -> accu +. two_e_h k i n a s'' s *. two_e_f a j l m s s' ) 0. aux_mos
-. Array.fold_left (fun accu a -> accu +. two_e_h i k l a s s'' *. two_e_f a j n m s'' s' ) 0. aux_mos
in
(one_e, two_e, Some three_e)
]
in in
CIMatrixElement.non_zero integrals deg_a deg_b ki kj for l=1 to d4 do
|> List.hd for k=1 to d3 do
for j=1 to d2 do
for i=1 to d1 do
result.{i,j,k,l} <- f i j k l
done
done
done
done;
result
let array_5_init d1 d2 d3 d4 d5 f =
let dressing_vector ~frozen_core hf12_integrals f12_amplitudes ci = let result =
Bigarray.(Genarray.create Float64 fortran_layout) [| d1;d2;d3;d4;d5 |]
if Parallel.master then
Printf.printf "Building matrix\n%!";
let det_space =
ci.CI.det_space
in
let mo_basis =
Ds.mo_basis det_space
in in
for m=1 to d5 do
for l=1 to d4 do
for k=1 to d3 do
for j=1 to d2 do
for i=1 to d1 do
result.{i,j,k,l,m} <- f i j k l m
done
done
done
done
done;
result
let m_HF =
let f =
match Ds.determinants det_space with
| Ds.Arbitrary _ -> CI.create_matrix_arbitrary
| Ds.Spin _ -> CI.create_matrix_spin_computed ~nmax:3
in
f (fun deg_a deg_b ki kj ->
hf_ij_non_zero mo_basis hf12_integrals deg_a deg_b ki kj
) det_space
in
Matrix.mm (Lazy.force m_HF) (Matrix.dense_of_mat f12_amplitudes)
--- *)
let hf_ij_non_zero hf12_integrals deg_a deg_b ki kj =
let integrals = [
let { HF12.
simulation ; aux_basis ;
hf12 ; hf12_anti ;
hf12_single ; hf12_single_anti } = hf12_integrals
in
let kia = De.alfa ki and kib = De.beta ki in
let kja = De.alfa kj and kjb = De.beta kj in
let mo_a =
Bitstring.logand (Sp.bitstring kia) (Sp.bitstring kja)
|> Bitstring.to_list
and mo_b =
Bitstring.logand (Sp.bitstring kib) (Sp.bitstring kjb)
|> Bitstring.to_list
in
let one_e _ _ _ = 0. in
let two_e i j k l s s' =
if s = s' then
hf12_anti.{i,j,k,l} -. (
(List.fold_left (fun accu m -> accu +. hf12_single_anti.{m,i,j,k,l}) 0. mo_a) +.
(List.fold_left (fun accu m -> accu +. hf12_single_anti.{m,j,i,l,k}) 0. mo_b)
)
else
hf12.{i,j,k,l} -. (
(List.fold_left (fun accu m -> accu +. hf12_single.{m,i,j,k,l}) 0. mo_a) +.
(List.fold_left (fun accu m -> accu +. hf12_single.{m,j,i,l,k}) 0. mo_b)
)
in
let h = MOBasis.ee_ints aux_basis in
let two_e_h i j k l s s' =
if s' <> s then
ERI.get_phys h l k j i
else
(ERI.get_phys h l k j i) -. (ERI.get_phys h k l j i)
in
let f = MOBasis.f12_ints aux_basis in
let two_e_f i j k l s s' =
if s' <> s then
F12.get_phys f i j k l
else
(F12.get_phys f i j k l) -. (F12.get_phys f i j l k)
in
let mo_of_s = function
| Spin.Alfa -> mo_a
| Spin.Beta -> mo_b
in
let three_e i j k l m n s s' s'' =
List.fold_left (fun accu a -> accu +. two_e_h i j l a s s' *. two_e_f a k m n s' s'') 0. (mo_of_s s' )
-. List.fold_left (fun accu a -> accu +. two_e_h j i m a s' s *. two_e_f a k l n s s'') 0. (mo_of_s s )
+. List.fold_left (fun accu a -> accu +. two_e_h j k m a s' s'' *. two_e_f a i n l s'' s ) 0. (mo_of_s s'')
-. List.fold_left (fun accu a -> accu +. two_e_h k j n a s'' s' *. two_e_f a i m l s' s ) 0. (mo_of_s s' )
+. List.fold_left (fun accu a -> accu +. two_e_h k i n a s'' s *. two_e_f a j l m s s' ) 0. (mo_of_s s )
-. List.fold_left (fun accu a -> accu +. two_e_h i k l a s s'' *. two_e_f a j n m s'' s' ) 0. (mo_of_s s'')
in
(one_e, two_e, Some three_e)
]
in
CIMatrixElement.non_zero integrals deg_a deg_b ki kj
|> List.hd
let dressing_vector ~frozen_core hf12_integrals f12_amplitudes ci =
if Parallel.master then
Printf.printf "Building matrix\n%!";
let det_space =
ci.CI.det_space
in
let m_HF =
let f =
match Ds.determinants det_space with
| Ds.Arbitrary _ -> CI.create_matrix_arbitrary
| Ds.Spin _ -> CI.create_matrix_spin_computed ~nmax:3
in
f (fun deg_a deg_b ki kj ->
hf_ij_non_zero hf12_integrals deg_a deg_b ki kj
) det_space
in
Matrix.mm (Lazy.force m_HF) (Matrix.dense_of_mat f12_amplitudes)
let make ~simulation ?(threshold=1.e-12) ~frozen_core ~mo_basis ~aux_basis_filename ?(state=1) () = let make ~simulation ?(threshold=1.e-12) ~frozen_core ~mo_basis ~aux_basis_filename ?(state=1) () =
@ -302,6 +122,7 @@ let make ~simulation ?(threshold=1.e-12) ~frozen_core ~mo_basis ~aux_basis_filen
Parallel.broadcast (lazy x) Parallel.broadcast (lazy x)
in in
let eigensystem = lazy ( let eigensystem = lazy (
let m_H = let m_H =
Lazy.force ci.CI.m_H Lazy.force ci.CI.m_H

993
MOBasis/HF12.ml
View File

File diff suppressed because it is too large Load Diff