LCPQ/QCaml
10
1
Fork 0
mirror of https://gitlab.com/scemama/QCaml.git synced 2025-01-03 01:55:40 +01:00
Code Releases Activity

Initial new repo

Browse Source
This commit is contained in:
Anthony Scemama 2020-09-26 12:02:53 +02:00
parent c8b1170270
commit 58d4c2695a
259 changed files with 6030 additions and 119591 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

9
.gitignore vendored
View File

@ -1,5 +1,4 @@
_build/
Makefile
Parallel
*.byte
*.native
*~
_build
.merlin
*.install

7
.merlin
View File

@ -1,7 +0,0 @@
B _build/
B _build/**
S .
S ./**
FLG -w @a-4-29-40-41-42-44-45-48-58-59-60-40 -strict-sequence -strict-formats -short-paths -keep-locs
PKG str unix bigarray lacaml alcotest zarith getopt

25
.ocamlinit
View File

@ -1,25 +1,2 @@
let () =
try Topdirs.dir_directory (Sys.getenv "OCAML_TOPLEVEL_PATH")
with Not_found -> ()
;;
#use "topfind";;
#require "lacaml";;
#require "alcotest";;
#require "zarith";;
#require "getopt";;
#directory "_build";;
#directory "_build/Basis";;
#directory "_build/CI";;
#directory "_build/MOBasis";;
#directory "_build/Nuclei";;
#directory "_build/Parallel";;
#directory "_build/Perturbation";;
#directory "_build/SCF";;
#directory "_build/Utils";;
#load "Constants.cmo";;
#load_rec "Util.cma";;
open Printf;;

22
.ocp-indent Normal file
View File

@ -0,0 +1,22 @@
# See https://github.com/OCamlPro/ocp-indent/blob/master/.ocp-indent for more
# Indent for clauses inside a pattern-match (after the arrow):
# match foo with
# | _ ->
# ^^^^bar
# the default is 2, which aligns the pattern and the expression
match_clause = 4
# When nesting expressions on the same line, their indentation are in
# some cases stacked, so that it remains correct if you close them one
# at a line. This may lead to large indents in complex code though, so
# this parameter can be used to set a maximum value. Note that it only
# affects indentation after function arrows and opening parens at end
# of line.
#
# for example (left: `none`; right: `4`)
# let f = g (h (i (fun x -> # let f = g (h (i (fun x ->
# x) # x)
# ) # )
# ) # )
max_indent = 2

1
Basis/.merlin
View File

@ -1 +0,0 @@
REC

187
Basis/AOBasis.ml
View File

@ -1,187 +0,0 @@
open Lacaml.D
open Util
type t =
{
basis : Basis.t ;
overlap : Overlap.t lazy_t;
multipole : Multipole.t lazy_t;
ortho : Orthonormalization.t lazy_t;
eN_ints : NucInt.t lazy_t;
kin_ints : KinInt.t lazy_t;
ee_ints : ERI.t lazy_t;
ee_lr_ints : ERI_lr.t lazy_t;
f12_ints : F12.t lazy_t;
f12_over_r12_ints : ScreenedERI.t lazy_t;
cartesian : bool ;
}
let basis t = t.basis
let overlap t = Lazy.force t.overlap
let multipole t = Lazy.force t.multipole
let ortho t = Lazy.force t.ortho
let eN_ints t = Lazy.force t.eN_ints
let kin_ints t = Lazy.force t.kin_ints
let ee_ints t = Lazy.force t.ee_ints
let ee_lr_ints t = Lazy.force t.ee_lr_ints
let f12_ints t = Lazy.force t.f12_ints
let f12_over_r12_ints t = Lazy.force t.f12_over_r12_ints
let cartesian t = t.cartesian
module Cs = ContractedShell
let values t point =
let result = Vec.create (Basis.size t.basis) in
Array.iter (fun shell ->
Cs.values shell point
|> Array.iteri
(fun i_c value ->
let i = Cs.index shell + i_c + 1 in
result.{i} <- value)
) (Basis.contracted_shells t.basis);
result
let make ~cartesian ~basis ?f12 nuclei =
let overlap =
lazy (
Overlap.of_basis basis
) in
let ortho =
lazy (
Orthonormalization.make ~cartesian ~basis (Lazy.force overlap)
) in
let eN_ints =
lazy (
NucInt.of_basis_nuclei ~basis nuclei
) in
let kin_ints =
lazy (
KinInt.of_basis basis
) in
let ee_ints =
lazy (
ERI.of_basis basis
) in
let ee_lr_ints =
lazy (
ERI_lr.of_basis basis
) in
let f12_ints =
lazy (
F12.of_basis basis
) in
let f12_over_r12_ints =
lazy (
ScreenedERI.of_basis basis
) in
let multipole =
lazy (
Multipole.of_basis basis
) in
{ basis ; overlap ; multipole ; ortho ; eN_ints ; kin_ints ; ee_ints ;
ee_lr_ints ; f12_ints ; f12_over_r12_ints ; cartesian ;
}
let test_case name t =
let check_matrix title a r =
let a = Mat.to_array a in
Mat.to_array r
|> Array.iteri (fun i x ->
let message =
Printf.sprintf "%s line %d" title i
in
Alcotest.(check (array (float 1.e-10))) message a.(i) x
)
in
let check_eri a r =
let f { ERI.i_r1 ; j_r2 ; k_r1 ; l_r2 ; value } =
(i_r1, (j_r2, (k_r1, (l_r2, value))))
in
let a = ERI.to_list a |> List.rev_map f |> List.rev in
let r = ERI.to_list r |> List.rev_map f |> List.rev in
Alcotest.(check (list (pair int (pair int (pair int (pair int (float 1.e-10))))))) "ERI" a r
in
let check_eri_lr a r =
let f { ERI_lr.i_r1 ; j_r2 ; k_r1 ; l_r2 ; value } =
(i_r1, (j_r2, (k_r1, (l_r2, value))))
in
let a = ERI_lr.to_list a |> List.rev_map f |> List.rev in
let r = ERI_lr.to_list r |> List.rev_map f |> List.rev in
Alcotest.(check (list (pair int (pair int (pair int (pair int (float 1.e-10))))))) "ERI_lr" a r
in
let test_overlap () =
let reference =
sym_matrix_of_file ("test_files/"^name^"_overlap.ref")
in
let overlap =
Lazy.force t.overlap |> Overlap.matrix
in
check_matrix "Overlap" overlap reference
in
let test_eN_ints () =
let reference =
sym_matrix_of_file ("test_files/"^name^"_nuc.ref")
in
let eN_ints =
Lazy.force t.eN_ints |> NucInt.matrix
in
check_matrix "eN_ints" eN_ints reference
in
let test_kin_ints () =
let reference =
sym_matrix_of_file ("test_files/"^name^"_kin.ref")
in
let kin_ints =
Lazy.force t.kin_ints |> KinInt.matrix
in
check_matrix "kin_ints" kin_ints reference
in
let test_ee_ints () =
let reference =
ERI.of_file ("test_files/"^name^"_eri.ref") ~sparsity:`Dense ~size:(Basis.size t.basis)
in
let ee_ints =
Lazy.force t.ee_ints
in
check_eri ee_ints reference
;
in
let test_ee_lr_ints () =
let reference =
ERI_lr.of_file ("test_files/"^name^"_eri_lr.ref") ~sparsity:`Dense
~size:(Basis.size t.basis)
in
let ee_lr_ints =
Lazy.force t.ee_lr_ints
in
check_eri_lr ee_lr_ints reference
in
[
"Overlap", `Quick, test_overlap;
"eN_ints", `Quick, test_eN_ints;
"kin_ints", `Quick, test_kin_ints;
"ee_ints", `Quick, test_ee_ints;
"ee_lr_ints", `Quick, test_ee_lr_ints;
]

53
Basis/AOBasis.mli
View File

@ -1,53 +0,0 @@
(** Data structure for Atomic Orbitals. *)
open Lacaml.D
type t
(** {1 Accessors} *)
val basis : t -> Basis.t
(** One-electron basis set *)
val overlap : t -> Overlap.t
(** Overlap matrix *)
val multipole : t -> Multipole.t
(** Multipole matrices *)
val ortho : t -> Orthonormalization.t
(** Orthonormalization matrix of the overlap *)
val eN_ints : t -> NucInt.t
(** Electron-nucleus potential integrals *)
val ee_ints : t -> ERI.t
(** Electron-electron potential integrals *)
val ee_lr_ints : t -> ERI_lr.t
(** Electron-electron long-range potential integrals *)
val f12_ints : t -> F12.t
(** Electron-electron potential integrals *)
val kin_ints : t -> KinInt.t
(** Kinetic energy integrals *)
val cartesian : t -> bool
(** If true, use cartesian Gaussians (6d, 10f, ...) *)
val values : t -> Coordinate.t -> Vec.t
(** Values of the AOs evaluated at a given point *)
(** {1 Creators} *)
val make : cartesian:bool -> basis:Basis.t -> ?f12:F12factor.t -> Nuclei.t -> t
(** Creates the data structure for atomic orbitals from a {Basis.t} and the
molecular geometry {Nuclei.t} *)
(** {2 Tests} *)
val test_case : string -> t -> unit Alcotest.test_case list

55
Basis/ERI.ml
View File

@ -1,55 +0,0 @@
(** Electron-electron repulsion integrals *)
open Constants
open Util
module Csp = ContractedShellPair
module Cspc = ContractedShellPairCouple
module T = struct
let name = "Electron repulsion integrals"
open Zero_m_parameters
let zero_m z =
let expo_pq_inv = z.expo_p_inv +. z.expo_q_inv in
assert (expo_pq_inv <> 0.);
let expo_pq = 1. /. expo_pq_inv in
let t =
if z.norm_pq_sq > integrals_cutoff then
z.norm_pq_sq *. expo_pq
else 0.
in
let maxm = z.maxm in
let result = boys_function ~maxm t in
let rec aux accu k = function
| 0 -> result.(k) <- result.(k) *. accu
| l ->
begin
result.(k) <- result.(k) *. accu;
let new_accu = -. accu *. expo_pq in
(aux [@tailcall]) new_accu (k+1) (l-1)
end
in
let f = two_over_sq_pi *. (sqrt expo_pq) in
aux f 0 maxm;
result
let class_of_contracted_shell_pair_couple ~basis shell_pair_couple =
let shell_p = Cspc.shell_pair_p shell_pair_couple
and shell_q = Cspc.shell_pair_q shell_pair_couple
in
if Array.length (Csp.shell_pairs shell_p) +
(Array.length (Csp.shell_pairs shell_q)) < 4 then
TwoElectronRR.contracted_class_shell_pair_couple
~basis ~zero_m shell_pair_couple
else
TwoElectronRRVectorized.contracted_class_shell_pairs
~basis ~zero_m shell_p shell_q
end
module M = TwoElectronIntegrals.Make(T)
include M

64
Basis/ERI_lr.ml
View File

@ -1,64 +0,0 @@
(** Long-range electron-electron repulsion integrals.
See Eq(52) in 10.1039/b605188j
*)
open Constants
open Util
module Csp = ContractedShellPair
module Cspc = ContractedShellPairCouple
module T = struct
let name = "Long-range electron repulsion integrals"
open Zero_m_parameters
let zero_m z =
let mu_erf =
match Basis.range_separation z.basis with
| Some x -> x
| None -> invalid_arg "range_separation is None"
in
let m = mu_erf *. mu_erf in
let expo_pq_inv = z.expo_p_inv +. z.expo_q_inv in
let fG_inv = expo_pq_inv +. 1. /. m in
let fG = 1. /. fG_inv in
assert (expo_pq_inv <> 0.);
let t =
if z.norm_pq_sq > integrals_cutoff then
z.norm_pq_sq *. fG
else 0.
in
let maxm = z.maxm in
let result = boys_function ~maxm t in
let rec aux accu k = function
| 0 -> result.(k) <- result.(k) *. accu
| l ->
begin
result.(k) <- result.(k) *. accu;
let new_accu = -. accu *. fG in
(aux [@tailcall]) new_accu (k+1) (l-1)
end
in
let f = two_over_sq_pi *. (sqrt fG) in
aux f 0 maxm;
result
let class_of_contracted_shell_pair_couple ~basis shell_pair_couple =
let shell_p = Cspc.shell_pair_p shell_pair_couple
and shell_q = Cspc.shell_pair_q shell_pair_couple
in
if Array.length (Csp.shell_pairs shell_p) +
(Array.length (Csp.shell_pairs shell_q)) < 4 then
TwoElectronRR.contracted_class_shell_pair_couple
~basis ~zero_m shell_pair_couple
else
TwoElectronRRVectorized.contracted_class_shell_pairs
~basis ~zero_m shell_p shell_q
end
module M = TwoElectronIntegrals.Make(T)
include M

30
Basis/F12.ml
View File

@ -1,30 +0,0 @@
(** Two electron integral functor for operators that are separable among %{ $(x,y,z)$ %}.
It is parameterized by the [zero_m] function.
*)
open Constants
let cutoff = integrals_cutoff
module T = struct
let name = "F12"
let class_of_contracted_shell_pair_couple ~basis shell_pair_couple =
let f12 =
match Basis.f12 basis with
| Some f12 -> f12
| None -> invalid_arg "f12 factor should not be None"
in
let g = f12.F12factor.gaussian in
F12RR.contracted_class_shell_pair_couple ~basis
g.GaussianOperator.expo_g_inv
g.GaussianOperator.coef_g
shell_pair_couple
end
module M = TwoElectronIntegrals.Make(T)
include M

289
Basis/F12RR.ml
View File

@ -1,289 +0,0 @@
open Util
open Constants
module Am = AngularMomentum
module Asp = AtomicShellPair
module Aspc = AtomicShellPairCouple
module Co = Coordinate
module Cs = ContractedShell
module Csp = ContractedShellPair
module Cspc = ContractedShellPairCouple
module Po = Powers
module Psp = PrimitiveShellPair
module Pspc = PrimitiveShellPairCouple
module Ps = PrimitiveShell
let cutoff = Constants.integrals_cutoff
let cutoff2 = cutoff *. cutoff
exception NullQuartet
type four_idx_intermediates =
{
zero : float array array;
gp : float array;
gg : float array;
gq : float array;
coef_g : float array ;
center_ra : Co.t array ;
center_rc : Co.t array ;
center_ab : Co.t ;
center_cd : Co.t ;
}
(** Horizontal and Vertical Recurrence Relations (HVRR) *)
let rec hvrr angMom_a angMom_b angMom_c angMom_d
abcd map_x map_y map_z =
let gp = abcd.gp in
let gg = abcd.gg in
let gq = abcd.gq in
let coef_g = abcd.coef_g in
let run xyz map =
let zero =
match xyz with
| Co.X -> abcd.zero.(0)
| Co.Y -> abcd.zero.(1)
| Co.Z -> abcd.zero.(2)
in
let angMom_a = Po.get xyz angMom_a in
let angMom_b = Po.get xyz angMom_b in
let angMom_c = Po.get xyz angMom_c in
let angMom_d = Po.get xyz angMom_d in
let center_ab = Co.get xyz abcd.center_ab in
let center_cd = Co.get xyz abcd.center_cd in
let center_ra = Array.map (fun x -> Co.get xyz x) abcd.center_ra in
let center_rc = Array.map (fun x -> Co.get xyz x) abcd.center_rc in
let rec vrr angMom_a angMom_c =
match angMom_a, angMom_c with
| 0, -1
| -1, 0 -> assert false
| 0, 0 -> zero
| 1, 0 ->
let v1 = zero in
Array.mapi (fun i v1i -> center_ra.(i) *. v1i ) v1
| 0, 1 ->
let v1 = zero in
Array.mapi (fun i v1i -> center_rc.(i) *. v1i ) v1
| 1, 1 ->
let v1 = vrr 1 0 in
let v2 = zero in
Array.mapi (fun i v1i -> center_rc.(i) *. v1i +.
gg.(i) *. v2.(i) ) v1
| 2, 0 ->
let v1 = vrr 1 0 in
let v2 = zero in
Array.mapi (fun i v1i -> center_ra.(i) *. v1i +. gp.(i) *. v2.(i)) v1
| _, 0 ->
let v1 =
vrr (angMom_a-1) 0
in
let a = float_of_int_fast (angMom_a-1) in
let v2 =
vrr (angMom_a-2) 0
in
Array.mapi (fun i v1i -> center_ra.(i) *. v1i +. a *. gp.(i) *. v2.(i)) v1
| _, 1 ->
let v1 =
vrr angMom_a 0
in
let a = float_of_int_fast angMom_a in
let v2 =
vrr (angMom_a-1) 0
in
Array.mapi (fun i v1i -> center_rc.(i) *. v1i +.
a *. gg.(i) *. v2.(i) ) v1
| 0, _ ->
let v1 =
vrr 0 (angMom_c-1)
in
let b = float_of_int_fast (angMom_c-1) in
let v3 =
vrr 0 (angMom_c-2)
in
Array.mapi (fun i v1i -> center_rc.(i) *. v1i +.
b *. gq.(i) *. v3.(i)) v1
| _ ->
let v1 =
vrr angMom_a (angMom_c-1)
in
let a = float_of_int_fast angMom_a in
let b = float_of_int_fast (angMom_c-1) in
let v2 =
vrr (angMom_a-1) (angMom_c-1)
in
let v3 =
vrr angMom_a (angMom_c-2)
in
Array.mapi (fun i v1i -> center_rc.(i) *. v1i +.
a *. gg.(i) *. v2.(i) +. b *. gq.(i) *. v3.(i)) v1
in
let rec hrr angMom_a angMom_b angMom_c angMom_d =
let key = Zkey.of_int_four angMom_a angMom_b angMom_c angMom_d in
try Zmap.find map key with
| Not_found ->
let result =
match angMom_b, angMom_d with
| -1, 0
| 0, -1 -> assert false
| 0, 0 ->
vrr angMom_a angMom_c
| _, 0 ->
let h1 =
hrr (angMom_a+1) (angMom_b-1) angMom_c angMom_d
in
if center_ab = 0. then
h1
else
let h2 =
hrr angMom_a (angMom_b-1) angMom_c angMom_d
in
Array.mapi (fun i h1i -> h1i +. center_ab *. h2.(i)) h1
| _ ->
let h1 =
hrr angMom_a angMom_b (angMom_c+1) (angMom_d-1)
in
if center_cd = 0. then
h1
else
let h2 =
hrr angMom_a angMom_b angMom_c (angMom_d-1)
in
Array.mapi (fun i h1i -> h1i +. center_cd *. h2.(i)) h1
in (Zmap.add map key result; result)
in
hrr angMom_a angMom_b angMom_c angMom_d
in
let x, y, z =
(run Co.X map_x), (run Co.Y map_y), (run Co.Z map_z)
in
let rec aux accu = function
| 0 -> accu +. coef_g.(0) *. x.(0) *. y.(0) *. z.(0)
| i -> (aux [@tailcall]) (accu +. coef_g.(i) *. x.(i) *. y.(i) *. z.(i)) (i-1)
in
aux 0. (Array.length x - 1)
let contracted_class_shell_pair_couple ~basis expo_g_inv coef_g shell_pair_couple : float Zmap.t =
(* Pre-computation of integral class indices *)
let class_indices = Cspc.zkey_array shell_pair_couple in
let contracted_class =
Array.make (Array.length class_indices) 0.;
in
(* Compute all integrals in the shell for each pair of significant shell pairs *)
let shell_p = Cspc.shell_pair_p shell_pair_couple
and shell_q = Cspc.shell_pair_q shell_pair_couple
in
let center_ab = Csp.a_minus_b shell_p
and center_cd = Csp.a_minus_b shell_q
in
let norm_scales = Cspc.norm_scales shell_pair_couple in
List.iter (fun (coef_prod, spc) ->
let sp_ab = Pspc.shell_pair_p spc
and sp_cd = Pspc.shell_pair_q spc
in
let expo_p_inv = Psp.exponent_inv sp_ab in
let expo_q_inv = Psp.exponent_inv sp_cd in
let expo_pgq = Array.map (fun e ->
1. /. (expo_p_inv +. expo_q_inv +. e)
) expo_g_inv
in
let fp = Array.map (fun e -> expo_p_inv *. e) expo_pgq in
let fq = Array.map (fun e -> expo_q_inv *. e) expo_pgq in
let gp =
let x = 0.5 *. expo_p_inv in
Array.map (fun f -> (1. -. f) *. x) fp
in
let gq =
let x = 0.5 *. expo_q_inv in
Array.map (fun f -> (1. -. f) *. x) fq
in
let gg =
let x = 0.5 *. expo_q_inv in
Array.map (fun f -> f *. x) fp
in
let center_pq = Co.(Psp.center sp_ab |- Psp.center sp_cd) in
let center_qc = Psp.center_minus_a sp_cd in
let center_pa = Psp.center_minus_a sp_ab in
let center_ra = Array.map (fun f -> Co.(center_pa |- (f |. center_pq))) fp in
let center_rc = Array.map (fun f -> Co.(center_qc |+ (f |. center_pq))) fq in
(* zero_m is defined here *)
let zero = Array.map (fun xyz ->
let x = Co.get xyz center_pq in
Array.mapi (fun i ei ->
let fg = expo_g_inv.(i) *. ei in
(sqrt fg) *. exp (-. x *. x *. ei )) expo_pgq
) Co.[| X ; Y ; Z |]
in
begin
match Cspc.ang_mom shell_pair_couple with
(*
| Am.S ->
let integral =
zero.(0) *. zero.(1) *. zero.(2)
in
contracted_class.(0) <- contracted_class.(0) +. coef_prod *. integral
*)
| _ ->
let map_x, map_y, map_z =
Zmap.create (Array.length class_indices),
Zmap.create (Array.length class_indices),
Zmap.create (Array.length class_indices)
in
(* Compute the integral class from the primitive shell quartet *)
class_indices
|> Array.iteri (fun i key ->
let (angMom_a,angMom_b,angMom_c,angMom_d) =
match Zkey.to_powers key with
| Zkey.Twelve x -> x
| _ -> assert false
in
let norm = norm_scales.(i) in
let coef_prod = coef_prod *. norm in
let abcd = {
zero ; gp ; gg ; gq ;
center_ab ; center_cd ;
center_ra ; center_rc ;
coef_g ;
} in
let integral =
hvrr
angMom_a angMom_b angMom_c angMom_d
abcd map_x map_y map_z
in
contracted_class.(i) <- contracted_class.(i) +. coef_prod *. integral
)
end
) (Cspc.coefs_and_shell_pair_couples shell_pair_couple);
let result =
Zmap.create (Array.length contracted_class)
in
Array.iteri (fun i key -> Zmap.add result key contracted_class.(i)) class_indices;
result

78
Basis/F12factor.ml
View File

@ -1,78 +0,0 @@
(** Type for f12 correlation factors *)
open Constants
type t =
{
expo_s : float ;
gaussian : GaussianOperator.t
}
let make_gaussian_corr_factor expo_s coef_g expo_sg =
let expo_sg =
Array.map (fun x -> x *. expo_s *. expo_s) expo_sg
in
let gaussian = GaussianOperator.make coef_g expo_sg in
{ expo_s ; gaussian }
(* -1/expo_s *. exp (-expo_s r) *)
let gaussian_geminal expo_s =
let coef_g =
[| 0.3144 ; 0.3037 ; 0.1681 ; 0.09811 ; 0.06024 ; 0.03726 |]
|> Array.map (fun x -> -. x /. expo_s)
and expo_sg =
[| 0.2209 ; 1.004 ; 3.622 ; 12.16 ; 45.87 ; 254.4 |]
in
make_gaussian_corr_factor expo_s coef_g expo_sg
(* exp (-expo_s r) *)
let simple_gaussian_geminal expo_s =
let coef_g =
[| 0.3144 ; 0.3037 ; 0.1681 ; 0.09811 ; 0.06024 ; 0.03726 |]
and expo_sg =
[| 0.2209 ; 1.004 ; 3.622 ; 12.16 ; 45.87 ; 254.4 |]
in
make_gaussian_corr_factor expo_s coef_g expo_sg
(** r12 * exp ( -expo_s * r) *)
let gaussian_geminal_times_r12 expo_s =
let coef_g =
[| 0.2454 ; 0.2938 ; 0.1815 ; 0.11281 ; 0.07502 ; 0.05280 |]
and expo_sg =
[| 0.1824 ; 0.7118; 2.252 ; 6.474 ; 19.66 ; 77.92 |]
in make_gaussian_corr_factor expo_s coef_g expo_sg
(* exp (-expo_s r) *)
let simple_gaussian_geminal' expo_s =
let coef_g =
[|
-3.4793465193721626604883567779324948787689208984375 ;
-0.00571703486454788484955047422886309504974633455276489257812 ;
4.14878218728681513738365538301877677440643310546875 ;
0.202874298181392742623785352407139725983142852783203125 ;
0.0819187742387294803858566183407674543559551239013671875 ;
0.04225945671351955673644695821167260874062776565551757812 ;
|]
and expo_sg =
[|
0.63172472556807146570889699432882480323314666748046875;
26.3759196683467962429858744144439697265625;
0.63172102793029016876147352377302013337612152099609375;
7.08429025944207335641067402320913970470428466796875;
42.4442841447001910637482069432735443115234375;
391.44036073596890901171718724071979522705078125 ;
|]
in make_gaussian_corr_factor expo_s coef_g expo_sg

17
Basis/GamessReader.ml
View File

@ -1,17 +0,0 @@
(** Reads a basis set in GAMESS format *)
let read_basis filename =
let lexbuf =
let ic = open_in filename in
Lexing.from_channel ic
in
let rec aux accu =
try
let key, basis =
GamessParser.input BasisLexer.read_all lexbuf
in
aux ((key, basis)::accu)
with
| Parsing.Parse_error -> List.rev accu
in
aux []

39
Basis/GaussianOperator.ml
View File

@ -1,39 +0,0 @@
(** Representation for two-electron operators expressed in a Gaussian basis set. *)
open Constants
type t =
{
coef_g : float array;
expo_g : float array;
expo_g_inv : float array;
}
let make coef_g expo_g =
let expo_g_inv =
Array.map (fun x -> 1. /. x ) expo_g
in
{ coef_g ; expo_g ; expo_g_inv }
let one_over_r =
let coef_g = [|
841.88478132 ; 70.590185207 ; 18.3616020768 ; 7.2608642093 ;
3.57483416444 ; 2.01376031082 ; 1.24216542801 ; 0.81754348620 ;
0.564546514023 ; 0.404228610699 ; 0.297458536575 ; 0.223321219537 ;
0.169933732064 ; 0.130190978230 ; 0.099652303426 ; 0.075428246546 ;
0.0555635614051 ; 0.0386791283055 ; 0.0237550435652 ; 0.010006278387 ;
|]
and expo_g =
[| 84135.654509 ; 2971.58727634 ; 474.716025959 ; 130.676724560 ;
47.3938388887 ; 20.2078651631 ; 9.5411021938 ; 4.8109546955 ;
2.52795733067 ; 1.35894103210 ; 0.73586710268 ; 0.39557629706 ;
0.20785895177 ; 0.104809693858 ; 0.049485682527 ; 0.021099788990 ;
0.007652472186 ; 0.0021065225215 ; 0.0003365204879 ; 0.0000118855674 |]
in make coef_g expo_g

68
Basis/Orthonormalization.ml
View File

@ -1,68 +0,0 @@
open Util
open Lacaml.D
type t = Mat.t
module Am = AngularMomentum
module Bs = Basis
module Cs = ContractedShell
module Ov = Overlap
let make_canonical ~thresh ~basis ~cartesian ~overlap =
let overlap_matrix = Ov.matrix overlap in
let make_canonical_spherical basis =
let ao_num = Bs.size basis in
let cart_sphe = Mat.make ao_num ao_num 0.
and i = ref 0
and n = ref 0 in
Array.iter (fun shell ->
let submatrix =
SphericalToCartesian.matrix (Cs.ang_mom shell)
in
ignore @@ lacpy ~b:cart_sphe ~br:(!i+1) ~bc:(!n+1) submatrix;
i := !i + Mat.dim1 submatrix;
n := !n + Mat.dim2 submatrix;
) (Bs.contracted_shells basis);
let s = gemm ~transa:`T ~m:!n cart_sphe overlap_matrix in
let overlap_matrix = gemm s ~n:!n cart_sphe in
let s = canonical_ortho ~thresh ~overlap:overlap_matrix (Mat.identity !n) in
gemm cart_sphe ~k:!n s
in
if cartesian then
canonical_ortho ~thresh ~overlap:overlap_matrix (Mat.identity @@ Mat.dim1 overlap_matrix)
else
match basis with
| None -> invalid_arg
"Basis.t is required when cartesian=false in make_canonical"
| Some basis -> make_canonical_spherical basis
let make_lowdin ~thresh ~overlap =
let overlap_matrix = Ov.matrix overlap in
let u_vec, u_val = diagonalize_symm overlap_matrix in
Vec.iter (fun x -> if x < thresh then
invalid_arg (__FILE__^": make_lowdin") ) u_val;
let u_val = Vec.reci (Vec.sqrt u_val) in
let u_vec' =
Mat.init_cols (Mat.dim1 u_vec) (Mat.dim2 u_vec) (fun i j -> u_vec.{i,j} *. u_val.{j})
in
gemm u_vec' ~transb:`T u_vec
let make ?(thresh=1.e-12) ?basis ~cartesian overlap =
(*
make_lowdin ~thresh ~overlap
*)
make_canonical ~thresh ~basis ~cartesian ~overlap

95
Basis/ScreenedERI.ml
View File

@ -1,95 +0,0 @@
(** Screened Electron-electron repulsion integrals (Yukawa potential). Required for F12/r12. *)
open Constants
open Util
module Csp = ContractedShellPair
module Cspc = ContractedShellPairCouple
module T = struct
let name = "Screened electron repulsion integrals"
let f12_factor = F12factor.gaussian_geminal 1.0
open Zero_m_parameters
let zero_m z =
let expo_pq_inv = z.expo_p_inv +. z.expo_q_inv in
assert (expo_pq_inv <> 0.);
(*
let f12_factor =
match z.f12_factor with
| Some f -> f
| None -> assert false
in
*)
let expo_G_inv, coef_G =
f12_factor.F12factor.gaussian.GaussianOperator.expo_g_inv,
f12_factor.F12factor.gaussian.GaussianOperator.coef_g
in
let expo_pq = 1. /. expo_pq_inv in
let maxm = z.maxm in
let result = Array.init (maxm+1) (fun _ -> 0.) in
array_range 0 (Array.length coef_G)
|> Array.iter (fun i ->
let fG_inv = expo_pq_inv +. expo_G_inv.(i) in
let fG = 1. /. fG_inv in
let t =
if z.norm_pq_sq > integrals_cutoff then
z.norm_pq_sq *. (expo_pq -. fG)
else 0.
in
let fm = boys_function ~maxm t in
let tmp_array =
let result = Array.init (maxm+1) (fun k -> 1.) in
array_range 1 maxm
|> Array.iter (fun k -> result.(k) <- result.(k-1) *. expo_pq *. expo_G_inv.(i));
result
in
let tmp_result = Array.init (maxm+1) (fun _ -> 0.) in
let rec aux accu m = function
| 0 -> tmp_result.(m) <- fm.(m) *. accu
| j ->
begin
let f =
array_range 0 m
|> Array.fold_left (fun v k ->
v +. (binom_float m k) *. tmp_array.(k) *. fm.(k)) 0.
in
tmp_result.(m) <- accu *. f;
let new_accu = -. accu *. expo_pq in
(aux [@tailcall]) new_accu (m+1) (j-1)
end
in
let f =
two_over_sq_pi *. (sqrt expo_pq) *. fG *. expo_G_inv.(i) *. exp (-.fG *. z.norm_pq_sq)
in
aux f 0 maxm;
Array.iteri (fun k v ->
result.(k) <- result.(k) +. coef_G.(i) *. v
) tmp_result) ;
result
let class_of_contracted_shell_pair_couple ~basis shell_pair_couple =
let shell_p = Cspc.shell_pair_p shell_pair_couple
and shell_q = Cspc.shell_pair_q shell_pair_couple
in
if Array.length (Csp.shell_pairs shell_p) +
(Array.length (Csp.shell_pairs shell_q)) < 4 then
TwoElectronRR.contracted_class_shell_pair_couple
~basis ~zero_m shell_pair_couple
else
TwoElectronRRVectorized.contracted_class_shell_pairs
~basis ~zero_m shell_p shell_q
end
module M = TwoElectronIntegrals.Make(T)
include M

296
Basis/TwoElectronIntegrals.ml
View File

@ -1,296 +0,0 @@
(** Two electron integrals
*)
open Constants
let cutoff = integrals_cutoff
module Bs = Basis
module Cs = ContractedShell
module Csp = ContractedShellPair
module Cspc = ContractedShellPairCouple
module Fis = FourIdxStorage
module type TwoEI_structure =
sig
val name : string
val class_of_contracted_shell_pair_couple :
basis:Basis.t -> ContractedShellPairCouple.t -> float Zmap.t
end
module Make(T : TwoEI_structure) = struct
include FourIdxStorage
let class_of_contracted_shell_pair_couple = T.class_of_contracted_shell_pair_couple
(*
let filter_contracted_shell_pairs ?(cutoff=integrals_cutoff) ~basis shell_pairs =
List.rev_map (fun pair ->
match Cspc.make ~cutoff pair pair with
| Some cspc ->
let cls = class_of_contracted_shell_pair_couple ~basis cspc in
(pair, Zmap.fold (fun _key value accu -> max (abs_float value) accu) cls 0. )
(* TODO \sum_k |coef_k * integral_k| *)
| None -> (pair, -1.)
) shell_pairs
|> List.filter (fun (_, schwartz_p_max) -> schwartz_p_max >= cutoff)
|> List.rev_map fst
*)
(* TODO
let filter_contracted_shell_pair_couples
?(cutoff=integrals_cutoff) shell_pair_couples =
List.rev_map (fun pair ->
let cls =
class_of_contracted_shell_pairs pair pair
in
(pair, Zmap.fold (fun key value accu -> max (abs_float value) accu) cls 0. )
) shell_pairs
|> List.filter (fun (_, schwartz_p_max) -> schwartz_p_max >= cutoff)
|> List.rev_map fst
*)
let store_class ?(cutoff=integrals_cutoff) data contracted_shell_pair_couple cls =
let to_powers x =
let open Zkey in
match to_powers x with
| Three x -> x
| _ -> assert false
in
let shell_p = Cspc.shell_pair_p contracted_shell_pair_couple
and shell_q = Cspc.shell_pair_q contracted_shell_pair_couple
in
Array.iteri (fun i_c powers_i ->
let i_c = Cs.index (Csp.shell_a shell_p) + i_c + 1 in
let xi = to_powers powers_i in
Array.iteri (fun j_c powers_j ->
let j_c = Cs.index (Csp.shell_b shell_p) + j_c + 1 in
let xj = to_powers powers_j in
Array.iteri (fun k_c powers_k ->
let k_c = Cs.index (Csp.shell_a shell_q) + k_c + 1 in
let xk = to_powers powers_k in
Array.iteri (fun l_c powers_l ->
let l_c = Cs.index (Csp.shell_b shell_q) + l_c + 1 in
let xl = to_powers powers_l in
let key = Zkey.of_powers_twelve xi xj xk xl in
let value = Zmap.find cls key in
set_chem data i_c j_c k_c l_c value
) (Cs.zkey_array (Csp.shell_b shell_q))
) (Cs.zkey_array (Csp.shell_a shell_q))
) (Cs.zkey_array (Csp.shell_b shell_p))
) (Cs.zkey_array (Csp.shell_a shell_p))
let of_basis_serial basis =
let n = Bs.size basis
and shell = Bs.contracted_shells basis
in
let eri_array =
Fis.create ~size:n `Dense
(*
Fis.create ~size:n `Sparse
*)
in
let t0 = Unix.gettimeofday () in
let shell_pairs =
Csp.of_contracted_shell_array shell
in
Printf.printf "%d significant shell pairs computed in %f seconds\n"
(List.length shell_pairs) (Unix.gettimeofday () -. t0);
let t0 = Unix.gettimeofday () in
let ishell = ref 0 in
List.iter (fun shell_p ->
let () =
if (Cs.index (Csp.shell_a shell_p) > !ishell) then
(ishell := Cs.index (Csp.shell_a shell_p) ; print_int !ishell ; print_newline ())
in
let sp =
Csp.shell_pairs shell_p
in
try
List.iter (fun shell_q ->
let () =
if Cs.index (Csp.shell_a shell_q) >
Cs.index (Csp.shell_a shell_p) then
raise Exit
in
let sq = Csp.shell_pairs shell_q in
let cspc =
if Array.length sp < Array.length sq then
Cspc.make ~cutoff shell_p shell_q
else
Cspc.make ~cutoff shell_q shell_p
in
match cspc with
| Some cspc ->
let cls =
class_of_contracted_shell_pair_couple ~basis cspc
in
store_class ~cutoff eri_array cspc cls
| None -> ()
) shell_pairs
with Exit -> ()
) shell_pairs ;
Printf.printf "Computed ERIs in %f seconds\n%!" (Unix.gettimeofday () -. t0);
eri_array
(* Parallel functions *)
let of_basis_parallel basis =
let n = Bs.size basis
and shell = Bs.contracted_shells basis
in
let store_class_parallel
?(cutoff=integrals_cutoff) contracted_shell_pair_couple cls =
let to_powers x =
let open Zkey in
match to_powers x with
| Three x -> x
| _ -> assert false
in
let shell_p = Cspc.shell_pair_p contracted_shell_pair_couple
and shell_q = Cspc.shell_pair_q contracted_shell_pair_couple
in
let result = ref [] in
Array.iteri (fun i_c powers_i ->
let i_c = Cs.index (Csp.shell_a shell_p) + i_c + 1 in
let xi = to_powers powers_i in
Array.iteri (fun j_c powers_j ->
let j_c = Cs.index (Csp.shell_b shell_p) + j_c + 1 in
let xj = to_powers powers_j in
Array.iteri (fun k_c powers_k ->
let k_c = Cs.index (Csp.shell_a shell_q) + k_c + 1 in
let xk = to_powers powers_k in
Array.iteri (fun l_c powers_l ->
let l_c = Cs.index (Csp.shell_b shell_q) + l_c + 1 in
let xl = to_powers powers_l in
let key = Zkey.of_powers_twelve xi xj xk xl in
let value = Zmap.find cls key in
result := (i_c, j_c, k_c, l_c, value) :: !result
) (Cs.zkey_array (Csp.shell_b shell_q))
) (Cs.zkey_array (Csp.shell_a shell_q))
) (Cs.zkey_array (Csp.shell_b shell_p))
) (Cs.zkey_array (Csp.shell_a shell_p));
!result
in
let t0 = Unix.gettimeofday () in
let shell_pairs =
Csp.of_contracted_shell_array shell
in
if Parallel.master then
Printf.printf "%d significant shell pairs computed in %f seconds\n"
(List.length shell_pairs) (Unix.gettimeofday () -. t0);
let t0 = Unix.gettimeofday () in
let ishell = ref max_int in
let input_stream = Stream.of_list shell_pairs in
let f shell_p =
let () =
if Parallel.rank < 2 && Cs.index (Csp.shell_a shell_p) < !ishell then
(ishell := Cs.index (Csp.shell_a shell_p) ; print_int !ishell ; print_newline ())
in
let sp =
Csp.shell_pairs shell_p
in
let result = ref [] in
let () =
try
List.iter (fun shell_q ->
let () =
if Cs.index (Csp.shell_a shell_q) >
Cs.index (Csp.shell_a shell_p) then
raise Exit
in
let sq = Csp.shell_pairs shell_q in
let cspc =
if Array.length sp < Array.length sq then
Cspc.make ~cutoff shell_p shell_q
else
Cspc.make ~cutoff shell_q shell_p
in
match cspc with
| Some cspc ->
let cls =
class_of_contracted_shell_pair_couple ~basis cspc
in
result := (store_class_parallel ~cutoff cspc cls) :: !result;
| None -> ()
) shell_pairs;
with Exit -> ()
in
List.concat !result |> Array.of_list
in
let eri_array =
if Parallel.master then
Fis.create ~size:n `Dense
else
Fis.create ~size:n `Dense
in
Farm.run ~ordered:true ~f input_stream
|> Stream.iter (fun l ->
Array.iter (fun (i_c,j_c,k_c,l_c,value) ->
set_chem eri_array i_c j_c k_c l_c value) l);
if Parallel.master then
Printf.printf
"Computed %s Integrals in parallel in %f seconds\n%!" T.name (Unix.gettimeofday () -. t0);
Fis.broadcast eri_array
let of_basis =
match Parallel.size with
| 1 -> of_basis_serial
| _ -> of_basis_parallel
end

38
Basis/TwoElectronIntegrals.mli
View File

@ -1,38 +0,0 @@
(** Two-electron integrals with an arbitrary operator, with a functorial interface
parameterized by the fundamental two-electron integrals.
{% $(00|00)^m = \int \int \phi_p(r1) \hat{O} \phi_q(r2) dr_1 dr_2 $ %} : Fundamental two-electron integral
*)
module type TwoEI_structure =
sig
val name : string
(** Name of the kind of integrals, for printing purposes. *)
val class_of_contracted_shell_pair_couple :
basis:Basis.t -> ContractedShellPairCouple.t -> float Zmap.t
(** Returns an integral class from a couple of contracted shells.
The results is stored in a Zmap.
*)
end
module Make : functor (T : TwoEI_structure) ->
sig
include module type of FourIdxStorage
(*
val filter_contracted_shell_pairs :
?cutoff:float -> basis:Basis.t ->
ContractedShellPair.t list -> ContractedShellPair.t list
(** Uses Schwartz screening on contracted shell pairs. *)
*)
val of_basis : Basis.t -> t
(** Compute all ERI's for a given {!Basis.t}. *)
end

522
Basis/TwoElectronRR.ml
View File

@ -1,522 +0,0 @@
open Util
module Am = AngularMomentum
module Asp = AtomicShellPair
module Aspc = AtomicShellPairCouple
module Co = Coordinate
module Cs = ContractedShell
module Csp = ContractedShellPair
module Cspc = ContractedShellPairCouple
module Po = Powers
module Psp = PrimitiveShellPair
module Pspc = PrimitiveShellPairCouple
module Ps = PrimitiveShell
module Zp = Zero_m_parameters
let cutoff = Constants.integrals_cutoff
let cutoff2 = cutoff *. cutoff
exception NullQuartet
type four_idx_intermediates =
{
expo_b : float ;
expo_d : float ;
expo_p_inv : float ;
expo_q_inv : float ;
center_ab : Co.t ;
center_cd : Co.t ;
center_pq : Co.t ;
center_pa : Co.t ;
center_qc : Co.t ;
zero_m_array : float array ;
}
(** Horizontal and Vertical Recurrence Relations (HVRR) *)
let rec hvrr_two_e
angMom_a angMom_b angMom_c angMom_d
abcd map_1d map_2d =
(* Swap electrons 1 and 2 so that the max angular momentum is on 1 *)
if angMom_a.Po.tot + angMom_b.Po.tot < angMom_c.Po.tot + angMom_d.Po.tot then
let abcd = {
expo_b = abcd.expo_d ;
expo_d = abcd.expo_b ;
expo_p_inv = abcd.expo_q_inv ;
expo_q_inv = abcd.expo_p_inv ;
center_ab = abcd.center_cd ;
center_cd = abcd.center_ab ;
center_pq = Co.neg abcd.center_pq ;
center_pa = abcd.center_qc ;
center_qc = abcd.center_pa ;
zero_m_array = abcd.zero_m_array ;
} in
hvrr_two_e
angMom_c angMom_d angMom_a angMom_b
abcd map_1d map_2d
else
let maxm = angMom_a.Po.tot + angMom_b.Po.tot + angMom_c.Po.tot + angMom_d.Po.tot in
let maxsze = maxm+1 in
let get_xyz angMom =
match angMom with
| { Po.y=0 ; z=0 ; _ } -> Co.X
| { z=0 ; _ } -> Co.Y
| _ -> Co.Z
in
let expo_p_inv = abcd.expo_p_inv
and expo_q_inv = abcd.expo_q_inv
and center_ab = abcd.center_ab
and center_cd = abcd.center_cd
and center_pq = abcd.center_pq
in
(** Vertical recurrence relations *)
let rec vrr0 angMom_a =
match angMom_a.Po.tot with
| 0 -> abcd.zero_m_array
| _ ->
let key = Zkey.of_powers_three angMom_a in
try Zmap.find map_1d key with
| Not_found ->
let result =
let xyz = get_xyz angMom_a in
let am = Po.decr xyz angMom_a in
let amxyz = Po.get xyz am in
let f1 = expo_p_inv *. Co.get xyz center_pq
and f2 = abcd.expo_b *. expo_p_inv *. Co.get xyz center_ab
in
let result = Array.create_float (maxsze - angMom_a.Po.tot) in
if amxyz = 0 then
begin
let v1 = vrr0 am in
Array.iteri (fun m _ ->
result.(m) <- f1 *. v1.(m+1) -. f2 *. v1.(m)) result
end
else
begin
let amm = Po.decr xyz am in
let v3 = vrr0 amm in
let v1 = vrr0 am in
let f3 = (float_of_int_fast amxyz) *. expo_p_inv *. 0.5 in
Array.iteri (fun m _ ->
result.(m) <- f1 *. v1.(m+1) -. f2 *. v1.(m)
+. f3 *. (v3.(m) +. expo_p_inv *. v3.(m+1)) ) result
end;
result
in Zmap.add map_1d key result;
result
and vrr angMom_a angMom_c =
match angMom_a.Po.tot, angMom_c.Po.tot with
| (i,0) -> if (i>0) then vrr0 angMom_a
else abcd.zero_m_array
| (_,_) ->
let key = Zkey.of_powers_six angMom_a angMom_c in
try Zmap.find map_2d key with
| Not_found ->
let result =
(* angMom_c.Po.tot > 0 so cm.Po.tot >= 0 *)
let xyz = get_xyz angMom_c in
let cm = Po.decr xyz angMom_c in
let cmxyz = Po.get xyz cm in
let axyz = Po.get xyz angMom_a in
let f1 =
-. abcd.expo_d *. expo_q_inv *. Co.get xyz center_cd
and f2 =
expo_q_inv *. Co.get xyz center_pq
in
let result = Array.make (maxsze - angMom_a.Po.tot - angMom_c.Po.tot) 0. in
if axyz > 0 then
begin
let am = Po.decr xyz angMom_a in
let f5 =
(float_of_int_fast axyz) *. expo_p_inv *. expo_q_inv *. 0.5
in
if (abs_float f5 > cutoff) then
let v5 =
vrr am cm
in
Array.iteri (fun m _ ->
result.(m) <- result.(m) -. f5 *. v5.(m+1)) result
end;
if cmxyz > 0 then
begin
let f3 =
(float_of_int_fast cmxyz) *. expo_q_inv *. 0.5
in
if (abs_float f3 > cutoff) ||
(abs_float (f3 *. expo_q_inv) > cutoff) then
begin
let v3 =
let cmm = Po.decr xyz cm in
vrr angMom_a cmm
in
Array.iteri (fun m _ ->
result.(m) <- result.(m) +.
f3 *. (v3.(m) +. expo_q_inv *. v3.(m+1)) ) result
end
end;
if ( (abs_float f1 > cutoff) || (abs_float f2 > cutoff) ) then
begin
let v1 =
vrr angMom_a cm
in
Array.iteri (fun m _ ->
result.(m) <- result.(m) +. f1 *. v1.(m) -. f2 *. v1.(m+1) ) result
end;
result
in Zmap.add map_2d key result;
result
(*
and trr angMom_a angMom_c =
match (angMom_a.Po.tot, angMom_c.Po.tot) with
| (i,0) -> if (i>0) then (vrr0 angMom_a).(0)
else abcd.zero_m_array.(0)
| (_,_) ->
let key = Zkey.of_powers_six angMom_a angMom_c in
try (Zmap.find map_2d key).(0) with
| Not_found ->
let result =
let xyz = get_xyz angMom_c in
let axyz = Po.get xyz angMom_a in
let cm = Po.decr xyz angMom_c in
let cmxyz = Po.get xyz cm in
let expo_inv_q_over_p = expo_q_inv /. expo_p_inv in
let f =
Co.get xyz center_qc +. expo_inv_q_over_p *.
Co.get xyz center_pa
in
let result = 0. in
let result =
if cmxyz < 1 then result else
let f = 0.5 *. (float_of_int_fast cmxyz) *. expo_q_inv in
if abs_float f < cutoff then 0. else
let cmm = Po.decr xyz cm in
let v3 = trr angMom_a cmm in
result +. f *. v3
in
let result =
if abs_float f < cutoff then result else
let v1 = trr angMom_a cm in
result +. f *. v1
in
let result =
if cmxyz < 0 then result else
let f = -. expo_inv_q_over_p in
let ap = Po.incr xyz angMom_a in
let v4 = trr ap cm in
result +. v4 *. f
in
let result =
if axyz < 1 then result else
let f = 0.5 *. (float_of_int_fast axyz) *. expo_q_inv in
if abs_float f < cutoff then result else
let am = Po.decr xyz angMom_a in
let v2 = trr am cm in
result +. f *. v2
in
result
in
Zmap.add map_2d key [|result|];
result
*)
in
let vrr a c =
(vrr a c).(0)
(*
if maxm < 10 then (vrr a c).(0) else trr a c
*)
in
(** Horizontal recurrence relations *)
let rec hrr0 angMom_a angMom_b angMom_c =
match angMom_b.Po.tot with
| 1 ->
let xyz = get_xyz angMom_b in
let ap = Po.incr xyz angMom_a in
let v1 = vrr ap angMom_c in
let f2 = Co.get xyz center_ab in
if (abs_float f2 < cutoff) then v1 else
let v2 = vrr angMom_a angMom_c in
v1 +. f2 *. v2
| 0 -> vrr angMom_a angMom_c
| _ ->
let xyz = get_xyz angMom_b in
let bxyz = Po.get xyz angMom_b in
if bxyz > 0 then
let ap = Po.incr xyz angMom_a in
let bm = Po.decr xyz angMom_b in
let h1 = hrr0 ap bm angMom_c in
let f2 = Co.get xyz center_ab in
if abs_float f2 < cutoff then h1 else
let h2 = hrr0 angMom_a bm angMom_c in
h1 +. f2 *. h2
else 0.
and hrr angMom_a angMom_b angMom_c angMom_d =
match (angMom_b.Po.tot, angMom_d.Po.tot) with
| (_,0) ->
if (angMom_b.Po.tot = 0) then
vrr angMom_a angMom_c
else
hrr0 angMom_a angMom_b angMom_c
| (_,_) ->
let xyz = get_xyz angMom_d in
let cp = Po.incr xyz angMom_c in
let dm = Po.decr xyz angMom_d in
let h1 = hrr angMom_a angMom_b cp dm in
let f2 = Co.get xyz center_cd in
if abs_float f2 < cutoff then h1 else
let h2 = hrr angMom_a angMom_b angMom_c dm in
h1 +. f2 *. h2
in
hrr angMom_a angMom_b angMom_c angMom_d
let contracted_class_shell_pair_couple ~basis ~zero_m shell_pair_couple : float Zmap.t =
let maxm = Am.to_int (Cspc.ang_mom shell_pair_couple) in
(* Pre-computation of integral class indices *)
let class_indices = Cspc.zkey_array shell_pair_couple in
let contracted_class =
Array.make (Array.length class_indices) 0.;
in
let monocentric =
Cspc.monocentric shell_pair_couple
in
(* Compute all integrals in the shell for each pair of significant shell pairs *)
let shell_p = Cspc.shell_pair_p shell_pair_couple
and shell_q = Cspc.shell_pair_q shell_pair_couple
in
let center_ab = Csp.a_minus_b shell_p
and center_cd = Csp.a_minus_b shell_q
in
let norm_scales = Cspc.norm_scales shell_pair_couple in
List.iter (fun (coef_prod, spc) ->
let sp_ab = Pspc.shell_pair_p spc
and sp_cd = Pspc.shell_pair_q spc
in
let center_pq = Co.(Psp.center sp_ab |- Psp.center sp_cd) in
let center_pa = Psp.center_minus_a sp_ab in
let center_qc = Psp.center_minus_a sp_cd in
let norm_pq_sq = Co.dot center_pq center_pq in
let expo_p_inv = Psp.exponent_inv sp_ab in
let expo_q_inv = Psp.exponent_inv sp_cd in
let zero = Zp.zero basis zero_m in
let zero_m_array = zero_m
{ zero with
maxm ; expo_p_inv ; expo_q_inv ; norm_pq_sq ;
center_pq ; center_pa ; center_qc ;
}
in
begin
match Cspc.ang_mom shell_pair_couple with
| Am.S ->
let integral = zero_m_array.(0) in
contracted_class.(0) <- contracted_class.(0) +. coef_prod *. integral
| _ ->
let expo_b = Ps.exponent (Psp.shell_b sp_ab)
and expo_d = Ps.exponent (Psp.shell_b sp_cd)
in
let map_1d = Zmap.create (4*maxm)
and map_2d = Zmap.create (Array.length class_indices)
in
(* Compute the integral class from the primitive shell quartet *)
class_indices
|> Array.iteri (fun i key ->
let (angMom_a,angMom_b,angMom_c,angMom_d) =
match Zkey.to_powers key with
| Zkey.Twelve x -> x
| _ -> assert false
in
try
if monocentric then
begin
if ( ((1 land angMom_a.Po.x + angMom_b.Po.x + angMom_c.Po.x + angMom_d.Po.x)=1) ||
((1 land angMom_a.Po.y + angMom_b.Po.y + angMom_c.Po.y + angMom_d.Po.y)=1) ||
((1 land angMom_a.Po.z + angMom_b.Po.z + angMom_c.Po.z + angMom_d.Po.z)=1)
) then
raise NullQuartet
end;
let norm = norm_scales.(i) in
let coef_prod = coef_prod *. norm in
let abcd = {
expo_b ; expo_d ; expo_p_inv ; expo_q_inv ;
center_ab ; center_cd ; center_pq ;
center_pa ; center_qc ; zero_m_array ;
} in
let integral =
hvrr_two_e
angMom_a angMom_b angMom_c angMom_d
abcd map_1d map_2d
in
contracted_class.(i) <- contracted_class.(i) +. coef_prod *. integral
with NullQuartet -> ()
)
end
) (Cspc.coefs_and_shell_pair_couples shell_pair_couple);
let result =
Zmap.create (Array.length contracted_class)
in
Array.iteri (fun i key -> Zmap.add result key contracted_class.(i)) class_indices;
result
let contracted_class_atomic_shell_pair_couple ~basis ~zero_m atomic_shell_pair_couple : float Zmap.t =
let maxm = Am.to_int (Aspc.ang_mom atomic_shell_pair_couple) in
(* Pre-computation of integral class indices *)
let class_indices = Aspc.zkey_array atomic_shell_pair_couple in
let contracted_class =
Array.make (Array.length class_indices) 0.;
in
let monocentric =
Aspc.monocentric atomic_shell_pair_couple
in
let shell_p = Aspc.atomic_shell_pair_p atomic_shell_pair_couple
and shell_q = Aspc.atomic_shell_pair_q atomic_shell_pair_couple
in
(* Compute all integrals in the shell for each pair of significant shell pairs *)
let center_ab = Asp.a_minus_b shell_p
and center_cd = Asp.a_minus_b shell_q
in
let norm_scales = Aspc.norm_scales atomic_shell_pair_couple in
List.iter (fun cspc ->
List.iter (fun (coef_prod, spc) ->
let sp_ab = Pspc.shell_pair_p spc
and sp_cd = Pspc.shell_pair_q spc
in
let expo_p_inv = Psp.exponent_inv sp_ab
in
let center_pq = Co.(Psp.center sp_ab |- Psp.center sp_cd) in
let center_qc = Psp.center_minus_a sp_cd in
let center_pa = Psp.center_minus_a sp_ab in
let norm_pq_sq = Co.dot center_pq center_pq in
let expo_q_inv = Psp.exponent_inv sp_cd in
let zero = Zp.zero basis zero_m in
let zero_m_array = zero_m
{ zero with
maxm ; expo_p_inv ; expo_q_inv ; norm_pq_sq ;
center_pq ; center_pa ; center_qc ;
}
in
begin
match Aspc.ang_mom atomic_shell_pair_couple with
| Am.S ->
let integral = zero_m_array.(0) in
contracted_class.(0) <- contracted_class.(0) +. coef_prod *. integral
| _ ->
let expo_b = Ps.exponent (Psp.shell_b sp_ab)
and expo_d = Ps.exponent (Psp.shell_b sp_cd)
in
let map_1d = Zmap.create (4*maxm)
and map_2d = Zmap.create (Array.length class_indices)
in
(* Compute the integral class from the primitive shell quartet *)
class_indices
|> Array.iteri (fun i key ->
let (angMom_a,angMom_b,angMom_c,angMom_d) =
match Zkey.to_powers key with
| Zkey.Twelve x -> x
| _ -> assert false
in
try
if monocentric then
begin
if ( ((1 land angMom_a.Po.x + angMom_b.Po.x + angMom_c.Po.x + angMom_d.Po.x)=1) ||
((1 land angMom_a.Po.y + angMom_b.Po.y + angMom_c.Po.y + angMom_d.Po.y)=1) ||
((1 land angMom_a.Po.z + angMom_b.Po.z + angMom_c.Po.z + angMom_d.Po.z)=1)
) then
raise NullQuartet
end;
let norm = norm_scales.(i) in
let coef_prod = coef_prod *. norm in
let abcd = {
expo_b ; expo_d ; expo_p_inv ; expo_q_inv ;
center_ab ; center_cd ; center_pq ;
center_pa ; center_qc ; zero_m_array ;
} in
let integral =
hvrr_two_e
angMom_a angMom_b angMom_c angMom_d
abcd
map_1d map_2d
in
contracted_class.(i) <- contracted_class.(i) +. coef_prod *. integral
with NullQuartet -> ()
)
end
) (Cspc.coefs_and_shell_pair_couples cspc)
) (Aspc.contracted_shell_pair_couples atomic_shell_pair_couple);
let result =
Zmap.create (Array.length contracted_class)
in
Array.iteri (fun i key -> Zmap.add result key contracted_class.(i)) class_indices;
result

875
Basis/TwoElectronRRVectorized.ml
View File

@ -1,875 +0,0 @@
open Util
open Lacaml.D
open Bigarray
module Am = AngularMomentum
module Co = Coordinate
module Cs = ContractedShell
module Csp = ContractedShellPair
module Cspc = ContractedShellPairCouple
module Po = Powers
module Psp = PrimitiveShellPair
module Ps = PrimitiveShell
module Zp = Zero_m_parameters
exception NullQuartet
exception Found
let cutoff = Constants.integrals_cutoff
let cutoff2 = cutoff *. cutoff
let empty = Zmap.create 0
let at_least_one_valid arr =
try
Array.iter (fun x -> if (abs_float x > cutoff) then raise Found) arr ; false
with Found -> true
type four_idx_intermediate =
{
expo_b : float array;
expo_d : float array;
expo_p_inv : float array;
expo_q_inv : float array;
center_ab : Co.t ;
center_cd : Co.t ;
center_pq : Co.axis -> float array array;
center_pa : Co.axis -> float array;
center_qc : Co.axis -> float array;
zero_m_array : float array array array;
}
(** Horizontal and Vertical Recurrence Relations (HVRR) *)
let hvrr_two_e_vector (angMom_a, angMom_b, angMom_c, angMom_d)
abcd map_1d map_2d np nq
=
let expo_p_inv = abcd.expo_p_inv
and expo_q_inv = abcd.expo_q_inv
and center_ab = abcd.center_ab
and center_cd = abcd.center_cd
and center_pq = abcd.center_pq
in
let zero_m_array = abcd.zero_m_array in
let maxm = Array.length zero_m_array - 1 in
let get_xyz angMom =
match angMom with
| { Po.y=0 ; z=0 ; _ } -> Co.X
| { z=0 ; _ } -> Co.Y
| _ -> Co.Z
in
(** Vertical recurrence relations *)
let rec vrr0_v angMom_a =
match angMom_a.Po.tot with
| 0 -> zero_m_array
| _ ->
let key = Zkey.of_powers_three angMom_a
in
try Zmap.find map_1d key with
| Not_found ->
let result =
let xyz = get_xyz angMom_a in
let am = Po.decr xyz angMom_a in
let cab = Co.get xyz center_ab in
let result = Array.init (maxm+1-angMom_a.Po.tot) (fun _ -> Array.make_matrix np nq 0.) in
let v_am= vrr0_v am in
begin
if abs_float cab >= cutoff then
let expo_b = abcd.expo_b in
Array.iteri (fun m result_m ->
let v0 = v_am.(m) in
Array.iteri (fun l result_ml ->
let f0 = -. expo_b.(l) *. expo_p_inv.(l) *. cab
and v0_l = v0.(l)
in
Array.iteri (fun k v0_lk ->
result_ml.(k) <- v0_lk *. f0) v0_l
) result_m
) result
end;
let amxyz = Po.get xyz am in
if amxyz < 1 then
Array.iteri (fun l expo_inv_p_l ->
let center_pq_xyz_l = (center_pq xyz).(l) in
Array.iteri (fun m result_m ->
let result_ml = result_m.(l) in
let p0 = v_am.(m+1) in
let p0_l = p0.(l)
in
Array.iteri (fun k p0_lk ->
result_ml.(k) <- result_ml.(k)
+. expo_inv_p_l *. center_pq_xyz_l.(k) *. p0_lk
) p0_l
) result
) expo_p_inv
else
begin
let amm = Po.decr xyz am in
let amxyz = float_of_int_fast amxyz in
let v_amm = vrr0_v amm in
Array.iteri (fun l expo_inv_p_l ->
let f = amxyz *. expo_p_inv.(l) *. 0.5
and center_pq_xyz_l = (center_pq xyz).(l)
in
Array.iteri (fun m result_m ->
let v1 = v_amm.(m) in
let v1_l = v1.(l) in
let result_ml = result_m.(l) in
let v2 = v_amm.(m+1) in
let p0 = v_am.(m+1) in
let v2_l = v2.(l)
in
Array.iteri (fun k p0_lk ->
result_ml.(k) <- result_ml.(k) +.
expo_inv_p_l *. center_pq_xyz_l.(k) *. p0_lk +.
f *. (v1_l.(k) +. v2_l.(k) *. expo_inv_p_l)
) p0.(l)
) result
) expo_p_inv
end;
result
in
Zmap.add map_1d key result;
result
and vrr_v m angMom_a angMom_c =
match (angMom_a.Po.tot, angMom_c.Po.tot) with
| (_,0) -> Some (vrr0_v angMom_a).(m)
| (_,_) ->
let key = Zkey.of_powers_six angMom_a angMom_c in
try Zmap.find map_2d.(m) key with
| Not_found ->
let result =
begin
let xyz = get_xyz angMom_c in
let cm = Po.decr xyz angMom_c in
let axyz = Po.get xyz angMom_a in
let do_compute = ref false in
let v1 =
let f = -. (Co.get xyz center_cd) in
let f1 =
let expo_d = abcd.expo_d in
Array.init nq (fun k ->
let x = expo_d.(k) *. expo_q_inv.(k) *. f in
if ( (not !do_compute) && (abs_float x > cutoff) ) then
do_compute := true;
x)
in
if (!do_compute) then
match vrr_v m angMom_a cm with
| None -> None
| Some v1 ->
begin
Some (Array.init np (fun l ->
let v1_l = v1.(l) in
Array.mapi (fun k f1k -> v1_l.(k) *. f1k) f1
) )
end
else None
in
let v2 =
let f2 =
Array.init np (fun l ->
let cpq_l = (center_pq xyz).(l) in
Array.init nq (fun k ->
let x = expo_q_inv.(k) *. cpq_l.(k) in
if (!do_compute) then x
else (if abs_float x > cutoff then do_compute := true ; x)
) )
in
if (!do_compute) then
match vrr_v (m+1) angMom_a cm with
| None -> None
| Some v2 ->
begin
for l=0 to np-1 do
let f2_l = f2.(l)
and v2_l = v2.(l)
in
for k=0 to nq-1 do
f2_l.(k) <- -. v2_l.(k) *. f2_l.(k)
done
done;
Some f2
end
else None
in
let p1 =
match v1, v2 with
| None, None -> None
| None, Some v2 -> Some v2
| Some v1, None -> Some v1
| Some v1, Some v2 ->
begin
for l=0 to np-1 do
let v1_l = v1.(l)
and v2_l = v2.(l)
in
for k=0 to nq-1 do
v2_l.(k) <- v2_l.(k) +. v1_l.(k)
done
done;
Some v2
end
in
let cxyz = Po.get xyz angMom_c in
let p2 =
if cxyz < 2 then p1 else
let cmm = Po.decr xyz cm in
let fcm = (float_of_int_fast (cxyz-1)) *. 0.5 in
let f1 =
Array.init nq (fun k ->
let x = fcm *. expo_q_inv.(k) in
if (!do_compute) then x
else (if abs_float x > cutoff then do_compute := true ; x)
)
in
let v1 =
if (!do_compute) then
match vrr_v m angMom_a cmm with
| None -> None
| Some v1 ->
begin
let result = Array.make_matrix np nq 0. in
for l=0 to np-1 do
let v1_l = v1.(l)
and result_l = result.(l)
in
for k=0 to nq-1 do
result_l.(k) <- v1_l.(k) *. f1.(k)
done;
done;
Some result
end
else None
in
let v3 =
let f2 =
Array.init nq (fun k ->
let x = expo_q_inv.(k) *. f1.(k) in
if (!do_compute) then x
else (if abs_float x > cutoff then do_compute := true ; x)
)
in
if (!do_compute) then
match vrr_v (m+1) angMom_a cmm with
| None -> None
| Some v3 ->
begin
let result = Array.make_matrix np nq 0. in
for l=0 to np-1 do
let v3_l = v3.(l)
and result_l = result.(l)
in
for k=0 to nq-1 do
result_l.(k) <- v3_l.(k) *. f2.(k)
done
done;
Some result
end
else None
in
match p1, v1, v3 with
| None, None, None -> None
| Some p1, None, None -> Some p1
| None, Some v1, None -> Some v1
| None, None, Some v3 -> Some v3
| Some p1, Some v1, Some v3 ->
begin
for l=0 to np-1 do
let v3_l = v3.(l)
and v1_l = v1.(l)
and p1_l = p1.(l)
in
for k=0 to nq-1 do
v3_l.(k) <- p1_l.(k) +. v1_l.(k) +. v3_l.(k)
done
done;
Some v3
end
| Some p1, Some v1, None ->
begin
for l=0 to np-1 do
let v1_l = v1.(l)
and p1_l = p1.(l)
in
for k=0 to nq-1 do
p1_l.(k) <- v1_l.(k) +. p1_l.(k)
done
done;
Some p1
end
| Some p1, None, Some v3 ->
begin
for l=0 to np-1 do
let v3_l = v3.(l)
and p1_l = p1.(l)
in
for k=0 to nq-1 do
p1_l.(k) <- p1_l.(k) +. v3_l.(k)
done
done;
Some p1
end
| None , Some v1, Some v3 ->
begin
for l=0 to np-1 do
let v3_l = v3.(l)
and v1_l = v1.(l)
in
for k=0 to nq-1 do
v3_l.(k) <- v1_l.(k) +. v3_l.(k)
done
done;
Some v3
end
in
if (axyz < 1) || (cxyz < 1) then p2 else
let am = Po.decr xyz angMom_a in
let v =
vrr_v (m+1) am cm
in
match (p2, v) with
| None, None -> None
| Some p2, None -> Some p2
| _, Some v ->
begin
let p2 =
match p2 with
| None -> Array.make_matrix np nq 0.
| Some p2 -> p2
in
for l=0 to np-1 do
let fa = (float_of_int_fast axyz) *. expo_p_inv.(l) *. 0.5 in
let p2_l = p2.(l)
and v_l = v.(l)
in
for k=0 to nq-1 do
p2_l.(k) <- p2_l.(k) -. fa *. expo_q_inv.(k) *. v_l.(k)
done
done;
Some p2
end
end
in Zmap.add map_2d.(m) key result;
result
(*
and trr_v angMom_a angMom_c =
match (angMom_a.Po.tot, angMom_c.Po.tot) with
| (i,0) -> Some (vrr0_v angMom_a).(0)
| (_,_) ->
let key = Zkey.of_powers_six angMom_a angMom_c in
try Zmap.find map_2d.(0) key with
| Not_found ->
let xyz = get_xyz angMom_c in
let axyz = Po.get xyz angMom_a in
let cm = Po.decr xyz angMom_c in
let cmxyz = Po.get xyz cm in
let expo_inv_q_over_p =
Array.mapi (fun l expo_inv_p_l ->
let expo_p_l = 1./.expo_inv_p_l in
Array.mapi (fun k expo_inv_q_k ->
expo_inv_q_k *. expo_p_l) expo_q_inv ) expo_p_inv
in
let result = None in
let result =
if cmxyz < 1 then result else
begin
let f = 0.5 *. (float_of_int_fast cmxyz) in
let cmm = Po.decr xyz cm in
match result, trr_v angMom_a cmm with
| None, None -> None
| None, Some v3 ->
Some (Array.init np (fun l ->
let v3_l = v3.(l) in
Array.mapi (fun k v3_lk ->
expo_q_inv.(k) *. f *. v3_lk) v3_l
) )
| Some result, None -> Some result
| Some result, Some v3 ->
(Array.iteri (fun l v3_l ->
let result_l = result.(l) in
Array.iteri (fun k v3_lk ->
result_l.(k) <- result_l.(k) +.
expo_q_inv.(k) *. f *. v3_lk) v3_l
) v3 ; Some result)
end
in
let result =
begin
match result, trr_v angMom_a cm with
| Some result, None -> Some result
| Some result, Some v1 ->
(Array.iteri (fun l v1_l ->
let cpa = (center_pa xyz).(l)
and result_l = result.(l)
and expo_inv_q_over_p_l = expo_inv_q_over_p.(l)
in
Array.iteri (fun k v1_lk ->
let cqc = (center_qc xyz).(k) in
result_l.(k) <- result_l.(k) +.
(cqc +. expo_inv_q_over_p_l.(k) *. cpa) *. v1_lk
) v1_l
) v1 ; Some result)
| None, None -> None
| None, Some v1 ->
Some (Array.init np (fun l ->
let v1_l = v1.(l)
and cpa = (center_pa xyz).(l)
and expo_inv_q_over_p_l = expo_inv_q_over_p.(l)
in
Array.mapi (fun k v1_lk ->
let cqc = (center_qc xyz).(k) in
(cqc +. expo_inv_q_over_p_l.(k) *. cpa) *. v1_lk
) v1_l
) )
end
in
let result =
if cmxyz < 0 then result else
begin
let ap = Po.incr xyz angMom_a in
match result, trr_v ap cm with
| Some result, None -> Some result
| Some result, Some v4 ->
(Array.iteri (fun l v4_l ->
let result_l = result.(l) in
Array.iteri (fun k v4_lk ->
let expo_inv_q_over_p_l = expo_inv_q_over_p.(l) in
result_l.(k) <- result_l.(k)
-. expo_inv_q_over_p_l.(k) *. v4_lk) v4_l
) v4 ; Some result)
| None, None -> None
| None, Some v4 ->
Some (Array.init np (fun l ->
let v4_l = v4.(l) in
let expo_inv_q_over_p_l = expo_inv_q_over_p.(l) in
Array.mapi (fun k v4_lk ->
-. expo_inv_q_over_p_l.(k) *. v4_lk) v4_l
) )
end
in
let result =
if axyz < 1 then result else
begin
let f = 0.5 *. (float_of_int_fast axyz) in
let am = Po.decr xyz angMom_a in
match result, trr_v am cm with
| Some result, None -> Some result
| Some result, Some v2 ->
(Array.iteri (fun l v2_l ->
let result_l = result.(l) in
Array.iteri (fun k v2_lk ->
result_l.(k) <- result_l.(k) +.
expo_q_inv.(k) *. f *. v2_lk) v2_l
) v2; Some result)
| None, None -> None
| None, Some v2 ->
Some (Array.init np (fun l ->
let v2_l = v2.(l) in
Array.mapi (fun k v2_lk ->
expo_q_inv.(k) *. f *. v2_lk) v2_l
) )
end
in
Zmap.add map_2d.(0) key result;
result
*)
in
let sum matrix =
Array.fold_left (fun accu c -> accu +. Array.fold_left (+.) 0. c) 0. matrix
in
let vrr_v a c =
let v =
(*
if c.Po.tot <> 0 then
vrr_v 0 a c
else trr_v a c
*)
vrr_v 0 a c
in
match v with
| Some matrix -> sum matrix
| None -> 0.
in
(** Horizontal recurrence relations *)
let rec hrr0_v angMom_a angMom_b angMom_c =
match angMom_b.Po.tot with
| 0 ->
begin
match (angMom_a.Po.tot, angMom_c.Po.tot) with
| (0,0) -> sum zero_m_array.(0)
| (_,_) -> vrr_v angMom_a angMom_c
end
| 1 ->
let xyz = get_xyz angMom_b in
let ap = Po.incr xyz angMom_a in
let f = Co.get xyz center_ab in
let v1 = vrr_v ap angMom_c in
if (abs_float f < cutoff) then v1 else
let v2 = vrr_v angMom_a angMom_c in
v1 +. v2 *. f
| _ ->
let xyz = get_xyz angMom_b in
let bxyz = Po.get xyz angMom_b in
if (bxyz < 0) then 0. else
let ap = Po.incr xyz angMom_a in
let bm = Po.decr xyz angMom_b in
let h1 = hrr0_v ap bm angMom_c in
let f = Co.get xyz center_ab in
if abs_float f < cutoff then h1 else
let h2 = hrr0_v angMom_a bm angMom_c in
h1 +. h2 *. f
and hrr_v angMom_a angMom_b angMom_c angMom_d =
match (angMom_b.Po.tot, angMom_d.Po.tot) with
| (_,0) -> if angMom_b.Po.tot = 0 then
vrr_v angMom_a angMom_c
else
hrr0_v angMom_a angMom_b angMom_c
| (_,_) ->
let xyz = get_xyz angMom_d in
let cp = Po.incr xyz angMom_c in
let dm = Po.decr xyz angMom_d in
let h1 =
hrr_v angMom_a angMom_b cp dm
in
let f = Co.get xyz center_cd in
if abs_float f < cutoff then
h1
else
let h2 =
hrr_v angMom_a angMom_b angMom_c dm
in h1 +. f *. h2
in
hrr_v angMom_a angMom_b angMom_c angMom_d
let contracted_class_shell_pairs ~basis ~zero_m ?schwartz_p ?schwartz_q shell_p shell_q : float Zmap.t =
let sp = Csp.shell_pairs shell_p
and sq = Csp.shell_pairs shell_q
and cp = Csp.coefficients shell_p
and cq = Csp.coefficients shell_q
in
let np, nq =
Array.length sp,
Array.length sq
in
try
match Cspc.make ~cutoff shell_p shell_q with
| None -> raise NullQuartet
| Some shell_pair_couple ->
let shell_a = Cspc.shell_a shell_pair_couple
and shell_c = Cspc.shell_c shell_pair_couple
in
let maxm = Am.to_int (Cspc.ang_mom shell_pair_couple) in
(* Pre-computation of integral class indices *)
let class_indices = Cspc.zkey_array shell_pair_couple in
let contracted_class =
Array.make (Array.length class_indices) 0.;
in
let monocentric =
Cspc.monocentric shell_pair_couple
in
(* Compute all integrals in the shell for each pair of significant shell pairs *)
begin
match Cspc.ang_mom shell_pair_couple with
| Am.S ->
contracted_class.(0) <-
begin
try
let expo_p_inv =
Vec.init np (fun ab -> Psp.exponent_inv sp.(ab-1))
and expo_q_inv =
Vec.init nq (fun cd -> Psp.exponent_inv sq.(cd-1))
in
let coef =
let result = Mat.make0 nq np in
Lacaml.D.ger (Vec.of_array @@ cq) (Vec.of_array @@ cp) result;
result
in
let zm_array = Mat.init_cols np nq (fun i j ->
try
if (abs_float coef.{j,i} ) < 1.e-3*.cutoff then
raise NullQuartet;
let expo_p_inv, expo_q_inv =
expo_p_inv.{i}, expo_q_inv.{j}
in
let center_pq =
Co.(Psp.center sp.(i-1) |- Psp.center sq.(j-1))
and center_pa =
Co.(Psp.center sp.(i-1) |- Cs.center shell_a)
and center_qc =
Co.(Psp.center sq.(i-1) |- Cs.center shell_c)
in
let norm_pq_sq =
Co.dot center_pq center_pq
in
let zero = Zp.zero basis zero_m in
let zero_m_array =
zero_m
{zero with
expo_p_inv ; expo_q_inv ; norm_pq_sq ;
center_pq ; center_pa ; center_qc ;
}
in
zero_m_array.(0)
with NullQuartet -> 0.
)
in
Mat.gemm_trace zm_array coef
with (Invalid_argument _) -> 0.
end
| _ ->
let coef =
Array.init np (fun l -> Array.init nq (fun k -> cq.(k) *. cp.(l)) )
in
let norm = Cspc.norm_scales shell_pair_couple in
let expo_p_inv =
Array.map (fun shell_ab -> Psp.exponent_inv shell_ab) sp
and expo_q_inv =
Array.map (fun shell_cd -> Psp.exponent_inv shell_cd) sq
in
let expo_b =
Array.map (fun shell_ab -> Ps.exponent (Psp.shell_b shell_ab) ) sp
and expo_d =
Array.map (fun shell_cd -> Ps.exponent (Psp.shell_b shell_cd) ) sq
in
let center_pq =
let result =
Array.init 3 (fun xyz ->
Array.init np (fun ab ->
let shell_ab = sp.(ab) in
Array.init nq (fun cd ->
let shell_cd = sq.(cd)
in
let cpq =
Co.(Psp.center shell_ab |- Psp.center shell_cd)
in
match xyz with
| 0 -> Co.get X cpq;
| 1 -> Co.get Y cpq;
| _ -> Co.get Z cpq;
)
)
)
in function
| Co.X -> result.(0)
| Co.Y -> result.(1)
| Co.Z -> result.(2)
in
let center_pa =
let result =
Array.init 3 (fun xyz ->
Array.init np (fun ab ->
let shell_ab = sp.(ab) in
let cpa =
Co.(Psp.center shell_ab |- Cs.center shell_a)
in
match xyz with
| 0 -> Co.(get X cpa);
| 1 -> Co.(get Y cpa);
| _ -> Co.(get Z cpa);
)
)
in function
| Co.X -> result.(0)
| Co.Y -> result.(1)
| Co.Z -> result.(2)
in
let center_qc =
let result =
Array.init 3 (fun xyz ->
Array.init nq (fun cd ->
let shell_cd = sq.(cd) in
let cqc =
Co.(Psp.center shell_cd |- Cs.center shell_c)
in
match xyz with
| 0 -> Co.(get X cqc);
| 1 -> Co.(get Y cqc);
| _ -> Co.(get Z cqc);
)
)
in function
| Co.X -> result.(0)
| Co.Y -> result.(1)
| Co.Z -> result.(2)
in
let zero_m_array =
let result =
Array.init (maxm+1) (fun _ ->
Array.init np (fun _ -> Array.make nq 0. ) )
in
let empty = Array.make (maxm+1) 0. in
let center_qc_tmp = Array.init nq (fun cd ->
Coordinate.make { Coordinate.
x = (center_qc Co.X).(cd) ;
y = (center_qc Co.Y).(cd) ;
z = (center_qc Co.Z).(cd) ;
})
in
Array.iteri (fun ab _shell_ab ->
let center_pa = Coordinate.make { Coordinate.
x = (center_pa Co.X).(ab) ;
y = (center_pa Co.Y).(ab) ;
z = (center_pa Co.Z).(ab) ;
}
in
let zero_m_array_tmp =
Array.mapi (fun cd _shell_cd ->
if (abs_float coef.(ab).(cd) < cutoff) then
empty
else
let expo_p_inv, expo_q_inv =
expo_p_inv.(ab), expo_q_inv.(cd)
in
let x = (center_pq X).(ab).(cd)
and y = (center_pq Y).(ab).(cd)
and z = (center_pq Z).(ab).(cd)
in
let norm_pq_sq =
x *. x +. y *. y +. z *. z
in
let zero = Zp.zero basis zero_m in
zero_m {zero with
maxm ; expo_p_inv ; expo_q_inv ; norm_pq_sq ;
center_pq = Coordinate.make Coordinate.{x ; y ; z} ;
center_pa ; center_qc = center_qc_tmp.(cd) ;
}
) sq
in
(* Transpose result *)
let coef_ab = coef.(ab) in
for m=0 to maxm do
let result_m_ab = result.(m).(ab)
in
for cd=0 to nq-1 do
result_m_ab.(cd) <- zero_m_array_tmp.(cd).(m) *. coef_ab.(cd)
done
done
) sp;
result
in
let map_1d = Zmap.create (4*maxm)
and map_2d = Array.init (maxm+1) (fun _ -> Zmap.create (Array.length class_indices))
in
(* Compute the integral class from the primitive shell quartet *)
Array.iteri (fun i key ->
let (angMom_a,angMom_b,angMom_c,angMom_d) =
match Zkey.to_powers key with
| Zkey.Twelve x -> x
| _ -> assert false
in
try
if monocentric then
begin
if ( ((1 land angMom_a.x + angMom_b.x + angMom_c.x + angMom_d.x) =1) ||
((1 land angMom_a.y + angMom_b.y + angMom_c.y + angMom_d.y) =1) ||
((1 land angMom_a.z + angMom_b.z + angMom_c.z + angMom_d.z) =1)
) then
raise NullQuartet
end;
(* Schwartz screening *)
if (np+nq> 24) then
(
let schwartz_p =
let key = Zkey.of_powers_twelve
angMom_a angMom_b angMom_a angMom_b
in
match schwartz_p with
| None -> 1.
| Some schwartz_p -> Zmap.find schwartz_p key
in
if schwartz_p < cutoff then raise NullQuartet;
let schwartz_q =
let key = Zkey.of_powers_twelve
angMom_c angMom_d angMom_c angMom_d
in
match schwartz_q with
| None -> 1.
| Some schwartz_q -> Zmap.find schwartz_q key
in
if schwartz_p *. schwartz_q < cutoff2 then raise NullQuartet;
);
let abcd =
{ expo_b ; expo_d ; expo_p_inv ; expo_q_inv ;
center_ab = Csp.a_minus_b shell_p;
center_cd = Csp.a_minus_b shell_q ;
center_pq ; center_pa ;
center_qc ; zero_m_array }
in
let integral =
hvrr_two_e_vector (angMom_a, angMom_b, angMom_c, angMom_d)
abcd map_1d map_2d np nq
in
contracted_class.(i) <- contracted_class.(i) +. integral *. norm.(i)
with NullQuartet -> ()
) class_indices
end;
let result =
Zmap.create (Array.length contracted_class)
in
Array.iteri (fun i key -> Zmap.add result key contracted_class.(i)) class_indices;
result
with NullQuartet -> empty

27
Basis/Zero_m_parameters.ml
View File

@ -1,27 +0,0 @@
type t =
{
expo_p_inv : float ;
expo_q_inv : float ;
norm_pq_sq : float ;
maxm : int ;
center_pq : Coordinate.t ;
center_pa : Coordinate.t ;
center_qc : Coordinate.t ;
zero_m_func : t -> float array ;
basis : Basis.t ;
}
let zero basis zero_m_func =
{
zero_m_func ;
basis ;
maxm=0 ;
expo_p_inv = 0.;
expo_q_inv = 0.;
norm_pq_sq = 0.;
center_pq = Coordinate.zero ;
center_pa = Coordinate.zero ;
center_qc = Coordinate.zero ;
}

1
CI/.merlin
View File

@ -1 +0,0 @@
REC

1217
CI/CI.ml
View File

File diff suppressed because it is too large Load Diff

257
CI/CIMatrixElement.ml
View File

@ -1,257 +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 single h p spin same opposite =
let same_spin_mo_list =
Sp.to_list same
and opposite_spin_mo_list =
Sp.to_list opposite
in
fun one_e two_e ->
let same_spin =
List.fold_left (fun accu i -> accu +. two_e h i p i spin spin) 0. same_spin_mo_list
and opposite_spin =
List.fold_left (fun accu i -> accu +. two_e h i p i spin (Spin.other spin) ) 0. opposite_spin_mo_list
in (one_e h p spin) +. same_spin +. opposite_spin
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_2e = lazy (
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
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
| 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 *)
begin
let h, p, phase = Ex.single_of_spindet kia kja in
match phase with
| Phase.Pos -> fun one_e two_e -> single h p Spin.Alfa kia kib one_e two_e
| Phase.Neg -> fun one_e two_e -> -. single h p Spin.Alfa kia kib one_e two_e
end
| 0, 1 -> (* beta single *)
begin
let h, p, phase = Ex.single_of_spindet kib kjb in
match phase with
| Phase.Pos -> fun one_e two_e -> single h p Spin.Beta kib kia one_e two_e
| Phase.Neg -> fun one_e two_e -> -. single h p Spin.Beta kib kia one_e two_e
end
| 0, 0 -> (* diagonal element *)
diag_element
| _ -> assert false
) in
let result_3e = lazy (
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
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
| 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 *)
begin
let h, p, phase = Ex.single_of_spindet kia kja in
match phase with
| Phase.Pos -> fun one_e two_e _ -> single h p Spin.Alfa kia kib one_e two_e
| Phase.Neg -> fun one_e two_e _ -> -. single h p Spin.Alfa kia kib one_e two_e
end
| 0, 1 -> (* beta single *)
begin
let h, p, phase = Ex.single_of_spindet kib kjb in
match phase with
| Phase.Pos -> fun one_e two_e _ -> single h p Spin.Beta kib kia one_e two_e
| Phase.Neg -> fun one_e two_e _ -> -. single h p Spin.Beta kib kia one_e two_e
end
| 0, 0 -> (* diagonal element *)
fun one_e two_e _ -> diag_element one_e two_e
| 3, 0 -> (* alpha triple *)
begin
let h1, p1, h2, p2, h3, p3, phase = Ex.triple_of_spindet kia kja in
match phase with
| Phase.Pos -> fun _ _ three_e -> three_e h1 h2 h3 p1 p2 p3 Spin.Alfa Spin.Alfa Spin.Alfa
| Phase.Neg -> fun _ _ three_e -> -. three_e h1 h2 h3 p1 p2 p3 Spin.Alfa Spin.Alfa Spin.Alfa
end
| 0, 3 -> (* beta triple *)
begin
let h1, p1, h2, p2, h3, p3, phase = Ex.triple_of_spindet kib kja in
match phase with
| Phase.Pos -> fun _ _ three_e -> three_e h1 h2 h3 p1 p2 p3 Spin.Beta Spin.Beta Spin.Beta
| Phase.Neg -> fun _ _ three_e -> -. three_e h1 h2 h3 p1 p2 p3 Spin.Beta Spin.Beta Spin.Beta
end
| 2, 1 -> (* alpha2 beta triple *)
begin
let h1, p1, h2, p2, phase = Ex.double_of_spindet kia kja in
let h3, p3, phase' = Ex.single_of_spindet kib kjb in
match phase, phase' with
| Phase.Pos, Phase.Pos
| Phase.Neg, Phase.Neg ->
fun _ _ three_e -> three_e h1 h2 h3 p1 p2 p3 Spin.Alfa Spin.Alfa Spin.Beta
| Phase.Neg, Phase.Pos
| Phase.Pos, Phase.Neg ->
fun _ _ three_e -> -. three_e h1 h2 h3 p1 p2 p3 Spin.Alfa Spin.Alfa Spin.Beta
end
| 1, 2 -> (* alpha beta2 triple *)
begin
let h1, p1, phase = Ex.single_of_spindet kia kja in
let h2, p2, h3, p3, phase' = Ex.double_of_spindet kib kjb in
match phase, phase' with
| Phase.Pos, Phase.Pos
| Phase.Neg, Phase.Neg ->
fun _ _ three_e -> three_e h1 h2 h3 p1 p2 p3 Spin.Alfa Spin.Beta Spin.Beta
| Phase.Neg, Phase.Pos
| Phase.Pos, Phase.Neg ->
fun _ _ three_e -> -. three_e h1 h2 h3 p1 p2 p3 Spin.Alfa Spin.Beta Spin.Beta
end
| _ -> fun _ _ _ -> 0.
) in
List.map (fun (one_e, two_e, x) ->
match x with
| None -> (Lazy.force result_2e) one_e two_e
| Some three_e -> (Lazy.force result_3e) one_e two_e three_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.

222
CI/Determinant.ml
View File

@ -1,222 +0,0 @@
type t =
{
alfa : Spindeterminant.t ;
beta : Spindeterminant.t ;
}
type hole = int
type particle = int
let alfa t = t.alfa
let beta t = t.beta
let vac n =
{
alfa = Spindeterminant.vac n;
beta = Spindeterminant.vac n;
}
let phase t =
match Spindeterminant.(phase t.alfa, phase t.beta) with
| Phase.Pos, Phase.Pos
| Phase.Neg, Phase.Neg -> Phase.Pos
| _ -> Phase.Neg
let of_spindeterminants a b =
{
alfa = a ;
beta = b
}
let is_none t = Spindeterminant.(is_none t.alfa || is_none t.beta)
let negate_phase t =
{ t with alfa = Spindeterminant.negate_phase t.alfa }
let set_phase p t =
{ alfa = Spindeterminant.set_phase p t.alfa ;
beta = Spindeterminant.set_phase Phase.Pos t.beta
}
let degree_alfa t t' =
Spindeterminant.degree t.alfa t'.alfa
let degree_beta t t' =
Spindeterminant.degree t.beta t'.beta
let degrees t t' =
degree_alfa t t', degree_beta t t'
let degree t t' =
(degree_alfa t t') + (degree_beta t t')
let of_lists n a b =
let alfa = Spindeterminant.of_list n a
and beta = Spindeterminant.of_list n b
in of_spindeterminants alfa beta
let to_lists t =
Spindeterminant.to_list t.alfa,
Spindeterminant.to_list t.beta
let creation spin p t =
match spin with
| Spin.Alfa -> { t with alfa = Spindeterminant.creation p t.alfa }
| Spin.Beta -> { t with beta = Spindeterminant.creation p t.beta }
let annihilation spin h t =
match spin with
| Spin.Alfa -> { t with alfa = Spindeterminant.annihilation h t.alfa }
| Spin.Beta -> { t with beta = Spindeterminant.annihilation h t.beta }
let single_excitation spin h p t =
assert (h <> p);
match spin with
| Spin.Alfa -> { t with alfa = Spindeterminant.single_excitation h p t.alfa }
| Spin.Beta -> { t with beta = Spindeterminant.single_excitation h p t.beta }
let double_excitation spin h p spin' h' p' t =
assert (h <> p);
assert (h' <> p');
match spin, spin' with
| Spin.(Alfa, Beta) -> { alfa = Spindeterminant.single_excitation h p t.alfa ;
beta = Spindeterminant.single_excitation h' p' t.beta }
| Spin.(Beta, Alfa) -> { beta = Spindeterminant.single_excitation h p t.beta ;
alfa = Spindeterminant.single_excitation h' p' t.alfa }
| Spin.(Alfa, Alfa) -> { t with alfa = Spindeterminant.double_excitation h p h' p' t.alfa }
| Spin.(Beta, Beta) -> { t with beta = Spindeterminant.double_excitation h p h' p' t.beta }
let compare = compare
let pp n ppf t =
Format.fprintf ppf "@[<v>@[phase:%a@]@;@[a:%a@]@;@[b:%a@]@]@."
Phase.pp (phase t)
(Spindeterminant.pp n) t.alfa
(Spindeterminant.pp n) t.beta
let test_case () =
let test_creation () =
let l_a = [ 1 ; 2 ; 3 ; 5 ; 64 ]
and l_b = [ 2 ; 3 ; 5 ; 65 ] in
let det = of_lists 66 l_a l_b in
let z_a = alfa det
and z_b = beta det in
Alcotest.(check (list int )) "alfa" (Spindeterminant.to_list z_a) l_a;
Alcotest.(check (list int )) "beta" (Spindeterminant.to_list z_b) l_b;
Alcotest.(check bool) "phase" (phase det = Phase.Pos) true;
in
let test_phase () =
let l_a = [ 1 ; 2 ; 3 ; 64 ; 5 ]
and l_b = [ 2 ; 3 ; 5 ; 65 ] in
let det = of_lists 66 l_a l_b in
Alcotest.(check bool) "phase" (phase det = Phase.Neg) true;
let l_a = [ 1 ; 2 ; 3 ; 64 ; 5 ]
and l_b = [ 3 ; 2 ; 5 ; 65 ] in
let det = of_lists 66 l_a l_b in
Alcotest.(check bool) "phase" (phase det = Phase.Pos) true;
let l_a = [ 1 ; 3 ; 2 ; 64 ; 5 ]
and l_b = [ 3 ; 2 ; 5 ; 65 ] in
let det = of_lists 66 l_a l_b in
Alcotest.(check bool) "phase" (phase det = Phase.Neg) true;
let l_a = [ 1 ; 3 ; 2 ; 64 ; 5 ]
and l_b = [ 3 ; 2 ; 65 ; 5 ] in
let det = of_lists 66 l_a l_b in
Alcotest.(check bool) "phase" (phase det = Phase.Pos) true;
in
let test_operators () =
let det =
let open Spin in
creation Alfa 1 @@ creation Alfa 3 @@ creation Alfa 2 @@ creation Alfa 5 @@
creation Beta 1 @@ creation Beta 3 @@ creation Beta 4 @@ creation Beta 5 @@ vac 10
in
Alcotest.(check bool) "creation 1" true
(det = of_lists 10 [ 1 ; 3 ; 2 ; 5 ] [1 ; 3 ; 4 ; 5 ] );
let det' =
single_excitation Spin.Alfa 3 6 det
in
Alcotest.(check bool) "single_exc 1" true
(det' = of_lists 10 [ 1 ; 6 ; 2 ; 5 ] [1 ; 3 ; 4 ; 5 ] );
let det' =
single_excitation Spin.Beta 3 6 det
in
Alcotest.(check bool) "single_exc 2" true
(det' = of_lists 10 [ 1 ; 3 ; 2 ; 5 ] [1 ; 6 ; 4 ; 5 ] );
let det' =
single_excitation Spin.Alfa 4 6 det
in
Alcotest.(check bool) "single_exc 3" true (is_none det');
let det' =
single_excitation Spin.Beta 1 5 det
in
Alcotest.(check bool) "single_exc 4" true (is_none det');
let det' =
double_excitation Spin.Alfa 3 6 Spin.Alfa 2 7 det
in
let det'' = of_lists 10 [ 1 ; 6 ; 7 ; 5 ] [1 ; 3 ; 4 ; 5 ] in
Alcotest.(check bool) "double_exc 1" true (det' = det'');
let det' =
double_excitation Spin.Beta 3 6 Spin.Beta 5 7 det
in
Alcotest.(check bool) "double_exc 2" true
(det' = of_lists 10 [ 1 ; 3 ; 2 ; 5 ] [1 ; 6 ; 4 ; 7 ] );
let det' =
double_excitation Spin.Alfa 3 6 Spin.Beta 5 7 det
in
Alcotest.(check bool) "double_exc 3" true
(det' = of_lists 10 [ 1 ; 6 ; 2 ; 5 ] [1 ; 3 ; 4 ; 7 ] );
let det' =
double_excitation Spin.Beta 5 7 Spin.Alfa 3 6 det
in
Alcotest.(check bool) "double_exc 4" true
(det' = of_lists 10 [ 1 ; 6 ; 2 ; 5 ] [1 ; 3 ; 4 ; 7 ] );
let det' =
double_excitation Spin.Alfa 4 6 Spin.Alfa 2 7 det
in
Alcotest.(check bool) "double_exc 5" true (is_none det');
let det' =
double_excitation Spin.Beta 1 5 Spin.Alfa 2 7 det
in
Alcotest.(check bool) "double_exc 6" true (is_none det');
in
[
"Creation", `Quick, test_creation;
"Phase", `Quick, test_phase;
"Operators",`Quick, test_operators;
]

93
CI/Determinant.mli
View File

@ -1,93 +0,0 @@
(** A Slater determinant is expressed as a Waller-Hartree double determinant:
{% $$
D(\mathbf{R}) = D_\alpha(\mathbf{R_\alpha}) \times D_\beta(\mathbf{R_\beta})
$$ %}
The {% $\alpha$ %} and {% $\beta$ %} determinants are of type [Spindeterminant.t].
*)
type t
type hole = int
type particle = int
(** {1 Accessors} *)
val alfa : t -> Spindeterminant.t
(** Get the {% $\alpha$ %} spin-determinant. *)
val beta : t -> Spindeterminant.t
(** Get the {% $\beta$ %} spin-determinant. *)
val phase : t -> Phase.t
(** Get the phase of the Slater determinant, the product of the phases of the
spin-determinants.
*)
val is_none : t -> bool
(** Tests if a Determinant is [None]. *)
(** {1 Second quantization operators} *)
val vac : int -> t
(** Vacuum state, [vac = Some ]{% $|\rangle$ %}. The integer parameter is the size of the
MO basis set. *)
val creation : Spin.t -> particle -> t -> t
(** [creation spin p] is the creation operator {% $a^\dagger_p$ %}. *)
val annihilation : Spin.t -> hole -> t -> t
(** [annihilation spin h] is the annihilation operator {% $a_h$ %}. *)
val single_excitation : Spin.t -> hole -> particle -> t -> t
(** Single excitation operator {% $T_h^p = a^\dagger_p a_h$ %}. *)
val double_excitation : Spin.t -> hole -> particle -> Spin.t -> hole -> particle -> t -> t
(** Double excitation operator {% $T_{hh'}^{pp'} = a^\dagger_p a^\dagger_{p'} a_{h'} a_h$ %}. *)
val degree_alfa : t -> t -> int
(** Returns degree of excitation between two determinants in the {% $\alpha$ %} spin. *)
val degree_beta : t -> t -> int
(** Returns degree of excitation between two determinants in the {% $\beta$ %} spin. *)
val degrees : t -> t -> int*int
(** Returns degrees of excitation between two determinants in {% $\alpha$ %} and
{% $\beta$ %} spins as a pair. *)
val degree : t -> t -> int
(** Returns degree of excitation between two determinants. *)
val to_lists : t -> int list * int list
(** Converts a Slater determinant to a pair of lists of orbital indices. *)
(** {1 Creators} *)
val of_spindeterminants : Spindeterminant.t -> Spindeterminant.t -> t
(** Creates a Slater determinant from an {% $\alpha$ %} and a {% $\beta$ %}
[Spindeterminant.t].
*)
val of_lists : int -> int list -> int list -> t
(** Creates a Slater determinant from a two lists of orbital indices.
The integer parameter is the size of the MO basis set. *)
val negate_phase : t -> t
(** Returns the same determinant with the phase negated. *)
val set_phase : Phase.t -> t -> t
(** Returns the same determinant with the phase set to [p]. *)
val compare : t -> t -> int
(** Comparison function for sorting *)
(** {1 Printers} *)
val pp : int -> Format.formatter -> t -> unit
(** First [int] is the number of MOs to print. *)
(** {1 Unit tests} *)
val test_case : unit -> (string * [> `Quick ] * (unit -> unit)) list

360
CI/DeterminantSpace.ml
View File

@ -1,360 +0,0 @@
(** Data structures for storing the determinant space.
If the space is built as the outer product of all {% $\alpha$ %} and {%
$\beta$ %} determinants, the storage is of type [Spin]. It is sufficient
to have the arrays of {% $\alpha$ %} and {% $\beta$ %} spindeterminants.
Otherwise, the space is of type [Arbitrary].
*)
type arbitrary_space =
{
det : int array array ;
det_alfa : Spindeterminant.t array ;
det_beta : Spindeterminant.t array ;
index_start : int array;
}
type determinant_storage =
| Arbitrary of arbitrary_space
| Spin of (Spindeterminant.t array * Spindeterminant.t array)
type t =
{
n_alfa : int ;
n_beta : int ;
mo_class : MOClass.t ;
mo_basis : MOBasis.t ;
determinants : determinant_storage;
}
module Ss = SpindeterminantSpace
let n_alfa t = t.n_alfa
let n_beta t = t.n_beta
let mo_class t = t.mo_class
let mo_basis t = t.mo_basis
let active_mos t =
mo_class t
|> MOClass.active_mos
let inactive_mos t =
mo_class t
|> MOClass.inactive_mos
let virtual_mos t =
mo_class t
|> MOClass.inactive_mos
let mo_class_array t =
mo_class t
|> MOClass.mo_class_array
let size t =
match t.determinants with
| Spin (a,b) -> (Array.length a) * (Array.length b)
| Arbitrary a ->
let ndet_a = Array.length a.det_alfa in
a.index_start.(ndet_a)
let determinant_stream t =
match t.determinants with
| Arbitrary a ->
let det_beta = a.det_beta
and det_alfa = a.det_alfa
and det = a.det in
let n_alfa = Array.length det_alfa in
let alfa = ref det_alfa.(0)
and det_i_alfa = ref det.(0) in
let i_alfa = ref 0
and k_beta = ref 0
in
Stream.from (fun _ ->
if !i_alfa = n_alfa then None else
begin
let i_beta = (!det_i_alfa).(!k_beta) in
let beta = det_beta.(i_beta) in
let result =
Some (Determinant.of_spindeterminants (!alfa) beta)
in
incr k_beta;
if !k_beta = Array.length !det_i_alfa then
begin
k_beta := 0;
incr i_alfa;
if !i_alfa < n_alfa then
begin
alfa := det_alfa.(!i_alfa);
det_i_alfa := det.(!i_alfa)
end
end;
result
end
)
| Spin (a,b) ->
let na = Array.length a
and nb = Array.length b in
let i = ref 0
and j = ref 0 in
Stream.from (fun k ->
if !j < nb then
let result =
Determinant.of_spindeterminants a.(!i) b.(!j)
in
incr i;
if !i = na then (i := 0 ; incr j);
Some result
else
None)
let determinants t = t.determinants
let determinants_array t =
let s = determinant_stream t in
Array.init (size t) (fun _ -> Stream.next s)
let determinant t i =
let alfa, beta =
match t.determinants with
| Arbitrary a ->
let i_alfa =
let index_start = a.index_start in
let rec loop i_alfa =
if index_start.(i_alfa) <= i then
(loop [@tailcall]) (i_alfa+1)
else i_alfa
in loop 0
in
let i_beta = i - a.index_start.(i_alfa) in
let alfa = a.det_alfa.(i_alfa) in
let beta = a.det_beta.(i_beta) in
alfa, beta
| Spin (a,b) ->
let nb = Array.length b in
let k = i / nb in
let j = i - k * nb in
a.(j), b.(k)
in
Determinant.of_spindeterminants alfa beta
let fock_diag det_space det =
let alfa_list =
Determinant.alfa det
|> Spindeterminant.to_list
in
let beta_list =
Determinant.beta det
|> Spindeterminant.to_list
in
let mo_basis = mo_basis det_space in
let mo_num = MOBasis.size mo_basis in
let one_e_ints = MOBasis.one_e_ints mo_basis
and two_e_ints = MOBasis.two_e_ints mo_basis
in
let two_e i j k l = ERI.get_phys two_e_ints i j k l in
let build_array list1 list2 =
let result = Array.make (mo_num+1) 0. in
(* Occupied *)
List.iter (fun i ->
let x = one_e_ints.{i,i} in
result.(i) <- result.(i) +. x;
result.(0) <- result.(0) +. x;
List.iter (fun j ->
if j <> i then
begin
let x = two_e i j i j -. two_e i j j i in
result.(i) <- result.(i) +. x;
result.(0) <- result.(0) +. 0.5 *. x;
end
) list1;
List.iter (fun j ->
begin
let x = two_e i j i j in
result.(i) <- result.(i) +. x;
result.(0) <- result.(0) +. 0.5 *. x;
end
) list2;
) list1;
(* Virtuals*)
List.iter (fun i ->
if result.(i) = 0. then
begin
let x = one_e_ints.{i,i} in
result.(i) <- result.(i) +. x;
List.iter (fun j ->
let x = two_e i j i j -. two_e i j j i in
result.(i) <- result.(i) +. x;
) list1;
List.iter (fun j ->
begin
let x = two_e i j i j in
result.(i) <- result.(i) +. x;
end
) list2;
end
) (Util.list_range 1 mo_num);
result
in
let alfa, beta =
build_array alfa_list beta_list,
build_array beta_list alfa_list
in
let e = alfa.(0) +. beta.(0) in
alfa.(0) <- e;
beta.(0) <- e;
alfa, beta
let spin_of_mo_basis mo_basis f =
let s = MOBasis.simulation mo_basis in
let e = Simulation.electrons s in
let n_alfa = Electrons.n_alfa e
and n_beta = Electrons.n_beta e in
let det_a = f n_alfa
and det_b = f n_beta
in
let mo_class = Ss.mo_class det_a in
let determinants =
let det_alfa = Ss.spin_determinants det_a
and det_beta = Ss.spin_determinants det_b
in
let n_det_beta = Array.length det_beta in
let n_det_alfa = Array.length det_alfa in
let ndet = n_det_alfa * n_det_beta in
if Parallel.master then
Format.printf "Number of determinants : %d %d %d\n%!"
n_det_alfa n_det_beta ndet;
Spin (det_alfa, det_beta)
in
{ n_alfa ; n_beta ; mo_class ; mo_basis ; determinants }
let arbitrary_of_mo_basis mo_basis f =
let s = MOBasis.simulation mo_basis in
let e = Simulation.electrons s in
let n_alfa = Electrons.n_alfa e
and n_beta = Electrons.n_beta e in
let det_a = f n_alfa
and det_b = f n_beta
in
let mo_class = Ss.mo_class det_a in
let determinants =
let det_alfa = Ss.spin_determinants det_a
and det_beta = Ss.spin_determinants det_b
in
let n_det_beta = Array.length det_beta in
let n_det_alfa = Array.length det_alfa in
let det = Array.make n_det_alfa
(Array.init n_det_beta (fun i -> i))
in
let index_start = Array.init (n_det_alfa+1) (fun i -> i*n_det_beta) in
let ndet = (index_start.(n_det_alfa)) in
if Parallel.master then
Format.printf "Number of determinants : %d %d %d\n%!"
n_det_alfa n_det_beta ndet;
Arbitrary {
det_alfa ; det_beta ; det ; index_start
}
in
{ n_alfa ; n_beta ; mo_class ; mo_basis ; determinants }
let cas_of_mo_basis mo_basis ~frozen_core n m =
let f n_alfa =
Ss.cas_of_mo_basis mo_basis ~frozen_core n_alfa n m
in
spin_of_mo_basis mo_basis f
let fci_of_mo_basis mo_basis ~frozen_core =
let f n_alfa =
Ss.fci_of_mo_basis mo_basis ~frozen_core n_alfa
in
spin_of_mo_basis mo_basis f
let fci_f12_of_mo_basis mo_basis ~frozen_core mo_num =
let s = MOBasis.simulation mo_basis in
let e = Simulation.electrons s in
let n_alfa = Electrons.n_alfa e
and n_beta = Electrons.n_beta e in
let n_core =
if frozen_core then
(Nuclei.small_core @@ Simulation.nuclei @@ MOBasis.simulation mo_basis) / 2
else 0
in
let n, m =
(n_alfa + n_beta - n_core),
(mo_num - n_core)
in
let f n_alfa =
Ss.cas_of_mo_basis mo_basis ~frozen_core n_alfa n m
in
let r =
spin_of_mo_basis mo_basis f
in
{ r with mo_class =
MOClass.to_list r.mo_class
|> List.rev_map (fun i ->
match i with
| MOClass.Virtual i when i > mo_num -> MOClass.Auxiliary i
| i -> i)
|> List.rev
|> MOClass.of_list }
let cas_f12_of_mo_basis mo_basis ~frozen_core n m mo_num =
let f n_alfa =
Ss.cas_of_mo_basis mo_basis ~frozen_core n_alfa n m
in
let r =
spin_of_mo_basis mo_basis f
in
{ r with mo_class =
MOClass.to_list r.mo_class
|> List.rev_map (fun i ->
match i with
| MOClass.Virtual i when i > mo_num -> MOClass.Auxiliary i
| i -> i)
|> List.rev
|> MOClass.of_list
}
let pp ppf t =
Format.fprintf ppf "@[<v 2>[ ";
let i = ref 0 in
determinant_stream t
|> Stream.iter (fun d -> Format.fprintf ppf "@[<v>@[%8d@]@;@[%a@]@]@;" !i
(Determinant.pp (MOBasis.size (mo_basis t))) d; incr i) ;
Format.fprintf ppf "]@]"

74
CI/DeterminantSpace.mli
View File

@ -1,74 +0,0 @@
(**
The determinant space in which we solve the Schrodinger equation.
*)
type t
type arbitrary_space =
{
det : int array array ;
det_alfa : Spindeterminant.t array ;
det_beta : Spindeterminant.t array ;
index_start : int array;
}
type determinant_storage =
| Arbitrary of arbitrary_space
| Spin of (Spindeterminant.t array * Spindeterminant.t array)
(** {1 Accessors} *)
val n_alfa : t -> int
(** Number of {% $\alpha$ %} electrons in the {% $\alpha$ %} MOs. *)
val n_beta : t -> int
(** Number of {% $\beta$ %} electrons in the {% $\beta$ %} MOs. *)
val mo_class : t -> MOClass.t
(** The MO classes used to generate the space. *)
val mo_basis : t -> MOBasis.t
(** The MO basis on which the determinants are expanded. *)
val determinants : t -> determinant_storage
(** All the determinants belonging to the space. *)
val determinants_array : t -> Determinant.t array
(** All the determinants belonging to the space. *)
val determinant_stream : t -> Determinant.t Stream.t
(** All the determinants belonging to the space, as a stream. *)
val size : t -> int
(** Size of the determinant space *)
val fock_diag : t -> Determinant.t -> float array * float array
(** Returns the diagonal of the {% $\alpha$ %} and {% $\beta$ %} Fock matrices.
The zero elements contain the energy of the determinant.
*)
val fci_of_mo_basis : MOBasis.t -> frozen_core:bool -> t
(** Creates a space of all possible ways to put [n_alfa] electrons in the {% $\alpha$ %}
[Active] MOs and [n_beta] electrons in the {% $\beta$ %} [Active] MOs.
All other MOs are untouched.
*)
val cas_of_mo_basis : MOBasis.t -> frozen_core:bool -> int -> int -> t
(** Creates a CAS(n,m) space of determinants. *)
val fci_f12_of_mo_basis : MOBasis.t -> frozen_core:bool -> int -> t
(** Creates the active space to perform a FCI-F12 with an
auxiliary basis set. *)
val cas_f12_of_mo_basis : MOBasis.t -> frozen_core:bool -> int -> int -> int -> t
(** [cas_of_mo_basis mo_basis m n mo_num] Creates a CAS(n,m) space
of determinants with an auxiliary basis set defined as the MOs from
[mo_num+1] to [MOBasis.size mo_basis].
*)
(** {2 Printing} *)
val pp : Format.formatter -> t -> unit

205
CI/Excitation.ml
View File

@ -1,205 +0,0 @@
type single_exc =
{
hole : int ;
particle : int ;
spin : Spin.t ;
}
type t =
| Identity of Phase.t
| Single of Phase.t * single_exc
| Double of Phase.t * single_exc * single_exc
| Triple of Phase.t * single_exc * single_exc * single_exc
| Multiple of Phase.t * single_exc list
let single_of_spindet t t' =
assert (Spindeterminant.degree t t' = 1);
let d = Spindeterminant.bitstring t
and d' = Spindeterminant.bitstring t'
in
let tmp = Bitstring.logxor d d' in
let shift_left_one = Bitstring.(shift_left_one (numbits tmp)) in
let hole_z = Bitstring.logand (Spindeterminant.bitstring t ) tmp
and particle_z = Bitstring.logand (Spindeterminant.bitstring t') tmp
in
let hole = 1 + Bitstring.trailing_zeros hole_z
and particle = 1 + Bitstring.trailing_zeros particle_z
in
(* Phase calculation *)
let low, high =
if particle > hole then hole, particle
else particle, hole
in
let mask =
let h = high-1 in
let l = low in
let mask_up = shift_left_one h |> Bitstring.minus_one
and mask_dn = Bitstring.plus_one @@ Bitstring.lognot (shift_left_one l)
in Bitstring.logand mask_up mask_dn
in
let phase =
Phase.add (Phase.add (Spindeterminant.phase t) (Spindeterminant.phase t'))
(Phase.of_nperm (Bitstring.popcount @@ Bitstring.logand d mask ))
in
(hole, particle, phase)
let single_of_det t t' =
assert Determinant.(beta t = beta t' || alfa t = alfa t');
if Determinant.(beta t = beta t') then
let hole, particle, phase =
single_of_spindet (Determinant.alfa t) (Determinant.alfa t')
in
Single (phase, { hole ; particle ; spin=Spin.Alfa })
else
let hole, particle, phase =
single_of_spindet (Determinant.beta t) (Determinant.beta t')
in
Single (phase, { hole ; particle ; spin=Spin.Beta })
let multiple_of_spindet t t' =
let holes = Spindeterminant.holes_of t t'
and particles = Spindeterminant.particles_of t t'
in
let t'' =
List.fold_left (fun accu h -> Spindeterminant.annihilation h accu) t holes
in
let t'' =
List.fold_left (fun accu p -> Spindeterminant.creation p accu) t'' particles
in
assert (t' = t'' || t' = Spindeterminant.negate_phase t'');
let phase =
if Spindeterminant.phase t' = Spindeterminant.phase t'' then
Phase.Pos
else
Phase.Neg
in
(phase, List.rev @@ List.rev_map2 (fun hole particle -> (hole, particle)) holes (List.rev particles) )
let double_of_spindet t t' =
match multiple_of_spindet t t' with
| (phase, (h1,p1)::(h2,p2)::[]) -> (h1, p1, h2, p2, phase)
| _ -> invalid_arg "t and t' are not doubly excited"
let triple_of_spindet t t' =
match multiple_of_spindet t t' with
| (phase, (h1,p1)::(h2,p2)::(h3,p3)::[]) -> (h1, p1, h2, p2, h3, p3, phase)
| _ -> invalid_arg "t and t' are not doubly excited"
let multiple_of_det t t' =
let pa, a =
multiple_of_spindet (Determinant.alfa t) (Determinant.alfa t')
and pb, b =
multiple_of_spindet (Determinant.beta t) (Determinant.beta t')
in
let phase = Phase.add pa pb in
Multiple (phase, List.concat [
List.rev @@ List.rev_map (fun (hole, particle) -> { hole ; particle ; spin=Spin.Alfa }) a ;
List.rev @@ List.rev_map (fun (hole, particle) -> { hole ; particle ; spin=Spin.Beta }) b ])
let double_of_det t t' =
match multiple_of_det t t' with
| Multiple (phase, [e1 ; e2]) -> Double (phase, e1, e2)
| _ -> assert false
let triple_of_det t t' =
match multiple_of_det t t' with
| Multiple (phase, [e1 ; e2 ; e3]) -> Triple (phase, e1, e2, e3)
| _ -> assert false
let of_det t t' =
match Determinant.degree t t' with
| 0 -> if Determinant.phase t = Determinant.phase t' then
Identity Phase.Pos
else
Identity Phase.Neg
| 1 -> single_of_det t t'
| 2 -> double_of_det t t'
| 3 -> triple_of_det t t'
| _ -> multiple_of_det t t'
let pp_s_exc ppf t =
Format.fprintf ppf "@[T^{%s}_{%d->%d}@]"
(match t.spin with
| Spin.Alfa -> "\\alpha"
| Spin.Beta -> "\\beta " )
t.hole t.particle
let pp ppf t =
let phase, l =
match t with
| Identity p -> p, []
| Single (p,x) -> p, x::[]
| Double (p,x,y) -> p, x::y::[]
| Triple (p,x,y,z) -> p, x::y::z::[]
| Multiple (p,l) -> p, l
in
Format.fprintf ppf "@[%c"
(match phase with
| Phase.Pos -> '+'
| Phase.Neg -> '-' );
List.iter (fun x -> Format.fprintf ppf "@[T^{%s}_{%d->%d}@]"
(match x.spin with
| Spin.Alfa -> "\\alpha"
| Spin.Beta -> "\\beta " )
x.hole x.particle) l;
Format.fprintf ppf "@]"
let test_case () =
(*
let test_id () =
let l_a = [ 1 ; 2 ; 3 ; 5 ; 64 ]
and l_b = [ 2 ; 3 ; 5 ; 65 ] in
let det1 = Determinant.of_lists l_a l_b in
let det2 = Determinant.negate_phase det1 in
in
*)
let test_single () =
let l_a = [ 1 ; 2 ; 3 ; 5 ; 64 ]
and l_b = [ 2 ; 3 ; 5 ; 65 ] in
let det1 = Determinant.of_lists 66 l_a l_b in
let det2 = Determinant.single_excitation Spin.Alfa 3 7 det1 in
let t = single_of_det det1 det2 in
Alcotest.(check bool) "single 1" true (t = Single (Phase.Pos, { hole=3 ; particle=7 ; spin=Spin.Alfa}) );
let det2 =
Determinant.single_excitation Spin.Alfa 2 7 det1
|> Determinant.negate_phase
in
let t = single_of_det det1 det2 in
Alcotest.(check bool) "single 2" true (t = Single (Phase.Neg, { hole=2 ; particle=7 ; spin=Spin.Alfa }) );
let det2 = Determinant.single_excitation Spin.Beta 2 7 det1 in
let t = single_of_det det1 det2 in
Alcotest.(check bool) "single 3" true (t = Single (Phase.Pos, { hole=2 ; particle=7 ; spin=Spin.Beta}) );
let det2 = Determinant.single_excitation Spin.Beta 3 256 det1 in
let t = single_of_det det1 det2 in
Alcotest.(check bool) "single 4" true (t = Single (Phase.Pos, { hole=3 ; particle=256 ; spin=Spin.Beta}) );
in
let test_double () =
let l_a = [ 1 ; 2 ; 3 ; 5 ; 64 ]
and l_b = [ 2 ; 3 ; 5 ; 65 ] in
let det1 = Determinant.of_lists 66 l_a l_b in
let det2 = Determinant.double_excitation Spin.Alfa 3 7 Spin.Alfa 2 6 det1 in
let t = double_of_det det1 det2 in
Alcotest.(check bool) "double 1" true
(t = Double (Phase.Neg,
{ hole=2 ; particle=7 ; spin=Spin.Alfa},
{ hole=3 ; particle=6 ; spin=Spin.Alfa}));
in
[
"Single", `Quick, test_single;
"Double", `Quick, test_double;
]

204
CI/F12CI.ml
View File

@ -1,204 +0,0 @@
open Lacaml.D
module Ds = DeterminantSpace
module De = Determinant
module Sp = Spindeterminant
type t =
{
mo_basis : MOBasis.t ;
det_space : DeterminantSpace.t ;
ci : CI.t ;
hf12_integrals : HF12.t ;
eigensystem : (Mat.t * Vec.t) lazy_t;
}
let ci t = t.ci
let mo_basis t = t.mo_basis
let det_space t = t.det_space
let mo_class t = Ds.mo_class @@ det_space t
let eigensystem t = Lazy.force t.eigensystem
let dressing_vector ~frozen_core hf12_integrals f12_amplitudes ci =
if Parallel.master then
Printf.printf "Building dressing\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
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
let m_HF =
Lazy.force m_HF
in
let result =
Matrix.parallel_mm m_HF (Matrix.dense_of_mat f12_amplitudes)
in
if Parallel.master then
Printf.printf "dressing done\n%!";
Parallel.broadcast (lazy result)
let sum l f = List.fold_left (fun accu i -> accu +. f i) 0. l
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
in
let ci = CI.make ~n_states:state det_space in
let hf12_integrals =
HF12.make ~frozen_core ~simulation ~mo_basis ~aux_basis_filename ()
in
let ci_coef, ci_energy =
let x = Lazy.force ci.eigensystem in
Parallel.broadcast (lazy x)
in
let eigensystem = lazy (
let m_H =
Lazy.force ci.CI.m_H
in
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 =
(* delta_i = {% $\sum_j c_j H_{ij}$ %} *)
dressing_vector ~frozen_core hf12_integrals psi ci
|> Matrix.to_mat
in
(*
Format.printf "%a@." Matrix.pp_matrix @@ Matrix.dense_of_mat delta;
*)
Printf.printf "Cmax : %e\n" psi.{column_idx,state};
Printf.printf "Norm : %e\n" (sqrt (gemm ~transa:`T delta delta).{state,state});
let f = 1.0 /. psi.{column_idx,state} in
let delta_00 =
(* Delta_00 = {% $\sum_{j \ne x} delta_j c_j / c_x$ %} *)
f *. ( (gemm ~transa:`T delta psi).{state,state} -.
delta.{column_idx,state} *. psi.{column_idx,state} )
in
Printf.printf "Delta_00 : %e %e\n" delta.{column_idx,state} delta_00;
delta.{column_idx,state} <- delta.{column_idx,state} -. delta_00;
let eigenvectors, eigenvalues =
let delta = lacpy delta in
Mat.scal f delta;
for k=1 to state-1 do
for i=1 to Mat.dim1 delta do
delta.{i,k} <- delta.{i,state}
done;
done;
let diagonal =
Vec.init (Matrix.dim1 m_H) (fun i ->
if i = column_idx then
Matrix.get m_H i i +. delta.{column_idx,state}
else
Matrix.get m_H i i
)
in
let matrix_prod c =
let w =
Matrix.mm ~transa:`T c m_H
|> Matrix.transpose
|> Matrix.to_mat
in
let c = Matrix.to_mat c in
for k=1 to state do
for i=1 to (Mat.dim1 w) do
w.{i,k} <- w.{i,k} +. delta.{i,k} *. c.{column_idx, k} ;
w.{column_idx,k} <- w.{column_idx,k} +. delta.{i,k} *. c.{i,k};
done;
w.{column_idx,k} <- w.{column_idx,k} -.
delta.{column_idx,k} *. c.{column_idx,k};
done;
Matrix.dense_of_mat w
in
Parallel.broadcast (lazy (
Davidson.make ~threshold:1.e-10 ~guess:psi ~n_states:state diagonal matrix_prod
))
in
let eigenvectors =
Conventions.rephase @@ Util.remove_epsilons eigenvectors
in
Vec.iter (fun energy -> Printf.printf "%g\t" energy) eigenvalues;
print_newline ();
let conv =
1.0 -. abs_float ( dot
(Mat.to_col_vecs psi).(0)
(Mat.to_col_vecs eigenvectors).(0) )
in
if Parallel.master then
Printf.printf "F12 Convergence : %e %f\n" conv (eigenvalues.{state}
+. Simulation.nuclear_repulsion simulation);
if conv > threshold then
iteration ~state eigenvectors
else
let eigenvalues =
Vec.map (fun x -> x +. ci.CI.e_shift) eigenvalues
in
eigenvectors, eigenvalues
in
iteration ~state ci_coef
)
in
{ mo_basis ; det_space ; ci ; hf12_integrals ; eigensystem }

31
CI/Phase.ml
View File

@ -1,31 +0,0 @@
type t =
| Pos
| Neg
let of_nperm nperm =
if (nperm land 1) = 1 then Neg
else Pos
let to_nperm = function
| Pos -> 0
| Neg -> 1
let add t t' =
match t, t' with
| Pos, Pos
| Neg, Neg -> Pos
| Pos, Neg
| Neg, Pos -> Neg
let neg = function
| Pos -> Neg
| Neg -> Pos
let add_nperm phase = function
| 0 -> phase
| nperm -> add phase (of_nperm nperm)
let pp ppf = function
| Pos -> Format.fprintf ppf "@[<h>+1@]"
| Neg -> Format.fprintf ppf "@[<h>-1@]"

22
CI/Phase.mli
View File

@ -1,22 +0,0 @@
type t =
| Pos
| Neg
val of_nperm : int -> t
(** Returns the phase obtained by a given number of permuations. *)
val to_nperm : t -> int
(** Converts the phase to [1] or [0] permutations. *)
val add : t -> t -> t
(** Add a given phase to an existing phase. *)
val add_nperm : t -> int -> t
(** Add to an existing phase a given number of permutations. *)
val neg : t -> t
(** Negate the phase. *)
(** {1 Printers} *)
val pp : Format.formatter -> t -> unit

249
CI/Spindeterminant.ml
View File

@ -1,249 +0,0 @@
type s =
{
bitstring : Bitstring.t;
phase : Phase.t ;
}
type t = s option
type hole = int
type particle = int
let phase = function
| Some s -> s.phase
| None -> Phase.Pos
let is_none = function
| None -> true
| _ -> false
let bitstring = function
| Some s -> s.bitstring
| None -> invalid_arg "Spindeterminant is None"
let vac n =
Some { bitstring = Bitstring.zero n;
phase = Phase.Pos; }
let creation p = function
| None -> None
| Some spindet ->
let i = pred p in
if Bitstring.testbit spindet.bitstring i then
None
else
begin
let numbits = Bitstring.numbits spindet.bitstring in
let x = Bitstring.shift_left_one numbits i in
let bitstring = Bitstring.logor spindet.bitstring x in
let mask = Bitstring.minus_one x in
let r = Bitstring.logand bitstring mask in
let phase = Phase.add_nperm spindet.phase (Bitstring.popcount r) in
Some { bitstring ; phase }
end
let annihilation h = function
| None -> None
| Some spindet ->
let i = pred h in
if not (Bitstring.testbit spindet.bitstring i) then
None
else
begin
let numbits = Bitstring.numbits spindet.bitstring in
let x = Bitstring.shift_left_one numbits i in
let mask = Bitstring.minus_one x in
let r = Bitstring.logand spindet.bitstring mask in
let phase = Phase.add_nperm spindet.phase (Bitstring.popcount r) in
let bitstring = Bitstring.logand spindet.bitstring (Bitstring.lognot x) in
Some { bitstring ; phase }
end
let single_excitation_reference h p spindet =
creation p @@ annihilation h @@ spindet
let single_excitation h p =
single_excitation_reference h p
let double_excitation_reference h' p' h p spindet =
creation p' @@ creation p @@ annihilation h @@ annihilation h' @@ spindet
let double_excitation h' p' h p =
double_excitation_reference h' p' h p
let degree t t' =
Bitstring.hamdist (bitstring t) (bitstring t') / 2
let holes_of t t' =
Bitstring.logand (bitstring t) (Bitstring.logxor (bitstring t) (bitstring t'))
|> Bitstring.to_list
let particles_of t t' =
Bitstring.logand (bitstring t') (Bitstring.logxor (bitstring t) (bitstring t'))
|> Bitstring.to_list
let holes_particles_of t t' =
let x = Bitstring.logxor (bitstring t) (bitstring t') in
let holes = Bitstring.logand (bitstring t) x |> Bitstring.to_list
and particles = Bitstring.logand (bitstring t') x |> Bitstring.to_list
in
List.rev_map2 (fun h p -> (h,p)) holes particles
|> List.rev
let set_phase p = function
| Some t -> Some { t with phase = p }
| None -> None
let negate_phase = function
| Some t -> Some { t with phase = Phase.neg t.phase }
| None -> None
let of_bitstring ?(phase=Phase.Pos) bitstring =
Some { bitstring ; phase }
let of_list n l =
List.rev l
|> List.fold_left (fun accu p -> creation p accu) (vac n)
let to_list = function
| None -> []
| Some spindet ->
let rec aux accu z =
if not (Bitstring.is_zero z) then
let element = ((Bitstring.trailing_zeros z)+1) in
(aux [@tailcall]) (element::accu) (Bitstring.logand z (Bitstring.minus_one z) )
else List.rev accu
in aux [] spindet.bitstring
let to_array t =
to_list t
|> Array.of_list
let n_electrons = function
| Some t -> Bitstring.popcount t.bitstring
| None -> 0
let pp n ppf = function
| None -> Format.fprintf ppf "@[<h>None@]"
| Some s ->
Format.fprintf ppf "@[<h>%a %a@]" Phase.pp s.phase Bitstring.pp
s.bitstring
(*-----------------------------------------------------------------------------------*)
let test_case () =
let test_creation () =
let l_a = [ 1 ; 2 ; 3 ; 5 ] in
let det = of_list 10 l_a in
Alcotest.(check (list int )) "bitstring 1" l_a (to_list det);
Alcotest.(check bool) "phase 2" true (phase det = Phase.Pos);
let l_b = [ 1 ; 3 ; 2 ; 5 ] in
let det = of_list 10 l_b in
Alcotest.(check (list int )) "bitstring 2" l_a (to_list det);
Alcotest.(check bool) "phase 2" true (phase det = Phase.Neg);
in
let test_a_operators () =
let det =
creation 5 @@ creation 2 @@ creation 2 @@ creation 1 @@ (vac 10)
in
Alcotest.(check bool) "none 1" true (is_none det);
let det =
creation 5 @@ creation 3 @@ creation 2 @@ creation 1 @@ (vac 10)
in
let l_a = [ 1 ; 2 ; 3 ; 5 ] in
Alcotest.(check (list int )) "bitstring 1" l_a (to_list det);
Alcotest.(check bool) "phase 1" true (phase det = Phase.Pos);
let det =
creation 1 @@ creation 3 @@ creation 2 @@ creation 5 @@ (vac 10)
in
Alcotest.(check (list int )) "bitstring 2" l_a (to_list det);
Alcotest.(check bool) "phase 2" true (phase det = Phase.Neg);
let l_b = [ 1 ; 3 ; 2 ; 5 ] in
let det = of_list 10 l_b in
Alcotest.(check (list int )) "bitstring 3" l_a (to_list det);
Alcotest.(check bool) "phase 3" true (phase det = Phase.Neg);
Alcotest.(check bool) "none 1" true (annihilation 4 det |> is_none);
let det =
annihilation 1 det
in
Alcotest.(check (list int )) "bitstring 4" (List.tl l_a) (to_list det);
Alcotest.(check bool) "phase 4" true (phase det = Phase.Neg);
let det =
annihilation 3 det
in
Alcotest.(check (list int )) "bitstring 5" [ 2 ; 5 ] (to_list det);
Alcotest.(check bool) "phase 5" true (phase det = Phase.Pos);
let det =
annihilation 5 @@ annihilation 2 det
in
Alcotest.(check (list int )) "bitstring 6" [] (to_list det);
Alcotest.(check bool) "phase 6" true (phase det = Phase.Pos);
in
let test_exc_operators () =
let l_a = [ 1 ; 2 ; 3 ; 5 ] in
let det = of_list 10 l_a in
let l_b = [ 1 ; 7 ; 3 ; 5 ] in
let det2 = of_list 10 l_b in
Format.printf "%a@." (pp 7) det;
Format.printf "%a@." (pp 7) det2;
Format.printf "%a@." (pp 7) (single_excitation_reference 2 7 det);
Alcotest.(check bool) "single 1" true (single_excitation_reference 2 7 det = det2);
Alcotest.(check bool) "single 2" true (single_excitation 2 7 det = single_excitation_reference 2 7 det);
Alcotest.(check bool) "single 3" true (single_excitation_reference 4 7 det |> is_none);
Alcotest.(check bool) "single 4" true (single_excitation 4 7 det |> is_none);
let l_c = [ 1 ; 7 ; 6 ; 5 ] in
let det3 = of_list 10 l_c in
Alcotest.(check bool) "double 1" true (double_excitation_reference 2 7 3 6 det = det3);
Alcotest.(check bool) "double 2" true (double_excitation 2 7 3 6 det = double_excitation_reference 2 7 3 6 det);
Alcotest.(check bool) "double 3" true (double_excitation_reference 4 7 3 6 det |> is_none);
Alcotest.(check bool) "double 4" true (double_excitation 4 7 3 6 det |> is_none);
in
let test_exc_spindet () =
let l_a = [ 1 ; 2 ; 3 ; 5 ] in
let det = of_list 10 l_a in
let l_b = [ 1 ; 7 ; 3 ; 5 ] in
let det2 = of_list 10 l_b in
Alcotest.(check int) "single" 1 (degree det det2);
Alcotest.(check (list int)) "holes" [2] (holes_of det det2);
Alcotest.(check (list int)) "particles" [7] (particles_of det det2);
let l_b = [ 1 ; 7 ; 3 ; 6 ] in
let det2 = of_list 10 l_b in
Alcotest.(check int) "double" 2 (degree det det2);
Alcotest.(check (list int)) "holes" [2 ; 5] (holes_of det det2);
Alcotest.(check (list int)) "particles" [6 ; 7] (particles_of det det2);
in
[
"Creation", `Quick, test_creation;
"Creation/Annihilation Operators", `Quick, test_a_operators;
"Excitation Operators", `Quick, test_exc_operators;
"Excitation of spindet", `Quick, test_exc_spindet;
]

94
CI/Spindeterminant.mli
View File

@ -1,94 +0,0 @@
(**
A spin-determinant is one of the two determinants in the Waller-Hartree
double determinant representation of a Slater determinant. It is represented
as a bit string and a phase factor.
*)
type t
type hole = int
type particle = int
(** {1 Accessors}. *)
val phase : t -> Phase.t
(** Phase factor.
@raise Invalid_argument if the spin-determinant is [None].
*)
val set_phase : Phase.t -> t -> t
(** Returns a spin-determinant with the phase set to [p]. *)
val bitstring : t -> Bitstring.t
(** Bit string.
@raise Invalid_argument if the spin-determinant is [None].
*)
val is_none : t -> bool
(** Tests if a spin-determinant is [None]. *)
val negate_phase : t -> t
(** Returns a spin-determinant with the phase reversed. *)
(** {1 Second quantization operators} *)
val vac : int -> t
(** Vacuum state, [vac = Some ]{% $|\rangle$ %}. The integer parameter contains the
number of orbitals in the basis set. *)
val creation : particle -> t -> t
(** [creation p] is the creation operator {% $a^\dagger_p$ %}. *)
val annihilation : hole -> t -> t
(** [annihilation h] is the annihilation operator {% $a_h$ %}. *)
val single_excitation : hole -> particle -> t -> t
(** Single excitation operator {% $T_h^p = a^\dagger_p a_h$ %}. *)
val double_excitation : hole -> particle -> hole -> particle -> t -> t
(** Double excitation operator {% $T_{hh'}^{pp'} = a^\dagger_p a^\dagger_{p'} a_{h'} a_h$ %}. *)
val degree : t -> t -> int
(** Returns degree of excitation between two spin-determinants. *)
val holes_of : t -> t -> int list
(** Returns the list of holes in the excitation from one determinant to another. *)
val particles_of : t -> t -> int list
(** Returns the list of particles in the excitation from one determinant to another. *)
val holes_particles_of : t -> t -> (int*int) list
(** Returns the list of pairs of holes/particles in the excitation from one determinant to
another. *)
val n_electrons : t -> int
(** Returns the number of electrons in the determinant. *)
(** {1 Creation} *)
val of_bitstring : ?phase:Phase.t -> Bitstring.t -> t
(** Creates from a bitstring and an optional phase.*)
val of_list : int -> int list -> t
(** Builds a spin-determinant from a list of orbital indices. If the creation of the
spin-determinant is not possible because of Pauli's exclusion principle, a [None]
spin-determinant is returned.
The first integer is the size of the MO basis set. *)
val to_list : t -> int list
(** Transforms a spin-determinant into a list of orbital indices. *)
val to_array : t -> int array
(** Transforms a spin-determinant into an array of orbital indices. *)
(** {1 Printers}. *)
val pp : int -> Format.formatter -> t -> unit
(** First [int] is the number of MOs to print *)
(** {1 Unit testing} *)
val test_case : unit -> (string * [> `Quick ] * (unit -> unit)) list

74
CI/SpindeterminantSpace.ml
View File

@ -1,74 +0,0 @@
type t =
{
elec_num : int;
mo_basis : MOBasis.t;
mo_class : MOClass.t;
spin_determinants : Spindeterminant.t array;
}
let spin_determinants t = t.spin_determinants
let elec_num t = t.elec_num
let mo_basis t = t.mo_basis
let mo_class t = t.mo_class
let size t = Array.length t.spin_determinants
let fci_of_mo_basis ~frozen_core mo_basis elec_num =
let mo_num = MOBasis.size mo_basis in
let mo_class = MOClass.fci ~frozen_core mo_basis 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 occ_mask = m (MOClass.core_mos mo_class)
and active_mask = m (MOClass.active_mos mo_class)
in
let neg_active_mask = Bitstring.lognot active_mask in
(* Here we generate the FCI space and filter out unwanted determinants
with excitations involving the core electrons. This should be improved. *)
let spin_determinants =
Bitstring.permtutations elec_num mo_num
|> List.filter (fun b -> Bitstring.logand neg_active_mask b = occ_mask)
|> Array.of_list
|> Array.map (fun b -> Spindeterminant.of_bitstring b)
in
{ elec_num ; mo_basis ; mo_class ; spin_determinants }
let cas_of_mo_basis mo_basis ~frozen_core elec_num n m =
let mo_num = MOBasis.size mo_basis in
let mo_class = MOClass.cas_sd ~frozen_core mo_basis n m 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 active_mask = m (MOClass.active_mos mo_class) in
let occ_mask = m (MOClass.core_mos mo_class) in
let inactive_mask = m (MOClass.inactive_mos mo_class) in
let occ_mask = Bitstring.logor occ_mask inactive_mask in
let neg_active_mask = Bitstring.lognot active_mask in
(* Here we generate the FCI space and filter out all the unwanted determinants.
This should be improved. *)
let spin_determinants =
Bitstring.permtutations elec_num mo_num
|> List.filter (fun b -> Bitstring.logand neg_active_mask b = occ_mask)
|> Array.of_list
|> Array.map (fun b -> Spindeterminant.of_bitstring b)
in
{ elec_num ; mo_basis ; mo_class ; spin_determinants }
let pp ppf t =
Format.fprintf ppf "@[<v 2> [";
let pp = Spindeterminant.pp @@ MOBasis.size (mo_basis t) in
Array.iteri (fun i d ->
Format.fprintf ppf "@[<v>@[%8d@] @[%a@]@]@;" i pp d)
(spin_determinants t) ;
Format.fprintf ppf "]@]"

46
CI/SpindeterminantSpace.mli
View File

@ -1,46 +0,0 @@
(**
The space built with determinants made with same-spin spinorbitals.
*)
type t
(** {1 Accessors} *)
val size : t -> int
(** Number of determinants in the space. *)
val spin_determinants : t -> Spindeterminant.t array
(** All the spin-determinants belonging to the space. *)
val elec_num : t -> int
(** Number of (same-spin) electrons occupying the MOs. *)
val mo_class : t -> MOClass.t
(** The MO classes used to generate the space. *)
val mo_basis : t -> MOBasis.t
(** The MO basis on which the determinants are expanded. *)
(** {1 Creation} *)
val fci_of_mo_basis : frozen_core:bool -> MOBasis.t -> int -> t
(** Create a space of all possible ways to put [n_elec-ncore] electrons in the
[Active] MOs. All other MOs are untouched.
*)
val cas_of_mo_basis : MOBasis.t -> frozen_core:bool -> int -> int -> int -> t
(** [cas_of_mo_basis mo_basis n_elec n m] creates a CAS(n,m) space of
[Active] MOs. The unoccupied MOs are [Virtual], and the occupied MOs
are [Core] and [Inactive].
*)
(** {2 Printing} *)
val pp : Format.formatter -> t -> unit

84
INSTALL.md
View File

@ -1,84 +0,0 @@
# Generic installation
```bash
opam install ocamlbuild ocamlfind lacaml mpi getopt alcotest zarith
```
# BLAS/Lapack
Install OpenBLAS from your system package manager, for example:
```bash
sudo apt-get install libopenblas-dev
```
# LaCAML
LaCAML is the OCaml binding to the LAPACK library.
```bash
opam install lacaml
```
To use MKL with LaCaml:
```bash
export LACAML_LIBS="-L${MKLROOT}/lib/intel64 -Wl,--no-as-needed -lmkl_rt -lpthread -lm -ldl"
opam install lacaml
```
# MPI
MPI is the Message Passing Interface, required for distributed parallelism.
For large MPI calculations, a version >= 4.09.0 of the compiler is required.
```bash
opam install mpi
```
To use Intel MPI
```bash
export MPI_INC_DIR=${I_MPI_ROOT}/include64/
export MPI_LIB_DIR=${I_MPI_ROOT}/lib64/
export MPI_BIN_PATH=${I_MPI_ROOT}/bin64/
opam install mpi
```
# odoc-ltxhtml
This plugin allows to embed equations in the documentation generated by Ocamldoc.
Download the source code [here](https://github.com/scemama/odoc-ltxhtml).
```bash
git clone https://github.com/scemama/odoc-ltxhtml
cd odoc-ltxhtml
make install
```
# Getopt
Parsing of command line arguments (similar to GNU GetOpt)
```bash
opam install getopt
```
# Alcotest
Lightweight and colourful test framework
```bash
opam install alcotest
```
# Zarith
Implements arithmetic and logical operations over arbitrary-precision integer
```bash
opam install zarith
```

674
LICENSE
View File

@ -1,674 +0,0 @@
GNU GENERAL PUBLIC LICENSE
Version 3, 29 June 2007
Copyright (C) 2007 Free Software Foundation, Inc. <http://fsf.org/>
Everyone is permitted to copy and distribute verbatim copies
of this license document, but changing it is not allowed.
Preamble
The GNU General Public License is a free, copyleft license for
software and other kinds of works.
The licenses for most software and other practical works are designed
to take away your freedom to share and change the works. By contrast,
the GNU General Public License is intended to guarantee your freedom to
share and change all versions of a program--to make sure it remains free
software for all its users. We, the Free Software Foundation, use the
GNU General Public License for most of our software; it applies also to
any other work released this way by its authors. You can apply it to
your programs, too.
When we speak of free software, we are referring to freedom, not
price. Our General Public Licenses are designed to make sure that you
have the freedom to distribute copies of free software (and charge for
them if you wish), that you receive source code or can get it if you
want it, that you can change the software or use pieces of it in new
free programs, and that you know you can do these things.
To protect your rights, we need to prevent others from denying you
these rights or asking you to surrender the rights. Therefore, you have
certain responsibilities if you distribute copies of the software, or if
you modify it: responsibilities to respect the freedom of others.
For example, if you distribute copies of such a program, whether
gratis or for a fee, you must pass on to the recipients the same
freedoms that you received. You must make sure that they, too, receive
or can get the source code. And you must show them these terms so they
know their rights.
Developers that use the GNU GPL protect your rights with two steps:
(1) assert copyright on the software, and (2) offer you this License
giving you legal permission to copy, distribute and/or modify it.
For the developers' and authors' protection, the GPL clearly explains
that there is no warranty for this free software. For both users' and
authors' sake, the GPL requires that modified versions be marked as
changed, so that their problems will not be attributed erroneously to
authors of previous versions.
Some devices are designed to deny users access to install or run
modified versions of the software inside them, although the manufacturer
can do so. This is fundamentally incompatible with the aim of
protecting users' freedom to change the software. The systematic
pattern of such abuse occurs in the area of products for individuals to
use, which is precisely where it is most unacceptable. Therefore, we
have designed this version of the GPL to prohibit the practice for those
products. If such problems arise substantially in other domains, we
stand ready to extend this provision to those domains in future versions
of the GPL, as needed to protect the freedom of users.
Finally, every program is threatened constantly by software patents.
States should not allow patents to restrict development and use of
software on general-purpose computers, but in those that do, we wish to
avoid the special danger that patents applied to a free program could
make it effectively proprietary. To prevent this, the GPL assures that
patents cannot be used to render the program non-free.
The precise terms and conditions for copying, distribution and
modification follow.
TERMS AND CONDITIONS
0. Definitions.
"This License" refers to version 3 of the GNU General Public License.
"Copyright" also means copyright-like laws that apply to other kinds of
works, such as semiconductor masks.
"The Program" refers to any copyrightable work licensed under this
License. Each licensee is addressed as "you". "Licensees" and
"recipients" may be individuals or organizations.
To "modify" a work means to copy from or adapt all or part of the work
in a fashion requiring copyright permission, other than the making of an
exact copy. The resulting work is called a "modified version" of the
earlier work or a work "based on" the earlier work.
A "covered work" means either the unmodified Program or a work based
on the Program.
To "propagate" a work means to do anything with it that, without
permission, would make you directly or secondarily liable for
infringement under applicable copyright law, except executing it on a
computer or modifying a private copy. Propagation includes copying,
distribution (with or without modification), making available to the
public, and in some countries other activities as well.
To "convey" a work means any kind of propagation that enables other
parties to make or receive copies. Mere interaction with a user through
a computer network, with no transfer of a copy, is not conveying.
An interactive user interface displays "Appropriate Legal Notices"
to the extent that it includes a convenient and prominently visible
feature that (1) displays an appropriate copyright notice, and (2)
tells the user that there is no warranty for the work (except to the
extent that warranties are provided), that licensees may convey the
work under this License, and how to view a copy of this License. If
the interface presents a list of user commands or options, such as a
menu, a prominent item in the list meets this criterion.
1. Source Code.
The "source code" for a work means the preferred form of the work
for making modifications to it. "Object code" means any non-source
form of a work.
A "Standard Interface" means an interface that either is an official
standard defined by a recognized standards body, or, in the case of
interfaces specified for a particular programming language, one that
is widely used among developers working in that language.
The "System Libraries" of an executable work include anything, other
than the work as a whole, that (a) is included in the normal form of
packaging a Major Component, but which is not part of that Major
Component, and (b) serves only to enable use of the work with that
Major Component, or to implement a Standard Interface for which an
implementation is available to the public in source code form. A
"Major Component", in this context, means a major essential component
(kernel, window system, and so on) of the specific operating system
(if any) on which the executable work runs, or a compiler used to
produce the work, or an object code interpreter used to run it.
The "Corresponding Source" for a work in object code form means all
the source code needed to generate, install, and (for an executable
work) run the object code and to modify the work, including scripts to
control those activities. However, it does not include the work's
System Libraries, or general-purpose tools or generally available free
programs which are used unmodified in performing those activities but
which are not part of the work. For example, Corresponding Source
includes interface definition files associated with source files for
the work, and the source code for shared libraries and dynamically
linked subprograms that the work is specifically designed to require,
such as by intimate data communication or control flow between those
subprograms and other parts of the work.
The Corresponding Source need not include anything that users
can regenerate automatically from other parts of the Corresponding
Source.
The Corresponding Source for a work in source code form is that
same work.
2. Basic Permissions.
All rights granted under this License are granted for the term of
copyright on the Program, and are irrevocable provided the stated
conditions are met. This License explicitly affirms your unlimited
permission to run the unmodified Program. The output from running a
covered work is covered by this License only if the output, given its
content, constitutes a covered work. This License acknowledges your
rights of fair use or other equivalent, as provided by copyright law.
You may make, run and propagate covered works that you do not
convey, without conditions so long as your license otherwise remains
in force. You may convey covered works to others for the sole purpose
of having them make modifications exclusively for you, or provide you
with facilities for running those works, provided that you comply with
the terms of this License in conveying all material for which you do
not control copyright. Those thus making or running the covered works
for you must do so exclusively on your behalf, under your direction
and control, on terms that prohibit them from making any copies of
your copyrighted material outside their relationship with you.
Conveying under any other circumstances is permitted solely under
the conditions stated below. Sublicensing is not allowed; section 10
makes it unnecessary.
3. Protecting Users' Legal Rights From Anti-Circumvention Law.
No covered work shall be deemed part of an effective technological
measure under any applicable law fulfilling obligations under article
11 of the WIPO copyright treaty adopted on 20 December 1996, or
similar laws prohibiting or restricting circumvention of such
measures.
When you convey a covered work, you waive any legal power to forbid
circumvention of technological measures to the extent such circumvention
is effected by exercising rights under this License with respect to
the covered work, and you disclaim any intention to limit operation or
modification of the work as a means of enforcing, against the work's
users, your or third parties' legal rights to forbid circumvention of
technological measures.
4. Conveying Verbatim Copies.
You may convey verbatim copies of the Program's source code as you
receive it, in any medium, provided that you conspicuously and
appropriately publish on each copy an appropriate copyright notice;
keep intact all notices stating that this License and any
non-permissive terms added in accord with section 7 apply to the code;
keep intact all notices of the absence of any warranty; and give all
recipients a copy of this License along with the Program.
You may charge any price or no price for each copy that you convey,
and you may offer support or warranty protection for a fee.
5. Conveying Modified Source Versions.
You may convey a work based on the Program, or the modifications to
produce it from the Program, in the form of source code under the
terms of section 4, provided that you also meet all of these conditions:
a) The work must carry prominent notices stating that you modified
it, and giving a relevant date.
b) The work must carry prominent notices stating that it is
released under this License and any conditions added under section
7. This requirement modifies the requirement in section 4 to
"keep intact all notices".
c) You must license the entire work, as a whole, under this
License to anyone who comes into possession of a copy. This
License will therefore apply, along with any applicable section 7
additional terms, to the whole of the work, and all its parts,
regardless of how they are packaged. This License gives no
permission to license the work in any other way, but it does not
invalidate such permission if you have separately received it.
d) If the work has interactive user interfaces, each must display
Appropriate Legal Notices; however, if the Program has interactive
interfaces that do not display Appropriate Legal Notices, your
work need not make them do so.
A compilation of a covered work with other separate and independent
works, which are not by their nature extensions of the covered work,
and which are not combined with it such as to form a larger program,
in or on a volume of a storage or distribution medium, is called an
"aggregate" if the compilation and its resulting copyright are not
used to limit the access or legal rights of the compilation's users
beyond what the individual works permit. Inclusion of a covered work
in an aggregate does not cause this License to apply to the other
parts of the aggregate.
6. Conveying Non-Source Forms.
You may convey a covered work in object code form under the terms
of sections 4 and 5, provided that you also convey the
machine-readable Corresponding Source under the terms of this License,
in one of these ways:
a) Convey the object code in, or embodied in, a physical product
(including a physical distribution medium), accompanied by the
Corresponding Source fixed on a durable physical medium
customarily used for software interchange.
b) Convey the object code in, or embodied in, a physical product
(including a physical distribution medium), accompanied by a
written offer, valid for at least three years and valid for as
long as you offer spare parts or customer support for that product
model, to give anyone who possesses the object code either (1) a
copy of the Corresponding Source for all the software in the
product that is covered by this License, on a durable physical
medium customarily used for software interchange, for a price no
more than your reasonable cost of physically performing this
conveying of source, or (2) access to copy the
Corresponding Source from a network server at no charge.
c) Convey individual copies of the object code with a copy of the
written offer to provide the Corresponding Source. This
alternative is allowed only occasionally and noncommercially, and
only if you received the object code with such an offer, in accord
with subsection 6b.
d) Convey the object code by offering access from a designated
place (gratis or for a charge), and offer equivalent access to the
Corresponding Source in the same way through the same place at no
further charge. You need not require recipients to copy the
Corresponding Source along with the object code. If the place to
copy the object code is a network server, the Corresponding Source
may be on a different server (operated by you or a third party)
that supports equivalent copying facilities, provided you maintain
clear directions next to the object code saying where to find the
Corresponding Source. Regardless of what server hosts the
Corresponding Source, you remain obligated to ensure that it is
available for as long as needed to satisfy these requirements.
e) Convey the object code using peer-to-peer transmission, provided
you inform other peers where the object code and Corresponding
Source of the work are being offered to the general public at no
charge under subsection 6d.
A separable portion of the object code, whose source code is excluded
from the Corresponding Source as a System Library, need not be
included in conveying the object code work.
A "User Product" is either (1) a "consumer product", which means any
tangible personal property which is normally used for personal, family,
or household purposes, or (2) anything designed or sold for incorporation
into a dwelling. In determining whether a product is a consumer product,
doubtful cases shall be resolved in favor of coverage. For a particular
product received by a particular user, "normally used" refers to a
typical or common use of that class of product, regardless of the status
of the particular user or of the way in which the particular user
actually uses, or expects or is expected to use, the product. A product
is a consumer product regardless of whether the product has substantial
commercial, industrial or non-consumer uses, unless such uses represent
the only significant mode of use of the product.
"Installation Information" for a User Product means any methods,
procedures, authorization keys, or other information required to install
and execute modified versions of a covered work in that User Product from
a modified version of its Corresponding Source. The information must
suffice to ensure that the continued functioning of the modified object
code is in no case prevented or interfered with solely because
modification has been made.
If you convey an object code work under this section in, or with, or
specifically for use in, a User Product, and the conveying occurs as
part of a transaction in which the right of possession and use of the
User Product is transferred to the recipient in perpetuity or for a
fixed term (regardless of how the transaction is characterized), the
Corresponding Source conveyed under this section must be accompanied
by the Installation Information. But this requirement does not apply
if neither you nor any third party retains the ability to install
modified object code on the User Product (for example, the work has
been installed in ROM).
The requirement to provide Installation Information does not include a
requirement to continue to provide support service, warranty, or updates
for a work that has been modified or installed by the recipient, or for
the User Product in which it has been modified or installed. Access to a
network may be denied when the modification itself materially and
adversely affects the operation of the network or violates the rules and
protocols for communication across the network.
Corresponding Source conveyed, and Installation Information provided,
in accord with this section must be in a format that is publicly
documented (and with an implementation available to the public in
source code form), and must require no special password or key for
unpacking, reading or copying.
7. Additional Terms.
"Additional permissions" are terms that supplement the terms of this
License by making exceptions from one or more of its conditions.
Additional permissions that are applicable to the entire Program shall
be treated as though they were included in this License, to the extent
that they are valid under applicable law. If additional permissions
apply only to part of the Program, that part may be used separately
under those permissions, but the entire Program remains governed by
this License without regard to the additional permissions.
When you convey a copy of a covered work, you may at your option
remove any additional permissions from that copy, or from any part of
it. (Additional permissions may be written to require their own
removal in certain cases when you modify the work.) You may place
additional permissions on material, added by you to a covered work,
for which you have or can give appropriate copyright permission.
Notwithstanding any other provision of this License, for material you
add to a covered work, you may (if authorized by the copyright holders of
that material) supplement the terms of this License with terms:
a) Disclaiming warranty or limiting liability differently from the
terms of sections 15 and 16 of this License; or
b) Requiring preservation of specified reasonable legal notices or
author attributions in that material or in the Appropriate Legal
Notices displayed by works containing it; or
c) Prohibiting misrepresentation of the origin of that material, or
requiring that modified versions of such material be marked in
reasonable ways as different from the original version; or
d) Limiting the use for publicity purposes of names of licensors or
authors of the material; or
e) Declining to grant rights under trademark law for use of some
trade names, trademarks, or service marks; or
f) Requiring indemnification of licensors and authors of that
material by anyone who conveys the material (or modified versions of
it) with contractual assumptions of liability to the recipient, for
any liability that these contractual assumptions directly impose on
those licensors and authors.
All other non-permissive additional terms are considered "further
restrictions" within the meaning of section 10. If the Program as you
received it, or any part of it, contains a notice stating that it is
governed by this License along with a term that is a further
restriction, you may remove that term. If a license document contains
a further restriction but permits relicensing or conveying under this
License, you may add to a covered work material governed by the terms
of that license document, provided that the further restriction does
not survive such relicensing or conveying.
If you add terms to a covered work in accord with this section, you
must place, in the relevant source files, a statement of the
additional terms that apply to those files, or a notice indicating
where to find the applicable terms.
Additional terms, permissive or non-permissive, may be stated in the
form of a separately written license, or stated as exceptions;
the above requirements apply either way.
8. Termination.
You may not propagate or modify a covered work except as expressly
provided under this License. Any attempt otherwise to propagate or
modify it is void, and will automatically terminate your rights under
this License (including any patent licenses granted under the third
paragraph of section 11).
However, if you cease all violation of this License, then your
license from a particular copyright holder is reinstated (a)
provisionally, unless and until the copyright holder explicitly and
finally terminates your license, and (b) permanently, if the copyright
holder fails to notify you of the violation by some reasonable means
prior to 60 days after the cessation.
Moreover, your license from a particular copyright holder is
reinstated permanently if the copyright holder notifies you of the
violation by some reasonable means, this is the first time you have
received notice of violation of this License (for any work) from that
copyright holder, and you cure the violation prior to 30 days after
your receipt of the notice.
Termination of your rights under this section does not terminate the
licenses of parties who have received copies or rights from you under
this License. If your rights have been terminated and not permanently
reinstated, you do not qualify to receive new licenses for the same
material under section 10.
9. Acceptance Not Required for Having Copies.
You are not required to accept this License in order to receive or
run a copy of the Program. Ancillary propagation of a covered work
occurring solely as a consequence of using peer-to-peer transmission
to receive a copy likewise does not require acceptance. However,
nothing other than this License grants you permission to propagate or
modify any covered work. These actions infringe copyright if you do
not accept this License. Therefore, by modifying or propagating a
covered work, you indicate your acceptance of this License to do so.
10. Automatic Licensing of Downstream Recipients.
Each time you convey a covered work, the recipient automatically
receives a license from the original licensors, to run, modify and
propagate that work, subject to this License. You are not responsible
for enforcing compliance by third parties with this License.
An "entity transaction" is a transaction transferring control of an
organization, or substantially all assets of one, or subdividing an
organization, or merging organizations. If propagation of a covered
work results from an entity transaction, each party to that
transaction who receives a copy of the work also receives whatever
licenses to the work the party's predecessor in interest had or could
give under the previous paragraph, plus a right to possession of the
Corresponding Source of the work from the predecessor in interest, if
the predecessor has it or can get it with reasonable efforts.
You may not impose any further restrictions on the exercise of the
rights granted or affirmed under this License. For example, you may
not impose a license fee, royalty, or other charge for exercise of
rights granted under this License, and you may not initiate litigation
(including a cross-claim or counterclaim in a lawsuit) alleging that
any patent claim is infringed by making, using, selling, offering for
sale, or importing the Program or any portion of it.
11. Patents.
A "contributor" is a copyright holder who authorizes use under this
License of the Program or a work on which the Program is based. The
work thus licensed is called the contributor's "contributor version".
A contributor's "essential patent claims" are all patent claims
owned or controlled by the contributor, whether already acquired or
hereafter acquired, that would be infringed by some manner, permitted
by this License, of making, using, or selling its contributor version,
but do not include claims that would be infringed only as a
consequence of further modification of the contributor version. For
purposes of this definition, "control" includes the right to grant
patent sublicenses in a manner consistent with the requirements of
this License.
Each contributor grants you a non-exclusive, worldwide, royalty-free
patent license under the contributor's essential patent claims, to
make, use, sell, offer for sale, import and otherwise run, modify and
propagate the contents of its contributor version.
In the following three paragraphs, a "patent license" is any express
agreement or commitment, however denominated, not to enforce a patent
(such as an express permission to practice a patent or covenant not to
sue for patent infringement). To "grant" such a patent license to a
party means to make such an agreement or commitment not to enforce a
patent against the party.
If you convey a covered work, knowingly relying on a patent license,
and the Corresponding Source of the work is not available for anyone
to copy, free of charge and under the terms of this License, through a
publicly available network server or other readily accessible means,
then you must either (1) cause the Corresponding Source to be so
available, or (2) arrange to deprive yourself of the benefit of the
patent license for this particular work, or (3) arrange, in a manner
consistent with the requirements of this License, to extend the patent
license to downstream recipients. "Knowingly relying" means you have
actual knowledge that, but for the patent license, your conveying the
covered work in a country, or your recipient's use of the covered work
in a country, would infringe one or more identifiable patents in that
country that you have reason to believe are valid.
If, pursuant to or in connection with a single transaction or
arrangement, you convey, or propagate by procuring conveyance of, a
covered work, and grant a patent license to some of the parties
receiving the covered work authorizing them to use, propagate, modify
or convey a specific copy of the covered work, then the patent license
you grant is automatically extended to all recipients of the covered
work and works based on it.
A patent license is "discriminatory" if it does not include within
the scope of its coverage, prohibits the exercise of, or is
conditioned on the non-exercise of one or more of the rights that are
specifically granted under this License. You may not convey a covered
work if you are a party to an arrangement with a third party that is
in the business of distributing software, under which you make payment
to the third party based on the extent of your activity of conveying
the work, and under which the third party grants, to any of the
parties who would receive the covered work from you, a discriminatory
patent license (a) in connection with copies of the covered work
conveyed by you (or copies made from those copies), or (b) primarily
for and in connection with specific products or compilations that
contain the covered work, unless you entered into that arrangement,
or that patent license was granted, prior to 28 March 2007.
Nothing in this License shall be construed as excluding or limiting
any implied license or other defenses to infringement that may
otherwise be available to you under applicable patent law.
12. No Surrender of Others' Freedom.
If conditions are imposed on you (whether by court order, agreement or
otherwise) that contradict the conditions of this License, they do not
excuse you from the conditions of this License. If you cannot convey a
covered work so as to satisfy simultaneously your obligations under this
License and any other pertinent obligations, then as a consequence you may
not convey it at all. For example, if you agree to terms that obligate you
to collect a royalty for further conveying from those to whom you convey
the Program, the only way you could satisfy both those terms and this
License would be to refrain entirely from conveying the Program.
13. Use with the GNU Affero General Public License.
Notwithstanding any other provision of this License, you have
permission to link or combine any covered work with a work licensed
under version 3 of the GNU Affero General Public License into a single
combined work, and to convey the resulting work. The terms of this
License will continue to apply to the part which is the covered work,
but the special requirements of the GNU Affero General Public License,
section 13, concerning interaction through a network will apply to the
combination as such.
14. Revised Versions of this License.
The Free Software Foundation may publish revised and/or new versions of
the GNU General Public License from time to time. Such new versions will
be similar in spirit to the present version, but may differ in detail to
address new problems or concerns.
Each version is given a distinguishing version number. If the
Program specifies that a certain numbered version of the GNU General
Public License "or any later version" applies to it, you have the
option of following the terms and conditions either of that numbered
version or of any later version published by the Free Software
Foundation. If the Program does not specify a version number of the
GNU General Public License, you may choose any version ever published
by the Free Software Foundation.
If the Program specifies that a proxy can decide which future
versions of the GNU General Public License can be used, that proxy's
public statement of acceptance of a version permanently authorizes you
to choose that version for the Program.
Later license versions may give you additional or different
permissions. However, no additional obligations are imposed on any
author or copyright holder as a result of your choosing to follow a
later version.
15. Disclaimer of Warranty.
THERE IS NO WARRANTY FOR THE PROGRAM, TO THE EXTENT PERMITTED BY
APPLICABLE LAW. EXCEPT WHEN OTHERWISE STATED IN WRITING THE COPYRIGHT
HOLDERS AND/OR OTHER PARTIES PROVIDE THE PROGRAM "AS IS" WITHOUT WARRANTY
OF ANY KIND, EITHER EXPRESSED OR IMPLIED, INCLUDING, BUT NOT LIMITED TO,
THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR
PURPOSE. THE ENTIRE RISK AS TO THE QUALITY AND PERFORMANCE OF THE PROGRAM
IS WITH YOU. SHOULD THE PROGRAM PROVE DEFECTIVE, YOU ASSUME THE COST OF
ALL NECESSARY SERVICING, REPAIR OR CORRECTION.
16. Limitation of Liability.
IN NO EVENT UNLESS REQUIRED BY APPLICABLE LAW OR AGREED TO IN WRITING
WILL ANY COPYRIGHT HOLDER, OR ANY OTHER PARTY WHO MODIFIES AND/OR CONVEYS
THE PROGRAM AS PERMITTED ABOVE, BE LIABLE TO YOU FOR DAMAGES, INCLUDING ANY
GENERAL, SPECIAL, INCIDENTAL OR CONSEQUENTIAL DAMAGES ARISING OUT OF THE
USE OR INABILITY TO USE THE PROGRAM (INCLUDING BUT NOT LIMITED TO LOSS OF
DATA OR DATA BEING RENDERED INACCURATE OR LOSSES SUSTAINED BY YOU OR THIRD
PARTIES OR A FAILURE OF THE PROGRAM TO OPERATE WITH ANY OTHER PROGRAMS),
EVEN IF SUCH HOLDER OR OTHER PARTY HAS BEEN ADVISED OF THE POSSIBILITY OF
SUCH DAMAGES.
17. Interpretation of Sections 15 and 16.
If the disclaimer of warranty and limitation of liability provided
above cannot be given local legal effect according to their terms,
reviewing courts shall apply local law that most closely approximates
an absolute waiver of all civil liability in connection with the
Program, unless a warranty or assumption of liability accompanies a
copy of the Program in return for a fee.
END OF TERMS AND CONDITIONS
How to Apply These Terms to Your New Programs
If you develop a new program, and you want it to be of the greatest
possible use to the public, the best way to achieve this is to make it
free software which everyone can redistribute and change under these terms.
To do so, attach the following notices to the program. It is safest
to attach them to the start of each source file to most effectively
state the exclusion of warranty; and each file should have at least
the "copyright" line and a pointer to where the full notice is found.
QCaml
Copyright (C) 2018 Anthony Scemama
This program is free software: you can redistribute it and/or modify
it under the terms of the GNU General Public License as published by
the Free Software Foundation, either version 3 of the License, or
(at your option) any later version.
This program is distributed in the hope that it will be useful,
but WITHOUT ANY WARRANTY; without even the implied warranty of
MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
GNU General Public License for more details.
You should have received a copy of the GNU General Public License
along with this program. If not, see <http://www.gnu.org/licenses/>.
Also add information on how to contact you by electronic and paper mail.
If the program does terminal interaction, make it output a short
notice like this when it starts in an interactive mode:
QCaml Copyright (C) 2018 Anthony Scemama
This program comes with ABSOLUTELY NO WARRANTY; for details type `show w'.
This is free software, and you are welcome to redistribute it
under certain conditions; type `show c' for details.
The hypothetical commands `show w' and `show c' should show the appropriate
parts of the General Public License. Of course, your program's commands
might be different; for a GUI interface, you would use an "about box".
You should also get your employer (if you work as a programmer) or school,
if any, to sign a "copyright disclaimer" for the program, if necessary.
For more information on this, and how to apply and follow the GNU GPL, see
<http://www.gnu.org/licenses/>.
The GNU General Public License does not permit incorporating your program
into proprietary programs. If your program is a subroutine library, you
may consider it more useful to permit linking proprietary applications with
the library. If this is what you want to do, use the GNU Lesser General
Public License instead of this License. But first, please read
<http://www.gnu.org/philosophy/why-not-lgpl.html>.

3
META
View File

@ -1,3 +0,0 @@
version = "%{version}%"
description = "Quantum Chamistry"
requires = "lacaml"

1
MOBasis/.merlin
View File

@ -1 +0,0 @@
REC

1170
MOBasis/HF12.ml
View File

File diff suppressed because it is too large Load Diff

1198
MOBasis/Localisation.ml
View File

File diff suppressed because it is too large Load Diff

202
MOBasis/MOBasis.ml
View File

@ -1,202 +0,0 @@
open Lacaml.D
open Util
open Constants
(** One-electron orthogonal basis set, corresponding to Molecular Orbitals. *)
module HF = HartreeFock
module Si = Simulation
type mo_type =
| RHF | ROHF | UHF | CASSCF | Projected
| Natural of string
| Localized of string
type t =
{
simulation : Simulation.t; (* Simulation which produced the MOs *)
mo_type : mo_type; (* Kind of MOs (RHF, CASSCF, Localized...) *)
mo_occupation : Vec.t; (* Occupation numbers *)
mo_coef : Mat.t; (* Matrix of the MO coefficients in the AO basis *)
eN_ints : NucInt.t lazy_t; (* Electron-nucleus potential integrals *)
ee_ints : ERI.t lazy_t; (* Electron-electron potential integrals *)
f12_ints : F12.t lazy_t; (* F12 integrals *)
kin_ints : KinInt.t lazy_t; (* Kinetic energy integrals *)
one_e_ints : Mat.t lazy_t; (* Kinetic energy integrals *)
}
let size t =
Mat.dim2 t.mo_coef
let simulation t = t.simulation
let mo_type t = t.mo_type
let ao_basis t = Si.ao_basis t.simulation
let mo_occupation t = t.mo_occupation
let mo_coef t = t.mo_coef
let eN_ints t = Lazy.force t.eN_ints
let ee_ints t = Lazy.force t.ee_ints
let kin_ints t = Lazy.force t.kin_ints
let two_e_ints t = Lazy.force t.ee_ints
let f12_ints t = Lazy.force t.f12_ints
let one_e_ints t = Lazy.force t.one_e_ints
let mo_energies t =
let m_C = mo_coef t in
let f =
let m_N = Mat.of_diag @@ mo_occupation t in
let m_P = x_o_xt m_N m_C in
match t.mo_type with
| RHF -> Fock.make_rhf ~density:m_P (ao_basis t)
| Projected
| ROHF -> (Mat.scal 0.5 m_P;
Fock.make_uhf ~density_same:m_P ~density_other:m_P (ao_basis t))
| _ -> failwith "Not implemented"
in
let m_F0 = Fock.fock f in
xt_o_x m_F0 m_C
|> Mat.copy_diag
let mo_matrix_of_ao_matrix ~mo_coef ao_matrix =
xt_o_x ~x:mo_coef ~o:ao_matrix
let ao_matrix_of_mo_matrix ~mo_coef ~ao_overlap mo_matrix =
let sc = gemm ao_overlap mo_coef in
x_o_xt ~x:sc ~o:mo_matrix
let make ~simulation ~mo_type ~mo_occupation ~mo_coef () =
let ao_basis =
Si.ao_basis simulation
in
let eN_ints = lazy (
AOBasis.eN_ints ao_basis
|> NucInt.matrix
|> mo_matrix_of_ao_matrix ~mo_coef
|> NucInt.of_matrix
)
and kin_ints = lazy (
AOBasis.kin_ints ao_basis
|> KinInt.matrix
|> mo_matrix_of_ao_matrix ~mo_coef
|> KinInt.of_matrix
)
and ee_ints = lazy (
AOBasis.ee_ints ao_basis
|> ERI.four_index_transform mo_coef
)
and f12_ints = lazy (
AOBasis.f12_ints ao_basis
|> F12.four_index_transform mo_coef
)
in
let one_e_ints = lazy (
Mat.add (NucInt.matrix @@ Lazy.force eN_ints)
(KinInt.matrix @@ Lazy.force kin_ints) )
in
{ simulation ; mo_type ; mo_occupation ; mo_coef ;
eN_ints ; ee_ints ; kin_ints ; one_e_ints ;
f12_ints }
let values t point =
let c = mo_coef t in
let a = AOBasis.values (Simulation.ao_basis t.simulation) point in
gemv ~trans:`T c a
let of_hartree_fock hf =
let mo_coef = HF.eigenvectors hf in
let simulation = HF.simulation hf in
let mo_occupation = HF.occupation hf in
let mo_type =
match HF.kind hf with
| HartreeFock.RHF -> RHF
| HartreeFock.ROHF -> ROHF
| HartreeFock.UHF -> UHF
in
make ~simulation ~mo_type ~mo_occupation ~mo_coef ()
let of_mo_basis simulation other =
let mo_coef =
let basis = Simulation.ao_basis simulation in
let basis_other = ao_basis other in
let m_S =
Overlap.(matrix @@ of_basis_pair
(AOBasis.basis basis)
(AOBasis.basis basis_other) )
in
let m_X = AOBasis.ortho basis in
(* Project other vectors in the current basis *)
let m_C =
gemm m_S @@ mo_coef other
in
(* Append dummy vectors to the input vectors *)
let result =
let vecs = Mat.to_col_vecs m_X in
Array.iteri (fun i v -> if (i < Array.length vecs) then vecs.(i) <- v)
(Mat.to_col_vecs m_C) ;
Mat.of_col_vecs vecs
in
(* Gram-Schmidt Orthonormalization *)
gemm m_X @@ (Util.qr_ortho @@ gemm ~transa:`T m_X result)
|> Util.remove_epsilons
|> Conventions.rephase
in
let mo_occupation =
let occ = mo_occupation other in
Vec.init (Mat.dim2 mo_coef) (fun i ->
if (i <= Vec.dim occ) then occ.{i}
else 0.)
in
make ~simulation ~mo_type:Projected ~mo_occupation ~mo_coef ()
let pp ?(start=1) ?(finish=0) ppf t =
let open Lacaml.Io in
let rows = Mat.dim1 t.mo_coef
and cols = Mat.dim2 t.mo_coef
in
let finish =
match finish with
| 0 -> cols
| x -> x
in
let rec aux first =
if (first > finish) then ()
else
begin
Format.fprintf ppf "@[<v>@[<v4>@[<h>%s@;" "Eigenvalues:";
Array.iteri (fun i x ->
if (i+1 >= first) && (i+1 <= first+4 ) then
Format.fprintf ppf "%12f@ " x)
(Vec.to_array @@ mo_energies t);
Format.fprintf ppf "@]@;";
Format.fprintf ppf "@[%a@]"
(Lacaml.Io.pp_lfmat
~row_labels:
(Array.init rows (fun i -> Printf.sprintf "%d " (i + 1)))
~col_labels:
(Array.init (min 5 (cols-first+1)) (fun i -> Printf.sprintf "-- %d --" (i + first) ))
~print_right:false
~print_foot:false
() ) (lacpy ~ac:first ~n:(min 5 (cols-first+1)) (t.mo_coef)) ;
Format.fprintf ppf "@]@;@;@]";
(aux [@tailcall]) (first+5)
end
in
aux start

89
MOBasis/MOBasis.mli
View File

@ -1,89 +0,0 @@
(** Data structure to represent the molecular orbitals.
The MO indices start from 1.
*)
open Lacaml.D
type mo_type =
| RHF | ROHF | UHF | CASSCF | Projected
| Natural of string
| Localized of string
type t
(** {1 Accessors} *)
val simulation : t -> Simulation.t
(** Simulation which produced the MOs *)
val mo_type : t -> mo_type
(** Kind of MOs (RHF, CASSCF, Localized...) *)
val ao_basis : t -> AOBasis.t
(** Matrix of the MO coefficients in the AO basis *)
val mo_occupation : t -> Vec.t
(** Occupation numbers *)
val mo_coef : t -> Mat.t
(** Molecular orbitcal coefficients *)
val eN_ints : t -> NucInt.t
(** Electron-nucleus potential integrals *)
val ee_ints : t -> ERI.t
(** Electron-electron repulsion integrals *)
val kin_ints : t -> KinInt.t
(** Kinetic energy integrals *)
val one_e_ints : t -> Mat.t
(** One-electron integrals {% $\hat{T} + V$ %} *)
val two_e_ints : t -> ERI.t
(** Electron-electron repulsion integrals *)
val f12_ints : t -> F12.t
(** F12 integrals *)
val size : t -> int
(** Number of molecular orbitals in the basis *)
val mo_energies : t -> Vec.t
(** Fock MO energies *)
val values : t -> Coordinate.t -> Vec.t
(** Values of the MOs evaluated at a given coordinate. *)
(** {1 Creators} *)
val make : simulation:Simulation.t ->
mo_type:mo_type ->
mo_occupation:Vec.t ->
mo_coef:Mat.t ->
unit -> t
(** Function to build a data structure representing the molecular orbitals. *)
val of_hartree_fock : HartreeFock.t -> t
(** Build MOs from a Restricted Hartree-Fock calculation. *)
val of_mo_basis : Simulation.t -> t -> t
(** Project the MOs of the other basis on the current one. *)
val mo_matrix_of_ao_matrix : mo_coef:Mat.t -> Mat.t -> Mat.t
(** Build a matrix in MO basis from a matrix in AO basis. *)
val ao_matrix_of_mo_matrix : mo_coef:Mat.t -> ao_overlap:Mat.t -> Mat.t -> Mat.t
(** Build a matrix in AO basis from a matrix in MO basis. *)
(** {1 Printers} *)
val pp : ?start:int -> ?finish:int -> Format.formatter -> t -> unit

140
MOBasis/MOClass.ml
View File

@ -1,140 +0,0 @@
type mo_class =
| Core of int (* Always doubly occupied *)
| Inactive of int (* With 0,1 or 2 holes *)
| Active of int (* With 0,1 or 2 holes or particles *)
| Virtual of int (* With 0,1 or 2 particles *)
| Deleted of int (* Always unoccupied *)
| Auxiliary of int (* Auxiliary basis function *)
type t = mo_class list
let pp_mo_class ppf = function
| Core i -> Format.fprintf ppf "@[Core %d@]" i
| Inactive i -> Format.fprintf ppf "@[Inactive %d@]" i
| Active i -> Format.fprintf ppf "@[Active %d@]" i
| Virtual i -> Format.fprintf ppf "@[Virtual %d@]" i
| Deleted i -> Format.fprintf ppf "@[Deleted %d@]" i
| Auxiliary i -> Format.fprintf ppf "@[Auxiliary %d@]" i
let pp ppf t =
Format.fprintf ppf "@[[@,";
let rec aux = function
| [] -> Format.fprintf ppf "]@]"
| x :: [] -> Format.fprintf ppf "%a@,]@]" pp_mo_class x
| x :: rest -> ( Format.fprintf ppf "%a@,;@," pp_mo_class x; aux rest )
in
aux t
let of_list t = t
let to_list t = t
let core_mos t =
List.filter_map (fun x ->
match x with
| Core i -> Some i
| _ -> None) t
let inactive_mos t =
List.filter_map (fun x ->
match x with
| Inactive i -> Some i
| _ -> None ) t
let active_mos t =
List.filter_map (fun x ->
match x with
| Active i -> Some i
| _ -> None ) t
let virtual_mos t =
List.filter_map (fun x ->
match x with
| Virtual i -> Some i
| _ -> None ) t
let deleted_mos t =
List.filter_map (fun x ->
match x with
| Deleted i -> Some i
| _ -> None ) t
let auxiliary_mos t =
List.filter_map (fun x ->
match x with
| Auxiliary i -> Some i
| _ -> None ) t
let mo_class_array t =
let sze = List.length t + 1 in
let result = Array.make sze (Deleted 0) in
List.iter (fun c ->
match c with
| Core i -> result.(i) <- Core i
| Inactive i -> result.(i) <- Inactive i
| Active i -> result.(i) <- Active i
| Virtual i -> result.(i) <- Virtual i
| Deleted i -> result.(i) <- Deleted i
| Auxiliary i -> result.(i) <- Auxiliary i
) t;
result
let fci ~frozen_core mo_basis =
let mo_num = MOBasis.size mo_basis in
let ncore = (Nuclei.small_core @@ Simulation.nuclei @@ MOBasis.simulation mo_basis) / 2 in
of_list (
if frozen_core then
List.concat [
Util.list_range 1 ncore
|> List.map (fun i -> Core i) ;
Util.list_range (ncore+1) mo_num
|> List.map (fun i -> Active i)
]
else
Util.list_range 1 mo_num
|> List.map (fun i -> Active i)
)
let cas_sd mo_basis ~frozen_core n m =
let mo_num = MOBasis.size mo_basis in
let n_alfa = MOBasis.simulation mo_basis |> Simulation.electrons |> Electrons.n_alfa in
let n_beta = MOBasis.simulation mo_basis |> Simulation.electrons |> Electrons.n_beta in
let n_unpaired = n_alfa - n_beta in
let n_alfa_in_cas = (n - n_unpaired)/2 + n_unpaired in
let last_inactive = n_alfa - n_alfa_in_cas in
let last_active = last_inactive + m in
let ncore =
if frozen_core then
(Nuclei.small_core @@ Simulation.nuclei @@ MOBasis.simulation mo_basis) / 2
|> min last_inactive
else 0
in
of_list (
List.concat [
if ncore > 0 then
Util.list_range 1 ncore
|> List.map (fun i -> Core i)
else
[] ;
Util.list_range (ncore+1) last_inactive
|> List.map (fun i -> Inactive i) ;
Util.list_range (last_inactive+1) last_active
|> List.map (fun i -> Active i) ;
Util.list_range (last_active+1) mo_num
|> List.map (fun i -> Virtual i)
]
)

58
MOBasis/MOClass.mli
View File

@ -1,58 +0,0 @@
(** CI Classes of MOs : active, inactive, etc *)
type mo_class =
| Core of int (* Always doubly occupied *)
| Inactive of int (* With 0,1 or 2 holes *)
| Active of int (* With 0,1 or 2 holes or particles *)
| Virtual of int (* With 0,1 or 2 particles *)
| Deleted of int (* Always unoccupied *)
| Auxiliary of int (* Function of the auxiliary basis set *)
type t
(** Creation *)
val of_list : mo_class list -> t
val to_list : t -> mo_class list
val fci : frozen_core:bool -> MOBasis.t -> t
(** Creates the MO classes for FCI calculations : all [Active]. The
[n] lowest MOs are [Core] if [frozen_core = true].
*)
val cas_sd: MOBasis.t -> frozen_core:bool -> int -> int -> t
(** [cas_sd mo_basis n m ] creates the MO classes for CAS(n,m) + SD
calculations. lowest MOs are [Core], then all the next MOs are [Inactive],
then [Active], then [Virtual].
*)
val core_mos : t -> int list
(** Returns a list containing the indices of the core MOs. *)
val active_mos : t -> int list
(** Returns a list containing the indices of the active MOs. *)
val virtual_mos : t -> int list
(** Returns a list containing the indices of the virtual MOs. *)
val inactive_mos : t -> int list
(** Returns a list containing the indices of the inactive MOs. *)
val deleted_mos : t -> int list
(** Returns a list containing the indices of the deleted MOs. *)
val auxiliary_mos : t -> int list
(** Returns a list containing the indices of the auxiliary MOs. *)
val mo_class_array : t -> mo_class array
(** Returns an array [a] such that [a.(i)] returns the class of MO [i].
As the MO indices start from [1], the array has an extra zero entry
that should be ignored. *)
(** {2 Printers} *)
val pp_mo_class : Format.formatter -> mo_class -> unit
val pp : Format.formatter -> t -> unit

23
Makefile Normal file
View File

@ -0,0 +1,23 @@
# Frontend to dune.
.PHONY: default build install uninstall test clean
default: build
build:
dune build
test:
dune runtest -f
install:
dune install
uninstall:
dune uninstall
clean:
dune clean
# Optionally, remove all files/folders ignored by git as defined
# in .gitignore (-X).
git clean -dfXq

65
Makefile.include
View File

@ -1,65 +0,0 @@
.NOPARALLEL:
LIBS=
PKGS=
OCAMLBUILD=ocamlbuild -j 0 -cflags $(ocamlcflags) -lflags $(ocamllflags) $(ocamldocflags) -ocamlopt $(ocamloptflags) $(mpi)
MLLFILES=$(filter-out $(wildcard _build/*), $(wildcard */*.mll) $(wildcard *.mll)) Utils/math_functions.c
MLYFILES=$(filter-out $(wildcard _build/*), $(wildcard */*.mly) $(wildcard *.mly))
MLFILES= $(filter-out $(wildcard Parallel_*/*) $(wildcard _build/*), $(wildcard */*.ml) $(wildcard *.ml) )
MLIFILES=$(filter-out $(wildcard Parallel_*/*) $(wildcard _build/*), $(wildcard */*.mli) $(wildcard *.mli) )
ALL_NATIVE=$(patsubst %.ml,%.native,$(wildcard run_*.ml))
ALL_BYTE=$(patsubst %.ml,%.byte,$(wildcard run_*.ml))
ALL_EXE=$(ALL_BYTE) $(ALL_NATIVE) lib
.PHONY: default doc
default: $(ALL_EXE)
tests: run_tests.native
lib: _build/Utils/Util.cma
_build/Utils/Util.cma: _build/Utils/Util.cmo _build/Utils/math_functions.o
ocamlmklib -o _build/Utils/Util _build/Utils/Util.cmo _build/Utils/math_functions.o
QCaml.odocl: $(MLIFILES)
ls $(MLIFILES) | sed "s/\.mli//" > QCaml.odocl
doc: QCaml.odocl
$(OCAMLBUILD) QCaml.docdir/index.html -use-ocamlfind $(PKGS)
%.inferred.mli: $(MLFILES)
$(OCAMLBUILD) $*.inferred.mli -use-ocamlfind $(PKGS)
mv _build/$*.inferred.mli .
%.byte: $(MLFILES) $(MLIFILES) $(MLLFILES) $(MLYFILES)
rm -f -- $*
$(OCAMLBUILD) $*.byte -use-ocamlfind $(PKGS)
%.native: $(MLFILES) $(MLIFILES) $(MLLFILES) $(MLYFILES)
rm -f -- $*
$(OCAMLBUILD) $*.native -use-ocamlfind $(PKGS)
ln -s $*.native $*
%.p.native: $(MLFILES) $(MLIFILES) $(MLLFILES) $(MLYFILES)
rm -f -- $*
$(OCAMLBUILD) $*.p.native -use-ocamlfind $(PKGS)
%.p.byte: $(MLFILES) $(MLIFILES) $(MLLFILES) $(MLYFILES)
rm -f -- $*
$(OCAMLBUILD) -ocamlc ocamlcp $*.byte -use-ocamlfind $(PKGS)
clean:
rm -f QCaml.odocl *.byte *.native && $(OCAMLBUILD) -clean
debug: run_integrals.native
./debug.sh
install: $(ALL_NATIVE)
cp run_hartree_fock.native $(bin)/run_hartree_fock
uninstall:
rm -f $(bin)/run_hartree_fock

