From ffcccba18820405828408cf772bfaccd106f8e89 Mon Sep 17 00:00:00 2001 From: Anthony Scemama Date: Thu, 26 Mar 2020 17:43:11 +0100 Subject: [PATCH] map optimizations --- Basis/AOBasis.ml | 36 +++++++++++++++++---------- Basis/AtomicShellPair.ml | 3 +-- Basis/AtomicShellPairCouple.ml | 3 +-- Basis/ContractedShellPairCouple.ml | 3 +-- Basis/TwoElectronIntegrals.ml | 8 +++--- CI/CI.ml | 39 ++++++++++++++++-------------- CI/DeterminantSpace.ml | 6 +++-- CI/Excitation.ml | 6 ++--- CI/Spindeterminant.ml | 3 ++- CI/SpindeterminantSpace.ml | 4 +-- MOBasis/HF12.ml | 10 +++++--- MOBasis/MOClass.ml | 18 +++++--------- Utils/AngularMomentum.ml | 21 ++++++++-------- Utils/Davidson.ml | 2 +- Utils/Matrix.ml | 21 ++++++++++------ Utils/Util.ml | 3 ++- Utils/Vector.ml | 4 +-- 17 files changed, 103 insertions(+), 87 deletions(-) diff --git a/Basis/AOBasis.ml b/Basis/AOBasis.ml index 32cce78..7f128a4 100644 --- a/Basis/AOBasis.ml +++ b/Basis/AOBasis.ml @@ -72,24 +72,34 @@ let test_case name t = let check_matrix title a r = let a = Mat.to_array a in - 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 - ) (Mat.to_array r) + 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 title 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.map f - and r = ERI.to_list r |> List.map f - 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 + Printf.eprintf "test \n%!"; Alcotest.(check (list (pair int (pair int (pair int (pair int (float 1.e-12))))))) "ERI" a r in + let check_eri_lr title 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-12))))))) "ERI_lr" a r + in + let test_overlap () = let reference = sym_matrix_of_file ("test_files/"^name^"_overlap.ref") @@ -133,13 +143,13 @@ let test_case name t = let test_ee_lr_ints () = let reference = - ERI.of_file ("test_files/"^name^"_eri_lr.ref") ~sparsity:`Dense + ERI_lr.of_file ("test_files/"^name^"_eri_lr.ref") ~sparsity:`Dense ~size:(Basis.size t.basis) in - let ee_ints = - Lazy.force t.ee_ints + let ee_lr_ints = + Lazy.force t.ee_lr_ints in - check_eri "ee_lr_ints" ee_ints reference + check_eri_lr "ee_lr_ints" ee_lr_ints reference in [ diff --git a/Basis/AtomicShellPair.ml b/Basis/AtomicShellPair.ml index db7b242..40a67ef 100644 --- a/Basis/AtomicShellPair.ml +++ b/Basis/AtomicShellPair.ml @@ -26,7 +26,7 @@ let make ?(cutoff=Constants.epsilon) atomic_shell_a atomic_shell_b = in let contracted_shell_pairs = - List.map (fun s_a -> + List.concat_map (fun s_a -> List.map (fun s_b -> if Cs.index s_b <= Cs.index s_a then Csp.make ~cutoff s_a s_b @@ -34,7 +34,6 @@ let make ?(cutoff=Constants.epsilon) atomic_shell_a atomic_shell_b = None ) l_b ) l_a - |> List.concat |> list_some in match contracted_shell_pairs with diff --git a/Basis/AtomicShellPairCouple.ml b/Basis/AtomicShellPairCouple.ml index c993a1a..8636401 100644 --- a/Basis/AtomicShellPairCouple.ml +++ b/Basis/AtomicShellPairCouple.ml @@ -28,12 +28,11 @@ let make ?(cutoff=Constants.epsilon) atomic_shell_pair_p atomic_shell_pair_q = and atomic_shell_d = Asp.atomic_shell_b atomic_shell_pair_q in let contracted_shell_pair_couples = - List.map (fun ap_ab -> + List.concat_map (fun ap_ab -> List.map (fun ap_cd -> ContractedShellPairCouple.make ~cutoff ap_ab ap_cd ) (Asp.contracted_shell_pairs atomic_shell_pair_q) ) (Asp.contracted_shell_pairs atomic_shell_pair_p) - |> List.concat |> list_some in match contracted_shell_pair_couples with diff --git a/Basis/ContractedShellPairCouple.ml b/Basis/ContractedShellPairCouple.ml index f371e5b..88f3891 100644 --- a/Basis/ContractedShellPairCouple.ml +++ b/Basis/ContractedShellPairCouple.ml @@ -29,14 +29,13 @@ let make ?(cutoff=Constants.epsilon) shell_pair_p shell_pair_q = in let cutoff = 1.e-3 *. cutoff in let coefs_and_shell_pair_couples = - List.map (fun (c_ab, sp_ab) -> + List.concat_map (fun (c_ab, sp_ab) -> List.map (fun (c_cd, sp_cd) -> let coef_prod = c_ab *. c_cd in if abs_float coef_prod < cutoff then None else Some (coef_prod, Pspc.make sp_ab sp_cd) ) (Csp.coefs_and_shell_pairs shell_pair_q) ) (Csp.coefs_and_shell_pairs shell_pair_p) - |> List.concat |> list_some in match coefs_and_shell_pair_couples with diff --git a/Basis/TwoElectronIntegrals.ml b/Basis/TwoElectronIntegrals.ml index 4fe99b1..236bff0 100644 --- a/Basis/TwoElectronIntegrals.ml +++ b/Basis/TwoElectronIntegrals.ml @@ -24,7 +24,7 @@ module Make(T : TwoEI_structure) = struct let class_of_contracted_shell_pair_couple = T.class_of_contracted_shell_pair_couple let filter_contracted_shell_pairs ?(cutoff=integrals_cutoff) shell_pairs = - List.map (fun pair -> + List.rev_map (fun pair -> match Cspc.make ~cutoff pair pair with | Some cspc -> let cls = class_of_contracted_shell_pair_couple cspc in @@ -33,20 +33,20 @@ module Make(T : TwoEI_structure) = struct | None -> (pair, -1.) ) shell_pairs |> List.filter (fun (_, schwartz_p_max) -> schwartz_p_max >= cutoff) - |> List.map fst + |> List.rev_map fst (* TODO let filter_contracted_shell_pair_couples ?(cutoff=integrals_cutoff) shell_pair_couples = - List.map (fun pair -> + 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.map fst + |> List.rev_map fst *) diff --git a/CI/CI.ml b/CI/CI.ml index 5ac3280..b983172 100644 --- a/CI/CI.ml +++ b/CI/CI.ml @@ -97,10 +97,12 @@ let create_matrix_arbitrary f det_space = in let singles = List.filter (fun (i,d,det_j) -> d < 2) doubles - |> List.map (fun (i,_,det_j) -> (i,det_j)) + |> List.rev_map (fun (i,_,det_j) -> (i,det_j)) + |> List.rev in let doubles = - List.map (fun (i,_,det_j) -> (i,det_j)) doubles + List.rev_map (fun (i,_,det_j) -> (i,det_j)) doubles + |> List.rev in (singles, doubles) ) det_beta @@ -262,10 +264,12 @@ let create_matrix_spin ?(nmax=2) f det_space = in let singles = List.filter (fun (i,d,det_j) -> d < 2) doubles - |> List.map (fun (i,_,det_j) -> (i,det_j)) + |> List.rev_map (fun (i,_,det_j) -> (i,det_j)) + |> List.rev in let doubles = - List.map (fun (i,_,det_j) -> (i,det_j)) doubles + List.rev_map (fun (i,_,det_j) -> (i,det_j)) doubles + |> List.rev in (singles, doubles, triples) ) b @@ -292,13 +296,16 @@ let create_matrix_spin ?(nmax=2) f det_space = in let triples = - List.map (fun (i,_,det_j) -> (i,det_j)) triples + List.rev_map (fun (i,_,det_j) -> (i,det_j)) triples + |> List.rev in let doubles = - List.map (fun (i,_,det_j) -> (i,det_j)) doubles + List.rev_map (fun (i,_,det_j) -> (i,det_j)) doubles + |> List.rev in let singles = - List.map (fun (i,_,det_j) -> (i,det_j)) singles + List.rev_map (fun (i,_,det_j) -> (i,det_j)) singles + |> List.rev in (singles, doubles, triples) ) b @@ -769,7 +776,8 @@ let second_order_sum { det_space ; m_H ; m_S2 ; eigensystem ; n_states } in let psi_filtered = - List.map (fun i -> psi0.(i)) psi_filtered_idx + List.rev_map (fun i -> psi0.(i)) psi_filtered_idx + |> List.rev in let psi_h_alfa alfa = @@ -896,39 +904,34 @@ let second_order_sum2 { det_space ; m_H ; m_S2 ; eigensystem ; n_states } Ds.determinants_array det_space |> Array.to_list - |> List.map (fun det_i -> + |> List.concat_map (fun det_i -> [ Spin.Alfa ; Spin.Beta ] - |> List.map (fun spin -> - List.map (fun particle -> + |> List.concat_map (fun spin -> + List.concat_map (fun particle -> List.map (fun hole -> [ [ Determinant.single_excitation spin hole particle det_i ] ; - List.map (fun particle' -> + List.concat_map (fun particle' -> List.map (fun hole' -> Determinant.double_excitation spin hole particle spin hole' particle' det_i ) list_holes ) list_particles - |> List.concat ; - List.map (fun particle' -> + List.concat_map (fun particle' -> List.map (fun hole' -> Determinant.double_excitation spin hole particle (Spin.other spin) hole' particle' det_i ) list_holes ) list_particles - |> List.concat ] |> List.concat ) list_holes ) list_particles - |> List.concat ) - |> List.concat ) |> List.concat - |> List.concat |> List.filter (fun alfa -> not (Determinant.is_none alfa)) |> List.sort_uniq compare in diff --git a/CI/DeterminantSpace.ml b/CI/DeterminantSpace.ml index e024921..10c1a6f 100644 --- a/CI/DeterminantSpace.ml +++ b/CI/DeterminantSpace.ml @@ -323,10 +323,11 @@ let fci_f12_of_mo_basis mo_basis ~frozen_core mo_num = in { r with mo_class = MOClass.to_list r.mo_class - |> List.map (fun i -> + |> 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 } @@ -339,10 +340,11 @@ let cas_f12_of_mo_basis mo_basis ~frozen_core n m mo_num = in { r with mo_class = MOClass.to_list r.mo_class - |> List.map (fun i -> + |> 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 } diff --git a/CI/Excitation.ml b/CI/Excitation.ml index 013e259..75bcc60 100644 --- a/CI/Excitation.ml +++ b/CI/Excitation.ml @@ -76,7 +76,7 @@ let multiple_of_spindet t t' = else Phase.Neg in - (phase, List.map2 (fun hole particle -> (hole, particle)) holes (List.rev particles) ) + (phase, List.rev @@ List.rev_map2 (fun hole particle -> (hole, particle)) holes (List.rev particles) ) let double_of_spindet t t' = @@ -99,8 +99,8 @@ let multiple_of_det t t' = in let phase = Phase.add pa pb in Multiple (phase, List.concat [ - List.map (fun (hole, particle) -> { hole ; particle ; spin=Spin.Alfa }) a ; - List.map (fun (hole, particle) -> { hole ; particle ; spin=Spin.Beta }) b ]) + 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' = diff --git a/CI/Spindeterminant.ml b/CI/Spindeterminant.ml index 1dcfc87..9391af6 100644 --- a/CI/Spindeterminant.ml +++ b/CI/Spindeterminant.ml @@ -93,7 +93,8 @@ let holes_particles_of t t' = let holes = Bitstring.logand (bitstring t) x |> Bitstring.to_list and particles = Bitstring.logand (bitstring t') x |> Bitstring.to_list in - List.map2 (fun h p -> (h,p)) holes particles + List.rev_map2 (fun h p -> (h,p)) holes particles + |> List.rev let set_phase p = function diff --git a/CI/SpindeterminantSpace.ml b/CI/SpindeterminantSpace.ml index 06d25fb..7fff6cb 100644 --- a/CI/SpindeterminantSpace.ml +++ b/CI/SpindeterminantSpace.ml @@ -30,8 +30,8 @@ let fci_of_mo_basis ~frozen_core mo_basis elec_num = let spin_determinants = Bitstring.permtutations elec_num mo_num |> List.filter (fun b -> Bitstring.logand neg_active_mask b = occ_mask) - |> List.map (fun b -> Spindeterminant.of_bitstring b) |> Array.of_list + |> Array.map (fun b -> Spindeterminant.of_bitstring b) in { elec_num ; mo_basis ; mo_class ; spin_determinants } @@ -54,8 +54,8 @@ let cas_of_mo_basis mo_basis ~frozen_core elec_num n m = let spin_determinants = Bitstring.permtutations elec_num mo_num |> List.filter (fun b -> Bitstring.logand neg_active_mask b = occ_mask) - |> List.map (fun b -> Spindeterminant.of_bitstring b) |> Array.of_list + |> Array.map (fun b -> Spindeterminant.of_bitstring b) in { elec_num ; mo_basis ; mo_class ; spin_determinants } diff --git a/MOBasis/HF12.ml b/MOBasis/HF12.ml index d0a0693..e675adf 100644 --- a/MOBasis/HF12.ml +++ b/MOBasis/HF12.ml @@ -67,10 +67,11 @@ let array_4_init d1 d2 d3 d4 fx = SharedMemory.create Bigarray.Float64 [| d1;d2;d3;d4 |] in Util.list_range 1 d4 - |> List.map (fun l -> + |> List.rev_map (fun l -> Util.list_range 1 d3 - |> List.map (fun k -> (k,l)) ) + |> List.rev_map (fun k -> (k,l)) ) |> List.concat + |> List.rev |> Stream.of_list |> Farm.run ~f ~ordered:false |> Stream.iter (fun (k,l,x) -> @@ -133,10 +134,11 @@ let array_5_init d1 d2 d3 d4 d5 fx = SharedMemory.create Bigarray.Float64 [| d1;d2;d3;d4;d5 |] in Util.list_range 1 d5 - |> List.map (fun m -> + |> List.rev_map (fun m -> Util.list_range 1 d4 - |> List.map (fun l -> (l,m)) ) + |> List.rev_map (fun l -> (l,m)) ) |> List.concat + |> List.rev |> Stream.of_list |> Farm.run ~f ~ordered:false |> Stream.iter (fun (l,m,x) -> diff --git a/MOBasis/MOClass.ml b/MOBasis/MOClass.ml index 22d90d1..ef15c83 100644 --- a/MOBasis/MOClass.ml +++ b/MOBasis/MOClass.ml @@ -34,51 +34,45 @@ let to_list t = t let core_mos t = - List.map (fun x -> + List.filter_map (fun x -> match x with | Core i -> Some i | _ -> None) t - |> Util.list_some let inactive_mos t = - List.map (fun x -> + List.filter_map (fun x -> match x with | Inactive i -> Some i | _ -> None ) t - |> Util.list_some let active_mos t = - List.map (fun x -> + List.filter_map (fun x -> match x with | Active i -> Some i | _ -> None ) t - |> Util.list_some let virtual_mos t = - List.map (fun x -> + List.filter_map (fun x -> match x with | Virtual i -> Some i | _ -> None ) t - |> Util.list_some let deleted_mos t = - List.map (fun x -> + List.filter_map (fun x -> match x with | Deleted i -> Some i | _ -> None ) t - |> Util.list_some let auxiliary_mos t = - List.map (fun x -> + List.filter_map (fun x -> match x with | Auxiliary i -> Some i | _ -> None ) t - |> Util.list_some let mo_class_array t = diff --git a/Utils/AngularMomentum.ml b/Utils/AngularMomentum.ml index 2c5e53d..9345de4 100644 --- a/Utils/AngularMomentum.ml +++ b/Utils/AngularMomentum.ml @@ -107,19 +107,19 @@ let zkey_array a = begin match a with | Singlet l1 -> - List.map (fun x -> Zkey.of_powers_three x) (keys_1d @@ to_int l1) + List.rev_map (fun x -> Zkey.of_powers_three x) (keys_1d @@ to_int l1) | Doublet (l1, l2) -> - List.map (fun a -> - List.map (fun b -> Zkey.of_powers_six a b) (keys_1d @@ to_int l2) + List.rev_map (fun a -> + List.rev_map (fun b -> Zkey.of_powers_six a b) (keys_1d @@ to_int l2) ) (keys_1d @@ to_int l1) |> List.concat | Triplet (l1, l2, l3) -> - List.map (fun a -> - List.map (fun b -> - List.map (fun c -> + List.rev_map (fun a -> + List.rev_map (fun b -> + List.rev_map (fun c -> Zkey.of_powers_nine a b c) (keys_1d @@ to_int l3) ) (keys_1d @@ to_int l2) |> List.concat @@ -128,10 +128,10 @@ let zkey_array a = | Quartet (l1, l2, l3, l4) -> - List.map (fun a -> - List.map (fun b -> - List.map (fun c -> - List.map (fun d -> + List.rev_map (fun a -> + List.rev_map (fun b -> + List.rev_map (fun c -> + List.rev_map (fun d -> Zkey.of_powers_twelve a b c d) (keys_1d @@ to_int l4) ) (keys_1d @@ to_int l3) |> List.concat @@ -140,6 +140,7 @@ let zkey_array a = ) (keys_1d @@ to_int l1) |> List.concat end + |> List.rev |> Array.of_list in Hashtbl.add zkey_array_memo a result; diff --git a/Utils/Davidson.ml b/Utils/Davidson.ml index 78c2caf..8d5c85a 100644 --- a/Utils/Davidson.ml +++ b/Utils/Davidson.ml @@ -117,7 +117,7 @@ let make in - let residual_norms = List.map nrm2 u_proposed in + let residual_norms = List.rev @@ List.rev_map nrm2 u_proposed in let residual_norm = List.fold_left (fun accu i -> accu +. i *. i) 0. residual_norms |> sqrt diff --git a/Utils/Matrix.ml b/Utils/Matrix.ml index 9a764cc..2d38e70 100644 --- a/Utils/Matrix.ml +++ b/Utils/Matrix.ml @@ -80,11 +80,12 @@ let sparse_of_computed ?(threshold=epsilon) = function | Computed {m ; n ; f} -> Sparse { m ; n ; v=Array.init n (fun j -> Util.list_range 1 m - |> List.map (fun i -> + |> List.rev_map (fun i -> let x = f i (j+1) in if abs_float x > threshold then Some (i, x) else None) |> Util.list_some + |> List.rev |> Vector.sparse_of_assoc_list m ) } | _ -> invalid_arg "Expected a computed matrix" @@ -176,7 +177,7 @@ let outer_product ?(threshold=epsilon) v1 v2 = in let v = Array.init (Vector.dim v2) (fun j -> - List.map (fun (i, x) -> + List.rev_map (fun (i, x) -> let z = x *. v'.{j+1} in if abs_float z < threshold then None @@ -184,6 +185,7 @@ let outer_product ?(threshold=epsilon) v1 v2 = Some (i, z) ) v |> Util.list_some + |> List.rev |> Vector.sparse_of_assoc_list (Vector.dim v1) ) in @@ -500,22 +502,23 @@ let split_cols nrows = function Mat.to_col_vecs a |> Array.to_list |> Util.list_pack nrows - |> List.map (fun l -> + |> List.rev_map (fun l -> Dense (Mat.of_col_vecs @@ Array.of_list l) ) + |> List.rev end | Sparse a -> begin Array.to_list a.v |> Util.list_pack nrows - |> List.map Array.of_list - |> List.map (fun v -> Sparse { m=a.m ; n= Array.length v ; v }) + |> List.rev_map Array.of_list + |> List.rev_map (fun v -> Sparse { m=a.m ; n= Array.length v ; v }) end | Computed a -> begin Util.list_range 0 (a.n-1) |> Util.list_pack nrows - |> List.map Array.of_list - |> List.map (fun v -> Computed { m=a.m ; n= Array.length v ; f = (fun i j -> a.f i (j+v.(0)) ) }) + |> List.rev_map Array.of_list + |> List.rev_map (fun v -> Computed { m=a.m ; n= Array.length v ; f = (fun i j -> a.f i (j+v.(0)) ) }) end @@ -534,7 +537,9 @@ let join_cols l = | [] -> Sparse { m=0 ; n=0 ; v=[| |] } | (Dense a) :: rest -> aux_dense [] ((Dense a) :: rest) | (Sparse a) :: rest -> aux_sparse 0 0 [] ((Sparse a) :: rest) - | (Computed a) :: rest -> aux_sparse 0 0 [] (List.map sparse_of_computed ( (Computed a) :: rest )) + | (Computed a) :: rest -> aux_sparse 0 0 [] + (List.rev_map sparse_of_computed ( (Computed a) :: rest ) + |> List.rev) in aux (List.rev l) diff --git a/Utils/Util.ml b/Utils/Util.ml index cf5faa3..cdc84fc 100644 --- a/Utils/Util.ml +++ b/Utils/Util.ml @@ -244,7 +244,8 @@ let of_some = function let list_some l = List.filter (function None -> false | _ -> true) l - |> List.map (function Some x -> x | _ -> assert false) + |> List.rev_map (function Some x -> x | _ -> assert false) + |> List.rev let list_range first last = diff --git a/Utils/Vector.ml b/Utils/Vector.ml index 756b1bd..b6334b9 100644 --- a/Utils/Vector.ml +++ b/Utils/Vector.ml @@ -91,8 +91,8 @@ let sparse_of_vec ?(threshold=epsilon) v = let sparse_of_assoc_list n v = Sparse { n ; - v = List.map (fun (index, value) -> {index ; value}) v - |> Array.of_list + v = Array.of_list v + |> Array.map (fun (index, value) -> {index ; value}) }