mirror of
https://gitlab.com/scemama/QCaml.git
synced 2025-01-03 01:55:40 +01:00
Implemented fast f12 in native code
This commit is contained in:
parent
85a4425a6e
commit
a20ec08125
1
CI/CI.ml
1
CI/CI.ml
@ -290,6 +290,7 @@ let create_matrix_spin ?(nmax=2) f det_space =
|
||||
let singles =
|
||||
List.filter (fun (i,d,det_j) -> d < 2) doubles
|
||||
in
|
||||
|
||||
let triples =
|
||||
List.map (fun (i,_,det_j) -> (i,det_j)) triples
|
||||
in
|
||||
|
||||
@ -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
329
CI/F12CI.ml
@ -20,269 +20,89 @@ let mo_class t = Ds.mo_class @@ det_space t
|
||||
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 v_s = Mat.create nocc nvir in
|
||||
let v_o = Mat.create nocc nvir in
|
||||
let h_o, h_s, f_o, f_s =
|
||||
Mat.create nocc nvir ,
|
||||
Mat.create nocc nvir ,
|
||||
Mat.create nocc nvir ,
|
||||
Mat.create nocc nvir ,
|
||||
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 { 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
|
||||
for a=1 to nvir do
|
||||
for m=1 to occ do
|
||||
for u=1 to nocc do
|
||||
for t=1 to nocc do
|
||||
let hmtau = ERI.get_phys eri m t a u
|
||||
and hmtua = ERI.get_phys eri m t u a
|
||||
in
|
||||
v_o.{t,u} <- hmtau;
|
||||
v_s.{t,u} <- hmtau -. hmtua;
|
||||
done
|
||||
done;
|
||||
h_o.{m,a} <- dot d_o @@ Mat.as_vec v_o;
|
||||
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 fmtau = ERI.get_phys f12 m t a u
|
||||
and fmtua = ERI.get_phys f12 m t u a
|
||||
in
|
||||
v_o.{t,u} <- 0.375 *. fmtau +. 0.125 *. fmtua;
|
||||
v_s.{t,u} <- 0.25 *, (fmtau -. fmtua);
|
||||
done
|
||||
done;
|
||||
f_o.{m,a} <- dot d_o @@ Mat.as_vec v_o;
|
||||
f_s.{m,a} <- dot d_s @@ Mat.as_vec v_s
|
||||
f (fun deg_a deg_b ki kj ->
|
||||
match deg_a + deg_b with
|
||||
| 0 -> f_0 ki
|
||||
| 1 -> f_1 ki kj
|
||||
| 2 -> f_2 ki kj
|
||||
| 3 -> f_3 ki kj
|
||||
| _ -> assert false
|
||||
) det_space
|
||||
|
||||
in
|
||||
|
||||
Matrix.mm (Lazy.force m_HF) (Matrix.dense_of_mat f12_amplitudes)
|
||||
|
||||
|
||||
let sum l f = List.fold_left (fun accu i -> accu +. f i) 0. l
|
||||
|
||||
let array_3_init d1 d2 d3 f =
|
||||
let result =
|
||||
Bigarray.(Array3.create Float64 fortran_layout) d1 d2 d3
|
||||
in
|
||||
for k=1 to d3 do
|
||||
for j=1 to d2 do
|
||||
for i=1 to d1 do
|
||||
result.{i,j,k} <- f i j k
|
||||
done
|
||||
done
|
||||
done;
|
||||
*)
|
||||
done;
|
||||
result
|
||||
|
||||
(*---
|
||||
let hf_ij_non_zero mo_basis 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
|
||||
|> 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)
|
||||
]
|
||||
let array_4_init d1 d2 d3 d4 f =
|
||||
let result =
|
||||
Bigarray.(Genarray.create Float64 fortran_layout) [| d1;d2;d3;d4 |]
|
||||
in
|
||||
CIMatrixElement.non_zero integrals deg_a deg_b ki kj
|
||||
|> List.hd
|
||||
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} <- f i j k l
|
||||
done
|
||||
done
|
||||
done
|
||||
done;
|
||||
result
|
||||
|
||||
|
||||
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 mo_basis =
|
||||
Ds.mo_basis det_space
|
||||
let array_5_init d1 d2 d3 d4 d5 f =
|
||||
let result =
|
||||
Bigarray.(Genarray.create Float64 fortran_layout) [| d1;d2;d3;d4;d5 |]
|
||||
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) () =
|
||||
@ -302,6 +122,7 @@ let make ~simulation ?(threshold=1.e-12) ~frozen_core ~mo_basis ~aux_basis_filen
|
||||
Parallel.broadcast (lazy x)
|
||||
in
|
||||
|
||||
|
||||
let eigensystem = lazy (
|
||||
let m_H =
|
||||
Lazy.force ci.CI.m_H
|
||||
|
||||
993
MOBasis/HF12.ml
993
MOBasis/HF12.ml
File diff suppressed because it is too large
Load Diff
Loading…
Reference in New Issue
Block a user