8123
Notebooks/F12_fast.ipynb
View File

File diff suppressed because it is too large Load Diff

9743
Notebooks/F12_matrix.ipynb
View File

File diff suppressed because one or more lines are too long

1765
Notebooks/SpVec.ipynb
View File

File diff suppressed because it is too large Load Diff

159
Notebooks/TemplateQCaml.ipynb
View File

@ -1,159 +0,0 @@
{
"cells": [
{
"cell_type": "code",
"execution_count": 4,
"metadata": {},
"outputs": [
{
"data": {
"text/plain": [
"val png_image : string -> unit = <fun>\n"
]
},
"execution_count": 4,
"metadata": {},
"output_type": "execute_result"
},
{
"name": "stdout",
"output_type": "stream",
"text": [
"- : unit = ()\n",
"Findlib has been successfully loaded. Additional directives:\n",
" #require \"package\";; to load a package\n",
" #list;; to list the available packages\n",
" #camlp4o;; to load camlp4 (standard syntax)\n",
" #camlp4r;; to load camlp4 (revised syntax)\n",
" #predicates \"p,q,...\";; to set these predicates\n",
" Topfind.reset();; to force that packages will be reloaded\n",
" #thread;; to enable threads\n",
"\n",
"- : unit = ()\n"
]
},
{
"data": {
"text/plain": [
"val png_image : string -> Jupyter_notebook.display_id = <fun>\n"
]
},
"execution_count": 4,
"metadata": {},
"output_type": "execute_result"
}
],
"source": [
"let png_image = print_endline ;;\n",
"\n",
"(* --------- *)\n",
"\n",
"#cd \"/home/scemama/QCaml\";;\n",
"#use \"topfind\";;\n",
"#require \"jupyter.notebook\";;\n",
"\n",
"let png_image name = \n",
" Jupyter_notebook.display_file ~base64:true \"image/png\" (\"Notebooks/images/\"^name)\n",
";;\n",
"\n",
"#require \"lacaml.top\";;\n",
"#require \"alcotest\";;\n",
"#require \"str\";;\n",
"#require \"bigarray\";;\n",
"#require \"zarith\";;\n",
"#require \"getopt\";;\n",
"#directory \"_build\";;\n",
"#directory \"_build/Basis\";;\n",
"#directory \"_build/CI\";;\n",
"#directory \"_build/MOBasis\";;\n",
"#directory \"_build/Nuclei\";;\n",
"#directory \"_build/Parallel\";;\n",
"#directory \"_build/Perturbation\";;\n",
"#directory \"_build/SCF\";;\n",
"#directory \"_build/Utils\";;\n"
]
},
{
"cell_type": "code",
"execution_count": 5,
"metadata": {},
"outputs": [
{
"name": "stdout",
"output_type": "stream",
"text": [
"File Constants.cmo is not a bytecode object file.\n",
"File Util.cma is not a bytecode object file.\n",
"File Matrix.cmo is not a bytecode object file.\n",
"File Simulation.cmo is not a bytecode object file.\n",
"File Spindeterminant.cmo is not a bytecode object file.\n",
"File Determinant.cmo is not a bytecode object file.\n",
"File HartreeFock.cmo is not a bytecode object file.\n",
"File MOBasis.cmo is not a bytecode object file.\n",
"File F12CI.cmo is not a bytecode object file.\n"
]
}
],
"source": [
"#load \"Constants.cmo\";;\n",
"#load_rec \"Util.cma\";;\n",
"#load_rec \"Matrix.cmo\";;\n",
"#load_rec \"Simulation.cmo\";;\n",
"#load_rec \"Spindeterminant.cmo\";;\n",
"#load_rec \"Determinant.cmo\";;\n",
"#load_rec \"HartreeFock.cmo\";;\n",
"#load_rec \"MOBasis.cmo\";;\n",
"#load_rec \"F12CI.cmo\";;"
]
},
{
"cell_type": "code",
"execution_count": null,
"metadata": {},
"outputs": [],
"source": [
"#install_printer AngularMomentum.pp_string ;;\n",
"#install_printer Basis.pp ;;\n",
"#install_printer Charge.pp ;;\n",
"#install_printer Coordinate.pp ;;\n",
"#install_printer Vector.pp;;\n",
"#install_printer Matrix.pp;;\n",
"#install_printer Util.pp_float_2darray;;\n",
"#install_printer Util.pp_float_array;;\n",
"#install_printer Util.pp_matrix;;\n",
"#install_printer HartreeFock.pp ;;\n",
"#install_printer Fock.pp ;;\n",
"#install_printer MOClass.pp ;;\n",
"let pp_mo ppf t = MOBasis.pp ~start:1 ~finish:0 ppf t ;;\n",
"#install_printer pp_mo;;\n",
"(*\n",
"#install_printer DeterminantSpace.pp;;\n",
"*)\n",
"#install_printer SpindeterminantSpace.pp;;\n",
"#install_printer Bitstring.pp;;\n",
"\n",
"(* --------- *)\n",
"\n",
"open Lacaml.D\n"
]
}
],
"metadata": {
"kernelspec": {
"display_name": "OCaml default",
"language": "OCaml",
"name": "ocaml-jupyter"
},
"language_info": {
"codemirror_mode": "text/x-ocaml",
"file_extension": ".ml",
"mimetype": "text/x-ocaml",
"name": "OCaml",
"nbconverter_exporter": null,
"pygments_lexer": "OCaml",
"version": "4.07.1"
}
},
"nbformat": 4,
"nbformat_minor": 4
}

