LCPQ
/
QCaml
mirror of https://gitlab.com/scemama/QCaml.git
10
1
Fork 0
Code Releases Activity

Implemented fast f12 in native code

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 =
List.filter (fun (i,d,det_j) -> d < 2) doubles
in
let triples =
List.map (fun (i,_,det_j) -> (i,det_j)) triples
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.

325
CI/F12CI.ml
View File

@ -4,7 +4,7 @@ module Ds = DeterminantSpace
module De = Determinant
module Sp = Spindeterminant
type t =
type t =
{
mo_basis : MOBasis.t ;
det_space : DeterminantSpace.t ;
@ -20,245 +20,6 @@ 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 ,
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
done
done;
*)
(*---
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)
]
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 mo_basis =
Ds.mo_basis 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 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 =
@ -269,6 +30,11 @@ let dressing_vector ~frozen_core hf12_integrals f12_amplitudes ci =
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 =
@ -277,7 +43,12 @@ let dressing_vector ~frozen_core hf12_integrals f12_amplitudes ci =
| 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
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
@ -285,10 +56,59 @@ let dressing_vector ~frozen_core hf12_integrals f12_amplitudes ci =
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;
result
let array_4_init d1 d2 d3 d4 f =
let result =
Bigarray.(Genarray.create Float64 fortran_layout) [| d1;d2;d3;d4 |]
in
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 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 make ~simulation ?(threshold=1.e-12) ~frozen_core ~mo_basis ~aux_basis_filename ?(state=1) () =
let det_space =
DeterminantSpace.fci_of_mo_basis mo_basis ~frozen_core
let det_space =
DeterminantSpace.fci_of_mo_basis mo_basis ~frozen_core
in
let ci = CI.make ~n_states:state det_space in
@ -302,20 +122,21 @@ 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
in
let rec iteration ~state psi =
let rec iteration ~state psi =
(*
Format.printf "%a@." DeterminantSpace.pp_det_space @@ CI.det_space ci;
Format.printf "%a@." Matrix.pp_matrix @@ Matrix.dense_of_mat psi;
*)
let column_idx = iamax (Mat.to_col_vecs psi).(state-1) in
let delta =
let delta =
(* delta_i = {% $\sum_j c_j H_{ij}$ %} *)
dressing_vector ~frozen_core hf12_integrals psi ci
|> Matrix.to_mat
@ -339,7 +160,7 @@ Format.printf "%a@." Matrix.pp_matrix @@ Matrix.dense_of_mat psi;
delta.{column_idx,state} <- delta.{column_idx,state} -. delta_00;
let eigenvectors, eigenvalues =
let eigenvectors, eigenvalues =
let delta = lacpy delta in
Mat.scal f delta;
@ -357,8 +178,8 @@ Format.printf "%a@." Matrix.pp_matrix @@ Matrix.dense_of_mat psi;
)
in
let matrix_prod c =
let w =
let matrix_prod c =
let w =
Matrix.mm ~transa:`T m_H c
|> Matrix.to_mat
in
@ -382,7 +203,7 @@ Format.printf "%a@." Matrix.pp_matrix @@ Matrix.dense_of_mat psi;
))
in
let eigenvectors =
let eigenvectors =
Conventions.rephase @@ Util.remove_epsilons eigenvectors
in
@ -396,11 +217,11 @@ Format.printf "%a@." Matrix.pp_matrix @@ Matrix.dense_of_mat psi;
(Mat.to_col_vecs eigenvectors).(0) )
in
if Parallel.master then
Printf.printf "F12 Convergence : %e %f\n" conv (eigenvalues.{state}
Printf.printf "F12 Convergence : %e %f\n" conv (eigenvalues.{state}
+. Simulation.nuclear_repulsion simulation);
(*
let cabs_singles =
let cabs_singles =
let f =
Fock.make_rhf ~density ~ao_basis:large_ao_basis
in

993
MOBasis/HF12.ml
View File

File diff suppressed because it is too large Load Diff