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

Beryllium singlet/triplet ok

Browse Source
This commit is contained in:
Anthony Scemama 2019-08-17 11:36:59 +02:00
parent 8f9a28f340
commit 701ac05e23
1 changed files with 66 additions and 20 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

86
CI/F12CI.ml
View File

@ -26,20 +26,24 @@ let f12_integrals mo_basis =
begin
let ijkl = F12.get_phys two_e_ints i j k l
in
let ijlk = F12.get_phys two_e_ints i j l k
in
(*
if s' = Spin.other s then
(* Minus sign because we swap spin variables
instead of orbital variables *)
0.375 *. ijkl +. 0.125 *. ijlk
else
0.25 *. (ijkl -. ijlk)
*)
if s' = Spin.other s then
ijkl
else
let ijlk = F12.get_phys two_e_ints i j l k
in
ijkl -. ijlk
end
) )
let h_ij mo_basis ki kj =
let integrals =
List.map (fun f -> f mo_basis)
@ -57,10 +61,9 @@ let f_ij mo_basis ki kj =
CIMatrixElement.make integrals ki kj
|> List.hd
let hf_ij mo_basis ki kj =
(*
[ h_ij mo_basis ki kj ; f_ij mo_basis ki kj ]
*)
let integrals =
List.map (fun f -> f mo_basis)
[ CI.h_integrals ; f12_integrals ]
@ -77,13 +80,13 @@ let is_a_double det_space =
) (Bitstring.zero mo_num) l
in
let aux_mask = m (MOClass.auxiliary_mos mo_class) in
fun a ->
fun k ->
let alfa =
Determinant.alfa a
Determinant.alfa k
|> Spindeterminant.bitstring
in
let beta =
Determinant.beta a
Determinant.beta k
|> Spindeterminant.bitstring
in
let a = Bitstring.logand aux_mask alfa
@ -94,6 +97,43 @@ let is_a_double det_space =
| _ -> false
let p12 det_space =
let mo_class = DeterminantSpace.mo_class det_space in
let mo_num = Array.length @@ MOClass.mo_class_array mo_class in
let m l =
List.fold_left (fun accu i ->
let j = i-1 in Bitstring.logor accu (Bitstring.shift_left_one mo_num j)
) (Bitstring.zero mo_num) l
in
let aux_mask = m (MOClass.auxiliary_mos mo_class) in
let not_aux_mask =
Bitstring.(shift_left_one mo_num mo_num |> minus_one)
in
fun k ->
let alfa =
Determinant.alfa k
|> Spindeterminant.bitstring
in
let beta =
Determinant.beta k
|> Spindeterminant.bitstring
in
let a = Bitstring.logand aux_mask alfa
and b = Bitstring.logand aux_mask beta
in
match Bitstring.popcount a, Bitstring.popcount b with
| 2, 0
| 0, 2 -> Some (Determinant.negate_phase k)
| 1, 1 -> Some (Determinant.of_spindeterminants
(Spindeterminant.of_bitstring @@
Bitstring.(logor b (logand not_aux_mask alfa)) )
(Spindeterminant.of_bitstring @@
Bitstring.(logor a (logand not_aux_mask beta))
) )
| _ -> None
let dressing_vector ~frozen_core aux_basis f12_amplitudes ci =
if Parallel.master then
@ -117,12 +157,12 @@ let dressing_vector ~frozen_core aux_basis f12_amplitudes ci =
(* Select only doubly excited determinants wrt FCI space *)
Stream.from (fun _ ->
try
let p12 = p12 ci.CI.det_space in
let rec result () =
let ki = Stream.next s in
if not (is_a_double ci.CI.det_space ki) then
result ()
else
Some ki
match p12 ki with
| Some ki' -> Some (ki, ki')
| None -> result ()
in
result ()
with Stream.Failure -> None
@ -135,20 +175,26 @@ let dressing_vector ~frozen_core aux_basis f12_amplitudes ci =
| [] ->
List.rev accu_H,
List.rev accu_F
| ki :: rest ->
| (ki, ki') :: rest ->
begin
let h, f =
List.map (fun kj ->
match hf_ij aux_basis ki kj with
match hf_ij aux_basis kj ki with
| [ a ; b ] -> a, b
| _ -> assert false ) in_dets
|> List.split
in
let h =
Vec.of_list h
and f =
Vec.of_list f
let f' =
List.map (fun kj -> f_ij aux_basis kj ki') in_dets
in
let h = Vec.of_list h in
let f = Vec.of_list f in
let f' = Vec.of_list f' in
scal 0.375 f;
scal 0.125 f';
let f = Vec.add f f' in
col_vecs_list (h::accu_H) (f::accu_F) rest
end
in
let h, f =
col_vecs_list [] [] alpha_list