BIN
Notebooks/images/0_1_11.png
View File

Binary file not shown.
Side by Side

Before

Width:  |  Height:  |  Size: 4.9 KiB

37
Notebooks/images/0_1_11.tikz
View File

@ -1,37 +0,0 @@
\begin{tikzpicture}
\input{Electrons.tikz}
% Det |I>
\renewcommand{\XX}{\XI}
\cabs{
\emp{\XX}{2.5}
\emp{\XX}{2.0}
}
\emp{\XX}{1.5}
\emp{\XX}{1.0}
\updna{\XX}{0.5}
\updn{\XX}{0.}
% Det |alpha>
\renewcommand{\XX}{\XA}
\cabs{
\emp{\XX}{2.5}
\upa{\XX}{2.0}
}
\emp{\XX}{1.5}
\emp{\XX}{1.0}
\dn{\XX}{0.5}
\updn{\XX}{0.}
% Det |J>
\renewcommand{\XX}{\XJ}
\cabs{
\emp{\XX}{2.5}
\emp{\XX}{2.0}
}
\emp{\XX}{1.5}
\emp{\XX}{1.0}
\updna{\XX}{0.5}
\updn{\XX}{0.}
\end{tikzpicture}

BIN
Notebooks/images/0_1_22.png
View File

Binary file not shown.
Side by Side

