From 701ac05e2361196735cd419c8c8b129d1f3cd4ae Mon Sep 17 00:00:00 2001
From: Anthony Scemama <scemama@irsamc.ups-tlse.fr>
Date: Sat, 17 Aug 2019 11:36:59 +0200
Subject: [PATCH] Beryllium singlet/triplet ok

---
 CI/F12CI.ml | 86 ++++++++++++++++++++++++++++++++++++++++-------------
 1 file changed, 66 insertions(+), 20 deletions(-)

diff --git a/CI/F12CI.ml b/CI/F12CI.ml
index e179463..44db115 100644
--- a/CI/F12CI.ml
+++ b/CI/F12CI.ml
@@ -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