Before

Width:  |  Height:  |  Size: 5.2 KiB

37
Notebooks/images/0_1_22.tikz
View File

@ -1,37 +0,0 @@
\begin{tikzpicture}
\input{Electrons.tikz}
% Det |I>
\renewcommand{\XX}{\XI}
\cabs{
\emp{\XX}{2.5}
\emp{\XX}{2.0}
}
\emp{\XX}{1.5}
\emp{\XX}{1.0}
\updnab{\XX}{0.5}
\updn{\XX}{0.}
% Det |alpha>
\renewcommand{\XX}{\XA}
\cabs{
\emp{\XX}{2.5}
\upa{\XX}{2.0}
}
\emp{\XX}{1.5}
\dnb{\XX}{1.0}
\emp{\XX}{0.5}
\updn{\XX}{0.}
% Det |J>
\renewcommand{\XX}{\XJ}
\cabs{
\emp{\XX}{2.5}
\emp{\XX}{2.0}
}
\emp{\XX}{1.5}
\emp{\XX}{1.0}
\updnab{\XX}{0.5}
\updn{\XX}{0.}
\end{tikzpicture}

BIN
Notebooks/images/0_2_22.png
View File

Binary file not shown.
Side by Side

Before

Width:  |  Height:  |  Size: 5.2 KiB

37
Notebooks/images/0_2_22.tikz
View File

@ -1,37 +0,0 @@
\begin{tikzpicture}
\input{Electrons.tikz}
% Det |I>
\renewcommand{\XX}{\XI}
\cabs{
\emp{\XX}{2.5}
\emp{\XX}{2.0}
}
\emp{\XX}{1.5}
\emp{\XX}{1.0}
\updnab{\XX}{0.5}
\updn{\XX}{0.}
% Det |alpha>
\renewcommand{\XX}{\XA}
\cabs{
\emp{\XX}{2.5}
\updnab{\XX}{2.0}
}
\emp{\XX}{1.5}
\emp{\XX}{1.0}
\emp{\XX}{0.5}
\updn{\XX}{0.}
% Det |J>
\renewcommand{\XX}{\XJ}
\cabs{
\emp{\XX}{2.5}
\emp{\XX}{2.0}
}
\emp{\XX}{1.5}
\emp{\XX}{1.0}
\updnab{\XX}{0.5}
\updn{\XX}{0.}
\end{tikzpicture}

BIN
Notebooks/images/1_1_11.png
View File

Binary file not shown.
Side by Side

Before

Width:  |  Height:  |  Size: 5.0 KiB

37
Notebooks/images/1_1_11.tikz
View File

@ -1,37 +0,0 @@
\begin{tikzpicture}
\input{Electrons.tikz}
% Det |I>
\renewcommand{\XX}{\XI}
\cabs{
\emp{\XX}{2.5}
\emp{\XX}{2.0}
}
\emp{\XX}{1.5}
\emp{\XX}{1.0}
\updna{\XX}{0.5}
\updn{\XX}{0.}
% Det |alpha>
\renewcommand{\XX}{\XA}
\cabs{
\emp{\XX}{2.5}
\upa{\XX}{2.0}
}
\emp{\XX}{1.5}
\emp{\XX}{1.0}
\dn{\XX}{0.5}
\updn{\XX}{0.}
% Det |J>
\renewcommand{\XX}{\XJ}
\cabs{
\emp{\XX}{2.5}
\emp{\XX}{2.0}
}
\emp{\XX}{1.5}
\upa{\XX}{1.0}
\dn{\XX}{0.5}
\updn{\XX}{0.}
\end{tikzpicture}

BIN
Notebooks/images/1_1_12.png
View File

Binary file not shown.
Side by Side

Before

Width:  |  Height:  |  Size: 5.1 KiB

37
Notebooks/images/1_1_12.tikz
View File

@ -1,37 +0,0 @@
\begin{tikzpicture}
\input{Electrons.tikz}
% Det |I>
\renewcommand{\XX}{\XI}
\cabs{
\emp{\XX}{2.5}
\emp{\XX}{2.0}
}
\emp{\XX}{1.5}
\emp{\XX}{1.0}
\updnab{\XX}{0.5}
\updn{\XX}{0.}
% Det |alpha>
\renewcommand{\XX}{\XA}
\cabs{
\emp{\XX}{2.5}
\upa{\XX}{2.0}
}
\emp{\XX}{1.5}
\emp{\XX}{1.0}
\dnb{\XX}{0.5}
\updn{\XX}{0.}
% Det |J>
\renewcommand{\XX}{\XJ}
\cabs{
\emp{\XX}{2.5}
\emp{\XX}{2.0}
}
\emp{\XX}{1.5}
\dnb{\XX}{1.0}
\upa{\XX}{0.5}
\updn{\XX}{0.}
\end{tikzpicture}

BIN
Notebooks/images/1_1_21.png
View File

Binary file not shown.
Side by Side

Before

Width:  |  Height:  |  Size: 5.2 KiB

37
Notebooks/images/1_1_21.tikz
View File

@ -1,37 +0,0 @@
\begin{tikzpicture}
\input{Electrons.tikz}
% Det |I>
\renewcommand{\XX}{\XI}
\cabs{
\emp{\XX}{2.5}
\emp{\XX}{2.0}
}
\emp{\XX}{1.5}
\emp{\XX}{1.0}
\updnab{\XX}{0.5}
\updn{\XX}{0.}
% Det |alpha>
\renewcommand{\XX}{\XA}
\cabs{
\emp{\XX}{2.5}
\upa{\XX}{2.0}
}
\emp{\XX}{1.5}
\dnb{\XX}{1.0}
\emp{\XX}{0.5}
\updn{\XX}{0.}
% Det |J>
\renewcommand{\XX}{\XJ}
\cabs{
\emp{\XX}{2.5}
\emp{\XX}{2.0}
}
\emp{\XX}{1.5}
\dnb{\XX}{1.0}
\upa{\XX}{0.5}
\updn{\XX}{0.}
\end{tikzpicture}

BIN
Notebooks/images/1_1_22.png
View File

Binary file not shown.
Side by Side

Before

Width:  |  Height:  |  Size: 5.2 KiB

37
Notebooks/images/1_1_22.tikz
View File

@ -1,37 +0,0 @@
\begin{tikzpicture}
\input{Electrons.tikz}
% Det |I>
\renewcommand{\XX}{\XI}
\cabs{
\emp{\XX}{2.5}
\emp{\XX}{2.0}
}
\emp{\XX}{1.5}
\emp{\XX}{1.0}
\updnab{\XX}{0.5}
\updn{\XX}{0.}
% Det |alpha>
\renewcommand{\XX}{\XA}
\cabs{
\emp{\XX}{2.5}
\upa{\XX}{2.0}
}
\emp{\XX}{1.5}
\dnb{\XX}{1.0}
\emp{\XX}{0.5}
\updn{\XX}{0.}
% Det |J>
\renewcommand{\XX}{\XJ}
\cabs{
\emp{\XX}{2.5}
\emp{\XX}{2.0}
}
\dnb{\XX}{1.5}
\emp{\XX}{1.0}
\upa{\XX}{0.5}
\updn{\XX}{0.}
\end{tikzpicture}

BIN
Notebooks/images/1_2_22.png
View File

Binary file not shown.
Side by Side

Before

Width:  |  Height:  |  Size: 5.3 KiB

37
Notebooks/images/1_2_22.tikz
View File

@ -1,37 +0,0 @@
\begin{tikzpicture}
\input{Electrons.tikz}
% Det |I>
\renewcommand{\XX}{\XI}
\cabs{
\emp{\XX}{2.5}
\emp{\XX}{2.0}
}
\emp{\XX}{1.5}
\emp{\XX}{1.0}
\updnab{\XX}{0.5}
\updn{\XX}{0.}
% Det |alpha>
\renewcommand{\XX}{\XA}
\cabs{
\emp{\XX}{2.5}
\updnab{\XX}{2.0}
}
\emp{\XX}{1.5}
\emp{\XX}{1.0}
\emp{\XX}{0.5}
\updn{\XX}{0.}
% Det |J>
\renewcommand{\XX}{\XJ}
\cabs{
\emp{\XX}{2.5}
\emp{\XX}{2.0}
}
\emp{\XX}{1.5}
\dnb{\XX}{1.0}
\upa{\XX}{0.5}
\updn{\XX}{0.}
\end{tikzpicture}

BIN
Notebooks/images/2_1_12.png
View File

Binary file not shown.
Side by Side

Before

Width:  |  Height:  |  Size: 5.2 KiB

37
Notebooks/images/2_1_12.tikz
View File

@ -1,37 +0,0 @@
\begin{tikzpicture}
\input{Electrons.tikz}
% Det |I>
\renewcommand{\XX}{\XI}
\cabs{
\emp{\XX}{2.5}
\emp{\XX}{2.0}
}
\emp{\XX}{1.5}
\emp{\XX}{1.0}
\updnab{\XX}{0.5}
\updn{\XX}{0.}
% Det |alpha>
\renewcommand{\XX}{\XA}
\cabs{
\emp{\XX}{2.5}
\upa{\XX}{2.0}
}
\emp{\XX}{1.5}
\emp{\XX}{1.0}
\dnb{\XX}{0.5}
\updn{\XX}{0.}
% Det |J>
\renewcommand{\XX}{\XJ}
\cabs{
\emp{\XX}{2.5}
\emp{\XX}{2.0}
}
\emp{\XX}{1.5}
\updnab{\XX}{1.0}
\emp{\XX}{0.5}
\updn{\XX}{0.}
\end{tikzpicture}

BIN
Notebooks/images/2_1_21.png
View File

Binary file not shown.
Side by Side

Before

Width:  |  Height:  |  Size: 5.2 KiB

37
Notebooks/images/2_1_21.tikz
View File

@ -1,37 +0,0 @@
\begin{tikzpicture}
\input{Electrons.tikz}
% Det |I>
\renewcommand{\XX}{\XI}
\cabs{
\emp{\XX}{2.5}
\emp{\XX}{2.0}
}
\emp{\XX}{1.5}
\emp{\XX}{1.0}
\updnab{\XX}{0.5}
\updn{\XX}{0.}
% Det |alpha>
\renewcommand{\XX}{\XA}
\cabs{
\emp{\XX}{2.5}
\upa{\XX}{2.0}
}
\emp{\XX}{1.5}
\dnb{\XX}{1.0}
\emp{\XX}{0.5}
\updn{\XX}{0.}
% Det |J>
\renewcommand{\XX}{\XJ}
\cabs{
\emp{\XX}{2.5}
\emp{\XX}{2.0}
}
\emp{\XX}{1.5}
\updnab{\XX}{1.0}
\emp{\XX}{0.5}
\updn{\XX}{0.}
\end{tikzpicture}

BIN
Notebooks/images/2_1_22.png
View File

Binary file not shown.
Side by Side

Before

Width:  |  Height:  |  Size: 5.3 KiB

37
Notebooks/images/2_1_22.tikz
View File

@ -1,37 +0,0 @@
\begin{tikzpicture}
\input{Electrons.tikz}
% Det |I>
\renewcommand{\XX}{\XI}
\cabs{
\emp{\XX}{2.5}
\emp{\XX}{2.0}
}
\emp{\XX}{1.5}
\emp{\XX}{1.0}
\updnab{\XX}{0.5}
\updn{\XX}{0.}
% Det |alpha>
\renewcommand{\XX}{\XA}
\cabs{
\emp{\XX}{2.5}
\upa{\XX}{2.0}
}
\emp{\XX}{1.5}
\dnb{\XX}{1.0}
\emp{\XX}{0.5}
\updn{\XX}{0.}
% Det |J>
\renewcommand{\XX}{\XJ}
\cabs{
\emp{\XX}{2.5}
\emp{\XX}{2.0}
}
\dnb{\XX}{1.5}
\upa{\XX}{1.0}
\emp{\XX}{0.5}
\updn{\XX}{0.}
\end{tikzpicture}

BIN
Notebooks/images/2_2_22.png
View File

Binary file not shown.
Side by Side

Before

Width:  |  Height:  |  Size: 5.3 KiB

37
Notebooks/images/2_2_22.tikz
View File

@ -1,37 +0,0 @@
\begin{tikzpicture}
\input{Electrons.tikz}
% Det |I>
\renewcommand{\XX}{\XI}
\cabs{
\emp{\XX}{2.5}
\emp{\XX}{2.0}
}
\emp{\XX}{1.5}
\emp{\XX}{1.0}
\updnab{\XX}{0.5}
\updn{\XX}{0.}
% Det |alpha>
\renewcommand{\XX}{\XA}
\cabs{
\emp{\XX}{2.5}
\updnab{\XX}{2.0}
}
\emp{\XX}{1.5}
\emp{\XX}{1.0}
\emp{\XX}{0.5}
\updn{\XX}{0.}
% Det |J>
\renewcommand{\XX}{\XJ}
\cabs{
\emp{\XX}{2.5}
\emp{\XX}{2.0}
}
\emp{\XX}{1.5}
\updnab{\XX}{1.0}
\emp{\XX}{0.5}
\updn{\XX}{0.}
\end{tikzpicture}

BIN
Notebooks/images/3_1_22.png
View File

Binary file not shown.
Side by Side

Before

Width:  |  Height:  |  Size: 5.5 KiB

37
Notebooks/images/3_1_22.tikz
View File

@ -1,37 +0,0 @@
\begin{tikzpicture}
\input{Electrons.tikz}
% Det |I>
\renewcommand{\XX}{\XI}
\cabs{
\emp{\XX}{2.5}
\emp{\XX}{2.0}
}
\emp{\XX}{1.5}
\emp{\XX}{1.0}
\updnab{\XX}{0.5}
\updnc{\XX}{0.}
% Det |alpha>
\renewcommand{\XX}{\XA}
\cabs{
\emp{\XX}{2.5}
\upa{\XX}{2.0}
}
\emp{\XX}{1.5}
\dnb{\XX}{1.0}
\emp{\XX}{0.5}
\updnc{\XX}{0.}
% Det |J>
\renewcommand{\XX}{\XJ}
\cabs{
\emp{\XX}{2.5}
\emp{\XX}{2.0}
}
\upa{\XX}{1.5}
\updncb{\XX}{1.0}
\emp{\XX}{0.5}
\dn{\XX}{0.}
\end{tikzpicture}

135
Notebooks/images/Electrons.tikz
View File

@ -1,135 +0,0 @@
% Documentation
% -------------
%
% \up : up electron (black)
% \upr : up electron (red)
% \dn : down electron (black)
% \dnr : down electron (red)
% \updn : up electron (black), down electron (black)
% \updnrr : up electron (red ), down electron (red )
% \updnrb : up electron (red ), down electron (black)
% \updnbr : up electron (black), down electron (red )
% \emp : empty orbital
% \cabs{ } : CABS space inside
%
% Example
% -------
%
% \input{Electrons.tikz}
%
% \cabs{
% \emp{0.}{2.0}
% \emp{0.}{1.5}
% }
% \emp{0.}{1.0}
% \updnrb{0.}{0.5}
% \updn{0.}{0.}
%
% Electron symbol
\newcommand{\upel}{$\uparrow$}
\newcommand{\dnel}{$\downarrow$}
% Colors
\newcommand{\cabs}[1]{ { \color{lightgray}{#1} } }
\newcommand{\obs}[1]{ { \color{black}{#1} } }
\newcommand{\exca}[1]{ { \color{red}{#1} } }
\newcommand{\excb}[1]{ { \color{Cyan}{#1} } }
\newcommand{\excc}[1]{ { \color{Green}{#1} } }
\newcommand{\noexc}[1]{{ \color{black}{#1} } }
% Spacing between the 3 diagrams
\newcommand{\XI}{-1.}
\newcommand{\XA}{0.}
\newcommand{\XJ}{1.}
% Up electron
\newcommand{\up}[2]{
\draw [-,thick] (-0.2+#1,#2) -- (0.2+#1,#2);
\node at (#1-0.1,#2) {\noexc{\upel}};
}
\newcommand{\upa}[2]{
\draw [-,thick] (-0.2+#1,#2) -- (0.2+#1,#2);
\node at (#1-0.1,#2) {\exca{\upel}};
}
\newcommand{\upb}[2]{
\draw [-,thick] (-0.2+#1,#2) -- (0.2+#1,#2);
\node at (#1-0.1,#2) {\excb{\upel}};
}
\newcommand{\upc}[2]{
\draw [-,thick] (-0.2+#1,#2) -- (0.2+#1,#2);
\node at (#1-0.1,#2) {\excc{\upel}};
}
% Down electron
\newcommand{\dn}[2]{
\draw [-,thick] (-0.2+#1,#2) -- (0.2+#1,#2);
\node at (#1+0.1,#2) {\noexc{\dnel}};
}
\newcommand{\dna}[2]{
\draw [-,thick] (-0.2+#1,#2) -- (0.2+#1,#2);
\node at (#1+0.1,#2) {\exca{\dnel}};
}
\newcommand{\dnb}[2]{
\draw [-,thick] (-0.2+#1,#2) -- (0.2+#1,#2);
\node at (#1+0.1,#2) {\excb{\dnel}};
}
\newcommand{\dnc}[2]{
\draw [-,thick] (-0.2+#1,#2) -- (0.2+#1,#2);
\node at (#1+0.1,#2) {\excc{\dnel}};
}
% Up and Down electrons
\newcommand{\updn}[2]{
\draw [-,thick] (-0.2+#1,#2) -- (0.2+#1,#2);
\node at (#1+0.1,#2) {\noexc{\dnel}};
\node at (#1-0.1,#2) {\noexc{\upel}};
}
\newcommand{\updnab}[2]{
\draw [-,thick] (-0.2+#1,#2) -- (0.2+#1,#2);
\node at (#1+0.1,#2) {\excb{\dnel}};
\node at (#1-0.1,#2) {\exca{\upel}};
}
\newcommand{\updncb}[2]{
\draw [-,thick] (-0.2+#1,#2) -- (0.2+#1,#2);
\node at (#1+0.1,#2) {\excb{\dnel}};
\node at (#1-0.1,#2) {\excc{\upel}};
}
\newcommand{\updna}[2]{
\draw [-,thick] (-0.2+#1,#2) -- (0.2+#1,#2);
\node at (#1+0.1,#2) {\noexc{\dnel}};
\node at (#1-0.1,#2) {\exca{\upel}};
}
\newcommand{\updnb}[2]{
\draw [-,thick] (-0.2+#1,#2) -- (0.2+#1,#2);
\node at (#1-0.1,#2) {\noexc{\upel}};
\node at (#1+0.1,#2) {\excb{\dnel}};
}
\newcommand{\updnc}[2]{
\draw [-,thick] (-0.2+#1,#2) -- (0.2+#1,#2);
\node at (#1+0.1,#2) {\noexc{\dnel}};
\node at (#1-0.1,#2) {\excc{\upel}};
}
% Empty orbital
\newcommand{\emp}[2]{
\draw [-,thick] (-0.2+#1,#2) -- (0.2+#1,#2);
}
% Determinant label
\node at (\XI,-0.7) {$\ket{I}$};
\node at (\XA,-0.7) {$\ket{\alpha}$};
\node at (\XJ,-0.7) {$\ket{J}$};
\newcommand{\XX}{0.}

1
Nuclei/.merlin
View File

@ -1 +0,0 @@
REC

3
Nuclei/Mass.ml
View File

@ -1,3 +0,0 @@
(** Atomic mass. *)
include NonNegativeFloat

3
Nuclei/Mass.mli
View File

@ -1,3 +0,0 @@
(** Atomic mass. *)
include module type of NonNegativeFloat

246
Parallel_mpi/Farm.ml
View File

@ -1,246 +0,0 @@
(********************************************************************)
(* Single process *)
(********************************************************************)
let run_sequential f stream =
let rec next _ =
try
let task = Stream.next stream in
Some (f task)
with Stream.Failure -> None
in
Stream.from next
(********************************************************************)
(* Server side *)
(********************************************************************)
type task_id = int
let debug _s =
if true then
()
else
Printf.eprintf "%d : %s : %s\n%!" (Mpi.comm_rank Mpi.comm_world) (Unix.gettimeofday () |> string_of_float) _s
type status =
| Initializing
| Running
| Done
let run_parallel_server ~comm ~ordered stream =
(* [status.(rank)] is [Initializing] if rank has not yet obtained a task,
[Running] if rank is running a task and [Done] if [rank] is waiting at
the barrier.
*)
let status = Array.make (Mpi.comm_size comm) Initializing in
status.(0) <- Done;
(** Fetches a result coming from any client. Returns the result
as a (task_id * 'a) option and the rank of the client as an int.
*)
let fetch_result () : (task_id * 'a) option * int =
let (message, rank, _tag) : (task_id * 'a) option * int * int =
debug "Before receive_status";
(* Avoid busy receive *)
let rec wait_and_receive () =
match Mpi.iprobe Mpi.any_source Mpi.any_tag comm with
| Some _ -> Mpi.receive_status Mpi.any_source Mpi.any_tag comm
| None -> (Unix.sleepf 0.001 ; (wait_and_receive [@tailcall]) ())
in
wait_and_receive ()
in
debug @@ Printf.sprintf "After receive_status %d %d" rank _tag;
message, rank
in
(** Pops a task from the stream and sends it to a client.
If no task is available, sends [None].
The return value is a boolean telling if the stream is empty.
*)
let send_task (client_rank : int) : unit =
let task =
try
let task_id = Stream.count stream in
let element = Stream.next stream in
Some (task_id, element)
with Stream.Failure -> None
in
debug @@ Printf.sprintf "Sending to %d\n" client_rank;
Mpi.send task client_rank 0 comm;
debug @@ Printf.sprintf "Sent to %d : %s\n" client_rank
(if task = None then "None" else "Some");
if task <> None then
status.(client_rank) <- Running
else
status.(client_rank) <- Done
in
let all_done () =
try
Array.iter (fun i -> if i <> Done then raise Exit) status;
true
with Exit -> false
in
(** Main loop.
While [n_todo > 0], fetch a result from a client
and send it back a new task. If no more tasks are
available, send [None]. If the result of the task
is None, loop back into [get_result].
*)
let rec get_result () : (task_id * 'a ) option =
if all_done () then
begin
debug "Before barrier";
Mpi.barrier comm;
debug "After barrier";
None
end
else
begin
let message, rank = fetch_result () in
send_task rank;
match message with
| None -> get_result ()
| Some (task_id, result) -> Some (task_id, result)
end
in
(** Function from which the output stream is built. *)
let f =
if not ordered then
(* If [ordered] is false, the values are popped out whenever they arrive
from the clients.
*)
fun _ ->
match get_result () with
| Some (_, result) -> Some result
| None -> None
else
(* If [ordered] is true, out into the stream when the next expected task has
been computed.
*)
let buffer =
(* buffer of finished tasks with a task_id greater than the
current result_id. It allows to put back the results in
the correct order.
*)
Hashtbl.create 67
in
fun i ->
begin
match Hashtbl.find_opt buffer i with
| Some x ->
begin
Hashtbl.remove buffer i;
Some x
end
| None ->
let rec loop () =
match get_result () with
| None -> None
| Some (task_id, result) ->
if task_id = i then Some result
else (Hashtbl.add buffer task_id result; (loop [@tailcall]) () )
in loop ()
end
in
Stream.from f
(********************************************************************)
(* Client side *)
(********************************************************************)
let run_parallel_client ~comm f =
(** Send a first message containing [None] to request a task *)
debug "Before send None";
Mpi.send None 0 0 comm;
debug "After send None";
(** Main loop.
Receive a message. If the message is [None], there are no more
tasks to compute and we can go to the barrier.
If the message is not [None], apply [f] to the task, send the
result back to the server and loop.
*)
let rec run () =
let message =
debug "Before receive";
Mpi.receive 0 0 comm
in
debug "After receive" ;
match message with
| None ->
( debug "Before barrier";
Mpi.barrier comm;
debug "After barrier";)
| Some (task_id, task) ->
let result = f task in
begin
debug @@ Printf.sprintf "Before send task_id %d" task_id ;
Mpi.send (Some (task_id, result)) 0 0 comm;
debug @@ Printf.sprintf "After send task_id %d" task_id ;
(run [@tailcall]) ()
end
in
run ();
(* The output is an empty stream so that the type of run_parallel_client
is the same as the type of the server function.
*)
Stream.of_list []
let run_parallel ~comm ~ordered f stream =
match Mpi.comm_rank comm with
| 0 -> run_parallel_server ~comm ~ordered stream
| _ -> run_parallel_client ~comm f
let nested = ref false
let run ?(ordered=true) ?(comm=Mpi.comm_world) ~f stream =
if !nested then
begin
let message =
"Nested parallel regions are not supported by Farm.ml"
in
Printf.eprintf "%s\n%!" message ;
failwith message
end;
nested := true;
let result =
match Mpi.comm_size comm with
| 1 -> run_sequential f stream
| _ -> run_parallel ~comm ~ordered f stream
in
nested := false;
result

18
Parallel_mpi/Farm.mli
View File

@ -1,18 +0,0 @@
(** The Farm skeleton, similar to SklMl.
The input is a stream of input data, and the output is a stream of data.
*)
val run_sequential : ('a -> 'b) -> 'a Stream.t -> 'b Stream.t
val run : ?ordered:bool -> ?comm:Mpi.communicator ->
f:('a -> 'b) -> 'a Stream.t -> 'b Stream.t
(** Run the [f] function on every process by popping elements from the
input stream, and putting the results on the output stream. If [ordered]
(the default is [ordered = true], then the order of the output is kept
consistent with the order of the input.
[comm], within MPI is a communicator. It describes a subgroup of processes.
*)

273
Parallel_mpi/Parallel.ml
View File

@ -1,273 +0,0 @@
(** Module for handling distributed parallelism *)
let size =
let result =
Mpi.comm_size Mpi.comm_world
in
assert (result > 0);
result
let rank =
let result =
Mpi.comm_rank Mpi.comm_world
in
assert (result >= 0);
result
let master = rank = 0
let barrier () =
Mpi.barrier Mpi.comm_world
let broadcast_generic broadcast x =
let x =
if master then Some (Lazy.force x)
else None
in
match broadcast x 0 Mpi.comm_world with
| Some x -> x
| None -> assert false
let broadcast x = broadcast_generic Mpi.broadcast x
let broadcast_int x =
Mpi.broadcast_int x 0 Mpi.comm_world
let broadcast_int_array x =
Mpi.broadcast_int_array x 0 Mpi.comm_world;
x
let broadcast_float x =
Mpi.broadcast_float x 0 Mpi.comm_world
let broadcast_float_array x =
Mpi.broadcast_float_array x 0 Mpi.comm_world;
x
let broadcast_vec x =
let a = Lacaml.D.Vec.to_array x in
let a = broadcast_float_array a in
Lacaml.D.Vec.of_array a
module Node = struct
let name = Unix.gethostname ()
let world_rank = rank
let comm =
let _, color =
Mpi.allgather (name, world_rank) Mpi.comm_world
|> Array.to_list
|> List.sort compare
|> List.find (fun (n, r) -> n = name)
in
Mpi.(comm_split comm_world color world_rank)
let rank =
Mpi.comm_rank comm
let master = rank = 0
let broadcast_generic broadcast x =
let x =
if master then Some (Lazy.force x)
else None
in
match broadcast x 0 comm with
| Some x -> x
| None -> assert false
let broadcast x = broadcast_generic Mpi.broadcast x
let barrier () = Mpi.barrier comm
let _ = barrier ()
end
module InterNode = struct
let world_rank = rank
let comm =
let ranks =
let name = Unix.gethostname () in
let rec aux accu old_name = function
| [] -> List.rev accu |> Array.of_list
| (new_name, r) :: rest when new_name <> old_name ->
aux (r::accu) new_name rest
| (new_name, r) :: rest -> aux accu new_name rest
in
Mpi.allgather (name, world_rank) Mpi.comm_world
|> Array.to_list
|> List.sort compare
|> aux [] ""
in
let world_group =
Mpi.comm_group Mpi.comm_world
in
let new_group =
Mpi.group_incl world_group ranks
in
Mpi.comm_create Mpi.comm_world new_group
let rank =
if Mpi.comm_is_null comm then 0 else
Mpi.comm_rank comm
let master = rank = 0
let broadcast_generic broadcast x =
if Mpi.comm_is_null comm then
Lazy.force x
else
begin
let x =
if master then Some (Lazy.force x)
else None
in
match broadcast x 0 comm with
| Some x -> x
| None -> assert false
end
let broadcast x = broadcast_generic Mpi.broadcast x
let barrier () =
if Mpi.comm_is_null comm then () else
Mpi.barrier comm
let _ = barrier ()
end
module Vec = struct
type t =
{
global_first : int ; (* Lower index in the global array *)
global_last : int ; (* Higher index in the global array *)
local_first : int ; (* Lower index in the local array *)
local_last : int ; (* Higher index in the local array *)
data : Lacaml.D.vec ; (* Lacaml vector containing the data *)
}
let dim vec =
vec.global_last - vec.global_first + 1
let local_first vec = vec.local_first
let local_last vec = vec.local_last
let global_first vec = vec.global_first
let global_last vec = vec.global_last
let data vec = vec.data
let pp ppf v =
Format.fprintf ppf "@[<2>";
Format.fprintf ppf "@[ gf : %d@]@;" v.global_first;
Format.fprintf ppf "@[ gl : %d@]@;" v.global_last;
Format.fprintf ppf "@[ lf : %d@]@;" v.local_first;
Format.fprintf ppf "@[ ll : %d@]@;" v.local_last;
Format.fprintf ppf "@[ data : %a@]@;" (Lacaml.Io.pp_lfvec ()) v.data;
Format.fprintf ppf "@]@.";
()
let create n =
let step = (n-1) / size + 1 in
let local_first = step * rank + 1 in
let local_last = min (local_first + step - 1) n in
{
global_first = 1 ;
global_last = n ;
local_first ;
local_last ;
data = Lacaml.D.Vec.create (max 0 (local_last - local_first + 1))
}
let make n x =
let result = create n in
{ result with data =
Lacaml.D.Vec.make
(Lacaml.D.Vec.dim result.data)
x
}
let make0 n =
make n 0.
let init n f =
let result = create n in
{ result with data =
Lacaml.D.Vec.init
(Lacaml.D.Vec.dim result.data)
(fun i -> f (i+result.local_first-1))
}
let of_array a =
let length_a = Array.length a in
let a =
let n = length_a mod size in
if n > 0 then
Array.concat [ a ; Array.make (size-n) 0. ]
else
a
in
let result = create length_a in
let a_local = Array.make ((Array.length a)/size) 0. in
let () = Mpi.scatter_float_array a a_local 0 Mpi.comm_world in
{ result with data = Lacaml.D.Vec.of_array a_local }
let to_array vec =
let final_size = dim vec in
let buffer_size = (Lacaml.D.Vec.dim vec.data) * size in
let buffer = Array.make buffer_size 0. in
let data = Lacaml.D.Vec.to_array vec.data in
let () = Mpi.gather_float_array data buffer 0 Mpi.comm_world in
if final_size = buffer_size then
buffer
else
Array.init final_size (fun i -> buffer.(i))
let of_vec a =
Lacaml.D.Vec.to_array a
|> of_array
let to_vec v =
to_array v
|> Lacaml.D.Vec.of_array
end
let dot v1 v2 =
if Vec.dim v1 <> Vec.dim v2 then
invalid_arg "Incompatible dimensions";
let local_dot =
Lacaml.D.dot (Vec.data v1) (Vec.data v2)
in
Mpi.reduce_float local_dot Mpi.Float_sum 0 Mpi.comm_world

171
Parallel_mpi/Parallel.mli
View File

@ -1,171 +0,0 @@
(** Module for handling distributed parallelism *)
val size : int
(** Number of distributed processes. *)
val rank : Mpi.rank
(** Rank of the current distributed processe. *)
val master : bool
(** True if [rank = 0]. *)
val barrier : unit -> unit
(** Wait for all processes to reach this point. *)
val broadcast : 'a lazy_t -> 'a
(** Broadcasts data to all processes. *)
val broadcast_int : int -> int
(** Broadcasts an [int] to all processes. *)
val broadcast_float : float -> float
(** Broadcasts a [float] to all processes. *)
val broadcast_int_array : int array -> int array
(** Broadcasts an [int array] to all processes. *)
val broadcast_float_array : float array -> float array
(** Broadcasts a [float array] to all processes. *)
val broadcast_vec : Lacaml.D.vec -> Lacaml.D.vec
(** Broadcasts a Lacaml vector to all processes. *)
(** {5 Intra-node operations} *)
module Node : sig
(** This module contains parallel primitives among processes
within the same compute node.
*)
val name : string
(** Name of the current host *)
val comm : Mpi.communicator
(** MPI Communicator containing the processes of the current node *)
val rank : Mpi.rank
(** Rank of the current process in the node *)
val master : bool
(** If true, master process of the node *)
val broadcast : 'a lazy_t -> 'a
(** Broadcasts data to all the processes of the current node. *)
val barrier : unit -> unit
(** Wait for all processes among the node to reach this point. *)
end
(** {5 Inter-node operations} *)
module InterNode : sig
val comm : Mpi.communicator
(** MPI Communicator among the master processes of the each node *)
val rank : Mpi.rank
(** Rank of the current process in the inter-node communicator *)
val master : bool
(** If true, master process of the inter-node communicator *)
val broadcast : 'a lazy_t -> 'a
(** Broadcasts data to all the processes of the inter-node communicator. *)
val barrier : unit -> unit
(** Wait for all processes among the node to reach this point. *)
end
(** {5 Vector operations} *)
module Vec : sig
type t = private
{
global_first : int ; (* Lower index in the global array *)
global_last : int ; (* Higher index in the global array *)
local_first : int ; (* Lower index in the local array *)
local_last : int ; (* Higher index in the local array *)
data : Lacaml.D.vec ; (* Lacaml vector containing the data *)
}
val pp : Format.formatter -> t -> unit
(** {6 Creation/conversion of vectors} *)
val create : int -> t
(** [create n] @return a distributed vector with [n] rows (not initialized). *)
val make : int -> float -> t
(** [make n x] @return a distributed vector with [n] rows initialized with value [x]. *)
val make0 : int -> t
(** [make0 n x] @return a distributed vector with [n] rows initialized with the zero
element. *)
val init : int -> (int -> float) -> t
(** [init n f] @return a distributed vector containing [n] elements, where
each element at position [i] is initialized by the result of calling [f i]. *)
val of_array : float array -> t
(** [of_array ar] @return a distributed vector initialized from array [ar]. *)
val to_array : t -> float array
(** [to_array v] @return an array initialized from vector [v]. *)
val of_vec : Lacaml.D.vec -> t
(** [of_vec vec] @return a distributed vector initialized from Lacaml vector [vec]. *)
val to_vec : t -> Lacaml.D.vec
(** [to_vec v] @return a Lacaml vector initialized from vector [v]. *)
(** {6 Accessors } *)
val dim : t -> int
(** [dim v] @return the dimension of the vector [v]. *)
val global_first : t -> int
(** [global_first v] @return the index of the first element of [v]. *)
val global_last : t -> int
(** [global_last v] @return the index of the last element of [v]. *)
val local_first : t -> int
(** [local_first v] @return the index of the first element of the local piece of [v]. *)
val global_last : t -> int
(** [local_last v] @return the index of the last element of the local piece of [v]. *)
val data : t -> Lacaml.D.vec
(** [data v] @return the local Lacaml vector in which the piece of the vector [v] is stored. *)
end
(*
module Mat : sig
type t =
{
global_first_row : int ; (* Lower row index in the global array *)
global_last_row : int ; (* Higher row index in the global array *)
global_first_col : int ; (* Lower column index in the global array *)
global_last_col : int ; (* Higher column index in the global array *)
local_first_row : int ; (* Lower row index in the local array *)
local_last_row : int ; (* Higher row index in the local array *)
local_first_col : int ; (* Lower column index in the local array *)
local_last_col : int ; (* Higher column index in the local array *)
data : Lacaml.D.mat ; (* Lacaml matrix containing the data *)
}
end
val gemm : Mat.t -> Mat.t -> Mat.t
(* Distributed matrix-matrix product. The result is a distributed matrix. *)
*)
val dot : Vec.t -> Vec.t-> float
(* Dot product between distributed vectors. *)

24
Parallel_mpi/SharedMemory.ml
View File

@ -1,24 +0,0 @@
let create ?(temp_dir="/dev/shm") data_type size_array =
let filename =
Parallel.Node.broadcast (lazy (Filename.temp_file ~temp_dir "4idx." ".tmp"))
in
if Parallel.Node.master then
begin
let fd = Unix.openfile filename Unix.[O_RDWR ; O_CREAT] 0o777 in
let result =
Unix.map_file fd data_type Bigarray.fortran_layout true size_array
in
Bigarray.Genarray.fill result 0.;
Parallel.Node.barrier ();
at_exit (fun () -> Unix.close fd ; try Sys.remove filename with _ -> ());
result
end
else
begin
Parallel.Node.barrier ();
let fd = Unix.openfile filename [Unix.O_RDONLY] 0o777 in
at_exit (fun () -> Unix.close fd ; try Sys.remove filename with _ -> ());
Unix.map_file fd data_type Bigarray.fortran_layout false size_array
end

13
Parallel_serial/Farm.ml
View File

@ -1,13 +0,0 @@
(* Single process function *)
let run_sequential f stream =
let next _ =
try
let task = Stream.next stream in
Some (f task)
with Stream.Failure -> None in
Stream.from next
let run ?(ordered=true) ?(comm) ~f stream =
run_sequential f stream

16
Parallel_serial/Farm.mli
View File

@ -1,16 +0,0 @@
(** The Farm skeleton, similar to SklMl.
The input is a stream of input data, and the output is a stream of data.
*)
val run : ?ordered:bool -> ?comm:'c ->
f:('a -> 'b) -> 'a Stream.t -> 'b Stream.t
(** Run the [f] function on every process by popping elements from the
input stream, and putting the results on the output stream. If [ordered]
(the default is [ordered = true], then the order of the output is kept
consistent with the order of the input.
In the non-parallel mode, the [comm] argument is unused.
*)

155
Parallel_serial/Parallel.ml
View File

@ -1,155 +0,0 @@
(** Module for handling distributed parallelism *)
let size = 1
let rank = 0
let master = true
let barrier () = ()
let broadcast x = Lazy.force x
let broadcast_int x = x
let broadcast_int_array x = x
let broadcast_float x = x
let broadcast_float_array x = x
let broadcast_vec x = x
module Node = struct
let name = Unix.gethostname ()
let comm = None
let rank = 0
let master = true
let broadcast x = Lazy.force x
let barrier () = ()
end
module InterNode = struct
let comm = None
let rank = 0
let master = true
let broadcast x = Lazy.force x
let barrier () = ()
end
module Vec = struct
type t =
{
global_first : int ; (* Lower index in the global array *)
global_last : int ; (* Higher index in the global array *)
local_first : int ; (* Lower index in the local array *)
local_last : int ; (* Higher index in the local array *)
data : Lacaml.D.vec ; (* Lacaml vector containing the data *)
}
let dim vec =
vec.global_last - vec.global_first + 1
let local_first vec = vec.local_first
let local_last vec = vec.local_last
let global_first vec = vec.global_first
let global_last vec = vec.global_last
let data vec = vec.data
let pp ppf v =
Format.fprintf ppf "@[<2>";
Format.fprintf ppf "@[ gf : %d@]@;" v.global_first;
Format.fprintf ppf "@[ gl : %d@]@;" v.global_last;
Format.fprintf ppf "@[ lf : %d@]@;" v.local_first;
Format.fprintf ppf "@[ ll : %d@]@;" v.local_last;
Format.fprintf ppf "@[ data : %a@]@;" (Lacaml.Io.pp_lfvec ()) v.data;
Format.fprintf ppf "@]@.";
()
let create n =
{
global_first = 1 ;
global_last = n ;
local_first = 1 ;
local_last = n ;
data = Lacaml.D.Vec.create n
}
let make n x =
let result = create n in
{ result with data =
Lacaml.D.Vec.make
(Lacaml.D.Vec.dim result.data)
x
}
let make0 n =
make n 0.
let init n f =
let result = create n in
{ result with data =
Lacaml.D.Vec.init
(Lacaml.D.Vec.dim result.data)
(fun i -> f (i+result.local_first-1))
}
let of_array a =
let length_a = Array.length a in
let a =
let n = length_a mod size in
if n > 0 then
Array.concat [ a ; Array.make (size-n) 0. ]
else
a
in
let result = create length_a in
let a_local = Array.make (Array.length a) 0. in
{ result with data = Lacaml.D.Vec.of_array a_local }
let to_array vec =
Lacaml.D.Vec.to_array vec.data
|> Array.copy
let of_vec a =
Lacaml.D.Vec.to_array a
|> of_array
let to_vec v =
to_array v
|> Lacaml.D.Vec.of_array
end
let dot v1 v2 =
if Vec.dim v1 <> Vec.dim v2 then
invalid_arg "Incompatible dimensions";
Lacaml.D.dot (Vec.data v1) (Vec.data v2)

167
Parallel_serial/Parallel.mli
View File

@ -1,167 +0,0 @@
(** Module for handling distributed parallelism *)
val size : int
(** Number of distributed processes. *)
val rank : int
(** Rank of the current distributed processe. *)
val master : bool
(** True if [rank = 0]. *)
val barrier : unit -> unit
(** Wait for all processes to reach this point. *)
val broadcast : 'a lazy_t -> 'a
(** Broadcasts data to all processes. *)
val broadcast_int : int -> int
(** Broadcasts an [int] to all processes. *)
val broadcast_float : float -> float
(** Broadcasts a [float] to all processes. *)
val broadcast_int_array : int array -> int array
(** Broadcasts an [int array] to all processes. *)
val broadcast_float_array : float array -> float array
(** Broadcasts a [float array] to all processes. *)
val broadcast_vec : Lacaml.D.vec -> Lacaml.D.vec
(** Broadcasts a Lacaml vector to all processes. *)
(** {5 Intra-node operations} *)
module Node : sig
val name : string
(** Name of the current host *)
val comm : 'a option
(** Always [None] *)
val rank : int
(** Always zero *)
val master : bool
(** Always true *)
val broadcast : 'a lazy_t -> 'a
(** Same as Lazy.force *)
val barrier : unit -> unit
(** Does nothing. *)
end
(** {5 Inter-node operations} *)
module InterNode : sig
val comm : 'a option
(** Always [None] *)
val rank : int
(** Always zero *)
val master : bool
(** Always true *)
val broadcast : 'a lazy_t -> 'a
(** Same as Lazy.force *)
val barrier : unit -> unit
(** Does nothing. *)
end
(** {5 Vector operations} *)
module Vec : sig
type t = private
{
global_first : int ; (* Lower index in the global array *)
global_last : int ; (* Higher index in the global array *)
local_first : int ; (* Lower index in the local array *)
local_last : int ; (* Higher index in the local array *)
data : Lacaml.D.vec ; (* Lacaml vector containing the data *)
}
val pp : Format.formatter -> t -> unit
(** {6 Creation/conversion of vectors} *)
val create : int -> t
(** [create n] @return a distributed vector with [n] rows (not initialized). *)
val make : int -> float -> t
(** [make n x] @return a distributed vector with [n] rows initialized with value [x]. *)
val make0 : int -> t
(** [make0 n x] @return a distributed vector with [n] rows initialized with the zero
element. *)
val init : int -> (int -> float) -> t
(** [init n f] @return a distributed vector containing [n] elements, where
each element at position [i] is initialized by the result of calling [f i]. *)
val of_array : float array -> t
(** [of_array ar] @return a distributed vector initialized from array [ar]. *)
val to_array : t -> float array
(** [to_array v] @return an array initialized from vector [v]. *)
val of_vec : Lacaml.D.vec -> t
(** [of_vec vec] @return a distributed vector initialized from Lacaml vector [vec]. *)
val to_vec : t -> Lacaml.D.vec
(** [to_vec v] @return a Lacaml vector initialized from vector [v]. *)
(** {6 Accessors } *)
val dim : t -> int
(** [dim v] @return the dimension of the vector [v]. *)
val global_first : t -> int
(** [global_first v] @return the index of the first element of [v]. *)
val global_last : t -> int
(** [global_last v] @return the index of the last element of [v]. *)
val local_first : t -> int
(** [local_first v] @return the index of the first element of the local piece of [v]. *)
val global_last : t -> int
(** [local_last v] @return the index of the last element of the local piece of [v]. *)
val data : t -> Lacaml.D.vec
(** [data v] @return the local Lacaml vector in which the piece of the vector [v] is stored. *)
end
(*
module Mat : sig
type t =
{
global_first_row : int ; (* Lower row index in the global array *)
global_last_row : int ; (* Higher row index in the global array *)
global_first_col : int ; (* Lower column index in the global array *)
global_last_col : int ; (* Higher column index in the global array *)
local_first_row : int ; (* Lower row index in the local array *)
local_last_row : int ; (* Higher row index in the local array *)
local_first_col : int ; (* Lower column index in the local array *)
local_last_col : int ; (* Higher column index in the local array *)
data : Lacaml.D.mat ; (* Lacaml matrix containing the data *)
}
end
val gemm : Mat.t -> Mat.t -> Mat.t
(* Distributed matrix-matrix product. The result is a distributed matrix. *)
*)
val dot : Vec.t -> Vec.t-> float
(* Dot product between distributed vectors. *)

7
Parallel_serial/SharedMemory.ml
View File

@ -1,7 +0,0 @@
let create ?(temp_dir="/dev/shm") data_type size_array =
let result =
Bigarray.Genarray.create data_type Bigarray.fortran_layout size_array
in
Bigarray.Genarray.fill result 0.;
result

1
Perturbation/.merlin
View File

@ -1 +0,0 @@
REC

60
Perturbation/MP2.ml
View File

@ -1,60 +0,0 @@
type t = float
let make ~frozen_core hf =
let mo_basis =
MOBasis.of_hartree_fock hf
in
let epsilon =
MOBasis.mo_energies mo_basis
in
let mo_class =
MOClass.cas_sd mo_basis ~frozen_core 0 0
|> MOClass.to_list
in
let eri =
MOBasis.ee_ints mo_basis
in
let inactives =
List.filter (fun i ->
match i with MOClass.Inactive _ -> true | _ -> false) mo_class
and virtuals =
List.filter (fun i ->
match i with MOClass.Virtual _ -> true | _ -> false) mo_class
in
let rmp2 () =
List.fold_left (fun accu b ->
match b with MOClass.Virtual b ->
let eps = -. epsilon.{b} in
accu +.
List.fold_left (fun accu a ->
match a with MOClass.Virtual a ->
let eps = eps -. epsilon.{a} in
accu +.
List.fold_left (fun accu j ->
match j with MOClass.Inactive j ->
let eps = eps +. epsilon.{j} in
accu +.
List.fold_left (fun accu i ->
match i with MOClass.Inactive i ->
let eps = eps +. epsilon.{i} in
let ijab = ERI.get_phys eri i j a b
and abji = ERI.get_phys eri a b j i in
let abij = ijab in
accu +. ijab *. ( abij +. abij -. abji) /. eps
| _ -> accu
) 0. inactives
| _ -> accu
) 0. inactives
| _ -> accu
) 0. virtuals
| _ -> accu
) 0. virtuals
in
match HartreeFock.kind hf with
| HartreeFock.RHF -> rmp2 ()
| _ -> failwith "Not implemented"

79
README.md
View File

@ -3,15 +3,92 @@ QCaml (Quantum Camel)
<img src="data/chamo_bg.png" width="300" >
QCaml is a quantum chemistry software written in OCaml.
Requirements
------------
* MPI : Message Passing Interface
* BLAS/LAPACK : Linear algebra
* LaCaml : LAPACK OCaml interface
* Zarith : Arbitrary-precision integers
* GetOpt : Parsing of command-line
* gmp : GNU Multiple Precision arithmetic library
* odoc-ltxhtml : https://github.com/akabe/odoc-ltxhtml
* Alcotest : Lightweight testing framework
```bash
opam install dune lacaml getopt alcotest zarith
```
To use the Intel MKL library:
```bash
export LACAML_LIBS="-L${MKLROOT}/lib/intel64 -Wl,--no-as-needed -lmkl_rt -lpthread -lm -ldl"
opam install lacaml
odoc-ltxhtml allows to embed equations in the documentation generated by Ocamldoc.
Download the source code [here](https://github.com/scemama/odoc-ltxhtml).
```bash
git clone https://github.com/scemama/odoc-ltxhtml
cd odoc-ltxhtml
make install
```
How to build the project
------------------------
Run `make` to compile the libraries and executables that are
meant to be installed.
```
$ make
```
How to run tests
----------------
```
$ make test
```
How to use local libraries interactively
----------------------------------------
Use `dune utop DIR` where DIR if the folder contains the `dune`
file for a library. For instance, our `sub2` sample library can be
used as follows:
```
$ dune utop sub2/lib
...
utop # Proj_sub2.A.do_something ();;
1525373137.245 seconds have elapsed since 1970-01-01T00:00:00.
- : unit = ()
```
Installation
------------
The project can be installed with or without opam.
Without opam, you can run the following which relies directly on
dune:
```
$ make install
```
Similarly:
```
$ make uninstall
```
With opam, you can install the current development version of your
project as a single opam package. It will override the currently
installed package of the same name, if any:
```
$ opam pin add proj .
```
For more information on `opam pin`, please consult the opam documentation.
The advantage of the opam-based method is that other opam packages can
depend on this one, and opam will recompile them automatically as
necessary.

244
SCF/Fock.ml
View File

@ -1,244 +0,0 @@
open Lacaml.D
open Simulation
open Constants
open Util
type t =
{
fock : Mat.t ;
core : Mat.t ;
coulomb : Mat.t ;
exchange : Mat.t ;
}
let fock t = t.fock
let core t = t.core
let coulomb t = t.coulomb
let exchange t = t.exchange
module Ao = AOBasis
let make_rhf ~density ?(threshold=Constants.epsilon) ao_basis =
let m_P = density
and m_T = Ao.kin_ints ao_basis |> KinInt.matrix
and m_V = Ao.eN_ints ao_basis |> NucInt.matrix
and m_G = Ao.ee_ints ao_basis
in
let nBas = Mat.dim1 m_T
in
let m_Hc = Mat.add m_T m_V
and m_J = Array.make_matrix nBas nBas 0.
and m_K = Array.make_matrix nBas nBas 0.
in
for sigma = 1 to nBas do
let m_Ksigma = m_K.(sigma-1) in
for nu = 1 to nBas do
let m_Jnu = m_J.(nu-1) in
for lambda = 1 to nBas do
let pJ = m_P.{lambda,sigma}
and pK = 0.5 *. m_P.{lambda,nu}
in
match (abs_float pJ > threshold , abs_float pK > threshold, nu < sigma) with
| (false, false, _) -> ()
| (true , true , true) ->
begin
for mu = 1 to nu do
let integral =
ERI.get_phys m_G mu lambda nu sigma
in
if (integral <> 0.) then begin
m_Jnu.(mu-1) <- m_Jnu.(mu-1) +. pJ *. integral;
m_Ksigma.(mu-1) <- m_Ksigma.(mu-1) +. pK *. integral
end
done;
for mu = nu+1 to sigma do
m_Ksigma.(mu-1) <- m_Ksigma.(mu-1) +. pK *.
ERI.get_phys m_G mu lambda nu sigma
done
end
| (true , true , false) ->
begin
for mu = 1 to sigma do
let integral =
ERI.get_phys m_G mu lambda nu sigma
in
if (integral <> 0.) then begin
m_Jnu.(mu-1) <- m_Jnu.(mu-1) +. pJ *. integral;
m_Ksigma.(mu-1) <- m_Ksigma.(mu-1) +. pK *. integral
end
done;
for mu = sigma+1 to nu do
m_Jnu.(mu-1) <-
m_Jnu.(mu-1) +. pJ *. ERI.get_phys m_G mu lambda nu sigma
done
end
| (false, true , _) ->
for mu = 1 to sigma do
m_Ksigma.(mu-1) <-
m_Ksigma.(mu-1) +. pK *. ERI.get_phys m_G mu lambda nu sigma
done
| (true , false, _) ->
for mu = 1 to nu do
m_Jnu.(mu-1) <-
m_Jnu.(mu-1) +. pJ *. ERI.get_phys m_G mu lambda nu sigma
done
done
done;
for mu = 1 to sigma-1 do
m_K.(mu-1).(sigma-1) <- m_Ksigma.(mu-1);
done
done;
for nu = 1 to nBas do
let m_Jnu = m_J.(nu-1) in
for mu = 1 to nu-1 do
m_J.(mu-1).(nu-1) <- m_Jnu.(mu-1)
done
done;
let m_J = Mat.of_array m_J
and m_K = Mat.of_array m_K
in
{ fock = Mat.add m_Hc (Mat.sub m_J m_K) ;
core = m_Hc ; coulomb = m_J ; exchange = m_K }
let make_uhf ~density_same ~density_other ?(threshold=Constants.epsilon) ao_basis =
let m_P_a = density_same
and m_P_b = density_other
and m_T = Ao.kin_ints ao_basis |> KinInt.matrix
and m_V = Ao.eN_ints ao_basis |> NucInt.matrix
and m_G = Ao.ee_ints ao_basis
in
let nBas = Mat.dim1 m_T
in
let m_Hc = Mat.add m_T m_V
and m_J = Array.make_matrix nBas nBas 0.
and m_K = Array.make_matrix nBas nBas 0.
in
for sigma = 1 to nBas do
let m_Ksigma = m_K.(sigma-1) in
for nu = 1 to nBas do
let m_Jnu = m_J.(nu-1) in
for lambda = 1 to nBas do
let pJ = m_P_a.{lambda,sigma} +. m_P_b.{lambda,sigma}
and pK = m_P_a.{lambda,nu}
in
match (abs_float pJ > threshold , abs_float pK > threshold, nu < sigma) with
| (false, false, _) -> ()
| (true , true , true) ->
begin
for mu = 1 to nu do
let integral =
ERI.get_phys m_G mu lambda nu sigma
in
if (integral <> 0.) then begin
m_Jnu.(mu-1) <- m_Jnu.(mu-1) +. pJ *. integral;
m_Ksigma.(mu-1) <- m_Ksigma.(mu-1) +. pK *. integral
end
done;
for mu = nu+1 to sigma do
m_Ksigma.(mu-1) <- m_Ksigma.(mu-1) +. pK *.
ERI.get_phys m_G mu lambda nu sigma
done
end
| (true , true , false) ->
begin
for mu = 1 to sigma do
let integral =
ERI.get_phys m_G mu lambda nu sigma
in
if (integral <> 0.) then begin
m_Jnu.(mu-1) <- m_Jnu.(mu-1) +. pJ *. integral;
m_Ksigma.(mu-1) <- m_Ksigma.(mu-1) +. pK *. integral
end
done;
for mu = sigma+1 to nu do
m_Jnu.(mu-1) <-
m_Jnu.(mu-1) +. pJ *. ERI.get_phys m_G mu lambda nu sigma
done
end
| (false, true , _) ->
for mu = 1 to sigma do
m_Ksigma.(mu-1) <-
m_Ksigma.(mu-1) +. pK *. ERI.get_phys m_G mu lambda nu sigma
done
| (true , false, _) ->
for mu = 1 to nu do
m_Jnu.(mu-1) <-
m_Jnu.(mu-1) +. pJ *. ERI.get_phys m_G mu lambda nu sigma
done
done
done;
for mu = 1 to sigma-1 do
m_K.(mu-1).(sigma-1) <- m_Ksigma.(mu-1);
done
done;
for nu = 1 to nBas do
let m_Jnu = m_J.(nu-1) in
for mu = 1 to nu-1 do
m_J.(mu-1).(nu-1) <- m_Jnu.(mu-1)
done
done;
let m_J = Mat.of_array m_J
and m_K = Mat.of_array m_K
in
{ fock = Mat.add m_Hc (Mat.sub m_J m_K) ;
core = m_Hc ; coulomb = m_J ; exchange = m_K }
let op ~f f1 f2 =
assert (f1.core = f2.core);
let m_Hc = f1.core
and m_J = f f1.coulomb f2.coulomb
and m_K = f f1.exchange f2.exchange
in
{
fock = Mat.add m_Hc (Mat.sub m_J m_K);
core = m_Hc;
coulomb = m_J;
exchange = m_K;
}
let add = op ~f:(fun a b -> Mat.add a b)
let sub = op ~f:(fun a b -> Mat.sub a b)
let scale alpha f1 =
let m_Hc = f1.core
and m_J = lacpy f1.coulomb
and m_K = lacpy f1.exchange
in
Mat.scal alpha m_J;
Mat.scal alpha m_K;
{
fock = Mat.add m_Hc (Mat.sub m_J m_K);
core = m_Hc;
coulomb = m_J;
exchange = m_K;
}
let pp ppf a =
Format.fprintf ppf "@[<2>";
Format.fprintf ppf "@[ Fock matrix:@[<2>@[%a@]@.]@]" pp_matrix a.fock;
Format.fprintf ppf "@[ Core Hamiltonian:@[<2>@[%a@]@.]@]" pp_matrix a.core;
Format.fprintf ppf "@[ Coulomb matrix:@[<2>@[%a@]@.]@]" pp_matrix a.coulomb;
Format.fprintf ppf "@[ Exchange matrix:@[<2>@[%a@]@.]@]" pp_matrix a.exchange;
Format.fprintf ppf "@]"

50
SCF/Fock.mli
View File

@ -1,50 +0,0 @@
(** Type for the Fock operator in AO basis. *)
open Lacaml.D
type t
(** {1 Accessors} *)
val fock : t -> Mat.t
(** Fock matrix in AO basis *)
val core : t -> Mat.t
(** Core Hamiltonian : {% $\langle i | \hat{h} | j \rangle$ %} *)
val coulomb : t -> Mat.t
(** Coulomb matrix : {% $\langle i | J | j \rangle$ %} *)
val exchange : t -> Mat.t
(** Exchange matrix : {% $\langle i | K | j \rangle$ %} *)
(** {1 Creators} *)
val make_rhf : density:Mat.t -> ?threshold:float -> AOBasis.t -> t
(** Create a Fock operator in the RHF formalism. Expected density is
{% $2 \mathbf{C\, C}^\dagger$ %}. [threshold] is a threshold on the
integrals. *)
val make_uhf : density_same: Mat.t -> density_other:Mat.t -> ?threshold:float ->
AOBasis.t -> t
(** Create a Fock operator in the UHF formalism. Expected density is
{% $\mathbf{C\, C}^\dagger$ %}. When building the {% $\alpha$ %} Fock
operator, [density_same] is the {% $\alpha$ %} density and [density_other]
is the {% $\beta$ %} density. [threshold] is a threshold on the integrals. *)
(** {1 Operations} *)
val add : t -> t -> t
(** Add two Fock operators sharing the same core Hamiltonian. *)
val sub : t -> t -> t
(** Subtract two Fock operators sharing the same core Hamiltonian. *)
(** {1 Printers} *)
val pp : Format.formatter -> t -> unit

82
SCF/Guess.ml
View File

@ -1,82 +0,0 @@
open Lacaml.D
open Util
type guess =
| Hcore of Mat.t
| Huckel of Mat.t
| Matrix of Mat.t
type t = guess
module Ao = AOBasis
module El = Electrons
module Ov = Overlap
let hcore_guess ao_basis =
let eN_ints = Ao.eN_ints ao_basis |> NucInt.matrix
and kin_ints = Ao.kin_ints ao_basis |> KinInt.matrix
in
Mat.add eN_ints kin_ints
let huckel_guess ao_basis =
let c = 0.5 *. 1.75 in
let eN_ints = Ao.eN_ints ao_basis |> NucInt.matrix
and kin_ints = Ao.kin_ints ao_basis |> KinInt.matrix
in
let m_F =
Mat.add eN_ints kin_ints
in
let ao_num = Ao.basis ao_basis |> Basis.size
and overlap = Ao.overlap ao_basis |> Ov.matrix
in
let diag = Vec.init ao_num (fun i ->
m_F.{i,i} )
in
function
| 0 -> invalid_arg "Huckel guess needs a non-zero number of occupied MOs."
| nocc ->
Mat.init_cols ao_num ao_num (fun i j ->
if (i<>j) then
if (diag.{i} +. diag.{j}) < 0. then
c *. overlap.{i,j} *. (diag.{i} +. diag.{j}) +. m_F.{i,j} (*TODO Pseudo *)
else
m_F.{i,j} (*TODO Pseudo *)
else
diag.{i}
)
let make ?(nocc=0) ~guess ao_basis =
match guess with
| `Hcore -> Hcore (hcore_guess ao_basis)
| `Huckel -> Huckel (huckel_guess ao_basis nocc)
| `Matrix m -> Matrix m
let test_case ao_basis =
let test_hcore () =
match make ~guess:`Hcore ao_basis with
| Hcore matrix ->
let a = Lacaml.D.Mat.to_array matrix in
let reference =
Lacaml.D.Mat.add
(AOBasis.eN_ints ao_basis |> NucInt.matrix)
(AOBasis.kin_ints ao_basis |> KinInt.matrix)
|> Lacaml.D.Mat.to_array
in
Array.iteri (fun i x ->
let message =
Printf.sprintf "Guess line %d" (i)
in
Alcotest.(check (array (float 1.e-15))) message a.(i) x) reference
| _ -> assert false
in
[
"HCore", `Quick, test_hcore;
]

18
SCF/Guess.mli
View File

@ -1,18 +0,0 @@
open Lacaml.D
(** Guess for Hartree-Fock calculations. *)
type guess =
| Hcore of Mat.t (* Core Hamiltonian Matrix *)
| Huckel of Mat.t (* Huckel Hamiltonian Matrix *)
| Matrix of Mat.t (* Guess Eigenvectors *)
type t = guess
val make : ?nocc:int -> guess:[ `Hcore | `Huckel | `Matrix of Mat.t ] -> AOBasis.t -> t
(** {2 Tests} *)
val test_case : AOBasis.t -> unit Alcotest.test_case list

725
SCF/HartreeFock.ml
View File

@ -1,725 +0,0 @@
open Lacaml.D
open Util
open Constants
type hartree_fock_data =
{
iteration : int ;
coefficients : Mat.t option ;
eigenvalues : Vec.t option ;
error : float option ;
diis : DIIS.t option ;
energy : float option ;
density : Mat.t option ;
density_a : Mat.t option ;
density_b : Mat.t option ;
fock : Fock.t option ;
fock_a : Fock.t option ;
fock_b : Fock.t option ;
}
type hartree_fock_kind =
| RHF (** Restricted Hartree-Fock *)
| ROHF (** Restricted Open-shell Hartree-Fock *)
| UHF (** Unrestricted Hartree-Fock *)
type t =
{
kind : hartree_fock_kind;
simulation : Simulation.t;
guess : Guess.t;
data : hartree_fock_data option lazy_t array;
nocc : int ;
}
let empty =
{
iteration = 0 ;
coefficients = None ;
eigenvalues = None ;
error = None ;
diis = None ;
energy = None ;
density = None ;
density_a = None ;
density_b = None ;
fock = None ;
fock_a = None ;
fock_b = None ;
}
module Si = Simulation
module El = Electrons
module Ao = AOBasis
module Ov = Overlap
let kind t = t.kind
let simulation t = t.simulation
let guess t = t.guess
let nocc t = t.nocc
let n_iterations t =
Array.fold_left (fun accu x ->
match Lazy.force x with
| Some x -> accu + 1
| None -> accu
) 0 t.data
let last_iteration t =
of_some @@ Lazy.force (t.data.(n_iterations t - 1))
let eigenvectors t =
let data = last_iteration t in
of_some data.coefficients
let eigenvalues t =
let data = last_iteration t in
of_some data.eigenvalues
let density t =
let data = last_iteration t in
match kind t with
| RHF -> of_some data.density
| ROHF -> Mat.add (of_some data.density_a) (of_some data.density_b)
| _ -> failwith "Not implemented"
let occupation t =
let n_alfa, n_beta =
El.n_alfa @@ Simulation.electrons @@ simulation t,
El.n_beta @@ Simulation.electrons @@ simulation t
in
match kind t with
| RHF -> Vec.init (Mat.dim2 @@ eigenvectors t) (fun i ->
if i <= nocc t then 2.0 else 0.0)
| ROHF -> Vec.init (Mat.dim2 @@ eigenvectors t) (fun i ->
if i <= n_beta then 2.0 else
if i <= n_alfa then 1.0 else
0.0)
| _ -> failwith "Not implemented"
let energy t =
let data = last_iteration t in
of_some data.energy
let nuclear_repulsion t =
Si.nuclear_repulsion (simulation t)
let ao_basis t =
Si.ao_basis (simulation t)
let kin_energy t =
let m_T =
ao_basis t
|> Ao.kin_ints
|> KinInt.matrix
in
let m_P = density t in
Mat.gemm_trace m_P m_T
let eN_energy t =
let m_V =
ao_basis t
|> Ao.eN_ints
|> NucInt.matrix
in
let m_P = density t in
Mat.gemm_trace m_P m_V
let coulomb_energy t =
let data =
last_iteration t
in
match kind t with
| RHF -> let m_P = of_some data.density in
let fock = of_some data.fock in
let m_J = Fock.coulomb fock in
0.5 *. Mat.gemm_trace m_P m_J
| ROHF -> let m_P_a = of_some data.density_a in
let m_P_b = of_some data.density_b in
let fock_a = of_some data.fock_a in
let fock_b = of_some data.fock_b in
let m_J_a = Fock.coulomb fock_a in
let m_J_b = Fock.coulomb fock_b in
0.5 *. ( (Mat.gemm_trace m_P_a m_J_a) +. (Mat.gemm_trace m_P_b m_J_b) )
| _ -> failwith "Not implemented"
let exchange_energy t =
let data =
last_iteration t
in
match kind t with
| RHF -> let m_P = of_some data.density in
let fock = of_some data.fock in
let m_K = Fock.exchange fock in
-. 0.5 *. Mat.gemm_trace m_P m_K
| ROHF -> let m_P_a = of_some data.density_a in
let m_P_b = of_some data.density_b in
let fock_a = of_some data.fock_a in
let fock_b = of_some data.fock_b in
let m_K_a = Fock.exchange fock_a in
let m_K_b = Fock.exchange fock_b in
-. 0.5 *. ( (Mat.gemm_trace m_P_a m_K_a) +. (Mat.gemm_trace m_P_b m_K_b) )
| _ -> failwith "Not implemented"
let make
?kind
?guess:(guess=`Huckel)
?max_scf:(max_scf=64)
?level_shift:(level_shift=0.2)
?threshold_SCF:(threshold_SCF=1.e-8)
simulation =
(* Number of occupied MOs *)
let n_alfa, n_beta =
El.n_alfa @@ Si.electrons simulation,
El.n_beta @@ Si.electrons simulation
in
let nocc = n_alfa in
let kind =
match kind with
| Some kind -> kind
| None -> if (n_alfa = n_beta) then RHF else ROHF
in
let nuclear_repulsion =
Si.nuclear_repulsion simulation
in
let ao_basis =
Si.ao_basis simulation
in
(* Orthogonalization matrix *)
let m_X =
Ao.ortho ao_basis
in
(* Overlap matrix *)
let m_S =
Ao.overlap ao_basis
|> Ov.matrix
in
(* Level shift in MO basis *)
let m_LSmo =
Array.init (Mat.dim2 m_X) (fun i ->
if i > nocc then level_shift else 0.)
|> Vec.of_array
|> Mat.of_diag
in
(* Guess coefficients *)
let guess =
Guess.make ~nocc ~guess ao_basis
in
let m_C =
let c_of_h m_H =
let m_Hmo = xt_o_x m_H m_X in
let m_C', _ = diagonalize_symm m_Hmo in
gemm m_X m_C'
in
match guess with
| Guess.Hcore m_H -> c_of_h m_H
| Guess.Huckel m_H -> c_of_h m_H
| Guess.Matrix m_C -> m_C
in
(* A single SCF iteration *)
let scf_iteration_rhf data =
let nSCF = data.iteration + 1
and m_C = of_some data.coefficients
and m_P_prev = data.density
and fock_prev = data.fock
and diis =
match data.diis with
| Some diis -> diis
| None -> DIIS.make ()
and threshold =
match data.error with
| Some error -> error
| None -> threshold_SCF *. 2.
in
(* Density matrix over nocc occupied MOs *)
let m_P =
gemm ~alpha:2. ~transb:`T ~k:nocc m_C m_C
in
(* Fock matrix in AO basis *)
let fock =
match fock_prev, m_P_prev, threshold > 100. *. threshold_SCF with
| Some fock_prev, Some m_P_prev, true ->
let threshold = 1.e-8 in
Fock.make_rhf ~density:(Mat.sub m_P m_P_prev) ~threshold ao_basis
|> Fock.add fock_prev
| _ -> Fock.make_rhf ~density:m_P ao_basis
in
let m_F0, m_Hc, m_J, m_K =
let x = fock in
Fock.(fock x, core x, coulomb x, exchange x)
in
(* Add level shift in AO basis *)
let m_F =
let m_SC =
gemm m_S m_C
in
gemm m_SC (gemm m_LSmo m_SC ~transb:`T)
|> Mat.add m_F0
in
(* Fock matrix in orthogonal basis *)
let m_F_ortho =
xt_o_x m_F m_X
in
let error_fock =
let fps =
gemm m_F (gemm m_P m_S)
and spf =
gemm m_S (gemm m_P m_F)
in
xt_o_x (Mat.sub fps spf) m_X
in
let diis, m_F_diis =
let diis =
DIIS.append ~p:(Mat.as_vec m_F_ortho) ~e:(Mat.as_vec error_fock) diis
in
try
let m_F_diis =
let x =
Bigarray.genarray_of_array1 (DIIS.next diis)
in
Bigarray.reshape_2 x (Mat.dim1 m_F_ortho) (Mat.dim2 m_F_ortho)
in
diis, m_F_diis
with Failure _ -> (* Failure in DIIS.next *)
DIIS.make (), m_F_ortho
in
let diis =
DIIS.append ~p:(Mat.as_vec m_F_ortho) ~e:(Mat.as_vec error_fock) diis
in
(* MOs in orthogonal MO basis *)
let m_C', _ =
diagonalize_symm m_F_diis
in
(* Re-compute eigenvalues to remove level-shift *)
let eigenvalues =
let m_F_ortho =
xt_o_x m_F0 m_X
in
xt_o_x m_F_ortho m_C'
|> Mat.copy_diag
in
(* MOs in AO basis *)
let m_C =
gemm m_X m_C'
|> Conventions.rephase
in
(* Hartree-Fock energy *)
let energy =
nuclear_repulsion +. 0.5 *.
Mat.gemm_trace m_P (Mat.add m_Hc m_F)
in
(* Convergence criterion *)
let error =
error_fock
|> Mat.as_vec
|> amax
|> abs_float
in
{ empty with
iteration = nSCF ;
eigenvalues = Some eigenvalues ;
coefficients = Some m_C ;
error = Some error ;
diis = Some diis ;
energy = Some energy ;
density = Some m_P ;
fock = Some fock ;
}
in
let scf_iteration_rohf data =
let nSCF = data.iteration + 1
and m_C = of_some data.coefficients
and m_P_a_prev = data.density_a
and m_P_b_prev = data.density_b
and fock_a_prev = data.fock_a
and fock_b_prev = data.fock_b
and diis =
match data.diis with
| Some diis -> diis
| None -> DIIS.make ()
and threshold =
match data.error with
| Some error -> error
| None -> threshold_SCF *. 2.
in
(* Density matrix *)
let m_P_a =
gemm ~alpha:1. ~transb:`T ~k:n_alfa m_C m_C
in
let m_P_b =
gemm ~alpha:1. ~transb:`T ~k:n_beta m_C m_C
in
let m_P =
Mat.add m_P_a m_P_b
in
(* Fock matrix in AO basis *)
let fock_a =
match fock_a_prev, threshold > 100. *. threshold_SCF with
| Some fock_a_prev, true ->
let threshold = 1.e-8 in
Fock.make_uhf ~density_same:(Mat.sub m_P_a @@ of_some m_P_a_prev) ~density_other:(Mat.sub m_P_b @@ of_some m_P_b_prev) ~threshold ao_basis
|> Fock.add fock_a_prev
| _ -> Fock.make_uhf ~density_same:m_P_a ~density_other:m_P_b ao_basis
in
let fock_b =
match fock_b_prev, threshold > 100. *. threshold_SCF with
| Some fock_b_prev, true ->
let threshold = 1.e-8 in
Fock.make_uhf ~density_same:(Mat.sub m_P_b @@ of_some m_P_b_prev) ~density_other:(Mat.sub m_P_a @@ of_some m_P_a_prev) ~threshold ao_basis
|> Fock.add fock_b_prev
| _ -> Fock.make_uhf ~density_same:m_P_b ~density_other:m_P_a ao_basis
in
let m_F_a, m_Hc_a, m_J_a, m_K_a =
let x = fock_a in
Fock.(fock x, core x, coulomb x, exchange x)
in
let m_F_b, m_Hc_b, m_J_b, m_K_b =
let x = fock_b in
Fock.(fock x, core x, coulomb x, exchange x)
in
let m_F_mo_a =
xt_o_x ~o:m_F_a ~x:m_C
in
let m_F_mo_b =
xt_o_x ~o:m_F_b ~x:m_C
in
let m_F_mo =
let space k =
if k <= n_beta then
`Core
else if k <= n_alfa then
`Active
else
`Virtual
in
Array.init (Mat.dim2 m_F_mo_a) (fun i ->
let i = i+1 in
Array.init (Mat.dim1 m_F_mo_a) (fun j ->
let j = j+1 in
match (space i), (space j) with
| `Core , `Core ->
0.5 *. (m_F_mo_a.{i,j} +. m_F_mo_b.{i,j}) -.
(m_F_mo_b.{i,j} -. m_F_mo_a.{i,j})
| `Active , `Core
| `Core , `Active ->
m_F_mo_b.{i,j}
| `Core , `Virtual
| `Virtual , `Core
| `Active , `Active ->
0.5 *. (m_F_mo_a.{i,j} +. m_F_mo_b.{i,j})
| `Virtual , `Active
| `Active , `Virtual ->
m_F_mo_a.{i,j}
| `Virtual , `Virtual ->
0.5 *. (m_F_mo_a.{i,j} +. m_F_mo_b.{i,j}) +.
(m_F_mo_b.{i,j} -. m_F_mo_a.{i,j})
) )
|> Mat.of_array
in
let m_SC =
gemm m_S m_C
in
let m_F0 =
x_o_xt ~x:m_SC ~o:m_F_mo
in
(* Add level shift in AO basis *)
let m_F =
x_o_xt ~x:m_SC ~o:m_LSmo
|> Mat.add m_F0
in
(* Fock matrix in orthogonal basis *)
let m_F_ortho =
xt_o_x m_F m_X
in
let error_fock =
let fps =
gemm m_F (gemm m_P m_S)
and spf =
gemm m_S (gemm m_P m_F)
in
xt_o_x (Mat.sub fps spf) m_X
in
let diis, m_F_diis =
let diis =
DIIS.append ~p:(Mat.as_vec m_F_ortho) ~e:(Mat.as_vec error_fock) diis
in
try
let m_F_diis =
let x =
Bigarray.genarray_of_array1 (DIIS.next diis)
in
Bigarray.reshape_2 x (Mat.dim1 m_F_ortho) (Mat.dim2 m_F_ortho)
in
diis, m_F_diis
with Failure _ -> (* Failure in DIIS.next *)
DIIS.make (), m_F_ortho
in
(* MOs in orthogonal MO basis *)
let m_C', eigenvalues =
diagonalize_symm m_F_diis
in
(* Re-compute eigenvalues to remove level-shift *)
let eigenvalues =
let m_F_ortho =
xt_o_x m_F0 m_X
in
xt_o_x m_F_ortho m_C'
|> Mat.copy_diag
in
(* MOs in AO basis *)
let m_C =
gemm m_X m_C'
|> Conventions.rephase
in
(* Hartree-Fock energy *)
let energy =
nuclear_repulsion +. 0.5 *. ( Mat.gemm_trace m_P_a (Mat.add m_Hc_a m_F_a) +.
Mat.gemm_trace m_P_b (Mat.add m_Hc_b m_F_b) )
in
(* Convergence criterion *)
let error =
error_fock
|> Mat.as_vec
|> amax
|> abs_float
in
{ empty with
iteration = nSCF ;
eigenvalues = Some eigenvalues ;
coefficients = Some m_C ;
error = Some error ;
diis = Some diis ;
energy = Some energy ;
density_a = Some m_P_a ;
density_b = Some m_P_b ;
fock_a = Some fock_a ;
fock_b = Some fock_b ;
}
in
let scf_iteration data =
match kind with
| RHF -> scf_iteration_rhf data
| ROHF -> scf_iteration_rohf data
| _ -> failwith "Not implemented"
in
let array_data =
let storage =
Array.make max_scf None
in
let rec iteration = function
| 0 -> Some (scf_iteration { empty with coefficients = Some m_C })
| n -> begin
match storage.(n) with
| Some result -> Some result
| None ->
begin
let data = iteration (n-1) in
match data with
| None -> None
| Some data ->
begin
(** Check convergence *)
let converged, error =
match data.error with
| None -> false, 0.
| Some error -> (data.iteration = max_scf || error < threshold_SCF), error
in
if converged then
None
else
begin
storage.(n-1) <- Some { empty with
iteration = data.iteration;
energy = data.energy ;
eigenvalues = data.eigenvalues ;
error = data.error ;
};
storage.(n) <- Some (scf_iteration data);
storage.(n);
end
end
end
end
in
Array.init max_scf (fun i -> lazy (iteration i))
in
{
kind;
simulation;
guess ;
data = array_data;
nocc;
}
let linewidth = 60
let pp_iterations ppf t =
Format.fprintf ppf "@[%4s%s@]@." "" (Printing.line linewidth);
Format.fprintf ppf "@[%4s@[%5s@]@,@[%16s@]@,@[%16s@]@,@[%11s@]@]@."
"" "#" "HF energy " "Convergence" "HOMO-LUMO";
Format.fprintf ppf "@[%4s%s@]@." "" (Printing.line linewidth);
let nocc = nocc t in
Array.iter (fun data ->
let data = Lazy.force data in
match data with
| None -> ()
| Some data ->
let e = of_some data.eigenvalues in
let gap = e.{nocc+1} -. e.{nocc} in
begin
Format.fprintf ppf "@[%4s@[%5d@]@,@[%16.8f@]@,@[%16.4e@]@,@[%11.4f@]@]@." ""
(data.iteration) (of_some data.energy) (of_some data.error) gap;
end
) t.data;
Format.fprintf ppf "@[%4s%s@]@." "" (Printing.line linewidth)
let pp_summary ppf t =
let print text value =
Format.fprintf ppf "@[@[%30s@]@,@[%16.10f@]@]@;" text value;
and line () =
Format.fprintf ppf "@[ %s @]@;" (Printing.line (linewidth-4));
in
let ha_to_ev = Constants.ha_to_ev in
let e = eigenvalues t in
Format.fprintf ppf "@[%s@]@;" (Printing.line ~c:'=' linewidth)
; Format.fprintf ppf "@[<v>"
; print "One-electron energy" (kin_energy t +. eN_energy t)
; print "Kinetic" (kin_energy t)
; print "Potential" (eN_energy t)
; line ()
; print "Two-electron energy" (coulomb_energy t +. exchange_energy t)
; print "Coulomb" (coulomb_energy t)
; print "Exchange" (exchange_energy t)
; line ()
; print "HF HOMO" (ha_to_ev *. e.{nocc t})
; print "HF LUMO" (ha_to_ev *. e.{nocc t + 1})
; print "HF LUMO-LUMO" (ha_to_ev *. (e.{nocc t + 1} -. e.{nocc t }))
; line ()
; print "Electronic energy" (energy t -. nuclear_repulsion t)
; print "Nuclear repulsion" (nuclear_repulsion t)
; print "Hartree-Fock energy" (energy t)
; Format.fprintf ppf "@]"
; Format.fprintf ppf "@[%s@]@;" (Printing.line ~c:'=' linewidth)
; Util.debug_matrix "MOs" (eigenvectors t)
let pp ppf t =
Format.fprintf ppf "@.@[%s@]@." (Printing.line ~c:'=' 70);
Format.fprintf ppf "@[%34s %-34s@]@." (match t.kind with
| UHF -> "Unrestricted"
| RHF -> "Restricted"
| ROHF -> "Restricted Open-shell") "Hartree-Fock";
Format.fprintf ppf "@[%s@]@.@." (Printing.line ~c:'=' 70);
Format.fprintf ppf "@[%a@]@." pp_iterations t;
Format.fprintf ppf "@[<v 4>@;%a@]@." pp_summary t

Some files were not shown because too many files have changed in this diff Show More