Index: trunk/omega/tests/keystones.ml =================================================================== --- trunk/omega/tests/keystones.ml (revision 8491) +++ trunk/omega/tests/keystones.ml (revision 8492) @@ -1,444 +1,530 @@ (* keystones.ml -- Copyright (C) 2019-2020 by Wolfgang Kilian Thorsten Ohl Juergen Reuter WHIZARD 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 2, or (at your option) any later version. WHIZARD 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, write to the Free Software Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. *) -open Coupling - -type field = lorentz * int +type field = Coupling.lorentz * int type argument = | G of int (* complex coupling *) + | N of int (* negative of complex coupling *) | M of int (* real mass (or width) *) | P of int (* momentum *) | F of field (* field *) | V of string (* verbatim *) type keystone = { bra : field; name : string; args : argument list } type vertex = { tag : string; keystones : keystone list } let order_fields (_, i) (_, j) = compare i j let extract_fields { bra; args } = List.sort order_fields (List.fold_left (fun acc arg -> match arg with | F f -> f :: acc | _ -> acc) [bra] args) let check_indices field_list = if List.exists (fun (n, _) -> n > 1) (ThoList.classify (List.map snd field_list)) then invalid_arg "check_indices"; () let spin_to_string = function - | Scalar -> "Scalar" - | Spinor -> "Spinor" - | ConjSpinor -> "ConjSpinor" - | Majorana -> "Majorana" - | Vector | Massive_Vector -> "Vector" - | Tensor_2 -> "Tensor_2" + | Coupling.Scalar -> "Scalar" + | Coupling.Spinor -> "Spinor" + | Coupling.ConjSpinor -> "ConjSpinor" + | Coupling.Majorana -> "Majorana" + | Coupling.Vector | Coupling.Massive_Vector -> "Vector" + | Coupling.Tensor_2 -> "Tensor_2" | _ -> failwith "spin_to_string" let fields_to_string fields = "[" ^ String.concat "; " (List.map (fun (s, i) -> Printf.sprintf "%s(%d)" (spin_to_string s) i) fields) ^ "]" let check_fields ks_list = let fields = List.map extract_fields ks_list in if not (ThoList.homogeneous fields) then begin let spins = "[" ^ String.concat "; " (List.map fields_to_string fields) ^ "]" in invalid_arg ("check_spins: " ^ spins) end; check_indices (List.hd fields) open Format_Fortran let spin_type = function - | Scalar -> "complex(kind=default)" - | Spinor -> "type(spinor)" - | ConjSpinor -> "type(conjspinor)" - | Majorana -> "type(bispinor)" - | Vector | Massive_Vector -> "type(vector)" - | Tensor_2 -> "type(tensor)" + | Coupling.Scalar -> "complex(kind=default)" + | Coupling.Spinor -> "type(spinor)" + | Coupling.ConjSpinor -> "type(conjspinor)" + | Coupling.Majorana -> "type(bispinor)" + | Coupling.Vector | Coupling.Massive_Vector -> "type(vector)" + | Coupling.Tensor_2 -> "type(tensor)" | _ -> failwith "spin_type" let type_arg = function | G _ -> Some "complex(kind=default)" + | N _ -> Some "complex(kind=default)" | M _ -> Some "real(kind=default)" | P _ -> Some "type(momentum)" | F (s, _) -> Some (spin_type s) | V _ -> None let spin_mnemonic = function - | Scalar -> "phi" - | Spinor -> "psi" - | ConjSpinor -> "psibar" - | Majorana -> "chi" - | Maj_Ghost -> "???" - | Vector -> "a" - | Massive_Vector -> "v" - | Tensor_2 -> "h" + | Coupling.Scalar -> "phi" + | Coupling.Spinor -> "psi" + | Coupling.ConjSpinor -> "psibar" + | Coupling.Majorana -> "chi" + | Coupling.Maj_Ghost -> "???" + | Coupling.Vector -> "a" + | Coupling.Massive_Vector -> "v" + | Coupling.Tensor_2 -> "h" | _ -> failwith "spin_mnemonic" let format_coupling i = Printf.sprintf "g%d" i +let format_negative_coupling i = + Printf.sprintf "(-g%d)" i + let format_momentum i = Printf.sprintf "p%d" i let format_mass i = Printf.sprintf "m%d" i let format_field (s, i) = Printf.sprintf "%s%d" (spin_mnemonic s) i +let format_declaration = function + | G i -> format_coupling i + | N i -> format_coupling i + | M i -> format_mass i + | P i -> format_momentum i + | F f -> format_field f + | V s -> s + let format_arg = function | G i -> format_coupling i + | N i -> format_negative_coupling i | M i -> format_mass i | P i -> format_momentum i | F f -> format_field f | V s -> s let fusion_to_fortran ff name args = let printf fmt = fprintf ff fmt in match args with | [] -> invalid_arg "fusion_to_fortran" | arg1 :: arg2n -> printf "%s (%s" name (format_arg arg1); List.iter (fun arg -> printf ",@ %s" (format_arg arg)) arg2n; printf ")" (* \begin{dubious} The ordering here works for Dirac spinors, but fails for Majorana spinors, leading to a sign ambiguity in this test \ldots \end{dubious} *) let keystone_to_fortran ff (ksv, { bra; name; args }) = let printf fmt = fprintf ff fmt and nl = pp_newline ff in printf " @[<2>%s =@ " ksv; begin match bra with - | Spinor, _ -> + | Coupling.Spinor, _ -> fusion_to_fortran ff name args; printf "@ * %s" (format_field bra) - | Majorana, _ -> + | Coupling.Majorana, _ -> begin match args with - | _ :: F (Majorana, _) :: _ -> + | _ :: F (Coupling.Majorana, _) :: _ -> fusion_to_fortran ff name args; printf "@ * %s" (format_field bra) | _ -> printf "%s@ * " (format_field bra); fusion_to_fortran ff name args end | _, _ -> printf "%s@ * " (format_field bra); fusion_to_fortran ff name args end; printf "@]"; nl() let keystones_to_subroutine ff { tag; keystones } = check_fields keystones; let printf fmt = fprintf ff fmt and nl = pp_newline ff in printf " @[<4>subroutine@ testks_%s@ (repetitions," tag; printf "@ passed,@ threshold,@ quiet,@ abs_threshold)@]"; nl (); printf " integer, intent(in) :: repetitions"; nl (); printf " logical, intent(inout) :: passed"; nl (); printf " logical, intent(in), optional :: quiet"; nl (); printf " @[<2>real(kind=default),@ intent(in),@ optional ::"; printf "@ threshold,@ abs_threshold@]"; nl (); printf " integer :: i"; nl (); let ks1 = List.hd keystones in let all_momenta = List.map (fun i -> P i) (ThoList.range 0 (List.length (extract_fields ks1) - 1)) in let variables = ThoList.uniq (List.sort compare (F (ks1.bra) :: ks1.args @ all_momenta)) in List.iter (fun a -> match type_arg a with | None -> () - | Some t -> printf " @[<2>%s :: %s@]" t (format_arg a); nl ()) + | Some t -> printf " @[<2>%s :: %s@]" t (format_declaration a); nl ()) variables; let ks_list = List.map (fun (n, ks) -> (Printf.sprintf "ks%d" n, ks)) (ThoList.enumerate 0 keystones) in begin match ks_list with | [] -> failwith "keystones_to_fortran" | (ksv1, _) :: ks2n -> printf " @[<2>complex(kind=default) ::@ %s" ksv1; List.iter (fun (ksv, _) -> printf ",@ %s" ksv) ks2n; printf "@]"; nl () end; printf " do i = 1, repetitions"; nl (); List.iter (fun a -> match a with | P 0 -> () (* this will be determined by momentum conservation! *) | V _ -> () | a -> printf " @[<2>call@ make_random@ (%s)@]" (format_arg a); nl ()) variables; begin match all_momenta with | [] -> failwith "keystones_to_fortran" | p1 :: p2n -> printf " @[<2>%s =" (format_arg p1); List.iter (fun p -> printf "@ - %s" (format_arg p)) p2n; printf "@]"; nl () end; List.iter (keystone_to_fortran ff) ks_list; begin match ks_list with | [] -> failwith "keystones_to_fortran" | (ksv1, ks1) :: ks2n -> List.iter (fun (ksv, ks) -> printf " @[<8>call@ expect@ (%s,@ %s," ksv ksv1; printf "@ '%s: %s <> %s'," tag ks.name ks1.name; printf "@ passed,@ threshold, quiet, abs_threshold)@]"; nl ()) ks2n end; printf " end do"; nl (); printf " @[<2>end@ subroutine@ testks_%s@]" tag; nl () let keystones_to_fortran ff ?(reps=1000) ?(threshold=0.85) - ?(omega_module="omega95") + ?(program="keystones_test") ?(omega_module="omega95") ?(modules=[]) vertices = let printf fmt = fprintf ff fmt and nl = pp_newline ff in - printf "program keystones_omegalib_demo"; nl (); + printf "program %s" program; nl (); List.iter (fun m -> printf " use %s" m; nl ()) ("kinds" :: "constants" :: omega_module :: "omega_testtools" :: "keystones_tools" :: modules); printf " implicit none"; nl (); printf " logical :: passed"; nl (); printf " logical, parameter :: quiet = .false."; nl (); printf " integer, parameter :: reps = %d" reps; nl (); printf " real(kind=default), parameter :: threshold = %f" threshold; nl (); printf " real(kind=default), parameter :: abs_threshold = 1E-17"; nl (); printf " integer, dimension(8) :: date_time"; nl (); printf " integer :: rsize"; nl (); printf " call date_and_time (values = date_time)"; nl (); printf " call random_seed (size = rsize)"; nl (); printf " @[<8>call random_seed@ (put = spread (product (date_time),"; printf "@ dim = 1,@ ncopies = rsize))@]"; nl (); printf " passed = .true."; nl (); List.iter (fun v -> printf " @[<8>call testks_%s@ (reps,@ passed," v.tag; printf "@ threshold, quiet, abs_threshold)@]"; nl ()) vertices; printf " if (passed) then"; nl (); printf " stop 0"; nl (); printf " else"; nl (); printf " stop 1"; nl (); printf " end if"; nl (); printf "contains"; nl (); List.iter (keystones_to_subroutine ff) vertices; - printf "end program keystones_omegalib_demo"; nl () + printf "end program %s" program; nl () -let generate ?reps ?threshold ?omega_module ?modules vertices = +let generate ?reps ?threshold ?program ?omega_module ?modules vertices = let my_name = Sys.argv.(0) in let verbose = ref false and cat = ref false and usage = "usage: " ^ my_name ^ " ..." in Arg.parse (Arg.align [ ("-cat", Arg.Set cat, " print test snippets"); ("-v", Arg.Set verbose, " be more verbose"); ("-verbose", Arg.Set verbose, " be more verbose") ]) (fun s -> raise (Arg.Bad s)) usage; if !cat then keystones_to_fortran - std_formatter ?reps ?threshold ?omega_module ?modules vertices + std_formatter ?reps ?threshold ?program ?omega_module ?modules vertices type ufo_vertex = { v_tag : string; - v_spins : lorentz array; - v_tensor : UFOx.Lorentz.t } + v_spins : Coupling.lorentz array; + v_tensor : UFO_Lorentz.t; + v_flines : Coupling.fermion_lines } type ufo_propagator = { p_tag : string; p_omega : string; - p_spins : lorentz * lorentz; + p_spins : Coupling.lorentz * Coupling.lorentz; p_propagator : UFO.Propagator.t } let transpose p = { p_tag = p.p_tag; p_omega = p.p_omega; p_spins = (snd p.p_spins, fst p.p_spins); p_propagator = UFO.Propagator.transpose p.p_propagator } -let equivalent_tensors v_spins alternatives = +let equivalent_tensors ?(fermion_lines=[]) v_spins alternatives = List.map (fun (v_tag, tensor) -> - { v_tag; v_spins; v_tensor = UFOx.Lorentz.of_string tensor }) + let v_tensor = + UFO_Lorentz.parse + (Array.to_list v_spins) + (UFOx.Lorentz.of_string tensor) in + { v_tag; v_spins; v_tensor; v_flines = fermion_lines }) alternatives module P = Permutation.Default let permute_spins p s = P.array p s (* We must permute only the free indices, of course. Note that we apply the \emph{inverse} permutation to the indices in order to match the permutation of the particles/spins. *) -let permute_structure n p l = + +(* The following is copied from [UFO.Lorentz.permute]. + We can't simply call it, because the types [UFO.Lorentz.t] + and [vertex] differ. + This should be changed to make sure that we're also + testing [UFO.Lorentz.permute], but note + that only the ["_p" ^ permutation] naming convention + and the simultaneous exchange of indices in Lorentz structures + and fermion lines is relevant for applications! *) +let permute_structure n p (l, f) = let permuted = P.array (P.inverse p) (Array.init n succ) in let permute_index i = if i > 0 then - permuted.(pred i) + UFOx.Index.map_position (fun pos -> permuted.(pred pos)) i else i in - UFOx.Lorentz.map_indices permute_index l + (UFO_Lorentz.map_indices permute_index l, + UFO_Lorentz.map_fermion_lines permute_index f) let permute_vertex n v p = - { v_tag = v.v_tag ^ "_p" ^ P.to_string p; + let v_tensor, v_flines = permute_structure n p (v.v_tensor, v.v_flines) in + { v_tag = v.v_tag ^ "_p" ^ P.to_string (P.inverse p); v_spins = permute_spins p v.v_spins; - v_tensor = permute_structure n p v.v_tensor } + v_tensor; + v_flines } let vertex_permutations v = let n = Array.length v.v_spins in List.map (permute_vertex n v) (P.cyclic n) +(* The following is mostly copied from + [UFO.Lorentz.all_charge_conjugates]. + We can't simply call it, because the types [UFO.Lorentz.t] + and [vertex] differ. + This should be changed to make sure that we're also + testing [UFO.Lorentz.all_charge_conjugates], but note + that only [UFO_Lorentz.charge_conjugate] and the ["_c%x%x"] + naming convention is relevant for applications! + Note also that we're \emph{only} charge conjugating + fermion lines involving Majoranas. *) +let charge_conjugate1 v (bra, ket as fermion_line) = + { v_tag = v.v_tag ^ Printf.sprintf "_c%x%x" bra ket; + v_spins = v.v_spins; + v_tensor = UFO_Lorentz.charge_conjugate fermion_line v.v_tensor; + v_flines = v.v_flines } + +let charge_conjugate l fermion_lines = + List.fold_left charge_conjugate1 l fermion_lines + +let is_majorana = function + | Coupling.Majorana | Coupling.Vectorspinor | Coupling.Maj_Ghost -> true + | _ -> false + +let is_majorana_fline v_spins (bra, ket) = + is_majorana v_spins.(pred bra) || is_majorana v_spins.(pred ket) + +(*i +let all_charge_conjugates l = + List.map + (charge_conjugate l) + (ThoList.power (List.filter (is_majorana_fline l.v_spins) l.v_flines)) +i*) + +let required_charge_conjugates l = + let saturated_fermion_lines = + List.filter (fun (bra, ket) -> bra != 1 && ket != 1) l.v_flines in + List.map + (charge_conjugate l) + (ThoList.power + (List.filter (is_majorana_fline l.v_spins) saturated_fermion_lines)) + let keystones_of_ufo_vertex { v_tag; v_spins } = { tag = v_tag; keystones = let fields = Array.mapi (fun i s -> (s, i)) v_spins in let n = Array.length fields in List.map (fun p -> let permuted = P.array p fields in match Array.to_list permuted with | [] -> invalid_arg "keystones_of_ufo_vertex" | bra :: args -> { bra; - name = v_tag ^ "_p" ^ P.to_string p; + name = v_tag ^ "_p" ^ P.to_string (P.inverse p); args = G (0) :: (ThoList.flatmap (fun (s, i) -> [ F (s, i); P (i) ]) args) }) (P.cyclic n) } let keystones_of_propagator { p_tag; p_omega; p_spins } = let s0, s1 = p_spins in let keystone omega name = match omega, s1, name with - | _, (Scalar|Tensor_2), _ + | _, (Coupling.Scalar|Coupling.Tensor_2), _ | false, _, _ -> { bra = (s0, 0); name; args = [P (1); M (0); M (1); F (s1, 1) ] } - | _, Vector, "pr_gauge" -> + | _, Coupling.Vector, "pr_gauge" -> { bra = (s0, 0); name; args = [P (1); V ("42.0_default"); F (s1, 1) ] } - | _, Vector, "pr_rxi" -> + | _, Coupling.Vector, "pr_rxi" -> { bra = (s0, 0); name; args = [P (1); M (0); M (1); V ("42.0_default"); F (s1, 1) ] } - | _, Vector, _ -> + | _, Coupling.Vector, _ -> { bra = (s0, 0); name; args = [P (1); F (s1, 1) ] } | true, _, _ -> { bra = (s0, 0); name; args = [P (1); M (0); M (1); V (".false."); F (s1, 1) ] } in { tag = p_tag; keystones = [keystone false ("pr_U_" ^ p_tag); keystone true p_omega] } let merge (ufo_list, omegalib) = match ufo_list with | [] -> omegalib | ufo1 :: _ -> { tag = ufo1.v_tag; keystones = (omegalib.keystones @ ThoList.flatmap (fun ufo -> (keystones_of_ufo_vertex ufo).keystones) ufo_list) } let fusions ff ?(omega_module="omega95") module_name vertices propagators = let printf fmt = fprintf ff fmt and nl () = pp_newline ff () in printf "module %s" module_name; nl (); printf " use kinds"; nl (); printf " use %s" omega_module; nl (); printf " implicit none"; nl (); printf " private"; nl (); - let permuted_vertices = ThoList.flatmap vertex_permutations vertices in + let permuted_vertices = + ThoList.flatmap + required_charge_conjugates + (ThoList.flatmap vertex_permutations vertices) in List.iter (fun v -> printf " public :: %s" v.v_tag; nl ()) permuted_vertices; List.iter (fun p -> printf " public :: pr_U_%s" p.p_tag; nl ()) propagators; UFO_targets.Fortran.eps4_g4_g44_decl std_formatter (); UFO_targets.Fortran.eps4_g4_g44_init std_formatter (); printf "contains"; nl (); UFO_targets.Fortran.inner_product_functions std_formatter (); List.iter (fun v -> - let tensor = UFO_Lorentz.parse (Array.to_list v.v_spins) v.v_tensor in printf " ! %s" (String.make 68 '='); nl (); - printf " ! %s" (UFO_Lorentz.to_string tensor); nl (); - UFO_targets.Fortran.lorentz std_formatter v.v_tag v.v_spins tensor) + printf " ! %s" (UFO_Lorentz.to_string v.v_tensor); nl (); + UFO_targets.Fortran.lorentz std_formatter v.v_tag v.v_spins v.v_tensor) permuted_vertices; List.iter (fun p -> UFO_targets.Fortran.propagator std_formatter p.p_tag "parameters" p.p_propagator.UFO.Propagator.variables p.p_spins p.p_propagator.UFO.Propagator.numerator p.p_propagator.UFO.Propagator.denominator) propagators; printf "end module %s" module_name; nl () -let generate_ufo ?omega_module ?reps ?threshold module_name vertices propagators = +let generate_ufo ?program ?omega_module ?reps ?threshold + ?(only_fusions=[]) module_name vertices propagators = + fusions + ?omega_module std_formatter module_name + (only_fusions @ ThoList.flatmap fst vertices) propagators; + generate + ?reps ?threshold ?program ?omega_module ~modules:[module_name] + (List.map merge vertices @ List.map keystones_of_propagator propagators) + +(* \begin{dubious} + placeholder: + \end{dubious} *) + +let generate_ufo_bispinors ?program ?omega_module ?reps ?threshold + ?(only_fusions=[]) module_name vertices propagators = fusions ?omega_module std_formatter module_name - (ThoList.flatmap fst vertices) propagators; + (only_fusions @ ThoList.flatmap fst vertices) propagators; generate - ?reps ?threshold ?omega_module ~modules:[module_name] + ?reps ?threshold ?program ?omega_module ~modules:[module_name] (List.map merge vertices @ List.map keystones_of_propagator propagators) Index: trunk/omega/tests/benchmark_UFO_SMEFT.f90 =================================================================== --- trunk/omega/tests/benchmark_UFO_SMEFT.f90 (revision 8491) +++ trunk/omega/tests/benchmark_UFO_SMEFT.f90 (revision 8492) @@ -1,138 +1,141 @@ ! benchmark.f90 -- ! benchmark.f90 -- race O'Mega matrix elements !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! ! ! Copyright (C) 1999-2020 by ! Wolfgang Kilian ! Thorsten Ohl ! Juergen Reuter ! Christian Speckner ! ! WHIZARD 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 2, or (at your option) ! any later version. ! ! WHIZARD 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, write to the Free Software ! Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! program benchmark use kinds use constants use amplitude_benchmark_UFO_SMEFT, only: new_event, & number_particles_in, number_particles_out use amplitude_benchmark_UFO_SMEFT_opt, only: new_event_opt => new_event - use parameters_UFO_SMEFT + use parameters_UFO_SMEFT, only: & + setup_parameters_UFO_SMEFT => setup_parameters + implicit none - integer, parameter :: NCALLS = 2000 + integer, parameter :: NCALLS = 100 real(kind=double), parameter :: ROOTS = 1000 real(kind=default), dimension(:,:), allocatable :: p real(kind=double) :: wtime_start, wtime integer, dimension(:), allocatable :: seed integer :: i, seed_size call random_seed (seed_size) allocate (seed(seed_size)) seed = 42 call random_seed (put = seed) deallocate (seed) - call setup_parameters + call setup_parameters_UFO_SMEFT + allocate (p(0:3,number_particles_in()+number_particles_out())) call beams (roots, 0.0_default, 0.0_default, p(:,1), p(:,2)) call cpu_time (wtime_start) do i = 1, NCALLS call massless_isotropic_decay (roots, p(:,3:)) - call new_event (p) + call new_event_opt (p) end do call cpu_time (wtime) - write (*, "(1X,A,F10.4,A)") "not optimized: " ,& + write (*, "(1X,A,F10.4,A)") "UFO SMEFT optimized: " ,& 1000 * (wtime - wtime_start) / NCALLS, ' milliseconds / evaluation' call cpu_time (wtime_start) do i = 1, NCALLS call massless_isotropic_decay (roots, p(:,3:)) - call new_event_opt (p) + call new_event (p) end do call cpu_time (wtime) - write (*, "(1X,A,F10.4,A)") " optimized: " ,& + write (*, "(1X,A,F10.4,A)") "UFO SMEFT not optimized: " ,& 1000 * (wtime - wtime_start) / NCALLS, ' milliseconds / evaluation' deallocate (p) stop 0 contains pure function dot (p, q) result (pq) real(kind=default), dimension(0:), intent(in) :: p, q real(kind=default) :: pq pq = p(0)*q(0) - dot_product (p(1:), q(1:)) end function dot pure function mass2 (p) result (m2) real(kind=default), dimension(0:), intent(in) :: p real(kind=default) :: m2 m2 = p(0)*p(0) - p(1)*p(1) - p(2)*p(2) - p(3)*p(3) end function mass2 pure subroutine beams (roots, m1, m2, p1, p2) real(kind=default), intent(in) :: roots, m1, m2 real(kind=default), dimension(0:), intent(out) :: p1, p2 real(kind=default) :: m12, m22 m12 = m1**2 m22 = m2**2 p1(0) = (roots**2 + m12 - m22) / (2*roots) p1(1:2) = 0 p1(3) = sqrt (p1(0)**2 - m12) p2(0) = roots - p1(0) p2(1:3) = - p1(1:3) end subroutine beams ! The massless RAMBO algorithm subroutine massless_isotropic_decay (roots, p) real(kind=default), intent(in) :: roots real(kind=default), dimension(0:,:), intent(out) :: p real(kind=default), dimension(0:3,size(p,dim=2)) :: q real(kind=default), dimension(0:3) :: qsum real(kind=default), dimension(4) :: ran real(kind=default) :: c, s, f, qabs, x, r, z integer :: k ! Generate isotropic null vectors do k = 1, size (p, dim = 2) call random_number (ran) ! generate a x*exp(-x) distribution for q(0,k) q(0,k)= -log(ran(1)*ran(2)) c = 2*ran(3)-1 f = 2*PI*ran(4) s = sqrt(1-c*c) q(2,k) = q(0,k)*s*sin(f) q(3,k) = q(0,k)*s*cos(f) q(1,k) = q(0,k)*c enddo ! Boost and rescale the vectors qsum = sum (q, dim = 2) qabs = sqrt (dot (qsum, qsum)) x = roots/qabs do k = 1, size (p, dim = 2) r = dot (q(0:,k), qsum) / qabs z = (q(0,k)+r)/(qsum(0)+qabs) p(1:3,k) = x*(q(1:3,k)-qsum(1:3)*z) p(0,k) = x*r enddo end subroutine massless_isotropic_decay end program benchmark Index: trunk/omega/tests/benchmark_UFO_SM.f90 =================================================================== --- trunk/omega/tests/benchmark_UFO_SM.f90 (revision 0) +++ trunk/omega/tests/benchmark_UFO_SM.f90 (revision 8492) @@ -0,0 +1,142 @@ +! benchmark.f90 -- +! benchmark.f90 -- race O'Mega matrix elements +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! +! +! Copyright (C) 1999-2020 by +! Wolfgang Kilian +! Thorsten Ohl +! Juergen Reuter +! Christian Speckner +! +! WHIZARD 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 2, or (at your option) +! any later version. +! +! WHIZARD 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, write to the Free Software +! Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. +! +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + +program benchmark + + use kinds + use constants + use amplitude_benchmark_UFO_SM, only: new_event, & + number_particles_in, number_particles_out + use amplitude_benchmark_UFO_SM_classic, only: new_event_classic => new_event + + use parameters_SM_from_UFO, only: & + setup_parameters_classic => init_parameters + use parameters_SM_UFO, only: setup_parameters + + implicit none + + integer, parameter :: NCALLS = 500 + real(kind=double), parameter :: ROOTS = 1000 + + real(kind=default), dimension(:,:), allocatable :: p + real(kind=double) :: wtime_start, wtime + integer, dimension(:), allocatable :: seed + integer :: i, seed_size + + call random_seed (seed_size) + allocate (seed(seed_size)) + seed = 42 + call random_seed (put = seed) + deallocate (seed) + + call setup_parameters_classic + call setup_parameters + allocate (p(0:3,number_particles_in()+number_particles_out())) + call beams (roots, 0.0_default, 0.0_default, p(:,1), p(:,2)) + + call cpu_time (wtime_start) + do i = 1, NCALLS + call massless_isotropic_decay (roots, p(:,3:)) + call new_event_classic (p) + end do + call cpu_time (wtime) + write (*, "(1X,A,F10.4,A)") "O'Mega SM classic: " ,& + 1000 * (wtime - wtime_start) / NCALLS, ' milliseconds / evaluation' + + call cpu_time (wtime_start) + do i = 1, NCALLS + call massless_isotropic_decay (roots, p(:,3:)) + call new_event (p) + end do + call cpu_time (wtime) + write (*, "(1X,A,F10.4,A)") "O'Mega SM from UFO: " ,& + 1000 * (wtime - wtime_start) / NCALLS, ' milliseconds / evaluation' + + deallocate (p) + stop 0 + +contains + + pure function dot (p, q) result (pq) + real(kind=default), dimension(0:), intent(in) :: p, q + real(kind=default) :: pq + pq = p(0)*q(0) - dot_product (p(1:), q(1:)) + end function dot + + pure function mass2 (p) result (m2) + real(kind=default), dimension(0:), intent(in) :: p + real(kind=default) :: m2 + m2 = p(0)*p(0) - p(1)*p(1) - p(2)*p(2) - p(3)*p(3) + end function mass2 + + pure subroutine beams (roots, m1, m2, p1, p2) + real(kind=default), intent(in) :: roots, m1, m2 + real(kind=default), dimension(0:), intent(out) :: p1, p2 + real(kind=default) :: m12, m22 + m12 = m1**2 + m22 = m2**2 + p1(0) = (roots**2 + m12 - m22) / (2*roots) + p1(1:2) = 0 + p1(3) = sqrt (p1(0)**2 - m12) + p2(0) = roots - p1(0) + p2(1:3) = - p1(1:3) + end subroutine beams + + ! The massless RAMBO algorithm + subroutine massless_isotropic_decay (roots, p) + real(kind=default), intent(in) :: roots + real(kind=default), dimension(0:,:), intent(out) :: p + real(kind=default), dimension(0:3,size(p,dim=2)) :: q + real(kind=default), dimension(0:3) :: qsum + real(kind=default), dimension(4) :: ran + real(kind=default) :: c, s, f, qabs, x, r, z + integer :: k + ! Generate isotropic null vectors + do k = 1, size (p, dim = 2) + call random_number (ran) + ! generate a x*exp(-x) distribution for q(0,k) + q(0,k)= -log(ran(1)*ran(2)) + c = 2*ran(3)-1 + f = 2*PI*ran(4) + s = sqrt(1-c*c) + q(2,k) = q(0,k)*s*sin(f) + q(3,k) = q(0,k)*s*cos(f) + q(1,k) = q(0,k)*c + enddo + ! Boost and rescale the vectors + qsum = sum (q, dim = 2) + qabs = sqrt (dot (qsum, qsum)) + x = roots/qabs + do k = 1, size (p, dim = 2) + r = dot (q(0:,k), qsum) / qabs + z = (q(0,k)+r)/(qsum(0)+qabs) + p(1:3,k) = x*(q(1:3,k)-qsum(1:3)*z) + p(0,k) = x*r + enddo + end subroutine massless_isotropic_decay + +end program benchmark + Index: trunk/omega/tests/keystones_UFO_bispinors_generate.ml =================================================================== --- trunk/omega/tests/keystones_UFO_bispinors_generate.ml (revision 8491) +++ trunk/omega/tests/keystones_UFO_bispinors_generate.ml (revision 8492) @@ -1,155 +1,288 @@ (* keystones_UFO_generate.ml -- Copyright (C) 2019-2020 by Wolfgang Kilian Thorsten Ohl Juergen Reuter WHIZARD 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 2, or (at your option) any later version. WHIZARD 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, write to the Free Software Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. *) open Coupling open Keystones let qed = equivalent_tensors + ~fermion_lines:[(3, 1)] [| Majorana; Vector; Majorana |] [ ("qed", "Gamma(2,1,3)") ] let axial = equivalent_tensors + ~fermion_lines:[(3, 1)] [| Majorana; Vector; Majorana |] [ ("axial1", "Gamma5(1,-1)*Gamma(2,-1,3)"); ("axial2", "-Gamma(2,1,-3)*Gamma5(-3,3)") ] let left = equivalent_tensors + ~fermion_lines:[(3, 1)] [| Majorana; Vector; Majorana |] [ ("left1", "(Identity(1,-1)+Gamma5(1,-1))*Gamma(2,-1,3)"); ("left2", "2*ProjP(1,-1)*Gamma(2,-1,3)"); ("left3", "Gamma(2,1,-3)*(Identity(-3,3)-Gamma5(-3,3))"); ("left4", "2*Gamma(2,1,-3)*ProjM(-3,3)") ] let right = equivalent_tensors + ~fermion_lines:[(3, 1)] [| Majorana; Vector; Majorana |] [ ("right1", "(Identity(1,-1)-Gamma5(1,-1))*Gamma(2,-1,3)"); ("right2", "2*ProjM(1,-1)*Gamma(2,-1,3)"); ("right3", "Gamma(2,1,-3)*(Identity(-3,3)+Gamma5(-3,3))"); ("right4", "2*Gamma(2,1,-3)*ProjP(-3,3)") ] let vector_spinor_current tag = { tag = Printf.sprintf "vector_spinor_current__%s_ff" tag; keystones = [ { bra = (Majorana, 0); name = Printf.sprintf "f_%sf" tag; args = [G (0); F (Vector, 1); F (Majorana, 2)] }; { bra = (Vector, 1); name = Printf.sprintf "%s_ff" tag; args = [G (0); F (Majorana, 0); F (Majorana, 2)] } ] } let scalar = equivalent_tensors + ~fermion_lines:[(3, 1)] [| Majorana; Scalar; Majorana |] [ ("scalar_current", "Identity(1,3)") ] let pseudo = equivalent_tensors + ~fermion_lines:[(3, 1)] [| Majorana; Scalar; Majorana |] [ ("pseudo_current", "Gamma5(1,3)") ] let left_scalar = equivalent_tensors + ~fermion_lines:[(3, 1)] [| Majorana; Scalar; Majorana |] [ ("left_scalar1", "Identity(1,3)-Gamma5(1,3)"); ("left_scalar2", "2*ProjM(1,3)") ] - + let right_scalar = equivalent_tensors + ~fermion_lines:[(3, 1)] [| Majorana; Scalar; Majorana |] [ ("right_scalar1", "Identity(1,3)+Gamma5(1,3)"); ("right_scalar2", "2*ProjP(1,3)") ] let scalar_spinor_current tag = { tag = Printf.sprintf "scalar_spinor_current__%s_ff" tag; keystones = [ { bra = (Majorana, 0); name = Printf.sprintf "f_%sf" tag; args = [G (0); F (Scalar, 1); F (Majorana, 2)] }; { bra = (Scalar, 1); name = Printf.sprintf "%s_ff" tag; args = [G (0); F (Majorana, 0); F (Majorana, 2)] } ] } let empty = { tag = "empty"; keystones = [ ] } let vertices = [ (qed, vector_spinor_current "v"); (axial, vector_spinor_current "a"); (left, vector_spinor_current "vl"); (right, vector_spinor_current "vr"); (scalar, scalar_spinor_current "s"); (pseudo, scalar_spinor_current "p"); (left_scalar, scalar_spinor_current "sl"); (right_scalar, scalar_spinor_current "sr"); ] let parse_propagator (p_tag, p_omega, p_spins, numerator, denominator) = let p = UFO.Propagator.of_propagator_UFO ~majorana:true { UFO.Propagator_UFO.name = p_tag; UFO.Propagator_UFO.numerator = UFOx.Lorentz.of_string numerator; UFO.Propagator_UFO.denominator = UFOx.Lorentz.of_string denominator } in { p_tag; p_omega; p_spins; p_propagator = p } let default_denominator = "P('mu', id) * P('mu', id) - Mass(id) * Mass(id) \ + complex(0,1) * Mass(id) * Width(id)" let majorana_propagator = ( "majorana", "pr_psi", (Majorana, Majorana), "Gamma('mu', 1, 2) * P('mu', id) + Mass(id) * Identity(1, 2)", default_denominator ) let gravitino_propagator = ( "vectorspinor", "pr_grav", (Vectorspinor, Vectorspinor), "(Gamma(-1,1,2)*P(-1,id) - Mass(id)*Identity(1,2)) \ * (Metric(1,2) - P(1,id)*P(2,id)/Mass(id)**2) \ + 1/3 * (Gamma(1,1,-1) - P(1,id)/Mass(id)*Identity(1,-1)) \ * (Gamma(-3,-1,-2)*P(-3,id) + Mass(id)*Identity(-1,-2)) \ * (Gamma(2,-2,2) - P(2,id)/Mass(id)*Identity(-2,2)) ", default_denominator ) let gravitino_propagator = ( "vectorspinor", "pr_grav", (Vectorspinor, Vectorspinor), "(Gamma(-1,2001,2002)*P(-1,id) - Mass(id)*Identity(2001,2002)) \ * (Metric(1001,1002) - P(1001,id)*P(1002,id)/Mass(id)**2) \ + 1/3 * (Gamma(1001,2001,-1) - P(1001,id)/Mass(id)*Identity(2001,-1)) \ * (Gamma(-3,-1,-2)*P(-3,id) + Mass(id)*Identity(-1,-2)) \ * (Gamma(1002,-2,2002) - P(1002,id)/Mass(id)*Identity(-2,2002)) ", default_denominator ) let propagators = List.map parse_propagator [ majorana_propagator; (* [gravitino_propagator] *) ] +let mvm_UFO = + equivalent_tensors + ~fermion_lines:[(3, 1)] + [| Majorana; Vector; Majorana |] + [ ("mvm", "Gamma(2,1,3)") ] + +let mvm_current omegalib_tag ufo_name = + { tag = omegalib_tag ^ "_mvm_current"; + keystones = + [ { bra = (Majorana, 0); + name = "f_" ^ omegalib_tag ^ "f"; + args = [G (0); F (Vector, 1); F (Majorana, 2)] }; + { bra = (Majorana, 0); + name = ufo_name ^ "_p012"; + args = [G (0); F (Vector, 1); P 1; F (Majorana, 2); P 2] }; + { bra = (Majorana, 2); + name = ufo_name ^ "_p201"; + args = [G (0); F (Majorana, 0); P 0; F (Vector, 1); P 1] }; + { bra = (Vector, 1); + name = omegalib_tag ^ "_ff"; + args = [G (0); F (Majorana, 0); F (Majorana, 2)] }; + { bra = (Vector, 1); + name = ufo_name ^ "_p120"; + args = [G (0); F (Majorana, 2); P 2; F (Majorana, 0); P 0] } ] } + +let mmv_UFO = + equivalent_tensors + ~fermion_lines:[(1, 2)] + [| Majorana; Majorana; Vector |] + [ ("mmv", "Gamma(3,2,1)") ] + +let mmv_current omegalib_tag ufo_name = + { tag = omegalib_tag ^ "_mmv_current"; + keystones = + [ { bra = (Majorana, 1); + name = "f_" ^ omegalib_tag ^ "f"; + args = [G (0); F (Vector, 2); F (Majorana, 0)] }; + { bra = (Majorana, 1); + name = ufo_name ^ "_p120"; + args = [G (0); F (Vector, 2); P 1; F (Majorana, 0); P 2] }; + { bra = (Majorana, 0); + name = ufo_name ^ "_p012"; + args = [G (0); F (Majorana, 1); P 0; F (Vector, 2); P 1] }; + { bra = (Vector, 2); + name = omegalib_tag ^ "_ff"; + args = [G (0); F (Majorana, 1); F (Majorana, 0)] }; + { bra = (Vector, 2); + name = ufo_name ^ "_p201"; + args = [G (0); F (Majorana, 0); P 2; F (Majorana, 1); P 0] } ] } + +let vmm_UFO = + equivalent_tensors + ~fermion_lines:[(2, 3)] + [| Vector; Majorana; Majorana |] + [ ("vmm", "Gamma(1,3,2)") ] + +let vmm_current omegalib_tag ufo_name = + { tag = omegalib_tag ^ "_vmm_current"; + keystones = + [ { bra = (Majorana, 2); + name = "f_" ^ omegalib_tag ^ "f"; + args = [G (0); F (Vector, 0); F (Majorana, 1)] }; + { bra = (Majorana, 2); + name = ufo_name ^ "_p201"; + args = [G (0); F (Vector, 0); P 1; F (Majorana, 1); P 2] }; + { bra = (Majorana, 1); + name = ufo_name ^ "_p120"; + args = [G (0); F (Majorana, 2); P 0; F (Vector, 0); P 1] }; + { bra = (Vector, 0); + name = omegalib_tag ^ "_ff"; + args = [G (0); F (Majorana, 2); F (Majorana, 1)] }; + { bra = (Vector, 0); + name = ufo_name ^ "_p012"; + args = [G (0); F (Majorana, 1); P 2; F (Majorana, 2); P 0] } ] } + +let mam_UFO = + equivalent_tensors + ~fermion_lines:[(3, 1)] + [| Majorana; Vector; Majorana |] + [ ("mam", "Gamma5(1,-1)*Gamma(2,-1,3)") ] + +let mma_UFO = + equivalent_tensors + ~fermion_lines:[(1, 2)] + [| Majorana; Majorana; Vector |] + [ ("mma", "Gamma5(2,-1)*Gamma(3,-1,1)") ] + +let amm_UFO = + equivalent_tensors + ~fermion_lines:[(2, 3)] + [| Vector; Majorana; Majorana |] + [ ("amm", "Gamma5(3,-1)*Gamma(1,-1,2)") ] + +let mvlm_UFO = + equivalent_tensors + ~fermion_lines:[(3, 1)] + [| Majorana; Vector; Majorana |] + [ ("mvlm", "2*ProjP(1,-1)*Gamma(2,-1,3)") ] + +let mvrm_UFO = + equivalent_tensors + ~fermion_lines:[(3, 1)] + [| Majorana; Vector; Majorana |] + [ ("mvrm", "2*ProjM(1,-1)*Gamma(2,-1,3)") ] + +let only_fusions = + List.concat + [mvm_UFO; mmv_UFO; vmm_UFO; + mam_UFO; mma_UFO; amm_UFO; + mvlm_UFO; + mvrm_UFO] + +let propagators = [] + +let vertices = + [([], mvm_current "v" "mvm"); + ([], mmv_current "v" "mmv"); + ([], vmm_current "v" "vmm"); + ([], mvm_current "a" "mam"); + ([], mmv_current "a" "mma"); + ([], vmm_current "a" "amm"); + ([], mvm_current "vl" "mvlm"); + ([], mvm_current "vr" "mvrm")] + let _ = - generate_ufo - ~reps:1000 ~threshold:0.70 ~omega_module:"omega95_bispinors" - "fusions_UFO_bispinors" vertices propagators; + generate_ufo_bispinors + ~reps:1000 ~threshold:0.70 + ~program:"keystones_UFO_bispinors" ~omega_module:"omega95_bispinors" + ~only_fusions "fusions_UFO_bispinors" vertices propagators; exit 0 Index: trunk/omega/tests/compare_lib.f90 =================================================================== --- trunk/omega/tests/compare_lib.f90 (revision 8491) +++ trunk/omega/tests/compare_lib.f90 (revision 8492) @@ -1,644 +1,647 @@ ! compare_lib.f90 -- compare two O'Mega versions !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! ! ! Copyright (C) 1999-2021 by ! Wolfgang Kilian ! Thorsten Ohl ! Juergen Reuter ! Christian Speckner ! ! WHIZARD 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 2, or (at your option) ! any later version. ! ! WHIZARD 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, write to the Free Software ! Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! module compare_lib ! use ieee_arithmetic use kinds use constants use tao_random_numbers use omega95 use omega_interface use omega_testtools implicit none private public :: check public :: omega_flavor_states, omega_squared_matrix_element public :: massless_isotropic_decay, rambo, beams, dot, rambo_check contains elemental function ieee_is_nan (x) result (yorn) logical :: yorn real (kind=default), intent(in) :: x yorn = (x /= x) end function ieee_is_nan subroutine check (v1, v2, roots, threshold, n, & failures, attempts, seed, abs_threshold, & ignore_phase, flip_sign) type(omega_procedures), intent(in) :: v1, v2 real(kind=default), intent(in) :: roots, threshold integer, intent(in) :: n integer, intent(out) :: failures, attempts integer, intent(in), optional :: seed real(kind=default), intent(in), optional :: abs_threshold logical, intent(in), optional :: ignore_phase, flip_sign logical :: modulus_only logical :: match, passed integer :: n_out, n_flv, n_hel, n_col integer :: i, i_flv, i_hel, i_col real(kind=default), dimension(:,:), allocatable :: p complex(kind=default) :: a1, a2 real(kind=default) :: asq1, asq2, s_asq1, s_asq2, relative_sign character(len=80) :: msg modulus_only = .false. if (present (ignore_phase)) then modulus_only = ignore_phase end if relative_sign = 1 if (present (flip_sign)) then if (flip_sign) then relative_sign = -1 end if end if failures = 0 attempts = 0 a1 = 0 a2 = 0 asq1 = 0 asq2 = 0 s_asq1 = 0 s_asq2 = 0 call quantum_numbers (v1, v2, n_out, n_flv, n_hel, n_col, match) if (.not.match) then failures = 1 return end if if (n_out <= 0) then print *, "no outgoing particles" failures = 1 return end if if (n_flv <= 0) then print *, "no allowed flavor combinations" failures = 1 return end if if (n_hel <= 0) then print *, "no allowed helicity combinations" failures = 1 return end if if (n_col <= 0) then print *, "no allowed color flows" failures = 1 return end if if (present (seed)) then call tao_random_seed (seed) end if call v1%reset_helicity_selection (-1.0_default, -1) call v2%reset_helicity_selection (-1.0_default, -1) allocate (p(0:3,2+n_out)) call beams (ROOTS, 0.0_default, 0.0_default, p(:,1), p(:,2)) do i = 1, N if (n_out > 1) then call massless_isotropic_decay (ROOTS, p(:,3:)) end if if (n_out == 1) then p(:,3) = p(:,1) + p(:,2) end if call v1%new_event (p) call v2%new_event (p) do i_flv = 1, n_flv do i_hel = 1, n_hel attempts = attempts + 1 passed = .true. do i_col = 1, n_col a1 = v1%get_amplitude (i_flv, i_hel, i_col) a2 = v2%get_amplitude (i_flv, i_hel, i_col)*relative_sign if (ieee_is_nan (real (a1)) .or. ieee_is_nan (aimag (a1))) then write (*, "(1X,'evt=',I5,', flv=',I3,', col=',I3,': ', A)") & i, i_flv, i_col, "v1 amplitude NaN" end if if (ieee_is_nan (real (a2)) .or. ieee_is_nan (aimag (a2))) then write (*, "(1X,'evt=',I5,', flv=',I3,', col=',I3,': ', A)") & i, i_flv, i_col, "v2 amplitude NaN" end if write (msg, "(1X,'evt=',I5,', flv=',I3,', col=',I3,', hel=',I3)") & i, i_flv, i_col, i_hel if (modulus_only) then call expect (abs (a1), abs (a2), trim(msg), passed, & quiet=.true., threshold=threshold, & abs_threshold=abs_threshold) else call expect (a1, a2, trim(msg), passed, & quiet=.true., threshold=threshold, & abs_threshold=abs_threshold) end if end do write (msg, "(1X,'evt=',I5,', flv=',I3,', hel=',I3)") & i, i_flv, i_hel asq1 = v1%color_sum (i_flv, i_hel) s_asq1 = s_asq1 + asq1 asq2 = v2%color_sum (i_flv, i_hel) s_asq2 = s_asq2 + asq2 call expect (asq1, asq2, trim(msg), passed, & quiet=.true., threshold=threshold, & abs_threshold=abs_threshold) if (.not.passed) then failures = failures + 1 end if end do end do end do print *, 'Summed results: ' print *, 's_asq1, s_asq2 = ', s_asq1, s_asq2 deallocate (p) end subroutine check subroutine quantum_numbers (v1, v2, n_out, n_flv, n_hel, n_col, match) type(omega_procedures), intent(in) :: v1, v2 integer, intent(out) :: n_out, n_flv, n_hel, n_col logical, intent(out) :: match integer, dimension(:,:), allocatable :: & v1_flavor_states, v2_flavor_states, & v1_spin_states, v2_spin_states integer, dimension(:,:,:), allocatable :: & v1_color_flows, v2_color_flows logical, dimension(:,:), allocatable :: & v1_ghost_flags, v2_ghost_flags type(omega_color_factor), dimension(:), allocatable :: & v1_color_factors, v2_color_factors integer :: n_in, n_prt, n_cix, n_cfs n_in = v1%number_particles_in () n_out = v1%number_particles_out () n_prt = n_in + n_out n_flv = v1%number_flavor_states () n_hel = v1%number_spin_states () n_cix = v1%number_color_indices () n_col = v1%number_color_flows () n_cfs = v1%number_color_factors () match = .true. if (v2%number_particles_in () .ne. n_in) then print *, "number_particles_in don't match!" match = .false. end if if (v2%number_particles_out () .ne. n_out) then print *, "number_particles_out don't match!" match = .false. end if if (v2%number_flavor_states () .ne. n_flv) then print *, "number_flavor_states don't match!" match = .false. end if if (v2%number_spin_states () .ne. n_hel) then print *, "number_spin_states don't match!" match = .false. end if if (v2%number_color_indices () .ne. n_cix) then print *, "number_color_indices don't match!" match = .false. end if if (v2%number_color_flows () .ne. n_col) then print *, "number_color_flows don't match!" match = .false. end if ! We save only the symmetric part in the OVM !if (v2%number_color_factors () .ne. n_cfs) then !print *, "number_color_factors don't match!" !match = .false. !end if if (match) then allocate (v1_flavor_states(n_prt,n_flv), v2_flavor_states(n_prt,n_flv)) allocate (v1_spin_states(n_prt,n_hel), v2_spin_states(n_prt,n_hel)) allocate (v1_color_flows(n_cix,n_prt,n_col), & v2_color_flows(n_cix,n_prt,n_col)) allocate (v1_ghost_flags(n_prt,n_col), v2_ghost_flags(n_prt,n_col)) !allocate (v1_color_factors(n_cfs), v2_color_factors(n_cfs)) call v1%flavor_states (v1_flavor_states) call v2%flavor_states (v2_flavor_states) call v1%spin_states (v1_spin_states) call v2%spin_states (v2_spin_states) call v1%color_flows (v1_color_flows, v1_ghost_flags) call v2%color_flows (v2_color_flows, v2_ghost_flags) !call v1%color_factors (v1_color_factors) !call v2%color_factors (v2_color_factors) if (any (v1_flavor_states .ne. v2_flavor_states)) then print *, "flavor states don't match!" print *, "CAVEAT: this might be due to simple reordering!" match = .false. end if if (any (v1_spin_states .ne. v2_spin_states)) then print *, "spin states don't match!" print *, "CAVEAT: this might be due to simple reordering!" match = .false. end if if (any (v1_color_flows .ne. v2_color_flows)) then print *, "color flows don't match!" print *, "CAVEAT: this might be due to simple reordering!" match = .false. end if if (any (v1_ghost_flags .neqv. v2_ghost_flags)) then print *, "ghost flags don't match!" print *, "CAVEAT: this might be due to simple reordering!" match = .false. end if !if (any (.not. color_factors_equal (v1_color_factors, & !v2_color_factors))) then !print *, "color_factors don't match!" !print *, "CAVEAT: this might be due to simple reordering!" !match = .false. !end if deallocate (v1_flavor_states, v2_flavor_states) deallocate (v1_spin_states, v2_spin_states) deallocate (v1_color_flows, v2_color_flows) deallocate (v1_ghost_flags, v2_ghost_flags) !deallocate (v1_color_factors, v2_color_factors) end if end subroutine quantum_numbers elemental function color_factors_equal (cf1, cf2) result (eq) logical :: eq type(omega_color_factor), intent(in) :: cf1, cf2 eq = (cf1%i1 .eq. cf2%i1) .and. (cf1%i2 .eq. cf2%i2) .and. (cf1%factor .eq. cf2%factor) end function color_factors_equal subroutine omega_flavor_states (proc, flavors) type(omega_procedures) :: proc integer, dimension(:,:), allocatable, intent(inout) :: flavors integer :: n_in, n_out, n_prt, n_flv n_in = proc%number_particles_in () n_out = proc%number_particles_out () n_prt = n_in + n_out n_flv = proc%number_flavor_states () if (allocated (flavors)) then if (any (size (flavors) /= (/ n_prt, n_flv /))) then deallocate (flavors) allocate (flavors (n_prt, n_flv)) end if else allocate (flavors (n_prt, n_flv)) end if call proc%flavor_states (flavors) end subroutine omega_flavor_states subroutine omega_squared_matrix_element (proc, p, asq, error) type(omega_procedures) :: proc real(kind=default), dimension(0:,:), intent(in) :: p real(kind=default), intent(out) :: asq logical, intent(out) :: error real(kind=default) :: asq_sum integer :: i_hel call proc%new_event (p) error = .false. if (proc%number_flavor_states () /= 1) then print *, "ambiguous flavor in omega amplitude" error = .true. return end if asq_sum = 0 do i_hel = 1, proc%number_spin_states () asq_sum = asq_sum + proc%color_sum (1, i_hel) end do asq = asq_sum / 4 end subroutine omega_squared_matrix_element pure function dot (p, q) result (pq) real(kind=default), dimension(0:), intent(in) :: p, q real(kind=default) :: pq pq = p(0)*q(0) - dot_product (p(1:), q(1:)) end function dot pure subroutine beams (roots, m1, m2, p1, p2) real(kind=default), intent(in) :: roots, m1, m2 real(kind=default), dimension(0:), intent(out) :: p1, p2 real(kind=default) :: m12, m22 m12 = m1**2 m22 = m2**2 p1(0) = (roots**2 + m12 - m22) / (2*roots) p1(1:2) = 0 p1(3) = sqrt (p1(0)**2 - m12) p2(0) = roots - p1(0) p2(1:3) = - p1(1:3) end subroutine beams ! The massless RAMBO algorithm subroutine massless_isotropic_decay (roots, p) real(kind=default), intent(in) :: roots real(kind=default), dimension(0:,:), intent(out) :: p real(kind=default), dimension(0:3,size(p,dim=2)) :: q real(kind=default), dimension(0:3) :: qsum real(kind=double), dimension(4) :: ran_double real(kind=default), dimension(4) :: ran real(kind=default) :: c, s, f, qabs, x, r, z integer :: k ! Generate isotropic null vectors do k = 1, size (p, dim = 2) ! if default is not double or single, we can't use ! tao_random_number directly ... call tao_random_number (ran_double) ran = ran_double ! generate a x*exp(-x) distribution for q(0,k) q(0,k)= -log(ran(1)*ran(2)) c = 2*ran(3)-1 f = 2*PI*ran(4) s = sqrt(1-c*c) q(2,k) = q(0,k)*s*sin(f) q(3,k) = q(0,k)*s*cos(f) q(1,k) = q(0,k)*c enddo ! Boost and rescale the vectors qsum = sum (q, dim = 2) qabs = sqrt (dot (qsum, qsum)) x = roots/qabs do k = 1, size (p, dim = 2) r = dot (q(0:,k), qsum) / qabs z = (q(0,k)+r)/(qsum(0)+qabs) p(1:3,k) = x*(q(1:3,k)-qsum(1:3)*z) p(0,k) = x*r enddo end subroutine massless_isotropic_decay !------------------------------------------------------ ! RAMBO, R. Kleiss, W.J. Stirling, S.D. Ellis. ! Comp. Phys. Commun. 40 (1986) 359 !------------------------------------------------------ subroutine rambo (roots, m, p, weight, unweighted) implicit none real(kind=default), intent(in) :: roots real(kind=default), dimension(:), intent(in) :: m real(kind=default), dimension(0:,:), intent(out) :: p real(kind=default), intent(out) :: weight logical, intent(in) :: unweighted real(kind=default), dimension(0:3,size(m)):: q real(kind=default), dimension(0:3) :: sum_q real(kind=default) :: mass_sum_q real(kind=default), dimension(4) :: random real(kind=default) :: random_weight real(kind=double), dimension(4) :: random_double real(kind=double) :: random_weight_double real(kind=default), dimension(size(m)):: m2, e, v, p2 real(kind=default) :: a,accu,bq,costh,phi,f0,g,g0,pm2 real(kind=default) :: sinth,sm2,w,wt2,wt3,wtm,wtmax,x,x2,xmax,sum_m real(kind=default) :: b(3) integer :: i, iter, k, num_massive real(kind=default), dimension(:), allocatable, save :: z real(kind=default), save :: twopi, log_pi_over_2 real(kind=default), parameter :: ACC = 1d-14 integer, parameter :: MAX_ITERATIONS = 6 integer, save :: underflows = 0, overflows = 0, excessive_weights = 0 if (size(p,dim=2) /= size(m)) then print *, 'rambo: mismatch of array dimensions of M and P' stop end if ! initialize the factorials for the phase space weight if (allocated(z)) then if (size(z) < size(m)) then deallocate (z) end if end if if (.not.allocated(z)) then allocate (z(size(m))) ! z(1) = ??? twopi = 8 * atan (1.0_default) log_pi_over_2 = log (twopi / 4) z(2) = log_pi_over_2 do k = 3, size(z) z(k) = z(k-1) + log_pi_over_2 - 2 * log (real (k-2, kind=default)) end do do k = 3, size(z) z(k) = z(k) - log (real (k-1, kind=default)) end do end if ! check whether total energy suffices and count nonzero masses num_massive = count (m /= 0) sum_m = sum (abs (m)) if (sum_m > roots) then print *, ' RAMBO FAILS: TOTAL MASS =', sum_m, & ' IS NOT', ' SMALLER THAN TOTAL ENERGY =', roots stop end if ! generate N massless momenta generate: do do i = 1, size(m) call tao_random_number (random_double) random = random_double costh = 2 * random(1) - 1 sinth = sqrt (1 - costh*costh) phi = twopi * random(2) q(0,i) = -log (random(3)*random(4)) q(3,i) = q(0,i) * costh q(2,i) = q(0,i) * sinth * cos (phi) q(1,i) = q(0,i) * sinth * sin (phi) end do ! compute the parameters of the conformal transformation sum_q = sum (q, dim=2) mass_sum_q = sqrt (dot (sum_q, sum_q)) b = - sum_q(1:3) / mass_sum_q g = sum_q(0) / mass_sum_q a = 1 / (1 + g) x = roots / mass_sum_q ! TRANSFORM THE Q'S CONFORMALLY INTO THE P'S do i = 1, size(m) bq = b(1) * q(1,i) + b(2) * q(2,i) + b(3) * q(3,i) p(1:3,i) = x * (q(1:3,i) + b * (q(0,i) + a*bq)) p(0,i) = x * (g*q(0,i) + bq) end do ! for unweighted massless momenta, we're done weight = 1 if (num_massive == 0 .and. unweighted) then exit generate end if ! CALCULATE WEIGHT AND POSSIBLE WARNINGS weight = log_pi_over_2 if (size(m) /= 2) then weight = (2*size(m) - 4) * log (roots) + z(size(m)) end if if (weight < - 180) then if (underflows <= 5) then call rambo_flow (weight, 'under') end if underflows = underflows + 1 end if if (weight > 174) then if (overflows <= 5) then call rambo_flow (weight, 'over') end if overflows = overflows + 1 end if ! return FOR WEIGHTED MASSLESS MOMENTA if (num_massive /= 0) then ! MASSIVE PARTICLES: RESCALE THE MOMENTA BY A FACTOR X xmax = sqrt (1 - (sum_m/roots)**2) m2 = m**2 p2 = p(0,:)**2 x = xmax accu = roots * ACC iter = 0 solve: do f0 = - roots g0 = 0 x2 = x*x do i = 1, size(m) e(i) = sqrt (m2(i) + x2 * p2(i)) f0 = f0 + e(i) g0 = g0 + p2(i) / e(i) end do if (abs (f0) > accu) then iter = iter + 1 if (iter <= MAX_ITERATIONS) then x = x - f0 / (x*g0) cycle solve else print *, ' RAMBO WARNS:', MAX_ITERATIONS, & ' ITERATIONS DID NOT GIVE THE', & ' DESIRED ACCURACY =', ACC end if end if exit solve end do solve v = x * p(0,:) P(1:3,:) = x * P(1:3,:) P(0,:) = e ! CALCULATE THE MASS-EFFECT WEIGHT FACTOR wt2 = product (v / e) wt3 = sum (v**2 / e) wtm = (2*size(m) - 3) * log (x) + LOG (wt2 / wt3 * roots) if (unweighted) then ! UNWEIGHTED MASSIVE MOMENTA REQUIRED: ESTIMATE MAXIMUM WEIGHT weight = exp (wtm) if (num_massive <= 1) then ! ONE MASSIVE PARTICLE wtmax = xmax**(4*size(m) - 6) elseif (num_massive > 2) then ! MORE THAN TWO MASSIVE PARTICLES: AN ESTIMATE ONLY wtmax = xmax**(2*size(m) - 5 + num_massive) else ! TWO MASSIVE PARTICLES sm2 = sum (m2) ! this was wrong (always 0) in thr orignal) pm2 = product (m2, mask = (m2 /= 0)) wtmax = ((1 - sm2 / (roots**2))**2 & - 4*pm2 / roots**4)**(size(m) - 1.5_default) end if ! DETERMINE WHETHER OR NOT TO ACCEPT THIS EVENT w = weight / wtmax if (w > 1) then - print *, ' RAMBO WARNS: ESTIMATE FOR MAXIMUM WEIGHT =', & - wtmax, ' EXCEEDED BY A FACTOR ', w +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! +! For the purpose of our tests, we can suppress this warning +! print *, ' RAMBO WARNS: ESTIMATE FOR MAXIMUM WEIGHT =', & +! wtmax, ' EXCEEDED BY A FACTOR ', w +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! excessive_weights = excessive_weights + 1 end if call tao_random_number (random_weight_double) random_weight = random_weight_double if (w < random_weight) then cycle generate end if weight = 1 else ! return FOR WEIGHTED MASSIVE MOMENTA weight = weight + wtm if (weight < -180) then if (underflows <= 5) then call rambo_flow (weight, 'under') end if underflows = underflows + 1 end if if (weight > 174) then if (overflows <= 5) then call rambo_flow (weight, 'over') end if overflows = overflows + 1 end if weight = exp (weight) end if else weight = exp (weight) end if exit generate end do generate end subroutine rambo subroutine rambo_check (roots, m, p, quiet) real(kind=default), intent(in) :: roots real(kind=default), dimension(:), intent(in) :: m real(kind=default), dimension(0:,:), intent(in) :: p logical, intent (in) :: quiet real(kind=default), dimension(0:3) :: sum_p integer :: mu, i logical :: passed real(kind=default), parameter :: & THRESHOLD_MOMENTUM = 0.80, & THRESHOLD_MASS = 0.45 passed = .true. sum_p = sum (p, dim=2) call expect (sum_p(0), roots, 'energy momentum', & passed, threshold=THRESHOLD_MOMENTUM, quiet=quiet) do mu = 1, 3 call expect_zero (sum_p(mu), roots, 'spatial momentum', & passed, threshold=THRESHOLD_MOMENTUM, quiet=quiet) end do do i = 1, size(m) call expect (dot (p(:,i), p(:,i)), m(i)**2, 'mass shell', & passed, threshold=THRESHOLD_MASS, quiet=quiet) end do if (.not.passed .and. .not.quiet) then do i = 1, size (m) print *, 'M(', i, ') = ', sqrt (abs (dot (p(:,i), p(:,i)))), & 'vs. ', m(i) end do do mu = 0, 3 print *, 'sum p(', mu, ',:) = ', sum_p(mu) end do end if end subroutine rambo_check subroutine rambo_flow (w, f) implicit none real(kind=default), intent(in) :: w character(len=*), intent(in) :: f print *, ' RAMBO WARNS: WEIGHT = EXP(', w,') MAY ', f end subroutine rambo_flow end module compare_lib Index: trunk/omega/tests/keystones_UFO_generate.ml =================================================================== --- trunk/omega/tests/keystones_UFO_generate.ml (revision 8491) +++ trunk/omega/tests/keystones_UFO_generate.ml (revision 8492) @@ -1,379 +1,388 @@ (* keystones_UFO_generate.ml -- Copyright (C) 2019-2020 by Wolfgang Kilian Thorsten Ohl Juergen Reuter WHIZARD 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 2, or (at your option) any later version. WHIZARD 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, write to the Free Software Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. *) open Coupling open Keystones +(* For testing Dirac equations \&c.~\ldots *) + +let pslash = + equivalent_tensors + [| ConjSpinor; Spinor |] + [ ("pslash", "P(-1,2)*Gamma(-1,1,2)") ] + let qed = equivalent_tensors [| ConjSpinor; Vector; Spinor |] [ ("qed", "Gamma(2,1,3)") ] let axial = equivalent_tensors [| ConjSpinor; Vector; Spinor |] [ ("axial1", "Gamma5(1,-1)*Gamma(2,-1,3)"); ("axial2", "-Gamma(2,1,-3)*Gamma5(-3,3)") ] let left = equivalent_tensors [| ConjSpinor; Vector; Spinor |] [ ("left1", "(Identity(1,-1)+Gamma5(1,-1))*Gamma(2,-1,3)"); ("left2", "2*ProjP(1,-1)*Gamma(2,-1,3)"); ("left3", "Gamma(2,1,-3)*(Identity(-3,3)-Gamma5(-3,3))"); ("left4", "2*Gamma(2,1,-3)*ProjM(-3,3)") ] let right = equivalent_tensors [| ConjSpinor; Vector; Spinor |] [ ("right1", "(Identity(1,-1)-Gamma5(1,-1))*Gamma(2,-1,3)"); ("right2", "2*ProjM(1,-1)*Gamma(2,-1,3)"); ("right3", "Gamma(2,1,-3)*(Identity(-3,3)+Gamma5(-3,3))"); ("right4", "2*Gamma(2,1,-3)*ProjP(-3,3)") ] let vector_spinor_current tag = { tag = Printf.sprintf "vector_spinor_current__%s_ff" tag; keystones = [ { bra = (ConjSpinor, 0); name = Printf.sprintf "f_%sf" tag; args = [G (0); F (Vector, 1); F (Spinor, 2)] }; { bra = (Vector, 1); name = Printf.sprintf "%s_ff" tag; args = [G (0); F (ConjSpinor, 0); F (Spinor, 2)] }; { bra = (Spinor, 2); name = Printf.sprintf "f_f%s" tag; args = [G (0); F (ConjSpinor, 0); F (Vector, 1)] } ] } let scalar = equivalent_tensors [| ConjSpinor; Scalar; Spinor |] [ ("scalar_current", "Identity(1,3)") ] let pseudo = equivalent_tensors [| ConjSpinor; Scalar; Spinor |] [ ("pseudo_current", "Gamma5(1,3)") ] let left_scalar = equivalent_tensors [| ConjSpinor; Scalar; Spinor |] [ ("left_scalar1", "Identity(1,3)-Gamma5(1,3)"); ("left_scalar2", "2*ProjM(1,3)") ] let right_scalar = equivalent_tensors [| ConjSpinor; Scalar; Spinor |] [ ("right_scalar1", "Identity(1,3)+Gamma5(1,3)"); ("right_scalar2", "2*ProjP(1,3)") ] let scalar_spinor_current tag = { tag = Printf.sprintf "scalar_spinor_current__%s_ff" tag; keystones = [ { bra = (ConjSpinor, 0); name = Printf.sprintf "f_%sf" tag; args = [G (0); F (Scalar, 1); F (Spinor, 2)] }; { bra = (Scalar, 1); name = Printf.sprintf "%s_ff" tag; args = [G (0); F (ConjSpinor, 0); F (Spinor, 2)] }; { bra = (Spinor, 2); name = Printf.sprintf "f_f%s" tag; args = [G (0); F (ConjSpinor, 0); F (Scalar, 1)] } ] } let fermi_ss = equivalent_tensors [| ConjSpinor; Spinor; ConjSpinor; Spinor |] [ ("fermi_ss", "Identity(1,2)*Identity(3,4)"); ("fermi_ss_f", " (1/4) * Identity(1,4)*Identity(3,2)" ^ " + (1/4) * Gamma(-1,1,4)*Gamma(-1,3,2)" ^ " + (1/8) * Sigma(-1,-2,1,4)*Sigma(-1,-2,3,2)" ^ " - (1/4) * Gamma(-1,1,-4)*Gamma5(-4,4)*Gamma(-1,3,-2)*Gamma5(-2,2)" ^ " + (1/4) * Gamma5(1,4)*Gamma5(3,2)") ] let fermi_vv = equivalent_tensors [| ConjSpinor; Spinor; ConjSpinor; Spinor |] [ ("fermi_vv", "Gamma(-1,1,2)*Gamma(-1,3,4)"); ("fermi_vv_f", " Identity(1,4)*Identity(3,2)" ^ " - (1/2) * Gamma(-1,1,4)*Gamma(-1,3,2)" ^ " - (1/2) * Gamma(-1,1,-4)*Gamma5(-4,4)*Gamma(-1,3,-2)*Gamma5(-2,2)" ^ " - Gamma5(1,4)*Gamma5(3,2)") ] let fermi_tt = equivalent_tensors [| ConjSpinor; Spinor; ConjSpinor; Spinor |] [ ("fermi_tt1", " Sigma(-1,-2,1,2)*Sigma(-1,-2,3,4)"); ("fermi_tt2", " - Sigma(-1,-2,1,2)*Sigma(-2,-1,3,4)"); ("fermi_tt3", " - Sigma(-2,-1,1,2)*Sigma(-1,-2,3,4)"); ("fermi_tt_f", " 3 * Identity(1,4)*Identity(3,2)" ^ " - (1/2) * Sigma(-1,-2,1,4)*Sigma(-1,-2,3,2)" ^ " + 3 * Gamma5(1,4)*Gamma5(3,2)") ] let fermi_aa = equivalent_tensors [| ConjSpinor; Spinor; ConjSpinor; Spinor |] [ ("fermi_aa", "Gamma5(1,-2)*Gamma(-1,-2,2)*Gamma5(3,-3)*Gamma(-1,-3,4)"); ("fermi_aa_f", " - Identity(1,4)*Identity(3,2)" ^ " - (1/2) * Gamma(-1,1,4)*Gamma(-1,3,2)" ^ " - (1/2) * Gamma(-1,1,-4)*Gamma5(-4,4)*Gamma(-1,3,-2)*Gamma5(-2,2)" ^ " + Gamma5(1,4)*Gamma5(3,2)") ] let fermi_pp = equivalent_tensors [| ConjSpinor; Spinor; ConjSpinor; Spinor |] [ ("fermi_pp", "Gamma5(1,2)*Gamma5(3,4)"); ("fermi_pp_f", " (1/4) * Identity(1,4)*Identity(3,2)" ^ " - (1/4) * Gamma(-1,1,4)*Gamma(-1,3,2)" ^ " + (1/8) * Sigma(-1,-2,1,4)*Sigma(-1,-2,3,2)" ^ " + (1/4) * Gamma(-1,1,-4)*Gamma5(-4,4)*Gamma(-1,3,-2)*Gamma5(-2,2)" ^ " + (1/4) * Gamma5(1,4)*Gamma5(3,2)") ] let fermi_ll = equivalent_tensors [| ConjSpinor; Spinor; ConjSpinor; Spinor |] [ ("fermi_ll", " Gamma(-1,1,-2)*ProjM(-2,2)*Gamma(-1,3,-4)*ProjM(-4,4)"); ("fermi_ll_f", " - Gamma(-1,1,-2)*ProjM(-2,4)*Gamma(-1,3,-4)*ProjM(-4,2)") ] let fermi_va = equivalent_tensors [| ConjSpinor; Spinor; ConjSpinor; Spinor |] [ ("fermi_va", "Gamma(-1,1,2)*Gamma5(3,-3)*Gamma(-1,-3,4)") ] let fermi_av = equivalent_tensors [| ConjSpinor; Spinor; ConjSpinor; Spinor |] [ ("fermi_av", "Gamma5(1,-2)*Gamma(-1,-2,2)*Gamma(-1,3,4)") ] let sqed = equivalent_tensors [| Scalar; Vector; Scalar |] [ ("sqed1", "P(2,3)-P(2,1)"); ("sqed2", "2*P(2,3)+P(2,2)"); ("sqed3", "-P(2,2)-2*P(2,1)") ] let vector_scalar_current = { tag = "vector_scalar_current__v_ss"; keystones = [ { bra = (Vector, 1); name = "v_ss"; args = [G (0); F (Scalar, 2); P (2); F (Scalar, 0); P (0)] }; { bra = (Scalar, 0); name = "s_vs"; args = [G (0); F (Vector, 1); P (1); F (Scalar, 2); P (2)] } ] } let svv_t = equivalent_tensors [| Scalar; Vector; Vector |] [ ("svv_t", "P(-1,2)*P(-1,3)*Metric(2,3)-P(2,3)*P(3,2)") ] let scalar_vector_current tag = { tag = Printf.sprintf "transversal_vector_current__s_vv_%s" tag; keystones = [ { bra = (Scalar, 0); name = Printf.sprintf "s_vv_%s" tag; args = [G (0); F (Vector, 1); P (1); F (Vector, 2); P (2)] }; { bra = (Vector, 1); name = Printf.sprintf "v_sv_%s" tag; args = [G (0); F (Scalar, 0); P (0); F (Vector, 2); P (2)] } ] } let gauge = equivalent_tensors [| Vector; Vector; Vector |] [ ("gauge", " Metric(1,2)*P(3,1) - Metric(1,2)*P(3,2) \ + Metric(3,1)*P(2,3) - Metric(3,1)*P(2,1) \ + Metric(2,3)*P(1,2) - Metric(2,3)*P(1,3)") ] let gauge_omega = { tag = "g_gg"; keystones = [ { bra = (Vector, 0); name = "(0,1)*g_gg"; args = [G (0); F (Vector, 1); P (1); F (Vector, 2); P (2)] } ] } (* Note that $C^{-1}=-C$ for the charge conjugation matrix.*) let charge_conjugate_s = equivalent_tensors [| Scalar; ConjSpinor; Spinor |] [ ("gamma1", "Identity(2,3)"); ("gamma1_cc", "C(3,-3)*Identity(-3,-2)*(-C(-2,2))"); ("gamma1_cx", "C(3,-1)*(-C(-1,2))") ] (* $C \gamma_5 C^{-1} = \gamma_5^T$ *) let charge_conjugate_p = equivalent_tensors [| Scalar; ConjSpinor; Spinor |] [ ("gamma5", "Gamma5(2,3)"); ("gamma5_cc", "C(3,-3)*Gamma5(-3,-2)*(-C(-2,2))") ] (* $C \gamma_\mu C^{-1} = - \gamma_\mu^T$ *) let charge_conjugate_v = equivalent_tensors [| Vector; ConjSpinor; Spinor |] [ ("gamma_mu", "Gamma(1,2,3)"); ("gamma_mu_cc", "-C(3,-3)*Gamma(1,-3,-2)*(-C(-2,2))") ] (* $C \gamma_5\gamma_\mu C^{-1} = (\gamma_5\gamma_\mu)^T$ *) let charge_conjugate_a = equivalent_tensors [| Vector; ConjSpinor; Spinor |] [ ("gamma_5mu", "Gamma5(2,-2)*Gamma(1,-2,3)"); ("gamma_5mu_cc", "C(3,-3)*Gamma5(-3,-1)*Gamma(1,-1,-2)*(-C(-2,2))") ] (* $C \sigma_{\mu\nu} C^{-1} = - \sigma_{\mu\nu}^T$ *) let charge_conjugate_t = equivalent_tensors [| Vector; Vector; ConjSpinor; Spinor |] [ ("sigma_munu", "Sigma(1,2,3,4)"); ("sigma_munu_cc", "-C(4,-4)*Sigma(1,2,-4,-3)*(-C(-3,3))") ] (* $C \gamma_\mu \gamma_\nu C^{-1} = \gamma_\nu^T \gamma_\mu^T$ *) let charge_conjugate_vv = equivalent_tensors [| Vector; Vector; ConjSpinor; Spinor |] [ ("gamma_mu_nu", "Gamma(1,3,-1)*Gamma(2,-1,4)"); ("gamma_mu_nu_cc", "C(4,-4)*Gamma(2,-4,-1)*Gamma(1,-1,-3)*(-C(-3,3))") ] let empty = { tag = "empty"; keystones = [ ] } let vertices = - [ (qed, vector_spinor_current "v"); + [ (pslash, empty); + (qed, vector_spinor_current "v"); (axial, vector_spinor_current "a"); (left, vector_spinor_current "vl"); (right, vector_spinor_current "vr"); (scalar, scalar_spinor_current "s"); (pseudo, scalar_spinor_current "p"); (left_scalar, scalar_spinor_current "sl"); (right_scalar, scalar_spinor_current "sr"); (sqed, vector_scalar_current); (fermi_ss, empty); (fermi_vv, empty); (fermi_tt, empty); (fermi_aa, empty); (fermi_pp, empty); (fermi_ll, empty); (fermi_va, empty); (fermi_av, empty); (svv_t, scalar_vector_current "t"); (gauge, gauge_omega); (charge_conjugate_s, empty); (charge_conjugate_p, empty); (charge_conjugate_v, empty); (charge_conjugate_a, empty); (charge_conjugate_t, empty); (charge_conjugate_vv, empty) ] let parse_propagator (p_tag, p_omega, p_spins, numerator, denominator) = let p = UFO.Propagator.of_propagator_UFO { UFO.Propagator_UFO.name = p_tag; UFO.Propagator_UFO.numerator = UFOx.Lorentz.of_string numerator; UFO.Propagator_UFO.denominator = UFOx.Lorentz.of_string denominator } in { p_tag; p_omega; p_spins; p_propagator = p } let default_denominator = "P('mu', id) * P('mu', id) - Mass(id) * Mass(id) \ + complex(0,1) * Mass(id) * Width(id)" let scalar_propagator = ( "scalar", "pr_phi", (Scalar, Scalar), "1", default_denominator ) let spinor_propagator = ( "spinor", "pr_psi", (ConjSpinor, Spinor), "Gamma('mu', 1, 2) * P('mu', id) + Mass(id) * Identity(1, 2)", default_denominator ) let conjspinor_propagator = ( "conjspinor", "pr_psibar", (ConjSpinor, Spinor), "Gamma('mu', 1, 2) * P('mu', id) + Mass(id) * Identity(1, 2)", default_denominator ) let feynman_propagator = ( "feynman", "pr_feynman", (Vector, Vector), " - Metric(1, 2)", "P('mu', id) * P('mu', id)" ) let gauge_propagator = ( "gauge_propagator", "pr_gauge", (Vector, Vector), " - Metric(1, 2) + (1 - 42) * P(1,id) * P(2,id) / " ^ "( P('mu', id) * P('mu', id) )", "P('mu', id) * P('mu', id)" ) let rxi_propagator = ( "rxi_propagator", "pr_rxi", (Vector, Vector), " - Metric(1, 2) + (1 - 42) * P(1,id) * P(2,id) / " ^ "( P('mu', id) * P('mu', id) - 42 * Mass(id)**2 )", default_denominator ) let unitarity_propagator = ( "unitarity", "pr_unitarity", (Massive_Vector, Massive_Vector), "- Metric(1, 2) + Metric(1,'mu')*P('mu', id)*P(2, id)/Mass(id)**2", default_denominator ) let tensor_propagator = ( "tensor", "pr_tensor", (Tensor_2, Tensor_2), " 1/2 * (Metric(1001,1002) - P(1001,id)*P(1002,id)/Mass(id)**2) \ * (Metric(2001,2002) - P(2001,id)*P(2002,id)/Mass(id)**2) \ + 1/2 * (Metric(1001,2002) - P(1001,id)*P(2002,id)/Mass(id)**2) \ * (Metric(2001,1002) - P(2001,id)*P(1002,id)/Mass(id)**2) \ - 1/3 * (Metric(1001,2001) - P(1001,id)*P(2001,id)/Mass(id)**2) \ * (Metric(1002,2002) - P(1002,id)*P(2002,id)/Mass(id)**2) ", default_denominator ) let tensor_propagator_51_52 = ( "tensor_51_52", "pr_tensor", (Tensor_2, Tensor_2), " 1/2 * (Metric( 1, 2) - P( 1,id)*P( 2,id)/Mass(id)**2) \ * (Metric(51,52) - P(51,id)*P(52,id)/Mass(id)**2) \ + 1/2 * (Metric( 1,52) - P( 1,id)*P(52,id)/Mass(id)**2) \ * (Metric(51, 2) - P(51,id)*P( 2,id)/Mass(id)**2) \ - 1/3 * (Metric( 1,51) - P( 1,id)*P(51,id)/Mass(id)**2) \ * (Metric( 2,52) - P( 2,id)*P(52,id)/Mass(id)**2) ", default_denominator ) let propagators = List.map parse_propagator [ scalar_propagator; spinor_propagator; feynman_propagator; gauge_propagator; rxi_propagator; unitarity_propagator; tensor_propagator; tensor_propagator_51_52 ] let conjugate_propagators = List.map (fun p -> transpose (parse_propagator p)) [ conjspinor_propagator ] let all_propagators = propagators @ conjugate_propagators let _ = generate_ufo - ~reps:1000 ~threshold:0.70 "fusions_UFO" vertices all_propagators; + ~reps:1000 ~threshold:0.70 ~program:"keystones_UFO" + "fusions_UFO" vertices all_propagators; exit 0 Index: trunk/omega/tests/comparisons_majorana.list =================================================================== --- trunk/omega/tests/comparisons_majorana.list (revision 8491) +++ trunk/omega/tests/comparisons_majorana.list (revision 8492) @@ -1,23 +1,61 @@ # comparisons_majorana.list -- ######################################################################## -# NB: the *overall* sign of an apmplitude may change depending on whether +# NB: the *overall* sign of an amplitude may change depending on whether # we compute with Fusion.Mixed23 or Fusion.Mixed23_Majorana ######################################################################## # ---------------------------------------------------------------------- # thr abs_thr n roots model sign process ... # ---------------------------------------------------------------------- +pe_z 0.90 1E-11 100 1000 SM .true. scatter e+ e- -> Z +ep_z 0.90 1E-11 100 1000 SM .false. scatter e- e+ -> Z +ze_e 0.90 1E-11 100 1000 SM .false. scatter Z e- -> e- +ez_e 0.90 1E-11 100 1000 SM .false. scatter e- Z -> e- +zp_p 0.90 1E-11 100 1000 SM .true. scatter Z e+ -> e+ +pz_p 0.90 1E-11 100 1000 SM .true. scatter e+ Z -> e+ +z_pe 0.90 1E-11 100 1000 SM .false. decay Z -> e+ e- +z_ep 0.90 1E-11 100 1000 SM .true. decay Z -> e- e+ +e_ze 0.90 1E-11 100 1000 SM .false. decay e- -> Z e- +e_ez 0.90 1E-11 100 1000 SM .false. decay e- -> e- Z +p_zp 0.90 1E-11 100 1000 SM .true. decay e+ -> Z e+ +p_pz 0.90 1E-11 100 1000 SM .true. decay e+ -> e+ Z eeee 0.90 1E-11 100 1000 SM .true. scatter e- e- -> e- e- -eeeea 0.90 1E-11 100 1000 SM .true. scatter e- e- -> e- e- A -eeeeaa 0.90 1E-11 100 1000 SM .true. scatter e- e- -> e- e- A A -eeeeep 0.80 1E-11 100 1000 SM .true. scatter e- e- -> e- e- e+ e- -aaep 0.90 1E-11 100 1000 SM .false. scatter A A -> e+ e- -aaepep 0.75 1E-11 100 1000 SM .false. scatter A A -> e+ e- e+ e- +eeeea 0.90 1E-11 10 1000 SM .true. scatter e- e- -> e- e- A +eeeeaa 0.90 1E-11 10 1000 SM .true. scatter e- e- -> e- e- A A +eeeeep 0.80 1E-11 10 1000 SM .true. scatter e- e- -> e- e- e+ e- +epep 0.90 1E-11 100 1000 SM .true. scatter e+ e- -> e+ e- +epepa 0.75 1E-11 10 1000 SM .true. scatter e+ e- -> e+ e- A +epepaa 0.80 1E-11 10 1000 SM .true. scatter e+ e- -> e+ e- A A +epepep 0.80 1E-11 10 1000 SM .true. scatter e+ e- -> e+ e- e+ e- +epepepa 0.70 1E-11 10 1000 SM .true. scatter e+ e- -> e+ e- e+ e- A +epepepaa 0.70 1E-11 10 1000 SM .true. scatter e+ e- -> e+ e- e+ e- A A +epepepep 0.70 1E-11 10 1000 SM .true. scatter e+ e- -> e+ e- e+ e- e+ e- +aaep 0.90 1E-11 100 1000 SM .true. scatter A A -> e- e+ +aape 0.90 1E-11 100 1000 SM .false. scatter A A -> e+ e- eaea 0.90 1E-11 100 1000 SM .false. scatter e- A -> e- A epaa 0.90 1E-11 100 1000 SM .true. scatter e+ e- -> A A -epep 0.90 1E-11 100 1000 SM .true. scatter e+ e- -> e+ e- -epepa 0.75 1E-11 100 1000 SM .true. scatter e+ e- -> e+ e- A -epepaa 0.80 1E-11 100 1000 SM .true. scatter e+ e- -> e+ e- A A -epepep 0.80 1E-11 100 1000 SM .true. scatter e+ e- -> e+ e- e+ e- -epepepa 0.70 1E-11 100 1000 SM .true. scatter e+ e- -> e+ e- e+ e- A -epepepaa 0.70 1E-11 100 1000 SM .true. scatter e+ e- -> e+ e- e+ e- A A -epepepep 0.70 1E-11 100 1000 SM .true. scatter e+ e- -> e+ e- e+ e- e+ e- +aaepep 0.75 1E-11 10 1000 SM .false. scatter A A -> e+ e- e+ e- +epvv 0.90 1E-11 100 1000 SM .true. scatter e+ e- -> nuebar nue +epvva 0.90 1E-11 10 1000 SM .true. scatter e+ e- -> nuebar nue A +vvep 0.90 1E-11 100 1000 SM .true. scatter nuebar nue -> e+ e- +vvepa 0.40 1E-11 10 1000 SM .true. scatter nuebar nue -> e+ e- A +wwep 0.70 1E-11 100 1000 SM .false. scatter W+ W- -> e+ e- +ewew 0.70 1E-11 100 1000 SM .false. scatter e- W+ -> e- W+ +pwpw 0.70 1E-11 100 1000 SM .true. scatter e+ W+ -> e+ W+ +epww 0.90 1E-11 100 1000 SM .true. scatter e+ e- -> W+ W- +wwvv 0.70 1E-11 100 1000 SM .false. scatter W+ W- -> nuebar nue +wwvv_ 0.70 1E-11 100 1000 SM .true. scatter W+ W- -> nue nuebar +zzep 0.90 1E-11 100 1000 SM .false. scatter Z Z -> e+ e- +ezez 0.90 1E-11 100 1000 SM .false. scatter e- Z -> e- Z +epzz 0.90 1E-11 100 1000 SM .true. scatter e+ e- -> Z Z +zzvv 0.90 1E-11 100 1000 SM .false. scatter Z Z -> nuebar nue +vvzz 0.90 1E-11 100 1000 SM .true. scatter nuebar nue -> Z Z +azep 0.90 1E-11 100 1000 SM .false. scatter A Z -> e+ e- +zaep 0.90 1E-11 100 1000 SM .false. scatter Z A -> e+ e- +ezea 0.90 1E-11 100 1000 SM .false. scatter e- Z -> e- A +eaez 0.90 1E-11 100 1000 SM .false. scatter e- A -> e- Z +epaz 0.90 1E-11 100 1000 SM .true. scatter e+ e- -> A Z +epza 0.90 1E-11 100 1000 SM .true. scatter e+ e- -> Z A +epwwz 0.90 1E-11 10 1000 SM .true. scatter e+ e- -> W+ W- Z +epwwww 0.90 1E-11 10 1000 SM .true. scatter e+ e- -> W+ W- W+ W- +epwwzz 0.90 1E-11 10 1000 SM .true. scatter e+ e- -> W+ W- Z Z +cc10 0.90 1E-11 10 1000 SM .true. scatter e+ e- -> mu- numubar u dbar Index: trunk/omega/tests/comparisons_majorana_UFO.list =================================================================== --- trunk/omega/tests/comparisons_majorana_UFO.list (revision 8491) +++ trunk/omega/tests/comparisons_majorana_UFO.list (revision 8492) @@ -1,26 +1,61 @@ # comparisons_majorana_UFO.list -- ######################################################################## -# NB: the *overall* sign of an apmplitude may change depending on whether +# NB: the *overall* sign of an amplitude may change depending on whether # we compute with Fusion.Mixed23 or Fusion.Mixed23_Majorana ######################################################################## -# -# --------------------------------------------------------------------- -# thr abs_thr n roots model sign process ... -# --------------------------------------------------------------------- -eeee 0.90 1E-11 100 1000 SM .true. scatter e- e- -> e- e- -#eeea 0.40 1E-11 100 1000 SM .true. scatter e- e- -> e- e- a -#eeeaa 0.90 1E-11 100 1000 SM .false. scatter e- e- -> e- e- a a -#eeeep 0.80 1E-11 100 1000 SM .true. scatter e- e- -> e- e- e+ e- -#eeeeep 0.80 1E-11 100 1000 SM .false. scatter e- e- -> e- e- e+ e- -aaep 0.90 1E-11 100 1000 SM .false. scatter a a -> e+ e- -#aepep 0.90 1E-11 100 1000 SM .true. scatter a a -> e+ e- e+ e- -eaea 0.90 1E-11 100 1000 SM .false. scatter e- a -> e- a -epaa 0.90 1E-11 100 1000 SM .true. scatter e+ e- -> a a -epep 0.65 1E-11 100 1000 SM .false. scatter e+ e- -> e+ e- -#pepa 0.90 1E-11 100 1000 SM .false. scatter e+ e- -> e+ e- a -#pepaa 0.90 1E-11 100 1000 SM .false. scatter e+ e- -> e+ e- a a -#pepep 0.80 1E-11 100 1000 SM .false. scatter e+ e- -> e+ e- e+ e- -epvv 0.90 1E-11 100 1000 SM .false. scatter e+ e- -> ve~ ve -epvva 0.90 1E-11 100 1000 SM .false. scatter e+ e- -> ve~ ve a -vvep 0.90 1E-11 100 1000 SM .false. scatter ve~ ve -> e+ e- -#vepa 0.40 1E-11 100 1000 SM .false. scatter ve~ ve -> e+ e- a +# ---------------------------------------------------------------------- +# thr abs_thr n roots model sign process ... +# ---------------------------------------------------------------------- +pe_z 0.90 1E-11 100 1000 SM .true. scatter e+ e- -> Z +ep_z 0.90 1E-11 100 1000 SM .false. scatter e- e+ -> Z +ze_e 0.90 1E-11 100 1000 SM .false. scatter Z e- -> e- +ez_e 0.90 1E-11 100 1000 SM .false. scatter e- Z -> e- +zp_p 0.90 1E-11 100 1000 SM .true. scatter Z e+ -> e+ +pz_p 0.90 1E-11 100 1000 SM .true. scatter e+ Z -> e+ +z_pe 0.90 1E-11 100 1000 SM .false. decay Z -> e+ e- +z_ep 0.90 1E-11 100 1000 SM .true. decay Z -> e- e+ +e_ze 0.90 1E-11 100 1000 SM .false. decay e- -> Z e- +e_ez 0.90 1E-11 100 1000 SM .false. decay e- -> e- Z +p_zp 0.90 1E-11 100 1000 SM .true. decay e+ -> Z e+ +p_pz 0.90 1E-11 100 1000 SM .true. decay e+ -> e+ Z +eeee 0.90 1E-11 100 1000 SM .true. scatter e- e- -> e- e- +eeeea 0.80 1E-11 10 1000 SM .true. scatter e- e- -> e- e- a +eeeeaa 0.80 1E-11 10 1000 SM .true. scatter e- e- -> e- e- a a +eeeeep 0.80 1E-11 10 1000 SM .true. scatter e- e- -> e- e- e+ e- +epep 0.65 1E-11 100 1000 SM .true. scatter e+ e- -> e+ e- +epepa 0.80 1E-11 10 1000 SM .true. scatter e+ e- -> e+ e- a +epepaa 0.75 1E-11 10 1000 SM .true. scatter e+ e- -> e+ e- a a +epepep 0.80 1E-11 10 1000 SM .true. scatter e+ e- -> e+ e- e+ e- +epepepa 0.70 1E-11 10 1000 SM .true. scatter e+ e- -> e+ e- e+ e- a +epepepaa 0.70 1E-11 10 1000 SM .true. scatter e+ e- -> e+ e- e+ e- a a +epepepep 0.70 1E-11 10 1000 SM .true. scatter e+ e- -> e+ e- e+ e- e+ e- +aaep 0.90 1E-11 100 1000 SM .true. scatter a a -> e- e+ +aape 0.90 1E-11 100 1000 SM .false. scatter a a -> e+ e- +eaea 0.90 1E-11 100 1000 SM .false. scatter e- a -> e- a +epaa 0.90 1E-11 100 1000 SM .true. scatter e+ e- -> a a +aaepep 0.75 1E-11 10 1000 SM .false. scatter a a -> e+ e- e+ e- +epvv 0.90 1E-11 100 1000 SM .true. scatter e+ e- -> ve~ ve +epvva 0.90 1E-11 10 1000 SM .true. scatter e+ e- -> ve~ ve a +vvep 0.90 1E-11 100 1000 SM .true. scatter ve~ ve -> e+ e- +vvepa 0.40 1E-11 10 1000 SM .true. scatter ve~ ve -> e+ e- a +wwep 0.70 1E-11 100 1000 SM .false. scatter W+ W- -> e+ e- +ewew 0.70 1E-11 100 1000 SM .false. scatter e- W+ -> e- W+ +pwpw 0.70 1E-11 100 1000 SM .true. scatter e+ W+ -> e+ W+ +epww 0.90 1E-11 100 1000 SM .true. scatter e+ e- -> W+ W- +wwvv 0.70 1E-11 100 1000 SM .false. scatter W+ W- -> ve~ ve +wwvv_ 0.70 1E-11 100 1000 SM .true. scatter W+ W- -> ve ve~ +zzep 0.90 1E-11 100 1000 SM .false. scatter Z Z -> e+ e- +ezez 0.90 1E-11 100 1000 SM .false. scatter e- Z -> e- Z +epzz 0.90 1E-11 100 1000 SM .true. scatter e+ e- -> Z Z +zzvv 0.90 1E-11 100 1000 SM .false. scatter Z Z -> ve~ ve +vvzz 0.90 1E-11 100 1000 SM .true. scatter ve~ ve -> Z Z +azep 0.90 1E-11 100 1000 SM .false. scatter a Z -> e+ e- +zaep 0.90 1E-11 100 1000 SM .false. scatter Z a -> e+ e- +ezea 0.90 1E-11 100 1000 SM .false. scatter e- Z -> e- a +eaez 0.90 1E-11 100 1000 SM .false. scatter e- a -> e- Z +epaz 0.90 1E-11 100 1000 SM .true. scatter e+ e- -> a Z +epza 0.90 1E-11 100 1000 SM .true. scatter e+ e- -> Z a +epwwz 0.70 1E-11 10 1000 SM .true. scatter e+ e- -> W+ W- Z +epwwww 0.70 1E-11 10 1000 SM .true. scatter e+ e- -> W+ W- W+ W- +epwwzz 0.70 1E-11 10 1000 SM .true. scatter e+ e- -> W+ W- Z Z +cc10 0.90 1E-11 10 1000 SM .true. scatter e+ e- -> mu- vm~ u d~ Index: trunk/omega/tests/omega_unit.ml =================================================================== --- trunk/omega/tests/omega_unit.ml (revision 8491) +++ trunk/omega/tests/omega_unit.ml (revision 8492) @@ -1,211 +1,213 @@ (* omega_unit.ml -- Copyright (C) 1999-2021 by Wolfgang Kilian Thorsten Ohl Juergen Reuter Christian Speckner WHIZARD 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 2, or (at your option) any later version. WHIZARD 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, write to the Free Software Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. *) open OUnit let unattended = ref true let skip_if_unattended () = skip_if !unattended "not suitable for unattended tests" let trivial_test = "trivial" >:: (bracket (fun () -> true) (fun b -> assert_bool "always true" b) (fun b -> ())) let short_random_list n = let l = ref [] in for i = 1 to n do l := Random.int 1024 :: !l done; !l let allowed_recursion_depth () = let rec allowed_recursion_depth' n = try allowed_recursion_depth' (succ n) with | Stack_overflow -> n in allowed_recursion_depth' 0 let long_random_list factor = let n = factor * allowed_recursion_depth () in let l = ref [] in for i = 1 to n do l := Random.int n :: !l done; !l module Integer = struct type t = int let compare = compare let pp_printer = Format.pp_print_int let pp_print_sep = OUnitDiff.pp_comma_separator end module Integer_List = OUnitDiff.ListSimpleMake(Integer) module ThoList_Unit_Tests = struct let inner_list = ThoList.range 1 5 let outer_list = List.map (( * ) 10) (ThoList.range 1 4) let f n = List.map ((+) n) inner_list let flatmap = "flatmap" >:: (fun () -> let result = ThoList.flatmap f outer_list and expected = List.flatten (List.map f outer_list) in assert_equal expected result) let rev_flatmap = "rev_flatmap" >:: (fun () -> let result = ThoList.rev_flatmap f outer_list and expected = List.rev (ThoList.flatmap f outer_list) in Integer_List.assert_equal expected result) let flatmap_stack_overflow = "flatmap_stack_overflow" >:: (fun () -> skip_if !unattended "memory limits not suitable for unattended tests"; let l = long_random_list 2 in let f n = List.map ((+) n) (short_random_list 2) in assert_raises Stack_overflow (fun () -> ThoList.flatmap f l)) let rev_flatmap_no_stack_overflow = "rev_flatmap_no_stack_overflow" >:: (fun () -> skip_if !unattended "memory limits not suitable for unattended tests"; let l = long_random_list 10 in let f n = List.map ((+) n) (short_random_list 10) in ignore (ThoList.rev_flatmap f l); assert_bool "always true" true) let suite = "ThoList" >::: [flatmap; flatmap_stack_overflow; rev_flatmap; rev_flatmap_no_stack_overflow ] end module IListSet = Set.Make (struct type t = int list let compare = compare end) let list_elements_unique l = let rec list_elements_unique' set = function | [] -> true | x :: rest -> if IListSet.mem x set then false else list_elements_unique' (IListSet.add x set) rest in list_elements_unique' IListSet.empty l let ilistset_test = "IListSet" >:: (fun () -> assert_bool "true" (list_elements_unique [[1];[2]]); assert_bool "false" (not (list_elements_unique [[1];[1]]))) module Combinatorics_Unit_Tests = struct let permute = "permute" >:: (fun () -> let n = 8 in let l = ThoList.range 1 n in let result = Combinatorics.permute l in assert_equal (Combinatorics.factorial n) (List.length result); assert_bool "unique" (list_elements_unique result)) let permute_no_stack_overflow = "permute_no_stack_overflow" >:: (fun () -> skip_if !unattended "memory limits not suitable for unattended tests"; let n = 10 in (* n = 10 needs 1 GB, n = 11 needs 7.3 GB *) let l = ThoList.range 1 n in let result = Combinatorics.permute l in assert_equal (Combinatorics.factorial n) (List.length result)) let suite = "Combinatorics" >::: [permute; permute_no_stack_overflow] end let selftest_suite = "testsuite" >::: [trivial_test; ilistset_test] module Permutation_Test_Using_Lists = Permutation.Test(Permutation.Using_Lists) module Permutation_Test_Using_Arrays = Permutation.Test(Permutation.Using_Arrays) let suite = "omega" >::: [selftest_suite; ThoList_Unit_Tests.suite; ThoList.Test.suite; ThoArray.Test.suite; ThoString.Test.suite; Partial.Test.suite; Permutation_Test_Using_Lists.suite; Permutation_Test_Using_Arrays.suite; Combinatorics_Unit_Tests.suite; Combinatorics.Test.suite; Algebra.Q.Test.suite; Algebra.QC.Test.suite; Algebra.Laurent.Test.suite; Color.Flow.Test.suite; Color.Arrow.Test.suite; Color.Birdtracks.Test.suite; Color.SU3.Test.suite; Color.U3.Test.suite; UFO_targets.Fortran.Test.suite; UFO_Lorentz.Test.suite; UFO.Test.suite; Format_Fortran.Test.suite; - Dirac.Chiral.test_suite] + Dirac.Chiral.test_suite; + Dirac.Dirac.test_suite; + Dirac.Majorana.test_suite] let _ = ignore (run_test_tt_main ~arg_specs:[("-attended", Arg.Clear unattended, " run tests that depend on the environment"); ("-unattended", Arg.Set unattended, " don't run tests depend on the environment")] suite); exit 0 Index: trunk/omega/tests/Makefile.am =================================================================== --- trunk/omega/tests/Makefile.am (revision 8491) +++ trunk/omega/tests/Makefile.am (revision 8492) @@ -1,1023 +1,1063 @@ # Makefile.am -- Makefile for O'Mega within and without WHIZARD ## ## Process this file with automake to produce Makefile.in ## ######################################################################## # # Copyright (C) 1999-2021 by # Wolfgang Kilian # Thorsten Ohl # Juergen Reuter # with contributions from # cf. main AUTHORS file # # WHIZARD 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 2, or (at your option) # any later version. # # WHIZARD 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, write to the Free Software # Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. # ######################################################################## SUBDIRS = UFO DIST_SUBDIRS = UFO # OMEGA_SPLIT = -target:single_function OMEGA_SPLIT = -target:split_function 10 # OMEGA_SPLIT = -target:split_module 10 # OMEGA_SPLIT = -target:split_file 10 OMEGA_QED = $(top_builddir)/omega/bin/omega_QED$(OCAML_NATIVE_EXT) OMEGA_QED_OPTS = $(OMEGA_SPLIT) -target:parameter_module parameters_QED OMEGA_QCD = $(top_builddir)/omega/bin/omega_QCD$(OCAML_NATIVE_EXT) OMEGA_QCD_OPTS = $(OMEGA_SPLIT) -target:parameter_module parameters_QCD OMEGA_SYM = $(top_builddir)/omega/bin/omega_SYM$(OCAML_NATIVE_EXT) OMEGA_SYM_OPTS = $(OMEGA_SPLIT) -target:parameter_module parameters_SYM OMEGA_SM = $(top_builddir)/omega/bin/omega_SM$(OCAML_NATIVE_EXT) OMEGA_SM_OPTS = $(OMEGA_SPLIT) -target:parameter_module parameters_SM OMEGA_SM_CKM = $(top_builddir)/omega/bin/omega_SM_CKM$(OCAML_NATIVE_EXT) OMEGA_SM_Higgs = $(top_builddir)/omega/bin/omega_SM_Higgs$(OCAML_NATIVE_EXT) OMEGA_THDM = $(top_builddir)/omega/bin/omega_THDM$(OCAML_NATIVE_EXT) OMEGA_THDM_CKM = $(top_builddir)/omega/bin/omega_THDM_CKM$(OCAML_NATIVE_EXT) OMEGA_HSExt = $(top_builddir)/omega/bin/omega_HSExt$(OCAML_NATIVE_EXT) OMEGA_Zprime = $(top_builddir)/omega/bin/omega_Zprime$(OCAML_NATIVE_EXT) OMEGA_SM_top_anom = $(top_builddir)/omega/bin/omega_SM_top_anom$(OCAML_NATIVE_EXT) OMEGA_SM_top_anom_OPTS = $(OMEGA_SPLIT) -target:parameter_module parameters_SM_top_anom OMEGA_UFO = $(top_builddir)/omega/bin/omega_UFO$(OCAML_NATIVE_EXT) OMEGA_UFO_MAJORANA = \ $(top_builddir)/omega/bin/omega_UFO_Majorana$(OCAML_NATIVE_EXT) OMEGA_UFO_OPTS = -target:parameter_module parameters_UFO OMEGA_UFO_PATH = $(top_srcdir)/omega/tests/UFO OMEGA_XXX = $(top_builddir)/omega/bin/omega_%%%$(OCAML_NATIVE_EXT) OMEGA_XXX_OPTS = -target:parameter_module parameters_%%% OMEGA_UFO_XXX_OPTS = \ "-model:UFO_dir $(top_srcdir)/omega/tests/UFO/%%%/ -model:exec" OMEGA_XXX_MAJORANA = \ $(top_builddir)/omega/bin/omega_%%%_Majorana$(OCAML_NATIVE_EXT) OMEGA_XXX_MAJORANA_LEGACY = \ $(top_builddir)/omega/bin/omega_%%%_Majorana_legacy$(OCAML_NATIVE_EXT) OMEGA_QED_VM = $(top_builddir)/omega/bin/omega_QED_VM$(OCAML_NATIVE_EXT) OMEGA_QCD_VM = $(top_builddir)/omega/bin/omega_QCD_VM$(OCAML_NATIVE_EXT) OMEGA_SM_VM = $(top_builddir)/omega/bin/omega_SM_VM$(OCAML_NATIVE_EXT) OMEGA_SM_CKM_VM = $(top_builddir)/omega/bin/omega_SM_CKM_VM$(OCAML_NATIVE_EXT) OMEGA_THDM_VM = $(top_builddir)/omega/bin/omega_THDM_VM$(OCAML_NATIVE_EXT) OMEGA_THDM_CKM_VM = $(top_builddir)/omega/bin/omega_THDM_CKM_VM$(OCAML_NATIVE_EXT) OMEGA_HSExt_VM = $(top_builddir)/omega/bin/omega_HSExt_VM$(OCAML_NATIVE_EXT) OMEGA_Zprime_VM = $(top_builddir)/omega/bin/omega_Zprime_VM$(OCAML_NATIVE_EXT) OMEGA_SM_Higgs_VM = $(top_builddir)/omega/bin/omega_SM_Higgs_VM$(OCAML_NATIVE_EXT) OMEGA_XXX_VM = $(top_builddir)/omega/bin/omega_%%%_VM$(OCAML_NATIVE_EXT) OMEGA_XXX_VM_PARAMS_OPTS = -params -target:parameter_module_external \ parameters_%%% -target:wrapper_module %% -target:bytecode_file % AM_FCFLAGS = -I$(top_builddir)/omega/src AM_LDFLAGS = ######################################################################## ## Default Fortran compiler options ## OpenMP if FC_USE_OPENMP AM_FCFLAGS += $(FCFLAGS_OPENMP) AM_TESTS_ENVIRONMENT = \ export OMP_NUM_THREADS=1; endif ######################################################################## TESTS = XFAIL_TESTS = EXTRA_PROGRAMS = EXTRA_DIST = ######################################################################## include $(top_srcdir)/omega/src/Makefile.ocaml if OCAML_AVAILABLE OCAMLFLAGS += -I $(top_builddir)/omega/src OMEGA_CORE = $(top_builddir)/omega/src/omega_core.cmxa OMEGA_MODELS = $(top_builddir)/omega/src/omega_models.cmxa TESTS += omega_unit EXTRA_PROGRAMS += omega_unit omega_unit_SOURCES = omega_unit.ml omega_unit: $(OMEGA_CORE) omega_unit.cmx @if $(AM_V_P); then :; else echo " OCAMLOPT " $@; fi $(AM_V_at)$(OCAMLOPT) $(OCAMLFLAGS) $(OCAMLOPTFLAGS) -o omega_unit \ unix.cmxa $(OMEGA_CORE) omega_unit.cmx omega_unit.cmx: omega_unit.ml omega_unit.cmx: $(OMEGA_CORE) endif ######################################################################## KINDS = $(top_builddir)/omega/src/kinds.lo TESTS += test_omega95 test_omega95_bispinors EXTRA_PROGRAMS += test_omega95 test_omega95_bispinors test_omega95_SOURCES = test_omega95.f90 omega_testtools.f90 test_omega95_LDADD = $(KINDS) $(top_builddir)/omega/src/libomega_core.la test_omega95_bispinors_SOURCES = test_omega95_bispinors.f90 omega_testtools.f90 test_omega95_bispinors_LDADD = $(KINDS) $(top_builddir)/omega/src/libomega_core.la test_omega95.o test_omega95_bispinors.o: omega_testtools.o if NOWEB_AVAILABLE test_omega95.f90: $(top_srcdir)/omega/src/omegalib.nw $(NOTANGLE) -R[[$@]] $< | $(CPIF) $@ test_omega95_bispinors.f90: $(top_srcdir)/omega/src/omegalib.nw $(NOTANGLE) -R[[$@]] $< | $(CPIF) $@ omega_testtools.f90: $(top_srcdir)/omega/src/omegalib.nw $(NOTANGLE) -R[[$@]] $< | $(CPIF) $@ endif NOWEB_AVAILABLE ######################################################################## if OCAML_AVAILABLE TESTS += test_qed_eemm EXTRA_PROGRAMS += test_qed_eemm test_qed_eemm_SOURCES = test_qed_eemm.f90 parameters_QED.f90 nodist_test_qed_eemm_SOURCES = amplitude_qed_eemm.f90 test_qed_eemm_LDADD = $(KINDS) $(top_builddir)/omega/src/libomega_core.la amplitude_qed_eemm.f90: $(OMEGA_QED) Makefile $(OMEGA_QED) $(OMEGA_QED_OPTS) -target:module amplitude_qed_eemm \ -scatter "e+ e- -> m+ m-" > $@ test_qed_eemm.o: amplitude_qed_eemm.o test_qed_eemm.o: parameters_QED.o amplitude_qed_eemm.o: parameters_QED.o endif ######################################################################## EXTENDED_COLOR_TESTS = \ $(srcdir)/fc_s.ects \ $(srcdir)/fc_a.ects $(srcdir)/cf_a.ects $(srcdir)/fa_f.ects \ $(srcdir)/ca_c.ects $(srcdir)/af_f.ects $(srcdir)/ac_c.ects \ $(srcdir)/aa_a.ects \ $(srcdir)/fc_fc.ects \ $(srcdir)/aa_s.ects $(srcdir)/as_a.ects $(srcdir)/sa_a.ects TESTS += ects EXTRA_PROGRAMS += ects EXTRA_DIST += ects_driver.sh $(EXTENDED_COLOR_TESTS) # Explicitly state dependence on model files ects.f90: $(OMEGA_QCD) $(OMEGA_SYM) $(OMEGA_SM) ects.f90: ects_driver.sh $(EXTENDED_COLOR_TESTS) @if $(AM_V_P); then :; else echo " ECTS_DRIVER"; fi $(AM_V_at)$(SHELL) $(srcdir)/ects_driver.sh \ $(OMEGA_XXX) $(EXTENDED_COLOR_TESTS) > $@ ects_SOURCES = color_test_lib.f90 \ parameters_SM.f90 parameters_QED.f90 parameters_QCD.f90 parameters_SYM.f90 nodist_ects_SOURCES = ects.f90 ects_LDADD = $(KINDS) $(top_builddir)/omega/src/libomega_core.la ######################################################################## TESTS += cascade # if there is some debugging output ... # XFAIL_TESTS += cascade CASCADE_TESTS = \ bhabha-s-channel.cascade bhabha-t-channel.cascade bhabha-full.cascade \ ww-onlycc.cascade ww-notgc.cascade \ jjj-notgc.cascade \ vbf-noh.cascade cascade: cascade_driver.sh Makefile $(SED) -e 's|%%cascade_tests%%|$(CASCADE_TESTS)|' \ -e 's|%%srcdir%%|$(srcdir)|' \ -e 's|%%SED%%|$(SED)|' \ -e 's|%%top_builddir%%|$(top_builddir)|' \ -e 's|%%OCAML_NATIVE_EXT%%|$(OCAML_NATIVE_EXT)|' $< >$@ chmod +x $@ EXTRA_DIST += cascade_driver.sh $(CASCADE_TESTS) ######################################################################## TESTS += phase_space PHASE_SPACE_TESTS = eeee.phs qqggg.phs phase_space: phase_space_driver.sh Makefile $(SED) -e 's|%%phase_space_tests%%|$(PHASE_SPACE_TESTS)|' \ -e 's|%%srcdir%%|$(srcdir)|' \ -e 's|%%SED%%|$(SED)|' \ -e 's|%%top_builddir%%|$(top_builddir)|' \ -e 's|%%OCAML_NATIVE_EXT%%|$(OCAML_NATIVE_EXT)|' $< >$@ chmod +x $@ EXTRA_DIST += phase_space_driver.sh $(PHASE_SPACE_TESTS) ######################################################################## TESTS += fermi # XFAIL_TESTS += fermi EXTRA_PROGRAMS += fermi EXTRA_DIST += fermi_driver.sh EXTRA_DIST += fermi.list FERMI_SUPPORT_F90 = \ omega_interface.f90 omega_testtools.f90 tao_random_numbers.f90 \ parameters_QED.f90 parameters_QCD.f90 parameters_SYM.f90 \ parameters_SM.f90 parameters_MSSM.f90 parameters_SM_top_anom.f90 FERMI_SUPPORT_O = $(FERMI_SUPPORT_F90:.f90=.o) fermi_lib.o: $(FERMI_SUPPORT_O) FERMI_LIB_F90 = fermi_lib.f90 $(FERMI_SUPPORT_F90) FERMI_LIB_O = $(FERMI_LIB_F90:.f90=.o) run_fermi: fermi ./fermi fermi.f90: fermi_driver.sh $(OMEGA_QED) $(OMEGA_QCD) $(OMEGA_SYM) fermi.f90: $(OMEGA_SM) $(OMEGA_SM_top_anom) fermi.f90: fermi.list @if $(AM_V_P); then :; else echo " FERMI_DRIVER"; fi $(AM_V_at)$(SHELL) $(srcdir)/fermi_driver.sh \ $(OMEGA_XXX) $(OMEGA_SPLIT) < $< > $@ fermi_SOURCES = $(FERMI_LIB_F90) nodist_fermi_SOURCES = fermi.f90 fermi_LDADD = $(KINDS) $(top_builddir)/omega/src/libomega_core.la fermi.o: $(FERMI_LIB_O) ######################################################################## TESTS += ward EXTRA_PROGRAMS += ward EXTRA_DIST += ward_driver.sh EXTRA_DIST += ward_identities.list WARD_SUPPORT_F90 = \ omega_interface.f90 omega_testtools.f90 tao_random_numbers.f90 \ parameters_QED.f90 parameters_QCD.f90 parameters_SYM.f90 \ parameters_SM.f90 parameters_SM_top_anom.f90 WARD_SUPPORT_O = $(WARD_SUPPORT_F90:.f90=.o) ward_lib.o: $(WARD_SUPPORT_O) WARD_LIB_F90 = ward_lib.f90 $(WARD_SUPPORT_F90) WARD_LIB_O = $(WARD_LIB_F90:.f90=.o) run_ward: ward ./ward ward.f90: ward_driver.sh $(OMEGA_QED) $(OMEGA_QCD) $(OMEGA_SYM) ward.f90: $(OMEGA_SM) $(OMEGA_SM_top_anom) ward.f90: ward_identities.list @if $(AM_V_P); then :; else echo " WARD_DRIVER"; fi $(AM_V_at)$(SHELL) $(srcdir)/ward_driver.sh \ $(OMEGA_XXX) $(OMEGA_SPLIT) < $< > $@ ward_SOURCES = $(WARD_LIB_F90) nodist_ward_SOURCES = ward.f90 ward_LDADD = $(KINDS) $(top_builddir)/omega/src/libomega_core.la ward.o: $(WARD_LIB_O) ######################################################################## EXTRA_PROGRAMS += ward_long EXTRA_DIST += ward_identities_long.list run_ward_long: ward_long ./ward_long ward_long.f90: ward_driver.sh ward_long.f90: ward_identities_long.list @if $(AM_V_P); then :; else echo " WARD_DRIVER"; fi $(AM_V_at)$(SHELL) $(srcdir)/ward_driver.sh \ $(OMEGA_XXX) $(OMEGA_SPLIT) < $< > $@ ward_long_SOURCES = $(WARD_LIB_F90) nodist_ward_long_SOURCES = ward_long.f90 ward_long_LDADD = $(KINDS) $(top_builddir)/omega/src/libomega_core.la # ward_long.o: ward_long.f90 # $(FCCOMPILE) -c -o $@ $(FCFLAGS_f90) -O0 $< ward_long.o: $(WARD_LIB_O) ######################################################################## EXTRA_PROGRAMS += ward_fail EXTRA_DIST += ward_identities_fail.list run_ward_fail: ward_fail ./ward_fail ward_fail.f90: ward_driver.sh ward_fail.f90: ward_identities_fail.list @if $(AM_V_P); then :; else echo " WARD_DRIVER"; fi $(AM_V_at)$(SHELL) $(srcdir)/ward_driver.sh \ $(OMEGA_XXX) $(OMEGA_SPLIT) < $< > $@ ward_fail_SOURCES = $(WARD_LIB_F90) nodist_ward_fail_SOURCES = ward_fail.f90 ward_fail_LDADD = $(KINDS) $(top_builddir)/omega/src/libomega_core.la ward_fail.o: ward_fail.f90 $(FCCOMPILE) -c -o $@ $(FCFLAGS_f90) -O0 $< ward_fail.o: $(WARD_LIB_O) ######################################################################## TESTS += compare_split_function compare_split_module EXTRA_PROGRAMS += compare_split_function compare_split_module EXTRA_DIST += compare_driver.sh EXTRA_DIST += comparisons.list COMPARE_SUPPORT_F90 = $(WARD_SUPPORT_F90) COMPARE_SUPPORT_O = $(WARD_SUPPORT_O) compare_lib.o: $(COMPARE_SUPPORT_O) COMPARE_LIB_F90 = compare_lib.f90 $(COMPARE_SUPPORT_F90) COMPARE_LIB_O = $(COMPARE_LIB_F90:.f90=.o) run_compare: compare_split_function compare_split_module ./compare_split_function ./compare_split_module compare_split_function.f90: comparisons.list @if $(AM_V_P); then :; else echo " COMPARE_DRIVER"; fi $(AM_V_at)$(SHELL) $(srcdir)/compare_driver.sh SF \ "$(OMEGA_XXX) -target:single_function" \ "$(OMEGA_XXX) -target:split_function 10" < $< > $@ compare_split_module.f90: comparisons.list @if $(AM_V_P); then :; else echo " COMPARE_DRIVER"; fi $(AM_V_at)$(SHELL) $(srcdir)/compare_driver.sh SM \ "$(OMEGA_XXX) -target:single_function" \ "$(OMEGA_XXX) -target:split_module 10" < $< > $@ compare_split_function.f90 compare_split_module.f90: \ compare_driver.sh $(OMEGA_QCD) $(OMEGA_SM) compare_split_function_SOURCES = $(COMPARE_LIB_F90) nodist_compare_split_function_SOURCES = compare_split_function.f90 compare_split_function_LDADD = $(KINDS) $(top_builddir)/omega/src/libomega_core.la compare_split_module_SOURCES = $(COMPARE_LIB_F90) nodist_compare_split_module_SOURCES = compare_split_module.f90 compare_split_module_LDADD = $(KINDS) $(top_builddir)/omega/src/libomega_core.la compare_split_function.o compare_split_module.o: $(COMPARE_LIB_O) ######################################################################## if OCAML_AVAILABLE TESTS += compare_majorana compare_majorana_legacy compare_majorana_UFO +# XFAIL_TESTS += compare_majorana_UFO EXTRA_PROGRAMS += compare_majorana compare_majorana_legacy compare_majorana_UFO EXTRA_DIST += compare_driver_majorana.sh compare_driver_majorana_UFO.sh EXTRA_DIST += comparisons_majorana.list comparisons_majorana_legacy.list \ comparisons_majorana_UFO.list compare_majorana.f90: comparisons_majorana.list @if $(AM_V_P); then :; else echo " COMPARE_DRIVER"; fi $(AM_V_at)$(SHELL) $(srcdir)/compare_driver_majorana.sh Maj \ "$(OMEGA_XXX)" "$(OMEGA_XXX_MAJORANA)" < $< > $@ compare_majorana_legacy.f90: comparisons_majorana_legacy.list @if $(AM_V_P); then :; else echo " COMPARE_DRIVER"; fi $(AM_V_at)$(SHELL) $(srcdir)/compare_driver_majorana.sh MajL \ "$(OMEGA_XXX)" "$(OMEGA_XXX_MAJORANA_LEGACY)" < $< > $@ compare_majorana_UFO.f90: comparisons_majorana_UFO.list @if $(AM_V_P); then :; else echo " COMPARE_DRIVER"; fi $(AM_V_at)$(SHELL) $(srcdir)/compare_driver_majorana_UFO.sh MajU \ "$(OMEGA_UFO)" "$(OMEGA_UFO_MAJORANA)" "$(OMEGA_UFO_PATH)" < $< > $@ compare_majorana.f90 compare_majorana_legacy.f90 compare_majorana_UFO.f90: \ compare_driver_majorana.sh $(OMEGA_UFO) $(OMEGA_UFO_MAJORANA) compare_majorana_SOURCES = $(COMPARE_LIB_F90) nodist_compare_majorana_SOURCES = compare_majorana.f90 compare_majorana_LDADD = $(KINDS) $(top_builddir)/omega/src/libomega_core.la compare_majorana_legacy_SOURCES = $(COMPARE_LIB_F90) nodist_compare_majorana_legacy_SOURCES = compare_majorana_legacy.f90 compare_majorana_legacy_LDADD = $(KINDS) $(top_builddir)/omega/src/libomega_core.la compare_majorana_UFO_SOURCES = $(COMPARE_LIB_F90) parameters_SM_UFO.f90 nodist_compare_majorana_UFO_SOURCES = compare_majorana_UFO.f90 compare_majorana_UFO_LDADD = $(KINDS) $(top_builddir)/omega/src/libomega_core.la compare_majorana.o compare_majorana_legacy.o compare_majorana_UFO.o: $(COMPARE_LIB_O) endif ######################################################################## if OCAML_AVAILABLE # At quadruple or extended precision, these tests take waaaaaayyyy too long! if FC_PREC else TESTS += compare_amplitude_UFO # XFAIL_TESTS += compare_amplitude_UFO EXTRA_PROGRAMS += compare_amplitude_UFO EXTRA_DIST += compare_driver_UFO.sh EXTRA_DIST += comparisons_UFO.list compare_amplitude_UFO_SOURCES = \ parameters_SM_from_UFO.f90 compare_lib.f90 \ omega_interface.f90 omega_testtools.f90 tao_random_numbers.f90 compare_amplitude_UFO.f90: comparisons_UFO.list compare_driver_UFO.sh $(OMEGA_UFO) @if $(AM_V_P); then :; else echo " COMPARE_DRIVER_UFO"; fi $(AM_V_at)$(SHELL) $(srcdir)/compare_driver_UFO.sh UFO \ "$(OMEGA_XXX) -model:constant_width" \ "$(OMEGA_UFO) -model:UFO_dir $(top_srcdir)/omega/tests/UFO/%%%/ -model:exec" \ < $< > $@ # -model:long_flavors nodist_compare_amplitude_UFO_SOURCES = \ compare_amplitude_UFO.f90 parameters_SM_UFO.f90 compare_amplitude_UFO_LDADD = $(KINDS) $(top_builddir)/omega/src/libomega_core.la parameters_SM_from_UFO.o: parameters_SM_UFO.o compare_amplitude_UFO.o: parameters_SM_UFO.o parameters_SM_from_UFO.o compare_amplitude_UFO.o: $(COMPARE_LIB_O) endif parameters_SM_UFO.f90: $(OMEGA_UFO) $(OMEGA_UFO) \ - -model:UFO_dir $(top_srcdir)/omega/tests/UFO/SM/ -model:exec \ + -model:UFO_dir $(OMEGA_UFO_PATH)/SM/ -model:exec \ -target:parameter_module parameters_sm_ufo -params > $@ endif ######################################################################## if OCAML_AVAILABLE # At quadruple or extended precision, these tests take waaaaaayyyy too long! if FC_PREC else TESTS += fermi_UFO # XFAIL_TESTS += fermi_UFO # We need more work on the parameters to pass the tests # at quadruple or extended precision. if FC_PREC XFAIL_TESTS += fermi_UFO endif EXTRA_PROGRAMS += fermi_UFO EXTRA_DIST += fermi_driver_UFO.sh EXTRA_DIST += fermi_UFO.list FERMI_UFO_SUPPORT_F90 = \ omega_interface.f90 omega_testtools.f90 tao_random_numbers.f90 FERMI_UFO_SUPPORT_O = $(FERMI_UFO_SUPPORT_F90:.f90=.o) fermi_UFO_lib.o: $(FERMI_SUPPORT_O) FERMI_UFO_LIB_F90 = fermi_lib.f90 $(FERMI_UFO_SUPPORT_F90) FERMI_UFO_LIB_O = $(FERMI_UFO_LIB_F90:.f90=.o) run_fermi_UFO: fermi_UFO ./fermi_UFO fermi_UFO.f90: fermi_UFO.list fermi_driver_UFO.sh $(OMEGA_UFO) @if $(AM_V_P); then :; else echo " FERMI_UFO_DRIVER"; fi $(AM_V_at)$(SHELL) $(srcdir)/fermi_driver_UFO.sh \ $(OMEGA_UFO) $(OMEGA_UFO_MAJORANA) $(OMEGA_UFO_PATH) \ $(OMEGA_SPLIT) < $< > $@ fermi_UFO_SOURCES = $(FERMI_UFO_LIB_F90) nodist_fermi_UFO_SOURCES = fermi_UFO.f90 parameters_SM_UFO.f90 fermi_UFO_LDADD = $(KINDS) $(top_builddir)/omega/src/libomega_core.la fermi_UFO.o: $(FERMI_UFO_LIB_O) endif endif ######################################################################## if OCAML_AVAILABLE # At quadruple or extended precision, these tests take waaaaaayyyy too long! if FC_PREC else TESTS += ward_UFO # We need more work on the parameters to pass the tests # at quadruple or extended precision. if FC_PREC XFAIL_TESTS += ward_UFO endif EXTRA_PROGRAMS += ward_UFO EXTRA_DIST += ward_driver_UFO.sh EXTRA_DIST += ward_identities_UFO.list WARD_UFO_SUPPORT_F90 = \ omega_interface.f90 omega_testtools.f90 tao_random_numbers.f90 WARD_UFO_SUPPORT_O = $(WARD_UFO_SUPPORT_F90:.f90=.o) ward_UFO_lib.o: $(WARD_SUPPORT_O) WARD_UFO_LIB_F90 = ward_lib.f90 $(WARD_UFO_SUPPORT_F90) WARD_UFO_LIB_O = $(WARD_UFO_LIB_F90:.f90=.o) run_ward_UFO: ward_UFO ./ward_UFO ward_UFO.f90: ward_identities_UFO.list ward_driver_UFO.sh $(OMEGA_UFO) @if $(AM_V_P); then :; else echo " WARD_UFO_DRIVER"; fi $(AM_V_at)$(SHELL) $(srcdir)/ward_driver_UFO.sh \ $(OMEGA_UFO) -model:UFO_dir $(top_srcdir)/omega/tests/UFO/SM/ \ $(OMEGA_SPLIT) < $< > $@ ward_UFO_SOURCES = $(WARD_UFO_LIB_F90) nodist_ward_UFO_SOURCES = ward_UFO.f90 parameters_SM_UFO.f90 ward_UFO_LDADD = $(KINDS) $(top_builddir)/omega/src/libomega_core.la ward_UFO.o: $(WARD_UFO_LIB_O) endif endif ######################################################################## TESTS += compare_amplitude_VM EXTRA_PROGRAMS += compare_amplitude_VM EXTRA_DIST += compare_driver_VM.sh compare_driver_VM_wrappers.sh EXTRA_DIST += comparisons_VM.list compare_amplitude_VM.f90: comparisons_VM.list comparisons_VM.wrappers.o @if $(AM_V_P); then :; else echo " COMPARE_DRIVER_VM"; fi $(AM_V_at)$(SHELL) $(srcdir)/compare_driver_VM.sh \ "$(OMEGA_XXX) " "$(OMEGA_XXX_VM) " "$(OMEGA_XXX_VM_PARAMS_OPTS)" < $< > $@ comparisons_VM.wrappers.f90: comparisons_VM.list @if $(AM_V_P); then :; else echo " COMPARE_DRIVER_VM_WRAPPERS"; fi $(AM_V_at)$(SHELL) $(srcdir)/compare_driver_VM_wrappers.sh \ "$(OMEGA_XXX) " "$(OMEGA_XXX_VM) " "$(OMEGA_XXX_VM_PARAMS_OPTS)" < $< > $@ # Explicitly state dependence on model files compare_amplitude_VM.f90: compare_driver_VM.sh \ $(OMEGA_QED) $(OMEGA_QED_VM) \ $(OMEGA_QCD) $(OMEGA_QCD_VM) \ $(OMEGA_SM) $(OMEGA_SM_VM) \ $(OMEGA_SM_CKM) $(OMEGA_SM_CKM_VM) \ $(OMEGA_SM_Higgs) $(OMEGA_SM_Higgs_VM) \ $(OMEGA_THDM) $(OMEGA_THDM_VM) \ $(OMEGA_THDM_CKM) $(OMEGA_THDM_CKM_VM) \ $(OMEGA_HSExt) $(OMEGA_HSExt_VM) \ $(OMEGA_Zprime) $(OMEGA_Zprime_VM) COMPARE_EXTRA_MODELS = parameters_SM_CKM.f90 parameters_SM_Higgs.f90 \ parameters_THDM.f90 parameters_THDM_CKM.f90 parameters_HSExt.f90 \ parameters_Zprime.f90 compare_amplitude_VM_SOURCES = $(COMPARE_LIB_F90) $(COMPARE_EXTRA_MODELS) nodist_compare_amplitude_VM_SOURCES = compare_amplitude_VM.f90 comparisons_VM.wrappers.f90 compare_amplitude_VM_LDADD = $(KINDS) $(top_builddir)/omega/src/libomega_core.la compare_amplitude_VM.o: $(COMPARE_LIB_O) ######################################################################## if FC_USE_OPENMP TESTS += test_openmp EXTRA_PROGRAMS += test_openmp TESTOPENMP_SUPPORT_F90 = $(WARD_SUPPORT_F90) TESTOPENMP_SUPPORT_O = $(WARD_SUPPORT_O) test_openmp_SOURCES = test_openmp.f90 $(TESTOPENMP_SUPPORT_F90) nodist_test_openmp_SOURCES = amplitude_openmp.f90 test_openmp_LDADD = $(KINDS) $(top_builddir)/omega/src/libomega_core.la amplitude_openmp.f90: $(OMEGA_QCD) Makefile $(OMEGA_QCD) $(OMEGA_QCD_OPTS) -target:openmp \ -target:module amplitude_openmp -scatter "gl gl -> gl gl gl" > $@ test_openmp.o: amplitude_openmp.o test_openmp.o: $(TESTOPENMP_SUPPORT_O) amplitude_openmp.o: parameters_QCD.o endif ######################################################################## EXTRA_PROGRAMS += benchmark_VM_vs_Fortran EXTRA_DIST += benchmark_VM_vs_Fortran_driver.sh BENCHMARK_LIB_F90 = benchmark_lib.f90 $(WARD_SUPPORT_F90) BENCHMARK_LIB_O = $(BENCHMARK_LIB_F90:.f90=.o) benchmark_VM_vs_Fortran.f90: benchmark_processes.list benchmark_processes.wrappers.o @if $(AM_V_P); then :; else echo " BENCHMARK_VM_DRIVER"; fi $(AM_V_at)$(SHELL) $(srcdir)/benchmark_VM_vs_Fortran_driver.sh \ "$(OMEGA_XXX) " "$(OMEGA_XXX_VM) " "$(OMEGA_XXX_VM_PARAMS_OPTS)" < $< > $@ benchmark_processes.wrappers.f90: benchmark_processes.list @if $(AM_V_P); then :; else echo " BENCHMARK_DRIVER_WRAPPERS"; fi $(AM_V_at)$(SHELL) $(srcdir)/benchmark_driver_wrappers.sh \ "$(OMEGA_XXX) " "$(OMEGA_XXX_VM) " "$(OMEGA_XXX_VM_PARAMS_OPTS)" < $< > $@ # Explicitly state dependence on model files benchmark_VM_vs_Fortran.f90: benchmark_VM_vs_Fortran_driver.sh \ $(OMEGA_QED) $(OMEGA_QED_VM) \ $(OMEGA_QCD) $(OMEGA_QCD_VM) \ $(OMEGA_SM) $(OMEGA_SM_VM) benchmark_VM_vs_Fortran_SOURCES = $(BENCHMARK_LIB_F90) nodist_benchmark_VM_vs_Fortran_SOURCES = benchmark_VM_vs_Fortran.f90 benchmark_processes.wrappers.f90 benchmark_VM_vs_Fortran_LDADD = $(KINDS) $(top_builddir)/omega/src/libomega_core.la benchmark_VM_vs_Fortran.o: $(BENCHMARK_LIB_O) ######################################################################## if FC_USE_OPENMP EXTRA_PROGRAMS += benchmark_amp_parallel benchmark_amp_parallel.f90: benchmark_processes.list benchmark_processes.wrappers.o @if $(AM_V_P); then :; else echo " BENCHMARK_PARALLEL_DRIVER"; fi $(AM_V_at)$(SHELL) $(srcdir)/benchmark_amp_parallel_driver.sh \ "$(OMEGA_XXX) " "$(OMEGA_XXX_VM) " "$(OMEGA_XXX_VM_PARAMS_OPTS)" < $< > $@ # Explicitly state dependence on model files benchmark_amp_parallel.f90: benchmark_amp_parallel_driver.sh \ $(OMEGA_QED) $(OMEGA_QED_VM) \ $(OMEGA_QCD) $(OMEGA_QCD_VM) \ $(OMEGA_SM) $(OMEGA_SM_VM) benchmark_amp_parallel_SOURCES = $(BENCHMARK_LIB_F90) nodist_benchmark_amp_parallel_SOURCES = benchmark_amp_parallel.f90 benchmark_processes.wrappers.f90 benchmark_amp_parallel_LDADD = $(KINDS) $(top_builddir)/omega/src/libomega_core.la benchmark_amp_parallel.o: $(BENCHMARK_LIB_O) endif ######################################################################## EXTRA_PROGRAMS += benchmark run_benchmark: benchmark ./benchmark BENCHMARK_PROCESS = -scatter "gl gl -> gl gl gl" BENCHMARK_SPLIT_SIZE = 10 benchmark_SOURCES = benchmark.f90 parameters_QCD.f90 nodist_benchmark_SOURCES = \ amplitude_benchmark_v1.f90 amplitude_benchmark_v2.f90 \ amplitude_benchmark_v3.f90 # amplitude_benchmark_v4.f90 benchmark_LDADD = $(KINDS) $(top_builddir)/omega/src/libomega_core.la amplitude_benchmark_v1.f90: $(OMEGA_QCD) Makefile $(OMEGA_QCD) $(OMEGA_QCD_OPTS) -target:module amplitude_benchmark_v1 \ $(BENCHMARK_PROCESS) -target:single_function > $@ amplitude_benchmark_v2.f90: $(OMEGA_QCD) Makefile $(OMEGA_QCD) $(OMEGA_QCD_OPTS) -target:module amplitude_benchmark_v2 \ $(BENCHMARK_PROCESS) -target:split_function $(BENCHMARK_SPLIT_SIZE) > $@ amplitude_benchmark_v3.f90: $(OMEGA_QCD) Makefile $(OMEGA_QCD) $(OMEGA_QCD_OPTS) -target:module amplitude_benchmark_v3 \ $(BENCHMARK_PROCESS) -target:split_module $(BENCHMARK_SPLIT_SIZE) > $@ amplitude_benchmark_v4.f90: $(OMEGA_QCD) Makefile $(OMEGA_QCD) $(OMEGA_QCD_OPTS) -target:module amplitude_benchmark_v4 \ $(BENCHMARK_PROCESS) -target:split_file $(BENCHMARK_SPLIT_SIZE) > $@ benchmark.o: \ amplitude_benchmark_v1.o amplitude_benchmark_v2.o \ amplitude_benchmark_v3.o # amplitude_benchmark_v4.o benchmark.o: parameters_QCD.o amplitude_benchmark_v1.o amplitude_benchmark_v2.o \ amplitude_benchmark_v3.o amplitude_benchmark_v4.o: parameters_QCD.o ######################################################################## +EXTRA_PROGRAMS += benchmark_UFO_SM + +run_benchmark_UFO_SM: benchmark_UFO_SM + ./benchmark_UFO_SM + +# NB: This IS portable ... +UFO_SM = $(OMEGA_UFO_PATH)/SM/ + +BENCHMARK_UFO_SM_PROCESS = -scatter "e+ e- -> W+ W- Z Z" + +benchmark_UFO_SM_SOURCES = \ + benchmark_UFO_SM.f90 parameters_SM_from_UFO.f90 +nodist_benchmark_UFO_SM_SOURCES = \ + amplitude_benchmark_UFO_SM.f90 \ + amplitude_benchmark_UFO_SM_classic.f90 \ + parameters_SM_UFO.f90 + +benchmark_UFO_SM_LDADD = $(KINDS) $(top_builddir)/omega/src/libomega_core.la + +amplitude_benchmark_UFO_SM_classic.f90: $(OMEGA_SM) Makefile + $(OMEGA_SM) -target:module amplitude_benchmark_UFO_SM_classic \ + -target:parameter_module parameters_SM_from_UFO \ + $(BENCHMARK_UFO_SM_PROCESS) > $@ + +amplitude_benchmark_UFO_SM.f90: $(OMEGA_UFO) Makefile + $(OMEGA_UFO) -model:UFO_dir $(UFO_SM) -model:exec \ + -target:module amplitude_benchmark_UFO_SM \ + -target:parameter_module parameters_SM_UFO \ + $(BENCHMARK_UFO_SM_PROCESS) > $@ + +benchmark_UFO_SM.o: \ + amplitude_benchmark_UFO_SM.o amplitude_benchmark_UFO_SM_classic.o + +benchmark_UFO_SM.o: parameters_SM_UFO.o parameters_SM_from_UFO.o +amplitude_benchmark_UFO_SM_classic.o: parameters_SM_from_UFO.o +amplitude_benchmark_UFO_SM.o: parameters_SM_UFO.o + +######################################################################## + EXTRA_PROGRAMS += benchmark_UFO_SMEFT run_benchmark_UFO_SMEFT: benchmark_UFO_SMEFT ./benchmark_UFO_SMEFT # NB: This is NOT portable ... UFO_SMEFT = /home/ohl/physics/SMEFT_mW_UFO/ BENCHMARK_UFO_SMEFT_PROCESS = -scatter "e+ e- -> W+ W- Z" benchmark_UFO_SMEFT_SOURCES = benchmark_UFO_SMEFT.f90 nodist_benchmark_UFO_SMEFT_SOURCES = \ amplitude_benchmark_UFO_SMEFT.f90 \ amplitude_benchmark_UFO_SMEFT_opt.f90 \ parameters_UFO_SMEFT.f90 benchmark_UFO_SMEFT_LDADD = $(KINDS) $(top_builddir)/omega/src/libomega_core.la amplitude_benchmark_UFO_SMEFT.f90: $(OMEGA_UFO) Makefile $(OMEGA_UFO) -model:UFO_dir $(UFO_SMEFT) -model:exec \ -target:module amplitude_benchmark_UFO_SMEFT \ -target:parameter_module parameters_UFO_SMEFT \ $(BENCHMARK_UFO_SMEFT_PROCESS) | $(SED) 's/g == 0/.false./' > $@ amplitude_benchmark_UFO_SMEFT_opt.f90: $(OMEGA_UFO) Makefile $(OMEGA_UFO) -model:UFO_dir $(UFO_SMEFT) -model:exec \ -target:module amplitude_benchmark_UFO_SMEFT_opt \ -target:parameter_module parameters_UFO_SMEFT \ $(BENCHMARK_UFO_SMEFT_PROCESS) > $@ benchmark_UFO_SMEFT.o: \ amplitude_benchmark_UFO_SMEFT.o amplitude_benchmark_UFO_SMEFT_opt.o benchmark_UFO_SMEFT.o: parameters_UFO_SMEFT.o amplitude_benchmark_UFO_SMEFT.o amplitude_benchmark_UFO_SMEFT_opt.o: \ parameters_UFO_SMEFT.o parameters_UFO_SMEFT.f90: $(OMEGA_UFO) $(OMEGA_UFO) -model:UFO_dir $(UFO_SMEFT) -model:exec \ -target:parameter_module parameters_UFO_SMEFT -params > $@ ######################################################################## if OCAML_AVAILABLE TESTS += vertex_unit EXTRA_PROGRAMS += vertex_unit vertex_unit_SOURCES = vertex_unit.ml vertex_unit: $(OMEGA_CORE) vertex_unit.cmx @if $(AM_V_P); then :; else echo " OCAMLOPT " $@; fi $(AM_V_at)$(OCAMLOPT) $(OCAMLFLAGS) $(OCAMLOPTFLAGS) -o vertex_unit \ unix.cmxa $(OMEGA_CORE) $(OMEGA_MODELS) vertex_unit.cmx vertex_unit.cmx: vertex_unit.ml vertex_unit.cmx: $(OMEGA_CORE) $(OMEGA_MODELS) endif ######################################################################## if OCAML_AVAILABLE TESTS += ufo_unit EXTRA_PROGRAMS += ufo_unit ufo_unit_SOURCES = ufo_unit.ml ufo_unit: $(OMEGA_CORE) ufo_unit.cmx @if $(AM_V_P); then :; else echo " OCAMLOPT " $@; fi $(AM_V_at)$(OCAMLOPT) $(OCAMLFLAGS) $(OCAMLOPTFLAGS) -o ufo_unit \ unix.cmxa $(OMEGA_CORE) $(OMEGA_MODELS) ufo_unit.cmx ufo_unit.cmx: ufo_unit.ml ufo_unit.cmx: $(OMEGA_CORE) $(OMEGA_MODELS) endif ######################################################################## if OCAML_AVAILABLE TESTS += keystones_omegalib keystones_UFO TESTS += keystones_omegalib_bispinors keystones_UFO_bispinors # XFAIL_TESTS += keystones_UFO # XFAIL_TESTS += keystones_UFO_bispinors EXTRA_PROGRAMS += keystones_omegalib keystones_UFO EXTRA_PROGRAMS += keystones_omegalib_bispinors keystones_UFO_bispinors keystones_omegalib_SOURCES = omega_testtools.f90 keystones_tools.f90 nodist_keystones_omegalib_SOURCES = keystones_omegalib.f90 keystones_omegalib_LDADD = $(KINDS) $(top_builddir)/omega/src/libomega_core.la keystones_UFO_SOURCES = omega_testtools.f90 keystones_tools.f90 nodist_keystones_UFO_SOURCES = keystones_UFO.f90 keystones_UFO_LDADD = $(KINDS) $(top_builddir)/omega/src/libomega_core.la keystones_omegalib_bispinors_SOURCES = omega_testtools.f90 keystones_tools.f90 nodist_keystones_omegalib_bispinors_SOURCES = keystones_omegalib_bispinors.f90 keystones_omegalib_bispinors_LDADD = $(KINDS) $(top_builddir)/omega/src/libomega_core.la keystones_UFO_bispinors_SOURCES = omega_testtools.f90 keystones_tools.f90 nodist_keystones_UFO_bispinors_SOURCES = keystones_UFO_bispinors.f90 keystones_UFO_bispinors_LDADD = $(KINDS) $(top_builddir)/omega/src/libomega_core.la EXTRA_PROGRAMS += keystones_omegalib_generate keystones_UFO_generate EXTRA_PROGRAMS += keystones_omegalib_bispinors_generate keystones_UFO_bispinors_generate keystones_omegalib_generate_SOURCES = \ keystones.ml keystones.mli keystones_omegalib_generate.ml keystones_UFO_generate_SOURCES = \ keystones.ml keystones.mli keystones_UFO_generate.ml keystones_omegalib_bispinors_generate_SOURCES = \ keystones.ml keystones.mli keystones_omegalib_bispinors_generate.ml keystones_UFO_bispinors_generate_SOURCES = \ keystones.ml keystones.mli keystones_UFO_bispinors_generate.ml keystones_omegalib.f90: keystones_omegalib_generate ./keystones_omegalib_generate -cat > $@ keystones_UFO.f90: keystones_UFO_generate ./keystones_UFO_generate -cat > $@ keystones_omegalib_bispinors.f90: keystones_omegalib_bispinors_generate ./keystones_omegalib_bispinors_generate -cat > $@ keystones_UFO_bispinors.f90: keystones_UFO_bispinors_generate ./keystones_UFO_bispinors_generate -cat > $@ keystones_omegalib_generate: $(OMEGA_CORE) keystones_omegalib_generate.cmx @if $(AM_V_P); then :; else echo " OCAMLOPT " $@; fi $(AM_V_at)$(OCAMLOPT) $(OCAMLFLAGS) $(OCAMLOPTFLAGS) \ -o keystones_omegalib_generate \ unix.cmxa $(OMEGA_CORE) $(OMEGA_MODELS) \ keystones.cmx keystones_omegalib_generate.cmx keystones_UFO_generate: $(OMEGA_CORE) keystones_UFO_generate.cmx @if $(AM_V_P); then :; else echo " OCAMLOPT " $@; fi $(AM_V_at)$(OCAMLOPT) $(OCAMLFLAGS) $(OCAMLOPTFLAGS) \ -o keystones_UFO_generate \ unix.cmxa $(OMEGA_CORE) $(OMEGA_MODELS) \ keystones.cmx keystones_UFO_generate.cmx keystones_omegalib_bispinors_generate: $(OMEGA_CORE) keystones_omegalib_bispinors_generate.cmx @if $(AM_V_P); then :; else echo " OCAMLOPT " $@; fi $(AM_V_at)$(OCAMLOPT) $(OCAMLFLAGS) $(OCAMLOPTFLAGS) \ -o keystones_omegalib_bispinors_generate \ unix.cmxa $(OMEGA_CORE) $(OMEGA_MODELS) \ keystones.cmx keystones_omegalib_bispinors_generate.cmx keystones_UFO_bispinors_generate: $(OMEGA_CORE) keystones_UFO_bispinors_generate.cmx @if $(AM_V_P); then :; else echo " OCAMLOPT " $@; fi $(AM_V_at)$(OCAMLOPT) $(OCAMLFLAGS) $(OCAMLOPTFLAGS) \ -o keystones_UFO_bispinors_generate \ unix.cmxa $(OMEGA_CORE) $(OMEGA_MODELS) \ keystones.cmx keystones_UFO_bispinors_generate.cmx keystones_omegalib_generate.cmx: \ keystones.cmi keystones.cmx keystones_omegalib_generate.ml keystones_omegalib_generate.cmx: $(OMEGA_CORE) $(OMEGA_MODELS) keystones_UFO_generate.cmx: \ keystones.cmi keystones.cmx keystones_UFO_generate.ml keystones_UFO_generate.cmx: $(OMEGA_CORE) $(OMEGA_MODELS) keystones_omegalib_bispinors_generate.cmx: \ keystones.cmi keystones.cmx keystones_omegalib_bispinors_generate.ml keystones_omegalib_bispinors_generate.cmx: $(OMEGA_CORE) $(OMEGA_MODELS) keystones_UFO_bispinors_generate.cmx: \ keystones.cmi keystones.cmx keystones_UFO_bispinors_generate.ml keystones_UFO_bispinors_generate.cmx: $(OMEGA_CORE) $(OMEGA_MODELS) keystones.cmx: keystones.ml keystones.cmi keystones.cmx: $(OMEGA_CORE) $(OMEGA_MODELS) keystones.cmi: keystones.mli $(OMEGA_CORE) endif ######################################################################## if RECOLA_AVAILABLE TESTS += compare_amplitude_recola # We need more work on the parameters to pass the tests # at quadruple or extended precision if FC_PREC XFAIL_TESTS += compare_amplitude_recola endif EXTRA_PROGRAMS += compare_amplitude_recola AM_FCFLAGS += $(RECOLA_INCLUDES) compare_amplitude_recola_SOURCES = \ parameters_SM_Higgs_recola.f90 \ omega_interface.f90 compare_lib.f90 compare_lib_recola.f90 \ omega_testtools.f90 tao_random_numbers.f90 nodist_compare_amplitude_recola_SOURCES = compare_amplitude_recola.f90 compare_amplitude_recola.f90: comparisons_recola.list compare_driver_recola.sh @if $(AM_V_P); then :; else echo " COMPARE_DRIVER_RECOLA"; fi $(AM_V_at)$(SHELL) $(srcdir)/compare_driver_recola.sh \ "$(OMEGA_XXX) -model:constant_width" < $< > $@ compare_amplitude_recola.o: \ omega_testtools.f90 compare_lib.o compare_lib_recola.o \ tao_random_numbers.o \ parameters_SM_Higgs_recola.o compare_lib_recola.o: \ omega_testtools.f90 compare_lib.o tao_random_numbers.o \ parameters_SM_Higgs_recola.o compare_amplitude_recola_LDADD = \ $(LDFLAGS_RECOLA) \ $(KINDS) $(top_builddir)/omega/src/libomega_core.la run_compare_recola: compare_amplitude_recola ./compare_amplitude_recola endif ######################################################################## installcheck-local: PATH=$(DESTDIR)$(bindir):$$PATH; export PATH; \ LD_LIBRARY_PATH=$(DESTDIR)$(libdir):$(DESTDIR)$(pkglibdir):$$LD_LIBRARY_PATH; \ export LD_LIBRARY_PATH; \ omega_QED.opt $(OMEGA_QED_OPTS) -scatter "e+ e- -> m+ m-" \ -target:module amplitude_qed_eemm > amplitude_qed_eemm.f90; \ $(FC) $(AM_FCFLAGS) $(FCFLAGS) -I$(pkgincludedir) \ -L$(DESTDIR)$(libdir) -L$(DESTDIR)$(pkglibdir) \ $(srcdir)/parameters_QED.f90 amplitude_qed_eemm.f90 \ $(srcdir)/test_qed_eemm.f90 -lomega_core; \ ./a.out ######################################################################## ### Remove DWARF debug information on MAC OS X clean-macosx: -rm -rf a.out.dSYM -rm -rf compare_amplitude_UFO.dSYM -rm -rf compare_amplitude_VM.dSYM -rm -rf compare_split_function.dSYM -rm -rf compare_split_module.dSYM -rm -rf ects.dSYM -rm -rf test_omega95.dSYM -rm -rf test_omega95_bispinors.dSYM -rm -rf test_qed_eemm.dSYM -rm -rf ward.dSYM .PHONY: clean-macosx clean-local: clean-macosx rm -f a.out gmon.out *.$(FCMOD) \ *.o *.cmi *.cmo *.cmx amplitude_*.f90 \ $(EXTRA_PROGRAMS) ects.f90 ward.f90 ward_UFO.f90 \ fermi.f90 fermi_UFO.f90 compare_*.f90 \ parameters_SM_UFO.f90 keystones_omegalib.f90 keystones_UFO.f90 \ keystones_UFO_bispinors.f90 keystones_omegalib_bispinors.f90 \ omega_testtools.f90 test_omega95*.f90 benchmark*.f90 \ parameters_UFO_SMEFT.f90 \ *.hbc *wrappers.f90 cascade phase_space \ output.rcl recola.log rm -fr output_cll if FC_SUBMODULES -rm -f *.smod endif ######################################################################## ## The End. ######################################################################## Index: trunk/omega/tests/fermi.list =================================================================== --- trunk/omega/tests/fermi.list (revision 8491) +++ trunk/omega/tests/fermi.list (revision 8492) @@ -1,29 +1,29 @@ # fermi.list -- # ---------------------------------------------------------------------- # thr abs_thr n roots model i j eps process ... # ---------------------------------------------------------------------- eeee 0.75 1E-11 100 1000 SM 1 2 -1 scatter e- e- -> e- e- eeee 0.80 1E-11 100 1000 SM 3 4 -1 scatter e- e- -> e- e- eeeea 0.65 1E-11 100 1000 SM 1 2 -1 scatter e- e- -> e- e- A eeeea 0.80 1E-11 100 1000 SM 3 4 -1 scatter e- e- -> e- e- A eeeeaa 0.72 1E-11 100 1000 SM 1 2 -1 scatter e- e- -> e- e- A A eeeeaa 0.75 1E-11 100 1000 SM 3 4 -1 scatter e- e- -> e- e- A A eeeeaa 0.75 1E-11 100 1000 SM 5 6 1 scatter e- e- -> e- e- A A eeeeee 0.75 1E-11 100 1000 SM 3 4 -1 scatter e+ e- -> e+ e+ e- e- eeeeee 0.75 1E-11 100 1000 SM 5 6 -1 scatter e+ e- -> e+ e+ e- e- -Seeee 0.70 1E-11 100 1000 MSSM 1 2 -1 scatter e- e- -> e- e- +Seeee 0.65 1E-11 100 1000 MSSM 1 2 -1 scatter e- e- -> e- e- Seeee 0.75 1E-11 100 1000 MSSM 3 4 -1 scatter e- e- -> e- e- Seeeea 0.75 1E-11 100 1000 MSSM 3 4 -1 scatter e- e- -> e- e- A Seenn 0.75 1E-11 100 1000 MSSM 3 4 -1 scatter e+ e- -> neu1 neu1 Seen4 0.75 1E-11 100 1000 MSSM 3 4 -1 scatter e+ e- -> neu1 neu1 neu1 neu1 Seen4 0.75 1E-11 100 1000 MSSM 3 5 -1 scatter e+ e- -> neu1 neu1 neu1 neu1 Seen4 0.75 1E-11 100 1000 MSSM 3 6 -1 scatter e+ e- -> neu1 neu1 neu1 neu1 Seen4 0.75 1E-11 100 1000 MSSM 4 5 -1 scatter e+ e- -> neu1 neu1 neu1 neu1 Seen4 0.75 1E-11 100 1000 MSSM 4 6 -1 scatter e+ e- -> neu1 neu1 neu1 neu1 Seen4 0.75 1E-11 100 1000 MSSM 5 6 -1 scatter e+ e- -> neu1 neu1 neu1 neu1 Seess 0.75 1E-11 100 1000 MSSM 1 2 -1 scatter e- e- -> se1- se1- Seess 0.75 1E-11 100 1000 MSSM 3 4 1 scatter e- e- -> se1- se1- Sees4 0.75 1E-11 100 1000 MSSM 3 4 1 scatter e+ e- -> se1+ se1+ se1- se1- Sees4 0.75 1E-11 100 1000 MSSM 5 6 1 scatter e+ e- -> se1+ se1+ se1- se1- ! uuuu 0.75 1E-11 100 1000 SM 3 4 -1 scatter u u -> u u Index: trunk/omega/tests/ward_identities_fail.list =================================================================== --- trunk/omega/tests/ward_identities_fail.list (revision 8491) +++ trunk/omega/tests/ward_identities_fail.list (revision 8492) @@ -1,21 +1,21 @@ # ward_identities_fail.list -- # ---------------------------------------------------------------------- # thr n roots model i process ... # ---------------------------------------------------------------------- # # Needs a mass for the Higgs: #gg1 0.7 1000 1000 SYM 3 scatter phi g1 -> g1 # # Works without a Hgg coupling (the required Hggg coupling is missing) #gggg1 0.7 1 1000 SYM 3 scatter g1 g1 -> g1 g1 g1 #ggggg1 0.7 1 1000 SYM 3 scatter g1 g1 -> g1 g1 g1 g1 # # The required Hggg coupling is missing #ggp1 0.7 1 1000 SYM 3 scatter g1 g1 -> g1 phi # # Without Hgg, SYM should work just as well as QCD -qqggg 0.7 100 1000 QCD 3 scatter u ubar -> gl gl gl -qqggg1 0.7 1 1000 SYM 3 scatter q1 Q1 -> g1 g1 g1 -ssggg1 0.7 1 1000 SYM 3 scatter sq1 sQ1 -> g1 g1 g1 -ssgss1 0.7 1 1000 SYM 3 scatter sq1 sQ1 -> g1 sq1 sQ1 +qqggg 0.7 500 1000 QCD 3 scatter u ubar -> gl gl gl +qqggg1 0.7 500 1000 SYM 3 scatter q1 Q1 -> g1 g1 g1 +ssggg1 0.7 500 1000 SYM 3 scatter sq1 sQ1 -> g1 g1 g1 +ssgss1 0.7 500 1000 SYM 3 scatter sq1 sQ1 -> g1 sq1 sQ1 Index: trunk/omega/tests/fermi_UFO.list =================================================================== --- trunk/omega/tests/fermi_UFO.list (revision 8491) +++ trunk/omega/tests/fermi_UFO.list (revision 8492) @@ -1,30 +1,30 @@ # fermi_UFO.list -- # ---------------------------------------------------------------------- # thr abs_thr n roots model i j eps process ... # ---------------------------------------------------------------------- -eeee 0.70 1E-11 100 1000 SM 1 2 -1 scatter e- e- -> e- e- +eeee 0.65 1E-11 100 1000 SM 1 2 -1 scatter e- e- -> e- e- eeee 0.75 1E-11 100 1000 SM 3 4 -1 scatter e- e- -> e- e- eeeea 0.60 1E-11 100 1000 SM 1 2 -1 scatter e- e- -> e- e- a eeeea 0.75 1E-11 100 1000 SM 3 4 -1 scatter e- e- -> e- e- a -eeeeaa 0.70 1E-11 100 1000 SM 1 2 -1 scatter e- e- -> e- e- a a +eeeeaa 0.65 1E-11 100 1000 SM 1 2 -1 scatter e- e- -> e- e- a a eeeeaa 0.75 1E-11 100 1000 SM 3 4 -1 scatter e- e- -> e- e- a a eeeeaa 0.75 1E-11 100 1000 SM 5 6 1 scatter e- e- -> e- e- a a eeeepe 0.70 1E-11 100 1000 SM 1 2 -1 scatter e- e- -> e- e- e+ e- eeeepe 0.75 1E-11 100 1000 SM 3 4 -1 scatter e- e- -> e- e- e+ e- eeeepe 0.75 1E-11 100 1000 SM 3 6 -1 scatter e- e- -> e- e- e+ e- eeeepe 0.75 1E-11 100 1000 SM 4 6 -1 scatter e- e- -> e- e- e+ e- peppee 0.75 1E-11 100 1000 SM 3 4 -1 scatter e+ e- -> e+ e+ e- e- peppee 0.75 1E-11 100 1000 SM 5 6 -1 scatter e+ e- -> e+ e+ e- e- -meeee 0.70 1E-11 100 1000 SM/M 1 2 -1 scatter e- e- -> e- e- +meeee 0.65 1E-11 100 1000 SM/M 1 2 -1 scatter e- e- -> e- e- meeee 0.75 1E-11 100 1000 SM/M 3 4 -1 scatter e- e- -> e- e- #eeeea 0.40 1E-11 100 1000 SM/M 1 2 -1 scatter e- e- -> e- e- a meeeea 0.70 1E-11 100 1000 SM/M 3 4 -1 scatter e- e- -> e- e- a #eeeeaa 0.50 1E-11 100 1000 SM/M 1 2 -1 scatter e- e- -> e- e- a a meeeeaa 0.75 1E-11 100 1000 SM/M 3 4 -1 scatter e- e- -> e- e- a a meeeeaa 0.75 1E-11 100 1000 SM/M 5 6 1 scatter e- e- -> e- e- a a meeeepe 0.70 1E-11 100 1000 SM/M 1 2 -1 scatter e- e- -> e- e- e+ e- meeeepe 0.75 1E-11 100 1000 SM/M 3 4 -1 scatter e- e- -> e- e- e+ e- #eeeepe 0.70 1E-11 100 1000 SM/M 3 6 -1 scatter e- e- -> e- e- e+ e- #eeeepe 0.75 1E-11 100 1000 SM/M 4 6 -1 scatter e- e- -> e- e- e+ e- mpeppee 0.75 1E-11 100 1000 SM/M 3 4 -1 scatter e+ e- -> e+ e+ e- e- mpeppee 0.75 1E-11 100 1000 SM/M 5 6 -1 scatter e+ e- -> e+ e+ e- e- Index: trunk/omega/tests/keystones_omegalib_bispinors_generate.ml =================================================================== --- trunk/omega/tests/keystones_omegalib_bispinors_generate.ml (revision 8491) +++ trunk/omega/tests/keystones_omegalib_bispinors_generate.ml (revision 8492) @@ -1,53 +1,54 @@ (* keystones_omegalib_bispinors_generate.ml -- Copyright (C) 2019-2020 by Wolfgang Kilian Thorsten Ohl Juergen Reuter WHIZARD 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 2, or (at your option) any later version. WHIZARD 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, write to the Free Software Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. *) open Coupling open Keystones let vector_spinor_current tag = { tag = Printf.sprintf "vector_spinor_current__%s_ff" tag; keystones = [ { bra = (Majorana, 0); name = Printf.sprintf "f_%sf" tag; args = [G (0); F (Vector, 1); F (Majorana, 2)] }; { bra = (Vector, 1); name = Printf.sprintf "%s_ff" tag; args = [G (0); F (Majorana, 0); F (Majorana, 2)] } ] } let scalar_spinor_current tag = { tag = Printf.sprintf "scalar_spinor_current__%s_ff" tag; keystones = [ { bra = (Majorana, 0); name = Printf.sprintf "f_%sf" tag; args = [G (0); F (Scalar, 1); F (Majorana, 2)] }; { bra = (Scalar, 1); name = Printf.sprintf "%s_ff" tag; args = [G (0); F (Majorana, 0); F (Majorana, 2)] } ] } let vertices = List.concat [ List.map vector_spinor_current ["v"; "a"; "vl"; "vr"]; List.map scalar_spinor_current ["s"; "p"; "sl"; "sr"] ] let _ = Keystones.generate - ~reps:1000 ~threshold:0.70 ~omega_module:"omega95_bispinors" + ~reps:1000 ~threshold:0.70 + ~program:"keystones_omegalib_bispinors" ~omega_module:"omega95_bispinors" vertices; exit 0 Index: trunk/omega/tests/keystones.mli =================================================================== --- trunk/omega/tests/keystones.mli (revision 8491) +++ trunk/omega/tests/keystones.mli (revision 8492) @@ -1,64 +1,90 @@ (* keystones.mli -- Copyright (C) 2019-2020 by Wolfgang Kilian Thorsten Ohl Juergen Reuter WHIZARD 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 2, or (at your option) any later version. WHIZARD 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, write to the Free Software Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. *) +(* A [field] has a Lorentz representation, which will be translated + to a Fortran type, i.\,e.~the corresponding mnemonic, + and a position index. *) type field = Coupling.lorentz * int +(* The different kind of arguments of the fusions. *) type argument = | G of int (* complex coupling *) + | N of int (* negative of complex coupling *) | M of int (* real mass (or width) *) | P of int (* momentum *) | F of field (* field *) | V of string (* verbatim *) +(* A [keystone] is translated to the Fortran expression + \texttt{bra * name (args)}. *) type keystone = { bra : field; name : string; args : argument list } +(* A vertex has a unique name [tag] used for the Fortran + routine and a list of keystones that must \emph{all} produce + the same result within a reasonable numerical accuracy. *) type vertex = { tag : string; keystones : keystone list } val generate : ?reps:int -> ?threshold:float -> - ?omega_module:string -> ?modules:string list -> + ?program:string -> ?omega_module:string -> ?modules:string list -> vertex list -> unit +(* In the case of UFO Lorentz structures, we can generate the + [keystone list] automatically: *) type ufo_vertex = { v_tag : string; v_spins : Coupling.lorentz array; - v_tensor : UFOx.Lorentz.t } + v_tensor : UFO_Lorentz.t; + v_flines : Coupling.fermion_lines } type ufo_propagator = { p_tag : string; p_omega : string; p_spins : Coupling.lorentz * Coupling.lorentz; p_propagator : UFO.Propagator.t } +(* Almost always, there is more than one way to write the + \emph{same} Lorentz structure. Produce the corresponding + [ufo_vertex list]. NB: despite the name there is no checking + for equivalences done here. *) val equivalent_tensors : + ?fermion_lines:Coupling.fermion_lines -> Coupling.lorentz array -> (string * string) list -> ufo_vertex list val transpose : ufo_propagator -> ufo_propagator val generate_ufo : - ?omega_module:string -> ?reps:int -> ?threshold:float -> + ?program:string -> ?omega_module:string -> ?reps:int -> ?threshold:float -> + ?only_fusions:ufo_vertex list -> + string -> (ufo_vertex list * vertex) list -> ufo_propagator list -> unit + +(* We need different tests for the Majorana spinor permutations, + transpositions and conjugations. *) +val generate_ufo_bispinors : + ?program:string -> ?omega_module:string -> ?reps:int -> ?threshold:float -> + ?only_fusions:ufo_vertex list -> string -> (ufo_vertex list * vertex) list -> ufo_propagator list -> unit Index: trunk/omega/tests/keystones_omegalib_generate.ml =================================================================== --- trunk/omega/tests/keystones_omegalib_generate.ml (revision 8491) +++ trunk/omega/tests/keystones_omegalib_generate.ml (revision 8492) @@ -1,79 +1,80 @@ (* keystones_omegalib_generate.ml -- Copyright (C) 2019-2020 by Wolfgang Kilian Thorsten Ohl Juergen Reuter WHIZARD 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 2, or (at your option) any later version. WHIZARD 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, write to the Free Software Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. *) open Coupling open Keystones let vector_spinor_current tag = { tag = Printf.sprintf "vector_spinor_current__%s_ff" tag; keystones = [ { bra = (ConjSpinor, 0); name = Printf.sprintf "f_%sf" tag; args = [G (0); F (Vector, 1); F (Spinor, 2)] }; { bra = (Vector, 1); name = Printf.sprintf "%s_ff" tag; args = [G (0); F (ConjSpinor, 0); F (Spinor, 2)] }; { bra = (Spinor, 2); name = Printf.sprintf "f_f%s" tag; args = [G (0); F (ConjSpinor, 0); F (Vector, 1)] } ] } let scalar_spinor_current tag = { tag = Printf.sprintf "scalar_spinor_current__%s_ff" tag; keystones = [ { bra = (ConjSpinor, 0); name = Printf.sprintf "f_%sf" tag; args = [G (0); F (Scalar, 1); F (Spinor, 2)] }; { bra = (Scalar, 1); name = Printf.sprintf "%s_ff" tag; args = [G (0); F (ConjSpinor, 0); F (Spinor, 2)] }; { bra = (Spinor, 2); name = Printf.sprintf "f_f%s" tag; args = [G (0); F (ConjSpinor, 0); F (Scalar, 1)] } ] } (* NB: the vertex is anti-symmetric in the scalars and we need to use a cyclic permutation. *) let vector_scalar_current = { tag = "vector_scalar_current__v_ss"; keystones = [ { bra = (Vector, 0); name = "v_ss"; args = [G (0); F (Scalar, 1); P (1); F (Scalar, 2); P (2)] }; { bra = (Scalar, 2); name = "s_vs"; args = [G (0); F (Vector, 0); P (0); F (Scalar, 1); P (1)] } ] } let scalar_vector_current tag = { tag = Printf.sprintf "transversal_vector_current__s_vv_%s" tag; keystones = [ { bra = (Scalar, 0); name = Printf.sprintf "s_vv_%s" tag; args = [G (0); F (Vector, 1); P (1); F (Vector, 2); P (2)] }; { bra = (Vector, 1); name = Printf.sprintf "v_sv_%s" tag; args = [G (0); F (Scalar, 0); P (0); F (Vector, 2); P (2)] } ] } let vertices = List.concat [ List.map vector_spinor_current ["v"; "a"; "vl"; "vr"]; List.map scalar_spinor_current ["s"; "p"; "sl"; "sr"]; [ vector_scalar_current ]; List.map scalar_vector_current ["t"; "6D"; "6DP"] ] let _ = - Keystones.generate ~reps:1000 ~threshold:0.70 vertices; + Keystones.generate + ~program:"keystones_omegalib" ~reps:1000 ~threshold:0.70 vertices; exit 0 Index: trunk/omega/src/UFO.ml =================================================================== --- trunk/omega/src/UFO.ml (revision 8491) +++ trunk/omega/src/UFO.ml (revision 8492) @@ -1,2901 +1,2915 @@ (* UFO.ml -- Copyright (C) 1999-2021 by Wolfgang Kilian Thorsten Ohl Juergen Reuter with contributions from Christian Speckner WHIZARD 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 2, or (at your option) any later version. WHIZARD 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, write to the Free Software Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. *) (* Unfortunately, \texttt{ocamlweb} will not typeset all multi character operators nicely. E.\,g.~\verb+f @< g+ comes out as [f @< g]. *) let (@@) f g x = f (g x) let (@@@) f g x y = f (g x y) module SMap = Map.Make (struct type t = string let compare = compare end) module SSet = Sets.String module CMap = Map.Make (struct type t = string let compare = ThoString.compare_caseless end) module CSet = Sets.String_Caseless let error_in_string text start_pos end_pos = let i = start_pos.Lexing.pos_cnum and j = end_pos.Lexing.pos_cnum in String.sub text i (j - i) let error_in_file name start_pos end_pos = Printf.sprintf "%s:%d.%d-%d.%d" name start_pos.Lexing.pos_lnum (start_pos.Lexing.pos_cnum - start_pos.Lexing.pos_bol) end_pos.Lexing.pos_lnum (end_pos.Lexing.pos_cnum - end_pos.Lexing.pos_bol) let parse_string text = try UFO_parser.file UFO_lexer.token (UFO_lexer.init_position "" (Lexing.from_string text)) with | UFO_tools.Lexical_Error (msg, start_pos, end_pos) -> invalid_arg (Printf.sprintf "lexical error (%s) at: `%s'" msg (error_in_string text start_pos end_pos)) | UFO_syntax.Syntax_Error (msg, start_pos, end_pos) -> invalid_arg (Printf.sprintf "syntax error (%s) at: `%s'" msg (error_in_string text start_pos end_pos)) | Parsing.Parse_error -> invalid_arg ("parse error: " ^ text) let parse_file name = let ic = open_in name in let result = begin try UFO_parser.file UFO_lexer.token (UFO_lexer.init_position name (Lexing.from_channel ic)) with | UFO_tools.Lexical_Error (msg, start_pos, end_pos) -> begin close_in ic; invalid_arg (Printf.sprintf "%s: lexical error (%s)" (error_in_file name start_pos end_pos) msg) end | UFO_syntax.Syntax_Error (msg, start_pos, end_pos) -> begin close_in ic; invalid_arg (Printf.sprintf "%s: syntax error (%s)" (error_in_file name start_pos end_pos) msg) end | Parsing.Parse_error -> begin close_in ic; invalid_arg ("parse error: " ^ name) end end in close_in ic; result (* These are the contents of the Python files after lexical analysis as context-free variable declarations, before any semantic interpretation. *) module type Files = sig type t = private { particles : UFO_syntax.t; couplings : UFO_syntax.t; coupling_orders : UFO_syntax.t; vertices : UFO_syntax.t; lorentz : UFO_syntax.t; parameters : UFO_syntax.t; propagators : UFO_syntax.t; decays : UFO_syntax.t } val parse_directory : string -> t end module Files : Files = struct type t = { particles : UFO_syntax.t; couplings : UFO_syntax.t; coupling_orders : UFO_syntax.t; vertices : UFO_syntax.t; lorentz : UFO_syntax.t; parameters : UFO_syntax.t; propagators : UFO_syntax.t; decays : UFO_syntax.t } let parse_directory dir = let parse stem = parse_file (Filename.concat dir (stem ^ ".py")) in { particles = parse "particles"; couplings = parse "couplings"; coupling_orders = (try parse "coupling_orders" with _ -> []); vertices = parse "vertices"; lorentz = parse "lorentz"; parameters = parse "parameters"; propagators = parse "propagators"; (* [(try parse "propagators" with _ -> []);] *) decays = (try parse "decays" with _ -> []) } end let dump_file pfx f = List.iter (fun s -> print_endline (pfx ^ ": " ^ s)) (UFO_syntax.to_strings f) type charge = | Q_Integer of int | Q_Fraction of int * int let charge_to_string = function | Q_Integer i -> Printf.sprintf "%d" i | Q_Fraction (n, d) -> Printf.sprintf "%d/%d" n d module S = UFO_syntax let find_attrib name attribs = try (List.find (fun a -> name = a.S.a_name) attribs).S.a_value with | Not_found -> failwith ("UFO.find_attrib: \"" ^ name ^ "\" not found") let find_attrib name attribs = (List.find (fun a -> name = a.S.a_name) attribs).S.a_value let name_to_string ?strip name = let stripped = begin match strip, List.rev name with | Some pfx, head :: tail -> if pfx = head then tail else failwith ("UFO.name_to_string: expected prefix '" ^ pfx ^ "', got '" ^ head ^ "'") | _, name -> name end in String.concat "." stripped let name_attrib ?strip name attribs = match find_attrib name attribs with | S.Name n -> name_to_string ?strip n | _ -> invalid_arg ("UFO.name_attrib: " ^ name) let integer_attrib name attribs = match find_attrib name attribs with | S.Integer i -> i | _ -> invalid_arg ("UFO.integer_attrib: " ^ name) let charge_attrib name attribs = match find_attrib name attribs with | S.Integer i -> Q_Integer i | S.Fraction (n, d) -> Q_Fraction (n, d) | _ -> invalid_arg ("UFO.charge_attrib: " ^ name) let string_attrib name attribs = match find_attrib name attribs with | S.String s -> s | _ -> invalid_arg ("UFO.string_attrib: " ^ name) let string_expr_attrib name attribs = match find_attrib name attribs with | S.Name n -> [S.Macro n] | S.String s -> [S.Literal s] | S.String_Expr e -> e | _ -> invalid_arg ("UFO.string_expr_attrib: " ^ name) let boolean_attrib name attribs = try match ThoString.lowercase (name_attrib name attribs) with | "true" -> true | "false" -> false | _ -> invalid_arg ("UFO.boolean_attrib: " ^ name) with | Not_found -> false type value = | Integer of int | Fraction of int * int | Float of float | Expr of UFOx.Expr.t | Name of string list let map_expr f default = function | Integer _ | Fraction (_, _) | Float _ | Name _ -> default | Expr e -> f e let variables = map_expr UFOx.Expr.variables CSet.empty let functions = map_expr UFOx.Expr.functions CSet.empty let add_to_set_in_map key element map = let set = try CMap.find key map with Not_found -> CSet.empty in CMap.add key (CSet.add element set) map (* Add all variables in [value] to the [map] from variables to the names in which they appear, indicating that [name] depends on these variables. *) let dependency name value map = CSet.fold (fun variable acc -> add_to_set_in_map variable name acc) (variables value) map let dependencies name_value_list = List.fold_left (fun acc (name, value) -> dependency name value acc) CMap.empty name_value_list let dependency_to_string (variable, appearences) = Printf.sprintf "%s -> {%s}" variable (String.concat ", " (CSet.elements appearences)) let dependencies_to_strings map = List.map dependency_to_string (CMap.bindings map) let expr_to_string = UFOx.Value.to_string @@ UFOx.Value.of_expr let value_to_string = function | Integer i -> Printf.sprintf "%d" i | Fraction (n, d) -> Printf.sprintf "%d/%d" n d | Float x -> string_of_float x | Expr e -> "'" ^ expr_to_string e ^ "'" | Name n -> name_to_string n let value_to_expr substitutions = function | Integer i -> Printf.sprintf "%d" i | Fraction (n, d) -> Printf.sprintf "%d/%d" n d | Float x -> string_of_float x | Expr e -> expr_to_string (substitutions e) | Name n -> name_to_string n let value_to_coupling substitutions atom = function | Integer i -> Coupling.Integer i | Fraction (n, d) -> Coupling.Quot (Coupling.Integer n, Coupling.Integer d) | Float x -> Coupling.Float x | Expr e -> UFOx.Value.to_coupling atom (UFOx.Value.of_expr (substitutions e)) | Name n -> failwith "UFO.value_to_coupling: Name not supported yet!" let value_to_numeric = function | Integer i -> Printf.sprintf "%d" i | Fraction (n, d) -> Printf.sprintf "%g" (float n /. float d) | Float x -> Printf.sprintf "%g" x | Expr e -> invalid_arg ("UFO.value_to_numeric: expr = " ^ (expr_to_string e)) | Name n -> invalid_arg ("UFO.value_to_numeric: name = " ^ name_to_string n) let value_to_float = function | Integer i -> float i | Fraction (n, d) -> float n /. float d | Float x -> x | Expr e -> invalid_arg ("UFO.value_to_float: string = " ^ (expr_to_string e)) | Name n -> invalid_arg ("UFO.value_to_float: name = " ^ name_to_string n) let value_attrib name attribs = match find_attrib name attribs with | S.Integer i -> Integer i | S.Fraction (n, d) -> Fraction (n, d) | S.Float x -> Float x | S.String s -> Expr (UFOx.Expr.of_string s) | S.Name n -> Name n | _ -> invalid_arg ("UFO.value_attrib: " ^ name) let string_list_attrib name attribs = match find_attrib name attribs with | S.String_List l -> l | _ -> invalid_arg ("UFO.string_list_attrib: " ^ name) let name_list_attrib ~strip name attribs = match find_attrib name attribs with | S.Name_List l -> List.map (name_to_string ~strip) l | _ -> invalid_arg ("UFO.name_list_attrib: " ^ name) let integer_list_attrib name attribs = match find_attrib name attribs with | S.Integer_List l -> l | _ -> invalid_arg ("UFO.integer_list_attrib: " ^ name) let order_dictionary_attrib name attribs = match find_attrib name attribs with | S.Order_Dictionary d -> d | _ -> invalid_arg ("UFO.order_dictionary_attrib: " ^ name) let coupling_dictionary_attrib ~strip name attribs = match find_attrib name attribs with | S.Coupling_Dictionary d -> List.map (fun (i, j, c) -> (i, j, name_to_string ~strip c)) d | _ -> invalid_arg ("UFO.coupling_dictionary_attrib: " ^ name) let decay_dictionary_attrib name attribs = match find_attrib name attribs with | S.Decay_Dictionary d -> List.map (fun (p, w) -> (List.map List.hd p, w)) d | _ -> invalid_arg ("UFO.decay_dictionary_attrib: " ^ name) (*i The following doesn't typecheck in applications, even with type annotations ... let attrib_handlers : type attribs value. string -> string -> attribs -> ((string -> attribs -> value) -> string -> value) * ((string -> attribs -> value) -> string -> value -> value) = fun kind symbol attribs -> let required query name = try query name attribs with | Not_found -> invalid_arg (Printf.sprintf "fatal UFO error: mandatory attribute `%s' missing for %s `%s'!" name kind symbol) and optional query name default = try query name attribs with | Not_found -> default in (required, optional) i*) let required_handler kind symbol attribs query name = try query name attribs with | Not_found -> invalid_arg (Printf.sprintf "fatal UFO error: mandatory attribute `%s' missing for %s `%s'!" name kind symbol) let optional_handler attribs query name default = try query name attribs with | Not_found -> default (* The UFO paper~\cite{Degrande:2011ua} is not clear on the question whether the \texttt{name} attribute of an instance must match its Python name. While the examples appear to imply this, there are examples of UFO files in the wild that violate this constraint. *) let warn_symbol_name file symbol name = if name <> symbol then Printf.eprintf "UFO: warning: symbol '%s' <> name '%s' in %s.py: \ while legal in UFO, it is unusual and can cause problems!\n" symbol name file let valid_fortran_id kind name = if not (ThoString.valid_fortran_id name) then invalid_arg (Printf.sprintf "fatal UFO error: the %s `%s' is not a valid fortran id!" kind name) let map_to_alist map = SMap.fold (fun key value acc -> (key, value) :: acc) map [] let keys map = SMap.fold (fun key _ acc -> key :: acc) map [] let keys_caseless map = CMap.fold (fun key _ acc -> key :: acc) map [] let values map = SMap.fold (fun _ value acc -> value :: acc) map [] module SKey = struct type t = string let hash = Hashtbl.hash let equal = (=) end module SHash = Hashtbl.Make (SKey) module type Particle = sig type t = private { pdg_code : int; name : string; antiname : string; spin : UFOx.Lorentz.r; color : UFOx.Color.r; mass : string; width : string; propagator : string option; texname : string; antitexname : string; charge : charge; ghost_number : int; lepton_number : int; y : charge; goldstone : bool; propagating : bool; (* NOT HANDLED YET! *) line : string option; (* NOT HANDLED YET! *) is_anti : bool } val of_file : S.t -> t SMap.t val to_string : string -> t -> string val conjugate : t -> t val force_spinor : t -> t val force_conjspinor : t -> t val force_majorana : t -> t val is_majorana : t -> bool val is_ghost : t -> bool val is_goldstone : t -> bool val is_physical : t -> bool val filter : (t -> bool) -> t SMap.t -> t SMap.t end module Particle : Particle = struct type t = { pdg_code : int; name : string; antiname : string; spin : UFOx.Lorentz.r; color : UFOx.Color.r; mass : string; width : string; propagator : string option; texname : string; antitexname : string; charge : charge; ghost_number : int; lepton_number : int; y : charge; goldstone : bool; propagating : bool; (* NOT HANDLED YET! *) line : string option; (* NOT HANDLED YET! *) is_anti : bool } let to_string symbol p = Printf.sprintf "particle: %s => [pdg = %d, name = '%s'/'%s', \ spin = %s, color = %s, \ mass = %s, width = %s,%s \ Q = %s, G = %d, L = %d, Y = %s, \ TeX = '%s'/'%s'%s]" symbol p.pdg_code p.name p.antiname (UFOx.Lorentz.rep_to_string p.spin) (UFOx.Color.rep_to_string p.color) p.mass p.width (match p.propagator with | None -> "" | Some p -> " propagator = " ^ p ^ ",") (charge_to_string p.charge) p.ghost_number p.lepton_number (charge_to_string p.y) p.texname p.antitexname (if p.goldstone then ", GB" else "") let conjugate_charge = function | Q_Integer i -> Q_Integer (-i) | Q_Fraction (n, d) -> Q_Fraction (-n, d) let is_neutral p = (p.name = p.antiname) (* We \emph{must not} mess with [pdg_code] and [color] if the particle is neutral! *) let conjugate p = if is_neutral p then p else { pdg_code = - p.pdg_code; name = p.antiname; antiname = p.name; spin = UFOx.Lorentz.rep_conjugate p.spin; color = UFOx.Color.rep_conjugate p.color; mass = p.mass; width = p.width; propagator = p.propagator; texname = p.antitexname; antitexname = p.texname; charge = conjugate_charge p.charge; ghost_number = p.ghost_number; lepton_number = p.lepton_number; y = p.y; goldstone = p.goldstone; propagating = p.propagating; line = p.line; is_anti = not p.is_anti } let of_file1 map d = let symbol = d.S.name in match d.S.kind, d.S.attribs with | [ "Particle" ], attribs -> let required query name = required_handler "particle" symbol attribs query name and optional query name default = optional_handler attribs query name default in let name = required string_attrib "name" and antiname = required string_attrib "antiname" in let neutral = (name = antiname) in SMap.add symbol { (* The required attributes per UFO docs. *) pdg_code = required integer_attrib "pdg_code"; name; antiname; spin = UFOx.Lorentz.rep_of_int neutral (required integer_attrib "spin"); color = UFOx.Color.rep_of_int neutral (required integer_attrib "color"); mass = required (name_attrib ~strip:"Param") "mass"; width = required (name_attrib ~strip:"Param") "width"; texname = required string_attrib "texname"; antitexname = required string_attrib "antitexname"; charge = required charge_attrib "charge"; (* The optional attributes per UFO docs. *) ghost_number = optional integer_attrib "GhostNumber" 0; lepton_number = optional integer_attrib "LeptonNumber" 0; y = optional charge_attrib "Y" (Q_Integer 0); goldstone = optional boolean_attrib "goldstone" false; propagating = optional boolean_attrib "propagating" true; line = (try Some (name_attrib "line" attribs) with _ -> None); (* Undocumented extensions. *) propagator = (try Some (name_attrib ~strip:"Prop" "propagator" attribs) with _ -> None); (* O'Mega extensions. *) is_anti = false } map | [ "anti"; p ], [] -> begin try SMap.add symbol (conjugate (SMap.find p map)) map with | Not_found -> invalid_arg ("Particle.of_file: " ^ p ^ ".anti() not yet defined!") end | _ -> invalid_arg ("Particle.of_file: " ^ name_to_string d.S.kind) let of_file particles = List.fold_left of_file1 SMap.empty particles let is_spinor p = match UFOx.Lorentz.omega p.spin with | Coupling.Spinor | Coupling.ConjSpinor | Coupling.Majorana -> true | _ -> false (* \begin{dubious} TODO: this is a bit of a hack: try to expose the type [UFOx.Lorentz_Atom'.r] instead. \end{dubious} *) let force_spinor p = if is_spinor p then { p with spin = UFOx.Lorentz.rep_of_int false 2 } else p let force_conjspinor p = if is_spinor p then { p with spin = UFOx.Lorentz.rep_of_int false (-2) } else p let force_majorana p = if is_spinor p then { p with spin = UFOx.Lorentz.rep_of_int true 2 } else p let is_majorana p = match UFOx.Lorentz.omega p.spin with | Coupling.Majorana | Coupling.Vectorspinor | Coupling.Maj_Ghost -> true | _ -> false let is_ghost p = p.ghost_number <> 0 let is_goldstone p = p.goldstone let is_physical p = not (is_ghost p || is_goldstone p) let filter predicate map = SMap.filter (fun symbol p -> predicate p) map end module type UFO_Coupling = sig type t = private { name : string; value : UFOx.Expr.t; order : (string * int) list } val of_file : S.t -> t SMap.t val to_string : string -> t -> string end module UFO_Coupling : UFO_Coupling = struct type t = { name : string; value : UFOx.Expr.t; order : (string * int) list } let order_to_string orders = String.concat ", " (List.map (fun (s, i) -> Printf.sprintf "'%s':%d" s i) orders) let to_string symbol c = Printf.sprintf "coupling: %s => [name = '%s', value = '%s', order = [%s]]" symbol c.name (expr_to_string c.value) (order_to_string c.order) let of_file1 map d = let symbol = d.S.name in match d.S.kind, d.S.attribs with | [ "Coupling" ], attribs -> let required query name = required_handler "coupling" symbol attribs query name in let name = required string_attrib "name" in warn_symbol_name "couplings" symbol name; valid_fortran_id "coupling" name; SMap.add symbol { name; value = UFOx.Expr.of_string (required string_attrib "value"); order = required order_dictionary_attrib "order" } map | _ -> invalid_arg ("UFO_Coupling.of_file: " ^ name_to_string d.S.kind) let of_file couplings = List.fold_left of_file1 SMap.empty couplings end module type Coupling_Order = sig type t = private { name : string; expansion_order : int; hierarchy : int } val of_file : S.t -> t SMap.t val to_string : string -> t -> string end module Coupling_Order : Coupling_Order = struct type t = { name : string; expansion_order : int; hierarchy : int } let to_string symbol c = Printf.sprintf "coupling_order: %s => [name = '%s', \ expansion_order = '%d', \ hierarchy = %d]" symbol c.name c.expansion_order c.hierarchy let of_file1 map d = let symbol = d.S.name in match d.S.kind, d.S.attribs with | [ "CouplingOrder" ], attribs -> let required query name = required_handler "coupling order" symbol attribs query name in let name = required string_attrib "name" in warn_symbol_name "coupling_orders" symbol name; SMap.add symbol { name; expansion_order = required integer_attrib "expansion_order"; hierarchy = required integer_attrib "hierarchy" } map | _ -> invalid_arg ("Coupling_order.of_file: " ^ name_to_string d.S.kind) let of_file coupling_orders = List.fold_left of_file1 SMap.empty coupling_orders end module type Lorentz_UFO = sig (* If the \texttt{name} attribute of a \texttt{Lorentz} object does \emph{not} match the the name of the object, we need the latter for weeding out unused Lorentz structures (see [Vertex.contains] below). Therefore, we keep it around. *) type t = private { name : string; symbol : string; spins : int list; structure : UFOx.Lorentz.t } val of_file : S.t -> t SMap.t val to_string : string -> t -> string end module Lorentz_UFO : Lorentz_UFO = struct type t = { name : string; symbol : string; spins : int list; structure : UFOx.Lorentz.t } let to_string symbol l = Printf.sprintf "lorentz: %s => [name = '%s', spins = [%s], \ structure = %s]" symbol l.name (String.concat ", " (List.map string_of_int l.spins)) (UFOx.Lorentz.to_string l.structure) let of_file1 map d = let symbol = d.S.name in match d.S.kind, d.S.attribs with | [ "Lorentz" ], attribs -> let required query name = required_handler "lorentz" symbol attribs query name in let name = required string_attrib "name" in warn_symbol_name "lorentz" symbol name; valid_fortran_id "lorentz" symbol; SMap.add symbol { name; symbol; spins = required integer_list_attrib "spins"; structure = UFOx.Lorentz.of_string (required string_attrib "structure") } map | _ -> invalid_arg ("Lorentz.of_file: " ^ name_to_string d.S.kind) let of_file lorentz = List.fold_left of_file1 SMap.empty lorentz end module type Vertex = sig type lcc = private (* Lorentz-color-coupling *) { lorentz : string; color : UFOx.Color.t; coupling : string } type t = private { name : string; particles : string array; lcc : lcc list } val of_file : Particle.t SMap.t -> S.t -> t SMap.t val to_string : string -> t -> string val to_string_expanded : Lorentz_UFO.t SMap.t -> UFO_Coupling.t SMap.t -> t -> string val contains : Particle.t SMap.t -> (Particle.t -> bool) -> t -> bool val filter : (t -> bool) -> t SMap.t -> t SMap.t end module Vertex : Vertex = struct type lcc = { lorentz : string; color : UFOx.Color.t; coupling : string } type t = { name : string; particles : string array; lcc : lcc list } let to_string symbol c = Printf.sprintf "vertex: %s => [name = '%s', particles = [%s], \ lorentz-color-couplings = [%s]" symbol c.name (String.concat ", " (Array.to_list c.particles)) (String.concat ", " (List.map (fun lcc -> Printf.sprintf "%s * %s * %s" lcc.coupling lcc.lorentz (UFOx.Color.to_string lcc.color)) c.lcc)) let to_string_expanded lorentz couplings c = let expand_lorentz s = try UFOx.Lorentz.to_string (SMap.find s lorentz).Lorentz_UFO.structure with | Not_found -> "?" in Printf.sprintf "expanded: [%s] -> { lorentz-color-couplings = [%s] }" (String.concat ", " (Array.to_list c.particles)) (String.concat ", " (List.map (fun lcc -> Printf.sprintf "%s * %s * %s" lcc.coupling (expand_lorentz lcc.lorentz) (UFOx.Color.to_string lcc.color)) c.lcc)) let contains particles predicate v = let p = v.particles in let rec contains' i = if i < 0 then false else if predicate (SMap.find p.(i) particles) then true else contains' (pred i) in contains' (Array.length p - 1) let force_adj_identity1 adj_indices = function | UFOx.Color_Atom.Identity (a, b) as atom -> begin match List.mem a adj_indices, List.mem b adj_indices with | true, true -> UFOx.Color_Atom.Identity8 (a, b) | false, false -> atom | true, false | false, true -> invalid_arg "force_adj_identity: mixed representations!" end | atom -> atom let force_adj_identity adj_indices tensor = UFOx.Color.map_atoms (force_adj_identity1 adj_indices) tensor let find_adj_indices map particles = let adj_indices = ref [] in Array.iteri (fun i p -> (* We must pattern match against the O'Mega representation, because [UFOx.Color.r] is abstract. *) match UFOx.Color.omega (SMap.find p map).Particle.color with | Color.AdjSUN _ -> adj_indices := succ i :: !adj_indices | _ -> ()) particles; !adj_indices let classify_color_indices map particles = let fund_indices = ref [] and conj_indices = ref [] and adj_indices = ref [] in Array.iteri (fun i p -> (* We must pattern match against the O'Mega representation, because [UFOx.Color.r] is abstract. *) match UFOx.Color.omega (SMap.find p map).Particle.color with | Color.SUN n -> if n > 0 then fund_indices := succ i :: !fund_indices else if n < 0 then conj_indices := succ i :: !conj_indices else failwith "classify_color_indices: SU(0)" | Color.AdjSUN n -> if n <> 0 then adj_indices := succ i :: !adj_indices else failwith "classify_color_indices: SU(0)" | _ -> ()) particles; (!fund_indices, !conj_indices, !adj_indices) (* FIXME: would have expected the opposite order \ldots *) let force_identity1 (fund_indices, conj_indices, adj_indices) = function | UFOx.Color_Atom.Identity (a, b) as atom -> if List.mem a fund_indices then begin if List.mem b conj_indices then UFOx.Color_Atom.Identity (b, a) else invalid_arg "force_adj_identity: mixed representations!" end else if List.mem a conj_indices then begin if List.mem b fund_indices then UFOx.Color_Atom.Identity (a, b) else invalid_arg "force_adj_identity: mixed representations!" end else if List.mem a adj_indices then begin if List.mem b adj_indices then UFOx.Color_Atom.Identity8 (a, b) else invalid_arg "force_adj_identity: mixed representations!" end else atom | atom -> atom let force_identity indices tensor = UFOx.Color.map_atoms (force_identity1 indices) tensor (* Here we don't have the Lorentz structures available yet. Thus we set [fermion_lines = []] for now and correct this later. *) let of_file1 particle_map map d = let symbol = d.S.name in match d.S.kind, d.S.attribs with | [ "Vertex" ], attribs -> let required query name = required_handler "vertex" symbol attribs query name in let name = required string_attrib "name" in warn_symbol_name "vertices" symbol name; let particles = Array.of_list (required (name_list_attrib ~strip:"P") "particles") in let color = let indices = classify_color_indices particle_map particles in Array.of_list (List.map (force_identity indices @@ UFOx.Color.of_string) (required string_list_attrib "color")) and lorentz = Array.of_list (required (name_list_attrib ~strip:"L") "lorentz") and couplings_alist = required (coupling_dictionary_attrib ~strip:"C") "couplings" in let lcc = List.map (fun (i, j, c) -> { lorentz = lorentz.(j); color = color.(i); coupling = c }) couplings_alist in SMap.add symbol { name; particles; lcc } map | _ -> invalid_arg ("Vertex.of_file: " ^ name_to_string d.S.kind) let of_file particles vertices = List.fold_left (of_file1 particles) SMap.empty vertices let filter predicate map = SMap.filter (fun symbol p -> predicate p) map end module type Parameter = sig type nature = private Internal | External type ptype = private Real | Complex type t = private { name : string; nature : nature; ptype : ptype; value : value; texname : string; lhablock : string option; lhacode : int list option; sequence : int } val of_file : S.t -> t SMap.t val to_string : string -> t -> string val missing : string -> t end module Parameter : Parameter = struct type nature = Internal | External let nature_to_string = function | Internal -> "internal" | External -> "external" let nature_of_string = function | "internal" -> Internal | "external" -> External | s -> invalid_arg ("Parameter.nature_of_string: " ^ s) type ptype = Real | Complex let ptype_to_string = function | Real -> "real" | Complex -> "complex" let ptype_of_string = function | "real" -> Real | "complex" -> Complex | s -> invalid_arg ("Parameter.ptype_of_string: " ^ s) type t = { name : string; nature : nature; ptype : ptype; value : value; texname : string; lhablock : string option; lhacode : int list option; sequence : int } let to_string symbol p = Printf.sprintf "parameter: %s => [#%d, name = '%s', nature = %s, type = %s, \ value = %s, texname = '%s', \ lhablock = %s, lhacode = [%s]]" symbol p.sequence p.name (nature_to_string p.nature) (ptype_to_string p.ptype) (value_to_string p.value) p.texname (match p.lhablock with None -> "???" | Some s -> s) (match p.lhacode with | None -> "" | Some c -> String.concat ", " (List.map string_of_int c)) let of_file1 (map, n) d = let symbol = d.S.name in match d.S.kind, d.S.attribs with | [ "Parameter" ], attribs -> let required query name = required_handler "particle" symbol attribs query name in let name = required string_attrib "name" in warn_symbol_name "parameters" symbol name; valid_fortran_id "parameter" name; (SMap.add symbol { name; nature = nature_of_string (required string_attrib "nature"); ptype = ptype_of_string (required string_attrib "type"); value = required value_attrib "value"; texname = required string_attrib "texname"; lhablock = (try Some (string_attrib "lhablock" attribs) with Not_found -> None); lhacode = (try Some (integer_list_attrib "lhacode" attribs) with Not_found -> None); sequence = n } map, succ n) | _ -> invalid_arg ("Parameter.of_file: " ^ name_to_string d.S.kind) let of_file parameters = let map, _ = List.fold_left of_file1 (SMap.empty, 0) parameters in map let missing name = { name; nature = External; ptype = Real; value = Integer 0; texname = Printf.sprintf "\\texttt{%s}" name; lhablock = None; lhacode = None; sequence = 0 } end (* Macros are encoded as a special [S.declaration] with [S.kind = "$"]. This is slightly hackish, but general enough and the overhead of a special union type is probably not worth the effort. *) module type Macro = sig type t val empty : t (* The domains and codomains are still a bit too much ad hoc, but it does the job. *) val define : t -> string -> S.value -> t val expand_string : t -> string -> S.value val expand_expr : t -> S.string_atom list -> string (* Only for documentation: *) val expand_atom : t -> S.string_atom -> string end module Macro : Macro = struct type t = S.value SMap.t let empty = SMap.empty let define macros name expansion = SMap.add name expansion macros let expand_string macros name = SMap.find name macros let rec expand_atom macros = function | S.Literal s -> s | S.Macro [name] -> begin try begin match SMap.find name macros with | S.String s -> s | S.String_Expr expr -> expand_expr macros expr | _ -> invalid_arg ("expand_atom: not a string: " ^ name) end with | Not_found -> invalid_arg ("expand_atom: not found: " ^ name) end | S.Macro [] -> invalid_arg "expand_atom: empty" | S.Macro name -> invalid_arg ("expand_atom: compound name: " ^ String.concat "." name) and expand_expr macros expr = String.concat "" (List.map (expand_atom macros) expr) end module type Propagator_UFO = sig type t = (* private *) { name : string; numerator : UFOx.Lorentz.t; denominator : UFOx.Lorentz.t } val of_file : S.t -> t SMap.t val to_string : string -> t -> string end module Propagator_UFO : Propagator_UFO = struct type t = { name : string; numerator : UFOx.Lorentz.t; denominator : UFOx.Lorentz.t } let to_string symbol p = Printf.sprintf "propagator: %s => [name = '%s', numerator = '%s', \ denominator = '%s']" symbol p.name (UFOx.Lorentz.to_string p.numerator) (UFOx.Lorentz.to_string p.denominator) (* The \texttt{denominator} attribute is optional and there is a default (cf.~\texttt{arXiv:1308.1668}) *) let default_denominator = "P('mu', id) * P('mu', id) \ - Mass(id) * Mass(id) \ + complex(0,1) * Mass(id) * Width(id)" let of_string_with_error_correction symbol num_or_den s = try UFOx.Lorentz.of_string s with | Invalid_argument msg -> begin let fixed = s ^ ")" in try let tensor = UFOx.Lorentz.of_string fixed in Printf.eprintf "UFO.Propagator.of_string: added missing closing parenthesis \ in %s of %s: \"%s\"\n" num_or_den symbol s; tensor with | Invalid_argument _ -> invalid_arg (Printf.sprintf "UFO.Propagator.of_string: %s of %s: %s in \"%s\"\n" num_or_den symbol msg fixed) end let of_file1 (macros, map) d = let symbol = d.S.name in match d.S.kind, d.S.attribs with | [ "Propagator" ], attribs -> let required query name = required_handler "particle" symbol attribs query name and optional query name default = optional_handler attribs query name default in let name = required string_attrib "name" in warn_symbol_name "propagators" symbol name; let num_string_expr = required string_expr_attrib "numerator" and den_string = begin match optional find_attrib "denominator" (S.String default_denominator) with | S.String s -> s | S.Name [n] -> begin match Macro.expand_string macros n with | S.String s -> s | _ -> invalid_arg "Propagator.denominator" end | _ -> invalid_arg "Propagator.denominator: " end in let num_string = Macro.expand_expr macros num_string_expr in let numerator = of_string_with_error_correction symbol "numerator" num_string and denominator = of_string_with_error_correction symbol "denominator" den_string in (macros, SMap.add symbol { name; numerator; denominator } map) | [ "$" ], [ macro ] -> begin match macro.S.a_value with | S.String _ as s -> (Macro.define macros symbol s, map); | S.String_Expr expr -> let expanded = S.String (Macro.expand_expr macros expr) in (Macro.define macros symbol expanded, map) | _ -> invalid_arg ("Propagator:of_file: not a string " ^ symbol) end | [ "$" ], [] -> invalid_arg ("Propagator:of_file: empty declaration " ^ symbol) | [ "$" ], _ -> invalid_arg ("Propagator:of_file: multiple declaration " ^ symbol) | _ -> invalid_arg ("Propagator:of_file: " ^ name_to_string d.S.kind) let of_file propagators = let _, propagators' = List.fold_left of_file1 (Macro.empty, SMap.empty) propagators in propagators' end module type Decay = sig type t = private { name : string; particle : string; widths : (string list * string) list } val of_file : S.t -> t SMap.t val to_string : string -> t -> string end module Decay : Decay = struct type t = { name : string; particle : string; widths : (string list * string) list } let width_to_string ws = String.concat ", " (List.map (fun (ps, w) -> "(" ^ String.concat ", " ps ^ ") -> '" ^ w ^ "'") ws) let to_string symbol d = Printf.sprintf "decay: %s => [name = '%s', particle = '%s', widths = [%s]]" symbol d.name d.particle (width_to_string d.widths) let of_file1 map d = let symbol = d.S.name in match d.S.kind, d.S.attribs with | [ "Decay" ], attribs -> let required query name = required_handler "particle" symbol attribs query name in let name = required string_attrib "name" in warn_symbol_name "decays" symbol name; SMap.add symbol { name; particle = required (name_attrib ~strip:"P") "particle"; widths = required decay_dictionary_attrib "partial_widths" } map | _ -> invalid_arg ("Decay.of_file: " ^ name_to_string d.S.kind) let of_file decays = List.fold_left of_file1 SMap.empty decays end (* We can read the spinor representations off the vertices to check for consistency. *) (* \begin{dubious} Note that we have to conjugate the representations! \end{dubious} *) let collect_spinor_reps_of_vertex particles lorentz v sets = List.fold_left (fun sets' lcc -> let l = (SMap.find lcc.Vertex.lorentz lorentz).Lorentz_UFO.structure in List.fold_left (fun (spinors, conj_spinors as sets'') (i, rep) -> let p = v.Vertex.particles.(pred i) in match UFOx.Lorentz.omega rep with | Coupling.ConjSpinor -> (SSet.add p spinors, conj_spinors) | Coupling.Spinor -> (spinors, SSet.add p conj_spinors) | _ -> sets'') sets' (UFOx.Lorentz.classify_indices l)) sets v.Vertex.lcc let collect_spinor_reps_of_vertices particles lorentz vertices = SMap.fold (fun _ v -> collect_spinor_reps_of_vertex particles lorentz v) vertices (SSet.empty, SSet.empty) let lorentz_reps_of_vertex particles v = ThoList.alist_of_list ~predicate:(not @@ UFOx.Lorentz.rep_trivial) ~offset:1 (List.map (fun p -> (* Why do we need to conjugate??? *) UFOx.Lorentz.rep_conjugate (SMap.find p particles).Particle.spin) (Array.to_list v.Vertex.particles)) let rep_compatible rep_vertex rep_particle = let open UFOx.Lorentz in let open Coupling in match omega rep_vertex, omega rep_particle with | (Spinor | ConjSpinor), Majorana -> true | r1, r2 -> r1 = r2 let reps_compatible reps_vertex reps_particles = List.for_all2 (fun (iv, rv) (ip, rp) -> iv = ip && rep_compatible rv rp) reps_vertex reps_particles let check_lorentz_reps_of_vertex particles lorentz v = let reps_particles = List.sort compare (lorentz_reps_of_vertex particles v) in List.iter (fun lcc -> let l = (SMap.find lcc.Vertex.lorentz lorentz).Lorentz_UFO.structure in let reps_vertex = List.sort compare (UFOx.Lorentz.classify_indices l) in if not (reps_compatible reps_vertex reps_particles) then begin Printf.eprintf "%s <> %s [%s]\n" (UFOx.Index.classes_to_string UFOx.Lorentz.rep_to_string reps_particles) (UFOx.Index.classes_to_string UFOx.Lorentz.rep_to_string reps_vertex) v.Vertex.name (* [(Vertex.to_string v.Vertex.name v)] *); (* [invalid_arg "check_lorentz_reps_of_vertex"] *) () end) v.Vertex.lcc let color_reps_of_vertex particles v = ThoList.alist_of_list ~predicate:(not @@ UFOx.Color.rep_trivial) ~offset:1 (List.map (fun p -> (SMap.find p particles).Particle.color) (Array.to_list v.Vertex.particles)) let check_color_reps_of_vertex particles v = let reps_particles = List.sort compare (color_reps_of_vertex particles v) in List.iter (fun lcc -> let reps_vertex = List.sort compare (UFOx.Color.classify_indices lcc.Vertex.color) in if reps_vertex <> reps_particles then begin Printf.printf "%s <> %s\n" (UFOx.Index.classes_to_string UFOx.Color.rep_to_string reps_particles) (UFOx.Index.classes_to_string UFOx.Color.rep_to_string reps_vertex); invalid_arg "check_color_reps_of_vertex" end) v.Vertex.lcc module P = Permutation.Default module type Lorentz = sig type spins = private | Unused | Unique of Coupling.lorentz array | Ambiguous of Coupling.lorentz array SMap.t type t = private { name : string; n : int; spins : spins; structure : UFO_Lorentz.t; fermion_lines : Coupling.fermion_lines; variables : string list } - val all_charge_conjugates : t -> t list + val required_charge_conjugates : t -> t list val permute : P.t -> t -> t val of_lorentz_UFO : Particle.t SMap.t -> Vertex.t SMap.t -> Lorentz_UFO.t SMap.t -> t SMap.t val lorentz_to_string : Coupling.lorentz -> string val to_string : string -> t -> string end module Lorentz : Lorentz = struct let rec lorentz_to_string = function | Coupling.Scalar -> "Scalar" | Coupling.Spinor -> "Spinor" | Coupling.ConjSpinor -> "ConjSpinor" | Coupling.Majorana -> "Majorana" | Coupling.Maj_Ghost -> "Maj_Ghost" | Coupling.Vector -> "Vector" | Coupling.Massive_Vector -> "Massive_Vector" | Coupling.Vectorspinor -> "Vectorspinor" | Coupling.Tensor_1 -> "Tensor_1" | Coupling.Tensor_2 -> "Tensor_2" | Coupling.BRS l -> "BRS(" ^ lorentz_to_string l ^ ")" (* Unlike UFO, O'Mega distinguishes bewteen spinors and conjugate spinors. However, we can inspect the particles in the vertices in which a Lorentz structure is used to determine the correct quantum numbers. Most model files in the real world contain unused Lorentz structures. This is not a problem, we can just ignore them. *) type spins = | Unused | Unique of Coupling.lorentz array | Ambiguous of Coupling.lorentz array SMap.t (* \begin{dubious} Use [UFO_targets.Fortran.fusion_name] below in order to avoid communication problems. Or even move away from strings alltogether. \end{dubious} *) type t = { name : string; n : int; spins : spins; structure : UFO_Lorentz.t; fermion_lines : Coupling.fermion_lines; variables : string list } (* Add one charge conjugated fermion lines. *) - let charge_conjugate1 l (bra, ket as fermion_line) = - { name = l.name ^ Printf.sprintf "_c%x%x" bra ket; + let charge_conjugate1 l (ket, bra as fermion_line) = + { name = l.name ^ Printf.sprintf "_c%x%x" ket bra; n = l.n; spins = l.spins; structure = UFO_Lorentz.charge_conjugate fermion_line l.structure; fermion_lines = l.fermion_lines; variables = l.variables } (* Add several charge conjugated fermion lines. *) let charge_conjugate l fermion_lines = List.fold_left charge_conjugate1 l fermion_lines - (* Add all combinations of charge conjugated fermion lines. *) +(*i let all_charge_conjugates l = List.map (charge_conjugate l) (ThoList.power l.fermion_lines) +i*) + + (* Add all combinations of charge conjugated fermion lines + that don't leave the fusion. *) + let required_charge_conjugates l = + let saturated_fermion_lines = + List.filter + (fun (ket, bra) -> ket != 1 && bra != 1) + l.fermion_lines in + List.map (charge_conjugate l) (ThoList.power saturated_fermion_lines) let permute_spins p = function | Unused -> Unused | Unique s -> Unique (P.array p s) | Ambiguous map -> Ambiguous (SMap.map (P.array p) map) (* Note that we apply the \emph{inverse} permutation to the indices in order to match the permutation of the particles/spins. *) let permute_structure n p (l, f) = let permuted = P.array (P.inverse p) (Array.init n succ) in let permute_index i = if i > 0 then UFOx.Index.map_position (fun pos -> permuted.(pred pos)) i else i in (UFO_Lorentz.map_indices permute_index l, UFO_Lorentz.map_fermion_lines permute_index f) let permute p l = let structure, fermion_lines = permute_structure l.n p (l.structure, l.fermion_lines) in { name = l.name ^ "_p" ^ P.to_string (P.inverse p); n = l.n; spins = permute_spins p l.spins; structure; fermion_lines; variables = l.variables } let omega_lorentz_reps n alist = let reps = Array.make n Coupling.Scalar in List.iter (fun (i, rep) -> reps.(pred i) <- UFOx.Lorentz.omega rep) alist; reps let contained lorentz vertex = List.exists (fun lcc1 -> lcc1.Vertex.lorentz = lorentz.Lorentz_UFO.symbol) vertex.Vertex.lcc (* Find all vertices in with the Lorentz structure [lorentz] is used and build a map from those vertices to the O'Mega Lorentz representations inferred from UFO's Lorentz structure and the [particles] involved. Then scan the bindings and check that we have inferred the same Lorentz representation from all vertices. *) let lorentz_reps_of_structure particles vertices lorentz = let uses = SMap.fold (fun name v acc -> if contained lorentz v then SMap.add name (omega_lorentz_reps (Array.length v.Vertex.particles) (lorentz_reps_of_vertex particles v)) acc else acc) vertices SMap.empty in let variants = ThoList.uniq (List.sort compare (List.map snd (SMap.bindings uses))) in match variants with | [] -> Unused | [s] -> Unique s | _ -> Printf.eprintf "UFO.Lorentz.lorentz_reps_of_structure: AMBIGUOUS!\n"; List.iter (fun variant -> Printf.eprintf "UFO.Lorentz.lorentz_reps_of_structure: %s\n" (ThoList.to_string lorentz_to_string (Array.to_list variant))) variants; Ambiguous uses let of_lorentz_tensor spins lorentz = match spins with | Unique s -> begin try Some (UFO_Lorentz.parse (Array.to_list s) lorentz) with | Failure msg -> begin prerr_endline msg; Some (UFO_Lorentz.dummy) end end | Unused -> Printf.eprintf "UFO.Lorentz: stripping unused structure %s\n" (UFOx.Lorentz.to_string lorentz); None | Ambiguous _ -> invalid_arg "UFO.Lorentz.of_lorentz_tensor: Ambiguous" (* NB: if the \texttt{name} attribute of a \texttt{Lorentz} object does \emph{not} match the the name of the object, the former has a better chance to correspond to a valid Fortran name. Therefore we use it. *) let of_lorentz_UFO particles vertices lorentz_UFO = SMap.fold (fun name l acc -> let spins = lorentz_reps_of_structure particles vertices l in match of_lorentz_tensor spins l.Lorentz_UFO.structure with | None -> acc | Some structure -> SMap.add name { name = l.Lorentz_UFO.symbol; n = List.length l.Lorentz_UFO.spins; spins; structure; fermion_lines = UFO_Lorentz.fermion_lines structure; variables = UFOx.Lorentz.variables l.Lorentz_UFO.structure } acc) lorentz_UFO SMap.empty let to_string symbol l = Printf.sprintf "lorentz: %s => [name = '%s', spins = %s, \ structure = %s, fermion_lines = %s]" symbol l.name (match l.spins with | Unique s -> "[" ^ String.concat ", " (List.map lorentz_to_string (Array.to_list s)) ^ "]" | Ambiguous _ -> "AMBIGUOUS!" | Unused -> "UNUSED!") (UFO_Lorentz.to_string l.structure) (UFO_Lorentz.fermion_lines_to_string l.fermion_lines) end (* According to arxiv:1308:1668, there should not be a factor of~$i$ in the numerators of propagators, but the (unused) \texttt{propagators.py} in most models violate this rule! *) let divide_propagators_by_i = ref false module type Propagator = sig type t = (* private *) { name : string; spins : Coupling.lorentz * Coupling.lorentz; numerator : UFO_Lorentz.t; denominator : UFO_Lorentz.t; variables : string list } val of_propagator_UFO : ?majorana:bool -> Propagator_UFO.t -> t val of_propagators_UFO : ?majorana:bool -> Propagator_UFO.t SMap.t -> t SMap.t val transpose : t -> t val to_string : string -> t -> string end module Propagator : Propagator = struct type t = (* private *) { name : string; spins : Coupling.lorentz * Coupling.lorentz; numerator : UFO_Lorentz.t; denominator : UFO_Lorentz.t; variables : string list } let lorentz_rep_at rep_classes i = try UFOx.Lorentz.omega (List.assoc i rep_classes) with | Not_found -> Coupling.Scalar let imaginary = Algebra.QC.make Algebra.Q.null Algebra.Q.unit let scalars = [Coupling.Scalar; Coupling.Scalar] (* If~$51$ and~$52$ show up as indices, we must map $(1,51)\to(1001,2001)$ and $(2,52)\to(1002,2002)$, as per the UFO conventions for Lorentz structures. *) (* \begin{dubious} This does not work yet, because [UFOx.Lorentz.map_indices] affects also the position argument of [P], [Mass] and [Width]. \end{dubious} *) let contains_51_52 tensor = List.exists (fun (i, _) -> i = 51 || i = 52) (UFOx.Lorentz.classify_indices tensor) let remap_51_52 = function | 1 -> 1001 | 51 -> 2001 | 2 -> 1002 | 52 -> 2002 | i -> i let canonicalize_51_52 tensor = if contains_51_52 tensor then UFOx.Lorentz.rename_indices remap_51_52 tensor else tensor let force_majorana = function | Coupling.Spinor | Coupling.ConjSpinor -> Coupling.Majorana | s -> s let string_list_union l1 l2 = Sets.String.elements (Sets.String.union (Sets.String.of_list l1) (Sets.String.of_list l2)) (* In the current conventions, the factor of~$i$ is not included: *) let of_propagator_UFO ?(majorana=false) p = let numerator = canonicalize_51_52 p.Propagator_UFO.numerator in let lorentz_reps = UFOx.Lorentz.classify_indices numerator in let spin1 = lorentz_rep_at lorentz_reps 1 and spin2 = lorentz_rep_at lorentz_reps 2 in let numerator_sans_i = if !divide_propagators_by_i then UFOx.Lorentz.map_coeff (fun q -> Algebra.QC.div q imaginary) numerator else numerator in { name = p.Propagator_UFO.name; spins = if majorana then (force_majorana spin1, force_majorana spin2) else (spin1, spin2); numerator = UFO_Lorentz.parse ~allow_denominator:true [spin1; spin2] numerator_sans_i; denominator = UFO_Lorentz.parse scalars p.Propagator_UFO.denominator; variables = string_list_union (UFOx.Lorentz.variables p.Propagator_UFO.denominator) (UFOx.Lorentz.variables numerator_sans_i) } let of_propagators_UFO ?majorana propagators_UFO = SMap.fold (fun name p acc -> SMap.add name (of_propagator_UFO ?majorana p) acc) propagators_UFO SMap.empty let permute12 = function | 1 -> 2 | 2 -> 1 | n -> n let transpose_positions t = UFOx.Index.map_position permute12 t let transpose p = { name = p.name; spins = (snd p.spins, fst p.spins); numerator = UFO_Lorentz.map_indices transpose_positions p.numerator; denominator = p.denominator; variables = p.variables } let to_string symbol p = Printf.sprintf "propagator: %s => [name = '%s', spin = '(%s, %s)', numerator/I = '%s', \ denominator = '%s']" symbol p.name (Lorentz.lorentz_to_string (fst p.spins)) (Lorentz.lorentz_to_string (snd p.spins)) (UFO_Lorentz.to_string p.numerator) (UFO_Lorentz.to_string p.denominator) end type t = { particles : Particle.t SMap.t; particle_array : Particle.t array; (* for diagnostics *) couplings : UFO_Coupling.t SMap.t; coupling_orders : Coupling_Order.t SMap.t; vertices : Vertex.t SMap.t; lorentz_UFO : Lorentz_UFO.t SMap.t; lorentz : Lorentz.t SMap.t; parameters : Parameter.t SMap.t; propagators_UFO : Propagator_UFO.t SMap.t; propagators : Propagator.t SMap.t; decays : Decay.t SMap.t; nc : int } let use_majorana_spinors = ref false let fallback_to_majorana_if_necessary particles vertices lorentz_UFO = let majoranas = SMap.fold (fun p particle acc -> if Particle.is_majorana particle then SSet.add p acc else acc) particles SSet.empty in let spinors, conj_spinors = collect_spinor_reps_of_vertices particles lorentz_UFO vertices in let ambiguous = SSet.diff (SSet.inter spinors conj_spinors) majoranas in let no_majoranas = SSet.is_empty majoranas and no_ambiguities = SSet.is_empty ambiguous in if no_majoranas && no_ambiguities && not !use_majorana_spinors then (SMap.mapi (fun p particle -> if SSet.mem p spinors then Particle.force_spinor particle else if SSet.mem p conj_spinors then Particle.force_conjspinor particle else particle) particles, false) else begin if !use_majorana_spinors then Printf.eprintf "O'Mega: Majorana fermions requested.\n"; if not no_majoranas then Printf.eprintf "O'Mega: found Majorana fermions!\n"; if not no_ambiguities then Printf.eprintf "O'Mega: found ambiguous spinor representations for %s!\n" (String.concat ", " (SSet.elements ambiguous)); Printf.eprintf "O'Mega: falling back to the Majorana representation for all fermions.\n"; (SMap.map Particle.force_majorana particles, true) end let nc_of_particles particles = let nc_set = List.fold_left (fun nc_set (_, p) -> match UFOx.Color.omega p.Particle.color with | Color.Singlet -> nc_set | Color.SUN nc -> Sets.Int.add (abs nc) nc_set | Color.AdjSUN nc -> Sets.Int.add (abs nc) nc_set) Sets.Int.empty (SMap.bindings particles) in match Sets.Int.elements nc_set with | [] -> 0 | [n] -> n | nc_list -> invalid_arg ("UFO.Model: more than one value of N_C: " ^ String.concat ", " (List.map string_of_int nc_list)) let of_file u = let particles = Particle.of_file u.Files.particles in let vertices = Vertex.of_file particles u.Files.vertices and lorentz_UFO = Lorentz_UFO.of_file u.Files.lorentz and propagators_UFO = Propagator_UFO.of_file u.Files.propagators in let particles, majorana = fallback_to_majorana_if_necessary particles vertices lorentz_UFO in let particle_array = Array.of_list (values particles) and lorentz = Lorentz.of_lorentz_UFO particles vertices lorentz_UFO and propagators = Propagator.of_propagators_UFO ~majorana propagators_UFO in let model = { particles; particle_array; couplings = UFO_Coupling.of_file u.Files.couplings; coupling_orders = Coupling_Order.of_file u.Files.coupling_orders; vertices; lorentz_UFO; lorentz; parameters = Parameter.of_file u.Files.parameters; propagators_UFO; propagators; decays = Decay.of_file u.Files.decays; nc = nc_of_particles particles } in SMap.iter (fun _ v -> check_color_reps_of_vertex model.particles v; check_lorentz_reps_of_vertex model.particles model.lorentz_UFO v) model.vertices; model let parse_directory dir = of_file (Files.parse_directory dir) let dump model = Printf.printf "NC = %d\n" model.nc; SMap.iter (print_endline @@@ Particle.to_string) model.particles; SMap.iter (print_endline @@@ UFO_Coupling.to_string) model.couplings; SMap.iter (print_endline @@@ Coupling_Order.to_string) model.coupling_orders; (* [SMap.iter (print_endline @@@ Vertex.to_string) model.vertices;] *) SMap.iter (fun symbol v -> (print_endline @@@ Vertex.to_string) symbol v; print_endline (Vertex.to_string_expanded model.lorentz_UFO model.couplings v)) model.vertices; SMap.iter (print_endline @@@ Lorentz_UFO.to_string) model.lorentz_UFO; SMap.iter (print_endline @@@ Lorentz.to_string) model.lorentz; SMap.iter (print_endline @@@ Parameter.to_string) model.parameters; SMap.iter (print_endline @@@ Propagator_UFO.to_string) model.propagators_UFO; SMap.iter (print_endline @@@ Propagator.to_string) model.propagators; SMap.iter (print_endline @@@ Decay.to_string) model.decays; SMap.iter (fun symbol d -> List.iter (fun (_, w) -> ignore (UFOx.Expr.of_string w)) d.Decay.widths) model.decays exception Unhandled of string let unhandled s = raise (Unhandled s) module Model = struct (* NB: we could use [type flavor = Particle.t], but that would be very inefficient, because we will use [flavor] as a key for maps below. *) type flavor = int type constant = string type gauge = unit module M = Modeltools.Mutable (struct type f = flavor type g = gauge type c = constant end) let flavors = M.flavors let external_flavors = M.external_flavors let external_flavors = M.external_flavors let lorentz = M.lorentz let color = M.color let nc = M.nc let propagator = M.propagator let width = M.width let goldstone = M.goldstone let conjugate = M.conjugate let fermion = M.fermion let vertices = M.vertices let fuse2 = M.fuse2 let fuse3 = M.fuse3 let fuse = M.fuse let max_degree = M.max_degree let parameters = M.parameters let flavor_of_string = M.flavor_of_string let flavor_to_string = M.flavor_to_string let flavor_to_TeX = M.flavor_to_TeX let flavor_symbol = M.flavor_symbol let gauge_symbol = M.gauge_symbol let pdg = M.pdg let mass_symbol = M.mass_symbol let width_symbol = M.width_symbol let constant_symbol = M.constant_symbol module Ch = M.Ch let charges = M.charges let rec fermion_of_lorentz = function | Coupling.Spinor -> 1 | Coupling.ConjSpinor -> -1 | Coupling.Majorana -> 2 | Coupling.Maj_Ghost -> 2 | Coupling.Vectorspinor -> 1 | Coupling.Vector | Coupling.Massive_Vector -> 0 | Coupling.Scalar | Coupling.Tensor_1 | Coupling.Tensor_2 -> 0 | Coupling.BRS f -> fermion_of_lorentz f module Q = Algebra.Q module QC = Algebra.QC let dummy_tensor3 = Coupling.Scalar_Scalar_Scalar 1 let dummy_tensor4 = Coupling.Scalar4 1 let triplet p = (p.(0), p.(1), p.(2)) let quartet p = (p.(0), p.(1), p.(2), p.(3)) let half_times q1 q2 = Q.mul (Q.make 1 2) (Q.mul q1 q2) let name g = g.UFO_Coupling.name let fractional_coupling g r = let g = name g in match Q.to_ratio r with | 0, _ -> "0.0_default" | 1, 1 -> g | -1, 1 -> Printf.sprintf "(-%s)" g | n, 1 -> Printf.sprintf "(%d*%s)" n g | 1, d -> Printf.sprintf "(%s/%d)" g d | -1, d -> Printf.sprintf "(-%s/%d)" g d | n, d -> Printf.sprintf "(%d*%s/%d)" n g d let lorentz_of_symbol model symbol = try SMap.find symbol model.lorentz with | Not_found -> invalid_arg ("lorentz_of_symbol: " ^ symbol) let lorentz_UFO_of_symbol model symbol = try SMap.find symbol model.lorentz_UFO with | Not_found -> invalid_arg ("lorentz_UFO_of_symbol: " ^ symbol) let coupling_of_symbol model symbol = try SMap.find symbol model.couplings with | Not_found -> invalid_arg ("coupling_of_symbol: " ^ symbol) let spin_triplet model name = match (lorentz_of_symbol model name).Lorentz.spins with | Lorentz.Unique [|s0; s1; s2|] -> (s0, s1, s2) | Lorentz.Unique _ -> invalid_arg "spin_triplet: wrong number of spins" | Lorentz.Unused -> invalid_arg "spin_triplet: Unused" | Lorentz.Ambiguous _ -> invalid_arg "spin_triplet: Ambiguous" let spin_quartet model name = match (lorentz_of_symbol model name).Lorentz.spins with | Lorentz.Unique [|s0; s1; s2; s3|] -> (s0, s1, s2, s3) | Lorentz.Unique _ -> invalid_arg "spin_quartet: wrong number of spins" | Lorentz.Unused -> invalid_arg "spin_quartet: Unused" | Lorentz.Ambiguous _ -> invalid_arg "spin_quartet: Ambiguous" let spin_multiplet model name = match (lorentz_of_symbol model name).Lorentz.spins with | Lorentz.Unique sarray -> sarray | Lorentz.Unused -> invalid_arg "spin_multiplet: Unused" | Lorentz.Ambiguous _ -> invalid_arg "spin_multiplet: Ambiguous" (* If we have reason to belive that a $\delta_{ab}$-vertex is an effective $\tr(T_aT_b)$-vertex generated at loop level, like~$gg\to H\ldots$ in the SM, we should interpret it as such and use the expression~(6.2) from~\cite{Kilian:2012pz}. *) (* AFAIK, there is no way to distinguish these cases directly in a UFO file. Instead we rely in a heuristic, in which each massless color octet vector particle or ghost is a gluon and colorless scalars are potential Higgses. *) let is_massless p = match ThoString.uppercase p.Particle.mass with | "ZERO" -> true | _ -> false let is_gluon model f = let p = model.particle_array.(f) in match UFOx.Color.omega p.Particle.color, UFOx.Lorentz.omega p.Particle.spin with | Color.AdjSUN _, Coupling.Vector -> is_massless p | Color.AdjSUN _, Coupling.Scalar -> if p.Particle.ghost_number <> 0 then is_massless p else false | _ -> false let is_color_singlet model f = let p = model.particle_array.(f) in match UFOx.Color.omega p.Particle.color with | Color.Singlet -> true | _ -> false let is_higgs_gluon_vertex model p adjoints = if Array.length p > List.length adjoints then List.for_all (fun (i, p) -> if List.mem i adjoints then is_gluon model p else is_color_singlet model p) (ThoList.enumerate 1 (Array.to_list p)) else false let delta8_heuristics model p a b = if is_higgs_gluon_vertex model p [a; b] then Color.Vertex.delta8_loop a b else Color.Vertex.delta8 a b let verbatim_higgs_glue = ref false let translate_color_atom model p = function | UFOx.Color_Atom.Identity (i, j) -> Color.Vertex.delta3 i j | UFOx.Color_Atom.Identity8 (a, b) -> if !verbatim_higgs_glue then Color.Vertex.delta8 a b else delta8_heuristics model p a b | UFOx.Color_Atom.T (a, i, j) -> Color.Vertex.t a i j | UFOx.Color_Atom.F (a, b, c) -> Color.Vertex.f a b c | UFOx.Color_Atom.D (a, b, c) -> Color.Vertex.d a b c | UFOx.Color_Atom.Epsilon (i, j, k) -> Color.Vertex.epsilon i j k | UFOx.Color_Atom.EpsilonBar (i, j, k) -> Color.Vertex.epsilonbar i j k | UFOx.Color_Atom.T6 (a, i, j) -> Color.Vertex.t6 a i j | UFOx.Color_Atom.K6 (i, j, k) -> Color.Vertex.k6 i j k | UFOx.Color_Atom.K6Bar (i, j, k) -> Color.Vertex.k6bar i j k let translate_color_term model p = function | [], q -> Color.Vertex.scale q Color.Vertex.unit | [atom], q -> Color.Vertex.scale q (translate_color_atom model p atom) | atoms, q -> let atoms = List.map (translate_color_atom model p) atoms in Color.Vertex.scale q (Color.Vertex.multiply atoms) let translate_color model p terms = match terms with | [] -> invalid_arg "translate_color: empty" | [ term ] -> translate_color_term model p term | terms -> Color.Vertex.sum (List.map (translate_color_term model p) terms) let translate_coupling_1 model p lcc = let l = lcc.Vertex.lorentz in let s = Array.to_list (spin_multiplet model l) and fl = (SMap.find l model.lorentz).Lorentz.fermion_lines and c = name (coupling_of_symbol model lcc.Vertex.coupling) in match lcc.Vertex.color with | UFOx.Color.Linear color -> let col = translate_color model p color in (Array.to_list p, Coupling.UFO (QC.unit, l, s, fl, col), c) | UFOx.Color.Ratios _ as color -> invalid_arg ("UFO.Model.translate_coupling: invalid color structure" ^ UFOx.Color.to_string color) let translate_coupling model p lcc = List.map (translate_coupling_1 model p) lcc let long_flavors = ref false module type Lookup = sig type f = private { flavors : flavor list; flavor_of_string : string -> flavor; flavor_of_symbol : string -> flavor; particle : flavor -> Particle.t; flavor_symbol : flavor -> string; conjugate : flavor -> flavor } type flavor_format = | Long | Decimal | Hexadecimal val flavor_format : flavor_format ref val of_model : t -> f end module Lookup : Lookup = struct type f = { flavors : flavor list; flavor_of_string : string -> flavor; flavor_of_symbol : string -> flavor; particle : flavor -> Particle.t; flavor_symbol : flavor -> string; conjugate : flavor -> flavor } type flavor_format = | Long | Decimal | Hexadecimal let flavor_format = ref Hexadecimal let conjugate_of_particle_array particles = Array.init (Array.length particles) (fun i -> let f' = Particle.conjugate particles.(i) in match ThoArray.match_all f' particles with | [i'] -> i' | [] -> invalid_arg ("no charge conjugate: " ^ f'.Particle.name) | _ -> invalid_arg ("multiple charge conjugates: " ^ f'.Particle.name)) let invert_flavor_array a = let table = SHash.create 37 in Array.iteri (fun i s -> SHash.add table s i) a; (fun name -> try SHash.find table name with | Not_found -> invalid_arg ("not found: " ^ name)) let digits base n = let rec digits' acc n = if n < 1 then acc else digits' (succ acc) (n / base) in if n < 0 then digits' 1 (-n) else if n = 0 then 1 else digits' 0 n let of_model model = let particle_array = Array.of_list (values model.particles) in let conjugate_array = conjugate_of_particle_array particle_array and name_array = Array.map (fun f -> f.Particle.name) particle_array and symbol_array = Array.of_list (keys model.particles) in let flavor_symbol f = begin match !flavor_format with | Long -> symbol_array.(f) | Decimal -> let w = digits 10 (Array.length particle_array - 1) in Printf.sprintf "%0*d" w f | Hexadecimal -> let w = digits 16 (Array.length particle_array - 1) in Printf.sprintf "%0*X" w f end in { flavors = ThoList.range 0 (Array.length particle_array - 1); flavor_of_string = invert_flavor_array name_array; flavor_of_symbol = invert_flavor_array symbol_array; particle = Array.get particle_array; flavor_symbol = flavor_symbol; conjugate = Array.get conjugate_array } end (* \begin{dubious} We appear to need to conjugate all flavors. Why??? \end{dubious} *) let translate_vertices model tables = let vn = List.fold_left (fun acc v -> let p = Array.map tables.Lookup.flavor_of_symbol v.Vertex.particles and lcc = v.Vertex.lcc in let p = Array.map conjugate p in (* FIXME: why? *) translate_coupling model p lcc @ acc) [] (values model.vertices) in ([], [], vn) let propagator_of_lorentz = function | Coupling.Scalar -> Coupling.Prop_Scalar | Coupling.Spinor -> Coupling.Prop_Spinor | Coupling.ConjSpinor -> Coupling.Prop_ConjSpinor | Coupling.Majorana -> Coupling.Prop_Majorana | Coupling.Maj_Ghost -> invalid_arg "UFO.Model.propagator_of_lorentz: SUSY ghosts do not propagate" | Coupling.Vector -> Coupling.Prop_Feynman | Coupling.Massive_Vector -> Coupling.Prop_Unitarity | Coupling.Tensor_2 -> Coupling.Prop_Tensor_2 | Coupling.Vectorspinor -> invalid_arg "UFO.Model.propagator_of_lorentz: Vectorspinor" | Coupling.Tensor_1 -> invalid_arg "UFO.Model.propagator_of_lorentz: Tensor_1" | Coupling.BRS _ -> invalid_arg "UFO.Model.propagator_of_lorentz: no BRST" let filter_unphysical model = let physical_particles = Particle.filter Particle.is_physical model.particles in let physical_particle_array = Array.of_list (values physical_particles) in let physical_vertices = Vertex.filter (not @@ (Vertex.contains model.particles (not @@ Particle.is_physical))) model.vertices in { model with particles = physical_particles; particle_array = physical_particle_array; vertices = physical_vertices } let whizard_constants = SSet.of_list [ "ZERO" ] let filter_constants parameters = List.filter (fun p -> not (SSet.mem (ThoString.uppercase p.Parameter.name) whizard_constants)) parameters let add_name set parameter = CSet.add parameter.Parameter.name set let hardcoded_parameters = CSet.of_list ["cmath.pi"] let missing_parameters input derived couplings = let input_parameters = List.fold_left add_name hardcoded_parameters input in let all_parameters = List.fold_left add_name input_parameters derived in let derived_dependencies = dependencies (List.map (fun p -> (p.Parameter.name, p.Parameter.value)) derived) in let coupling_dependencies = dependencies (List.map (fun p -> (p.UFO_Coupling.name, Expr p.UFO_Coupling.value)) (values couplings)) in let missing_input = CMap.filter (fun parameter derived_parameters -> not (CSet.mem parameter all_parameters)) derived_dependencies and missing = CMap.filter (fun parameter couplings -> not (CSet.mem parameter all_parameters)) coupling_dependencies in CMap.iter (fun parameter derived_parameters -> Printf.eprintf "UFO warning: undefined input parameter %s appears in derived \ parameters {%s}: will be added to the list of input parameters!\n" parameter (String.concat "; " (CSet.elements derived_parameters))) missing_input; CMap.iter (fun parameter couplings -> Printf.eprintf "UFO warning: undefined parameter %s appears in couplings {%s}: \ will be added to the list of input parameters!\n" parameter (String.concat "; " (CSet.elements couplings))) missing; keys_caseless missing_input @ keys_caseless missing let classify_parameters model = let compare_parameters p1 p2 = compare p1.Parameter.sequence p2.Parameter.sequence in let input, derived = List.fold_left (fun (input, derived) p -> match p.Parameter.nature with | Parameter.Internal -> (input, p :: derived) | Parameter.External -> begin match p.Parameter.ptype with | Parameter.Real -> () | Parameter.Complex -> Printf.eprintf "UFO warning: invalid complex declaration of input \ parameter `%s' ignored!\n" p.Parameter.name end; (p :: input, derived)) ([], []) (filter_constants (values model.parameters)) in let additional = missing_parameters input derived model.couplings in (List.sort compare_parameters input @ List.map Parameter.missing additional, List.sort compare_parameters derived) (*i List.iter (fun line -> Printf.eprintf "par: %s\n" line) (dependencies_to_strings derived_dependencies); List.iter (fun line -> Printf.eprintf "coupling: %s\n" line) (dependencies_to_strings coupling_dependencies); i*) let translate_name map name = try SMap.find name map with Not_found -> name let translate_input map p = (translate_name map p.Parameter.name, value_to_float p.Parameter.value) let alpha_s_half e = UFOx.Expr.substitute "aS" (UFOx.Expr.half "aS") e let alpha_s_half_etc map e = UFOx.Expr.rename (map_to_alist map) (alpha_s_half e) let translate_derived map p = let make_atom s = s in let c = make_atom (translate_name map p.Parameter.name) and v = value_to_coupling (alpha_s_half_etc map) make_atom p.Parameter.value in match p.Parameter.ptype with | Parameter.Real -> (Coupling.Real c, v) | Parameter.Complex -> (Coupling.Complex c, v) let translate_coupling_constant map c = let make_atom s = s in (Coupling.Complex c.UFO_Coupling.name, Coupling.Quot (value_to_coupling (alpha_s_half_etc map) make_atom (Expr c.UFO_Coupling.value), Coupling.I)) module Lowercase_Parameters = struct type elt = string type base = string let compare_elt = compare let compare_base = compare let pi = ThoString.lowercase end module Lowercase_Bundle = Bundle.Make (Lowercase_Parameters) let coupling_names model = SMap.fold (fun _ c acc -> c.UFO_Coupling.name :: acc) model.couplings [] let parameter_names model = SMap.fold (fun _ c acc -> c.Parameter.name :: acc) model.parameters [] let ambiguous_parameters model = let all_names = List.rev_append (coupling_names model) (parameter_names model) in let lc_bundle = Lowercase_Bundle.of_list all_names in let lc_set = List.fold_left (fun acc s -> SSet.add s acc) SSet.empty (Lowercase_Bundle.base lc_bundle) and ambiguities = List.filter (fun (_, names) -> List.length names > 1) (Lowercase_Bundle.fibers lc_bundle) in (lc_set, ambiguities) let disambiguate1 lc_set name = let rec disambiguate1' i = let name' = Printf.sprintf "%s_%d" name i in let lc_name' = ThoString.lowercase name' in if SSet.mem lc_name' lc_set then disambiguate1' (succ i) else (SSet.add lc_name' lc_set, name') in disambiguate1' 1 let disambiguate lc_set names = let _, replacements = List.fold_left (fun (lc_set', acc) name -> let lc_set'', name' = disambiguate1 lc_set' name in (lc_set'', SMap.add name name' acc)) (lc_set, SMap.empty) names in replacements let omegalib_names = ["u"; "ubar"; "v"; "vbar"; "eps"] let translate_parameters model = let lc_set, ambiguities = ambiguous_parameters model in let replacements = disambiguate lc_set (ThoList.flatmap snd ambiguities) in SMap.iter (Printf.eprintf "warning: case sensitive parameter names: renaming '%s' -> '%s'\n") replacements; let replacements = List.fold_left (fun acc name -> SMap.add name ("UFO_" ^ name) acc) replacements omegalib_names in let input_parameters, derived_parameters = classify_parameters model and couplings = values model.couplings in { Coupling.input = List.map (translate_input replacements) input_parameters; Coupling.derived = List.map (translate_derived replacements) derived_parameters @ List.map (translate_coupling_constant replacements) couplings; Coupling.derived_arrays = [] } (* UFO requires us to look up the mass parameter to distinguish between massless and massive vectors. TODO: this is a candidate for another lookup table. *) let lorentz_of_particle p = match UFOx.Lorentz.omega p.Particle.spin with | Coupling.Vector -> begin match ThoString.uppercase p.Particle.mass with | "ZERO" -> Coupling.Vector | _ -> Coupling.Massive_Vector end | s -> s type state = { directory : string; model : t } let initialized = ref None let is_initialized_from dir = match !initialized with | None -> false | Some state -> dir = state.directory let dump_raw = ref false let init dir = let model = filter_unphysical (parse_directory dir) in if !dump_raw then dump model; let tables = Lookup.of_model model in let vertices () = translate_vertices model tables in let particle f = tables.Lookup.particle f in let lorentz f = lorentz_of_particle (particle f) in let propagator f = let p = particle f in match p.Particle.propagator with | None -> propagator_of_lorentz (lorentz_of_particle p) | Some s -> Coupling.Prop_UFO s in let gauge_symbol () = "?GAUGE?" in let constant_symbol s = s in let parameters = translate_parameters model in M.setup ~color:(fun f -> UFOx.Color.omega (particle f).Particle.color) ~nc:(fun () -> model.nc) ~pdg:(fun f -> (particle f).Particle.pdg_code) ~lorentz ~propagator ~width:(fun f -> Coupling.Constant) ~goldstone:(fun f -> None) ~conjugate:tables.Lookup.conjugate ~fermion:(fun f -> fermion_of_lorentz (lorentz f)) ~vertices ~flavors:[("All Flavors", tables.Lookup.flavors)] ~parameters:(fun () -> parameters) ~flavor_of_string:tables.Lookup.flavor_of_string ~flavor_to_string:(fun f -> (particle f).Particle.name) ~flavor_to_TeX:(fun f -> (particle f).Particle.texname) ~flavor_symbol:tables.Lookup.flavor_symbol ~gauge_symbol ~mass_symbol:(fun f -> (particle f).Particle.mass) ~width_symbol:(fun f -> (particle f).Particle.width) ~constant_symbol; initialized := Some { directory = dir; model = model } let ufo_directory = ref Config.default_UFO_dir let load () = if is_initialized_from !ufo_directory then () else init !ufo_directory let include_all_fusions = ref false (* In case of Majorana spinors, also generate all combinations of charge conjugated fermion lines. The naming convention is to append \texttt{\_c}$nm$ if the $\gamma$-matrices of the fermion line $n\to m$ has been charge conjugated (this could become impractical for too many fermions at a vertex, but shouldn't matter in real life). *) (* \begin{dubious} To be decided: is it better (in the sense of \emph{easier to understand}, not efficiency) to permute first or to charge conjugate first? \end{dubious} *) + (* Here we alway generate \emph{all} charge conjugations, because + we treat \emph{all} fermions as Majorana fermion, if there + is at least one Majorana fermion in the model! *) + let is_majorana = function | Coupling.Majorana | Coupling.Vectorspinor | Coupling.Maj_Ghost -> true | _ -> false let name_spins_structure spins l = (l.Lorentz.name, spins, l.Lorentz.structure) let fusions_of_model ?only model = let include_fusion = match !include_all_fusions, only with | true, _ | false, None -> (fun name -> true) | false, Some names -> (fun name -> SSet.mem name names) in SMap.fold (fun name l acc -> if include_fusion name then List.fold_left (fun acc p -> let l' = Lorentz.permute p l in match l'.Lorentz.spins with | Lorentz.Unused -> acc | Lorentz.Unique spins -> if ThoArray.exists is_majorana spins then List.map (name_spins_structure spins) - (Lorentz.all_charge_conjugates l') + (Lorentz.required_charge_conjugates l') @ acc else name_spins_structure spins l' :: acc | Lorentz.Ambiguous _ -> failwith "fusions: Lorentz.Ambiguous") [] (Permutation.Default.cyclic l.Lorentz.n) @ acc else acc) model.lorentz [] let fusions ?only () = match !initialized with | None -> [] | Some { model = model } -> fusions_of_model ?only model let propagators_of_model ?only model = let include_propagator = match !include_all_fusions, only with | true, _ | false, None -> (fun name -> true) | false, Some names -> (fun name -> SSet.mem name names) in SMap.fold (fun name p acc -> if include_propagator name then (name, p) :: acc else acc) model.propagators [] let propagators ?only () = match !initialized with | None -> [] | Some { model = model } -> propagators_of_model ?only model let include_hadrons = ref true let ufo_majorana_warnings = [ "***************************************************"; "* *"; "* CAVEAT: *"; "* *"; "* These amplitudes have been computed for a *"; "* UFO model containing Majorana fermions. *"; "* This version of O'Mega contains some known *"; "* bugs for this case. It was released early at *"; "* the request of the Linear Collider community. *"; "* *"; "* These amplitudes MUST NOT be used for *"; "* publications without prior consulation *"; "* with the WHIZARD authors !!! *"; "* *"; "***************************************************" ] let caveats () = if !use_majorana_spinors then ufo_majorana_warnings else [] module Whizard : sig val write : unit -> unit end = struct let write_header dir = Printf.printf "# WHIZARD Model file derived from UFO directory\n"; Printf.printf "# '%s'\n\n" dir; List.iter (fun s -> Printf.printf "# %s\n" s) (M.caveats ()); Printf.printf "model \"%s\"\n\n" (Filename.basename dir) let write_input_parameters parameters = let open Parameter in Printf.printf "# Independent (input) Parameters\n"; List.iter (fun p -> Printf.printf "parameter %s = %s" p.name (value_to_numeric p.value); begin match p.lhablock, p.lhacode with | None, None -> () | Some name, Some (index :: indices) -> Printf.printf " slha_entry %s %d" name index; List.iter (fun i -> Printf.printf " %d" i) indices | Some name, None -> Printf.eprintf "UFO: parameter %s: slhablock %s without slhacode\n" p.name name | Some name, Some [] -> Printf.eprintf "UFO: parameter %s: slhablock %s with empty slhacode\n" p.name name | None, Some _ -> Printf.eprintf "UFO: parameter %s: slhacode without slhablock\n" p.name end; Printf.printf "\n") parameters; Printf.printf "\n" let write_derived_parameters parameters = let open Parameter in Printf.printf "# Dependent (derived) Parameters\n"; List.iter (fun p -> Printf.printf "derived %s = %s\n" p.name (value_to_expr alpha_s_half p.value)) parameters let write_particles particles = let open Particle in Printf.printf "# Particles\n"; Printf.printf "# NB: hypercharge assignments appear to be unreliable\n"; Printf.printf "# therefore we can't infer the isospin\n"; Printf.printf "# NB: parton-, gauge- & handedness are unavailable\n"; List.iter (fun p -> if not p.is_anti then begin Printf.printf "particle \"%s\" %d ### parton? gauge? left?\n" p.name p.pdg_code; Printf.printf " spin %s charge %s color %s ### isospin?\n" (UFOx.Lorentz.rep_to_string_whizard p.spin) (charge_to_string p.charge) (UFOx.Color.rep_to_string_whizard p.color); Printf.printf " name \"%s\"\n" p.name; if p.antiname <> p.name then Printf.printf " anti \"%s\"\n" p.antiname; Printf.printf " tex_name \"%s\"\n" p.texname; if p.antiname <> p.name then Printf.printf " tex_anti \"%s\"\n" p.antitexname; Printf.printf " mass %s width %s\n\n" p.mass p.width end) (values particles); Printf.printf "\n" let write_hadrons () = Printf.printf "# Hadrons (protons and beam remnants)\n"; Printf.printf "# NB: these are NOT part of the UFO model\n"; Printf.printf "# but added for WHIZARD's convenience!\n"; Printf.printf "particle PROTON 2212\n"; Printf.printf " spin 1/2 charge 1\n"; Printf.printf " name p \"p+\"\n"; Printf.printf " anti pbar \"p-\"\n"; Printf.printf "particle HADRON_REMNANT 90\n"; Printf.printf " name hr\n"; Printf.printf " tex_name \"had_r\"\n"; Printf.printf "particle HADRON_REMNANT_SINGLET 91\n"; Printf.printf " name hr1\n"; Printf.printf " tex_name \"had_r^{(1)}\"\n"; Printf.printf "particle HADRON_REMNANT_TRIPLET 92\n"; Printf.printf " color 3\n"; Printf.printf " name hr3\n"; Printf.printf " tex_name \"had_r^{(3)}\"\n"; Printf.printf " anti hr3bar\n"; Printf.printf " tex_anti \"had_r^{(\\bar 3)}\"\n"; Printf.printf "particle HADRON_REMNANT_OCTET 93\n"; Printf.printf " color 8\n"; Printf.printf " name hr8\n"; Printf.printf " tex_name \"had_r^{(8)}\"\n"; Printf.printf "\n" let write_vertices model vertices = Printf.printf "# Vertices (for phasespace generation only)\n"; Printf.printf "# NB: particles should be sorted increasing in mass.\n"; Printf.printf "# This is NOT implemented yet!\n"; List.iter (fun v -> let particles = String.concat " " (List.map (fun s -> "\"" ^ (SMap.find s model.particles).Particle.name ^ "\"") (Array.to_list v.Vertex.particles)) in Printf.printf "vertex %s\n" particles) (values vertices); Printf.printf "\n" let write () = match !initialized with | None -> failwith "UFO.Whizard.write: UFO model not initialized" | Some { directory = dir; model = model } -> let input_parameters, derived_parameters = classify_parameters model in write_header dir; write_input_parameters input_parameters; write_derived_parameters derived_parameters; write_particles model.particles; if !include_hadrons then write_hadrons (); write_vertices model model.vertices; exit 0 end let options = Options.create [ ("UFO_dir", Arg.String (fun name -> ufo_directory := name), "UFO model directory (default: " ^ !ufo_directory ^ ")"); ("Majorana", Arg.Set use_majorana_spinors, "use Majorana spinors (must come _before_ exec!)"); ("divide_propagators_by_i", Arg.Set divide_propagators_by_i, "divide propagators by I (pre 2013 FeynRules convention)"); ("verbatim_Hg", Arg.Set verbatim_higgs_glue, "don't correct the color flows for effective Higgs Gluon couplings"); ("write_WHIZARD", Arg.Unit Whizard.write, "write the WHIZARD model file (required once per model)"); ("long_flavors", Arg.Unit (fun () -> Lookup.flavor_format := Lookup.Long), "write use the UFO flavor names instead of integers"); ("dump", Arg.Set dump_raw, "dump UFO model for debugging the parser (must come _before_ exec!)"); ("all_fusions", Arg.Set include_all_fusions, "include all fusions in the fortran module"); ("no_hadrons", Arg.Clear include_hadrons, "don't add any particle not in the UFO file"); ("add_hadrons", Arg.Set include_hadrons, "add protons and beam remants for WHIZARD"); ("exec", Arg.Unit load, "load the UFO model files (required _before_ using particles names)"); ("help", Arg.Unit (fun () -> prerr_endline "..."), "print information on the model")] end module type Fortran_Target = sig val fuse : Algebra.QC.t -> string -> Coupling.lorentzn -> Coupling.fermion_lines -> string -> string list -> string list -> Coupling.fusen -> unit val lorentz_module : ?only:SSet.t -> ?name:string -> ?fortran_module:string -> ?parameter_module:string -> Format_Fortran.formatter -> unit -> unit end module Targets = struct module Fortran : Fortran_Target = struct open Format_Fortran let fuse = UFO_targets.Fortran.fuse let lorentz_functions ff fusions () = List.iter (fun (name, s, l) -> UFO_targets.Fortran.lorentz ff name s l) fusions let propagator_functions ff parameter_module propagators () = List.iter (fun (name, p) -> UFO_targets.Fortran.propagator ff name parameter_module p.Propagator.variables p.Propagator.spins p.Propagator.numerator p.Propagator.denominator) propagators let lorentz_module ?only ?(name="omega_amplitude_ufo") ?(fortran_module="omega95") ?(parameter_module="parameter_module") ff () = let printf fmt = fprintf ff fmt and nl = pp_newline ff in printf "module %s" name; nl (); printf " use kinds"; nl (); printf " use %s" fortran_module; nl (); printf " implicit none"; nl (); printf " private"; nl (); let fusions = Model.fusions ?only () and propagators = Model.propagators () in List.iter (fun (name, _, _) -> printf " public :: %s" name; nl ()) fusions; List.iter (fun (name, _) -> printf " public :: pr_U_%s" name; nl ()) propagators; UFO_targets.Fortran.eps4_g4_g44_decl ff (); UFO_targets.Fortran.eps4_g4_g44_init ff (); printf "contains"; nl (); UFO_targets.Fortran.inner_product_functions ff (); lorentz_functions ff fusions (); propagator_functions ff parameter_module propagators (); printf "end module %s" name; nl (); pp_flush ff () end end module type Test = sig val suite : OUnit.test end module Test : Test = struct open OUnit let lexer s = UFO_lexer.token (UFO_lexer.init_position "" (Lexing.from_string s)) let suite_lexer_escapes = "escapes" >::: [ "single-quote" >:: (fun () -> assert_equal (UFO_parser.STRING "a'b'c") (lexer "'a\\'b\\'c'")); "unterminated" >:: (fun () -> assert_raises End_of_file (fun () -> lexer "'a\\'b\\'c")) ] let suite_lexer = "lexer" >::: [suite_lexer_escapes] let suite = "UFO" >::: [suite_lexer] end Index: trunk/omega/src/UFOx.mli =================================================================== --- trunk/omega/src/UFOx.mli (revision 8491) +++ trunk/omega/src/UFOx.mli (revision 8492) @@ -1,249 +1,250 @@ (* vertex.mli -- Copyright (C) 1999-2021 by Wolfgang Kilian Thorsten Ohl Juergen Reuter with contributions from Christian Speckner WHIZARD 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 2, or (at your option) any later version. WHIZARD 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, write to the Free Software Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. *) module Expr : sig type t val of_string : string -> t val of_strings : string list -> t val substitute : string -> t -> t -> t val rename : (string * string) list -> t -> t val half : string -> t val variables : t -> Sets.String_Caseless.t val functions : t -> Sets.String_Caseless.t end module Value : sig type t val of_expr : Expr.t -> t val to_string : t -> string val to_coupling : (string -> 'b) -> t -> 'b Coupling.expr end (* \begin{dubious} UFO represents rank-2 indices $(i,j)$ as $1000\cdot j + i$. This should be replaced by a proper union type eventually. Unfortunately, this requires many changes in the [Atom]s in [UFOx]. Therefore, we try a quick'n'dirty proof of principle first. \end{dubious} *) module type Index = sig type t = int val position : t -> int val factor : t -> int val unpack : t -> int * int val pack : int -> int -> t val map_position : (int -> int) -> t -> t val to_string : t -> string val list_to_string : t list -> string (* Indices are represented by a pair [int * 'r], where ['r] denotes the representation the index belongs to. *) (* [free indices] returns all free indices in the list [indices], i.\,e.~all positive indices. *) val free : (t * 'r) list -> (t * 'r) list (* [summation indices] returns all summation indices in the list [indices], i.\,e.~all negative indices. *) val summation : (t * 'r) list -> (t * 'r) list val classes_to_string : ('r -> string) -> (t * 'r) list -> string (* Generate summation indices, starting from~$-1001$. TODO: check that there are no clashes with explicitely named indices. *) val fresh_summation : unit -> t val named_summation : string -> unit -> t end module Index : Index module type Tensor = sig type atom (* A tensor is a linear combination of products of [atom]s with rational coefficients. The following could be refined by introducing [scalar] atoms and restricting the denominators to [(scalar list * Algebra.QC.t) list]. At the moment, this restriction is implemented dynamically by [of_expr] and not statically in the type system. Polymorphic variants appear to be the right tool, either directly or as phantom types. However, this is certainly only \textit{nice-to-have} and is not essential. *) type 'a linear = ('a list * Algebra.QC.t) list type t = | Linear of atom linear | Ratios of (atom linear * atom linear) list (* We might need to replace atoms if the syntax is not context free. *) val map_atoms : (atom -> atom) -> t -> t (* We need to rename indices to implement permutations \ldots *) val map_indices : (int -> int) -> t -> t (* \ldots{} but in order to to clean up inconsistencies in the syntax of \texttt{lorentz.py} and \texttt{propagators.py} we also need to rename indices without touching the second argument of \texttt{P}, the argument of \texttt{Mass} etc. *) val rename_indices : (int -> int) -> t -> t (* We need scale coefficients. *) val map_coeff : (Algebra.QC.t -> Algebra.QC.t) -> t -> t (* Try to contract adjacent pairs of [atoms] as allowed but [Atom.contract_pair]. This is not exhaustive, but helps a lot with invariant squares of momenta in applications of [Lorentz]. *) val contract_pairs : t -> t (* The list of variable referenced in the tensor expression, that will need to be imported by the numerical code. *) val variables : t -> string list (* Parsing and unparsing. Lists of [string]s are interpreted as sums. *) val of_expr : UFOx_syntax.expr -> t val of_string : string -> t val of_strings : string list -> t val to_string : t -> string (* The supported representations. *) type r val classify_indices : t -> (int * r) list val rep_to_string : r -> string val rep_to_string_whizard : r -> string val rep_of_int : bool -> int -> r val rep_conjugate : r -> r val rep_trivial : r -> bool (* There is not a 1-to-1 mapping between the representations in the model files and the representations used by O'Mega, e.\,g.~in [Coupling.lorentz]. We might need to use heuristics. *) type r_omega val omega : r -> r_omega end module type Atom = sig type t val map_indices : (int -> int) -> t -> t val rename_indices : (int -> int) -> t -> t val contract_pair : t -> t -> t option val variable : t -> string option val scalar : t -> bool val is_unit : t -> bool val invertible : t -> bool val invert : t -> t val of_expr : string -> UFOx_syntax.expr list -> t list val to_string : t -> string type r val classify_indices : t list -> (int * r) list val disambiguate_indices : t list -> t list val rep_to_string : r -> string val rep_to_string_whizard : r -> string val rep_of_int : bool -> int -> r val rep_conjugate : r -> r val rep_trivial : r -> bool type r_omega val omega : r -> r_omega end module type Lorentz_Atom = sig type dirac = private | C of int * int | Gamma of int * int * int | Gamma5 of int * int | Identity of int * int | ProjP of int * int | ProjM of int * int | Sigma of int * int * int * int type vector = (* private *) | Epsilon of int * int * int * int | Metric of int * int | P of int * int type scalar = (* private *) | Mass of int | Width of int | P2 of int | P12 of int * int | Variable of string | Coeff of Value.t type t = (* private *) | Dirac of dirac | Vector of vector | Scalar of scalar | Inverse of scalar + val map_indices_scalar : (int -> int) -> scalar -> scalar val map_indices_vector : (int -> int) -> vector -> vector val rename_indices_vector : (int -> int) -> vector -> vector end module Lorentz_Atom : Lorentz_Atom module Lorentz : Tensor with type atom = Lorentz_Atom.t and type r_omega = Coupling.lorentz module type Color_Atom = sig type t = (* private *) | Identity of int * int | Identity8 of int * int | T of int * int * int | F of int * int * int | D of int * int * int | Epsilon of int * int * int | EpsilonBar of int * int * int | T6 of int * int * int | K6 of int * int * int | K6Bar of int * int * int end module Color_Atom : Color_Atom module Color : Tensor with type atom = Color_Atom.t and type r_omega = Color.t module type Test = sig val example : unit -> unit val suite : OUnit.test end Index: trunk/omega/src/omega.ocamlinit =================================================================== --- trunk/omega/src/omega.ocamlinit (revision 8491) +++ trunk/omega/src/omega.ocamlinit (revision 8492) @@ -1,23 +1,26 @@ (* This is for running O'Mega inside the utop O'Caml toplevel in order to debug some modules. *) #install_printer Algebra.Laurent.pp;; #install_printer Color.Birdtracks.pp;; #install_printer Color.SU3.pp;; #install_printer Color.U3.pp;; +#install_printer Dirac.Chiral.pp;; +#install_printer Dirac.Dirac.pp;; +#install_printer Dirac.Majorana.pp;; module A = Algebra.Laurent;; module SU3 = Color.SU3;; module U3 = Color.U3;; open SU3;; open BinOps;; (* parse and unparse *) let pnup spins s = let t = UFOx.Lorentz.of_string s in String.concat " >>>> " [s; UFOx.Lorentz.to_string t; UFO_Lorentz.to_string (UFO_Lorentz.parse spins t)];; let pnup1 spin s = pnup [spin; spin] s;; Index: trunk/omega/src/compare_majorana_UFO.sh =================================================================== --- trunk/omega/src/compare_majorana_UFO.sh (revision 8491) +++ trunk/omega/src/compare_majorana_UFO.sh (revision 8492) @@ -1,45 +1,46 @@ #! /bin/sh ######################################################################## # This script is for developers only and needs not to be portable. # This script takes TO's directory structure for granted. ######################################################################## # tl;dr : don't try this at home, kids ;) ######################################################################## case "$#" in 2) mode="$1" process="$2" ;; *) echo "usage: $0 [-scatter|-decay] process" 1>&2 exit 2 ;; esac jobs=12 width=1000 width=80 root=$HOME/physics/whizard build=$root/_build/default OCAMLFLAGS="-w -D -warn-error +P" make OCAMLFLAGS="$OCAMLFLAGS" -j $jobs -C $build/omega/src || exit 1 make -j $jobs -C $build/omega/bin \ omega_UFO.opt omega_UFO_Majorana.opt || exit 1 omega_dirac="$build/omega/bin/omega_UFO_Dirac.opt -model:exec -target:width $width" omega_majorana="$build/omega/bin/omega_UFO_Majorana.opt -model:Majorana -model:exec -target:width $width" omega_dirac="$build/omega/bin/omega_UFO.opt -model:exec -target:width $width" omega_majorana="$build/omega/bin/omega_UFO.opt -model:Majorana -model:exec -target:width $width" $omega_dirac "$mode" "$process" > omega_amplitude_dirac.f90 2>/dev/null $omega_majorana "$mode" "$process" > omega_amplitude_majorana.f90 2>/dev/null if grep -q 'integer, parameter :: n_prt = 0' omega_amplitude_dirac.f90; then echo "O'Mega Dirac empty: $mode $process" 1>&2; elif grep -q 'integer, parameter :: n_prt = 0' omega_amplitude_majorana.f90; then echo "O'Mega Majorana empty: $mode $process" 1>&2; else - diff -u omega_amplitude_dirac.f90 omega_amplitude_majorana.f90 + wdiff -n omega_amplitude_dirac.f90 omega_amplitude_majorana.f90 \ + | colordiff --difftype=wdiff | sed 's/\({+\|+}\|\[-\|-\]\)//g' fi Index: trunk/omega/src/dirac.ml =================================================================== --- trunk/omega/src/dirac.ml (revision 8491) +++ trunk/omega/src/dirac.ml (revision 8492) @@ -1,339 +1,493 @@ (* Dirac.ml -- Copyright (C) 1999-2017 by Wolfgang Kilian Thorsten Ohl Juergen Reuter with contributions from Christian Speckner WHIZARD 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 2, or (at your option) any later version. WHIZARD 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, write to the Free Software Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. *) (* \thocwmodulesection{Dirac $\gamma$-matrices} *) module type T = sig type qc = Algebra.QC.t type t = qc array array val zero : qc val one : qc val minus_one : qc val i : qc val minus_i : qc val unit : t val null : t val gamma0 : t val gamma1 : t val gamma2 : t val gamma3 : t val gamma5 : t val gamma : t array val cc : t val neg : t -> t val add : t -> t -> t val sub : t -> t -> t val mul : t -> t -> t val times : qc -> t -> t val transpose : t -> t val adjoint : t -> t val conj : t -> t val product : t list -> t + val pp : Format.formatter -> t -> unit val test_suite : OUnit.test end +(* \thocwmodulesubsection{Matrices with complex rational entries} *) + +module Q = Algebra.Q +module QC = Algebra.QC + +type complex_rational = QC.t + +let zero = QC.null +let one = QC.unit +let minus_one = QC.neg one +let i = QC.make Q.null Q.unit +let minus_i = QC.conj i + +type matrix = complex_rational array array + (* \thocwmodulesubsection{Dirac $\gamma$-matrices} *) -module Chiral : T = - struct +module type R = + sig + type qc = complex_rational + type t = matrix + val gamma0 : t + val gamma1 : t + val gamma2 : t + val gamma3 : t + val gamma5 : t + val cc : t + val cc_is_i_gamma2_gamma_0 : bool + end - module Q = Algebra.Q - module QC = Algebra.QC +module Make (R : R) : T = + struct - type qc = QC.t - type t = qc array array + type qc = complex_rational + type t = matrix - let zero = QC.null - let one = QC.unit - let minus_one = QC.neg one - let i = QC.make Q.null Q.unit - let minus_i = QC.conj i + let zero = zero + let one = one + let minus_one = minus_one + let i = i + let minus_i = minus_i let null = [| [| zero; zero; zero; zero |]; [| zero; zero; zero; zero |]; [| zero; zero; zero; zero |]; [| zero; zero; zero; zero |] |] let unit = [| [| one; zero; zero; zero |]; [| zero; one; zero; zero |]; [| zero; zero; one; zero |]; [| zero; zero; zero; one |] |] - let gamma0 = - [| [| zero; zero; one; zero |]; - [| zero; zero; zero; one |]; - [| one; zero; zero; zero |]; - [| zero; one; zero; zero |] |] - - let gamma1 = - [| [| zero; zero; zero; one |]; - [| zero; zero; one; zero |]; - [| zero; minus_one; zero; zero |]; - [| minus_one; zero; zero; zero |] |] - - let gamma2 = - [| [| zero; zero; zero; minus_i |]; - [| zero; zero; i; zero |]; - [| zero; i; zero; zero |]; - [| minus_i; zero; zero; zero |] |] - - let gamma3 = - [| [| zero; zero; one; zero |]; - [| zero; zero; zero; minus_one |]; - [| minus_one; zero; zero; zero |]; - [| zero; one; zero; zero |] |] - - let gamma5 = - [| [| minus_one; zero; zero; zero |]; - [| zero; minus_one; zero; zero |]; - [| zero; zero; one; zero |]; - [| zero; zero; zero; one |] |] - - let gamma = - [| gamma0; gamma1; gamma2; gamma3 |] - - let cc = - [| [| zero; one; zero; zero |]; - [| minus_one; zero; zero; zero |]; - [| zero; zero; zero; minus_one |]; - [| zero; zero; one; zero |] |] + let gamma0 = R.gamma0 + let gamma1 = R.gamma1 + let gamma2 = R.gamma2 + let gamma3 = R.gamma3 + let gamma5 = R.gamma5 + let gamma = [| gamma0; gamma1; gamma2; gamma3 |] + let cc = R.cc let neg g = let g' = Array.make_matrix 4 4 zero in for i = 0 to 3 do for j = 0 to 3 do g'.(i).(j) <- QC.neg g.(i).(j) done done; g' let add g1 g2 = let g12 = Array.make_matrix 4 4 zero in for i = 0 to 3 do for j = 0 to 3 do g12.(i).(j) <- QC.add g1.(i).(j) g2.(i).(j) done done; g12 let sub g1 g2 = let g12 = Array.make_matrix 4 4 zero in for i = 0 to 3 do for j = 0 to 3 do g12.(i).(j) <- QC.sub g1.(i).(j) g2.(i).(j) done done; g12 let mul g1 g2 = let g12 = Array.make_matrix 4 4 zero in for i = 0 to 3 do for k = 0 to 3 do for j = 0 to 3 do g12.(i).(k) <- QC.add g12.(i).(k) (QC.mul g1.(i).(j) g2.(j).(k)) done done done; g12 let times q g = let g' = Array.make_matrix 4 4 zero in for i = 0 to 3 do for j = 0 to 3 do g'.(i).(j) <- QC.mul q g.(i).(j) done done; g' let transpose g = let g' = Array.make_matrix 4 4 zero in for i = 0 to 3 do for j = 0 to 3 do g'.(i).(j) <- g.(j).(i) done done; g' let adjoint g = let g' = Array.make_matrix 4 4 zero in for i = 0 to 3 do for j = 0 to 3 do g'.(i).(j) <- QC.conj g.(j).(i) done done; g' let conj g = let g' = Array.make_matrix 4 4 zero in for i = 0 to 3 do for j = 0 to 3 do g'.(i).(j) <- QC.conj g.(i).(j) done done; g' let product glist = List.fold_right mul glist unit + let pp fmt g = + let pp_row i = + for j = 0 to 3 do + Format.fprintf fmt " %8s" (QC.to_string g.(i).(j)) + done in + Format.fprintf fmt "\n /"; + pp_row 0; + Format.fprintf fmt " \\\n"; + for i = 1 to 2 do + Format.fprintf fmt " |"; + pp_row i; + Format.fprintf fmt " |\n" + done; + Format.fprintf fmt " \\"; + pp_row 3; + Format.fprintf fmt " /\n" + open OUnit let two = QC.make (Q.make 2 1) Q.null let half = QC.make (Q.make 1 2) Q.null let two_unit = times two unit let ac_lhs mu nu = add (mul gamma.(mu) gamma.(nu)) (mul gamma.(nu) gamma.(mu)) let ac_rhs mu nu = if mu = nu then if mu = 0 then two_unit else neg two_unit else null let test_ac mu nu = (ac_lhs mu nu) = (ac_rhs mu nu) let ac_lhs_all = let lhs = Array.make_matrix 4 4 null in for mu = 0 to 3 do for nu = 0 to 3 do lhs.(mu).(nu) <- ac_lhs mu nu done done; lhs let ac_rhs_all = let rhs = Array.make_matrix 4 4 null in for mu = 0 to 3 do for nu = 0 to 3 do rhs.(mu).(nu) <- ac_rhs mu nu done done; rhs let dump2 lhs rhs = for i = 0 to 3 do for j = 0 to 3 do Printf.printf " i = %d, j =%d: %s + %s*I | %s + %s*I\n" i j (Q.to_string (QC.real lhs.(i).(j))) (Q.to_string (QC.imag lhs.(i).(j))) (Q.to_string (QC.real rhs.(i).(j))) (Q.to_string (QC.imag rhs.(i).(j))) done done let dump2_all lhs rhs = for mu = 0 to 3 do for nu = 0 to 3 do Printf.printf "mu = %d, nu =%d: \n" mu nu; dump2 lhs.(mu).(nu) rhs.(mu).(nu) done done let anticommute = "anticommutation relations" >:: (fun () -> assert_bool "" (if ac_lhs_all = ac_rhs_all then true else begin dump2_all ac_lhs_all ac_rhs_all; false end)) let equal_or_dump2 lhs rhs = if lhs = rhs then true else begin dump2 lhs rhs; false end let gamma5_def = "gamma5" >:: (fun () -> assert_bool "definition" (equal_or_dump2 gamma5 (times i (product [gamma0; gamma1; gamma2; gamma3])))) let self_adjoint = "(anti)selfadjointness" >::: [ "gamma0" >:: (fun () -> assert_bool "self" (equal_or_dump2 gamma0 (adjoint gamma0))); "gamma1" >:: (fun () -> assert_bool "anti" (equal_or_dump2 gamma1 (neg (adjoint gamma1)))); "gamma2" >:: (fun () -> assert_bool "anti" (equal_or_dump2 gamma2 (neg (adjoint gamma2)))); "gamma3" >:: (fun () -> assert_bool "anti" (equal_or_dump2 gamma3 (neg (adjoint gamma3)))); "gamma5" >:: (fun () -> assert_bool "self" (equal_or_dump2 gamma5 (adjoint gamma5))) ] + (* $C^2=-\mathbf{1}$ is \emph{not} true in all realizations, but + we assume it at several points in [UFO_Lorentz]. Therefore we + must test it here for all realizations that are implemented. *) let cc_inv = neg cc + (* Verify that $\Gamma^T= - C\Gamma C^{-1}$ using the actual + matrix transpose: *) let cc_gamma g = equal_or_dump2 (neg (transpose g)) (product [cc; g; cc_inv]) + (* Of course, $C=\ii\gamma^2\gamma^0$ is also not true in \emph{all} + realizations. But it is true in the chiral representation + used here and we can test it. *) let charge_conjugation = "charge conjugation" >::: [ "inverse" >:: (fun () -> assert_bool "" (equal_or_dump2 (mul cc cc_inv) unit)); + "gamma0" >:: (fun () -> assert_bool "" (cc_gamma gamma0)); "gamma1" >:: (fun () -> assert_bool "" (cc_gamma gamma1)); "gamma2" >:: (fun () -> assert_bool "" (cc_gamma gamma2)); "gamma3" >:: (fun () -> assert_bool "" (cc_gamma gamma3)); + "gamma5" >:: (fun () -> assert_bool "" (equal_or_dump2 (transpose gamma5) - (product [cc; gamma5; cc_inv]))) + (product [cc; gamma5; cc_inv]))); + "=i*g2*g0" >:: + (fun () -> + skip_if (not R.cc_is_i_gamma2_gamma_0) + "representation dependence"; + assert_bool "" (equal_or_dump2 cc (times i (mul gamma2 gamma0)))) ] let test_suite = "Dirac Matrices" >::: [anticommute; gamma5_def; self_adjoint; charge_conjugation] end +module Chiral_R : R = + struct + + type qc = complex_rational + type t = matrix + + let gamma0 = + [| [| zero; zero; one; zero |]; + [| zero; zero; zero; one |]; + [| one; zero; zero; zero |]; + [| zero; one; zero; zero |] |] + + let gamma1 = + [| [| zero; zero; zero; one |]; + [| zero; zero; one; zero |]; + [| zero; minus_one; zero; zero |]; + [| minus_one; zero; zero; zero |] |] + + let gamma2 = + [| [| zero; zero; zero; minus_i |]; + [| zero; zero; i; zero |]; + [| zero; i; zero; zero |]; + [| minus_i; zero; zero; zero |] |] + + let gamma3 = + [| [| zero; zero; one; zero |]; + [| zero; zero; zero; minus_one |]; + [| minus_one; zero; zero; zero |]; + [| zero; one; zero; zero |] |] + + let gamma5 = + [| [| minus_one; zero; zero; zero |]; + [| zero; minus_one; zero; zero |]; + [| zero; zero; one; zero |]; + [| zero; zero; zero; one |] |] + + let cc = + [| [| zero; one; zero; zero |]; + [| minus_one; zero; zero; zero |]; + [| zero; zero; zero; minus_one |]; + [| zero; zero; one; zero |] |] + + let cc_is_i_gamma2_gamma_0 = true + + end + +module Dirac_R : R = + struct + + type qc = complex_rational + type t = matrix + + let gamma0 = + [| [| one; zero; zero; zero |]; + [| zero; one; zero; zero |]; + [| zero; zero; minus_one; zero |]; + [| zero; zero; zero; minus_one |] |] + + let gamma1 = Chiral_R.gamma1 + let gamma2 = Chiral_R.gamma2 + let gamma3 = Chiral_R.gamma3 + + let gamma5 = + [| [| zero; zero; one; zero |]; + [| zero; zero; zero; one |]; + [| one; zero; zero; zero |]; + [| zero; one; zero; zero |] |] + + let cc = + [| [| zero; zero; zero; minus_one |]; + [| zero; zero; one; zero |]; + [| zero; minus_one; zero; zero |]; + [| one; zero; zero; zero |] |] + + let cc_is_i_gamma2_gamma_0 = true + + end + +module Majorana_R : R = + struct + + type qc = complex_rational + type t = matrix + + let gamma0 = + [| [| zero; zero; zero; minus_i |]; + [| zero; zero; i; zero |]; + [| zero; minus_i; zero; zero |]; + [| i; zero; zero; zero |] |] + + let gamma1 = + [| [| i; zero; zero; zero |]; + [| zero; minus_i; zero; zero |]; + [| zero; zero; i; zero |]; + [| zero; zero; zero; minus_i |] |] + + let gamma2 = + [| [| zero; zero; zero; i |]; + [| zero; zero; minus_i; zero |]; + [| zero; minus_i; zero; zero |]; + [| i; zero; zero; zero |] |] + + let gamma3 = + [| [| zero; minus_i; zero; zero |]; + [| minus_i; zero; zero; zero |]; + [| zero; zero; zero; minus_i |]; + [| zero; zero; minus_i; zero |] |] + + let gamma5 = + [| [| zero; minus_i; zero; zero |]; + [| i; zero; zero; zero |]; + [| zero; zero; zero; i |]; + [| zero; zero; minus_i; zero |] |] + + let cc = + [| [| zero; zero; zero; minus_one |]; + [| zero; zero; one; zero |]; + [| zero; minus_one; zero; zero |]; + [| one; zero; zero; zero |] |] + + let cc_is_i_gamma2_gamma_0 = false + + end + +module Chiral = Make (Chiral_R) +module Dirac = Make (Dirac_R) +module Majorana = Make (Majorana_R) Index: trunk/omega/src/algebra.ml =================================================================== --- trunk/omega/src/algebra.ml (revision 8491) +++ trunk/omega/src/algebra.ml (revision 8492) @@ -1,811 +1,811 @@ (* algebra.ml -- Copyright (C) 1999-2021 by Wolfgang Kilian Thorsten Ohl Juergen Reuter with contributions from Christian Speckner WHIZARD 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 2, or (at your option) any later version. WHIZARD 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, write to the Free Software Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. *) (* Avoid refering to [Pervasives.compare], because [Pervasives] will become [Stdlib.Pervasives] in O'Caml 4.07 and [Stdlib] in O'Caml 4.08. *) let pcompare = compare module type Test = sig val suite : OUnit.test end (* The terms will be small and there's no need to be fancy and/or efficient. It's more important to have a unique representation. *) module PM = Pmap.List (* \thocwmodulesection{Coefficients} *) (* For our algebra, we need coefficient rings. *) module type CRing = sig type t val null : t val unit : t val mul : t -> t -> t val add : t -> t -> t val sub : t -> t -> t val neg : t -> t val to_string : t -> string end (* And rational numbers provide a particularly important example: *) module type Rational = sig include CRing val is_null : t -> bool val is_unit : t -> bool val is_positive : t -> bool val is_negative : t -> bool val is_integer : t -> bool val make : int -> int -> t val abs : t -> t val inv : t -> t val div : t -> t -> t val pow : t -> int -> t val sum : t list -> t val to_ratio : t -> int * int val to_float : t -> float val to_integer : t -> int module Test : Test end (* \thocwmodulesection{Naive Rational Arithmetic} *) (* \begin{dubious} This \emph{is} dangerous and will overflow even for simple applications. The production code will have to be linked to a library for large integer arithmetic. \end{dubious} *) (* Anyway, here's Euclid's algorithm: *) let rec gcd i1 i2 = if i2 = 0 then abs i1 else gcd i2 (i1 mod i2) let lcm i1 i2 = (i1 / gcd i1 i2) * i2 module Small_Rational : Rational = struct type t = int * int let is_null (n, _) = (n = 0) let is_unit (n, d) = (n <> 0) && (n = d) let is_positive (n, d) = n * d > 0 let is_negative (n, d) = n * d < 0 let is_integer (n, d) = (gcd n d = d) let null = (0, 1) let unit = (1, 1) let make n d = let c = gcd n d in (n / c, d / c) let abs (n, d) = (abs n, abs d) let inv (n, d) = (d, n) let mul (n1, d1) (n2, d2) = make (n1 * n2) (d1 * d2) let div q1 q2 = mul q1 (inv q2) let add (n1, d1) (n2, d2) = make (n1 * d2 + n2 * d1) (d1 * d2) let sub (n1, d1) (n2, d2) = make (n1 * d2 - n2 * d1) (d1 * d2) let neg (n, d) = (- n, d) let rec pow q p = if p = 0 then unit else if p < 0 then pow (inv q) (-p) else mul q (pow q (pred p)) let sum qs = List.fold_right add qs null let to_ratio (n, d) = if d < 0 then (-n, -d) else (n, d) let to_float (n, d) = float n /. float d let to_string (n, d) = if d = 1 then Printf.sprintf "%d" n else let n, d = to_ratio (n, d) in Printf.sprintf "(%d/%d)" n d let to_integer (n, d) = if is_integer (n, d) then n else invalid_arg "Algebra.Small_Rational.to_integer" module Test = struct open OUnit let equal z1 z2 = is_null (sub z1 z2) let assert_equal_rational z1 z2 = assert_equal ~printer:to_string ~cmp:equal z1 z2 let suite_mul = "mul" >::: [ "1*1=1" >:: (fun () -> assert_equal_rational (mul unit unit) unit) ] let suite = "Algebra.Small_Rational" >::: [suite_mul] end end module Q = Small_Rational (* \thocwmodulesection{Rational Complex Numbers} *) module type QComplex = sig type q type t val make : q -> q -> t val null : t val unit : t val real : t -> q val imag : t -> q val conj : t -> t val neg : t -> t val add : t -> t -> t val sub : t -> t -> t val mul : t -> t -> t val inv : t -> t val div : t -> t -> t val pow : t -> int -> t val sum : t list -> t val is_null : t -> bool val is_unit : t -> bool val is_positive : t -> bool val is_negative : t -> bool val is_integer : t -> bool val is_real : t -> bool val to_string : t -> string module Test : Test end module QComplex (Q : Rational) : QComplex with type q = Q.t = struct type q = Q.t type t = { re : q; im : q } let make re im = { re; im } let null = { re = Q.null; im = Q.null } let unit = { re = Q.unit; im = Q.null } let real z = z.re let imag z = z.im let conj z = { re = z.re; im = Q.neg z.im } let neg z = { re = Q.neg z.re; im = Q.neg z.im } let add z1 z2 = { re = Q.add z1.re z2.re; im = Q.add z1.im z2.im } let sub z1 z2 = { re = Q.sub z1.re z2.re; im = Q.sub z1.im z2.im } let sum qs = List.fold_right add qs null (* Save one multiplication with respect to the standard formula \begin{equation} (x+iy)(u+iv) = \lbrack xu-yv\rbrack + i\lbrack(x+u)(y+v)-xu-yv\rbrack\, \end{equation} at the expense of one addition and two subtractions. *) let mul z1 z2 = let re12 = Q.mul z1.re z2.re and im12 = Q.mul z1.im z2.im in { re = Q.sub re12 im12; im = Q.sub (Q.sub (Q.mul (Q.add z1.re z1.im) (Q.add z2.re z2.im)) re12) im12 } let inv z = let modulus = Q.add (Q.mul z.re z.re) (Q.mul z.im z.im) in { re = Q.div z.re modulus; im = Q.div (Q.neg z.im) modulus } let div n d = mul (inv d) n let rec pow q p = if p = 0 then unit else if p < 0 then pow (inv q) (-p) else mul q (pow q (pred p)) let is_real q = Q.is_null q.im let test_real test q = is_real q && test q.re let is_null = test_real Q.is_null let is_unit = test_real Q.is_unit let is_positive = test_real Q.is_positive let is_negative = test_real Q.is_negative let is_integer = test_real Q.is_integer let q_to_string q = - (if Q.is_positive q then "+" else "-") ^ Q.to_string (Q.abs q) + (if Q.is_negative q then "-" else " ") ^ Q.to_string (Q.abs q) let to_string z = if Q.is_null z.im then q_to_string z.re else if Q.is_null z.re then if Q.is_unit z.im then - "+I" + " I" else if Q.is_unit (Q.neg z.im) then "-I" else q_to_string z.im ^ "*I" else Printf.sprintf "(%s%s*I)" (Q.to_string z.re) (q_to_string z.im) module Test = struct open OUnit let equal z1 z2 = is_null (sub z1 z2) let assert_equal_complex z1 z2 = assert_equal ~printer:to_string ~cmp:equal z1 z2 let suite_mul = "mul" >::: [ "1*1=1" >:: (fun () -> assert_equal_complex (mul unit unit) unit) ] let suite = "Algebra.QComplex" >::: [suite_mul] end end module QC = QComplex(Q) (* \thocwmodulesection{Laurent Polynomials} *) module type Laurent = sig type c type t val null : t val unit : t val is_null : t -> bool val atom : c -> int -> t val const : c -> t val scale : c -> t -> t val add : t -> t -> t val diff : t -> t -> t val sum : t list -> t val mul : t -> t -> t val product : t list -> t val pow : int -> t -> t val eval : c -> t -> c val to_string : string -> t -> string val compare : t -> t -> int val pp : Format.formatter -> t -> unit module Test : Test end module Laurent : Laurent with type c = QC.t = struct module IMap = Map.Make (struct type t = int let compare i1 i2 = pcompare i2 i1 end) type c = QC.t let qc_minus_one = QC.neg QC.unit type t = c IMap.t let null = IMap.empty let is_null l = IMap.is_empty l let atom qc n = if qc = QC.null then null else IMap.singleton n qc let const z = atom z 0 let unit = const QC.unit let add1 n qc l = try let qc' = QC.add qc (IMap.find n l) in if qc' = QC.null then IMap.remove n l else IMap.add n qc' l with | Not_found -> IMap.add n qc l let add l1 l2 = IMap.fold add1 l1 l2 let sum = function | [] -> null | [l] -> l | l :: l_list -> List.fold_left add l l_list let scale qc l = IMap.map (QC.mul qc) l let diff l1 l2 = add l1 (scale qc_minus_one l2) (* cf.~[Product.fold2_rev] *) let fold2 f l1 l2 acc = IMap.fold (fun n1 qc1 acc1 -> IMap.fold (fun n2 qc2 acc2 -> f n1 qc1 n2 qc2 acc2) l2 acc1) l1 acc let mul l1 l2 = fold2 (fun n1 qc1 n2 qc2 acc -> add1 (n1 + n2) (QC.mul qc1 qc2) acc) l1 l2 null let product = function | [] -> unit | [l] -> l | l :: l_list -> List.fold_left mul l l_list let poly_pow multiply one inverse n x = let rec pow' i x' acc = if i < 1 then acc else pow' (pred i) x' (multiply x' acc) in if n < 0 then let x' = inverse x in pow' (pred (-n)) x' x' else if n = 0 then one else pow' (pred n) x x let qc_pow n z = poly_pow QC.mul QC.unit QC.inv n z let pow n l = poly_pow mul unit (fun _ -> invalid_arg "Algebra.Laurent.pow") n l let q_to_string q = (if Q.is_positive q then "+" else "-") ^ Q.to_string (Q.abs q) let qc_to_string z = let r = QC.real z and i = QC.imag z in if Q.is_null i then q_to_string r else if Q.is_null r then if Q.is_unit i then "+I" else if Q.is_unit (Q.neg i) then "-I" else q_to_string i ^ "*I" else Printf.sprintf "(%s%s*I)" (Q.to_string r) (q_to_string i) let to_string1 name (n, qc) = if n = 0 then qc_to_string qc else if n = 1 then if QC.is_unit qc then name else if qc = qc_minus_one then "-" ^ name else Printf.sprintf "%s*%s" (qc_to_string qc) name else if n = -1 then Printf.sprintf "%s/%s" (qc_to_string qc) name else if n > 1 then if QC.is_unit qc then Printf.sprintf "%s^%d" name n else if qc = qc_minus_one then Printf.sprintf "-%s^%d" name n else Printf.sprintf "%s*%s^%d" (qc_to_string qc) name n else Printf.sprintf "%s/%s^%d" (qc_to_string qc) name (-n) let to_string name l = match IMap.bindings l with | [] -> "0" | l -> String.concat "" (List.map (to_string1 name) l) let pp fmt l = Format.fprintf fmt "%s" (to_string "N" l) let eval v l = IMap.fold (fun n qc acc -> QC.add (QC.mul qc (qc_pow n v)) acc) l QC.null let compare l1 l2 = pcompare (List.sort pcompare (IMap.bindings l1)) (List.sort pcompare (IMap.bindings l2)) let compare l1 l2 = IMap.compare pcompare l1 l2 module Test = struct open OUnit let equal l1 l2 = compare l1 l2 = 0 let assert_equal_laurent l1 l2 = assert_equal ~printer:(to_string "N") ~cmp:equal l1 l2 let suite_mul = "mul" >::: [ "(1+N)(1-N)=1-N^2" >:: (fun () -> assert_equal_laurent (sum [unit; atom (QC.neg QC.unit) 2]) (product [sum [unit; atom QC.unit 1]; sum [unit; atom (QC.neg QC.unit) 1]])); "(1+N)(1-1/N)=N-1/N" >:: (fun () -> assert_equal_laurent (sum [atom QC.unit 1; atom (QC.neg QC.unit) (-1)]) (product [sum [unit; atom QC.unit 1]; sum [unit; atom (QC.neg QC.unit) (-1)]])); ] let suite = "Algebra.Laurent" >::: [suite_mul] end end (* \thocwmodulesection{Expressions: Terms, Rings and Linear Combinations} *) (* The tensor algebra will be spanned by an abelian monoid: *) module type Term = sig type 'a t val unit : unit -> 'a t val is_unit : 'a t -> bool val atom : 'a -> 'a t val power : int -> 'a t -> 'a t val mul : 'a t -> 'a t -> 'a t val map : ('a -> 'b) -> 'a t -> 'b t val to_string : ('a -> string) -> 'a t -> string val derive : ('a -> 'b option) -> 'a t -> ('b * int * 'a t) list val product : 'a t list -> 'a t val atoms : 'a t -> 'a list end module type Ring = sig module C : Rational type 'a t val null : unit -> 'a t val unit : unit -> 'a t val is_null : 'a t -> bool val is_unit : 'a t -> bool val atom : 'a -> 'a t val scale : C.t -> 'a t -> 'a t val add : 'a t -> 'a t -> 'a t val sub : 'a t -> 'a t -> 'a t val mul : 'a t -> 'a t -> 'a t val neg : 'a t -> 'a t val derive_inner : ('a -> 'a t) -> 'a t -> 'a t (* this? *) val derive_inner' : ('a -> 'a t option) -> 'a t -> 'a t (* or that? *) val derive_outer : ('a -> 'b option) -> 'a t -> ('b * 'a t) list val sum : 'a t list -> 'a t val product : 'a t list -> 'a t val atoms : 'a t -> 'a list val to_string : ('a -> string) -> 'a t -> string end module type Linear = sig module C : Ring type ('a, 'c) t val null : unit -> ('a, 'c) t val atom : 'a -> ('a, 'c) t val singleton : 'c C.t -> 'a -> ('a, 'c) t val scale : 'c C.t -> ('a, 'c) t -> ('a, 'c) t val add : ('a, 'c) t -> ('a, 'c) t -> ('a, 'c) t val sub : ('a, 'c) t -> ('a, 'c) t -> ('a, 'c) t val partial : ('c -> ('a, 'c) t) -> 'c C.t -> ('a, 'c) t val linear : (('a, 'c) t * 'c C.t) list -> ('a, 'c) t val map : ('a -> 'c C.t -> ('b, 'd) t) -> ('a, 'c) t -> ('b, 'd) t val sum : ('a, 'c) t list -> ('a, 'c) t val atoms : ('a, 'c) t -> 'a list * 'c list val to_string : ('a -> string) -> ('c -> string) -> ('a, 'c) t -> string end module Term : Term = struct module M = PM type 'a t = ('a, int) M.t let unit () = M.empty let is_unit = M.is_empty let atom f = M.singleton f 1 let power p x = M.map (( * ) p) x let insert1 binop f p term = let p' = binop (try M.find compare f term with Not_found -> 0) p in if p' = 0 then M.remove compare f term else M.add compare f p' term let mul1 f p term = insert1 (+) f p term let mul x y = M.fold mul1 x y let map f term = M.fold (fun t -> mul1 (f t)) term M.empty let to_string fmt term = String.concat "*" (M.fold (fun f p acc -> (if p = 0 then "1" else if p = 1 then fmt f else "[" ^ fmt f ^ "]^" ^ string_of_int p) :: acc) term []) let derive derive1 x = M.fold (fun f p dx -> if p <> 0 then match derive1 f with | Some df -> (df, p, mul1 f (pred p) (M.remove compare f x)) :: dx | None -> dx else dx) x [] let product factors = List.fold_left mul (unit ()) factors let atoms t = List.map fst (PM.elements t) end module Make_Ring (C : Rational) (T : Term) : Ring = struct module C = C let one = C.unit module M = PM type 'a t = ('a T.t, C.t) M.t let null () = M.empty let is_null = M.is_empty let power t p = M.singleton t p let unit () = power (T.unit ()) one let is_unit t = unit () = t (* \begin{dubious} The following should be correct too, but produces to many false positives instead! What's going on? \end{dubious} *) let broken__is_unit t = match M.elements t with | [(t, p)] -> T.is_unit t || C.is_null p | _ -> false let atom t = power (T.atom t) one let scale c x = M.map (C.mul c) x let insert1 binop t c sum = let c' = binop (try M.find compare t sum with Not_found -> C.null) c in if C.is_null c' then M.remove compare t sum else M.add compare t c' sum let add x y = M.fold (insert1 C.add) x y let sub x y = M.fold (insert1 C.sub) y x (* One might be tempted to use [Product.outer_self M.fold] instead, but this would require us to combine~[tx] and~[cx] to~[(tx, cx)]. *) let fold2 f x y = M.fold (fun tx cx -> M.fold (f tx cx) y) x let mul x y = fold2 (fun tx cx ty cy -> insert1 C.add (T.mul tx ty) (C.mul cx cy)) x y (null ()) let neg x = sub (null ()) x let neg x = scale (C.neg C.unit) x (* Multiply the [derivatives] by [c] and add the result to [dx]. *) let add_derivatives derivatives c dx = List.fold_left (fun acc (df, dt_c, dt_t) -> add (mul df (power dt_t (C.mul c (C.make dt_c 1)))) acc) dx derivatives let derive_inner derive1 x = M.fold (fun t -> add_derivatives (T.derive (fun f -> Some (derive1 f)) t)) x (null ()) let derive_inner' derive1 x = M.fold (fun t -> add_derivatives (T.derive derive1 t)) x (null ()) let collect_derivatives derivatives c dx = List.fold_left (fun acc (df, dt_c, dt_t) -> (df, power dt_t (C.mul c (C.make dt_c 1))) :: acc) dx derivatives let derive_outer derive1 x = M.fold (fun t -> collect_derivatives (T.derive derive1 t)) x [] let sum terms = List.fold_left add (null ()) terms let product factors = List.fold_left mul (unit ()) factors let atoms t = ThoList.uniq (List.sort compare (ThoList.flatmap (fun (t, _) -> T.atoms t) (PM.elements t))) let to_string fmt sum = "(" ^ String.concat " + " (M.fold (fun t c acc -> if C.is_null c then acc else if C.is_unit c then T.to_string fmt t :: acc else if C.is_unit (C.neg c) then ("(-" ^ T.to_string fmt t ^ ")") :: acc else (C.to_string c ^ "*[" ^ T.to_string fmt t ^ "]") :: acc) sum []) ^ ")" end module Make_Linear (C : Ring) : Linear with module C = C = struct module C = C module M = PM type ('a, 'c) t = ('a, 'c C.t) M.t let null () = M.empty let is_null = M.is_empty let atom a = M.singleton a (C.unit ()) let singleton c a = M.singleton a c let scale c x = M.map (C.mul c) x let insert1 binop t c sum = let c' = binop (try M.find compare t sum with Not_found -> C.null ()) c in if C.is_null c' then M.remove compare t sum else M.add compare t c' sum let add x y = M.fold (insert1 C.add) x y let sub x y = M.fold (insert1 C.sub) y x let map f t = M.fold (fun a c -> add (f a c)) t M.empty let sum terms = List.fold_left add (null ()) terms let linear terms = List.fold_left (fun acc (a, c) -> add (scale c a) acc) (null ()) terms let partial derive t = let d t' = let dt' = derive t' in if is_null dt' then None else Some dt' in linear (C.derive_outer d t) let atoms t = let a, c = List.split (PM.elements t) in (a, ThoList.uniq (List.sort compare (ThoList.flatmap C.atoms c))) let to_string fmt cfmt sum = "(" ^ String.concat " + " (M.fold (fun t c acc -> if C.is_null c then acc else if C.is_unit c then fmt t :: acc else if C.is_unit (C.neg c) then ("(-" ^ fmt t ^ ")") :: acc else (C.to_string cfmt c ^ "*" ^ fmt t) :: acc) sum []) ^ ")" end (*i * Local Variables: * mode:caml * indent-tabs-mode:nil * page-delimiter:"^(\\* .*\n" * End: i*) Index: trunk/omega/src/UFO_targets.mli =================================================================== --- trunk/omega/src/UFO_targets.mli (revision 8491) +++ trunk/omega/src/UFO_targets.mli (revision 8492) @@ -1,76 +1,81 @@ (* UFO_targets.mli -- Copyright (C) 1999-2017 by Wolfgang Kilian Thorsten Ohl Juergen Reuter with contributions from Christian Speckner WHIZARD 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 2, or (at your option) any later version. WHIZARD 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, write to the Free Software Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. *) (* \thocwmodulesection{Generating Code for UFO Lorentz Structures} *) module type T = sig - (* NB: The [spins : int list] argument is \emph{not} sufficient + (* [lorentz ff name spins lorentz] writes the Fortran code + implementing the fusion corresponding to the Lorentz + structure [lorentz] to [ff]. + NB: The [spins : int list] element of [UFO.Lorentz.t] + from the UFO file is \emph{not} sufficient to determine the domain and codomain of the function. We - will need to inspect the flavors, where the Lorentz structure - is referenced. *) + had to inspect the flavors, where the Lorentz structure + is referenced to heuristically compute the [spins] + as a [Coupling.lorentz array] . *) val lorentz : Format_Fortran.formatter -> string -> Coupling.lorentz array -> UFO_Lorentz.t -> unit val propagator : Format_Fortran.formatter -> string -> string -> string list -> Coupling.lorentz * Coupling.lorentz -> UFO_Lorentz.t -> UFO_Lorentz.t -> unit (* [fusion_name name perm cc_list] forms a name for the fusion [name] with the permutations [perm] and charge conjugations applied to the fermion lines [cc_list]. *) val fusion_name : string -> Permutation.Default.t -> Coupling.fermion_lines -> string (* [fuse c v s fl g wfs ps fusion] fuses the wavefunctions named [wfs] with momenta named [ps] using the vertex named [v] with legs reordered according to [fusion]. The overall coupling constant named [g] is multiplied by the rational coefficient [c]. The list of spins [s] and the fermion lines [fl] are used for selecting the appropriately transformed version of the vertex [v]. *) val fuse : Algebra.QC.t -> string -> Coupling.lorentzn -> Coupling.fermion_lines -> string -> string list -> string list -> Coupling.fusen -> unit val eps4_g4_g44_decl : Format_Fortran.formatter -> unit -> unit val eps4_g4_g44_init : Format_Fortran.formatter -> unit -> unit val inner_product_functions : Format_Fortran.formatter -> unit -> unit module type Test = sig val suite : OUnit.test end module Test : Test end module Fortran : T Index: trunk/omega/src/fusion.ml =================================================================== --- trunk/omega/src/fusion.ml (revision 8491) +++ trunk/omega/src/fusion.ml (revision 8492) @@ -1,3427 +1,3548 @@ (* fusion.ml -- Copyright (C) 1999-2021 by Wolfgang Kilian Thorsten Ohl Juergen Reuter with contributions from Christian Speckner Marco Sekulla WHIZARD 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 2, or (at your option) any later version. WHIZARD 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, write to the Free Software Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. *) (* Avoid refering to [Pervasives.compare], because [Pervasives] will become [Stdlib.Pervasives] in O'Caml 4.07 and [Stdlib] in O'Caml 4.08. *) let pcompare = compare module type T = sig val options : Options.t val vintage : bool type wf val conjugate : wf -> wf type flavor type flavor_sans_color val flavor : wf -> flavor val flavor_sans_color : wf -> flavor_sans_color type p val momentum : wf -> p val momentum_list : wf -> int list val wf_tag : wf -> string option type constant type coupling type rhs type 'a children val sign : rhs -> int val coupling : rhs -> constant Coupling.t val coupling_tag : rhs -> string option type exclusions val no_exclusions : exclusions val children : rhs -> wf list type fusion val lhs : fusion -> wf val rhs : fusion -> rhs list type braket val bra : braket -> wf val ket : braket -> rhs list type amplitude type amplitude_sans_color type selectors val amplitudes : bool -> exclusions -> selectors -> flavor_sans_color list -> flavor_sans_color list -> amplitude list val amplitude_sans_color : bool -> exclusions -> selectors -> flavor_sans_color list -> flavor_sans_color list -> amplitude_sans_color val dependencies : amplitude -> wf -> (wf, coupling) Tree2.t val incoming : amplitude -> flavor list val outgoing : amplitude -> flavor list val externals : amplitude -> wf list val variables : amplitude -> wf list val fusions : amplitude -> fusion list val brakets : amplitude -> braket list val on_shell : amplitude -> (wf -> bool) val is_gauss : amplitude -> (wf -> bool) val constraints : amplitude -> string option val symmetry : amplitude -> int val allowed : amplitude -> bool val initialize_cache : string -> unit val set_cache_name : string -> unit val check_charges : unit -> flavor_sans_color list list val count_fusions : amplitude -> int val count_propagators : amplitude -> int val count_diagrams : amplitude -> int val forest : wf -> amplitude -> ((wf * coupling option, wf) Tree.t) list val poles : amplitude -> wf list list val s_channel : amplitude -> wf list val tower_to_dot : out_channel -> amplitude -> unit val amplitude_to_dot : out_channel -> amplitude -> unit val phase_space_channels : out_channel -> amplitude_sans_color -> unit val phase_space_channels_flipped : out_channel -> amplitude_sans_color -> unit end module type Maker = functor (P : Momentum.T) -> functor (M : Model.T) -> T with type p = P.t and type flavor = Colorize.It(M).flavor and type flavor_sans_color = M.flavor and type constant = M.constant and type selectors = Cascade.Make(M)(P).selectors (* \thocwmodulesection{Fermi Statistics} *) module type Stat = sig + + (* This will be [Model.T.flavor]. *) type flavor + + (* A record of the fermion lines in the 1POW. *) type stat + + (* Vertices with an odd number of fermion fields. *) exception Impossible + + (* External lines. *) val stat : flavor -> int -> stat + + (* [stat_fuse (Some flines) slist f] combines the fermion lines + in the elements of [slist] according to the connections listed + in [flines]. + On the other hand, [stat_fuse None slist f] corresponds to + the legacy mode with \emph{at most} two fermions. + The resulting flavor [f] of the 1POW can be ignored for models + with only Dirac fermions, except for debugging, since + the direction of the arrows is unambiguous. + However, in the case of Majorana fermions and/or fermion number + violating interactions, the flavor [f] must be used. *) val stat_fuse : Coupling.fermion_lines option -> stat list -> flavor -> stat + + (* Analogous to [stat_fuse], but for the finalizing keystone + instead of the 1POW. *) val stat_keystone : Coupling.fermion_lines option -> stat list -> flavor -> stat + + (* Compute the sign corresponding to the fermion lines in + a 1POW or keystone. *) val stat_sign : stat -> int - (* debugging \ldots *) + + (* Debugging and consistency checks \ldots *) val stat_to_string : stat -> string val equal : stat -> stat -> bool - val complete : stat -> bool - end + val saturated : stat -> bool + +end module type Stat_Maker = functor (M : Model.T) -> Stat with type flavor = M.flavor (* \thocwmodulesection{Dirac Fermions} *) +let dirac_log silent logging = logging +let dirac_log silent logging = silent + exception Majorana module Stat_Dirac (M : Model.T) : (Stat with type flavor = M.flavor) = struct type flavor = M.flavor (* \begin{equation} \gamma_\mu\psi(1)\,G^{\mu\nu}\,\bar\psi(2)\gamma_\nu\psi(3) - \gamma_\mu\psi(3)\,G^{\mu\nu}\,\bar\psi(2)\gamma_\nu\psi(1) \end{equation} *) type stat = | Fermion of int * (int option * int option) list | AntiFermion of int * (int option * int option) list | Boson of (int option * int option) list let lines_to_string lines = ThoList.to_string (function | Some i, Some j -> Printf.sprintf "%d>%d" i j | Some i, None -> Printf.sprintf "%d>*" i | None, Some j -> Printf.sprintf "*>%d" j | None, None -> "*>*") lines let stat_to_string = function | Boson lines -> Printf.sprintf "Boson %s" (lines_to_string lines) | Fermion (p, lines) -> Printf.sprintf "Fermion (%d, %s)" p (lines_to_string lines) | AntiFermion (p, lines) -> Printf.sprintf "AntiFermion (%d, %s)" p (lines_to_string lines) let equal s1 s2 = match s1, s2 with | Boson l1, Boson l2 -> List.sort compare l1 = List.sort compare l2 | Fermion (p1, l1), Fermion (p2, l2) | AntiFermion (p1, l1), AntiFermion (p2, l2) -> p1 = p2 && List.sort compare l1 = List.sort compare l2 | _ -> false - let complete = function + let saturated = function | Boson _ -> true | _ -> false let stat f p = match M.fermion f with | 0 -> Boson [] | 1 -> Fermion (p, []) | -1 -> AntiFermion (p, []) | 2 -> raise Majorana | _ -> invalid_arg "Fusion.Stat_Dirac: invalid fermion number" exception Impossible let stat_fuse_pair_legacy f s1 s2 = match s1, s2 with | Boson l1, Boson l2 -> Boson (l1 @ l2) | Boson l1, Fermion (p, l2) -> Fermion (p, l1 @ l2) | Boson l1, AntiFermion (p, l2) -> AntiFermion (p, l1 @ l2) | Fermion (p, l1), Boson l2 -> Fermion (p, l1 @ l2) | AntiFermion (p, l1), Boson l2 -> AntiFermion (p, l1 @ l2) | AntiFermion (pbar, l1), Fermion (p, l2) -> Boson ((Some pbar, Some p) :: l1 @ l2) | Fermion (p, l1), AntiFermion (pbar, l2) -> Boson ((Some pbar, Some p) :: l1 @ l2) | Fermion _, Fermion _ | AntiFermion _, AntiFermion _ -> raise Impossible let stat_fuse_legacy s1 s23__n f = List.fold_right (stat_fuse_pair_legacy f) s23__n s1 let stat_fuse_legacy_logging s1 s23__n f = let s = stat_fuse_legacy s1 s23__n f in Printf.eprintf - "Fusion.Stat_Dirac.stat_fuse_legacy: %s <- %s -> %s\n" + "stat_fuse_legacy: %s <- %s -> %s\n" (M.flavor_to_string f) (ThoList.to_string stat_to_string (s1 :: s23__n)) (stat_to_string s); s + let stat_fuse_legacy = + dirac_log stat_fuse_legacy stat_fuse_legacy_logging + module IMap = Map.Make (struct type t = int let compare = compare end) type partial = - { stat : stat; - fermions : int IMap.t; - antifermions : int IMap.t; - n : int } + { stat : stat (* the [stat] accumulated so far *); + fermions : int IMap.t (* a map from the indices in the vertex to open fermion lines *); + antifermions : int IMap.t (* a map from the indices in the vertex to open antifermion lines *); + n : int (* the number of incoming propagators *) } let partial_to_string p = Printf.sprintf - "{ %s, %s, %s, %d }" + "{ fermions=%s, antifermions=%s, state=%s, #=%d }" (ThoList.to_string - (fun (i, f) -> Printf.sprintf "%d@%d" i f) + (fun (i, f) -> Printf.sprintf "%d@%d" f i) (IMap.bindings p.fermions)) (ThoList.to_string - (fun (i, f) -> Printf.sprintf "%d@%d" i f) + (fun (i, f) -> Printf.sprintf "%d@%d" f i) (IMap.bindings p.antifermions)) (stat_to_string p.stat) p.n let add_lines l = function | Boson l' -> Boson (List.rev_append l l') | Fermion (n, l') -> Fermion (n, List.rev_append l l') | AntiFermion (n, l') -> AntiFermion (n, List.rev_append l l') let partial_of_slist slist = List.fold_left (fun acc s -> let n = succ acc.n in match s with | Boson l -> { acc with stat = add_lines l acc.stat; n } | Fermion (p, l) -> { acc with fermions = IMap.add n p acc.fermions; stat = add_lines l acc.stat; n } | AntiFermion (p, l) -> { acc with antifermions = IMap.add n p acc.antifermions; stat = add_lines l acc.stat; n } ) { stat = Boson []; fermions = IMap.empty; antifermions = IMap.empty; n = 0 } slist let find_opt p map = try Some (IMap.find p map) with Not_found -> None let match_fermion_line p (i, j) = if i <= p.n && j <= p.n then match find_opt i p.fermions, find_opt j p.antifermions with | (Some _ as f), (Some _ as fbar) -> { p with stat = add_lines [fbar, f] p.stat; fermions = IMap.remove i p.fermions; antifermions = IMap.remove j p.antifermions } | _ -> invalid_arg "match_fermion_line: mismatched boson" else if i <= p.n then match find_opt i p.fermions, p.stat with | Some f, Boson l -> { p with stat = Fermion (f, l); fermions = IMap.remove i p.fermions } | _ -> invalid_arg "match_fermion_line: mismatched fermion" else if j <= p.n then match find_opt j p.antifermions, p.stat with | Some fbar, Boson l -> { p with stat = AntiFermion (fbar, l); antifermions = IMap.remove j p.antifermions } | _ -> invalid_arg "match_fermion_line: mismatched antifermion" else failwith "match_fermion_line: impossible" let match_fermion_line_logging p (i, j) = Printf.eprintf - "Fusion.Stat_Dirac.match_fermion_line %s (%d, %d)" + "match_fermion_line %s (%d, %d)" (partial_to_string p) i j; let p' = match_fermion_line p (i, j) in Printf.eprintf " >> %s\n" (partial_to_string p'); p' - (* [let match_fermion_line = match_fermion_line_logging] *) + let match_fermion_line = + dirac_log match_fermion_line match_fermion_line_logging let match_fermion_lines flines s1 s23__n = let p = partial_of_slist (s1 :: s23__n) in List.fold_left match_fermion_line p flines let stat_fuse_new flines s1 s23__n f = (match_fermion_lines flines s1 s23__n).stat let stat_fuse_new_checking flines s1 s23__n f = let stat = stat_fuse_new flines s1 s23__n f in if List.length flines < 2 then begin let legacy = stat_fuse_legacy s1 s23__n f in if not (equal stat legacy) then failwith (Printf.sprintf "Fusion.Stat_Dirac.stat_fuse_new: %s <> %s!" (stat_to_string stat) (stat_to_string legacy)) end; stat let stat_fuse_new_logging flines s1 s23__n f = Printf.eprintf - "Fusion.Stat_Dirac.stat_fuse_new: \ - connecting fermion lines %s in %s <- %s\n" + "stat_fuse_new: connecting fermion lines %s in %s <- %s\n" (UFO_Lorentz.fermion_lines_to_string flines) (M.flavor_to_string f) (ThoList.to_string stat_to_string (s1 :: s23__n)); stat_fuse_new_checking flines s1 s23__n f - (* [let stat_fuse_new = stat_fuse_new_logging] *) + let stat_fuse_new = + dirac_log stat_fuse_new stat_fuse_new_logging let stat_fuse flines_opt slist f = match slist with | [] -> invalid_arg "Fusion.Stat_Dirac.stat_fuse: empty" | s1 :: s23__n -> begin match flines_opt with | Some flines -> stat_fuse_new flines s1 s23__n f | None -> stat_fuse_legacy s1 s23__n f end let stat_fuse_logging flines_opt slist f = Printf.eprintf - "Fusion.Stat_Dirac.stat_fuse: %s <- %s\n" + "stat_fuse: %s <- %s\n" (M.flavor_to_string f) (ThoList.to_string stat_to_string slist); stat_fuse flines_opt slist f + let stat_fuse = + dirac_log stat_fuse stat_fuse_logging + let stat_keystone_legacy s1 s23__n f = let s2 = List.hd s23__n and s34__n = List.tl s23__n in stat_fuse_legacy s1 [stat_fuse_legacy s2 s34__n (M.conjugate f)] f let stat_keystone_legacy_logging s1 s23__n f = let s = stat_keystone_legacy s1 s23__n f in Printf.eprintf - "Fusion.Stat_Dirac.stat_keystone_legacy: %s (%s) %s -> %s\n" + "stat_keystone_legacy: %s (%s) %s -> %s\n" (stat_to_string s1) (M.flavor_to_string f) (ThoList.to_string stat_to_string s23__n) (stat_to_string s); s + let stat_keystone_legacy = + dirac_log stat_keystone_legacy stat_keystone_legacy_logging + let stat_keystone flines_opt slist f = match slist with | [] -> invalid_arg "Fusion.Stat_Dirac.stat_keystone: empty" | [s] -> invalid_arg "Fusion.Stat_Dirac.stat_keystone: singleton" | s1 :: (s2 :: s34__n as s23__n) -> begin match flines_opt with | None -> stat_keystone_legacy s1 s23__n f | Some flines -> (* The fermion line indices in [flines] must match the lines on one side of the keystone. *) let stat = stat_fuse_legacy s1 [stat_fuse_new flines s2 s34__n f] f in - if complete stat then + if saturated stat then stat else failwith (Printf.sprintf "Fusion.Stat_Dirac.stat_keystone: incomplete %s!" (stat_to_string stat)) end + let stat_keystone_logging flines_opt slist f = + let s = stat_keystone flines_opt slist f in + Printf.eprintf + "stat_keystone: %s (%s) %s -> %s\n" + (stat_to_string (List.hd slist)) + (M.flavor_to_string f) + (ThoList.to_string stat_to_string (List.tl slist)) + (stat_to_string s); + s + + let stat_keystone = + dirac_log stat_keystone stat_keystone_logging (* \begin{figure} \begin{displaymath} \parbox{26\unitlength}{% \begin{fmfgraph*}(25,15) \fmfstraight \fmfleft{f} \fmfright{f1,f2,f3} \fmflabel{$\psi(1)$}{f1} \fmflabel{$\bar\psi(2)$}{f2} \fmflabel{$\psi(3)$}{f3} \fmflabel{$0$}{f} \fmf{fermion}{f1,v1,f} \fmffreeze \fmf{fermion,tension=0.5}{f3,v2,f2} \fmf{photon}{v1,v2} \fmfdot{v1,v2} \end{fmfgraph*}} \qquad\qquad-\qquad \parbox{26\unitlength}{% \begin{fmfgraph*}(25,15) \fmfstraight \fmfleft{f} \fmfright{f1,f2,f3} \fmflabel{$\psi(1)$}{f1} \fmflabel{$\bar\psi(2)$}{f2} \fmflabel{$\psi(3)$}{f3} \fmflabel{$0$}{f} \fmf{fermion}{f3,v1,f} \fmffreeze \fmf{fermion,tension=0.5}{f1,v2,f2} \fmf{photon}{v1,v2} \fmfdot{v1,v2} \end{fmfgraph*}} \end{displaymath} \caption{\label{fig:stat_fuse} Relative sign from Fermi statistics.} \end{figure} *) (* \begin{equation} \epsilon \left(\left\{ (0,1), (2,3) \right\}\right) = - \epsilon \left(\left\{ (0,3), (2,1) \right\}\right) \end{equation} *) let permutation lines = let fout, fin = List.split lines in let eps_in, _ = Combinatorics.sort_signed fin and eps_out, _ = Combinatorics.sort_signed fout in (eps_in * eps_out) (* \begin{dubious} This comparing of permutations of fermion lines is a bit tedious and takes a macroscopic fraction of time. However, it's less than 20\,\%, so we don't focus on improving on it yet. \end{dubious} *) let stat_sign = function | Boson lines -> permutation lines | Fermion (p, lines) -> permutation ((None, Some p) :: lines) | AntiFermion (pbar, lines) -> permutation ((Some pbar, None) :: lines) end (* \thocwmodulesection{Tags} *) module type Tags = sig type wf type coupling type 'a children val null_wf : wf val null_coupling : coupling val fuse : coupling -> wf children -> wf val wf_to_string : wf -> string option val coupling_to_string : coupling -> string option end module type Tagger = functor (PT : Tuple.Poly) -> Tags with type 'a children = 'a PT.t module type Tagged_Maker = functor (Tagger : Tagger) -> functor (P : Momentum.T) -> functor (M : Model.T) -> T with type p = P.t and type flavor = Colorize.It(M).flavor and type flavor_sans_color = M.flavor and type constant = M.constant (* No tags is one option for good tags \ldots *) module No_Tags (PT : Tuple.Poly) = struct type wf = unit type coupling = unit type 'a children = 'a PT.t let null_wf = () let null_coupling = () let fuse () _ = () let wf_to_string () = None let coupling_to_string () = None end (* \begin{dubious} Here's a simple additive tag that can grow into something useful for loop calculations. \end{dubious} *) module Loop_Tags (PT : Tuple.Poly) = struct type wf = int type coupling = int type 'a children = 'a PT.t let null_wf = 0 let null_coupling = 0 let fuse c wfs = PT.fold_left (+) c wfs let wf_to_string n = Some (string_of_int n) let coupling_to_string n = Some (string_of_int n) end module Order_Tags (PT : Tuple.Poly) = struct type wf = int type coupling = int type 'a children = 'a PT.t let null_wf = 0 let null_coupling = 0 let fuse c wfs = PT.fold_left (+) c wfs let wf_to_string n = Some (string_of_int n) let coupling_to_string n = Some (string_of_int n) end (* \thocwmodulesection{[Tagged], the [Fusion.Make] Functor} *) module Tagged (Tagger : Tagger) (PT : Tuple.Poly) (Stat : Stat_Maker) (T : Topology.T with type 'a children = 'a PT.t) (P : Momentum.T) (M : Model.T) = struct let vintage = false type cache_mode = Cache_Use | Cache_Ignore | Cache_Overwrite let cache_option = ref Cache_Ignore type qcd_order = | QCD_order of int type ew_order = | EW_order of int let qcd_order = ref (QCD_order 99) let ew_order = ref (EW_order 99) let options = Options.create [ "ignore-cache", Arg.Unit (fun () -> cache_option := Cache_Ignore), " ignore cached model tables (default)"; "use-cache", Arg.Unit (fun () -> cache_option := Cache_Use), " use cached model tables"; "overwrite-cache", Arg.Unit (fun () -> cache_option := Cache_Overwrite), " overwrite cached model tables"; "qcd", Arg.Int (fun n -> qcd_order := QCD_order n), " set QCD order n [>= 0, default = 99] (ignored)"; "ew", Arg.Int (fun n -> ew_order := EW_order n), " set QCD order n [>=0, default = 99] (ignored)"] exception Negative_QCD_order exception Negative_EW_order exception Vanishing_couplings exception Negative_QCD_EW_orders let int_orders = match !qcd_order, !ew_order with | QCD_order n, EW_order n' when n < 0 && n' >= 0 -> raise Negative_QCD_order | QCD_order n, EW_order n' when n >= 0 && n' < 0 -> raise Negative_EW_order | QCD_order n, EW_order n' when n < 0 && n' < 0 -> raise Negative_QCD_EW_orders | QCD_order n, EW_order n' -> (n, n') open Coupling module S = Stat(M) type stat = S.stat let stat = S.stat let stat_sign = S.stat_sign (* \begin{dubious} This will do \emph{something} for 4-, 6-, \ldots fermion vertices, but not necessarily the right thing \ldots \end{dubious} *) (* \begin{dubious} This is copied from [Colorize] and should be factored! \end{dubious} *) (* \begin{dubious} In the long run, it will probably be beneficial to apply the permutations in [Modeltools.add_vertexn]! \end{dubious} *) module PosMap = Partial.Make (struct type t = int let compare = compare end) let partial_map_undoing_permutation l l' = let module P = Permutation.Default in let p = P.of_list (List.map pred l') in PosMap.of_lists l (P.list p l) let partial_map_undoing_fuse fuse = partial_map_undoing_permutation (ThoList.range 1 (List.length fuse)) fuse let undo_permutation_of_fuse fuse = PosMap.apply_with_fallback (fun _ -> invalid_arg "permutation_of_fuse") (partial_map_undoing_fuse fuse) let fermion_lines = function | Coupling.V3 _ | Coupling.V4 _ -> None | Coupling.Vn (Coupling.UFO (_, _, _, fl, _), fuse, _) -> Some (UFO_Lorentz.map_fermion_lines (undo_permutation_of_fuse fuse) fl) type constant = M.constant (* \thocwmodulesubsection{Wave Functions} *) (* \begin{dubious} The code below is not yet functional. Too often, we assign to [Tags.null_wf] instead of calling [Tags.fuse]. \end{dubious} *) (* We will need two types of amplitudes: with color and without color. Since we can build them using the same types with only [flavor] replaced, it pays to use a functor to set up the scaffolding. *) module Tags = Tagger(PT) (* In the future, we might want to have [Coupling] among the functor arguments. However, for the moment, [Coupling] is assumed to be comprehensive. *) module type Tagged_Coupling = sig type sign = int type t = { sign : sign; coupling : constant Coupling.t; coupling_tag : Tags.coupling } val sign : t -> sign val coupling : t -> constant Coupling.t val coupling_tag : t -> string option end module Tagged_Coupling : Tagged_Coupling = struct type sign = int type t = { sign : sign; coupling : constant Coupling.t; coupling_tag : Tags.coupling } let sign c = c.sign let coupling c = c.coupling let coupling_tag_raw c = c.coupling_tag let coupling_tag rhs = Tags.coupling_to_string (coupling_tag_raw rhs) end (* \thocwmodulesubsection{Amplitudes: Monochrome and Colored} *) module type Amplitude = sig module Tags : Tags type flavor type p type wf = { flavor : flavor; momentum : p; wf_tag : Tags.wf } val flavor : wf -> flavor val conjugate : wf -> wf val momentum : wf -> p val momentum_list : wf -> int list val wf_tag : wf -> string option val wf_tag_raw : wf -> Tags.wf val order_wf : wf -> wf -> int val external_wfs : int -> (flavor * int) list -> wf list type 'a children type coupling = Tagged_Coupling.t type rhs = coupling * wf children val sign : rhs -> int val coupling : rhs -> constant Coupling.t val coupling_tag : rhs -> string option type exclusions val no_exclusions : exclusions val children : rhs -> wf list type fusion = wf * rhs list val lhs : fusion -> wf val rhs : fusion -> rhs list type braket = wf * rhs list val bra : braket -> wf val ket : braket -> rhs list module D : DAG.T with type node = wf and type edge = coupling and type children = wf children val wavefunctions : braket list -> wf list type amplitude = { fusions : fusion list; brakets : braket list; on_shell : (wf -> bool); is_gauss : (wf -> bool); constraints : string option; incoming : flavor list; outgoing : flavor list; externals : wf list; symmetry : int; dependencies : (wf -> (wf, coupling) Tree2.t); fusion_tower : D.t; fusion_dag : D.t } val incoming : amplitude -> flavor list val outgoing : amplitude -> flavor list val externals : amplitude -> wf list val variables : amplitude -> wf list val fusions : amplitude -> fusion list val brakets : amplitude -> braket list val on_shell : amplitude -> (wf -> bool) val is_gauss : amplitude -> (wf -> bool) val constraints : amplitude -> string option val symmetry : amplitude -> int val dependencies : amplitude -> wf -> (wf, coupling) Tree2.t val fusion_dag : amplitude -> D.t end module Amplitude (PT : Tuple.Poly) (P : Momentum.T) (M : Model.T) : Amplitude with type p = P.t and type flavor = M.flavor and type 'a children = 'a PT.t and module Tags = Tags = struct type flavor = M.flavor type p = P.t module Tags = Tags type wf = { flavor : flavor; momentum : p; wf_tag : Tags.wf } let flavor wf = wf.flavor let conjugate wf = { wf with flavor = M.conjugate wf.flavor } let momentum wf = wf.momentum let momentum_list wf = P.to_ints wf.momentum let wf_tag wf = Tags.wf_to_string wf.wf_tag let wf_tag_raw wf = wf.wf_tag let external_wfs rank particles = List.map (fun (f, p) -> { flavor = f; momentum = P.singleton rank p; wf_tag = Tags.null_wf }) particles (* Order wavefunctions so that the external come first, then the pairs, etc. Also put possible Goldstone bosons \emph{before} their gauge bosons. *) let lorentz_ordering f = match M.lorentz f with | Coupling.Scalar -> 0 | Coupling.Spinor -> 1 | Coupling.ConjSpinor -> 2 | Coupling.Majorana -> 3 | Coupling.Vector -> 4 | Coupling.Massive_Vector -> 5 | Coupling.Tensor_2 -> 6 | Coupling.Tensor_1 -> 7 | Coupling.Vectorspinor -> 8 | Coupling.BRS Coupling.Scalar -> 9 | Coupling.BRS Coupling.Spinor -> 10 | Coupling.BRS Coupling.ConjSpinor -> 11 | Coupling.BRS Coupling.Majorana -> 12 | Coupling.BRS Coupling.Vector -> 13 | Coupling.BRS Coupling.Massive_Vector -> 14 | Coupling.BRS Coupling.Tensor_2 -> 15 | Coupling.BRS Coupling.Tensor_1 -> 16 | Coupling.BRS Coupling.Vectorspinor -> 17 | Coupling.BRS _ -> invalid_arg "Fusion.lorentz_ordering: not needed" | Coupling.Maj_Ghost -> 18 (*i | Coupling.Ward_Vector -> 19 i*) let order_flavor f1 f2 = let c = compare (lorentz_ordering f1) (lorentz_ordering f2) in if c <> 0 then c else compare f1 f2 (* Note that [Momentum().compare] guarantees that wavefunctions will be ordered according to \emph{increasing} [Momentum().rank] of their momenta. *) let order_wf wf1 wf2 = let c = P.compare wf1.momentum wf2.momentum in if c <> 0 then c else let c = order_flavor wf1.flavor wf2.flavor in if c <> 0 then c else compare wf1.wf_tag wf2.wf_tag (* This \emph{must} be a pair matching the [edge * node children] pairs of [DAG.Forest]! *) type coupling = Tagged_Coupling.t type 'a children = 'a PT.t type rhs = coupling * wf children let sign (c, _) = Tagged_Coupling.sign c let coupling (c, _) = Tagged_Coupling.coupling c let coupling_tag (c, _) = Tagged_Coupling.coupling_tag c type exclusions = { x_flavors : flavor list; x_couplings : coupling list } let no_exclusions = { x_flavors = []; x_couplings = [] } let children (_, wfs) = PT.to_list wfs type fusion = wf * rhs list let lhs (l, _) = l let rhs (_, r) = r type braket = wf * rhs list let bra (b, _) = b let ket (_, k) = k module D = DAG.Make (DAG.Forest(PT) (struct type t = wf let compare = order_wf end) (struct type t = coupling let compare = compare end)) module WFSet = Set.Make (struct type t = wf let compare = order_wf end) let wavefunctions brakets = WFSet.elements (List.fold_left (fun set (wf1, wf23) -> WFSet.add wf1 (List.fold_left (fun set' (_, wfs) -> PT.fold_right WFSet.add wfs set') set wf23)) WFSet.empty brakets) type amplitude = { fusions : fusion list; brakets : braket list; on_shell : (wf -> bool); is_gauss : (wf -> bool); constraints : string option; incoming : flavor list; outgoing : flavor list; externals : wf list; symmetry : int; dependencies : (wf -> (wf, coupling) Tree2.t); fusion_tower : D.t; fusion_dag : D.t } let incoming a = a.incoming let outgoing a = a.outgoing let externals a = a.externals let fusions a = a.fusions let brakets a = a.brakets let symmetry a = a.symmetry let on_shell a = a.on_shell let is_gauss a = a.is_gauss let constraints a = a.constraints let variables a = List.map lhs a.fusions let dependencies a = a.dependencies let fusion_dag a = a.fusion_dag end module A = Amplitude(PT)(P)(M) (* Operator insertions can be fused only if they are external. *) let is_source wf = match M.propagator wf.A.flavor with | Only_Insertion -> P.rank wf.A.momentum = 1 | _ -> true (* [is_goldstone_of g v] is [true] if and only if [g] is the Goldstone boson corresponding to the gauge particle [v]. *) let is_goldstone_of g v = match M.goldstone v with | None -> false | Some (g', _) -> g = g' (* \begin{dubious} In the end, [PT.to_list] should become redudant! \end{dubious} *) let fuse_rhs rhs = M.fuse (PT.to_list rhs) (* \thocwmodulesubsection{Vertices} *) (* Compute the set of all vertices in the model from the allowed fusions and the set of all flavors: \begin{dubious} One could think of using [M.vertices] instead of [M.fuse2], [M.fuse3] and [M.fuse] \ldots \end{dubious} *) module VSet = Map.Make(struct type t = A.flavor let compare = compare end) let add_vertices f rhs m = VSet.add f (try rhs :: VSet.find f m with Not_found -> [rhs]) m let collect_vertices rhs = List.fold_right (fun (f1, c) -> add_vertices (M.conjugate f1) (c, rhs)) (fuse_rhs rhs) (* The set of all vertices with common left fields factored. *) (* I used to think that constant initializers are a good idea to allow compile time optimizations. The down side turned out to be that the constant initializers will be evaluated \emph{every time} the functor is applied. \emph{Relying on the fact that the functor will be called only once is not a good idea!} *) type vertices = (A.flavor * (constant Coupling.t * A.flavor PT.t) list) list let vertices_nocache max_degree flavors : vertices = VSet.fold (fun f rhs v -> (f, rhs) :: v) (PT.power_fold collect_vertices flavors VSet.empty) [] (* Performance hack: *) type vertex_table = ((A.flavor * A.flavor * A.flavor) * constant Coupling.vertex3 * constant) list * ((A.flavor * A.flavor * A.flavor * A.flavor) * constant Coupling.vertex4 * constant) list * (A.flavor list * constant Coupling.vertexn * constant) list module VCache = Cache.Make (struct type t = vertex_table end) (struct type t = vertices end) let vertices_cache = ref None let hash () = VCache.hash (M.vertices ()) (* \begin{dubious} Can we do better than the executable name provided by [Config.cache_prefix]??? We need a better way to avoid collisions among the caches for different models in the same program. \end{dubious} *) let cache_name = ref (Config.cache_prefix ^ "." ^ Config.cache_suffix) let set_cache_name name = cache_name := name let initialize_cache dir = Printf.eprintf " >>> Initializing vertex table %s. This may take some time ... " !cache_name; flush stderr; VCache.write_dir (hash ()) dir !cache_name (vertices_nocache (M.max_degree ()) (M.flavors())); Printf.eprintf "done. <<< \n" let vertices max_degree flavors : vertices = match !vertices_cache with | None -> begin match !cache_option with | Cache_Use -> begin match VCache.maybe_read (hash ()) !cache_name with | VCache.Hit result -> result | VCache.Miss -> Printf.eprintf " >>> Initializing vertex table %s. This may take some time ... " !cache_name; flush stderr; let result = vertices_nocache max_degree flavors in VCache.write (hash ()) !cache_name (result); vertices_cache := Some result; Printf.eprintf "done. <<< \n"; flush stderr; result | VCache.Stale file -> Printf.eprintf " >>> Re-initializing stale vertex table %s in file %s. " !cache_name file; Printf.eprintf "This may take some time ... "; flush stderr; let result = vertices_nocache max_degree flavors in VCache.write (hash ()) !cache_name (result); vertices_cache := Some result; Printf.eprintf "done. <<< \n"; flush stderr; result end | Cache_Overwrite -> Printf.eprintf " >>> Overwriting vertex table %s. This may take some time ... " !cache_name; flush stderr; let result = vertices_nocache max_degree flavors in VCache.write (hash ()) !cache_name (result); vertices_cache := Some result; Printf.eprintf "done. <<< \n"; flush stderr; result | Cache_Ignore -> let result = vertices_nocache max_degree flavors in vertices_cache := Some result; result end | Some result -> result (* Note that we must perform any filtering of the vertices \emph{after} caching, because the restrictions \emph{must not} influence the cache (unless we tag the cache with model and restrictions). *) (*i let unpack_constant = function | Coupling.V3 (_, _, cs) -> cs | Coupling.V4 (_, _, cs) -> cs | Coupling.Vn (_, _, cs) -> cs let coupling_and_flavors_to_string (c, fs) = M.constant_symbol (unpack_constant c) ^ "[" ^ String.concat ", " (List.map M.flavor_to_string (PT.to_list fs)) ^ "]" let fusions_to_string (f, cfs) = M.flavor_to_string f ^ " <- { " ^ String.concat " | " (List.map coupling_and_flavors_to_string cfs) ^ " }" let vertices_to_string vertices = String.concat "; " (List.map fusions_to_string vertices) i*) let filter_vertices select_vtx vertices = List.fold_left (fun acc (f, cfs) -> let f' = M.conjugate f in let cfs = List.filter (fun (c, fs) -> select_vtx c f' (PT.to_list fs)) cfs in match cfs with | [] -> acc | cfs -> (f, cfs) :: acc) [] vertices (* \thocwmodulesubsection{Partitions} *) (* Vertices that are not crossing invariant need special treatment so that they're only generated for the correct combinations of momenta. NB: the [crossing] checks here are a bit redundant, because [CM.fuse] below will bring the killed vertices back to life and will have to filter once more. Nevertheless, we keep them here, for the unlikely case that anybody ever wants to use uncolored amplitudes directly. NB: the analogous problem does not occur for [select_wf], because this applies to momenta instead of vertices. *) (* \begin{dubious} This approach worked before the colorize, but has become \emph{futile}, because [CM.fuse] will bring the killed vertices back to life. We need to implement the same checks there again!!! \end{dubious} *) (* \begin{dubious} Using [PT.Mismatched_arity] is not really good style \ldots Tho's approach doesn't work since he does not catch charge conjugated processes or crossed processes. Another very strange thing is that O'Mega seems always to run in the q2 q3 timelike case, but not in the other two. (Property of how the DAG is built?). For the $ZZZZ$ vertex I add the same vertex again, but interchange 1 and 3 in the [crossing] vertex \end{dubious} *) let kmatrix_cuts c momenta = match c with | V4 (Vector4_K_Matrix_tho (disc, _), fusion, _) | V4 (Vector4_K_Matrix_jr (disc, _), fusion, _) -> let s12, s23, s13 = begin match PT.to_list momenta with | [q1; q2; q3] -> (P.Scattering.timelike (P.add q1 q2), P.Scattering.timelike (P.add q2 q3), P.Scattering.timelike (P.add q1 q3)) | _ -> raise PT.Mismatched_arity end in begin match disc, s12, s23, s13, fusion with | 0, true, false, false, (F341|F431|F342|F432|F123|F213|F124|F214) | 0, false, true, false, (F134|F143|F234|F243|F312|F321|F412|F421) | 0, false, false, true, (F314|F413|F324|F423|F132|F231|F142|F241) -> true | 1, true, false, false, (F341|F431|F342|F432) | 1, false, true, false, (F134|F143|F234|F243) | 1, false, false, true, (F314|F413|F324|F423) -> true | 2, true, false, false, (F123|F213|F124|F214) | 2, false, true, false, (F312|F321|F412|F421) | 2, false, false, true, (F132|F231|F142|F241) -> true | 3, true, false, false, (F143|F413|F142|F412|F321|F231|F324|F234) | 3, false, true, false, (F314|F341|F214|F241|F132|F123|F432|F423) | 3, false, false, true, (F134|F431|F124|F421|F312|F213|F342|F243) -> true | _ -> false end | V4 (Vector4_K_Matrix_cf_t0 (disc, _), fusion, _) -> let s12, s23, s13 = begin match PT.to_list momenta with | [q1; q2; q3] -> (P.Scattering.timelike (P.add q1 q2), P.Scattering.timelike (P.add q2 q3), P.Scattering.timelike (P.add q1 q3)) | _ -> raise PT.Mismatched_arity end in begin match disc, s12, s23, s13, fusion with | 0, true, false, false, (F341|F431|F342|F432|F123|F213|F124|F214) | 0, false, true, false, (F134|F143|F234|F243|F312|F321|F412|F421) | 0, false, false, true, (F314|F413|F324|F423|F132|F231|F142|F241) -> true | 1, true, false, false, (F341|F431|F342|F432) | 1, false, true, false, (F134|F143|F234|F243) | 1, false, false, true, (F314|F413|F324|F423) -> true | 2, true, false, false, (F123|F213|F124|F214) | 2, false, true, false, (F312|F321|F412|F421) | 2, false, false, true, (F132|F231|F142|F241) -> true | 3, true, false, false, (F143|F413|F142|F412|F321|F231|F324|F234) | 3, false, true, false, (F314|F341|F214|F241|F132|F123|F432|F423) | 3, false, false, true, (F134|F431|F124|F421|F312|F213|F342|F243) -> true | _ -> false end | V4 (Vector4_K_Matrix_cf_t1 (disc, _), fusion, _) -> let s12, s23, s13 = begin match PT.to_list momenta with | [q1; q2; q3] -> (P.Scattering.timelike (P.add q1 q2), P.Scattering.timelike (P.add q2 q3), P.Scattering.timelike (P.add q1 q3)) | _ -> raise PT.Mismatched_arity end in begin match disc, s12, s23, s13, fusion with | 0, true, false, false, (F341|F431|F342|F432|F123|F213|F124|F214) | 0, false, true, false, (F134|F143|F234|F243|F312|F321|F412|F421) | 0, false, false, true, (F314|F413|F324|F423|F132|F231|F142|F241) -> true | 1, true, false, false, (F341|F431|F342|F432) | 1, false, true, false, (F134|F143|F234|F243) | 1, false, false, true, (F314|F413|F324|F423) -> true | 2, true, false, false, (F123|F213|F124|F214) | 2, false, true, false, (F312|F321|F412|F421) | 2, false, false, true, (F132|F231|F142|F241) -> true | 3, true, false, false, (F143|F413|F142|F412|F321|F231|F324|F234) | 3, false, true, false, (F314|F341|F214|F241|F132|F123|F432|F423) | 3, false, false, true, (F134|F431|F124|F421|F312|F213|F342|F243) -> true | _ -> false end | V4 (Vector4_K_Matrix_cf_t2 (disc, _), fusion, _) -> let s12, s23, s13 = begin match PT.to_list momenta with | [q1; q2; q3] -> (P.Scattering.timelike (P.add q1 q2), P.Scattering.timelike (P.add q2 q3), P.Scattering.timelike (P.add q1 q3)) | _ -> raise PT.Mismatched_arity end in begin match disc, s12, s23, s13, fusion with | 0, true, false, false, (F341|F431|F342|F432|F123|F213|F124|F214) | 0, false, true, false, (F134|F143|F234|F243|F312|F321|F412|F421) | 0, false, false, true, (F314|F413|F324|F423|F132|F231|F142|F241) -> true | 1, true, false, false, (F341|F431|F342|F432) | 1, false, true, false, (F134|F143|F234|F243) | 1, false, false, true, (F314|F413|F324|F423) -> true | 2, true, false, false, (F123|F213|F124|F214) | 2, false, true, false, (F312|F321|F412|F421) | 2, false, false, true, (F132|F231|F142|F241) -> true | 3, true, false, false, (F143|F413|F142|F412|F321|F231|F324|F234) | 3, false, true, false, (F314|F341|F214|F241|F132|F123|F432|F423) | 3, false, false, true, (F134|F431|F124|F421|F312|F213|F342|F243) -> true | _ -> false end | V4 (Vector4_K_Matrix_cf_t_rsi (disc, _), fusion, _) -> let s12, s23, s13 = begin match PT.to_list momenta with | [q1; q2; q3] -> (P.Scattering.timelike (P.add q1 q2), P.Scattering.timelike (P.add q2 q3), P.Scattering.timelike (P.add q1 q3)) | _ -> raise PT.Mismatched_arity end in begin match disc, s12, s23, s13, fusion with | 0, true, false, false, (F341|F431|F342|F432|F123|F213|F124|F214) | 0, false, true, false, (F134|F143|F234|F243|F312|F321|F412|F421) | 0, false, false, true, (F314|F413|F324|F423|F132|F231|F142|F241) -> true | 1, true, false, false, (F341|F431|F342|F432) | 1, false, true, false, (F134|F143|F234|F243) | 1, false, false, true, (F314|F413|F324|F423) -> true | 2, true, false, false, (F123|F213|F124|F214) | 2, false, true, false, (F312|F321|F412|F421) | 2, false, false, true, (F132|F231|F142|F241) -> true | 3, true, false, false, (F143|F413|F142|F412|F321|F231|F324|F234) | 3, false, true, false, (F314|F341|F214|F241|F132|F123|F432|F423) | 3, false, false, true, (F134|F431|F124|F421|F312|F213|F342|F243) -> true | _ -> false end | V4 (Vector4_K_Matrix_cf_m0 (disc, _), fusion, _) -> let s12, s23, s13 = begin match PT.to_list momenta with | [q1; q2; q3] -> (P.Scattering.timelike (P.add q1 q2), P.Scattering.timelike (P.add q2 q3), P.Scattering.timelike (P.add q1 q3)) | _ -> raise PT.Mismatched_arity end in begin match disc, s12, s23, s13, fusion with | 0, true, false, false, (F341|F431|F342|F432|F123|F213|F124|F214) | 0, false, true, false, (F134|F143|F234|F243|F312|F321|F412|F421) | 0, false, false, true, (F314|F413|F324|F423|F132|F231|F142|F241) -> true | 1, true, false, false, (F341|F431|F342|F432) | 1, false, true, false, (F134|F143|F234|F243) | 1, false, false, true, (F314|F413|F324|F423) -> true | 2, true, false, false, (F123|F213|F124|F214) | 2, false, true, false, (F312|F321|F412|F421) | 2, false, false, true, (F132|F231|F142|F241) -> true | 3, true, false, false, (F143|F413|F142|F412|F321|F231|F324|F234) | 3, false, true, false, (F314|F341|F214|F241|F132|F123|F432|F423) | 3, false, false, true, (F134|F431|F124|F421|F312|F213|F342|F243) -> true | _ -> false end | V4 (Vector4_K_Matrix_cf_m1 (disc, _), fusion, _) -> let s12, s23, s13 = begin match PT.to_list momenta with | [q1; q2; q3] -> (P.Scattering.timelike (P.add q1 q2), P.Scattering.timelike (P.add q2 q3), P.Scattering.timelike (P.add q1 q3)) | _ -> raise PT.Mismatched_arity end in begin match disc, s12, s23, s13, fusion with | 0, true, false, false, (F341|F431|F342|F432|F123|F213|F124|F214) | 0, false, true, false, (F134|F143|F234|F243|F312|F321|F412|F421) | 0, false, false, true, (F314|F413|F324|F423|F132|F231|F142|F241) -> true | 1, true, false, false, (F341|F431|F342|F432) | 1, false, true, false, (F134|F143|F234|F243) | 1, false, false, true, (F314|F413|F324|F423) -> true | 2, true, false, false, (F123|F213|F124|F214) | 2, false, true, false, (F312|F321|F412|F421) | 2, false, false, true, (F132|F231|F142|F241) -> true | 3, true, false, false, (F143|F413|F142|F412|F321|F231|F324|F234) | 3, false, true, false, (F314|F341|F214|F241|F132|F123|F432|F423) | 3, false, false, true, (F134|F431|F124|F421|F312|F213|F342|F243) -> true | _ -> false end | V4 (Vector4_K_Matrix_cf_m7 (disc, _), fusion, _) -> let s12, s23, s13 = begin match PT.to_list momenta with | [q1; q2; q3] -> (P.Scattering.timelike (P.add q1 q2), P.Scattering.timelike (P.add q2 q3), P.Scattering.timelike (P.add q1 q3)) | _ -> raise PT.Mismatched_arity end in begin match disc, s12, s23, s13, fusion with | 0, true, false, false, (F341|F431|F342|F432|F123|F213|F124|F214) | 0, false, true, false, (F134|F143|F234|F243|F312|F321|F412|F421) | 0, false, false, true, (F314|F413|F324|F423|F132|F231|F142|F241) -> true | 1, true, false, false, (F341|F431|F342|F432) | 1, false, true, false, (F134|F143|F234|F243) | 1, false, false, true, (F314|F413|F324|F423) -> true | 2, true, false, false, (F123|F213|F124|F214) | 2, false, true, false, (F312|F321|F412|F421) | 2, false, false, true, (F132|F231|F142|F241) -> true | 3, true, false, false, (F143|F413|F142|F412|F321|F231|F324|F234) | 3, false, true, false, (F314|F341|F214|F241|F132|F123|F432|F423) | 3, false, false, true, (F134|F431|F124|F421|F312|F213|F342|F243) -> true | _ -> false end | V4 (DScalar2_Vector2_K_Matrix_ms (disc, _), fusion, _) -> let s12, s23, s13 = begin match PT.to_list momenta with | [q1; q2; q3] -> (P.Scattering.timelike (P.add q1 q2), P.Scattering.timelike (P.add q2 q3), P.Scattering.timelike (P.add q1 q3)) | _ -> raise PT.Mismatched_arity end in begin match disc, s12, s23, s13, fusion with | 0, true, false, false, (F341|F431|F342|F432|F123|F213|F124|F214) | 0, false, true, false, (F134|F143|F234|F243|F312|F321|F412|F421) | 0, false, false, true, (F314|F413|F324|F423|F132|F231|F142|F241) -> true | 1, true, false, false, (F341|F432|F123|F214) | 1, false, true, false, (F134|F243|F312|F421) | 1, false, false, true, (F314|F423|F132|F241) -> true | 2, true, false, false, (F431|F342|F213|F124) | 2, false, true, false, (F143|F234|F321|F412) | 2, false, false, true, (F413|F324|F231|F142) -> true | 3, true, false, false, (F143|F413|F142|F412|F321|F231|F324|F234) | 3, false, true, false, (F314|F341|F214|F241|F132|F123|F432|F423) | 3, false, false, true, (F134|F431|F124|F421|F312|F213|F342|F243) -> true | 4, true, false, false, (F142|F413|F231|F324) | 4, false, true, false, (F214|F341|F123|F432) | 4, false, false, true, (F124|F431|F213|F342) -> true | 5, true, false, false, (F143|F412|F321|F234) | 5, false, true, false, (F314|F241|F132|F423) | 5, false, false, true, (F134|F421|F312|F243) -> true | 6, true, false, false, (F134|F132|F314|F312|F241|F243|F421|F423) | 6, false, true, false, (F213|F413|F231|F431|F124|F324|F142|F342) | 6, false, false, true, (F143|F123|F341|F321|F412|F214|F432|F234) -> true | 7, true, false, false, (F134|F312|F421|F243) | 7, false, true, false, (F413|F231|F142|F324) | 7, false, false, true, (F143|F321|F412|F432) -> true | 8, true, false, false, (F132|F314|F241|F423) | 8, false, true, false, (F213|F431|F124|F342) | 8, false, false, true, (F123|F341|F214|F234) -> true | _ -> false end | V4 (DScalar2_Vector2_m_0_K_Matrix_cf (disc, _), fusion, _) -> let s12, s23, s13 = begin match PT.to_list momenta with | [q1; q2; q3] -> (P.Scattering.timelike (P.add q1 q2), P.Scattering.timelike (P.add q2 q3), P.Scattering.timelike (P.add q1 q3)) | _ -> raise PT.Mismatched_arity end in begin match disc, s12, s23, s13, fusion with | 0, true, false, false, (F341|F431|F342|F432|F123|F213|F124|F214) | 0, false, true, false, (F134|F143|F234|F243|F312|F321|F412|F421) | 0, false, false, true, (F314|F413|F324|F423|F132|F231|F142|F241) -> true | 1, true, false, false, (F341|F432|F123|F214) | 1, false, true, false, (F134|F243|F312|F421) | 1, false, false, true, (F314|F423|F132|F241) -> true | 2, true, false, false, (F431|F342|F213|F124) | 2, false, true, false, (F143|F234|F321|F412) | 2, false, false, true, (F413|F324|F231|F142) -> true | 3, true, false, false, (F143|F413|F142|F412|F321|F231|F324|F234) | 3, false, true, false, (F314|F341|F214|F241|F132|F123|F432|F423) | 3, false, false, true, (F134|F431|F124|F421|F312|F213|F342|F243) -> true | 4, true, false, false, (F142|F413|F231|F324) | 4, false, true, false, (F214|F341|F123|F432) | 4, false, false, true, (F124|F431|F213|F342) -> true | 5, true, false, false, (F143|F412|F321|F234) | 5, false, true, false, (F314|F241|F132|F423) | 5, false, false, true, (F134|F421|F312|F243) -> true | 6, true, false, false, (F134|F132|F314|F312|F241|F243|F421|F423) | 6, false, true, false, (F213|F413|F231|F431|F124|F324|F142|F342) | 6, false, false, true, (F143|F123|F341|F321|F412|F214|F432|F234) -> true | 7, true, false, false, (F134|F312|F421|F243) | 7, false, true, false, (F413|F231|F142|F324) | 7, false, false, true, (F143|F321|F412|F432) -> true | 8, true, false, false, (F132|F314|F241|F423) | 8, false, true, false, (F213|F431|F124|F342) | 8, false, false, true, (F123|F341|F214|F234) -> true | _ -> false end | V4 (DScalar2_Vector2_m_1_K_Matrix_cf (disc, _), fusion, _) -> let s12, s23, s13 = begin match PT.to_list momenta with | [q1; q2; q3] -> (P.Scattering.timelike (P.add q1 q2), P.Scattering.timelike (P.add q2 q3), P.Scattering.timelike (P.add q1 q3)) | _ -> raise PT.Mismatched_arity end in begin match disc, s12, s23, s13, fusion with | 0, true, false, false, (F341|F431|F342|F432|F123|F213|F124|F214) | 0, false, true, false, (F134|F143|F234|F243|F312|F321|F412|F421) | 0, false, false, true, (F314|F413|F324|F423|F132|F231|F142|F241) -> true | 1, true, false, false, (F341|F432|F123|F214) | 1, false, true, false, (F134|F243|F312|F421) | 1, false, false, true, (F314|F423|F132|F241) -> true | 2, true, false, false, (F431|F342|F213|F124) | 2, false, true, false, (F143|F234|F321|F412) | 2, false, false, true, (F413|F324|F231|F142) -> true | 3, true, false, false, (F143|F413|F142|F412|F321|F231|F324|F234) | 3, false, true, false, (F314|F341|F214|F241|F132|F123|F432|F423) | 3, false, false, true, (F134|F431|F124|F421|F312|F213|F342|F243) -> true | 4, true, false, false, (F142|F413|F231|F324) | 4, false, true, false, (F214|F341|F123|F432) | 4, false, false, true, (F124|F431|F213|F342) -> true | 5, true, false, false, (F143|F412|F321|F234) | 5, false, true, false, (F314|F241|F132|F423) | 5, false, false, true, (F134|F421|F312|F243) -> true | 6, true, false, false, (F134|F132|F314|F312|F241|F243|F421|F423) | 6, false, true, false, (F213|F413|F231|F431|F124|F324|F142|F342) | 6, false, false, true, (F143|F123|F341|F321|F412|F214|F432|F234) -> true | 7, true, false, false, (F134|F312|F421|F243) | 7, false, true, false, (F413|F231|F142|F324) | 7, false, false, true, (F143|F321|F412|F432) -> true | 8, true, false, false, (F132|F314|F241|F423) | 8, false, true, false, (F213|F431|F124|F342) | 8, false, false, true, (F123|F341|F214|F234) -> true | _ -> false end | V4 (DScalar2_Vector2_m_7_K_Matrix_cf (disc, _), fusion, _) -> let s12, s23, s13 = begin match PT.to_list momenta with | [q1; q2; q3] -> (P.Scattering.timelike (P.add q1 q2), P.Scattering.timelike (P.add q2 q3), P.Scattering.timelike (P.add q1 q3)) | _ -> raise PT.Mismatched_arity end in begin match disc, s12, s23, s13, fusion with | 0, true, false, false, (F341|F431|F342|F432|F123|F213|F124|F214) | 0, false, true, false, (F134|F143|F234|F243|F312|F321|F412|F421) | 0, false, false, true, (F314|F413|F324|F423|F132|F231|F142|F241) -> true | 1, true, false, false, (F341|F432|F123|F214) | 1, false, true, false, (F134|F243|F312|F421) | 1, false, false, true, (F314|F423|F132|F241) -> true | 2, true, false, false, (F431|F342|F213|F124) | 2, false, true, false, (F143|F234|F321|F412) | 2, false, false, true, (F413|F324|F231|F142) -> true | 3, true, false, false, (F143|F413|F142|F412|F321|F231|F324|F234) | 3, false, true, false, (F314|F341|F214|F241|F132|F123|F432|F423) | 3, false, false, true, (F134|F431|F124|F421|F312|F213|F342|F243) -> true | 4, true, false, false, (F142|F413|F231|F324) | 4, false, true, false, (F214|F341|F123|F432) | 4, false, false, true, (F124|F431|F213|F342) -> true | 5, true, false, false, (F143|F412|F321|F234) | 5, false, true, false, (F314|F241|F132|F423) | 5, false, false, true, (F134|F421|F312|F243) -> true | 6, true, false, false, (F134|F132|F314|F312|F241|F243|F421|F423) | 6, false, true, false, (F213|F413|F231|F431|F124|F324|F142|F342) | 6, false, false, true, (F143|F123|F341|F321|F412|F214|F432|F234) -> true | 7, true, false, false, (F134|F312|F421|F243) | 7, false, true, false, (F413|F231|F142|F324) | 7, false, false, true, (F143|F321|F412|F432) -> true | 8, true, false, false, (F132|F314|F241|F423) | 8, false, true, false, (F213|F431|F124|F342) | 8, false, false, true, (F123|F341|F214|F234) -> true | _ -> false end | V4 (DScalar4_K_Matrix_ms (disc, _), fusion, _) -> let s12, s23, s13 = begin match PT.to_list momenta with | [q1; q2; q3] -> (P.Scattering.timelike (P.add q1 q2), P.Scattering.timelike (P.add q2 q3), P.Scattering.timelike (P.add q1 q3)) | _ -> raise PT.Mismatched_arity end in begin match disc, s12, s23, s13, fusion with | 0, true, false, false, (F341|F431|F342|F432|F123|F213|F124|F214) | 0, false, true, false, (F134|F143|F234|F243|F312|F321|F412|F421) | 0, false, false, true, (F314|F413|F324|F423|F132|F231|F142|F241) -> true | 3, true, false, false, (F143|F413|F142|F412|F321|F231|F324|F234) | 3, false, true, false, (F314|F341|F214|F241|F132|F123|F432|F423) | 3, false, false, true, (F134|F431|F124|F421|F312|F213|F342|F243) -> true | 4, true, false, false, (F142|F413|F231|F324) | 4, false, true, false, (F214|F341|F123|F432) | 4, false, false, true, (F124|F431|F213|F342) -> true | 5, true, false, false, (F143|F412|F321|F234) | 5, false, true, false, (F314|F241|F132|F423) | 5, false, false, true, (F134|F421|F312|F243) -> true | 6, true, false, false, (F134|F132|F314|F312|F241|F243|F421|F423) | 6, false, true, false, (F213|F413|F231|F431|F124|F324|F142|F342) | 6, false, false, true, (F143|F123|F341|F321|F412|F214|F432|F234) -> true | 7, true, false, false, (F134|F312|F421|F243) | 7, false, true, false, (F413|F231|F142|F324) | 7, false, false, true, (F143|F321|F412|F432) -> true | 8, true, false, false, (F132|F314|F241|F423) | 8, false, true, false, (F213|F431|F124|F342) | 8, false, false, true, (F123|F341|F214|F234) -> true | _ -> false end | _ -> true (* Counting QCD and EW orders. *) let qcd_ew_check orders = if fst (orders) <= fst (int_orders) && snd (orders) <= snd (int_orders) then true else false (* Match a set of flavors to a set of momenta. Form the direct product for the lists of momenta two and three with the list of couplings and flavors two and three. *) let flavor_keystone select_p dim (f1, f23) (p1, p23) = ({ A.flavor = f1; A.momentum = P.of_ints dim p1; A.wf_tag = A.Tags.null_wf }, Product.fold2 (fun (c, f) p acc -> try let p' = PT.map (P.of_ints dim) p in if select_p (P.of_ints dim p1) (PT.to_list p') && kmatrix_cuts c p' then (c, PT.map2 (fun f'' p'' -> { A.flavor = f''; A.momentum = p''; A.wf_tag = A.Tags.null_wf }) f p') :: acc else acc with | PT.Mismatched_arity -> acc) f23 p23 []) (*i let cnt = ref 0 let gc_stat () = let minor, promoted, major = Gc.counters () in Printf.sprintf "(%12.0f, %12.0f, %12.0f)" minor promoted major let flavor_keystone select_p n (f1, f23) (p1, p23) = incr cnt; Gc.set { (Gc.get()) with Gc.space_overhead = 20 }; Printf.eprintf "%6d@%8.1f: %s\n" !cnt (Sys.time ()) (gc_stat ()); flush stderr; flavor_keystone select_p n (f1, f23) (p1, p23) i*) (* Produce all possible combinations of vertices (flavor keystones) and momenta by forming the direct product. The semantically equivalent [Product.list2 (flavor_keystone select_wf n) vertices keystones] with \emph{subsequent} filtering would be a \emph{very bad} idea, because a potentially huge intermediate list is built for large models. E.\,g.~for the MSSM this would lead to non-termination by thrashing for $2\to4$ processes on most PCs. *) let flavor_keystones filter select_p dim vertices keystones = Product.fold2 (fun v k acc -> filter (flavor_keystone select_p dim v k) acc) vertices keystones [] (* Flatten the nested lists of vertices into a list of attached lines. *) let flatten_keystones t = ThoList.flatmap (fun (p1, p23) -> p1 :: (ThoList.flatmap (fun (_, rhs) -> PT.to_list rhs) p23)) t (* \thocwmodulesubsection{Subtrees} *) (* Fuse a tuple of wavefunctions, keeping track of Fermi statistics. Record only the the sign \emph{relative} to the children. (The type annotation is only for documentation.) *) let fuse select_wf select_vtx wfss : (A.wf * stat * A.rhs) list = if PT.for_all (fun (wf, _) -> is_source wf) wfss then try let wfs, ss = PT.split wfss in let flavors = PT.map A.flavor wfs and momenta = PT.map A.momentum wfs (*i and wf_tags = PT.map A.wf_tag_raw wfs i*) in let p = PT.fold_left_internal P.add momenta in (*i let wft = PT.fold_left Tags.fuse wf_tags in i*) List.fold_left (fun acc (f, c) -> if select_wf f p (PT.to_list momenta) && select_vtx c f (PT.to_list flavors) && kmatrix_cuts c momenta then (* [let _ = Printf.eprintf "Fusion.fuse: %s <- %s\n" (M.flavor_to_string f) (ThoList.to_string M.flavor_to_string (PT.to_list flavors)) in] *) let s = S.stat_fuse (fermion_lines c) (PT.to_list ss) f in let flip = PT.fold_left (fun acc s' -> acc * stat_sign s') (stat_sign s) ss in ({ A.flavor = f; A.momentum = p; A.wf_tag = A.Tags.null_wf }, s, ({ Tagged_Coupling.sign = flip; Tagged_Coupling.coupling = c; Tagged_Coupling.coupling_tag = A.Tags.null_coupling }, wfs)) :: acc else acc) [] (fuse_rhs flavors) with | P.Duplicate _ | S.Impossible -> [] else [] (* \begin{dubious} Eventually, the pairs of [tower] and [dag] in [fusion_tower'] below could and should be replaced by a graded [DAG]. This will look like, but currently [tower] containts statistics information that is missing from [dag]: \begin{quote} \verb+Type node = flavor * p is not compatible with type wf * stat+ \end{quote} This should be easy to fix. However, replacing [type t = wf] with [type t = wf * stat] is \emph{not} a good idea because the variable [stat] makes it impossible to test for the existance of a particular [wf] in a [DAG]. \end{dubious} \begin{dubious} In summary, it seems that [(wf * stat) list array * A.D.t] should be replaced by [(wf -> stat) * A.D.t]. \end{dubious} *) module GF = struct module Nodes = struct type t = A.wf module G = struct type t = int let compare = compare end let compare = A.order_wf let rank wf = P.rank wf.A.momentum end module Edges = struct type t = A.coupling let compare = compare end module F = DAG.Forest(PT)(Nodes)(Edges) type node = Nodes.t type edge = F.edge type children = F.children type t = F.t let compare = F.compare let for_all = F.for_all let fold = F.fold end module D' = DAG.Graded(GF) let tower_of_dag dag = let _, max_rank = D'.min_max_rank dag in Array.init max_rank (fun n -> D'.ranked n dag) (* The function [fusion_tower'] recursively builds the tower of all fusions from bottom up to a chosen level. The argument [tower] is an array of lists, where the $i$-th sublist (counting from 0) represents all off shell wave functions depending on $i+1$~momenta and their Fermistatistics. \begin{equation} \begin{aligned} \Bigl\lbrack & \{ \phi_1(p_1), \phi_2(p_2), \phi_3(p_3), \ldots \}, \\ & \{ \phi_{12}(p_1+p_2), \phi'_{12}(p_1+p_2), \ldots, \phi_{13}(p_1+p_3), \ldots, \phi_{23}(p_2+p_3), \ldots \}, \\ & \ldots \\ & \{ \phi_{1\cdots n}(p_1+\cdots+p_n), \phi'_{1\cdots n}(p_1+\cdots+p_n), \ldots \} \Bigr\rbrack \end{aligned} \end{equation} The argument [dag] is a DAG representing all the fusions calculated so far. NB: The outer array in [tower] is always very short, so we could also have accessed a list with [List.nth]. Appending of new members at the end brings no loss of performance. NB: the array is supposed to be immutable. *) (* The towers must be sorted so that the combinatorical functions can make consistent selections. \begin{dubious} Intuitively, this seems to be correct. However, one could have expected that no element appears twice and that this ordering is not necessary \ldots \end{dubious} *) let grow select_wf select_vtx tower = let rank = succ (Array.length tower) in List.sort pcompare (PT.graded_sym_power_fold rank (fun wfs acc -> fuse select_wf select_vtx wfs @ acc) tower []) let add_offspring dag (wf, _, rhs) = A.D.add_offspring wf rhs dag let filter_offspring fusions = List.map (fun (wf, s, _) -> (wf, s)) fusions let rec fusion_tower' n_max select_wf select_vtx tower dag : (A.wf * stat) list array * A.D.t = if Array.length tower >= n_max then (tower, dag) else let tower' = grow select_wf select_vtx tower in fusion_tower' n_max select_wf select_vtx (Array.append tower [|filter_offspring tower'|]) (List.fold_left add_offspring dag tower') (* Discard the tower and return a map from wave functions to Fermistatistics together with the DAG. *) let make_external_dag wfs = List.fold_left (fun m (wf, _) -> A.D.add_node wf m) A.D.empty wfs let mixed_fold_left f acc lists = Array.fold_left (List.fold_left f) acc lists module Stat_Map = Map.Make (struct type t = A.wf let compare = A.order_wf end) let fusion_tower height select_wf select_vtx wfs : (A.wf -> stat) * A.D.t = let tower, dag = fusion_tower' height select_wf select_vtx [|wfs|] (make_external_dag wfs) in let stats = mixed_fold_left (fun m (wf, s) -> Stat_Map.add wf s m) Stat_Map.empty tower in ((fun wf -> Stat_Map.find wf stats), dag) (* Calculate the minimal tower of fusions that suffices for calculating the amplitude. *) let minimal_fusion_tower n select_wf select_vtx wfs : (A.wf -> stat) * A.D.t = fusion_tower (T.max_subtree n) select_wf select_vtx wfs (* Calculate the complete tower of fusions. It is much larger than required, but it allows a complete set of gauge checks. *) let complete_fusion_tower select_wf select_vtx wfs : (A.wf -> stat) * A.D.t = fusion_tower (List.length wfs - 1) select_wf select_vtx wfs (* \begin{dubious} There is a natural product of two DAGs using [fuse]. Can this be used in a replacement for [fusion_tower]? The hard part is to avoid double counting, of course. A straight forward solution could do a diagonal sum (in order to reject flipped offspring representing the same fusion) and rely on the uniqueness in [DAG] otherwise. However, this will (probably) slow down the procedure significanty, because most fusions (including Fermi signs!) will be calculated before being rejected by [DAG().add_offspring]. \end{dubious} *) (* Add to [dag] all Goldstone bosons defined in [tower] that correspond to gauge bosons in [dag]. This is only required for checking Slavnov-Taylor identities in unitarity gauge. Currently, it is not used, because we use the complete tower for gauge checking. *) let harvest_goldstones tower dag = A.D.fold_nodes (fun wf dag' -> match M.goldstone wf.A.flavor with | Some (g, _) -> let wf' = { wf with A.flavor = g } in if A.D.is_node wf' tower then begin A.D.harvest tower wf' dag' end else begin dag' end | None -> dag') dag dag (* Calculate the sign from Fermi statistics that is not already included in the children. *) let strip_fermion_lines = function | (Coupling.V3 _ | Coupling.V4 _ as v) -> v | Coupling.Vn (Coupling.UFO (c, l, s, fl, col), f, x) -> Coupling.Vn (Coupling.UFO (c, l, s, [], col), f, x) let num_fermion_lines_v3 = function | FBF _ | PBP _ | BBB _ | GBG _ -> 1 | _ -> 0 let num_fermion_lines = function | Coupling.Vn (Coupling.UFO (c, l, s, fl, col), f, x) -> List.length fl | Coupling.V3 (v3, _, _) -> num_fermion_lines_v3 v3 | Coupling.V4 _ -> 0 let stat_keystone v stats wf1 wfs = let wf1' = stats wf1 and wfs' = PT.map stats wfs in let f = A.flavor wf1 in let slist = wf1' :: PT.to_list wfs' in let stat = S.stat_keystone (fermion_lines v) slist f in (* We can compare with the legacy implementation only if there are no fermion line ambiguities possible, i.\,e.~for at most one line. *) if num_fermion_lines v < 2 then begin let legacy = S.stat_keystone None slist f in if not (S.equal stat legacy) then failwith (Printf.sprintf "Fusion.stat_keystone: %s <> %s!" (S.stat_to_string legacy) (S.stat_to_string stat)); - if not (S.complete legacy) then + if not (S.saturated legacy) then failwith (Printf.sprintf "Fusion.stat_keystone: legacy incomplete: %s!" (S.stat_to_string legacy)) end; - if not (S.complete stat) then + if not (S.saturated stat) then failwith (Printf.sprintf "Fusion.stat_keystone: incomplete: %s!" (S.stat_to_string stat)); stat_sign stat * PT.fold_left (fun acc wf -> acc * stat_sign wf) (stat_sign wf1') wfs' let stat_keystone_logging v stats wf1 wfs = let sign = stat_keystone v stats wf1 wfs in Printf.eprintf "Fusion.stat_keystone: %s * %s -> %d\n" (M.flavor_to_string (A.flavor wf1)) (ThoList.to_string (fun wf -> M.flavor_to_string (A.flavor wf)) (PT.to_list wfs)) sign; sign (* Test all members of a list of wave functions are defined by the DAG simultaneously: *) let test_rhs dag (_, wfs) = PT.for_all (fun wf -> is_source wf && A.D.is_node wf dag) wfs (* Add the keystone [(wf1,pairs)] to [acc] only if it is present in [dag] and calculate the statistical factor depending on [stats] \emph{en passant}: *) let filter_keystone stats dag (wf1, pairs) acc = if is_source wf1 && A.D.is_node wf1 dag then match List.filter (test_rhs dag) pairs with | [] -> acc | pairs' -> (wf1, List.map (fun (c, wfs) -> ({ Tagged_Coupling.sign = stat_keystone c stats wf1 wfs; Tagged_Coupling.coupling = c; Tagged_Coupling.coupling_tag = A.Tags.null_coupling }, wfs)) pairs') :: acc else acc (* \begin{figure} \begin{center} \thocwincludegraphics{width=\textwidth}{bhabha0}\\ \hfil\\ \thocwincludegraphics{width=\textwidth}{bhabha} \end{center} \caption{\label{fig:bhabha} The DAGs for Bhabha scattering before and after weeding out unused nodes. The blatant asymmetry of these DAGs is caused by our prescription for removing doubling counting for an even number of external lines.} \end{figure} \begin{figure} \begin{center} \thocwincludegraphics{width=\textwidth}{epemudbarmunumubar0}\\ \hfil\\ \thocwincludegraphics{width=\textwidth}{epemudbarmunumubar} \end{center} \caption{\label{fig:epemudbarmunumubar} The DAGs for $e^+e^-\to u\bar d \mu^-\bar\nu_\mu$ before and after weeding out unused nodes.} \end{figure} \begin{figure} \begin{center} \thocwincludegraphics{width=\textwidth}{epemudbardubar0}\\ \hfil\\ \thocwincludegraphics{width=\textwidth}{epemudbardubar} \end{center} \caption{\label{fig:epemudbardubar} The DAGs for $e^+e^-\to u\bar d d\bar u$ before and after weeding out unused nodes.} \end{figure} *) (* \thocwmodulesubsection{Amplitudes} *) module C = Cascade.Make(M)(P) type selectors = C.selectors let external_wfs n particles = List.map (fun (f, p) -> ({ A.flavor = f; A.momentum = P.singleton n p; A.wf_tag = A.Tags.null_wf }, stat f p)) particles (* \thocwmodulesubsection{Main Function} *) module WFMap = Map.Make (struct type t = A.wf let compare = compare end) (* [map_amplitude_wfs f a] applies the function [f : wf -> wf] to all wavefunctions appearing in the amplitude [a]. *) let map_amplitude_wfs f a = let map_rhs (c, wfs) = (c, PT.map f wfs) in let map_braket (wf, rhs) = (f wf, List.map map_rhs rhs) and map_fusion (lhs, rhs) = (f lhs, List.map map_rhs rhs) in let map_dag = A.D.map f (fun node rhs -> map_rhs rhs) in let tower = map_dag a.A.fusion_tower and dag = map_dag a.A.fusion_dag in let dependencies_map = A.D.fold (fun wf _ -> WFMap.add wf (A.D.dependencies dag wf)) dag WFMap.empty in { A.fusions = List.map map_fusion a.A.fusions; A.brakets = List.map map_braket a.A.brakets; A.on_shell = a.A.on_shell; A.is_gauss = a.A.is_gauss; A.constraints = a.A.constraints; A.incoming = a.A.incoming; A.outgoing = a.A.outgoing; A.externals = List.map f a.A.externals; A.symmetry = a.A.symmetry; A.dependencies = (fun wf -> WFMap.find wf dependencies_map); A.fusion_tower = tower; A.fusion_dag = dag } (*i (* \begin{dubious} Just a silly little test: \end{dubious} *) let hack_amplitude = map_amplitude_wfs (fun wf -> { wf with momentum = P.split 2 16 wf.momentum }) i*) (* This is the main function that constructs the amplitude for sets of incoming and outgoing particles and returns the results in conveniently packaged pieces. *) let amplitude goldstones selectors fin fout = (* Set up external lines and match flavors with numbered momenta. *) let f = fin @ List.map M.conjugate fout in let nin, nout = List.length fin, List.length fout in let n = nin + nout in let externals = List.combine f (ThoList.range 1 n) in let wfs = external_wfs n externals in let select_p = C.select_p selectors in let select_wf = match fin with | [_] -> C.select_wf selectors P.Decay.timelike | _ -> C.select_wf selectors P.Scattering.timelike in let select_vtx = C.select_vtx selectors in (* Build the full fusion tower (including nodes that are never needed in the amplitude). *) let stats, tower = if goldstones then complete_fusion_tower select_wf select_vtx wfs else minimal_fusion_tower n select_wf select_vtx wfs in (* Find all vertices for which \emph{all} off shell wavefunctions are defined by the tower. *) let brakets = flavor_keystones (filter_keystone stats tower) select_p n (filter_vertices select_vtx (vertices (M.max_degree ()) (M.flavors ()))) (T.keystones (ThoList.range 1 n)) in (* Remove the part of the DAG that is never needed in the amplitude. *) let dag = if goldstones then tower else A.D.harvest_list tower (A.wavefunctions brakets) in (* Remove the leaf nodes of the DAG, corresponding to external lines. *) let fusions = List.filter (function (_, []) -> false | _ -> true) (A.D.lists dag) in (* Calculate the symmetry factor for identical particles in the final state. *) let symmetry = Combinatorics.symmetry fout in let dependencies_map = A.D.fold (fun wf _ -> WFMap.add wf (A.D.dependencies dag wf)) dag WFMap.empty in (* Finally: package the results: *) { A.fusions = fusions; A.brakets = brakets; A.on_shell = (fun wf -> C.on_shell selectors (A.flavor wf) wf.A.momentum); A.is_gauss = (fun wf -> C.is_gauss selectors (A.flavor wf) wf.A.momentum); A.constraints = C.description selectors; A.incoming = fin; A.outgoing = fout; A.externals = List.map fst wfs; A.symmetry = symmetry; A.dependencies = (fun wf -> WFMap.find wf dependencies_map); A.fusion_tower = tower; A.fusion_dag = dag } (* \thocwmodulesubsection{Color} *) module CM = Colorize.It(M) module CA = Amplitude(PT)(P)(CM) let colorize_wf flavor wf = { CA.flavor = flavor; CA.momentum = wf.A.momentum; CA.wf_tag = wf.A.wf_tag } let uncolorize_wf wf = { A.flavor = CM.flavor_sans_color wf.CA.flavor; A.momentum = wf.CA.momentum; A.wf_tag = wf.CA.wf_tag } (* \begin{dubious} At the end of the day, I shall want to have some sort of \textit{fibered DAG} as abstract data type, with a projection of colored nodes to their uncolored counterparts. \end{dubious} *) module CWFBundle = Bundle.Make (struct type elt = CA.wf let compare_elt = compare type base = A.wf let compare_base = compare let pi wf = { A.flavor = CM.flavor_sans_color wf.CA.flavor; A.momentum = wf.CA.momentum; A.wf_tag = wf.CA.wf_tag } end) (* \begin{dubious} For now, we can live with simple aggregation: \end{dubious} *) type fibered_dag = { dag : CA.D.t; bundle : CWFBundle.t } (* Not yet(?) needed: [module CS = Stat (CM)] *) let colorize_sterile_nodes dag f wf fibered_dag = if A.D.is_sterile wf dag then let wf', wf_bundle' = f wf fibered_dag in { dag = CA.D.add_node wf' fibered_dag.dag; bundle = wf_bundle' } else fibered_dag let colorize_nodes f wf rhs fibered_dag = let wf_rhs_list', wf_bundle' = f wf rhs fibered_dag in let dag' = List.fold_right (fun (wf', rhs') -> CA.D.add_offspring wf' rhs') wf_rhs_list' fibered_dag.dag in { dag = dag'; bundle = wf_bundle' } (* O'Caml (correctly) infers the type [val colorize_dag : (D.node -> D.edge * D.children -> fibered_dag -> (CA.D.node * (CA.D.edge * CA.D.children)) list * CWFBundle.t) -> (D.node -> fibered_dag -> CA.D.node * CWFBundle.t) -> D.t -> CWFBundle.t -> fibered_dag]. *) let colorize_dag f_node f_ext dag wf_bundle = A.D.fold (colorize_nodes f_node) dag (A.D.fold_nodes (colorize_sterile_nodes dag f_ext) dag { dag = CA.D.empty; bundle = wf_bundle }) let colorize_external wf fibered_dag = match CWFBundle.inv_pi wf fibered_dag.bundle with | [c_wf] -> (c_wf, fibered_dag.bundle) | [] -> failwith "colorize_external: not found" | _ -> failwith "colorize_external: not unique" let fuse_c_wf rhs = let momenta = PT.map (fun wf -> wf.CA.momentum) rhs in List.filter (fun (_, c) -> kmatrix_cuts c momenta) (CM.fuse (List.map (fun wf -> wf.CA.flavor) (PT.to_list rhs))) let colorize_coupling c coupling = { coupling with Tagged_Coupling.coupling = c } let colorize_fusion wf (coupling, children) fibered_dag = let match_flavor (f, _) = (CM.flavor_sans_color f = A.flavor wf) and find_colored wf' = CWFBundle.inv_pi wf' fibered_dag.bundle in let fusions = ThoList.flatmap (fun c_children -> List.map (fun (f, c) -> (colorize_wf f wf, (colorize_coupling c coupling, c_children))) (List.filter match_flavor (fuse_c_wf c_children))) (PT.product (PT.map find_colored children)) in let bundle = List.fold_right (fun (c_wf, _) -> CWFBundle.add c_wf) fusions fibered_dag.bundle in (fusions, bundle) let colorize_braket1 (wf, (coupling, children)) fibered_dag = let find_colored wf' = CWFBundle.inv_pi wf' fibered_dag.bundle in Product.fold2 (fun bra ket acc -> List.fold_left (fun brakets (f, c) -> if CM.conjugate bra.CA.flavor = f then (bra, (colorize_coupling c coupling, ket)) :: brakets else brakets) acc (fuse_c_wf ket)) (find_colored wf) (PT.product (PT.map find_colored children)) [] module CWFMap = Map.Make (struct type t = CA.wf let compare = CA.order_wf end) module CKetSet = Set.Make (struct type t = CA.rhs let compare = compare end) (* Find a set of kets in [map] that belong to [bra]. Return the empty set, if nothing is found. *) let lookup_ketset bra map = try CWFMap.find bra map with Not_found -> CKetSet.empty (* Return the set of kets belonging to [bra] in [map], augmented by [ket]. *) let addto_ketset bra ket map = CKetSet.add ket (lookup_ketset bra map) (* Augment or update [map] with a new [(bra, ket)] relation. *) let addto_ketset_map map (bra, ket) = CWFMap.add bra (addto_ketset bra ket map) map (* Take a list of [(bra, ket)] pairs and group the [ket]s according to [bra]. This is very similar to [ThoList.factorize] on page~\pageref{ThoList.factorize}, but the latter keeps duplicate copies, while we keep only one, with equality determined by [CA.order_wf]. *) (* \begin{dubious} Isn't [Bundle]~\ref{Bundle} the correct framework for this? \end{dubious} *) let factorize_brakets brakets = CWFMap.fold (fun bra ket acc -> (bra, CKetSet.elements ket) :: acc) (List.fold_left addto_ketset_map CWFMap.empty brakets) [] let colorize_braket (wf, rhs_list) fibered_dag = factorize_brakets (ThoList.flatmap (fun rhs -> (colorize_braket1 (wf, rhs) fibered_dag)) rhs_list) let colorize_amplitude a fin fout = let f = fin @ List.map CM.conjugate fout in let nin, nout = List.length fin, List.length fout in let n = nin + nout in let externals = List.combine f (ThoList.range 1 n) in let external_wfs = CA.external_wfs n externals in let wf_bundle = CWFBundle.of_list external_wfs in let fibered_dag = colorize_dag colorize_fusion colorize_external a.A.fusion_dag wf_bundle in let brakets = ThoList.flatmap (fun braket -> colorize_braket braket fibered_dag) a.A.brakets in let dag = CA.D.harvest_list fibered_dag.dag (CA.wavefunctions brakets) in let fusions = List.filter (function (_, []) -> false | _ -> true) (CA.D.lists dag) in let dependencies_map = CA.D.fold (fun wf _ -> CWFMap.add wf (CA.D.dependencies dag wf)) dag CWFMap.empty in { CA.fusions = fusions; CA.brakets = brakets; CA.constraints = a.A.constraints; CA.incoming = fin; CA.outgoing = fout; CA.externals = external_wfs; CA.fusion_dag = dag; CA.fusion_tower = dag; CA.symmetry = a.A.symmetry; CA.on_shell = (fun wf -> a.A.on_shell (uncolorize_wf wf)); CA.is_gauss = (fun wf -> a.A.is_gauss (uncolorize_wf wf)); CA.dependencies = (fun wf -> CWFMap.find wf dependencies_map) } let allowed amplitude = match amplitude.CA.brakets with | [] -> false | _ -> true let colorize_amplitudes a = List.fold_left (fun amps (fin, fout) -> let amp = colorize_amplitude a fin fout in if allowed amp then amp :: amps else amps) [] (CM.amplitude a.A.incoming a.A.outgoing) let amplitudes goldstones exclusions selectors fin fout = colorize_amplitudes (amplitude goldstones selectors fin fout) let amplitude_sans_color goldstones exclusions selectors fin fout = amplitude goldstones selectors fin fout type flavor = CA.flavor type flavor_sans_color = A.flavor type p = A.p type wf = CA.wf let conjugate = CA.conjugate let flavor = CA.flavor let flavor_sans_color wf = CM.flavor_sans_color (CA.flavor wf) let momentum = CA.momentum let momentum_list = CA.momentum_list let wf_tag = CA.wf_tag type coupling = CA.coupling let sign = CA.sign let coupling = CA.coupling let coupling_tag = CA.coupling_tag type exclusions = CA.exclusions let no_exclusions = CA.no_exclusions type 'a children = 'a CA.children type rhs = CA.rhs let children = CA.children type fusion = CA.fusion let lhs = CA.lhs let rhs = CA.rhs type braket = CA.braket let bra = CA.bra let ket = CA.ket type amplitude = CA.amplitude type amplitude_sans_color = A.amplitude let incoming = CA.incoming let outgoing = CA.outgoing let externals = CA.externals let fusions = CA.fusions let brakets = CA.brakets let symmetry = CA.symmetry let on_shell = CA.on_shell let is_gauss = CA.is_gauss let constraints = CA.constraints let variables a = List.map lhs (fusions a) let dependencies = CA.dependencies (* \thocwmodulesubsection{Checking Conservation Laws} *) let check_charges () = let vlist3, vlist4, vlistn = M.vertices () in List.filter (fun flist -> not (M.Ch.is_null (M.Ch.sum (List.map M.charges flist)))) (List.map (fun ((f1, f2, f3), _, _) -> [f1; f2; f3]) vlist3 @ List.map (fun ((f1, f2, f3, f4), _, _) -> [f1; f2; f3; f4]) vlist4 @ List.map (fun (flist, _, _) -> flist) vlistn) (* \thocwmodulesubsection{Diagnostics} *) let count_propagators a = List.length a.CA.fusions let count_fusions a = List.fold_left (fun n (_, a) -> n + List.length a) 0 a.CA.fusions + List.fold_left (fun n (_, t) -> n + List.length t) 0 a.CA.brakets + List.length a.CA.brakets (* \begin{dubious} This brute force approach blows up for more than ten particles. Find a smarter algorithm. \end{dubious} *) let count_diagrams a = List.fold_left (fun n (wf1, wf23) -> n + CA.D.count_trees wf1 a.CA.fusion_dag * (List.fold_left (fun n' (_, wfs) -> n' + PT.fold_left (fun n'' wf -> n'' * CA.D.count_trees wf a.CA.fusion_dag) 1 wfs) 0 wf23)) 0 a.CA.brakets exception Impossible let forest' a = let below wf = CA.D.forest_memoized wf a.CA.fusion_dag in ThoList.flatmap (fun (bra, ket) -> (Product.list2 (fun bra' ket' -> bra' :: ket') (below bra) (ThoList.flatmap (fun (_, wfs) -> Product.list (fun w -> w) (PT.to_list (PT.map below wfs))) ket))) a.CA.brakets let cross wf = { CA.flavor = CM.conjugate wf.CA.flavor; CA.momentum = P.neg wf.CA.momentum; CA.wf_tag = wf.CA.wf_tag } let fuse_trees wf ts = Tree.fuse (fun (wf', e) -> (cross wf', e)) wf (fun t -> List.mem wf (Tree.leafs t)) ts let forest wf a = List.map (fuse_trees wf) (forest' a) (*i (* \begin{dubious} The following duplication should be replaced by polymorphism or a functor. \end{dubious} *) let forest_uncolored' a = let below wf = A.D.forest_memoized wf a.A.fusion_dag in ThoList.flatmap (fun (bra, ket) -> (Product.list2 (fun bra' ket' -> bra' :: ket') (below bra) (ThoList.flatmap (fun (_, wfs) -> Product.list (fun w -> w) (PT.to_list (PT.map below wfs))) ket))) a.A.brakets let cross_uncolored wf = { A.flavor = M.conjugate wf.A.flavor; A.momentum = P.neg wf.A.momentum; A.wf_tag = wf.A.wf_tag } let fuse_trees_uncolored wf ts = Tree.fuse (fun (wf', e) -> (cross_uncolored wf', e)) wf (fun t -> List.mem wf (Tree.leafs t)) ts let forest_sans_color wf a = List.map (fuse_trees_uncolored wf) (forest_uncolored' a) i*) let poles_beneath wf dag = CA.D.eval_memoized (fun wf' -> [[]]) (fun wf' _ p -> List.map (fun p' -> wf' :: p') p) (fun wf1 wf2 -> Product.fold2 (fun wf' wfs' wfs'' -> (wf' @ wfs') :: wfs'') wf1 wf2 []) (@) [[]] [[]] wf dag let poles a = ThoList.flatmap (fun (wf1, wf23) -> let poles_wf1 = poles_beneath wf1 a.CA.fusion_dag in (ThoList.flatmap (fun (_, wfs) -> Product.list List.flatten (PT.to_list (PT.map (fun wf -> poles_wf1 @ poles_beneath wf a.CA.fusion_dag) wfs))) wf23)) a.CA.brakets module WFSet = Set.Make (struct type t = CA.wf let compare = CA.order_wf end) let s_channel a = WFSet.elements (ThoList.fold_right2 (fun wf wfs -> if P.Scattering.timelike wf.CA.momentum then WFSet.add wf wfs else wfs) (poles a) WFSet.empty) (* \begin{dubious} This should be much faster! Is it correct? Is it faster indeed? \end{dubious} *) let poles' a = List.map CA.lhs a.CA.fusions let s_channel a = WFSet.elements (List.fold_right (fun wf wfs -> if P.Scattering.timelike wf.CA.momentum then WFSet.add wf wfs else wfs) (poles' a) WFSet.empty) (* \thocwmodulesubsection{Pictures} *) (* Export the DAG in the \texttt{dot(1)} file format so that we can draw pretty pictures to impress audiences \ldots *) let p2s p = if p >= 0 && p <= 9 then string_of_int p else if p <= 36 then String.make 1 (Char.chr (Char.code 'A' + p - 10)) else "_" let variable wf = CM.flavor_symbol wf.CA.flavor ^ String.concat "" (List.map p2s (P.to_ints wf.CA.momentum)) module Int = Map.Make (struct type t = int let compare = compare end) let add_to_list i n m = Int.add i (n :: try Int.find i m with Not_found -> []) m let classify_nodes dag = Int.fold (fun i n acc -> (i, n) :: acc) (CA.D.fold_nodes (fun wf -> add_to_list (P.rank wf.CA.momentum) wf) dag Int.empty) [] let dag_to_dot ch brakets dag = Printf.fprintf ch "digraph OMEGA {\n"; CA.D.iter_nodes (fun wf -> Printf.fprintf ch " \"%s\" [ label = \"%s\" ];\n" (variable wf) (variable wf)) dag; List.iter (fun (_, wfs) -> Printf.fprintf ch " { rank = same;"; List.iter (fun n -> Printf.fprintf ch " \"%s\";" (variable n)) wfs; Printf.fprintf ch " };\n") (classify_nodes dag); List.iter (fun n -> Printf.fprintf ch " \"*\" -> \"%s\";\n" (variable n)) (flatten_keystones brakets); CA.D.iter (fun n (_, ns) -> let p = variable n in PT.iter (fun n' -> Printf.fprintf ch " \"%s\" -> \"%s\";\n" p (variable n')) ns) dag; Printf.fprintf ch "}\n" let tower_to_dot ch a = dag_to_dot ch a.CA.brakets a.CA.fusion_tower let amplitude_to_dot ch a = dag_to_dot ch a.CA.brakets a.CA.fusion_dag (* \thocwmodulesubsection{Phasespace} *) let variable wf = M.flavor_to_string wf.A.flavor ^ "[" ^ String.concat "/" (List.map p2s (P.to_ints wf.A.momentum)) ^ "]" let below_to_channel transform ch dag wf = let n2s wf = variable (transform wf) and e2s c = "" in Tree2.to_channel ch n2s e2s (A.D.dependencies dag wf) let bra_to_channel transform ch dag wf = let tree = A.D.dependencies dag wf in if Tree2.is_singleton tree then let n2s wf = variable (transform wf) and e2s c = "" in Tree2.to_channel ch n2s e2s tree else failwith "Fusion.phase_space_channels: wrong topology!" let ket_to_channel transform ch dag ket = Printf.fprintf ch "("; begin match A.children ket with | [] -> () | [child] -> below_to_channel transform ch dag child | child :: children -> below_to_channel transform ch dag child; List.iter (fun child -> Printf.fprintf ch ","; below_to_channel transform ch dag child) children end; Printf.fprintf ch ")" let phase_space_braket transform ch (bra, ket) dag = bra_to_channel transform ch dag bra; Printf.fprintf ch ": {"; begin match ket with | [] -> () | [ket1] -> Printf.fprintf ch " "; ket_to_channel transform ch dag ket1 | ket1 :: kets -> Printf.fprintf ch " "; ket_to_channel transform ch dag ket1; List.iter (fun k -> Printf.fprintf ch " \\\n | "; ket_to_channel transform ch dag k) kets end; Printf.fprintf ch " }\n" (*i Food for thought: let braket_to_tree2 dag (bra, ket) = let bra' = A.D.dependencies dag bra in if Tree2.is_singleton bra' then Tree2.cons [(fst ket, bra, List.map (A.D.dependencies dag) (A.children ket))] else failwith "Fusion.phase_space_channels: wrong topology!" let phase_space_braket transform ch (bra, ket) dag = let n2s wf = variable (transform wf) and e2s c = "" in Printf.fprintf ch "%s\n" (Tree2.to_string n2s e2s (braket_to_tree2 dag (bra, ket))) i*) let phase_space_channels_transformed transform ch a = List.iter (fun braket -> phase_space_braket transform ch braket a.A.fusion_dag) a.A.brakets let phase_space_channels ch a = phase_space_channels_transformed (fun wf -> wf) ch a let exchange_momenta_list p1 p2 p = List.map (fun pi -> if pi = p1 then p2 else if pi = p2 then p1 else pi) p let exchange_momenta p1 p2 p = P.of_ints (P.dim p) (exchange_momenta_list p1 p2 (P.to_ints p)) let flip_momenta wf = { wf with A.momentum = exchange_momenta 1 2 wf.A.momentum } let phase_space_channels_flipped ch a = phase_space_channels_transformed flip_momenta ch a end module Make = Tagged(No_Tags) module Binary = Make(Tuple.Binary)(Stat_Dirac)(Topology.Binary) module Tagged_Binary (T : Tagger) = Tagged(T)(Tuple.Binary)(Stat_Dirac)(Topology.Binary) (* \thocwmodulesection{Fusions with Majorana Fermions} *) let majorana_log silent logging = logging let majorana_log silent logging = silent let force_legacy = true let force_legacy = false module Stat_Majorana (M : Model.T) : (Stat with type flavor = M.flavor) = struct + exception Impossible + type flavor = M.flavor + (* \thocwmodulesubsection{Keeping Track of Fermion Lines} *) + (* JRR's algorithm doesn't use lists of pairs representing - directed arrows as in [Stat._Dirac().stat] above, but a list + directed arrows as in [Stat_Dirac().stat] above, but a list of integers denoting the external leg a fermion line connects to: *) type stat = | Fermion of int * int list | AntiFermion of int * int list | Boson of int list | Majorana of int * int list let sign_of_permutation lines = fst (Combinatorics.sort_signed lines) let lines_equivalent l1 l2 = sign_of_permutation l1 = sign_of_permutation l2 let stat_to_string s = let open Printf in let l2s = ThoList.to_string string_of_int in match s with - | Boson lines -> sprintf "B %s" (l2s lines) - | Fermion (p, lines) -> sprintf "F (%d, %s)" p (l2s lines) - | AntiFermion (p, lines) -> sprintf "A (%d, %s)" p (l2s lines) - | Majorana (p, lines) -> sprintf "M (%d, %s)" p (l2s lines) + | Boson lines -> sprintf "B%s" (l2s lines) + | Fermion (p, lines) -> sprintf "F(%d, %s)" p (l2s lines) + | AntiFermion (p, lines) -> sprintf "A(%d, %s)" p (l2s lines) + | Majorana (p, lines) -> sprintf "M(%d, %s)" p (l2s lines) - (* Writing a cases explicitely to allow exhaustiveness checking - is too tedious here. *) + (* Writing all cases explicitely is tedious, but allows exhaustiveness + checking. *) let equal s1 s2 = match s1, s2 with | Boson l1, Boson l2 -> lines_equivalent l1 l2 | Majorana (p1, l1), Majorana (p2, l2) | Fermion (p1, l1), Fermion (p2, l2) | AntiFermion (p1, l1), AntiFermion (p2, l2) -> p1 = p2 && lines_equivalent l1 l2 - | _ -> false + | Boson _, (Fermion _ | AntiFermion _ | Majorana _ ) + | (Fermion _ | AntiFermion _ | Majorana _ ), Boson _ + | Majorana _, (Fermion _ | AntiFermion _) + | (Fermion _ | AntiFermion _), Majorana _ + | Fermion _ , AntiFermion _ + | AntiFermion _ , Fermion _ -> false (* The final amplitude must not be fermionic! *) - let complete = function + let saturated = function | Boson _ -> true - | _ -> false + | Fermion _ | AntiFermion _ | Majorana _ -> false (* [stat f p] interprets the numeric fermion numbers of flavor [f] at external leg [p] at creates a leaf: *) let stat f p = match M.fermion f with | 0 -> Boson [] | 1 -> Fermion (p, []) | -1 -> AntiFermion (p, []) | 2 -> Majorana (p, []) | _ -> invalid_arg "Fusion.Stat_Majorana: invalid fermion number" -(* In the formalism of~\cite{Denner:Majorana}, it does not matter to distinguish - spinors and conjugate spinors, it is only important to know in which direction +(* The formalism of~\cite{Denner:Majorana} does not distinguish + spinors from conjugate spinors, it is only important to know in which direction a fermion line is calculated. So the sign is made by the calculation together with an aditional one due to the permuation of the pairs of endpoints of fermion lines in the direction they are calculated. We propose a ``canonical'' direction from the right to the left child at a fusion point so we only have to keep in mind which external particle hangs at each side. Therefore we need not to have a list of pairs of conjugate spinors and spinors but just a list in which the pairs are right-left-right-left and so on. Unfortunately it is unavoidable to have couplings with clashing arrows in supersymmetric theories so we need transmutations from fermions in antifermions and vice versa as well. *) - exception Impossible + (* \thocwmodulesubsection{Merge Fermion Lines for Legacy Models with Implied Fermion Connections} *) - (* In old case with at most one fermion line, it was straight + (* In the legacy case with at most one fermion line, it was straight forward to determine the kind of outgoing line from the corresponding flavor. In the general case, it is not possible to maintain this constraint, when constructing the $n$-ary fusion from binary ones. *) (* We can break up the process into two steps however: first perform unconstrained fusions pairwise \ldots *) let stat_fuse_pair_unconstrained s1 s2 = match s1, s2 with | Boson l1, Boson l2 -> Boson (l1 @ l2) | (Majorana (p1, l1) | Fermion (p1, l1) | AntiFermion (p1, l1)), (Majorana (p2, l2) | Fermion (p2, l2) | AntiFermion (p2, l2)) -> Boson ([p2; p1] @ l1 @ l2) | Boson l1, Majorana (p, l2) -> Majorana (p, l1 @ l2) | Boson l1, Fermion (p, l2) -> Fermion (p, l1 @ l2) | Boson l1, AntiFermion (p, l2) -> AntiFermion (p, l1 @ l2) | Majorana (p, l1), Boson l2 -> Majorana (p, l1 @ l2) | Fermion (p, l1), Boson l2 -> Fermion (p, l1 @ l2) | AntiFermion (p, l1), Boson l2 -> AntiFermion (p, l1 @ l2) (* \ldots{} and only apply the constraint to the outgoing leg. *) let constrain_stat_fusion s f = match s, M.lorentz f with | (Majorana (p, l) | Fermion (p, l) | AntiFermion (p, l)), - (Coupling.Majorana | Coupling.Vectorspinor) -> Majorana (p, l) + (Coupling.Majorana | Coupling.Vectorspinor | Coupling.Maj_Ghost) -> + Majorana (p, l) | (Majorana (p, l) | Fermion (p, l) | AntiFermion (p, l)), Coupling.Spinor -> Fermion (p, l) | (Majorana (p, l) | Fermion (p, l) | AntiFermion (p, l)), Coupling.ConjSpinor -> AntiFermion (p, l) - | (Majorana _ | Fermion _ | AntiFermion _ as s), _ -> + | (Majorana _ | Fermion _ | AntiFermion _ as s), + (Coupling.Scalar | Coupling.Vector | Coupling.Massive_Vector + | Coupling.Tensor_1 | Coupling.Tensor_2 | Coupling.BRS _) -> invalid_arg (Printf.sprintf "Fusion.stat_fuse_pair_constrained: expected boson, got %s" (stat_to_string s)) | Boson l as s, - (Coupling.Majorana | Coupling.Spinor | Coupling.ConjSpinor) -> + (Coupling.Majorana | Coupling.Vectorspinor | Coupling.Maj_Ghost + | Coupling.Spinor | Coupling.ConjSpinor) -> invalid_arg (Printf.sprintf "Fusion.stat_fuse_pair_constrained: expected fermion, got %s" (stat_to_string s)) - | Boson l, _ -> Boson l + | Boson l, + (Coupling.Scalar | Coupling.Vector | Coupling.Massive_Vector + | Coupling.Tensor_1 | Coupling.Tensor_2 | Coupling.BRS _) -> + Boson l let stat_fuse_pair_legacy f s1 s2 = stat_fuse_pair_unconstrained s1 s2 let stat_fuse_pair_legacy_logging f s1 s2 = let stat = stat_fuse_pair_legacy f s1 s2 in Printf.eprintf "stat_fuse_pair_legacy: (%s, %s) -> %s = %s\n" (stat_to_string s1) (stat_to_string s2) (stat_to_string stat) (M.flavor_to_string f); stat let stat_fuse_pair_legacy = majorana_log stat_fuse_pair_legacy stat_fuse_pair_legacy_logging (* Note that we are using [List.fold_left], therefore we perform the fusions as $f(f(\ldots(f(s_1,s_2),s_3),\ldots),s_n)$. Had we used [List.fold_right] instead, we would compute $f(s_1,f(s_2,\ldots f(s_{n-1},s_n))).$ For our Dirac algorithm, this makes no difference, but JRR's Majorana algorithm depends on the order! *) (* Also not that we \emph{must not} apply [constrain_stat_fusion] here, because [stat_fuse_legacy] will be used in [stat_keystone_legacy] again, where we always expect [Boson _]. *) let stat_fuse_legacy s1 s23__n f = List.fold_left (stat_fuse_pair_legacy f) s1 s23__n + (*i let stat_fuse_legacy' s1 s23__n f = match List.rev (s1 :: s23__n) with | s1 :: s23__n -> List.fold_left (stat_fuse_pair_legacy f) s1 s23__n | [] -> failwith "stat_fuse_legacy: impossible" let stat_fuse_legacy' s1 s23__n f = List.fold_right (stat_fuse_pair_legacy f) s23__n s1 +i*) let stat_fuse_legacy_logging s1 s23__n f = let stat = stat_fuse_legacy s1 s23__n f in Printf.eprintf "stat_fuse_legacy: %s -> %s = %s\n" (ThoList.to_string stat_to_string (s1 :: s23__n)) (stat_to_string stat) (M.flavor_to_string f); stat let stat_fuse_legacy = majorana_log stat_fuse_legacy stat_fuse_legacy_logging + (* \thocwmodulesubsection{Merge Fermion Lines using Explicit Fermion Connections} *) + (* We need to match the fermion lines in the incoming propagators using the connection information in the vertex. This used to be trivial in the old omega, because there was at most one fermion line in a vertex. *) module IMap = Map.Make (struct type t = int let compare = compare end) (* From version 4.05 on, this is just [IMap.find_opt]. *) let imap_find_opt p map = try Some (IMap.find p map) with Not_found -> None (* Partially combined [stat]s of the incoming propagators and keeping - track of the fermion lines, while we're scanning them. We will + track of the fermion lines, while we're scanning them. *) + type partial = + { stat : stat (* the [stat] accumulated so far *); + fermions : int IMap.t (* a map from the indices in the vertex to open (anti)fermion lines *); + n : int (* the number of incoming propagators *) } + + (* We will perform two passes: \begin{enumerate} \item collect the saturated fermion lines in a [Boson], while building a map from the indices in the vertex to the open fermion lines - \item connect the open fermion lines using this map. + \item connect the open fermion lines using the [int -> int] map + [fermions]. \end{enumerate} *) - type partial = - { stat : stat (* the [stat] accumulated so far *); - fermions : int IMap.t (* a map from the indices in the vertex to open fermion lines *); - n : int (* the number of incoming propagators *) } let empty_partial = { stat = Boson []; fermions = IMap.empty; n = 0 } (* Only for debugging: *) let partial_to_string p = Printf.sprintf - "{ %s, %s, %d }" + "{ fermions=%s, stat=%s, #=%d }" (ThoList.to_string - (fun (i, particle) -> Printf.sprintf "%d@%d" i particle) + (fun (i, particle) -> Printf.sprintf "%d@%d" particle i) (IMap.bindings p.fermions)) (stat_to_string p.stat) p.n (* Add a list of saturated fermion lines at the top of the list of lines in a [stat]. *) let add_lines l = function | Boson l' -> Boson (l @ l') | Fermion (n, l') -> Fermion (n, l @ l') | AntiFermion (n, l') -> AntiFermion (n, l @ l') | Majorana (n, l') -> Majorana (n, l @ l') - (* Single step of pass 1: collect the saturated fermion lines + (* Process one line in the first pass: add the saturated fermion lines + to the partial stat [p.stat] and add a pointer to an open fermion line in case of a fermion. *) let add_lines_to_partial p stat = let n = succ p.n in match stat with | Boson l -> { fermions = p.fermions; stat = add_lines l p.stat; n } | Majorana (f, l) -> { fermions = IMap.add n f p.fermions; stat = add_lines l p.stat; n } | Fermion (p, l) -> invalid_arg - "Fusion.Stat_Majorana.add_lines_to_partial: unexpected Fermion" + "add_lines_to_partial: unexpected Fermion" | AntiFermion (p, l) -> invalid_arg - "Fusion.Stat_Majorana.add_lines_to_partial: unexpected AntiFermion" + "add_lines_to_partial: unexpected AntiFermion" + (* Do it for all lines: *) let partial_of_slist stat_list = List.fold_left add_lines_to_partial empty_partial stat_list let partial_of_rev_slist stat_list = List.fold_left add_lines_to_partial empty_partial (List.rev stat_list) + (* The building blocks for a single step of the second pass: + saturate a fermion line or pass it through. *) + (* The indices [i] and [j] refer to incoming lines: add a saturated line to [p.stat] and remove the corresponding open lines from the map. *) let saturate_fermion_line p i j = match imap_find_opt i p.fermions, imap_find_opt j p.fermions with | Some f, Some f' -> { stat = add_lines [f'; f] p.stat; fermions = IMap.remove i (IMap.remove j p.fermions); n = p.n } - | _ -> invalid_arg "saturate_fermion_line: mismatch" + | Some _, None -> + invalid_arg "saturate_fermion_line: no open outgoing fermion line" + | None, Some _ -> + invalid_arg "saturate_fermion_line: no open incoming fermion line" + | None, None -> + invalid_arg "saturate_fermion_line: no open fermion lines" (* The index [i] refers to an incoming line: add the open line to [p.stat] and remove it from the map. *) let pass_through_fermion_line p i = match imap_find_opt i p.fermions, p.stat with | Some f, Boson l -> { stat = Majorana (f, l); fermions = IMap.remove i p.fermions; n = p.n } - | None, Boson l -> - invalid_arg "pass_through_fermion_line: mismatch" - | _, (Majorana _ | Fermion _ | AntiFermion _) -> - invalid_arg "pass_through_fermion_line: more than one open lines" + | Some _ , (Majorana _ | Fermion _ | AntiFermion _) -> + invalid_arg "pass_through_fermion_line: more than one open line" + | None, _ -> + invalid_arg "pass_through_fermion_line: expected fermion not found" - (* Single step of pass 2: saturate a fermion line or pass it through: *) - - (* \begin{dubious} - Experimental: ignore the direction of the fermion line - in order to reproduce JRR's algorithm. - \end{dubious} *) + (* Ignoring the direction of the fermion line reproduces JRR's algorithm. *) let sort_pair (i, j) = if i < j then (i, j) else (j, i) + (* The index [p.n + 1] corresponds to the outgoing line: *) + let is_incoming p i = + i <= p.n + let match_fermion_line p (i, j) = let i, j = sort_pair (i, j) in - if i <= p.n && j <= p.n then + if is_incoming p i && is_incoming p j then saturate_fermion_line p i j - else if i <= p.n then + else if is_incoming p i then pass_through_fermion_line p i - else if j <= p.n then + else if is_incoming p j then pass_through_fermion_line p j else - failwith "match_fermion_line: impossible" + failwith "match_fermion_line: both lines outgoing" let match_fermion_line_logging p (i, j) = Printf.eprintf - "match_fermion_line %s (%d, %d)" + "match_fermion_line %s [%d->%d]" (partial_to_string p) i j; let p' = match_fermion_line p (i, j) in Printf.eprintf " >> %s\n" (partial_to_string p'); p' let match_fermion_line = majorana_log match_fermion_line match_fermion_line_logging (* Combine the passes \ldots *) let match_fermion_lines flines s1 s23__n = List.fold_left match_fermion_line (partial_of_slist (s1 :: s23__n)) flines (* \ldots{} and keep only the [stat]. *) - let stat_fuse_new flines s1 s23__n f = + let stat_fuse_new flines s1 s23__n _ = (match_fermion_lines flines s1 s23__n).stat + (* If there is at most a single fermion line, we can compare [stat] + against the result of [stat_fuse_legacy] for checking + [stat_fuse_new] (admittedly, this case is rather trivial) \ldots *) let stat_fuse_new_check stat flines s1 s23__n f = if List.length flines < 2 then begin let legacy = stat_fuse_legacy s1 s23__n f in if not (equal stat legacy) then failwith (Printf.sprintf - "Fusion.Stat_Majorana.stat_fuse_new: %s <> %s!" + "stat_fuse_new: %s <> %s!" (stat_to_string stat) (stat_to_string legacy)) end + (* \ldots{} do it, but only when we are writing debugging output. *) let stat_fuse_new_logging flines s1 s23__n f = let stat = stat_fuse_new flines s1 s23__n f in Printf.eprintf "stat_fuse_new: %s: %s -> %s = %s\n" (UFO_Lorentz.fermion_lines_to_string flines) (ThoList.to_string stat_to_string (s1 :: s23__n)) (stat_to_string stat) (M.flavor_to_string f); stat_fuse_new_check stat flines s1 s23__n f; stat let stat_fuse_new = majorana_log stat_fuse_new stat_fuse_new_logging + (* Use [stat_fuse_new], whenever fermion connections are + available. NB: [Some []] is \emph{not} the same as [None]! *) let stat_fuse flines_opt slist f = match slist with - | [] -> invalid_arg "Fusion.Stat_Majorana.stat_fuse: empty" + | [] -> invalid_arg "stat_fuse: empty" | s1 :: s23__n -> constrain_stat_fusion (match flines_opt with | Some flines -> stat_fuse_new flines s1 s23__n f - | None -> stat_fuse_legacy s1 s23__n f) f + | None -> stat_fuse_legacy s1 s23__n f) + f let stat_fuse_logging flines_opt slist f = let stat = stat_fuse flines_opt slist f in Printf.eprintf "stat_fuse: %s -> %s = %s\n" (ThoList.to_string stat_to_string slist) (stat_to_string stat) (M.flavor_to_string f); stat let stat_fuse = majorana_log stat_fuse stat_fuse_logging + (* \thocwmodulesubsection{Final Step using Implied Fermion Connections} *) + let stat_keystone_legacy s1 s23__n f = stat_fuse_legacy s1 s23__n f let stat_keystone_legacy_logging s1 s23__n f = let s = stat_keystone_legacy s1 s23__n f in Printf.eprintf "stat_keystone_legacy: %s (%s) %s -> %s\n" (stat_to_string s1) (M.flavor_to_string f) (ThoList.to_string stat_to_string s23__n) (stat_to_string s); s let stat_keystone_legacy = majorana_log stat_keystone_legacy stat_keystone_legacy_logging - let stat_keystone flines_opt slist f = + (* \thocwmodulesubsection{Final Step using Explicit Fermion Connections} *) + + let stat_keystone_new flines slist f = match slist with - | [] -> invalid_arg "Fusion.Stat_Majorana.stat_keystone: empty" - | [s] -> invalid_arg "Fusion.Stat_Majorana.stat_keystone: singleton" - | s1 :: (s2 :: s34__n as s23__n) -> - begin match flines_opt with - | None -> stat_keystone_legacy s1 s23__n f - | Some flines -> - let stat = - stat_fuse_legacy s1 [stat_fuse_new flines s2 s34__n f] f - and legacy = stat_keystone_legacy s1 s23__n f in - if not (equal stat legacy) then - failwith - (Printf.sprintf - "Fusion.Stat_Majorana.stat_keystone: %s <> %s!" - (stat_to_string stat) - (stat_to_string legacy)); - if complete stat then - stat - else - failwith - (Printf.sprintf - "Fusion.Stat_Majorana.stat_keystone: incomplete %s!" - (stat_to_string stat)) + | [] -> invalid_arg "stat_keystone: empty" + | [s] -> invalid_arg "stat_keystone: singleton" + | s1 :: s2 :: s34__n -> + let stat = + stat_fuse_pair_unconstrained s1 (stat_fuse_new flines s2 s34__n f) in + if saturated stat then + stat + else + failwith + (Printf.sprintf + "stat_keystone: incomplete %s!" + (stat_to_string stat)) + + let stat_keystone_new_check stat slist f = + match slist with + | [] -> invalid_arg "stat_keystone_check: empty" + | s1 :: s23__n -> + let legacy = stat_keystone_legacy s1 s23__n f in + if not (equal stat legacy) then + failwith + (Printf.sprintf + "stat_keystone_check: %s <> %s!" + (stat_to_string stat) + (stat_to_string legacy)) + + let stat_keystone flines_opt slist f = + match flines_opt with + | Some flines -> stat_keystone_new flines slist f + | None -> + begin match slist with + | [] -> invalid_arg "stat_keystone: empty" + | s1 :: s23__n -> stat_keystone_legacy s1 s23__n f end + let stat_keystone_logging flines_opt slist f = + let stat = stat_keystone flines_opt slist f in + Printf.eprintf + "stat_keystone: %s (%s) %s -> %s\n" + (stat_to_string (List.hd slist)) + (M.flavor_to_string f) + (ThoList.to_string stat_to_string (List.tl slist)) + (stat_to_string stat); + stat_keystone_new_check stat slist f; + stat + + let stat_keystone = + majorana_log stat_keystone stat_keystone_logging + (* Force the legacy version w/o checking against the new implementation for comparing generated code against the hard coded models: *) let stat_fuse flines_opt slist f = if force_legacy then stat_fuse_legacy (List.hd slist) (List.tl slist) f else stat_fuse flines_opt slist f let stat_keystone flines_opt slist f = if force_legacy then stat_keystone_legacy (List.hd slist) (List.tl slist) f else stat_keystone flines_opt slist f + (* \thocwmodulesubsection{Evaluate Signs from Fermion Permuations} *) + let stat_sign = function | Boson lines -> sign_of_permutation lines | Fermion (p, lines) -> sign_of_permutation (p :: lines) | AntiFermion (pbar, lines) -> sign_of_permutation (pbar :: lines) | Majorana (pm, lines) -> sign_of_permutation (pm :: lines) let stat_sign_logging stat = let sign = stat_sign stat in Printf.eprintf "stat_sign: %s -> %d\n" (stat_to_string stat) sign; sign let stat_sign = majorana_log stat_sign stat_sign_logging end module Binary_Majorana = Make(Tuple.Binary)(Stat_Majorana)(Topology.Binary) module Nary (B: Tuple.Bound) = Make(Tuple.Nary(B))(Stat_Dirac)(Topology.Nary(B)) module Nary_Majorana (B: Tuple.Bound) = Make(Tuple.Nary(B))(Stat_Majorana)(Topology.Nary(B)) module Mixed23 = Make(Tuple.Mixed23)(Stat_Dirac)(Topology.Mixed23) module Mixed23_Majorana = Make(Tuple.Mixed23)(Stat_Majorana)(Topology.Mixed23) module Helac (B: Tuple.Bound) = Make(Tuple.Nary(B))(Stat_Dirac)(Topology.Helac(B)) module Helac_Majorana (B: Tuple.Bound) = Make(Tuple.Nary(B))(Stat_Majorana)(Topology.Helac(B)) (* \thocwmodulesection{Multiple Amplitudes} *) module type Multi = sig exception Mismatch val options : Options.t type flavor type process = flavor list * flavor list type amplitude type fusion type wf type exclusions val no_exclusions : exclusions type selectors type amplitudes val amplitudes : bool -> int option -> exclusions -> selectors -> process list -> amplitudes val empty : amplitudes val initialize_cache : string -> unit val set_cache_name : string -> unit val flavors : amplitudes -> process list val vanishing_flavors : amplitudes -> process list val color_flows : amplitudes -> Color.Flow.t list val helicities : amplitudes -> (int list * int list) list val processes : amplitudes -> amplitude list val process_table : amplitudes -> amplitude option array array val fusions : amplitudes -> (fusion * amplitude) list val multiplicity : amplitudes -> wf -> int val dictionary : amplitudes -> amplitude -> wf -> int val color_factors : amplitudes -> Color.Flow.factor array array val constraints : amplitudes -> string option end module type Multi_Maker = functor (Fusion_Maker : Maker) -> functor (P : Momentum.T) -> functor (M : Model.T) -> Multi with type flavor = M.flavor and type amplitude = Fusion_Maker(P)(M).amplitude and type fusion = Fusion_Maker(P)(M).fusion and type wf = Fusion_Maker(P)(M).wf and type selectors = Fusion_Maker(P)(M).selectors module Multi (Fusion_Maker : Maker) (P : Momentum.T) (M : Model.T) = struct exception Mismatch type progress_mode = | Quiet | Channel of out_channel | File of string let progress_option = ref Quiet module CM = Colorize.It(M) module F = Fusion_Maker(P)(M) module C = Cascade.Make(M)(P) (* \begin{dubious} A kludge, at best \ldots \end{dubious} *) let options = Options.extend F.options [ "progress", Arg.Unit (fun () -> progress_option := Channel stderr), "report progress to the standard error stream"; "progress_file", Arg.String (fun s -> progress_option := File s), "report progress to a file" ] type flavor = M.flavor type p = F.p type process = flavor list * flavor list type amplitude = F.amplitude type fusion = F.fusion type wf = F.wf type exclusions = F.exclusions let no_exclusions = F.no_exclusions type selectors = F.selectors type flavors = flavor list array type helicities = int list array type colors = Color.Flow.t array type amplitudes' = amplitude array array array type amplitudes = { flavors : process list; vanishing_flavors : process list; color_flows : Color.Flow.t list; helicities : (int list * int list) list; processes : amplitude list; process_table : amplitude option array array; fusions : (fusion * amplitude) list; multiplicity : (wf -> int); dictionary : (amplitude -> wf -> int); color_factors : Color.Flow.factor array array; constraints : string option } let flavors a = a.flavors let vanishing_flavors a = a.vanishing_flavors let color_flows a = a.color_flows let helicities a = a.helicities let processes a = a.processes let process_table a = a.process_table let fusions a = a.fusions let multiplicity a = a.multiplicity let dictionary a = a.dictionary let color_factors a = a.color_factors let constraints a = a.constraints let sans_colors f = List.map CM.flavor_sans_color f let colors (fin, fout) = List.map M.color (fin @ fout) let process_sans_color a = (sans_colors (F.incoming a), sans_colors (F.outgoing a)) let color_flow a = CM.flow (F.incoming a) (F.outgoing a) let process_to_string fin fout = String.concat " " (List.map M.flavor_to_string fin) ^ " -> " ^ String.concat " " (List.map M.flavor_to_string fout) let count_processes colored_processes = List.length colored_processes module FMap = Map.Make (struct type t = process let compare = compare end) module CMap = Map.Make (struct type t = Color.Flow.t let compare = compare end) (* Recently [Product.list] began to guarantee lexicographic order for sorted arguments. Anyway, we still force a lexicographic order. *) let rec order_spin_table1 s1 s2 = match s1, s2 with | h1 :: t1, h2 :: t2 -> let c = compare h1 h2 in if c <> 0 then c else order_spin_table1 t1 t2 | [], [] -> 0 | _ -> invalid_arg "order_spin_table: inconsistent lengths" let order_spin_table (s1_in, s1_out) (s2_in, s2_out) = let c = compare s1_in s2_in in if c <> 0 then c else order_spin_table1 s1_out s2_out let sort_spin_table table = List.sort order_spin_table table let id x = x let pair x y = (x, y) (* \begin{dubious} Improve support for on shell Ward identities: [Coupling.Vector -> [4]] for one and only one external vector. \end{dubious} *) let rec hs_of_lorentz = function | Coupling.Scalar -> [0] | Coupling.Spinor | Coupling.ConjSpinor | Coupling.Majorana | Coupling.Maj_Ghost -> [-1; 1] | Coupling.Vector -> [-1; 1] | Coupling.Massive_Vector -> [-1; 0; 1] | Coupling.Tensor_1 -> [-1; 0; 1] | Coupling.Vectorspinor -> [-2; -1; 1; 2] | Coupling.Tensor_2 -> [-2; -1; 0; 1; 2] | Coupling.BRS f -> hs_of_lorentz f let hs_of_flavor f = hs_of_lorentz (M.lorentz f) let hs_of_flavors (fin, fout) = (List.map hs_of_flavor fin, List.map hs_of_flavor fout) let rec unphysical_of_lorentz = function | Coupling.Vector -> [4] | Coupling.Massive_Vector -> [4] | _ -> invalid_arg "unphysical_of_lorentz: not a vector particle" let unphysical_of_flavor f = unphysical_of_lorentz (M.lorentz f) let unphysical_of_flavors1 n f_list = ThoList.mapi (fun i f -> if i = n then unphysical_of_flavor f else hs_of_flavor f) 1 f_list let unphysical_of_flavors n (fin, fout) = (unphysical_of_flavors1 n fin, unphysical_of_flavors1 (n - List.length fin) fout) let helicity_table unphysical flavors = let hs = begin match unphysical with | None -> List.map hs_of_flavors flavors | Some n -> List.map (unphysical_of_flavors n) flavors end in if not (ThoList.homogeneous hs) then invalid_arg "Fusion.helicity_table: not all flavors have the same helicity states!" else match hs with | [] -> [] | (hs_in, hs_out) :: _ -> sort_spin_table (Product.list2 pair (Product.list id hs_in) (Product.list id hs_out)) module Proc = Process.Make(M) module WFMap = Map.Make (struct type t = F.wf let compare = compare end) module WFSet2 = Set.Make (struct type t = F.wf * (F.wf, F.coupling) Tree2.t let compare = compare end) module WFMap2 = Map.Make (struct type t = F.wf * (F.wf, F.coupling) Tree2.t let compare = compare end) module WFTSet = Set.Make (struct type t = (F.wf, F.coupling) Tree2.t let compare = compare end) (* All wavefunctions are unique per amplitude. So we can use per-amplitude dependency trees without additional \emph{internal} tags to identify identical wave functions. *) (* \textbf{NB:} we miss potential optimizations, because we assume all coupling to be different, while in fact we have horizontal/family symmetries and non abelian gauge couplings are universal anyway. *) let disambiguate_fusions amplitudes = let fusions = ThoList.flatmap (fun amplitude -> List.map (fun fusion -> (fusion, F.dependencies amplitude (F.lhs fusion))) (F.fusions amplitude)) amplitudes in let duplicates = List.fold_left (fun map (fusion, dependencies) -> let wf = F.lhs fusion in let set = try WFMap.find wf map with Not_found -> WFTSet.empty in WFMap.add wf (WFTSet.add dependencies set) map) WFMap.empty fusions in let multiplicity_map = WFMap.fold (fun wf dependencies acc -> let cardinal = WFTSet.cardinal dependencies in if cardinal <= 1 then acc else WFMap.add wf cardinal acc) duplicates WFMap.empty and dictionary_map = WFMap.fold (fun wf dependencies acc -> let cardinal = WFTSet.cardinal dependencies in if cardinal <= 1 then acc else snd (WFTSet.fold (fun dependency (i', acc') -> (succ i', WFMap2.add (wf, dependency) i' acc')) dependencies (1, acc))) duplicates WFMap2.empty in let multiplicity wf = WFMap.find wf multiplicity_map and dictionary amplitude wf = WFMap2.find (wf, F.dependencies amplitude wf) dictionary_map in (multiplicity, dictionary) let eliminate_common_fusions1 seen_wfs amplitude = List.fold_left (fun (seen, acc) f -> let wf = F.lhs f in let dependencies = F.dependencies amplitude wf in if WFSet2.mem (wf, dependencies) seen then (seen, acc) else (WFSet2.add (wf, dependencies) seen, (f, amplitude) :: acc)) seen_wfs (F.fusions amplitude) let eliminate_common_fusions processes = let _, rev_fusions = List.fold_left eliminate_common_fusions1 (WFSet2.empty, []) processes in List.rev rev_fusions (*i let eliminate_common_fusions processes = ThoList.flatmap (fun amplitude -> (List.map (fun f -> (f, amplitude)) (F.fusions amplitude))) processes i*) (* \thocwmodulesubsection{Calculate All The Amplitudes} *) let amplitudes goldstones unphysical exclusions select_wf processes = (* \begin{dubious} Eventually, we might want to support inhomogeneous helicities. However, this makes little physics sense for external particles on the mass shell, unless we have a model with degenerate massive fermions and bosons. \end{dubious} *) if not (ThoList.homogeneous (List.map hs_of_flavors processes)) then invalid_arg "Fusion.Multi.amplitudes: incompatible helicities"; let unique_uncolored_processes = Proc.remove_duplicate_final_states (C.partition select_wf) processes in let progress = match !progress_option with | Quiet -> Progress.dummy | Channel oc -> Progress.channel oc (count_processes unique_uncolored_processes) | File name -> Progress.file name (count_processes unique_uncolored_processes) in let allowed = ThoList.flatmap (fun (fi, fo) -> Progress.begin_step progress (process_to_string fi fo); let amps = F.amplitudes goldstones exclusions select_wf fi fo in begin match amps with | [] -> Progress.end_step progress "forbidden" | _ -> Progress.end_step progress "allowed" end; amps) unique_uncolored_processes in Progress.summary progress "all processes done"; let color_flows = ThoList.uniq (List.sort compare (List.map color_flow allowed)) and flavors = ThoList.uniq (List.sort compare (List.map process_sans_color allowed)) in let vanishing_flavors = Proc.diff processes flavors in let helicities = helicity_table unphysical flavors in let f_index = fst (List.fold_left (fun (m, i) f -> (FMap.add f i m, succ i)) (FMap.empty, 0) flavors) and c_index = fst (List.fold_left (fun (m, i) c -> (CMap.add c i m, succ i)) (CMap.empty, 0) color_flows) in let table = Array.make_matrix (List.length flavors) (List.length color_flows) None in List.iter (fun a -> let f = FMap.find (process_sans_color a) f_index and c = CMap.find (color_flow a) c_index in table.(f).(c) <- Some (a)) allowed; let cf_array = Array.of_list color_flows in let ncf = Array.length cf_array in let color_factor_table = Array.make_matrix ncf ncf Color.Flow.zero in for i = 0 to pred ncf do for j = 0 to i do color_factor_table.(i).(j) <- Color.Flow.factor cf_array.(i) cf_array.(j); color_factor_table.(j).(i) <- color_factor_table.(i).(j) done done; let fusions = eliminate_common_fusions allowed and multiplicity, dictionary = disambiguate_fusions allowed in { flavors = flavors; vanishing_flavors = vanishing_flavors; color_flows = color_flows; helicities = helicities; processes = allowed; process_table = table; fusions = fusions; multiplicity = multiplicity; dictionary = dictionary; color_factors = color_factor_table; constraints = C.description select_wf } let initialize_cache = F.initialize_cache let set_cache_name = F.set_cache_name let empty = { flavors = []; vanishing_flavors = []; color_flows = []; helicities = []; processes = []; process_table = Array.make_matrix 0 0 None; fusions = []; multiplicity = (fun _ -> 1); dictionary = (fun _ _ -> 1); color_factors = Array.make_matrix 0 0 Color.Flow.zero; constraints = None } end Index: trunk/omega/src/UFO_Lorentz.ml =================================================================== --- trunk/omega/src/UFO_Lorentz.ml (revision 8491) +++ trunk/omega/src/UFO_Lorentz.ml (revision 8492) @@ -1,892 +1,1020 @@ (* UFO_Lorentz.ml -- Copyright (C) 1999-2017 by Wolfgang Kilian Thorsten Ohl Juergen Reuter with contributions from Christian Speckner WHIZARD 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 2, or (at your option) any later version. WHIZARD 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, write to the Free Software Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. *) (* \thocwmodulesection{Processed UFO Lorentz Structures} *) module Q = Algebra.Q module QC = Algebra.QC module A = UFOx.Lorentz_Atom module D = Dirac.Chiral (* Take a [A.t list] and return the corresponding pair [A.dirac list * A.vector list * A.scalar list * A.scalar list], without preserving the order (currently, the order is reversed). *) let split_atoms atoms = List.fold_left (fun (d, v, s, i) -> function | A.Vector v' -> (d, v' :: v, s, i) | A.Dirac d' -> (d' :: d, v, s, i) | A.Scalar s' -> (d, v, s' :: s, i) | A.Inverse i' -> (d, v, s, i' :: i)) ([], [], [], []) atoms (* Just like [UFOx.Lorentz_Atom.dirac], but without the Dirac matrix indices. *) type dirac = | Gamma5 | ProjM | ProjP | Gamma of int | Sigma of int * int | C | Minus let map_indices_gamma f = function | (Gamma5 | ProjM | ProjP | C | Minus as g) -> g | Gamma mu -> Gamma (f mu) | Sigma (mu, nu) -> Sigma (f mu, f nu) (* A sandwich of a string of $\gamma$-matrices. [bra] and [ket] are positions of fields in the vertex. *) type dirac_string = { bra : int; ket : int; + conjugated : bool; gammas : dirac list } let map_indices_dirac f d = { bra = f d.bra; ket = f d.ket; + conjugated = d.conjugated; gammas = List.map (map_indices_gamma f) d.gammas } -(* - Implementation of Dirac couplings using - \texttt{conjspinor\_spinor} +let toggle_conjugated ds = + { ds with conjugated = not ds.conjugated } + +let flip_bra_ket ds = + { ds with bra = ds.ket; ket = ds.bra } + +(* The implementation of couplings for Dirac spinors in + \texttt{omega\_spinors} uses + \texttt{conjspinor\_spinor} which is a straightforward + positive inner product \begin{equation} \text{\texttt{psibar0 * psi1}} - = \sum_\alpha \bar\psi_{0,\alpha} \psi_{1,\alpha} = \bar\psi_0\psi_1 + = \sum_\alpha \bar\psi_{0,\alpha} \psi_{1,\alpha}\,. \end{equation} - JRR's implementation of Majorana couplings using - \texttt{spinor\_product} + Note that~the row spinor~$\bar\psi_0$ is the actual argument, + it is \emph{not} conjugated and multplied by~$\gamma_0$! + In contrast, JRR's implementation of couplings for Majorana spinors uses + \texttt{spinor\_product} in \texttt{omega\_bispinors} \begin{equation} - \text{\texttt{chibar0 * chi1}} - = \sum_{\alpha} \bar\chi_{0,\alpha} (C^T\chi_1)_\beta - = \sum_{\alpha} (C\bar\chi_0^T)_\alpha \chi_{1,\alpha} - = (C\bar\chi_0^T)^T \chi_1 - = \tilde\chi_0^T\chi_1 + \text{\texttt{chi0 * chi1}} = \chi_0^T C\chi_1 \end{equation} - with charge conjugation\footnote{% - In detail, to make sure we understand all phases - \begin{multline} - \bar{\tilde\chi} - = \tilde\chi^\dagger\gamma_0 - = \left(C\bar\chi^T\right)^\dagger\gamma_0 - = \left(C(\chi^\dagger\gamma_0)^T\right)^\dagger\gamma_0 - = \left(C\gamma_0^T{\chi^\dagger}^T\right)^\dagger\gamma_0 - = \left(C\gamma_0^T{\chi^T}^\dagger\right)^\dagger\gamma_0 - = {\chi^T} {\gamma_0^T}^\dagger C^\dagger\gamma_0 \\ - = {\chi^T} {\gamma_0^\dagger}^T C^{-1}\gamma_0 - = {\chi^T} {\gamma_0}^T C^{-1}\gamma_0 - = {\chi^T} C^{-1} C {\gamma_0}^T C^{-1}\gamma_0 - = - {\chi^T} C^{-1} \gamma_0 \gamma_0 - = - {\chi^T} C^{-1}\,. - \end{multline}} + with a charge antisymmetric and unitary conjugation matrix: + $C^{-1}=C^\dagger$ and~$C^T=-C$. This product is obviously + antisymmetric: + \begin{equation} + \text{\texttt{chi0 * chi1}} + = \chi_0^T C\chi_1 + = \chi_1^T C^T\chi_0 + = - \chi_1^T C\chi_0 + = \text{\texttt{- chi1 * chi0}}\,. + \end{equation} *) + +(*i \begin{subequations} \begin{align} \tilde\chi &= C\bar\chi^T \\ \bar{\tilde\chi} &= -\chi^T C^{-1} \,. \end{align} \end{subequations} So we write in JRR's implementation \begin{equation} \bar\chi_0 \Gamma \chi_1\phi = \bar\chi_0 C^T C\Gamma \chi_1\phi = (C\bar\chi_0^T)^T C\Gamma \chi_1\phi = \tilde\chi_0^T C\Gamma \chi_1\phi \end{equation} using~$C^{-1}=C^\dagger$, $C^T=-C$ and the representation - dependent~$C^2=-1$ that holds in all our representation(s). - Analoguously + dependent~$C^2=-\mathbf{1}$ that holds in all our representation(s). + Analogously \begin{multline} \bar\chi_0 \Gamma \chi_1\phi = \left(\bar\chi_0 \Gamma \chi_1\right)^T \phi = - \chi_1^T \Gamma^T \bar\chi_0^T \phi = \bar{\tilde\chi}_1 C \Gamma^T C^{-1}\tilde\chi_0 \phi = - \chi_1^T C^{-1} C \Gamma^T C^{-1}\tilde\chi_0 \phi \\ = - \chi_1^T \Gamma^T C^{-1}\tilde\chi_0 \phi = - \chi_1^T \Gamma^T C^T \tilde\chi_0 \phi = - \chi_1^T (C\Gamma)^T \tilde\chi_0 \phi \end{multline} - *) +i*) (* In the following, we assume to be in a realization - with~$C^{-1}=-C=C^T$: *) + with~$C^{-1}=-C$, i.\,e.~$C^2=-\mathbf{1}$: *) let inv_C = [Minus; C] (* In JRR's implementation of Majorana fermions - (see~\pageref{pg:JRR-Fusions}), + (see page~\pageref{pg:JRR-Fusions}), \emph{all} fermion-boson fusions are realized with the - \texttt{f\_}$b$\texttt{f(g,phi,chi)} functions, where - $b\in\{\text{\texttt{v}},\text{\texttt{a}},\ldots\}$. + \texttt{f\_}$\phi$\texttt{f(g,phi,chi)} functions, where + $\phi\in\{\text{\texttt{v}},\text{\texttt{a}},\ldots\}$. This is different from the original Dirac implementation, where - \emph{both} \texttt{f\_}$b$\texttt{f(g,phi,psi)} - and \texttt{f\_f}$b$\texttt{(g,psibar,phi)} are used. *) - -(* However, the latter plays nicer with the permutations in the UFO - version of [fuse]. Therefore, we want to automatically map - \texttt{f\_}$b$\texttt{f(g,phi,chi)} to - \texttt{f\_f}$b$\texttt{(g,chi,phi)} by an appropriate + \emph{both} \texttt{f\_}$\phi$\texttt{f(g,phi,psi)} + and \texttt{f\_f}$\phi$\texttt{(g,psibar,phi)} are used. + However, the latter plays nicer with the permutations in the UFO + version of [fuse]. Therefore, we can attempt to automatically map + \texttt{f\_}$\phi$\texttt{f(g,phi,chi)} to + \texttt{f\_f}$\phi$\texttt{(g,chi,phi)} by an appropriate transformation of the $\gamma$-matrices involved. *) (* Starting from \begin{equation} - \text{\texttt{f\_}$b$\texttt{f(g,phi,chi)}} - \cong - \chi'_\alpha = - \sum_{\mu,\beta} \phi_\mu \Gamma^\mu_{\alpha\beta}\chi_\beta + \text{\texttt{f\_}$\phi$\texttt{f(g,phi,chi)}} + = \Gamma_\phi^\mu\chi \end{equation} - with~$\Gamma$ an appropriate product of $\gamma$-matrices, we obtain - \begin{equation} - \text{\texttt{f\_f}$b$\texttt{(g,chi,phi)}} - \cong - \chi'_\alpha - = \sum_{\mu,\beta} \phi_\mu \chi_\beta\tilde\Gamma^\mu_{\beta\alpha} - = \sum_{\mu,\beta} \phi_\mu - \left(\tilde\Gamma^\mu\right)^T_{\alpha\beta} \chi_\beta + where~$\Gamma_\phi$ is the contraction of the bosonic field~$\phi$ with + the appropriate product of $\gamma$-matrices, we obtain a condition on + the corresponding matrix~$\tilde\Gamma_\phi$ that appears + in~\texttt{f\_f}$\phi$: + \begin{equation} + \label{eq:Gamma-tilde} + \text{\texttt{f\_f}$\phi$\texttt{(g,chi,phi)}} + = \chi^T\tilde\Gamma_\phi^\mu + = \left((\tilde\Gamma_\phi)^T \chi\right)^T + \stackrel{!}{=} \left(\Gamma_\phi\chi\right)^T\,. \end{equation} - and we should require $\tilde\Gamma=\Gamma^T$. *) + This amounts to requiring $\tilde\Gamma=\Gamma^T$, as one might have + expected. Below we will see that this is \emph{not} the correct + approach. *) -(* We can now use the standard charge conjugation matrix relations +(* In any case, we can use the standard charge conjugation matrix relations \begin{subequations} + \label{eq:transpose-gamma} \begin{align} \mathbf{1}^T &= \mathbf{1} \\ \gamma_\mu^T &= - C\gamma_\mu C^{-1} \\ \sigma_{\mu\nu}^T &= C\sigma_{\nu\mu} C^{-1} = - C\sigma_{\mu\nu} C^{-1} \\ (\gamma_5\gamma_\mu)^T &= \gamma_\mu^T \gamma_5^T = - C\gamma_\mu\gamma_5 C^{-1} = C\gamma_5\gamma_\mu C^{-1} \\ \gamma_5^T &= C\gamma_5 C^{-1} \end{align} \end{subequations} to perform the transpositions symbolically. For the chiral projectors \begin{equation} \gamma_\pm = \mathbf{1}\pm\gamma_5 \end{equation} this means\footnote{The final two equations are two different ways to obtain the same result, of course.} \begin{subequations} + \label{eq:transpose-gamma'} \begin{align} \gamma_\pm^T &= (\mathbf{1}\pm\gamma_5)^T = C(\mathbf{1}\pm\gamma_5) C^{-1} = C\gamma_\pm C^{-1} \\ (\gamma_\mu\gamma_\pm)^T &= \gamma_\pm^T \gamma_\mu^T = - C\gamma_\pm \gamma_\mu C^{-1} = - C\gamma_\mu\gamma_\mp C^{-1} \\ (\gamma_\mu\pm\gamma_\mu\gamma_5)^T &= - C(\gamma_\mu\mp\gamma_\mu\gamma_5) C^{-1} \end{align} \end{subequations} and of course \begin{equation} C^T = - C\,. \end{equation} *) +(* The implementation starts from transposing + a single factor using~\eqref{eq:transpose-gamma} + and~\eqref{eq:transpose-gamma'}: *) let transpose1 = function | (Gamma5 | ProjM | ProjP as g) -> [C; g] @ inv_C | (Gamma _ | Sigma (_, _) as g) -> [Minus] @ [C; g] @ inv_C | C -> [Minus; C] | Minus -> [Minus] +(* In general, this will leave more than one [Minus] in the result + and we can pull these out: *) let rec collect_signs_rev (negative, acc) = function | [] -> (negative, acc) | Minus :: g_list -> collect_signs_rev (not negative, acc) g_list | g :: g_list -> collect_signs_rev (negative, g :: acc) g_list +(* Also, there will be products~$CC$ inside the result, these can be + canceled, since we assume~$C^2=-\mathbf{1}$: *) let rec compress_ccs_rev (negative, acc) = function | [] -> (negative, acc) | C :: C :: g_list -> compress_ccs_rev (not negative, acc) g_list | g :: g_list -> compress_ccs_rev (negative, g :: acc) g_list +(* Compose [collect_signs_rev] and [compress_ccs_rev]. The two list + reversals will cancel. *) let compress_signs g_list = let negative, g_list_rev = collect_signs_rev (false, []) g_list in match compress_ccs_rev (negative, []) g_list_rev with | true, g_list -> Minus :: g_list | false, g_list -> g_list +(* Transpose all factors in reverse order and clean up: *) let transpose d = { d with gammas = compress_signs (ThoList.rev_flatmap transpose1 d.gammas) } -(* Regarding the tests in \texttt{keystones\_UFO\_bispinors}, we observe% +(* We can also easily flip the sign: *) +let minus d = + { d with gammas = compress_signs (Minus :: d.gammas) } + +(*i \footnote{In components: \begin{subequations} \begin{align} - \text{\texttt{chi0 * f\_}$b$\texttt{f(g,phi1,chi2)}} + \text{\texttt{chi0 * f\_}$\phi$\texttt{f(g,phi1,chi2)}} &\cong \sum_{\mu,\alpha,\alpha',\beta} \phi_{1,\mu} C_{\alpha\alpha'}\chi_{0,\alpha'} \Gamma^\mu_{\alpha\beta}\chi_{2,\beta} = \sum_{\mu,\alpha,\alpha',\beta} \phi_{1,\mu} \chi_{0,\alpha'} C^T_{\alpha'\alpha} \Gamma^\mu_{\alpha\beta}\chi_{2,\beta} \\ - \text{\texttt{f\_f}$b$\texttt{(g,chi0,phi1) * chi2}} + \text{\texttt{f\_f}$\phi$\texttt{(g,chi0,phi1) * chi2}} &\cong \sum_{\mu,\alpha,\alpha',\beta} \phi_{1,\mu} C_{\alpha\alpha'}\chi_{0,\beta} \tilde\Gamma^\mu_{\beta\alpha'} \chi_{2,\alpha} =\sum_{\mu,\alpha,\alpha',\beta} \phi_{1,\mu} \chi_{0,\beta} \tilde\Gamma^\mu_{\beta\alpha'} C^T_{\alpha'\alpha}\chi_{2,\alpha} \\ - \text{\texttt{chi2 * f\_f}$b$\texttt{(g,chi0,phi1)}} + \text{\texttt{chi2 * f\_f}$\phi$\texttt{(g,chi0,phi1)}} &\cong \sum_{\mu,\alpha,\alpha',\beta} \phi_{1,\mu} C_{\alpha\alpha'} \chi_{2,\alpha'} \chi_{0,\beta} \tilde\Gamma^\mu_{\beta\alpha} =\sum_{\mu,\alpha,\alpha',\beta} \phi_{1,\mu} \chi_{0,\beta} \tilde\Gamma^\mu_{\beta\alpha} C_{\alpha\alpha'} \chi_{2,\alpha'} \end{align} \end{subequations}} +i*) + +(* Also in \texttt{omega\_spinors} + \begin{equation} + \text{$\phi$\texttt{\_ff(g,psibar1,psi2)}} + = \bar\psi_1 \Gamma_\phi\psi_2\,, + \end{equation} + while in \texttt{omega\_bispinors} + \begin{equation} + \text{$\phi$\texttt{\_ff(g,chi1,chi2)}} + = \chi_1^T C\Gamma_\phi\chi_2\,. + \end{equation} + The latter has mixed symmetry, depending on the $\gamma$-matrices + in~$\Gamma_\phi$ according to~\eqref{eq:transpose-gamma} + and~\eqref{eq:transpose-gamma'} + \begin{equation} + \text{$\phi$\texttt{\_ff(g,chi2,chi1)}} + = \chi_2^T C\Gamma_{\phi}\chi_1 + = \chi_1^T \Gamma^T_{\phi} C^T\chi_2 + = - \chi_1^T \Gamma^T_{\phi} C\chi_2 + = \pm \chi_1^T C \Gamma_{\phi} C^{-1} C\chi_2 + = \pm \chi_1^T C \Gamma_{\phi} \chi_2\,. + \end{equation} *) + +(* \thocwmodulesection{Testing for Self-Consistency Numerically} *) + +(* In the tests \texttt{keystones\_omegalib} and \texttt{keystones\_UFO}, + we check that the vertex~$\bar\psi_0\Gamma_{\phi_1}\psi_2$ can be + expressed in three ways, which must all agree. + In the case of \texttt{keystones\_omegalib}, the equivalences are \begin{subequations} \begin{align} - \text{\texttt{chi0 * f\_}$b$\texttt{f(g,phi1,chi2)}} - &\cong - \phi_1^\mu (C\chi_0)^T \Gamma_\mu \chi_2 - = \phi_1^\mu \chi_0^T C^T\Gamma_\mu\chi_2 \\ - \text{\texttt{f\_f}$b$\texttt{(g,chi0,phi1) * chi2}} - &\cong - \phi_1^\mu (C(\chi_0^T\tilde\Gamma_\mu)^T)^T \chi_2 - = \phi_1 (C\tilde\Gamma_\mu^T\chi_0)^T \chi_2 - = \phi_1 \chi_0^T \tilde\Gamma_\mu C^T \chi_2 \\ - \text{\texttt{chi2 * f\_f}$b$\texttt{(g,chi0,phi1)}} - &\cong - \phi_1^\mu (C\chi_2)^T (\chi_0^T\tilde\Gamma_\mu)^T - =\phi_1^\mu \chi_0^T\tilde\Gamma_\mu C\chi_2 + \text{\texttt{psibar0 * f\_$\phi$f(g,phi1,psi2)}} + &= \bar\psi_0 \Gamma_{\phi_1} \psi_2 \\ + \text{\texttt{f\_f$\phi$(g,psibar0,phi1) * psi2}} + &= \bar\psi_0 \Gamma_{\phi_1} \psi_2 \\ + \text{\texttt{phi1 * $\phi$\_ff(g,psibar0,psi2)}} + &= \bar\psi_0 \Gamma_{\phi_1} \psi_2 \,. \end{align} \end{subequations} - The natural - condition~$\text{\texttt{chi0 * f\_}$b$\texttt{f(g,phi1,chi2)}} - = \text{\texttt{f\_f}$b$\texttt{(g,chi0,phi1) * chi2}}$ - can be satisfied with - \begin{equation} - C^T \Gamma_\mu = \tilde\Gamma_\mu C^T\,, - \end{equation} - i.\,e. + In the case of \texttt{keystones\_UFO}, we use cyclic permutations + to match the use in [UFO_targets], as described in the table + following~\eqref{eq:cyclic-UFO-fusions} + \begin{subequations} + \begin{align} + \text{\texttt{psibar0 * f$\phi$f\_p012(g,phi1,psi2)}} + &= \bar\psi_0 \Gamma_{\phi_1} \psi_2 \\ + \text{\texttt{f$\phi$f\_p201(g,psibar0,phi1) * psi2}} + &= \bar\psi_0 \Gamma_{\phi_1} \psi_2 \\ + \text{\texttt{phi1 * f$\phi$f\_p120(g,psi2,psibar0)}} + &= \tr \left( \Gamma_{\phi_1} \psi_2\otimes\bar\psi_0 \right) + = \bar\psi_0 \Gamma_{\phi_1} \psi_2 \,. + \end{align} + \end{subequations} + In both cases, there is no ambiguity regarding the position of spinors + and conjugate spinors, since the inner product + \texttt{conjspinor\_spinor} is not symmetrical. + + Note that, from the point of view of permutations, the notation + $\tr(\Gamma \psi'\otimes\bar\psi)$ is more natural than the + equivalent $\bar\psi\Gamma\psi'$ that inspired the + $\phi{\texttt{\_ff}}$ functions in the \texttt{omegalib} more + than 20 years ago. *) + +(* We would like to perform the same tests in + \texttt{keystones\_omegalib\_bispinors} and + \texttt{keystones\_UFO\_bispinors}, but now we have to be more + careful in positioning the Majorana spinors, because we can not + rely on the Fortran type system to catch cofusions of + \texttt{spinor} and \texttt{conjspinor} fields. In addition, + we must make sure to insert charge conjugation matrices in the + proper places~\cite{Denner:Majorana}. + + Regarding the tests in \texttt{keystones\_omegalib\_bispinors}, we + observe + \begin{subequations} + \begin{align} + \text{\texttt{chi0 * f\_}$\phi$\texttt{f(g,phi1,chi2)}} + &= \chi_0^T C \Gamma_{\phi_1} \chi_2 \\ + \text{\texttt{phi1 * $\phi$\texttt{\_ff}(g,chi0,chi2)}} + &= \chi_0^T C \Gamma_{\phi_1} \chi_2 + \end{align} + \end{subequations} + and + \begin{subequations} + \begin{align} + \text{\texttt{chi2 * f\_f}$\phi$\texttt{(g,chi0,phi1)}} + &= \chi_2^T C (\chi_0^T\tilde\Gamma_{\phi_1}^\mu)^T + = \chi_2^T C (\tilde\Gamma_{\phi_1}^\mu)^T \chi_0 + = \chi_2^T C \Gamma_{\phi_1} \chi_0 \\ + \text{\texttt{phi1 * $\phi$\texttt{\_ff}(g,chi2,chi0)}} + &= \chi_2^T C \Gamma_{\phi_1} \chi_0\,, + \end{align} + \end{subequations} + while + \begin{align} + \text{\texttt{f\_f}$\phi$\texttt{(g,chi0,phi1) * chi2}} + &= \chi_0^T\tilde\Gamma_{\phi_1} C\chi_2 + = \chi_0^T\Gamma_{\phi_1}^T C\chi_2 + = (\Gamma_{\phi_1}\chi_0)^T C\chi_2 + \end{align} + is different. JRR solved this problem by abandoning + \texttt{f\_f$\phi$} altogether and using + \texttt{$\phi$\_ff} only in the form + \texttt{$\phi$\_ff(g,chi0,chi2)}. + Turning to the tests in \texttt{keystones\_UFO\_bispinors}, it would + be convenient to be able to use + \begin{subequations} + \begin{align} + \text{\texttt{chi0 * f$\phi$f\_p012(g,phi1,chi2)}} + &= \chi_0^T C \Gamma_{\phi_1}^{012} \chi_2 \\ + \text{\texttt{f$\phi$f\_p201(g,chi0,phi1) * chi2}} + &= \chi_0^T \Gamma_{\phi_1}^{201} C \chi_2 \\ + \text{\texttt{phi1 * f$\phi$f\_p120(g,chi2,chi0)}} + &= \tr \left( \Gamma_{\phi_1}^{120} \chi_2 \otimes \chi_0^T \right) + = \chi_0^T \Gamma_{\phi_1}^{120} \chi_2 + = \chi_2^T (\Gamma_{\phi_1}^{120})^T \chi_0 \,, + \end{align} + \end{subequations} + where~$\Gamma^{012}=\Gamma$ is the string of $\gamma$-matrices + as written in the Lagrangian. Obviously, we should require \begin{equation} - \tilde\Gamma_\mu = C \Gamma_\mu C^{-1}\,. + \Gamma^{120} = C \Gamma^{012} = C \Gamma \end{equation} - This is \emph{not} compatible with with~$\tilde\Gamma_\mu=\Gamma^T_\mu$, - but we can make this work for the \texttt{keystones\_UFO\_bispinors} - tests with *) - -let conjugate d = - { d with gammas = compress_signs (C :: d.gammas @ inv_C) } + as expected from \texttt{omega\_bispinors}. *) -let conjugate_transpose d = - conjugate (transpose d) +let cc_times d = + { d with gammas = compress_signs (C :: d.gammas) } -(* The alternative - condition~$\text{\texttt{chi0 * f\_}$b$\texttt{f(g,phi1,chi2)}} - = \text{\texttt{chi2 * f\_f}$b$\texttt{(g,chi0,phi1)}}$ - would require +(* For~$\Gamma^{201}$ we must require\footnote{% + Note that we don't get anything new, if we reverse the scalar product + \begin{equation*} + \text{\texttt{chi2 * f$\phi$f\_p201(g,chi0,phi1)}} + = \chi_2^T C (\chi_0^T \Gamma_{\phi_1}^{201})^T + = \chi_0^T \Gamma_{\phi_1}^{201} C^T \chi_2\,. + \end{equation*} + We would find the condition + \begin{equation*} + - \Gamma^{201} C = \Gamma^{201} C^T = C \Gamma + \end{equation*} + i.\,e.~only a sign + \begin{equation*} + \Gamma^{201} = - C \Gamma C^{-1} \not= \Gamma^T \,, + \end{equation*} + as was to be expected from the antisymmetry of \texttt{spinor\_product}, + of course.} \begin{equation} - C^T \Gamma_\mu = \tilde\Gamma_\mu C\,, + \Gamma^{201} C = C \Gamma^{012} = C \Gamma \end{equation} i.\,e. \begin{equation} - \tilde\Gamma_\mu = C \Gamma_\mu C = - C \Gamma_\mu C^{-1}\,. - \end{equation} *) + \Gamma^{201} = C \Gamma C^{-1} \not= \Gamma^T \,. + \end{equation} *) -(* \begin{dubious} - Now make also the fusions work in - \texttt{fermi\_UFO} and \texttt{compare\_majorana\_UFO}? - \end{dubious} *) +let conjugate d = + { d with gammas = compress_signs (C :: d.gammas @ inv_C) } -let minus d = - { d with gammas = compress_signs (Minus :: d.gammas) } +let conjugate_transpose d = + conjugate (transpose d) -let cc_times d = - { d with gammas = compress_signs (C :: d.gammas) } +let times_minus_cc d = + { d with gammas = compress_signs (d.gammas @ [Minus; C]) } -let times_cc_inv d = - { d with gammas = compress_signs (d.gammas @ inv_C) } +(* \thocwmodulesection{From Dirac Strings to $4\times4$ Matrices} *) (* [dirac_string bind ds] applies the mapping [bind] to the indices of $\gamma_\mu$ and~$\sigma_{\mu\nu}$ and multiplies the resulting matrices in order using complex rational arithmetic. *) + module type To_Matrix = sig val dirac_string : (int -> int) -> dirac_string -> D.t end module To_Matrix : To_Matrix = struct let half = QC.make (Q.make 1 2) Q.null let half_i = QC.make Q.null (Q.make 1 2) let gamma_L = D.times half (D.sub D.unit D.gamma5) let gamma_R = D.times half (D.add D.unit D.gamma5) let sigma = Array.make_matrix 4 4 D.null let () = for mu = 0 to 3 do for nu = 0 to 3 do sigma.(mu).(nu) <- D.times half_i (D.sub (D.mul D.gamma.(mu) D.gamma.(nu)) (D.mul D.gamma.(nu) D.gamma.(mu))) done done let dirac bind_indices = function | Gamma5 -> D.gamma5 | ProjM -> gamma_L | ProjP -> gamma_R | Gamma (mu) -> D.gamma.(bind_indices mu) | Sigma (mu, nu) -> sigma.(bind_indices mu).(bind_indices nu) | C -> D.cc | Minus -> D.neg D.unit let dirac_string bind_indices ds = D.product (List.map (dirac bind_indices) ds.gammas) end let dirac_string_to_matrix = To_Matrix.dirac_string (* The Lorentz indices appearing in a term are either negative internal summation indices or positive external polarization indices. Note that the external indices are not really indices, but denote the position of the particle in the vertex. *) type 'a term = { indices : int list; atom : 'a } let map_atom f term = { term with atom = f term.atom } let map_term f_index f_atom term = { indices = List.map f_index term.indices; atom = f_atom term.atom } (* Return a pair of lists: first the (negative) summation indices, second the (positive) external indices. *) let classify_indices ilist = List.partition (fun i -> if i < 0 then true else if i > 0 then false else invalid_arg "classify_indices") ilist +(* Recursions on this type only stop when we come across an + empty [denominator]. In practice, this is no problem + (we never construct values that recurse more than once), + but it would be cleaner to use polymorphic variants as + suggested for [UFOx.Tensor.t]. *) type contraction = { coeff : QC.t; dirac : dirac_string term list; vector : A.vector term list; scalar : A.scalar list; inverse : A.scalar list; denominator : contraction list } let fermion_lines_of_contraction contraction = List.sort compare (List.map (fun term -> (term.atom.ket, term.atom.bra)) contraction.dirac) -let map_indices_contraction f c = +let rec map_indices_contraction f c = { coeff = c.coeff; dirac = List.map (map_term f (map_indices_dirac f)) c.dirac; vector = List.map (map_term f (A.map_indices_vector f)) c.vector; - scalar = c.scalar; - inverse = c.inverse; - denominator = c.denominator } + scalar = List.map (A.map_indices_scalar f) c.scalar; + inverse = List.map (A.map_indices_scalar f) c.inverse; + denominator = List.map (map_indices_contraction f) c.denominator } type t = contraction list let dummy = [] -let rec charge_conjugate_dirac (bra, ket as fermion_line) = function +let rec charge_conjugate_dirac (ket, bra as fermion_line) = function | [] -> [] | dirac :: dirac_list -> if dirac.atom.bra = bra && dirac.atom.ket = ket then - map_atom conjugate dirac :: dirac_list + map_atom toggle_conjugated dirac :: dirac_list else dirac :: charge_conjugate_dirac fermion_line dirac_list let charge_conjugate_contraction fermion_line c = { c with dirac = charge_conjugate_dirac fermion_line c.dirac } let charge_conjugate fermion_line l = List.map (charge_conjugate_contraction fermion_line) l let fermion_lines contractions = let pairs = List.map fermion_lines_of_contraction contractions in match ThoList.uniq (List.sort compare pairs) with | [] -> invalid_arg "UFO_Lorentz.fermion_lines: impossible" | [pairs] -> pairs | _ -> invalid_arg "UFO_Lorentz.fermion_lines: ambiguous" let map_indices f contractions = List.map (map_indices_contraction f) contractions let map_fermion_lines f pairs = List.map (fun (i, j) -> (f i, f j)) pairs let dirac_of_atom = function | A.Identity (_, _) -> [] | A.C (_, _) -> [C] | A.Gamma5 (_, _) -> [Gamma5] | A.ProjP (_, _) -> [ProjP] | A.ProjM (_, _) -> [ProjM] | A.Gamma (mu, _, _) -> [Gamma mu] | A.Sigma (mu, nu, _, _) -> [Sigma (mu, nu)] let dirac_indices = function | A.Identity (i, j) | A.C (i, j) | A.Gamma5 (i, j) | A.ProjP (i, j) | A.ProjM (i, j) | A.Gamma (_, i, j) | A.Sigma (_, _, i, j) -> (i, j) let rec scan_for_dirac_string stack = function | [] -> (* We're done with this pass. There must be no leftover atoms on the [stack] of spinor atoms, but we'll check this in the calling function. *) (None, List.rev stack) | atom :: atoms -> let i, j = dirac_indices atom in if i > 0 then if j > 0 then (* That's an atomic Dirac string. Collect all atoms for further processing. *) - (Some { bra = i; ket = j; gammas = dirac_of_atom atom}, + (Some { bra = i; ket = j; conjugated = false; + gammas = dirac_of_atom atom }, List.rev_append stack atoms) else (* That's the start of a new Dirac string. Search for the remaining elements, not forgetting matrices that we might pushed on the [stack] earlier. *) collect_dirac_string i j (dirac_of_atom atom) [] (List.rev_append stack atoms) else (* The interior of a Dirac string. Push it on the stack until we find the start. *) scan_for_dirac_string (atom :: stack) atoms (* Complete the string starting with [i] and the current summation index [j]. *) and collect_dirac_string i j rev_ds stack = function | [] -> (* We have consumed all atoms without finding the end of the string. *) invalid_arg "collect_dirac_string: open string" | atom :: atoms -> let i', j' = dirac_indices atom in if i' = j then if j' > 0 then (* Found the conclusion. Collect all atoms on the [stack] for further processing. *) - (Some { bra = i; ket = j'; + (Some { bra = i; ket = j'; conjugated = false; gammas = List.rev_append rev_ds (dirac_of_atom atom)}, List.rev_append stack atoms) else (* Found the continuation. Pop the stack of open indices, since we're looking for a new one. *) collect_dirac_string i j' (dirac_of_atom atom @ rev_ds) [] (List.rev_append stack atoms) else (* Either the start of another Dirac string or a non-matching continuation. Push it on the stack until we're done with the current one. *) collect_dirac_string i j rev_ds (atom :: stack) atoms let dirac_string_of_dirac_atoms atoms = scan_for_dirac_string [] atoms let rec dirac_strings_of_dirac_atoms' rev_ds atoms = match dirac_string_of_dirac_atoms atoms with | (None, []) -> List.rev rev_ds | (None, _) -> invalid_arg "dirac_string_of_dirac_atoms: leftover atoms" | (Some ds, atoms) -> dirac_strings_of_dirac_atoms' (ds :: rev_ds) atoms let dirac_strings_of_dirac_atoms atoms = dirac_strings_of_dirac_atoms' [] atoms let indices_of_vector = function | A.Epsilon (mu1, mu2, mu3, mu4) -> [mu1; mu2; mu3; mu4] | A.Metric (mu1, mu2) -> [mu1; mu2] | A.P (mu, n) -> if n > 0 then [mu] else invalid_arg "indices_of_vector: invalid momentum" let classify_vector atom = { indices = indices_of_vector atom; atom } let indices_of_dirac = function | Gamma5 | ProjM | ProjP | C | Minus -> [] | Gamma (mu) -> [mu] | Sigma (mu, nu) -> [mu; nu] let indices_of_dirac_string ds = ThoList.flatmap indices_of_dirac ds.gammas let classify_dirac atom = { indices = indices_of_dirac_string atom; atom } let contraction_of_lorentz_atoms denominator (atoms, coeff) = let dirac_atoms, vector_atoms, scalar, inverse = split_atoms atoms in let dirac = List.map classify_dirac (dirac_strings_of_dirac_atoms dirac_atoms) and vector = List.map classify_vector vector_atoms in { coeff; dirac; vector; scalar; inverse; denominator } type redundancy = | Trace of int | Replace of int * int let rec redundant_metric' rev_atoms = function | [] -> (None, List.rev rev_atoms) | { atom = A.Metric (mu, nu) } as atom :: atoms -> if mu < 1 then if nu = mu then (Some (Trace mu), List.rev_append rev_atoms atoms) else (Some (Replace (mu, nu)), List.rev_append rev_atoms atoms) else if nu < 0 then (Some (Replace (nu, mu)), List.rev_append rev_atoms atoms) else redundant_metric' (atom :: rev_atoms) atoms | { atom = (A.Epsilon (_, _, _, _ ) | A.P (_, _) ) } as atom :: atoms -> redundant_metric' (atom :: rev_atoms) atoms let redundant_metric atoms = redundant_metric' [] atoms (* Substitude any occurance of the index [mu] by the index [nu]: *) let substitute_index_vector1 mu nu = function | A.Epsilon (mu1, mu2, mu3, mu4) as eps -> if mu = mu1 then A.Epsilon (nu, mu2, mu3, mu4) else if mu = mu2 then A.Epsilon (mu1, nu, mu3, mu4) else if mu = mu3 then A.Epsilon (mu1, mu2, nu, mu4) else if mu = mu4 then A.Epsilon (mu1, mu2, mu3, nu) else eps | A.Metric (mu1, mu2) as g -> if mu = mu1 then A.Metric (nu, mu2) else if mu = mu2 then A.Metric (mu1, nu) else g | A.P (mu1, n) as p -> if mu = mu1 then A.P (nu, n) else p let remove a alist = List.filter ((<>) a) alist let substitute_index1 mu nu mu1 = if mu = mu1 then nu else mu1 let substitute_index mu nu indices = List.map (substitute_index1 mu nu) indices (* This assumes that [mu] is a summation index and [nu] is a polarization index. *) let substitute_index_vector mu nu vectors = List.map (fun v -> { indices = substitute_index mu nu v.indices; atom = substitute_index_vector1 mu nu v.atom }) vectors (* Substitude any occurance of the index [mu] by the index [nu]: *) let substitute_index_dirac1 mu nu = function | (Gamma5 | ProjM | ProjP | C | Minus) as g -> g | Gamma (mu1) as g -> if mu = mu1 then Gamma (nu) else g | Sigma (mu1, mu2) as g -> if mu = mu1 then Sigma (nu, mu2) else if mu = mu2 then Sigma (mu1, nu) else g (* This assumes that [mu] is a summation index and [nu] is a polarization index. *) let substitute_index_dirac mu nu dirac_strings = List.map (fun ds -> { indices = substitute_index mu nu ds.indices; atom = { ds.atom with gammas = List.map (substitute_index_dirac1 mu nu) ds.atom.gammas } } ) dirac_strings let trace_metric = QC.make (Q.make 4 1) Q.null (* FIXME: can this be made typesafe by mapping to a type that \emph{only} contains [P] and [Epsilon]? *) let rec compress_metrics c = match redundant_metric c.vector with | None, _ -> c | Some (Trace mu), vector' -> compress_metrics { coeff = QC.mul trace_metric c.coeff; dirac = c.dirac; vector = vector'; scalar = c.scalar; inverse = c.inverse; denominator = c.denominator } | Some (Replace (mu, nu)), vector' -> compress_metrics { coeff = c.coeff; dirac = substitute_index_dirac mu nu c.dirac; vector = substitute_index_vector mu nu vector'; scalar = c.scalar; inverse = c.inverse; denominator = c.denominator } let compress_denominator = function | [([], q)] as denominator -> if QC.is_unit q then [] else denominator | denominator -> denominator let parse1 spins denominator atom = compress_metrics (contraction_of_lorentz_atoms denominator atom) let parse ?(allow_denominator=false) spins = function | UFOx.Lorentz.Linear l -> List.map (parse1 spins []) l | UFOx.Lorentz.Ratios r -> ThoList.flatmap (fun (numerator, denominator) -> match compress_denominator denominator with | [] -> List.map (parse1 spins []) numerator | d -> if allow_denominator then let parsed_denominator = List.map (parse1 [Coupling.Scalar; Coupling.Scalar] []) denominator in List.map (parse1 spins parsed_denominator) numerator else invalid_arg (Printf.sprintf "UFO_Lorentz.parse: denominator %s in %s not allowed here!" (UFOx.Lorentz.to_string (UFOx.Lorentz.Linear d)) (UFOx.Lorentz.to_string (UFOx.Lorentz.Ratios r)))) r let i2s = UFOx.Index.to_string let vector_to_string = function | A.Epsilon (mu, nu, ka, la) -> Printf.sprintf "Epsilon(%s,%s,%s,%s)" (i2s mu) (i2s nu) (i2s ka) (i2s la) | A.Metric (mu, nu) -> Printf.sprintf "Metric(%s,%s)" (i2s mu) (i2s nu) | A.P (mu, n) -> Printf.sprintf "P(%s,%d)" (i2s mu) n let dirac_to_string = function | Gamma5 -> "g5" | ProjM -> "(1-g5)/2" | ProjP -> "(1+g5)/2" | Gamma (mu) -> Printf.sprintf "g(%s)" (i2s mu) | Sigma (mu, nu) -> Printf.sprintf "s(%s,%s)" (i2s mu) (i2s nu) | C -> "C" | Minus -> "-1" let dirac_string_to_string ds = match ds.gammas with | [] -> Printf.sprintf "<%s|%s>" (i2s ds.bra) (i2s ds.ket) | gammas -> Printf.sprintf "<%s|%s|%s>" (i2s ds.bra) (String.concat "*" (List.map dirac_to_string gammas)) (i2s ds.ket) let scalar_to_string = function | A.Mass _ -> "m" | A.Width _ -> "w" | A.P2 i -> Printf.sprintf "p%d**2" i | A.P12 (i, j) -> Printf.sprintf "p%d*p%d" i j | A.Variable s -> s | A.Coeff c -> UFOx.Value.to_string c let rec contraction_to_string c = String.concat " * " (List.concat [if QC.is_unit c.coeff then [] else [QC.to_string c.coeff]; List.map (fun ds -> dirac_string_to_string ds.atom) c.dirac; List.map (fun v -> vector_to_string v.atom) c.vector; List.map scalar_to_string c.scalar]) ^ (match c.inverse with | [] -> "" | inverse -> " / (" ^ String.concat "*" (List.map scalar_to_string inverse) ^ ")") ^ (match c.denominator with | [] -> "" | denominator -> " / (" ^ to_string denominator ^ ")") and to_string contractions = String.concat " + " (List.map contraction_to_string contractions) let fermion_lines_to_string fermion_lines = ThoList.to_string - (fun (bra, ket) -> Printf.sprintf "%s->%s" (i2s bra) (i2s ket)) + (fun (ket, bra) -> Printf.sprintf "%s->%s" (i2s ket) (i2s bra)) fermion_lines module type Test = sig val suite : OUnit.test end module Test : Test = struct open OUnit let braket gammas = - { bra = 11; ket = 22; gammas } + { bra = 11; ket = 22; conjugated = false; gammas } let assert_transpose gt g = assert_equal ~printer:dirac_string_to_string (braket gt) (transpose (braket g)) let assert_conjugate_transpose gct g = assert_equal ~printer:dirac_string_to_string (braket gct) (conjugate_transpose (braket g)) let suite_transpose = "transpose" >::: [ "identity" >:: (fun () -> assert_transpose [] []); "gamma_mu" >:: (fun () -> assert_transpose [C; Gamma 1; C] [Gamma 1]); "sigma_munu" >:: (fun () -> assert_transpose [C; Sigma (1, 2); C] [Sigma (1, 2)]); "gamma_5*gamma_mu" >:: (fun () -> assert_transpose [C; Gamma 1; Gamma5; C] [Gamma5; Gamma 1]); "gamma5" >:: (fun () -> assert_transpose [Minus; C; Gamma5; C] [Gamma5]); "gamma+" >:: (fun () -> assert_transpose [Minus; C; ProjP; C] [ProjP]); "gamma-" >:: (fun () -> assert_transpose [Minus; C; ProjM; C] [ProjM]); "gamma_mu*gamma_nu" >:: (fun () -> assert_transpose [Minus; C; Gamma 2; Gamma 1; C] [Gamma 1; Gamma 2]); "gamma_mu*gamma_nu*gamma_la" >:: (fun () -> assert_transpose [C; Gamma 3; Gamma 2; Gamma 1; C] [Gamma 1; Gamma 2; Gamma 3]); "gamma_mu*gamma+" >:: (fun () -> assert_transpose [C; ProjP; Gamma 1; C] [Gamma 1; ProjP]); "gamma_mu*gamma-" >:: (fun () -> assert_transpose [C; ProjM; Gamma 1; C] [Gamma 1; ProjM]) ] let suite_conjugate_transpose = "conjugate_transpose" >::: [ "identity" >:: (fun () -> assert_conjugate_transpose [] []); "gamma_mu" >:: (fun () -> assert_conjugate_transpose [Minus; Gamma 1] [Gamma 1]); "sigma_munu" >:: (fun () -> assert_conjugate_transpose [Minus; Sigma (1, 2)] [Sigma (1,2)]); "gamma_mu*gamma5" >:: (fun () -> assert_conjugate_transpose [Minus; Gamma5; Gamma 1] [Gamma 1; Gamma5]); "gamma5" >:: (fun () -> assert_conjugate_transpose [Gamma5] [Gamma5]) ] let suite = "UFO_Lorentz" >::: [suite_transpose; suite_conjugate_transpose] end Index: trunk/omega/src/UFO_Lorentz.mli =================================================================== --- trunk/omega/src/UFO_Lorentz.mli (revision 8491) +++ trunk/omega/src/UFO_Lorentz.mli (revision 8492) @@ -1,147 +1,141 @@ (* UFO_Lorentz.mli -- Copyright (C) 1999-2017 by Wolfgang Kilian Thorsten Ohl Juergen Reuter with contributions from Christian Speckner WHIZARD 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 2, or (at your option) any later version. WHIZARD 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, write to the Free Software Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. *) (* \thocwmodulesection{Processed UFO Lorentz Structures} *) (* Just like [UFOx.Lorentz_Atom.dirac], but without the Dirac matrix indices. *) type dirac = (* [private] *) | Gamma5 | ProjM | ProjP | Gamma of int | Sigma of int * int | C | Minus (* A sandwich of a string of $\gamma$-matrices. [bra] and [ket] are positions of fields in the vertex, \emph{not} spinor indices. *) type dirac_string = (* [private] *) { bra : int; ket : int; + conjugated : bool; gammas : dirac list } (* In the case of Majorana spinors, we have to insert charge conjugation matrices. *) (* $\Gamma\to - \Gamma$: *) val minus : dirac_string -> dirac_string (* $\Gamma\to C\Gamma$: *) val cc_times : dirac_string -> dirac_string -(* $\Gamma\to \Gamma C^{-1}$: *) -val times_cc_inv : dirac_string -> dirac_string +(* $\Gamma\to - \Gamma C$: *) +val times_minus_cc : dirac_string -> dirac_string (* $\Gamma\to \Gamma^T$: *) val transpose : dirac_string -> dirac_string (* $\Gamma\to C\Gamma C^{-1}$: *) val conjugate : dirac_string -> dirac_string (* $\Gamma\to C\Gamma^T C^{-1}$, i.\,e.~the composition of [conjugate] and [transpose]: *) val conjugate_transpose : dirac_string -> dirac_string -(* \begin{dubious} - Careful: of the above, [transpose] is currently implemented - as [conjugate] to make the tests in~\texttt{keystones\_UFO\_bispinors} - work. This needs to be changed eventually! [conjugate_transpose] is - the real thing, though. - \end{dubious} *) - (* The Lorentz indices appearing in a term are either negative internal summation indices or positive external polarization indices. Note that the external indices are not really indices, but denote the position of the particle in the vertex. *) type 'a term = (* [private] *) { indices : int list; atom : 'a } (* Split the list of indices into summation and polarization indices. *) val classify_indices : int list -> int list * int list (* Replace the atom keeping the associated indices. *) val map_atom : ('a -> 'b) -> 'a term -> 'b term (* A contraction consists of a (possibly empty) product of Dirac strings and a (possibly empty) product of Lorentz tensors with a rational coefficient. The [denominator] is required for the poorly documented propagator extensions. The type [atom linear] is a [list] and an empty list is interpreted as~$1$. *) (* \begin{dubious} The [denominator] is a [contraction list] to allow code reuse, though a [(A.scalar list * A.scalar list * QC.t) list] would suffice. \end{dubious} *) type contraction = (* [private] *) { coeff : Algebra.QC.t; dirac : dirac_string term list; vector : UFOx.Lorentz_Atom.vector term list; scalar : UFOx.Lorentz_Atom.scalar list; inverse : UFOx.Lorentz_Atom.scalar list; denominator : contraction list } (* A sum of [contraction]s. *) type t = contraction list (* Fermion line connections. *) val fermion_lines : t -> Coupling.fermion_lines (* $\Gamma\to C\Gamma C^{-1}$ *) val charge_conjugate : int * int -> t -> t (* [parse spins lorentz] uses the [spins] to parse the UFO [lorentz] structure as a list of [contraction]s. *) val parse : ?allow_denominator:bool -> Coupling.lorentz list -> UFOx.Lorentz.t -> t (* [map_indices f lorentz] applies the map [f] to the free indices in [lorentz]. *) val map_indices : (int -> int) -> t -> t val map_fermion_lines : (int -> int) -> Coupling.fermion_lines -> Coupling.fermion_lines (* Create a readable representation for debugging and documenting generated code. *) val to_string : t -> string val fermion_lines_to_string : Coupling.fermion_lines -> string (* Punting \ldots *) val dummy : t (* More debugging and documenting. *) val dirac_string_to_string : dirac_string -> string (* [dirac_string_to_matrix substitute ds] take a string of $\gamma$-matrices [ds], applies [substitute] to the indices and returns the product as a matrix. *) val dirac_string_to_matrix : (int -> int) -> dirac_string -> Dirac.Chiral.t module type Test = sig val suite : OUnit.test end module Test : Test Index: trunk/omega/src/UFOx.ml =================================================================== --- trunk/omega/src/UFOx.ml (revision 8491) +++ trunk/omega/src/UFOx.ml (revision 8492) @@ -1,1514 +1,1522 @@ (* vertex.ml -- Copyright (C) 1999-2021 by Wolfgang Kilian Thorsten Ohl Juergen Reuter with contributions from Christian Speckner WHIZARD 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 2, or (at your option) any later version. WHIZARD 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, write to the Free Software Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. *) let error_in_string text start_pos end_pos = let i = max 0 start_pos.Lexing.pos_cnum in let j = min (String.length text) (max (i + 1) end_pos.Lexing.pos_cnum) in String.sub text i (j - i) let error_in_file name start_pos end_pos = Printf.sprintf "%s:%d.%d-%d.%d" name start_pos.Lexing.pos_lnum (start_pos.Lexing.pos_cnum - start_pos.Lexing.pos_bol) end_pos.Lexing.pos_lnum (end_pos.Lexing.pos_cnum - end_pos.Lexing.pos_bol) module SMap = Map.Make (struct type t = string let compare = compare end) module Expr = struct type t = UFOx_syntax.expr let of_string text = try UFOx_parser.input UFOx_lexer.token (UFOx_lexer.init_position "" (Lexing.from_string text)) with | UFO_tools.Lexical_Error (msg, start_pos, end_pos) -> invalid_arg (Printf.sprintf "lexical error (%s) at: `%s'" msg (error_in_string text start_pos end_pos)) | UFOx_syntax.Syntax_Error (msg, start_pos, end_pos) -> invalid_arg (Printf.sprintf "syntax error (%s) at: `%s'" msg (error_in_string text start_pos end_pos)) | Parsing.Parse_error -> invalid_arg ("parse error: " ^ text) let of_strings = function | [] -> UFOx_syntax.integer 0 | string :: strings -> List.fold_right (fun s acc -> UFOx_syntax.add (of_string s) acc) strings (of_string string) open UFOx_syntax let rec map f = function | Integer _ | Float _ | Quoted _ as e -> e | Variable s as e -> begin match f s with | Some value -> value | None -> e end | Sum (e1, e2) -> Sum (map f e1, map f e2) | Difference (e1, e2) -> Difference (map f e1, map f e2) | Product (e1, e2) -> Product (map f e1, map f e2) | Quotient (e1, e2) -> Quotient (map f e1, map f e2) | Power (e1, e2) -> Power (map f e1, map f e2) | Application (s, el) -> Application (s, List.map (map f) el) let substitute name value expr = map (fun s -> if s = name then Some value else None) expr let rename1 name_map name = try Some (Variable (SMap.find name name_map)) with Not_found -> None let rename alist_names value = let name_map = List.fold_left (fun acc (name, name') -> SMap.add name name' acc) SMap.empty alist_names in map (rename1 name_map) value let half name = Quotient (Variable name, Integer 2) let variables = UFOx_syntax.variables let functions = UFOx_syntax.functions end module Value = struct module S = UFOx_syntax module Q = Algebra.Q type builtin = | Sqrt | Exp | Log | Log10 | Sin | Asin | Cos | Acos | Tan | Atan | Sinh | Asinh | Cosh | Acosh | Tanh | Atanh | Sec | Asec | Csc | Acsc | Conj | Abs let builtin_to_string = function | Sqrt -> "sqrt" | Exp -> "exp" | Log -> "log" | Log10 -> "log10" | Sin -> "sin" | Cos -> "cos" | Tan -> "tan" | Asin -> "asin" | Acos -> "acos" | Atan -> "atan" | Sinh -> "sinh" | Cosh -> "cosh" | Tanh -> "tanh" | Asinh -> "asinh" | Acosh -> "acosh" | Atanh -> "atanh" | Sec -> "sec" | Csc -> "csc" | Asec -> "asec" | Acsc -> "acsc" | Conj -> "conjg" | Abs -> "abs" let builtin_of_string = function | "cmath.sqrt" -> Sqrt | "cmath.exp" -> Exp | "cmath.log" -> Log | "cmath.log10" -> Log10 | "cmath.sin" -> Sin | "cmath.cos" -> Cos | "cmath.tan" -> Tan | "cmath.asin" -> Asin | "cmath.acos" -> Acos | "cmath.atan" -> Atan | "cmath.sinh" -> Sinh | "cmath.cosh" -> Cosh | "cmath.tanh" -> Tanh | "cmath.asinh" -> Asinh | "cmath.acosh" -> Acosh | "cmath.atanh" -> Atanh | "sec" -> Sec | "csc" -> Csc | "asec" -> Asec | "acsc" -> Acsc | "complexconjugate" -> Conj | "abs" -> Abs | name -> failwith ("UFOx.Value: unsupported function: " ^ name) type t = | Integer of int | Rational of Q.t | Real of float | Complex of float * float | Variable of string | Sum of t list | Difference of t * t | Product of t list | Quotient of t * t | Power of t * t | Application of builtin * t list let rec to_string = function | Integer i -> string_of_int i | Rational q -> Q.to_string q | Real x -> string_of_float x | Complex (0.0, 1.0) -> "I" | Complex (0.0, -1.0) -> "-I" | Complex (0.0, i) -> string_of_float i ^ "*I" | Complex (r, 1.0) -> string_of_float r ^ "+I" | Complex (r, -1.0) -> string_of_float r ^ "-I" | Complex (r, i) -> string_of_float r ^ (if i < 0.0 then "-" else "+") ^ string_of_float (abs_float i) ^ "*I" | Variable s -> s | Sum [] -> "0" | Sum [e] -> to_string e | Sum es -> "(" ^ String.concat "+" (List.map maybe_parentheses es) ^ ")" | Difference (e1, e2) -> to_string e1 ^ "-" ^ maybe_parentheses e2 | Product [] -> "1" | Product ((Integer (-1) | Real (-1.)) :: es) -> "-" ^ maybe_parentheses (Product es) | Product es -> String.concat "*" (List.map maybe_parentheses es) | Quotient (e1, e2) -> to_string e1 ^ "/" ^ maybe_parentheses e2 | Power ((Integer i as e), Integer p) -> if p < 0 then maybe_parentheses (Real (float_of_int i)) ^ "^(" ^ string_of_int p ^ ")" else if p = 0 then "1" else if p <= 4 then maybe_parentheses e ^ "^" ^ string_of_int p else maybe_parentheses (Real (float_of_int i)) ^ "^" ^ string_of_int p | Power (e1, e2) -> maybe_parentheses e1 ^ "^" ^ maybe_parentheses e2 | Application (f, [Integer i]) -> to_string (Application (f, [Real (float i)])) | Application (f, es) -> builtin_to_string f ^ "(" ^ String.concat "," (List.map to_string es) ^ ")" and maybe_parentheses = function | Integer i as e -> if i < 0 then "(" ^ to_string e ^ ")" else to_string e | Real x as e -> if x < 0.0 then "(" ^ to_string e ^ ")" else to_string e | Complex (x, 0.0) -> to_string (Real x) | Complex (0.0, 1.0) -> "I" | Variable _ | Power (_, _) | Application (_, _) as e -> to_string e | Sum [e] -> to_string e | Product [e] -> maybe_parentheses e | e -> "(" ^ to_string e ^ ")" let rec to_coupling atom = function | Integer i -> Coupling.Integer i | Rational q -> let n, d = Q.to_ratio q in Coupling.Quot (Coupling.Integer n, Coupling.Integer d) | Real x -> Coupling.Float x | Product es -> Coupling.Prod (List.map (to_coupling atom) es) | Variable s -> Coupling.Atom (atom s) | Complex (r, 0.0) -> Coupling.Float r | Complex (0.0, 1.0) -> Coupling.I | Complex (0.0, -1.0) -> Coupling.Prod [Coupling.I; Coupling.Integer (-1)] | Complex (0.0, i) -> Coupling.Prod [Coupling.I; Coupling.Float i] | Complex (r, 1.0) -> Coupling.Sum [Coupling.Float r; Coupling.I] | Complex (r, -1.0) -> Coupling.Diff (Coupling.Float r, Coupling.I) | Complex (r, i) -> Coupling.Sum [Coupling.Float r; Coupling.Prod [Coupling.I; Coupling.Float i]] | Sum es -> Coupling.Sum (List.map (to_coupling atom) es) | Difference (e1, e2) -> Coupling.Diff (to_coupling atom e1, to_coupling atom e2) | Quotient (e1, e2) -> Coupling.Quot (to_coupling atom e1, to_coupling atom e2) | Power (e1, Integer e2) -> Coupling.Pow (to_coupling atom e1, e2) | Power (e1, e2) -> Coupling.PowX (to_coupling atom e1, to_coupling atom e2) | Application (f, [e]) -> apply1 (to_coupling atom e) f | Application (f, []) -> failwith ("UFOx.Value.to_coupling: " ^ builtin_to_string f ^ ": empty argument list") | Application (f, _::_::_) -> failwith ("UFOx.Value.to_coupling: " ^ builtin_to_string f ^ ": more than one argument in list") and apply1 e = function | Sqrt -> Coupling.Sqrt e | Exp -> Coupling.Exp e | Log -> Coupling.Log e | Log10 -> Coupling.Log10 e | Sin -> Coupling.Sin e | Cos -> Coupling.Cos e | Tan -> Coupling.Tan e | Asin -> Coupling.Asin e | Acos -> Coupling.Acos e | Atan -> Coupling.Atan e | Sinh -> Coupling.Sinh e | Cosh -> Coupling.Cosh e | Tanh -> Coupling.Tanh e | Sec -> Coupling.Quot (Coupling.Integer 1, Coupling.Cos e) | Csc -> Coupling.Quot (Coupling.Integer 1, Coupling.Sin e) | Asec -> Coupling.Acos (Coupling.Quot (Coupling.Integer 1, e)) | Acsc -> Coupling.Asin (Coupling.Quot (Coupling.Integer 1, e)) | Conj -> Coupling.Conj e | Abs -> Coupling.Abs e | (Asinh | Acosh | Atanh as f) -> failwith ("UFOx.Value.to_coupling: function `" ^ builtin_to_string f ^ "' not supported yet!") let compress terms = terms let rec of_expr e = compress (of_expr' e) and of_expr' = function | S.Integer i -> Integer i | S.Float x -> Real x | S.Variable "cmath.pi" -> Variable "pi" | S.Quoted name -> invalid_arg ("UFOx.Value.of_expr: unexpected quoted variable '" ^ name ^ "'") | S.Variable name -> Variable name | S.Sum (e1, e2) -> begin match of_expr e1, of_expr e2 with | (Integer 0 | Real 0.), e -> e | e, (Integer 0 | Real 0.) -> e | Sum e1, Sum e2 -> Sum (e1 @ e2) | e1, Sum e2 -> Sum (e1 :: e2) | Sum e1, e2 -> Sum (e2 :: e1) | e1, e2 -> Sum [e1; e2] end | S.Difference (e1, e2) -> begin match of_expr e1, of_expr e2 with | e1, (Integer 0 | Real 0.) -> e1 | e1, e2 -> Difference (e1, e2) end | S.Product (e1, e2) -> begin match of_expr e1, of_expr e2 with | (Integer 0 | Real 0.), _ -> Integer 0 | _, (Integer 0 | Real 0.) -> Integer 0 | (Integer 1 | Real 1.), e -> e | e, (Integer 1 | Real 1.) -> e | Product e1, Product e2 -> Product (e1 @ e2) | e1, Product e2 -> Product (e1 :: e2) | Product e1, e2 -> Product (e2 :: e1) | e1, e2 -> Product [e1; e2] end | S.Quotient (e1, e2) -> begin match of_expr e1, of_expr e2 with | e1, (Integer 0 | Real 0.) -> invalid_arg "UFOx.Value: divide by 0" | e1, (Integer 1 | Real 1.) -> e1 | e1, e2 -> Quotient (e1, e2) end | S.Power (e, p) -> begin match of_expr e, of_expr p with | (Integer 0 | Real 0.), (Integer 0 | Real 0.) -> invalid_arg "UFOx.Value: 0^0" | _, (Integer 0 | Real 0.) -> Integer 1 | e, (Integer 1 | Real 1.) -> e | Integer e, Integer p -> if p < 0 then Power (Real (float_of_int e), Integer p) else if p = 0 then Integer 1 else if p <= 4 then Power (Integer e, Integer p) else Power (Real (float_of_int e), Integer p) | e, p -> Power (e, p) end | S.Application ("complex", [r; i]) -> begin match of_expr r, of_expr i with | r, (Integer 0 | Real 0.0) -> r | Real r, Real i -> Complex (r, i) | Integer r, Real i -> Complex (float_of_int r, i) | Real r, Integer i -> Complex (r, float_of_int i) | Integer r, Integer i -> Complex (float_of_int r, float_of_int i) | _ -> invalid_arg "UFOx.Value: complex expects two numeric arguments" end | S.Application ("complex", _) -> invalid_arg "UFOx.Value: complex expects two arguments" | S.Application ("complexconjugate", [e]) -> Application (Conj, [of_expr e]) | S.Application ("complexconjugate", _) -> invalid_arg "UFOx.Value: complexconjugate expects single argument" | S.Application ("cmath.sqrt", [e]) -> Application (Sqrt, [of_expr e]) | S.Application ("cmath.sqrt", _) -> invalid_arg "UFOx.Value: sqrt expects single argument" | S.Application (name, args) -> Application (builtin_of_string name, List.map of_expr args) end let positive integers = List.filter (fun (i, _) -> i > 0) integers let not_positive integers = List.filter (fun (i, _) -> i <= 0) integers module type Index = sig type t = int val position : t -> int val factor : t -> int val unpack : t -> int * int val pack : int -> int -> t val map_position : (int -> int) -> t -> t val to_string : t -> string val list_to_string : t list -> string val free : (t * 'r) list -> (t * 'r) list val summation : (t * 'r) list -> (t * 'r) list val classes_to_string : ('r -> string) -> (t * 'r) list -> string val fresh_summation : unit -> t val named_summation : string -> unit -> t end module Index : Index = struct type t = int let free i = positive i let summation i = not_positive i let position i = if i > 0 then i mod 1000 else i let factor i = if i > 0 then i / 1000 else invalid_arg "UFOx.Index.factor: argument not positive" let unpack i = if i > 0 then (position i, factor i) else (i, 0) let pack i j = if j > 0 then if i > 0 then 1000 * j + i else invalid_arg "UFOx.Index.pack: position not positive" else if j = 0 then i else invalid_arg "UFOx.Index.pack: factor negative" let map_position f i = let pos, fac = unpack i in pack (f pos) fac let to_string i = let pos, fac = unpack i in if fac = 0 then Printf.sprintf "%d" pos else Printf.sprintf "%d.%d" pos fac let to_string' = string_of_int let list_to_string is = "[" ^ String.concat ", " (List.map to_string is) ^ "]" let classes_to_string rep_to_string index_classes = let reps = ThoList.uniq (List.sort compare (List.map snd index_classes)) in "[" ^ String.concat ", " (List.map (fun r -> (rep_to_string r) ^ "=" ^ (list_to_string (List.map fst (List.filter (fun (_, r') -> r = r') index_classes)))) reps) ^ "]" type factory = { mutable named : int SMap.t; mutable used : Sets.Int.t } let factory = { named = SMap.empty; used = Sets.Int.empty } let first_anonymous = -1001 let fresh_summation () = let next_anonymous = try pred (Sets.Int.min_elt factory.used) with | Not_found -> first_anonymous in factory.used <- Sets.Int.add next_anonymous factory.used; next_anonymous let named_summation name () = try SMap.find name factory.named with | Not_found -> begin let next_named = fresh_summation () in factory.named <- SMap.add name next_named factory.named; next_named end end module type Atom = sig type t val map_indices : (int -> int) -> t -> t val rename_indices : (int -> int) -> t -> t val contract_pair : t -> t -> t option val variable : t -> string option val scalar : t -> bool val is_unit : t -> bool val invertible : t -> bool val invert : t -> t val of_expr : string -> UFOx_syntax.expr list -> t list val to_string : t -> string type r val classify_indices : t list -> (Index.t * r) list val disambiguate_indices : t list -> t list val rep_to_string : r -> string val rep_to_string_whizard : r -> string val rep_of_int : bool -> int -> r val rep_conjugate : r -> r val rep_trivial : r -> bool type r_omega val omega : r -> r_omega end module type Tensor = sig type atom type 'a linear = ('a list * Algebra.QC.t) list type t = | Linear of atom linear | Ratios of (atom linear * atom linear) list val map_atoms : (atom -> atom) -> t -> t val map_indices : (int -> int) -> t -> t val rename_indices : (int -> int) -> t -> t val map_coeff : (Algebra.QC.t -> Algebra.QC.t) -> t -> t val contract_pairs : t -> t val variables : t -> string list val of_expr : UFOx_syntax.expr -> t val of_string : string -> t val of_strings : string list -> t val to_string : t -> string type r val classify_indices : t -> (Index.t * r) list val rep_to_string : r -> string val rep_to_string_whizard : r -> string val rep_of_int : bool -> int -> r val rep_conjugate : r -> r val rep_trivial : r -> bool type r_omega val omega : r -> r_omega end module Tensor (A : Atom) : Tensor with type atom = A.t and type r = A.r and type r_omega = A.r_omega = struct module S = UFOx_syntax (* TODO: we have to switch to [Algebra.QC] to support complex coefficients, as used in custom propagators. *) module Q = Algebra.Q module QC = Algebra.QC type atom = A.t type 'a linear = ('a list * Algebra.QC.t) list type t = | Linear of atom linear | Ratios of (atom linear * atom linear) list let term_to_string (tensors, c) = if QC.is_null c then "" else match tensors with | [] -> QC.to_string c | tensors -> String.concat "*" ((if QC.is_unit c then [] else [QC.to_string c]) @ List.map A.to_string tensors) let linear_to_string terms = String.concat "" (List.map term_to_string terms) let to_string = function | Linear terms -> linear_to_string terms | Ratios ratios -> String.concat " + " (List.map (fun (n, d) -> Printf.sprintf "(%s)/(%s)" (linear_to_string n) (linear_to_string d)) ratios) let variables_of_atoms atoms = List.fold_left (fun acc a -> match A.variable a with | None -> acc | Some name -> Sets.String.add name acc) Sets.String.empty atoms let variables_of_linear linear = List.fold_left (fun acc (atoms, _) -> Sets.String.union (variables_of_atoms atoms) acc) Sets.String.empty linear let variables_set = function | Linear linear -> variables_of_linear linear | Ratios ratios -> List.fold_left (fun acc (numerator, denominator) -> Sets.String.union (variables_of_linear numerator) (Sets.String.union (variables_of_linear denominator) acc)) Sets.String.empty ratios let variables t = Sets.String.elements (variables_set t) let map_ratios f = function | Linear n -> Linear (f n) | Ratios ratios -> Ratios (List.map (fun (n, d) -> (f n, f d)) ratios) let map_summands f t = map_ratios (List.map f) t let map_numerators f = function | Linear n -> Linear (List.map f n) | Ratios ratios -> Ratios (List.map (fun (n, d) -> (List.map f n, d)) ratios) let map_atoms f t = map_summands (fun (atoms, q) -> (List.map f atoms, q)) t let map_indices f t = map_atoms (A.map_indices f) t let rename_indices f t = map_atoms (A.rename_indices f) t let map_coeff f t = map_numerators (fun (atoms, q) -> (atoms, f q)) t type result = | Matched of atom list | Unmatched of atom list (* [contract_pair a rev_prefix suffix] returns [Unmatched (a :: List.rev_append rev_prefix suffix] if there is no match (as defined by [A.contract_pair]) and [Matched] with the reduced list otherwise. *) let rec contract_pair a rev_prefix = function | [] -> Unmatched (a :: List.rev rev_prefix) | a' :: suffix -> begin match A.contract_pair a a' with | None -> contract_pair a (a' :: rev_prefix) suffix | Some a'' -> if A.is_unit a'' then Matched (List.rev_append rev_prefix suffix) else Matched (List.rev_append rev_prefix (a'' :: suffix)) end (* Use [contract_pair] to find all pairs that match according to [A.contract_pair]. *) let rec contract_pairs1 = function | ([] | [_] as t) -> t | a :: t -> begin match contract_pair a [] t with | Unmatched ([]) -> [] | Unmatched (a' :: t') -> a' :: contract_pairs1 t' | Matched t' -> contract_pairs1 t' end let contract_pairs t = map_summands (fun (t', c) -> (contract_pairs1 t', c)) t let add t1 t2 = match t1, t2 with | Linear l1, Linear l2 -> Linear (l1 @ l2) | Ratios r, Linear l | Linear l, Ratios r -> Ratios ((l, [([], QC.unit)]) :: r) | Ratios r1, Ratios r2 -> Ratios (r1 @ r2) let multiply1 (t1, c1) (t2, c2) = (List.sort compare (t1 @ t2), QC.mul c1 c2) let multiply2 t1 t2 = Product.list2 multiply1 t1 t2 let multiply t1 t2 = match t1, t2 with | Linear l1, Linear l2 -> Linear (multiply2 l1 l2) | Ratios r, Linear l | Linear l, Ratios r -> Ratios (List.map (fun (n, d) -> (multiply2 l n, d)) r) | Ratios r1, Ratios r2 -> Ratios (Product.list2 (fun (n1, d1) (n2, d2) -> (multiply2 n1 n2, multiply2 d1 d2)) r1 r2) let rec power n t = if n < 0 then invalid_arg "UFOx.Tensor.power: n < 0" else if n = 0 then Linear [([], QC.unit)] else if n = 1 then t else multiply t (power (pred n) t) let compress ratios = map_ratios (fun terms -> List.map (fun (t, cs) -> (t, QC.sum cs)) (ThoList.factorize terms)) ratios let rec of_expr e = contract_pairs (compress (of_expr' e)) and of_expr' = function | S.Integer i -> Linear [([], QC.make (Q.make i 1) Q.null)] | S.Float _ -> invalid_arg "UFOx.Tensor.of_expr: unexpected float" | S.Quoted name -> invalid_arg ("UFOx.Tensor.of_expr: unexpected quoted variable '" ^ name ^ "'") | S.Variable name -> (* There should be a gatekeeper here or in [A.of_expr]: *) Linear [(A.of_expr name [], QC.unit)] | S.Application ("complex", [re; im]) -> begin match of_expr re, of_expr im with | Linear [([], re)], Linear [([], im)] -> if QC.is_real re && QC.is_real im then Linear [([], QC.make (QC.real re) (QC.real im))] else invalid_arg ("UFOx.Tensor.of_expr: argument of complex is complex") | _ -> invalid_arg "UFOx.Tensor.of_expr: unexpected argument of complex" end | S.Application (name, args) -> Linear [(A.of_expr name args, QC.unit)] | S.Sum (e1, e2) -> add (of_expr e1) (of_expr e2) | S.Difference (e1, e2) -> add (of_expr e1) (of_expr (S.Product (S.Integer (-1), e2))) | S.Product (e1, e2) -> multiply (of_expr e1) (of_expr e2) | S.Quotient (n, d) -> begin match of_expr n, of_expr d with | n, Linear [] -> invalid_arg "UFOx.Tensor.of_expr: zero denominator" | n, Linear [([], q)] -> map_coeff (fun c -> QC.div c q) n | n, Linear ([(invertibles, q)] as d) -> if List.for_all A.invertible invertibles then let inverses = List.map A.invert invertibles in multiply (Linear [(inverses, QC.inv q)]) n else multiply (Ratios [[([], QC.unit)], d]) n | n, (Linear d as d')-> if List.for_all (fun (t, _) -> List.for_all A.scalar t) d then multiply (Ratios [[([], QC.unit)], d]) n else invalid_arg ("UFOx.Tensor.of_expr: non scalar denominator: " ^ to_string d') | n, (Ratios _ as d) -> invalid_arg ("UFOx.Tensor.of_expr: illegal denominator: " ^ to_string d) end | S.Power (e, p) -> begin match of_expr e, of_expr p with | Linear [([], q)], Linear [([], p)] -> if QC.is_real p then let re_p = QC.real p in if Q.is_integer re_p then Linear [([], QC.pow q (Q.to_integer re_p))] else invalid_arg "UFOx.Tensor.of_expr: rational power of number" else invalid_arg "UFOx.Tensor.of_expr: complex power of number" | Linear [([], q)], _ -> invalid_arg "UFOx.Tensor.of_expr: non-numeric power of number" | t, Linear [([], p)] -> if QC.is_integer p then power (Q.to_integer (QC.real p)) t else invalid_arg "UFOx.Tensor.of_expr: non integer power of tensor" | _ -> invalid_arg "UFOx.Tensor.of_expr: non numeric power of tensor" end type r = A.r let rep_to_string = A.rep_to_string let rep_to_string_whizard = A.rep_to_string_whizard let rep_of_int = A.rep_of_int let rep_conjugate = A.rep_conjugate let rep_trivial = A.rep_trivial let numerators = function | Linear tensors -> tensors | Ratios ratios -> ThoList.flatmap fst ratios let classify_indices' filter tensors = ThoList.uniq (List.sort compare (List.map (fun (t, c) -> filter (A.classify_indices t)) (numerators tensors))) (* NB: the number of summation indices is not guarateed to be the same! Therefore it was foolish to try to check for uniqueness \ldots *) let classify_indices tensors = match classify_indices' Index.free tensors with | [] -> (* There's always at least an empty list! *) failwith "UFOx.Tensor.classify_indices: can't happen!" | [f] -> f | _ -> invalid_arg "UFOx.Tensor.classify_indices: incompatible free indices!" let disambiguate_indices1 (atoms, q) = (A.disambiguate_indices atoms, q) let disambiguate_indices tensors = map_ratios (List.map disambiguate_indices1) tensors let check_indices t = ignore (classify_indices t) let of_expr e = let t = disambiguate_indices (of_expr e) in check_indices t; t let of_string s = of_expr (Expr.of_string s) let of_strings s = of_expr (Expr.of_strings s) type r_omega = A.r_omega let omega = A.omega end module type Lorentz_Atom = sig type dirac = private | C of int * int | Gamma of int * int * int | Gamma5 of int * int | Identity of int * int | ProjP of int * int | ProjM of int * int | Sigma of int * int * int * int type vector = (* private *) | Epsilon of int * int * int * int | Metric of int * int | P of int * int type scalar = (* private *) | Mass of int | Width of int | P2 of int | P12 of int * int | Variable of string | Coeff of Value.t type t = (* private *) | Dirac of dirac | Vector of vector | Scalar of scalar | Inverse of scalar + val map_indices_scalar : (int -> int) -> scalar -> scalar val map_indices_vector : (int -> int) -> vector -> vector val rename_indices_vector : (int -> int) -> vector -> vector end module Lorentz_Atom = struct type dirac = | C of int * int | Gamma of int * int * int | Gamma5 of int * int | Identity of int * int | ProjP of int * int | ProjM of int * int | Sigma of int * int * int * int type vector = | Epsilon of int * int * int * int | Metric of int * int | P of int * int type scalar = | Mass of int | Width of int | P2 of int | P12 of int * int | Variable of string | Coeff of Value.t type t = | Dirac of dirac | Vector of vector | Scalar of scalar | Inverse of scalar + let map_indices_scalar f = function + | Mass i -> Mass (f i) + | Width i -> Width (f i) + | P2 i -> P2 (f i) + | P12 (i, j) -> P12 (f i, f j) + | (Variable _ | Coeff _ as s) -> s + let map_indices_vector f = function | Epsilon (mu, nu, ka, la) -> Epsilon (f mu, f nu, f ka, f la) | Metric (mu, nu) -> Metric (f mu, f nu) | P (mu, n) -> P (f mu, f n) let rename_indices_vector f = function | Epsilon (mu, nu, ka, la) -> Epsilon (f mu, f nu, f ka, f la) | Metric (mu, nu) -> Metric (f mu, f nu) | P (mu, n) -> P (f mu, n) end module Lorentz_Atom' : Atom with type t = Lorentz_Atom.t and type r_omega = Coupling.lorentz = struct type t = Lorentz_Atom.t open Lorentz_Atom let map_indices_dirac f = function | C (i, j) -> C (f i, f j) | Gamma (mu, i, j) -> Gamma (f mu, f i, f j) | Gamma5 (i, j) -> Gamma5 (f i, f j) | Identity (i, j) -> Identity (f i, f j) | ProjP (i, j) -> ProjP (f i, f j) | ProjM (i, j) -> ProjM (f i, f j) | Sigma (mu, nu, i, j) -> Sigma (f mu, f nu, f i, f j) let rename_indices_dirac = map_indices_dirac let map_indices_scalar f = function | Mass i -> Mass (f i) | Width i -> Width (f i) | P2 i -> P2 (f i) | P12 (i, j) -> P12 (f i, f j) | Variable s -> Variable s | Coeff c -> Coeff c let map_indices f = function | Dirac d -> Dirac (map_indices_dirac f d) | Vector v -> Vector (map_indices_vector f v) | Scalar s -> Scalar (map_indices_scalar f s) | Inverse s -> Inverse (map_indices_scalar f s) let rename_indices2 fd fv = function | Dirac d -> Dirac (rename_indices_dirac fd d) | Vector v -> Vector (rename_indices_vector fv v) | Scalar s -> Scalar s | Inverse s -> Inverse s let rename_indices f atom = rename_indices2 f f atom let contract_pair a1 a2 = match a1, a2 with | Vector (P (mu1, i1)), Vector (P (mu2, i2)) -> if mu1 <= 0 && mu1 = mu2 then if i1 = i2 then Some (Scalar (P2 i1)) else Some (Scalar (P12 (i1, i2))) else None | Scalar s, Inverse s' | Inverse s, Scalar s' -> if s = s' then Some (Scalar (Coeff (Value.Integer 1))) else None | _ -> None let variable = function | Scalar (Variable s) | Inverse (Variable s) -> Some s | _ -> None let scalar = function | Dirac _ | Vector _ -> false | Scalar _ | Inverse _ -> true let is_unit = function | Scalar (Coeff c) | Inverse (Coeff c) -> begin match c with | Value.Integer 1 -> true | Value.Rational q -> Algebra.Q.is_unit q | _ -> false end | _ -> false let invertible = scalar let invert = function | Dirac _ -> invalid_arg "UFOx.Lorentz_Atom.invert Dirac" | Vector _ -> invalid_arg "UFOx.Lorentz_Atom.invert Vector" | Scalar s -> Inverse s | Inverse s -> Scalar s let i2s = Index.to_string let dirac_to_string = function | C (i, j) -> Printf.sprintf "C(%s,%s)" (i2s i) (i2s j) | Gamma (mu, i, j) -> Printf.sprintf "Gamma(%s,%s,%s)" (i2s mu) (i2s i) (i2s j) | Gamma5 (i, j) -> Printf.sprintf "Gamma5(%s,%s)" (i2s i) (i2s j) | Identity (i, j) -> Printf.sprintf "Identity(%s,%s)" (i2s i) (i2s j) | ProjP (i, j) -> Printf.sprintf "ProjP(%s,%s)" (i2s i) (i2s j) | ProjM (i, j) -> Printf.sprintf "ProjM(%s,%s)" (i2s i) (i2s j) | Sigma (mu, nu, i, j) -> Printf.sprintf "Sigma(%s,%s,%s,%s)" (i2s mu) (i2s nu) (i2s i) (i2s j) let vector_to_string = function | Epsilon (mu, nu, ka, la) -> Printf.sprintf "Epsilon(%s,%s,%s,%s)" (i2s mu) (i2s nu) (i2s ka) (i2s la) | Metric (mu, nu) -> Printf.sprintf "Metric(%s,%s)" (i2s mu) (i2s nu) | P (mu, n) -> Printf.sprintf "P(%s,%d)" (i2s mu) n let scalar_to_string = function | Mass id -> Printf.sprintf "Mass(%d)" id | Width id -> Printf.sprintf "Width(%d)" id | P2 id -> Printf.sprintf "P(%d)**2" id | P12 (id1, id2) -> Printf.sprintf "P(%d)*P(%d)" id1 id2 | Variable s -> s | Coeff c -> Value.to_string c let to_string = function | Dirac d -> dirac_to_string d | Vector v -> vector_to_string v | Scalar s -> scalar_to_string s | Inverse s -> "1/" ^ scalar_to_string s module S = UFOx_syntax (* \begin{dubious} Here we handle some special cases in order to be able to parse propagators. This needs to be made more general, but unfortunately the syntax for the propagator extension is not well documented and appears to be a bit chaotic! \end{dubious} *) let quoted_index s = Index.named_summation s () let integer_or_id = function | S.Integer n -> n | S.Variable "id" -> 1 | _ -> failwith "UFOx.Lorentz_Atom.integer_or_id: impossible" let vector_index = function | S.Integer n -> n | S.Quoted mu -> quoted_index mu | S.Variable id -> let l = String.length id in if l > 1 then if id.[0] = 'l' then int_of_string (String.sub id 1 (pred l)) else invalid_arg ("UFOx.Lorentz_Atom.vector_index: " ^ id) else invalid_arg "UFOx.Lorentz_Atom.vector_index: empty variable" | _ -> invalid_arg "UFOx.Lorentz_Atom.vector_index" let spinor_index = function | S.Integer n -> n | S.Variable id -> let l = String.length id in if l > 1 then if id.[0] = 's' then int_of_string (String.sub id 1 (pred l)) else invalid_arg ("UFOx.Lorentz_Atom.spinor_index: " ^ id) else invalid_arg "UFOx.Lorentz_Atom.spinor_index: empty variable" | _ -> invalid_arg "UFOx.Lorentz_Atom.spinor_index" let of_expr name args = match name, args with | "C", [i; j] -> [Dirac (C (spinor_index i, spinor_index j))] | "C", _ -> invalid_arg "UFOx.Lorentz.of_expr: invalid arguments to C()" | "Epsilon", [mu; nu; ka; la] -> [Vector (Epsilon (vector_index mu, vector_index nu, vector_index ka, vector_index la))] | "Epsilon", _ -> invalid_arg "UFOx.Lorentz.of_expr: invalid arguments to Epsilon()" | "Gamma", [mu; i; j] -> [Dirac (Gamma (vector_index mu, spinor_index i, spinor_index j))] | "Gamma", _ -> invalid_arg "UFOx.Lorentz.of_expr: invalid arguments to Gamma()" | "Gamma5", [i; j] -> [Dirac (Gamma5 (spinor_index i, spinor_index j))] | "Gamma5", _ -> invalid_arg "UFOx.Lorentz.of_expr: invalid arguments to Gamma5()" | "Identity", [i; j] -> [Dirac (Identity (spinor_index i, spinor_index j))] | "Identity", _ -> invalid_arg "UFOx.Lorentz.of_expr: invalid arguments to Identity()" | "Metric", [mu; nu] -> [Vector (Metric (vector_index mu, vector_index nu))] | "Metric", _ -> invalid_arg "UFOx.Lorentz.of_expr: invalid arguments to Metric()" | "P", [mu; id] -> [Vector (P (vector_index mu, integer_or_id id))] | "P", _ -> invalid_arg "UFOx.Lorentz.of_expr: invalid arguments to P()" | "ProjP", [i; j] -> [Dirac (ProjP (spinor_index i, spinor_index j))] | "ProjP", _ -> invalid_arg "UFOx.Lorentz.of_expr: invalid arguments to ProjP()" | "ProjM", [i; j] -> [Dirac (ProjM (spinor_index i, spinor_index j))] | "ProjM", _ -> invalid_arg "UFOx.Lorentz.of_expr: invalid arguments to ProjM()" | "Sigma", [mu; nu; i; j] -> if mu <> nu then [Dirac (Sigma (vector_index mu, vector_index nu, spinor_index i, spinor_index j))] else invalid_arg "UFOx.Lorentz.of_expr: implausible arguments to Sigma()" | "Sigma", _ -> invalid_arg "UFOx.Lorentz.of_expr: invalid arguments to Sigma()" | "PSlash", [i; j; id] -> let mu = Index.fresh_summation () in [Dirac (Gamma (mu, spinor_index i, spinor_index j)); Vector (P (mu, integer_or_id id))] | "PSlash", _ -> invalid_arg "UFOx.Lorentz.of_expr: invalid arguments to PSlash()" | "Mass", [id] -> [Scalar (Mass (integer_or_id id))] | "Mass", _ -> invalid_arg "UFOx.Lorentz.of_expr: invalid arguments to Mass()" | "Width", [id] -> [Scalar (Width (integer_or_id id))] | "Width", _ -> invalid_arg "UFOx.Lorentz.of_expr: invalid arguments to Width()" | name, [] -> [Scalar (Variable name)] | name, _ -> invalid_arg ("UFOx.Lorentz.of_expr: invalid tensor '" ^ name ^ "'") type r = S | V | T | Sp | CSp | Maj | VSp | CVSp | VMaj | Ghost let rep_trivial = function | S | Ghost -> true | V | T | Sp | CSp | Maj | VSp | CVSp | VMaj -> false let rep_to_string = function | S -> "0" | V -> "1" | T -> "2" | Sp -> "1/2" | CSp-> "1/2bar" | Maj -> "1/2M" | VSp -> "3/2" | CVSp -> "3/2bar" | VMaj -> "3/2M" | Ghost -> "Ghost" let rep_to_string_whizard = function | S -> "0" | V -> "1" | T -> "2" | Sp | CSp | Maj -> "1/2" | VSp | CVSp | VMaj -> "3/2" | Ghost -> "Ghost" let rep_of_int neutral = function | -1 -> Ghost | 1 -> S | 2 -> if neutral then Maj else Sp | -2 -> if neutral then Maj else CSp (* used by [UFO.Particle.force_conjspinor] *) | 3 -> V | 4 -> if neutral then VMaj else VSp | -4 -> if neutral then VMaj else CVSp (* used by [UFO.Particle.force_conjspinor] *) | 5 -> T | s when s > 0 -> failwith "UFOx.Lorentz: spin > 2 not supported!" | _ -> invalid_arg "UFOx.Lorentz: invalid non-positive spin value" let rep_conjugate = function | S -> S | V -> V | T -> T | Sp -> CSp (* ??? *) | CSp -> Sp (* ??? *) | Maj -> Maj | VSp -> CVSp | CVSp -> VSp | VMaj -> VMaj | Ghost -> Ghost let classify_vector_indices1 = function | Epsilon (mu, nu, ka, la) -> [(mu, V); (nu, V); (ka, V); (la, V)] | Metric (mu, nu) -> [(mu, V); (nu, V)] | P (mu, n) -> [(mu, V)] let classify_dirac_indices1 = function | C (i, j) -> [(i, CSp); (j, Sp)] (* ??? *) | Gamma5 (i, j) | Identity (i, j) | ProjP (i, j) | ProjM (i, j) -> [(i, CSp); (j, Sp)] | Gamma (mu, i, j) -> [(mu, V); (i, CSp); (j, Sp)] | Sigma (mu, nu, i, j) -> [(mu, V); (nu, V); (i, CSp); (j, Sp)] let classify_indices1 = function | Dirac d -> classify_dirac_indices1 d | Vector v -> classify_vector_indices1 v | Scalar _ | Inverse _ -> [] module IMap = Map.Make (struct type t = int let compare = compare end) exception Incompatible_factors of r * r let product rep1 rep2 = match rep1, rep2 with | V, V -> T | V, Sp -> VSp | V, CSp -> CVSp | V, Maj -> VMaj | Sp, V -> VSp | CSp, V -> CVSp | Maj, V -> VMaj | _, _ -> raise (Incompatible_factors (rep1, rep2)) let combine_or_add_index (i, rep) map = let pos, fac = Index.unpack i in try let fac', rep' = IMap.find pos map in if pos < 0 then IMap.add pos (fac, rep) map else if fac <> fac' then IMap.add pos (0, product rep rep') map else if rep <> rep' then (* Can be disambiguated! *) IMap.add pos (0, product rep rep') map else invalid_arg (Printf.sprintf "UFO: duplicate subindex %d" pos) with | Not_found -> IMap.add pos (fac, rep) map | Incompatible_factors (rep1, rep2) -> invalid_arg (Printf.sprintf "UFO: incompatible factors (%s,%s) at %d" (rep_to_string rep1) (rep_to_string rep2) pos) let combine_or_add_indices atom map = List.fold_right combine_or_add_index (classify_indices1 atom) map let project_factors (pos, (fac, rep)) = if fac = 0 then (pos, rep) else invalid_arg (Printf.sprintf "UFO: leftover subindex %d.%d" pos fac) let classify_indices atoms = List.map project_factors (IMap.bindings (List.fold_right combine_or_add_indices atoms IMap.empty)) let add_factor fac indices pos = if pos > 0 then if Sets.Int.mem pos indices then Index.pack pos fac else pos else pos let disambiguate_indices1 indices atom = rename_indices2 (add_factor 1 indices) (add_factor 2 indices) atom let vectorspinors atoms = List.fold_left (fun acc (i, r) -> match r with | S | V | T | Sp | CSp | Maj | Ghost -> acc | VSp | CVSp | VMaj -> Sets.Int.add i acc) Sets.Int.empty (classify_indices atoms) let disambiguate_indices atoms = let vectorspinor_indices = vectorspinors atoms in List.map (disambiguate_indices1 vectorspinor_indices) atoms type r_omega = Coupling.lorentz let omega = function | S -> Coupling.Scalar | V -> Coupling.Vector | T -> Coupling.Tensor_2 | Sp -> Coupling.Spinor | CSp -> Coupling.ConjSpinor | Maj -> Coupling.Majorana | VSp -> Coupling.Vectorspinor | CVSp -> Coupling.Vectorspinor (* TODO: not really! *) | VMaj -> Coupling.Vectorspinor (* TODO: not really! *) | Ghost -> Coupling.Scalar end module Lorentz = Tensor(Lorentz_Atom') module type Color_Atom = sig type t = (* private *) | Identity of int * int | Identity8 of int * int | T of int * int * int | F of int * int * int | D of int * int * int | Epsilon of int * int * int | EpsilonBar of int * int * int | T6 of int * int * int | K6 of int * int * int | K6Bar of int * int * int end module Color_Atom = struct type t = | Identity of int * int | Identity8 of int * int | T of int * int * int | F of int * int * int | D of int * int * int | Epsilon of int * int * int | EpsilonBar of int * int * int | T6 of int * int * int | K6 of int * int * int | K6Bar of int * int * int end module Color_Atom' : Atom with type t = Color_Atom.t and type r_omega = Color.t = struct type t = Color_Atom.t module S = UFOx_syntax open Color_Atom let map_indices f = function | Identity (i, j) -> Identity (f i, f j) | Identity8 (a, b) -> Identity8 (f a, f b) | T (a, i, j) -> T (f a, f i, f j) | F (a, i, j) -> F (f a, f i, f j) | D (a, i, j) -> D (f a, f i, f j) | Epsilon (i, j, k) -> Epsilon (f i, f j, f k) | EpsilonBar (i, j, k) -> EpsilonBar (f i, f j, f k) | T6 (a, i', j') -> T6 (f a, f i', f j') | K6 (i', j, k) -> K6 (f i', f j, f k) | K6Bar (i', j, k) -> K6Bar (f i', f j, f k) let rename_indices = map_indices let contract_pair _ _ = None let variable _ = None let scalar _ = false let invertible _ = false let is_unit _ = false let invert _ = invalid_arg "UFOx.Color_Atom.invert" let of_expr1 name args = match name, args with | "Identity", [S.Integer i; S.Integer j] -> Identity (i, j) | "Identity", _ -> invalid_arg "UFOx.Color.of_expr: invalid arguments to Identity()" | "T", [S.Integer a; S.Integer i; S.Integer j] -> T (a, i, j) | "T", _ -> invalid_arg "UFOx.Color.of_expr: invalid arguments to T()" | "f", [S.Integer a; S.Integer b; S.Integer c] -> F (a, b, c) | "f", _ -> invalid_arg "UFOx.Color.of_expr: invalid arguments to f()" | "d", [S.Integer a; S.Integer b; S.Integer c] -> D (a, b, c) | "d", _ -> invalid_arg "UFOx.Color.of_expr: invalid arguments to d()" | "Epsilon", [S.Integer i; S.Integer j; S.Integer k] -> Epsilon (i, j, k) | "Epsilon", _ -> invalid_arg "UFOx.Color.of_expr: invalid arguments to Epsilon()" | "EpsilonBar", [S.Integer i; S.Integer j; S.Integer k] -> EpsilonBar (i, j, k) | "EpsilonBar", _ -> invalid_arg "UFOx.Color.of_expr: invalid arguments to EpsilonBar()" | "T6", [S.Integer a; S.Integer i'; S.Integer j'] -> T6 (a, i', j') | "T6", _ -> invalid_arg "UFOx.Color.of_expr: invalid arguments to T6()" | "K6", [S.Integer i'; S.Integer j; S.Integer k] -> K6 (i', j, k) | "K6", _ -> invalid_arg "UFOx.Color.of_expr: invalid arguments to K6()" | "K6Bar", [S.Integer i'; S.Integer j; S.Integer k] -> K6Bar (i', j, k) | "K6Bar", _ -> invalid_arg "UFOx.Color.of_expr: invalid arguments to K6Bar()" | name, _ -> invalid_arg ("UFOx.Color.of_expr: invalid tensor '" ^ name ^ "'") let of_expr name args = [of_expr1 name args] let to_string = function | Identity (i, j) -> Printf.sprintf "Identity(%d,%d)" i j | Identity8 (a, b) -> Printf.sprintf "Identity8(%d,%d)" a b | T (a, i, j) -> Printf.sprintf "T(%d,%d,%d)" a i j | F (a, b, c) -> Printf.sprintf "f(%d,%d,%d)" a b c | D (a, b, c) -> Printf.sprintf "d(%d,%d,%d)" a b c | Epsilon (i, j, k) -> Printf.sprintf "Epsilon(%d,%d,%d)" i j k | EpsilonBar (i, j, k) -> Printf.sprintf "EpsilonBar(%d,%d,%d)" i j k | T6 (a, i', j') -> Printf.sprintf "T6(%d,%d,%d)" a i' j' | K6 (i', j, k) -> Printf.sprintf "K6(%d,%d,%d)" i' j k | K6Bar (i', j, k) -> Printf.sprintf "K6Bar(%d,%d,%d)" i' j k type r = S | Sbar | F | C | A let rep_trivial = function | S | Sbar -> true | F | C | A-> false let rep_to_string = function | S -> "1" | Sbar -> "1bar" | F -> "3" | C -> "3bar" | A-> "8" let rep_to_string_whizard = function | S -> "1" | Sbar -> "-1" | F -> "3" | C -> "-3" | A-> "8" let rep_of_int neutral = function | 1 -> S | -1 -> Sbar (* UFO appears to use this for colorless antiparticles!. *) | 3 -> F | -3 -> C | 8 -> A | 6 | -6 -> failwith "UFOx.Color: sextets not supported yet!" | _ -> invalid_arg "UFOx.Color: impossible representation!" let rep_conjugate = function | Sbar -> S | S -> Sbar | C -> F | F -> C | A -> A let classify_indices1 = function | Identity (i, j) -> [(i, C); (j, F)] | Identity8 (a, b) -> [(a, A); (b, A)] | T (a, i, j) -> [(i, F); (j, C); (a, A)] | Color_Atom.F (a, b, c) | D (a, b, c) -> [(a, A); (b, A); (c, A)] | Epsilon (i, j, k) -> [(i, F); (j, F); (k, F)] | EpsilonBar (i, j, k) -> [(i, C); (j, C); (k, C)] | T6 (a, i', j') -> failwith "UFOx.Color: sextets not supported yet!" | K6 (i', j, k) -> failwith "UFOx.Color: sextets not supported yet!" | K6Bar (i', j, k) -> failwith "UFOx.Color: sextets not supported yet!" let classify_indices tensors = List.sort compare (List.fold_right (fun v acc -> classify_indices1 v @ acc) tensors []) let disambiguate_indices atoms = atoms type r_omega = Color.t (* FIXME: $N_C=3$ should not be hardcoded! *) let omega = function | S | Sbar -> Color.Singlet | F -> Color.SUN (3) | C -> Color.SUN (-3) | A-> Color.AdjSUN (3) end module Color = Tensor(Color_Atom') module type Test = sig val example : unit -> unit val suite : OUnit.test end Index: trunk/omega/src/modellib_SM.ml =================================================================== --- trunk/omega/src/modellib_SM.ml (revision 8491) +++ trunk/omega/src/modellib_SM.ml (revision 8492) @@ -1,2921 +1,2924 @@ (* modellib_SM.ml -- Copyright (C) 1999-2021 by Wolfgang Kilian Thorsten Ohl Juergen Reuter with contributions from Christian Speckner Fabian Bach (only parts of this file) So Young Shim (only parts of this file) WHIZARD 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 2, or (at your option) any later version. WHIZARD 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, write to the Free Software Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. *) (* \thocwmodulesection{$\phi^3$} *) module Phi3 = struct open Coupling let options = Options.empty let caveats () = [] type flavor = Phi let external_flavors () = [ "", [Phi]] let flavors () = ThoList.flatmap snd (external_flavors ()) type gauge = unit type constant = G type orders = unit let orders = function | _ -> () let lorentz _ = Scalar let color _ = Color.Singlet let nc () = 0 let propagator _ = Prop_Scalar let width _ = Timelike let goldstone _ = None let conjugate f = f let fermion _ = 0 module Ch = Charges.Null let charges _ = () module F = Modeltools.Fusions (struct type f = flavor type c = constant let compare = compare let conjugate = conjugate end) let vertices () = ([(Phi, Phi, Phi), Scalar_Scalar_Scalar 1, G], [], []) let table = F.of_vertices (vertices ()) let fuse2 = F.fuse2 table let fuse3 = F.fuse3 table let fuse = F.fuse table let max_degree () = 3 let parameters () = { input = [G, 1.0]; derived = []; derived_arrays = [] } let flavor_of_string = function | "p" -> Phi | _ -> invalid_arg "Modellib.Phi3.flavor_of_string" let flavor_to_string Phi = "phi" let flavor_to_TeX Phi = "\\phi" let flavor_symbol Phi = "phi" let gauge_symbol () = failwith "Modellib.Phi3.gauge_symbol: internal error" let pdg _ = 1 let mass_symbol _ = "m" let width_symbol _ = "w" let constant_symbol G = "g" end (* \thocwmodulesection{$\lambda_3\phi^3+\lambda_4\phi^4$} *) module Phi4 = struct open Coupling let options = Options.empty let caveats () = [] type flavor = Phi let external_flavors () = [ "", [Phi]] let flavors () = ThoList.flatmap snd (external_flavors ()) type gauge = unit type constant = G3 | G4 type orders = unit let orders = function | _ -> () let lorentz _ = Scalar let color _ = Color.Singlet let nc () = 0 let propagator _ = Prop_Scalar let width _ = Timelike let goldstone _ = None let conjugate f = f let fermion _ = 0 module Ch = Charges.Null let charges _ = () module F = Modeltools.Fusions (struct type f = flavor type c = constant let compare = compare let conjugate = conjugate end) let vertices () = ([(Phi, Phi, Phi), Scalar_Scalar_Scalar 1, G3], [(Phi, Phi, Phi, Phi), Scalar4 1, G4], []) let fuse2 _ = failwith "Modellib.Phi4.fuse2" let fuse3 _ = failwith "Modellib.Phi4.fuse3" let fuse = function | [] | [_] -> invalid_arg "Modellib.Phi4.fuse" | [_; _] -> [Phi, V3 (Scalar_Scalar_Scalar 1, F23, G3)] | [_; _; _] -> [Phi, V4 (Scalar4 1, F234, G4)] | _ -> [] let max_degree () = 4 let parameters () = { input = [G3, 1.0; G4, 1.0]; derived = []; derived_arrays = [] } let flavor_of_string = function | "p" -> Phi | _ -> invalid_arg "Modellib.Phi4.flavor_of_string" let flavor_to_string Phi = "phi" let flavor_to_TeX Phi = "\\phi" let flavor_symbol Phi = "phi" let gauge_symbol () = failwith "Modellib.Phi4.gauge_symbol: internal error" let pdg _ = 1 let mass_symbol _ = "m" let width_symbol _ = "w" let constant_symbol = function | G3 -> "g3" | G4 -> "g4" end (* \thocwmodulesection{Quantum Electro Dynamics} *) module QED = struct open Coupling let options = Options.empty let caveats () = [] type flavor = | Electron | Positron | Muon | AntiMuon | Tau | AntiTau | Photon let external_flavors () = [ "Leptons", [Electron; Positron; Muon; AntiMuon; Tau; AntiTau]; "Gauge Bosons", [Photon] ] let flavors () = ThoList.flatmap snd (external_flavors ()) type gauge = unit type constant = Q type orders = unit let orders = function | _ -> () let lorentz = function | Electron | Muon | Tau -> Spinor | Positron | AntiMuon | AntiTau -> ConjSpinor | Photon -> Vector let color _ = Color.Singlet let nc () = 0 let propagator = function | Electron | Muon | Tau -> Prop_Spinor | Positron | AntiMuon | AntiTau -> Prop_ConjSpinor | Photon -> Prop_Feynman let width _ = Timelike let goldstone _ = None let conjugate = function | Electron -> Positron | Positron -> Electron | Muon -> AntiMuon | AntiMuon -> Muon | Tau -> AntiTau | AntiTau -> Tau | Photon -> Photon let fermion = function | Electron | Muon | Tau -> 1 | Positron | AntiMuon | AntiTau -> -1 | Photon -> 0 (* Taking generation numbers makes electric charge redundant. *) module Ch = Charges.ZZ let charges = function | Electron -> [1; 0; 0] | Muon -> [0; 1; 0] | Tau -> [0; 0; 1] | Positron -> [-1;0; 0] | AntiMuon -> [0;-1; 0] | AntiTau -> [0; 0;-1] | Photon -> [0; 0; 0] module F = Modeltools.Fusions (struct type f = flavor type c = constant let compare = compare let conjugate = conjugate end) let vertices () = ([(Positron, Photon, Electron), FBF (1, Psibar, V, Psi), Q; (AntiMuon, Photon, Muon), FBF (1, Psibar, V, Psi), Q; (AntiTau, Photon, Tau), FBF (1, Psibar, V, Psi), Q], [], []) let table = F.of_vertices (vertices ()) let fuse2 = F.fuse2 table let fuse3 = F.fuse3 table let fuse = F.fuse table let max_degree () = 3 let parameters () = { input = [Q, 1.0]; derived = []; derived_arrays = [] } let flavor_of_string = function | "e-" -> Electron | "e+" -> Positron | "m-" -> Muon | "m+" -> AntiMuon | "t-" -> Tau | "t+" -> AntiTau | "A" -> Photon | _ -> invalid_arg "Modellib.QED.flavor_of_string" let flavor_to_string = function | Electron -> "e-" | Positron -> "e+" | Muon -> "m-" | AntiMuon -> "m+" | Tau -> "t-" | AntiTau -> "t+" | Photon -> "A" let flavor_to_TeX = function | Electron -> "e^-" | Positron -> "e^+" | Muon -> "\\mu^-" | AntiMuon -> "\\mu^+" | Tau -> "^\\tau^-" | AntiTau -> "\\tau+^" | Photon -> "\\gamma" let flavor_symbol = function | Electron -> "ele" | Positron -> "pos" | Muon -> "muo" | AntiMuon -> "amu" | Tau -> "tau" | AntiTau -> "ata" | Photon -> "gam" let gauge_symbol () = failwith "Modellib.QED.gauge_symbol: internal error" let pdg = function | Electron -> 11 | Positron -> -11 | Muon -> 13 | AntiMuon -> -13 | Tau -> 15 | AntiTau -> -15 | Photon -> 22 let mass_symbol f = "mass(" ^ string_of_int (abs (pdg f)) ^ ")" let width_symbol f = "width(" ^ string_of_int (abs (pdg f)) ^ ")" let constant_symbol = function | Q -> "qlep" end (* \thocwmodulesection{Quantum Chromo Dynamics} *) module QCD = struct open Coupling let options = Options.empty let caveats () = [] type flavor = | U | Ubar | D | Dbar | C | Cbar | S | Sbar | T | Tbar | B | Bbar | Gl let external_flavors () = [ "Quarks", [U; D; C; S; T; B; Ubar; Dbar; Cbar; Sbar; Tbar; Bbar]; "Gauge Bosons", [Gl]] let flavors () = ThoList.flatmap snd (external_flavors ()) type gauge = unit type constant = Gs | G2 | I_Gs type orders = unit let orders = function | _ -> () let lorentz = function | U | D | C | S | T | B -> Spinor | Ubar | Dbar | Cbar | Sbar | Tbar | Bbar -> ConjSpinor | Gl -> Vector let color = function | U | D | C | S | T | B -> Color.SUN 3 | Ubar | Dbar | Cbar | Sbar | Tbar | Bbar -> Color.SUN (-3) | Gl -> Color.AdjSUN 3 let nc () = 3 let propagator = function | U | D | C | S | T | B -> Prop_Spinor | Ubar | Dbar | Cbar | Sbar | Tbar | Bbar -> Prop_ConjSpinor | Gl -> Prop_Feynman let width _ = Timelike let goldstone _ = None let conjugate = function | U -> Ubar | D -> Dbar | C -> Cbar | S -> Sbar | T -> Tbar | B -> Bbar | Ubar -> U | Dbar -> D | Cbar -> C | Sbar -> S | Tbar -> T | Bbar -> B | Gl -> Gl let fermion = function | U | D | C | S | T | B -> 1 | Ubar | Dbar | Cbar | Sbar | Tbar | Bbar -> -1 | Gl -> 0 module Ch = Charges.ZZ let charges = function | D -> [1; 0; 0; 0; 0; 0] | U -> [0; 1; 0; 0; 0; 0] | S -> [0; 0; 1; 0; 0; 0] | C -> [0; 0; 0; 1; 0; 0] | B -> [0; 0; 0; 0; 1; 0] | T -> [0; 0; 0; 0; 0; 1] | Dbar -> [-1; 0; 0; 0; 0; 0] | Ubar -> [0; -1; 0; 0; 0; 0] | Sbar -> [0; 0; -1; 0; 0; 0] | Cbar -> [0; 0; 0; -1; 0; 0] | Bbar -> [0; 0; 0; 0; -1; 0] | Tbar -> [0; 0; 0; 0; 0; -1] | Gl -> [0; 0; 0; 0; 0; 0] module F = Modeltools.Fusions (struct type f = flavor type c = constant let compare = compare let conjugate = conjugate end) (* This is compatible with CD+. *) let color_current = [ ((Dbar, Gl, D), FBF ((-1), Psibar, V, Psi), Gs); ((Ubar, Gl, U), FBF ((-1), Psibar, V, Psi), Gs); ((Cbar, Gl, C), FBF ((-1), Psibar, V, Psi), Gs); ((Sbar, Gl, S), FBF ((-1), Psibar, V, Psi), Gs); ((Tbar, Gl, T), FBF ((-1), Psibar, V, Psi), Gs); ((Bbar, Gl, B), FBF ((-1), Psibar, V, Psi), Gs)] let three_gluon = [ ((Gl, Gl, Gl), Gauge_Gauge_Gauge 1, I_Gs)] let gauge4 = Vector4 [(2, C_13_42); (-1, C_12_34); (-1, C_14_23)] let four_gluon = [ ((Gl, Gl, Gl, Gl), gauge4, G2)] let vertices3 = (color_current @ three_gluon) let vertices4 = four_gluon let vertices () = (vertices3, vertices4, []) let table = F.of_vertices (vertices ()) let fuse2 = F.fuse2 table let fuse3 = F.fuse3 table let fuse = F.fuse table let max_degree () = 4 let parameters () = { input = [Gs, 1.0]; derived = []; derived_arrays = [] } let flavor_of_string = function | "u" -> U | "d" -> D | "c" -> C | "s" -> S | "t" -> T | "b" -> B | "ubar" -> Ubar | "dbar" -> Dbar | "cbar" -> Cbar | "sbar" -> Sbar | "tbar" -> Tbar | "bbar" -> Bbar | "gl" -> Gl | _ -> invalid_arg "Modellib.QCD.flavor_of_string" let flavor_to_string = function | U -> "u" | Ubar -> "ubar" | D -> "d" | Dbar -> "dbar" | C -> "c" | Cbar -> "cbar" | S -> "s" | Sbar -> "sbar" | T -> "t" | Tbar -> "tbar" | B -> "b" | Bbar -> "bbar" | Gl -> "gl" let flavor_to_TeX = function | U -> "u" | Ubar -> "\\bar{u}" | D -> "d" | Dbar -> "\\bar{d}" | C -> "c" | Cbar -> "\\bar{c}" | S -> "s" | Sbar -> "\\bar{s}" | T -> "t" | Tbar -> "\\bar{t}" | B -> "b" | Bbar -> "\\bar{b}" | Gl -> "g" let flavor_symbol = function | U -> "u" | Ubar -> "ubar" | D -> "d" | Dbar -> "dbar" | C -> "c" | Cbar -> "cbar" | S -> "s" | Sbar -> "sbar" | T -> "t" | Tbar -> "tbar" | B -> "b" | Bbar -> "bbar" | Gl -> "gl" let gauge_symbol () = failwith "Modellib.QCD.gauge_symbol: internal error" let pdg = function | D -> 1 | Dbar -> -1 | U -> 2 | Ubar -> -2 | S -> 3 | Sbar -> -3 | C -> 4 | Cbar -> -4 | B -> 5 | Bbar -> -5 | T -> 6 | Tbar -> -6 | Gl -> 21 let mass_symbol f = "mass(" ^ string_of_int (abs (pdg f)) ^ ")" let width_symbol f = "width(" ^ string_of_int (abs (pdg f)) ^ ")" let constant_symbol = function | I_Gs -> "(0,1)*gs" | Gs -> "gs" | G2 -> "gs**2" end (* \thocwmodulesection{Complete Minimal Standard Model (Unitarity Gauge)} *) module type SM_flags = sig val higgs_triangle : bool (* $H\gamma\gamma$, $Hg\gamma$ and $Hgg$ couplings *) val higgs_hmm : bool (* $H\mu^+\mu^-$ and $He^+e^-$ couplings *) val triple_anom : bool val quartic_anom : bool val higgs_anom : bool val dim6 : bool val k_matrix : bool val ckm_present : bool val top_anom : bool val top_anom_4f : bool val tt_threshold : bool end module SM_no_anomalous : SM_flags = struct let higgs_triangle = false let higgs_hmm = false let triple_anom = false let quartic_anom = false let higgs_anom = false let dim6 = false let k_matrix = false let ckm_present = false let top_anom = false let top_anom_4f = false let tt_threshold = false end module SM_no_anomalous_ckm : SM_flags = struct let higgs_triangle = false let higgs_hmm = false let triple_anom = false let quartic_anom = false let higgs_anom = false let dim6 = false let k_matrix = false let ckm_present = true let top_anom = false let top_anom_4f = false let tt_threshold = false end module SM_anomalous : SM_flags = struct let higgs_triangle = false let higgs_hmm = false let triple_anom = true let quartic_anom = true let higgs_anom = true let dim6 = false let k_matrix = false let ckm_present = false let top_anom = false let top_anom_4f = false let tt_threshold = false end module SM_anomalous_ckm : SM_flags = struct let higgs_triangle = false let higgs_hmm = false let triple_anom = true let quartic_anom = true let higgs_anom = true let dim6 = false let k_matrix = false let ckm_present = true let top_anom = false let top_anom_4f = false let tt_threshold = false end module SM_k_matrix : SM_flags = struct let higgs_triangle = false let higgs_hmm = false let triple_anom = false let quartic_anom = true let higgs_anom = false let dim6 = false let k_matrix = true let ckm_present = false let top_anom = false let top_anom_4f = false let tt_threshold = false end module SM_Higgs : SM_flags = struct let higgs_triangle = true let higgs_hmm = true let triple_anom = false let quartic_anom = false let higgs_anom = false let dim6 = false let k_matrix = false let ckm_present = false let top_anom = false let top_anom_4f = false let tt_threshold = false end module SM_Higgs_CKM : SM_flags = struct let higgs_triangle = true let higgs_hmm = true let triple_anom = false let quartic_anom = false let higgs_anom = false let dim6 = false let k_matrix = false let ckm_present = true let top_anom = false let top_anom_4f = false let tt_threshold = false end module SM_anomalous_top : SM_flags = struct let higgs_triangle = false let higgs_hmm = false let triple_anom = false let quartic_anom = false let higgs_anom = false let dim6 = false let k_matrix = false let ckm_present = false let top_anom = true let top_anom_4f = true let tt_threshold = false end module SM_tt_threshold : SM_flags = struct let higgs_triangle = false let higgs_hmm = false let triple_anom = false let quartic_anom = false let higgs_anom = false let dim6 = false let k_matrix = false let ckm_present = true let top_anom = false let top_anom_4f = false let tt_threshold = true end module SM_dim6 : SM_flags = struct let higgs_triangle = false let higgs_hmm = false let triple_anom = false let quartic_anom = false let higgs_anom = false let dim6 = true let k_matrix = false let ckm_present = false let top_anom = false let top_anom_4f = false let tt_threshold = false end (* \thocwmodulesection{Complete Minimal Standard Model (including some extensions)} *) module SM (Flags : SM_flags) = struct open Coupling let default_width = ref Timelike let use_fudged_width = ref false let options = Options.create [ "constant_width", Arg.Unit (fun () -> default_width := Constant), "use constant width (also in t-channel)"; "fudged_width", Arg.Set use_fudged_width, "use fudge factor for charge particle width"; "custom_width", Arg.String (fun f -> default_width := Custom f), "use custom width"; "cancel_widths", Arg.Unit (fun () -> default_width := Vanishing), "use vanishing width"; "cms_width", Arg.Unit (fun () -> default_width := Complex_Mass), "use complex mass scheme"; "running_width", Arg.Unit (fun () -> default_width := Running), "use running width" ] let caveats () = [] type f_aux_top = TTGG | TBWA | TBWZ | TTWW | BBWW | TCGG | TUGG (*i top auxiliary field "flavors" i*) | QGUG | QBUB | QW | DL | DR | QUQD1L | QUQD1R | QUQD8L | QUQD8R type matter_field = L of int | N of int | U of int | D of int type gauge_boson = Ga | Wp | Wm | Z | Gl type other = Phip | Phim | Phi0 | H | Aux_top of int*int*int*bool*f_aux_top (*i lorentz*color*charge*top-side*flavor i*) type flavor = M of matter_field | G of gauge_boson | O of other let matter_field f = M f let gauge_boson f = G f let other f = O f type field = | Matter of matter_field | Gauge of gauge_boson | Other of other let field = function | M f -> Matter f | G f -> Gauge f | O f -> Other f type gauge = unit let gauge_symbol () = failwith "Modellib.SM.gauge_symbol: internal error" let family n = List.map matter_field [ L n; N n; U n; D n ] let rec aux_top_flavors (f,l,co,ch) = List.append ( List.map other [ Aux_top (l,co,ch/2,true,f); Aux_top (l,co,ch/2,false,f) ] ) ( if ch > 1 then List.append ( List.map other [ Aux_top (l,co,-ch/2,true,f); Aux_top (l,co,-ch/2,false,f) ] ) ( aux_top_flavors (f,l,co,(ch-2)) ) else [] ) let external_flavors () = [ "1st Generation", ThoList.flatmap family [1; -1]; "2nd Generation", ThoList.flatmap family [2; -2]; "3rd Generation", ThoList.flatmap family [3; -3]; "Gauge Bosons", List.map gauge_boson [Ga; Z; Wp; Wm; Gl]; "Higgs", List.map other [H]; "Goldstone Bosons", List.map other [Phip; Phim; Phi0] ] let flavors () = List.append ( ThoList.flatmap snd (external_flavors ()) ) ( ThoList.flatmap aux_top_flavors [ (TTGG,2,1,1); (TCGG,2,1,1); (TUGG,2,1,1); (TBWA,2,0,2); (TBWZ,2,0,2); (TTWW,2,0,1); (BBWW,2,0,1); (QGUG,1,1,1); (QBUB,1,0,1); (QW,1,0,3); (DL,0,0,3); (DR,0,0,3); (QUQD1L,0,0,3); (QUQD1R,0,0,3); (QUQD8L,0,1,3); (QUQD8R,0,1,3) ] ) let spinor n = if n >= 0 then Spinor else ConjSpinor let lorentz_aux = function | 2 -> Tensor_1 | 1 -> Vector | 0 -> Scalar | _ -> invalid_arg ("SM.lorentz_aux: wrong value") let lorentz = function | M f -> begin match f with | L n -> spinor n | N n -> spinor n | U n -> spinor n | D n -> spinor n end | G f -> begin match f with | Ga | Gl -> Vector | Wp | Wm | Z -> Massive_Vector end | O f -> begin match f with | Aux_top (l,_,_,_,_) -> lorentz_aux l | _ -> Scalar end let color = function | M (U n) -> Color.SUN (if n > 0 then 3 else -3) | M (D n) -> Color.SUN (if n > 0 then 3 else -3) | G Gl -> Color.AdjSUN 3 | O (Aux_top (_,co,_,_,_)) -> if co == 0 then Color.Singlet else Color.AdjSUN 3 | _ -> Color.Singlet let nc () = 3 let prop_spinor n = if n >= 0 then Prop_Spinor else Prop_ConjSpinor let prop_aux = function | 2 -> Aux_Tensor_1 | 1 -> Aux_Vector | 0 -> Aux_Scalar | _ -> invalid_arg ("SM.prop_aux: wrong value") let propagator = function | M f -> begin match f with | L n -> prop_spinor n | N n -> prop_spinor n | U n -> prop_spinor n | D n -> prop_spinor n end | G f -> begin match f with | Ga | Gl -> Prop_Feynman | Wp | Wm | Z -> Prop_Unitarity end | O f -> begin match f with | Phip | Phim | Phi0 -> Only_Insertion | H -> Prop_Scalar | Aux_top (l,_,_,_,_) -> prop_aux l end (* Optionally, ask for the fudge factor treatment for the widths of charged particles. Currently, this only applies to $W^\pm$ and top. *) let width f = if !use_fudged_width then match f with | G Wp | G Wm | M (U 3) | M (U (-3)) -> Fudged | _ -> !default_width else !default_width let goldstone = function | G f -> begin match f with | Wp -> Some (O Phip, Coupling.Integer 1) | Wm -> Some (O Phim, Coupling.Integer 1) | Z -> Some (O Phi0, Coupling.Integer 1) | _ -> None end | _ -> None let conjugate = function | M f -> M (begin match f with | L n -> L (-n) | N n -> N (-n) | U n -> U (-n) | D n -> D (-n) end) | G f -> G (begin match f with | Gl -> Gl | Ga -> Ga | Z -> Z | Wp -> Wm | Wm -> Wp end) | O f -> O (begin match f with | Phip -> Phim | Phim -> Phip | Phi0 -> Phi0 | H -> H | Aux_top (l,co,ch,n,f) -> Aux_top (l,co,(-ch),(not n),f) end) let fermion = function | M f -> begin match f with | L n -> if n > 0 then 1 else -1 | N n -> if n > 0 then 1 else -1 | U n -> if n > 0 then 1 else -1 | D n -> if n > 0 then 1 else -1 end | G f -> begin match f with | Gl | Ga | Z | Wp | Wm -> 0 end | O _ -> 0 (* Electrical charge, lepton number, baryon number. We could avoid the rationals altogether by multiplying the first and last by 3 \ldots *) module Ch = Charges.QQ let ( // ) = Algebra.Small_Rational.make let generation' = function | 1 -> [ 1//1; 0//1; 0//1] | 2 -> [ 0//1; 1//1; 0//1] | 3 -> [ 0//1; 0//1; 1//1] | -1 -> [-1//1; 0//1; 0//1] | -2 -> [ 0//1; -1//1; 0//1] | -3 -> [ 0//1; 0//1; -1//1] | n -> invalid_arg ("SM.generation': " ^ string_of_int n) (* Generation is not a good quantum number for models with flavor mixing, i.e. if CKM mixing is present. Also, for the FCNC vertices implemented in the SM variant with anomalous top couplings it is not a valid symmetry. *) let generation f = if (Flags.ckm_present || Flags.top_anom) then [] else match f with | M (L n | N n | U n | D n) -> generation' n | G _ | O _ -> [0//1; 0//1; 0//1] let charge = function | M f -> begin match f with | L n -> if n > 0 then -1//1 else 1//1 | N n -> 0//1 | U n -> if n > 0 then 2//3 else -2//3 | D n -> if n > 0 then -1//3 else 1//3 end | G f -> begin match f with | Gl | Ga | Z -> 0//1 | Wp -> 1//1 | Wm -> -1//1 end | O f -> begin match f with | H | Phi0 -> 0//1 | Phip -> 1//1 | Phim -> -1//1 | Aux_top (_,_,ch,_,_) -> ch//1 end let lepton = function | M f -> begin match f with | L n | N n -> if n > 0 then 1//1 else -1//1 | U _ | D _ -> 0//1 end | G _ | O _ -> 0//1 let baryon = function | M f -> begin match f with | L _ | N _ -> 0//1 | U n | D n -> if n > 0 then 1//1 else -1//1 end | G _ | O _ -> 0//1 let charges f = [ charge f; lepton f; baryon f] @ generation f type constant = | Unit | Half | Pi | Alpha_QED | Sin2thw | Sinthw | Costhw | E | G_weak | I_G_weak | Vev | Q_lepton | Q_up | Q_down | G_CC | G_CCQ of int*int | G_NC_neutrino | G_NC_lepton | G_NC_up | G_NC_down | G_TVA_ttA | G_TVA_bbA | G_TVA_tuA | G_TVA_tcA | G_TVA_tcZ | G_TVA_tuZ | G_TVA_bbZ | G_VLR_ttZ | G_TVA_ttZ | G_VLR_tcZ | G_VLR_tuZ | VA_ILC_ttA | VA_ILC_ttZ | G_VLR_btW | G_VLR_tbW | G_TLR_btW | G_TRL_tbW | G_TLR_btWZ | G_TRL_tbWZ | G_TLR_btWA | G_TRL_tbWA | G_TVA_ttWW | G_TVA_bbWW | G_TVA_ttG | G_TVA_ttGG | G_TVA_tcG | G_TVA_tcGG | G_TVA_tuG | G_TVA_tuGG | G_SP_ttH | G_VLR_qGuG | G_VLR_qBuB | G_VLR_qBuB_u | G_VLR_qBuB_d | G_VLR_qBuB_e | G_VL_qBuB_n | G_VL_qW | G_VL_qW_u | G_VL_qW_d | G_SL_DttR | G_SR_DttR | G_SL_DttL | G_SLR_DbtR | G_SL_DbtL | C_quqd1R_bt | C_quqd1R_tb | C_quqd1L_bt | C_quqd1L_tb | C_quqd8R_bt | C_quqd8R_tb | C_quqd8L_bt | C_quqd8L_tb | I_Q_W | I_G_ZWW | G_WWWW | G_ZZWW | G_AZWW | G_AAWW | I_G1_AWW | I_G1_ZWW | I_G1_plus_kappa_plus_G4_AWW | I_G1_plus_kappa_plus_G4_ZWW | I_G1_plus_kappa_minus_G4_AWW | I_G1_plus_kappa_minus_G4_ZWW | I_G1_minus_kappa_plus_G4_AWW | I_G1_minus_kappa_plus_G4_ZWW | I_G1_minus_kappa_minus_G4_AWW | I_G1_minus_kappa_minus_G4_ZWW | I_lambda_AWW | I_lambda_ZWW | G5_AWW | G5_ZWW | I_kappa5_AWW | I_kappa5_ZWW | I_lambda5_AWW | I_lambda5_ZWW | Alpha_WWWW0 | Alpha_ZZWW1 | Alpha_WWWW2 | Alpha_ZZWW0 | Alpha_ZZZZ | D_Alpha_ZZWW0_S | D_Alpha_ZZWW0_T | D_Alpha_ZZWW1_S | D_Alpha_ZZWW1_T | D_Alpha_ZZWW1_U | D_Alpha_WWWW0_S | D_Alpha_WWWW0_T | D_Alpha_WWWW0_U | D_Alpha_WWWW2_S | D_Alpha_WWWW2_T | D_Alpha_ZZZZ_S | D_Alpha_ZZZZ_T | G_HWW | G_HHWW | G_HZZ | G_HHZZ | G_Htt | G_Hbb | G_Hcc | G_Hss | G_Hmm | G_Hee | G_Htautau | G_H3 | G_H4 | G_HGaZ | G_HGaGa | G_Hgg | G_HGaZ_anom | G_HGaGa_anom | G_HZZ_anom | G_HWW_anom | G_HGaZ_u | G_HZZ_u | G_HWW_u | Gs | I_Gs | G2 | Mass of flavor | Width of flavor | K_Matrix_Coeff of int | K_Matrix_Pole of int | I_Dim6_AWW_Gauge | I_Dim6_AWW_GGG | I_Dim6_AWW_DP | I_Dim6_AWW_DW | I_Dim6_WWZ_W | I_Dim6_WWZ_DPWDW | I_Dim6_WWZ_DW | I_Dim6_WWZ_D (*i | I_Dim6_GGG_G | I_Dim6_GGG_CG i*) | G_HZZ6_V3 | G_HZZ6_D | G_HZZ6_DP | G_HZZ6_PB | G_HWW_6_D | G_HWW_6_DP | G_HGaZ6_D | G_HGaZ6_DP | G_HGaZ6_PB | G_HGaGa6 | Dim6_vev3 | Dim6_Cphi | Anom_Dim6_AAWW_DW | Anom_Dim6_AAWW_W | Anom_Dim6_H4_v2 | Anom_Dim6_H4_P2 | Anom_Dim6_AHWW_DPB | Anom_Dim6_AHWW_DPW | Anom_Dim6_AHWW_DW | Anom_Dim6_HHWW_DW | Anom_Dim6_HHWW_DPW | Anom_Dim6_HWWZ_DW | Anom_Dim6_HWWZ_DDPW | Anom_Dim6_HWWZ_DPW | Anom_Dim6_HWWZ_DPB | Anom_Dim6_AHHZ_D | Anom_Dim6_AHHZ_DP | Anom_Dim6_AHHZ_PB | Anom_Dim6_AZWW_W | Anom_Dim6_AZWW_DWDPW | Anom_Dim6_WWWW_W | Anom_Dim6_WWWW_DWDPW | Anom_Dim6_WWZZ_W | Anom_Dim6_WWZZ_DWDPW | Anom_Dim6_HHAA | Anom_Dim6_HHZZ_D | Anom_Dim6_HHZZ_DP | Anom_Dim6_HHZZ_PB | Anom_Dim6_HHZZ_T (* Two integer counters for the QCD and EW order of the couplings. *) type orders = int * int let orders = function | Q_lepton | Q_up | Q_down | G_NC_lepton | G_NC_neutrino | G_NC_up | G_NC_down | G_CC | G_CCQ _ | G_Htt | G_H3 | G_Hbb | G_Hcc | G_Hss | G_Htautau | G_Hmm | G_Hee | I_Q_W | I_G_ZWW | I_G1_AWW | I_G1_ZWW | I_G_weak | G_HWW | G_HZZ | G_HWW_u | G_HZZ_u | G_HGaZ_u | G_HWW_anom | G_HZZ_anom | G_HGaZ | G_HGaGa | G_HGaZ_anom | G_HGaGa_anom | Half | Unit | I_G1_plus_kappa_plus_G4_AWW | I_G1_plus_kappa_plus_G4_ZWW | I_G1_minus_kappa_plus_G4_AWW | I_G1_minus_kappa_plus_G4_ZWW | I_G1_plus_kappa_minus_G4_AWW | I_G1_plus_kappa_minus_G4_ZWW | I_G1_minus_kappa_minus_G4_AWW | I_G1_minus_kappa_minus_G4_ZWW | I_kappa5_AWW | I_kappa5_ZWW | G5_AWW | G5_ZWW | I_lambda_AWW | I_lambda_ZWW | I_lambda5_AWW | I_lambda5_ZWW | G_TVA_ttA | G_TVA_bbA | G_TVA_tcA | G_TVA_tuA | G_VLR_ttZ | G_TVA_ttZ | G_VLR_tcZ | G_TVA_tcZ | G_TVA_bbZ | VA_ILC_ttA | VA_ILC_ttZ | G_VLR_tuZ | G_TVA_tuZ | G_VLR_btW | G_VLR_tbW | G_TLR_btW | G_TRL_tbW | G_TLR_btWA | G_TRL_tbWA | G_TLR_btWZ | G_TRL_tbWZ | G_VLR_qBuB | G_VLR_qBuB_u | G_VLR_qBuB_d | G_VLR_qBuB_e | G_VL_qBuB_n | G_VL_qW | G_VL_qW_u | G_VL_qW_d | G_SL_DttR | G_SR_DttR | G_SL_DttL | G_SLR_DbtR | G_SL_DbtL | G_HZZ6_V3 | G_HZZ6_D | G_HZZ6_DP | G_HZZ6_PB | G_HGaZ6_D | G_HGaZ6_DP | G_HGaZ6_PB | G_HWW_6_D | G_HWW_6_DP | G_HGaGa6 | I_Dim6_AWW_Gauge | I_Dim6_AWW_GGG | I_Dim6_AWW_DP | I_Dim6_AWW_DW | I_Dim6_WWZ_W | I_Dim6_WWZ_DPWDW | I_Dim6_WWZ_DW | I_Dim6_WWZ_D (*i | I_Dim6_GGG_G | I_Dim6_GGG_CG i*) | Dim6_vev3 | Dim6_Cphi | Anom_Dim6_H4_v2 | Anom_Dim6_H4_P2 | Anom_Dim6_AAWW_DW | Anom_Dim6_AAWW_W | Anom_Dim6_AHWW_DPB | Anom_Dim6_AHWW_DPW | Anom_Dim6_AHWW_DW | Anom_Dim6_HHWW_DW | Anom_Dim6_HHWW_DPW | Anom_Dim6_HWWZ_DW | Anom_Dim6_HWWZ_DDPW | Anom_Dim6_HWWZ_DPW | Anom_Dim6_HWWZ_DPB | Anom_Dim6_AHHZ_D | Anom_Dim6_AHHZ_DP | Anom_Dim6_AHHZ_PB | Anom_Dim6_AZWW_W | Anom_Dim6_AZWW_DWDPW | Anom_Dim6_WWWW_W | Anom_Dim6_WWWW_DWDPW | Anom_Dim6_WWZZ_W | Anom_Dim6_WWZZ_DWDPW | Anom_Dim6_HHAA | Anom_Dim6_HHZZ_D | Anom_Dim6_HHZZ_DP | Anom_Dim6_HHZZ_PB | Anom_Dim6_HHZZ_T | G_TVA_ttWW | G_TVA_bbWW | G_SP_ttH -> (0,1) | G_HHWW | G_HHZZ | G_H4 | G_WWWW | G_ZZWW | G_AZWW | G_AAWW | Alpha_WWWW0 | Alpha_WWWW2 | Alpha_ZZWW0 | Alpha_ZZWW1 | Alpha_ZZZZ | D_Alpha_WWWW0_S | D_Alpha_WWWW0_T | D_Alpha_WWWW0_U | D_Alpha_WWWW2_S | D_Alpha_WWWW2_T | D_Alpha_ZZWW0_S | D_Alpha_ZZWW0_T | D_Alpha_ZZWW1_S | D_Alpha_ZZWW1_T | D_Alpha_ZZWW1_U | D_Alpha_ZZZZ_S | D_Alpha_ZZZZ_T -> (0,2) | Gs | I_Gs | G_TVA_ttG | G_TVA_ttGG | G_TVA_tcG | G_TVA_tcGG | G_TVA_tuG | G_TVA_tuGG | G_VLR_qGuG | C_quqd1R_bt | C_quqd1R_tb | C_quqd1L_bt | C_quqd1L_tb | C_quqd8R_bt | C_quqd8R_tb | C_quqd8L_bt | C_quqd8L_tb -> (1,0) | G2 | G_Hgg -> (2,0) (* These constants are not used, hence initialized to zero. *) | Sinthw | Sin2thw | Costhw | Pi | Alpha_QED | G_weak | K_Matrix_Coeff _ | K_Matrix_Pole _ | Mass _ | Width _ | Vev | E -> (0,0) (* \begin{dubious} The current abstract syntax for parameter dependencies is admittedly tedious. Later, there will be a parser for a convenient concrete syntax as a part of a concrete syntax for models. But as these examples show, it should include simple functions. \end{dubious} *) (* \begin{subequations} \begin{align} \alpha_{\text{QED}} &= \frac{1}{137.0359895} \\ \sin^2\theta_w &= 0.23124 \end{align} \end{subequations} *) let input_parameters = [ Alpha_QED, 1. /. 137.0359895; Sin2thw, 0.23124; Mass (G Z), 91.187; Mass (M (N 1)), 0.0; Mass (M (L 1)), 0.51099907e-3; Mass (M (N 2)), 0.0; Mass (M (L 2)), 0.105658389; Mass (M (N 3)), 0.0; Mass (M (L 3)), 1.77705; Mass (M (U 1)), 5.0e-3; Mass (M (D 1)), 3.0e-3; Mass (M (U 2)), 1.2; Mass (M (D 2)), 0.1; Mass (M (U 3)), 174.0; Mass (M (D 3)), 4.2 ] (* \begin{subequations} \begin{align} e &= \sqrt{4\pi\alpha} \\ \sin\theta_w &= \sqrt{\sin^2\theta_w} \\ \cos\theta_w &= \sqrt{1-\sin^2\theta_w} \\ g &= \frac{e}{\sin\theta_w} \\ m_W &= \cos\theta_w m_Z \\ v &= \frac{2m_W}{g} \\ g_{CC} = -\frac{g}{2\sqrt2} &= -\frac{e}{2\sqrt2\sin\theta_w} \\ Q_{\text{lepton}} = -q_{\text{lepton}}e &= e \\ Q_{\text{up}} = -q_{\text{up}}e &= -\frac{2}{3}e \\ Q_{\text{down}} = -q_{\text{down}}e &= \frac{1}{3}e \\ \ii q_We = \ii g_{\gamma WW} &= \ii e \\ \ii g_{ZWW} &= \ii g \cos\theta_w \\ \ii g_{WWW} &= \ii g \end{align} \end{subequations} *) (* \begin{dubious} \ldots{} to be continued \ldots{} The quartic couplings can't be correct, because the dimensions are wrong! \begin{subequations} \begin{align} g_{HWW} &= g m_W = 2 \frac{m_W^2}{v}\\ g_{HHWW} &= 2 \frac{m_W^2}{v^2} = \frac{g^2}{2} \\ g_{HZZ} &= \frac{g}{\cos\theta_w}m_Z \\ g_{HHZZ} &= 2 \frac{m_Z^2}{v^2} = \frac{g^2}{2\cos\theta_w} \\ g_{Htt} &= \lambda_t \\ g_{Hbb} &= \lambda_b=\frac{m_b}{m_t}\lambda_t \\ g_{H^3} &= - \frac{3g}{2}\frac{m_H^2}{m_W} = - 3 \frac{m_H^2}{v} g_{H^4} &= - \frac{3g^2}{4} \frac{m_W^2}{v^2} = -3 \frac{m_H^2}{v^2} \end{align} \end{subequations} \end{dubious} *) let derived_parameters = [ Real E, Sqrt (Prod [Integer 4; Atom Pi; Atom Alpha_QED]); Real Sinthw, Sqrt (Atom Sin2thw); Real Costhw, Sqrt (Diff (Integer 1, Atom Sin2thw)); Real G_weak, Quot (Atom E, Atom Sinthw); Real (Mass (G Wp)), Prod [Atom Costhw; Atom (Mass (G Z))]; Real Vev, Quot (Prod [Integer 2; Atom (Mass (G Wp))], Atom G_weak); Real Q_lepton, Atom E; Real Q_up, Prod [Quot (Integer (-2), Integer 3); Atom E]; Real Q_down, Prod [Quot (Integer 1, Integer 3); Atom E]; Real G_CC, Neg (Quot (Atom G_weak, Prod [Integer 2; Sqrt (Integer 2)])); Complex I_Q_W, Prod [I; Atom E]; Complex I_G_weak, Prod [I; Atom G_weak]; Complex I_G_ZWW, Prod [I; Atom G_weak; Atom Costhw] ] (* \begin{equation} - \frac{g}{2\cos\theta_w} \end{equation} *) let g_over_2_costh = Quot (Neg (Atom G_weak), Prod [Integer 2; Atom Costhw]) (* \begin{subequations} \begin{align} - \frac{g}{2\cos\theta_w} g_V &= - \frac{g}{2\cos\theta_w} (T_3 - 2 q \sin^2\theta_w) \\ - \frac{g}{2\cos\theta_w} g_A &= - \frac{g}{2\cos\theta_w} T_3 \end{align} \end{subequations} *) let nc_coupling c t3 q = (Real_Array c, [Prod [g_over_2_costh; Diff (t3, Prod [Integer 2; q; Atom Sin2thw])]; Prod [g_over_2_costh; t3]]) let half = Quot (Integer 1, Integer 2) let derived_parameter_arrays = [ nc_coupling G_NC_neutrino half (Integer 0); nc_coupling G_NC_lepton (Neg half) (Integer (-1)); nc_coupling G_NC_up half (Quot (Integer 2, Integer 3)); nc_coupling G_NC_down (Neg half) (Quot (Integer (-1), Integer 3)) ] let parameters () = { input = input_parameters; derived = derived_parameters; derived_arrays = derived_parameter_arrays } module F = Modeltools.Fusions (struct type f = flavor type c = constant let compare = compare let conjugate = conjugate end) (* \begin{equation} \mathcal{L}_{\textrm{EM}} = - e \sum_i q_i \bar\psi_i\fmslash{A}\psi_i \end{equation} *) let mgm ((m1, g, m2), fbf, c) = ((M m1, G g, M m2), fbf, c) let mom ((m1, o, m2), fbf, c) = ((M m1, O o, M m2), fbf, c) let electromagnetic_currents n = List.map mgm [ ((L (-n), Ga, L n), FBF (1, Psibar, V, Psi), Q_lepton); ((U (-n), Ga, U n), FBF (1, Psibar, V, Psi), Q_up); ((D (-n), Ga, D n), FBF (1, Psibar, V, Psi), Q_down) ] let color_currents n = List.map mgm [ ((U (-n), Gl, U n), FBF ((-1), Psibar, V, Psi), Gs); ((D (-n), Gl, D n), FBF ((-1), Psibar, V, Psi), Gs) ] (* \begin{equation} \mathcal{L}_{\textrm{NC}} = - \frac{g}{2\cos\theta_W} \sum_i \bar\psi_i\fmslash{Z}(g_V^i-g_A^i\gamma_5)\psi_i \end{equation} *) let neutral_currents n = List.map mgm [ ((L (-n), Z, L n), FBF (1, Psibar, VA, Psi), G_NC_lepton); ((N (-n), Z, N n), FBF (1, Psibar, VA, Psi), G_NC_neutrino); ((U (-n), Z, U n), FBF (1, Psibar, VA, Psi), G_NC_up); ((D (-n), Z, D n), FBF (1, Psibar, VA, Psi), G_NC_down) ] (* \begin{equation} \mathcal{L}_{\textrm{CC}} = - \frac{g}{2\sqrt2} \sum_i \bar\psi_i (T^+\fmslash{W}^+ + T^-\fmslash{W}^-)(1-\gamma_5)\psi_i \end{equation} *) let charged_currents' n = List.map mgm [ ((L (-n), Wm, N n), FBF (1, Psibar, VL, Psi), G_CC); ((N (-n), Wp, L n), FBF (1, Psibar, VL, Psi), G_CC) ] let charged_currents'' n = List.map mgm [ ((D (-n), Wm, U n), FBF (1, Psibar, VL, Psi), G_CC); ((U (-n), Wp, D n), FBF (1, Psibar, VL, Psi), G_CC) ] let charged_currents_triv = ThoList.flatmap charged_currents' [1;2;3] @ ThoList.flatmap charged_currents'' [1;2;3] let charged_currents_ckm = let charged_currents_2 n1 n2 = List.map mgm [ ((D (-n1), Wm, U n2), FBF (1, Psibar, VL, Psi), G_CCQ (n2,n1)); ((U (-n1), Wp, D n2), FBF (1, Psibar, VL, Psi), G_CCQ (n1,n2)) ] in ThoList.flatmap charged_currents' [1;2;3] @ List.flatten (Product.list2 charged_currents_2 [1;2;3] [1;2;3]) let yukawa = [ ((M (U (-3)), O H, M (U 3)), FBF (1, Psibar, S, Psi), G_Htt); ((M (D (-3)), O H, M (D 3)), FBF (1, Psibar, S, Psi), G_Hbb); ((M (U (-2)), O H, M (U 2)), FBF (1, Psibar, S, Psi), G_Hcc); ((M (L (-3)), O H, M (L 3)), FBF (1, Psibar, S, Psi), G_Htautau) ] @ if Flags.higgs_hmm then [ ((M (D (-2)), O H, M (D 2)), FBF (1, Psibar, S, Psi), G_Hss); ((M (L (-2)), O H, M (L 2)), FBF (1, Psibar, S, Psi), G_Hmm); ((M (L (-1)), O H, M (L 1)), FBF (1, Psibar, S, Psi), G_Hee) ] else [] (* \begin{equation} \mathcal{L}_{\textrm{TGC}} = - e \partial_\mu A_\nu W_+^\mu W_-^\nu + \ldots - e \cot\theta_w \partial_\mu Z_\nu W_+^\mu W_-^\nu + \ldots \end{equation} *) let tgc ((g1, g2, g3), t, c) = ((G g1, G g2, G g3), t, c) let standard_triple_gauge = List.map tgc [ ((Ga, Wm, Wp), Gauge_Gauge_Gauge 1, I_Q_W); ((Z, Wm, Wp), Gauge_Gauge_Gauge 1, I_G_ZWW); ((Gl, Gl, Gl), Gauge_Gauge_Gauge 1, I_Gs)] (* \begin{multline} \mathcal{L}_{\textrm{TGC}}(g_1,\kappa) = g_1 \mathcal{L}_T(V,W^+,W^-) \\ + \frac{\kappa+g_1}{2} \Bigl(\mathcal{L}_T(W^-,V,W^+) - \mathcal{L}_T(W^+,V,W^-)\Bigr)\\ + \frac{\kappa-g_1}{2} \Bigl(\mathcal{L}_L(W^-,V,W^+) - \mathcal{L}_T(W^+,V,W^-)\Bigr) \end{multline} *) (* \begin{dubious} The whole thing in the LEP2 workshop notation: \begin{multline} \ii\mathcal{L}_{\textrm{TGC},V} / g_{WWV} = \\ g_1^V V^\mu (W^-_{\mu\nu}W^{+,\nu}-W^+_{\mu\nu}W^{-,\nu}) + \kappa_V W^+_\mu W^-_\nu V^{\mu\nu} + \frac{\lambda_V}{m_W^2} V_{\mu\nu} W^-_{\rho\mu} W^{+,\hphantom{\nu}\rho}_{\hphantom{+,}\nu} \\ + \ii g_5^V \epsilon_{\mu\nu\rho\sigma} \left( (\partial^\rho W^{-,\mu}) W^{+,\nu} - W^{-,\mu}(\partial^\rho W^{+,\nu}) \right) V^\sigma \\ + \ii g_4^V W^-_\mu W^+_\nu (\partial^\mu V^\nu + \partial^\nu V^\mu) - \frac{\tilde\kappa_V}{2} W^-_\mu W^+_\nu \epsilon^{\mu\nu\rho\sigma} V_{\rho\sigma} - \frac{\tilde\lambda_V}{2m_W^2} W^-_{\rho\mu} W^{+,\mu}_{\hphantom{+,\mu}\nu} \epsilon^{\nu\rho\alpha\beta} V_{\alpha\beta} \end{multline} using the conventions of Itzykson and Zuber with $\epsilon^{0123} = +1$. \end{dubious} *) (* \begin{dubious} This is equivalent to the notation of Hagiwara et al.~\cite{HPZH87}, if we remember that they have opposite signs for~$g_{WWV}$: \begin{multline} \mathcal{L}_{WWV} / (-g_{WWV}) = \\ \ii g_1^V \left( W^\dagger_{\mu\nu} W^\mu - W^\dagger_\mu W^\mu_{\hphantom{\mu}\nu} \right) V^\nu + \ii \kappa_V W^\dagger_\mu W_\nu V^{\mu\nu} + \ii \frac{\lambda_V}{m_W^2} W^\dagger_{\lambda\mu} W^\mu_{\hphantom{\mu}\nu} V^{\nu\lambda} \\ - g_4^V W^\dagger_\mu W_\nu \left(\partial^\mu V^\nu + \partial^\nu V^\mu \right) + g_5^V \epsilon^{\mu\nu\lambda\sigma} \left( W^\dagger_\mu \stackrel{\leftrightarrow}{\partial_\lambda} W_\nu \right) V_\sigma\\ + \ii \tilde\kappa_V W^\dagger_\mu W_\nu \tilde{V}^{\mu\nu} + \ii\frac{\tilde\lambda_V}{m_W^2} W^\dagger_{\lambda\mu} W^\mu_{\hphantom{\mu}\nu} \tilde{V}^{\nu\lambda} \end{multline} Here $V^\mu$ stands for either the photon or the~$Z$ field, $W^\mu$ is the $W^-$ field, $W_{\mu\nu} = \partial_\mu W_\nu - \partial_\nu W_\mu$, $V_{\mu\nu} = \partial_\mu V_\nu - \partial_\nu V_\mu$, and $\tilde{V}_{\mu\nu} = \frac{1}{2} \epsilon_{\mu\nu\lambda\sigma} V^{\lambda\sigma}$. \end{dubious} *) let anomalous_triple_gauge = List.map tgc [ ((Ga, Wm, Wp), Dim4_Vector_Vector_Vector_T (-1), I_G1_AWW); ((Z, Wm, Wp), Dim4_Vector_Vector_Vector_T (-1), I_G1_ZWW); ((Wm, Ga, Wp), Dim4_Vector_Vector_Vector_T 1, I_G1_plus_kappa_minus_G4_AWW); ((Wm, Z, Wp), Dim4_Vector_Vector_Vector_T 1, I_G1_plus_kappa_minus_G4_ZWW); ((Wp, Ga, Wm), Dim4_Vector_Vector_Vector_T (-1), I_G1_plus_kappa_plus_G4_AWW); ((Wp, Z, Wm), Dim4_Vector_Vector_Vector_T (-1), I_G1_plus_kappa_plus_G4_ZWW); ((Wm, Ga, Wp), Dim4_Vector_Vector_Vector_L (-1), I_G1_minus_kappa_plus_G4_AWW); ((Wm, Z, Wp), Dim4_Vector_Vector_Vector_L (-1), I_G1_minus_kappa_plus_G4_ZWW); ((Wp, Ga, Wm), Dim4_Vector_Vector_Vector_L 1, I_G1_minus_kappa_minus_G4_AWW); ((Wp, Z, Wm), Dim4_Vector_Vector_Vector_L 1, I_G1_minus_kappa_minus_G4_ZWW); ((Ga, Wm, Wp), Dim4_Vector_Vector_Vector_L5 (-1), I_kappa5_AWW); ((Z, Wm, Wp), Dim4_Vector_Vector_Vector_L5 (-1), I_kappa5_ZWW); ((Ga, Wm, Wp), Dim4_Vector_Vector_Vector_T5 (-1), G5_AWW); ((Z, Wm, Wp), Dim4_Vector_Vector_Vector_T5 (-1), G5_ZWW); ((Ga, Wp, Wm), Dim6_Gauge_Gauge_Gauge (-1), I_lambda_AWW); ((Z, Wp, Wm), Dim6_Gauge_Gauge_Gauge (-1), I_lambda_ZWW); ((Ga, Wp, Wm), Dim6_Gauge_Gauge_Gauge_5 (-1), I_lambda5_AWW); ((Z, Wp, Wm), Dim6_Gauge_Gauge_Gauge_5 (-1), I_lambda5_ZWW) ] let anomalous_dim6_triple_gauge = List.map tgc [ ((Ga, Wm, Wp), Dim6_Gauge_Gauge_Gauge_i 1, I_Dim6_AWW_GGG); ((Ga, Wm, Wp), Dim6_AWW_DP 1, I_Dim6_AWW_DP); ((Ga, Wm, Wp), Dim6_AWW_DW 1, I_Dim6_AWW_DW); ((Wm, Wp, Z), Dim6_Gauge_Gauge_Gauge_i 1, I_Dim6_WWZ_W); ((Wm, Wp, Z), Dim6_WWZ_DPWDW 1, I_Dim6_WWZ_DPWDW); ((Wm, Wp, Z), Dim6_WWZ_DW 1, I_Dim6_WWZ_DW); ((Wm, Wp, Z), Dim6_WWZ_D 1, I_Dim6_WWZ_D)(*i ; ((G, G, G), Dim6_Glu_Glu_Glu 1, I_Dim6_GGG_G); ((G, G, G), Gauge_Gauge_Gauge_I 1, I_Dim6_GGG_CG) i*) ] let triple_gauge = if Flags.triple_anom then anomalous_triple_gauge else if Flags.dim6 then standard_triple_gauge @ anomalous_dim6_triple_gauge else standard_triple_gauge (* \begin{equation} \mathcal{L}_{\textrm{QGC}} = - g^2 W_{+,\mu} W_{-,\nu} W_+^\mu W_-^\nu + \ldots \end{equation} *) (* Actually, quartic gauge couplings are a little bit more straightforward using auxiliary fields. Here we have to impose the antisymmetry manually: \begin{subequations} \begin{multline} (W^{+,\mu}_1 W^{-,\nu}_2 - W^{+,\nu}_1 W^{-,\mu}_2) (W^+_{3,\mu} W^-_{4,\nu} - W^+_{3,\nu} W^-_{4,\mu}) \\ = 2(W^+_1W^+_3)(W^-_2W^-_4) - 2(W^+_1W^-_4)(W^-_2W^+_3) \end{multline} also ($V$ can be $A$ or $Z$) \begin{multline} (W^{+,\mu}_1 V^\nu_2 - W^{+,\nu}_1 V^\mu_2) (W^-_{3,\mu} V_{4,\nu} - W^-_{3,\nu} V_{4,\mu}) \\ = 2(W^+_1W^-_3)(V_2V_4) - 2(W^+_1V_4)(V_2W^-_3) \end{multline} \end{subequations} *) (* \begin{subequations} \begin{multline} W^{+,\mu} W^{-,\nu} W^+_\mu W^-_\nu \end{multline} \end{subequations} *) let qgc ((g1, g2, g3, g4), t, c) = ((G g1, G g2, G g3, G g4), t, c) let gauge4 = Vector4 [(2, C_13_42); (-1, C_12_34); (-1, C_14_23)] let minus_gauge4 = Vector4 [(-2, C_13_42); (1, C_12_34); (1, C_14_23)] let standard_quartic_gauge = List.map qgc [ (Wm, Wp, Wm, Wp), gauge4, G_WWWW; (Wm, Z, Wp, Z), minus_gauge4, G_ZZWW; (Wm, Z, Wp, Ga), minus_gauge4, G_AZWW; (Wm, Ga, Wp, Ga), minus_gauge4, G_AAWW; (Gl, Gl, Gl, Gl), gauge4, G2 ] (* \begin{subequations} \begin{align} \mathcal{L}_4 &= \alpha_4 \left( \frac{g^4}{2}\left( (W^+_\mu W^{-,\mu})^2 + W^+_\mu W^{+,\mu} W^-_\mu W^{-,\mu} \right)\right.\notag \\ &\qquad\qquad\qquad \left. + \frac{g^4}{\cos^2\theta_w} W^+_\mu Z^\mu W^-_\nu Z^\nu + \frac{g^4}{4\cos^4\theta_w} (Z_\mu Z^\mu)^2 \right) \\ \mathcal{L}_5 &= \alpha_5 \left( g^4 (W^+_\mu W^{-,\mu})^2 + \frac{g^4}{\cos^2\theta_w} W^+_\mu W^{-,\mu} Z_\nu Z^\nu + \frac{g^4}{4\cos^4\theta_w} (Z_\mu Z^\mu)^2 \right) \end{align} \end{subequations} or \begin{multline} \mathcal{L}_4 + \mathcal{L}_5 = (\alpha_4+2\alpha_5) g^4 \frac{1}{2} (W^+_\mu W^{-,\mu})^2 \\ + 2\alpha_4 g^4 \frac{1}{4} W^+_\mu W^{+,\mu} W^-_\mu W^{-,\mu} + \alpha_4 \frac{g^4}{\cos^2\theta_w} W^+_\mu Z^\mu W^-_\nu Z^\nu \\ + 2\alpha_5 \frac{g^4}{\cos^2\theta_w} \frac{1}{2} W^+_\mu W^{-,\mu} Z_\nu Z^\nu + (2\alpha_4 + 2\alpha_5) \frac{g^4}{\cos^4\theta_w} \frac{1}{8} (Z_\mu Z^\mu)^2 \end{multline} and therefore \begin{subequations} \begin{align} \alpha_{(WW)_0} &= (\alpha_4+2\alpha_5) g^4 \\ \alpha_{(WW)_2} &= 2\alpha_4 g^4 \\ \alpha_{(WZ)_0} &= 2\alpha_5 \frac{g^4}{\cos^2\theta_w} \\ \alpha_{(WZ)_1} &= \alpha_4 \frac{g^4}{\cos^2\theta_w} \\ \alpha_{ZZ} &= (2\alpha_4 + 2\alpha_5) \frac{g^4}{\cos^4\theta_w} \end{align} \end{subequations} *) let anomalous_quartic_gauge = if Flags.quartic_anom then List.map qgc [ ((Wm, Wm, Wp, Wp), Vector4 [(1, C_13_42); (1, C_14_23)], Alpha_WWWW0); ((Wm, Wm, Wp, Wp), Vector4 [1, C_12_34], Alpha_WWWW2); ((Wm, Wp, Z, Z), Vector4 [1, C_12_34], Alpha_ZZWW0); ((Wm, Wp, Z, Z), Vector4 [(1, C_13_42); (1, C_14_23)], Alpha_ZZWW1); ((Z, Z, Z, Z), Vector4 [(1, C_12_34); (1, C_13_42); (1, C_14_23)], Alpha_ZZZZ) ] else [] let anomalous_dim6_quartic_gauge = if Flags.dim6 then List.map qgc [ ((Ga, Ga, Wm, Wp), Dim6_Vector4_DW 1, Anom_Dim6_AAWW_DW); ((Ga, Ga, Wm, Wp), Dim6_Vector4_W 1, Anom_Dim6_AAWW_W); ((Ga, Z, Wm, Wp), Dim6_Vector4_W 1, Anom_Dim6_AZWW_W); ((Ga, Z, Wm, Wp), Dim6_Vector4_DW 1, Anom_Dim6_AZWW_DWDPW); ((Wm, Wp, Wm, Wp), Dim6_Vector4_W 1, Anom_Dim6_WWWW_W); ((Wm, Wp, Wm, Wp), Dim6_Vector4_DW 1, Anom_Dim6_WWWW_DWDPW); ((Z, Z, Wm, Wp), Dim6_Vector4_W 1, Anom_Dim6_WWZZ_W); ((Z, Z, Wm, Wp), Dim6_Vector4_DW 1, Anom_Dim6_WWZZ_DWDPW) ] else [] (* In any diagonal channel~$\chi$, the scattering amplitude~$a_\chi(s)$ is unitary iff\footnote{% Trivial proof: \begin{equation} -1 = \textrm{Im}\left(\frac{1}{a_\chi(s)}\right) = \frac{\textrm{Im}(a_\chi^*(s))}{ |a_\chi(s)|^2 } = - \frac{\textrm{Im}(a_\chi(s))}{ |a_\chi(s)|^2 } \end{equation} i.\,e.~$\textrm{Im}(a_\chi(s)) = |a_\chi(s)|^2$.} \begin{equation} \textrm{Im}\left(\frac{1}{a_\chi(s)}\right) = -1 \end{equation} For a real perturbative scattering amplitude~$r_\chi(s)$ this can be enforced easily--and arbitrarily--by \begin{equation} \frac{1}{a_\chi(s)} = \frac{1}{r_\chi(s)} - \mathrm{i} \end{equation} *) let k_matrix_quartic_gauge = if Flags.k_matrix then List.map qgc [ ((Wm, Wp, Wm, Wp), Vector4_K_Matrix_jr (0, [(1, C_12_34)]), D_Alpha_WWWW0_S); ((Wm, Wp, Wm, Wp), Vector4_K_Matrix_jr (0, [(1, C_14_23)]), D_Alpha_WWWW0_T); ((Wm, Wp, Wm, Wp), Vector4_K_Matrix_jr (0, [(1, C_13_42)]), D_Alpha_WWWW0_U); ((Wp, Wm, Wp, Wm), Vector4_K_Matrix_jr (0, [(1, C_12_34)]), D_Alpha_WWWW0_S); ((Wp, Wm, Wp, Wm), Vector4_K_Matrix_jr (0, [(1, C_14_23)]), D_Alpha_WWWW0_T); ((Wp, Wm, Wp, Wm), Vector4_K_Matrix_jr (0, [(1, C_13_42)]), D_Alpha_WWWW0_U); ((Wm, Wm, Wp, Wp), Vector4_K_Matrix_jr (0, [(1, C_12_34)]), D_Alpha_WWWW2_S); ((Wm, Wm, Wp, Wp), Vector4_K_Matrix_jr (0, [(1, C_13_42); (1, C_14_23)]), D_Alpha_WWWW2_T); ((Wm, Wp, Z, Z), Vector4_K_Matrix_jr (0, [(1, C_12_34)]), D_Alpha_ZZWW0_S); ((Wm, Wp, Z, Z), Vector4_K_Matrix_jr (0, [(1, C_13_42); (1, C_14_23)]), D_Alpha_ZZWW0_T); ((Wm, Z, Wp, Z), Vector4_K_Matrix_jr (0, [(1, C_12_34)]), D_Alpha_ZZWW1_S); ((Wm, Z, Wp, Z), Vector4_K_Matrix_jr (0, [(1, C_13_42)]), D_Alpha_ZZWW1_T); ((Wm, Z, Wp, Z), Vector4_K_Matrix_jr (0, [(1, C_14_23)]), D_Alpha_ZZWW1_U); ((Wp, Z, Z, Wm), Vector4_K_Matrix_jr (1, [(1, C_12_34)]), D_Alpha_ZZWW1_S); ((Wp, Z, Z, Wm), Vector4_K_Matrix_jr (1, [(1, C_13_42)]), D_Alpha_ZZWW1_U); ((Wp, Z, Z, Wm), Vector4_K_Matrix_jr (1, [(1, C_14_23)]), D_Alpha_ZZWW1_T); ((Z, Wp, Wm, Z), Vector4_K_Matrix_jr (2, [(1, C_12_34)]), D_Alpha_ZZWW1_S); ((Z, Wp, Wm, Z), Vector4_K_Matrix_jr (2, [(1, C_13_42)]), D_Alpha_ZZWW1_U); ((Z, Wp, Wm, Z), Vector4_K_Matrix_jr (2, [(1, C_14_23)]), D_Alpha_ZZWW1_T); ((Z, Z, Z, Z), Vector4_K_Matrix_jr (0, [(1, C_12_34)]), D_Alpha_ZZZZ_S); ((Z, Z, Z, Z), Vector4_K_Matrix_jr (0, [(1, C_13_42); (1, C_14_23)]), D_Alpha_ZZZZ_T); ((Z, Z, Z, Z), Vector4_K_Matrix_jr (3, [(1, C_14_23)]), D_Alpha_ZZZZ_S); ((Z, Z, Z, Z), Vector4_K_Matrix_jr (3, [(1, C_13_42); (1, C_12_34)]), D_Alpha_ZZZZ_T)] else [] (*i Thorsten's original implementation of the K matrix, which we keep since it still might be usefull for the future. let k_matrix_quartic_gauge = if Flags.k_matrix then List.map qgc [ ((Wm, Wp, Wm, Wp), Vector4_K_Matrix_tho (0, [K_Matrix_Coeff 0, K_Matrix_Pole 0]), Alpha_WWWW0); ((Wm, Wm, Wp, Wp), Vector4_K_Matrix_tho (0, [K_Matrix_Coeff 2, K_Matrix_Pole 2]), Alpha_WWWW2); ((Wm, Wp, Z, Z), Vector4_K_Matrix_tho (0, [(K_Matrix_Coeff 0, K_Matrix_Pole 0); (K_Matrix_Coeff 2, K_Matrix_Pole 2)]), Alpha_ZZWW0); ((Wm, Z, Wp, Z), Vector4_K_Matrix_tho (0, [K_Matrix_Coeff 1, K_Matrix_Pole 1]), Alpha_ZZWW1); ((Z, Z, Z, Z), Vector4_K_Matrix_tho (0, [K_Matrix_Coeff 0, K_Matrix_Pole 0]), Alpha_ZZZZ) ] else [] i*) let quartic_gauge = standard_quartic_gauge @ anomalous_quartic_gauge @ anomalous_dim6_quartic_gauge @ k_matrix_quartic_gauge let standard_gauge_higgs = [ ((O H, G Wp, G Wm), Scalar_Vector_Vector 1, G_HWW); ((O H, G Z, G Z), Scalar_Vector_Vector 1, G_HZZ) ] let standard_gauge_higgs4 = [ (O H, O H, G Wp, G Wm), Scalar2_Vector2 1, G_HHWW; (O H, O H, G Z, G Z), Scalar2_Vector2 1, G_HHZZ ] let standard_higgs = [ (O H, O H, O H), Scalar_Scalar_Scalar 1, G_H3 ] let standard_higgs4 = [ (O H, O H, O H, O H), Scalar4 1, G_H4 ] (* WK's couplings (apparently, he still intends to divide by $\Lambda^2_{\text{EWSB}}=16\pi^2v_{\mathrm{F}}^2$): \begin{subequations} \begin{align} \mathcal{L}^{\tau}_4 &= \left\lbrack (\partial_{\mu}H)(\partial^{\mu}H) + \frac{g^2v_{\mathrm{F}}^2}{4} V_{\mu} V^{\mu} \right\rbrack^2 \\ \mathcal{L}^{\tau}_5 &= \left\lbrack (\partial_{\mu}H)(\partial_{\nu}H) + \frac{g^2v_{\mathrm{F}}^2}{4} V_{\mu} V_{\nu} \right\rbrack^2 \end{align} \end{subequations} with \begin{equation} V_{\mu} V_{\nu} = \frac{1}{2} \left( W^+_{\mu} W^-_{\nu} + W^+_{\nu} W^-_{\mu} \right) + \frac{1}{2\cos^2\theta_{w}} Z_{\mu} Z_{\nu} \end{equation} (note the symmetrization!), i.\,e. \begin{subequations} \begin{align} \mathcal{L}_4 &= \alpha_4 \frac{g^4v_{\mathrm{F}}^4}{16} (V_{\mu} V_{\nu})^2 \\ \mathcal{L}_5 &= \alpha_5 \frac{g^4v_{\mathrm{F}}^4}{16} (V_{\mu} V^{\mu})^2 \end{align} \end{subequations} *) (* Breaking thinks up \begin{subequations} \begin{align} \mathcal{L}^{\tau,H^4}_4 &= \left\lbrack (\partial_{\mu}H)(\partial^{\mu}H) \right\rbrack^2 \\ \mathcal{L}^{\tau,H^4}_5 &= \left\lbrack (\partial_{\mu}H)(\partial^{\mu}H) \right\rbrack^2 \end{align} \end{subequations} and \begin{subequations} \begin{align} \mathcal{L}^{\tau,H^2V^2}_4 &= \frac{g^2v_{\mathrm{F}}^2}{2} (\partial_{\mu}H)(\partial^{\mu}H) V_{\mu}V^{\mu} \\ \mathcal{L}^{\tau,H^2V^2}_5 &= \frac{g^2v_{\mathrm{F}}^2}{2} (\partial_{\mu}H)(\partial_{\nu}H) V_{\mu}V_{\nu} \end{align} \end{subequations} i.\,e. \begin{subequations} \begin{align} \mathcal{L}^{\tau,H^2V^2}_4 &= \frac{g^2v_{\mathrm{F}}^2}{2} \left\lbrack (\partial_{\mu}H)(\partial^{\mu}H) W^+_{\nu}W^{-,\nu} + \frac{1}{2\cos^2\theta_{w}} (\partial_{\mu}H)(\partial^{\mu}H) Z_{\nu} Z^{\nu} \right\rbrack \\ \mathcal{L}^{\tau,H^2V^2}_5 &= \frac{g^2v_{\mathrm{F}}^2}{2} \left\lbrack (W^{+,\mu}\partial_{\mu}H) (W^{-,\nu}\partial_{\nu}H) + \frac{1}{2\cos^2\theta_{w}} (Z^{\mu}\partial_{\mu}H)(Z^{\nu}\partial_{\nu}H) \right\rbrack \end{align} \end{subequations} *) (* \begin{multline} \tau^4_8 \mathcal{L}^{\tau,H^2V^2}_4 + \tau^5_8 \mathcal{L}^{\tau,H^2V^2}_5 = \\ - \frac{g^2v_{\mathrm{F}}^2}{2} \Biggl\lbrack 2\tau^4_8 \frac{1}{2}(\ii\partial_{\mu}H)(\ii\partial^{\mu}H) W^+_{\nu}W^{-,\nu} + \tau^5_8 (W^{+,\mu}\ii\partial_{\mu}H) (W^{-,\nu}\ii\partial_{\nu}H) \\ + \frac{2\tau^4_8}{\cos^2\theta_{w}} \frac{1}{4} (\ii\partial_{\mu}H)(\ii\partial^{\mu}H) Z_{\nu} Z^{\nu} + \frac{\tau^5_8}{\cos^2\theta_{w}} \frac{1}{2} (Z^{\mu}\ii\partial_{\mu}H)(Z^{\nu}\ii\partial_{\nu}H) \Biggr\rbrack \end{multline} where the two powers of $\ii$ make the sign conveniently negative, i.\,e. \begin{subequations} \begin{align} \alpha_{(\partial H)^2W^2}^2 &= \tau^4_8 g^2v_{\mathrm{F}}^2\\ \alpha_{(\partial HW)^2}^2 &= \frac{\tau^5_8 g^2v_{\mathrm{F}}^2}{2} \\ \alpha_{(\partial H)^2Z^2}^2 &= \frac{\tau^4_8 g^2v_{\mathrm{F}}^2}{\cos^2\theta_{w}} \\ \alpha_{(\partial HZ)^2}^2 &=\frac{\tau^5_8 g^2v_{\mathrm{F}}^2}{2\cos^2\theta_{w}} \end{align} \end{subequations} *) let anomalous_gauge_higgs = [ (O H, G Ga, G Ga), Dim5_Scalar_Gauge2 1, G_HGaGa_anom; (O H, G Ga, G Z), Dim5_Scalar_Gauge2 1, G_HGaZ_anom; (O H, G Z, G Z), Dim5_Scalar_Gauge2 1, G_HZZ_anom; (O H, G Wp, G Wm), Dim5_Scalar_Gauge2 1, G_HWW_anom; (O H, G Ga, G Z), Dim5_Scalar_Vector_Vector_TU 1, G_HGaZ_u; (O H, G Z, G Z), Dim5_Scalar_Vector_Vector_U 1, G_HZZ_u; (O H, G Wp, G Wm), Dim5_Scalar_Vector_Vector_U 1, G_HWW_u ] let anomalous_dim6_gauge_higgs = [ (O H, G Z, G Z), Scalar_Vector_Vector 1, G_HZZ6_V3; (O H, G Z, G Z), Dim6_Scalar_Vector_Vector_D 1, G_HZZ6_D; (O H, G Z, G Z), Dim6_Scalar_Vector_Vector_DP 1, G_HZZ6_DP; (O H, G Z, G Z), Scalar_Vector_Vector_t 1, G_HZZ6_PB; (O H, G Ga, G Z), Dim6_HAZ_D 1, G_HGaZ6_D; (O H, G Ga, G Z), Dim6_HAZ_DP 1, G_HGaZ6_DP; (O H, G Ga, G Z), Scalar_Vector_Vector_t 1, G_HGaZ6_PB; (O H, G Ga, G Ga), Scalar_Vector_Vector_t 1, G_HGaGa6; (O H, G Wm, G Wp), Dim6_Scalar_Vector_Vector_D 1, G_HWW_6_D; (O H, G Wm, G Wp), Dim6_Scalar_Vector_Vector_DP 1, G_HWW_6_DP ] let anomalous_gauge_higgs4 = [] let anomalous_dim6_gauge_higgs4 = [(G Ga, O H, G Wm, G Wp), Dim6_AHWW_DPB 1, Anom_Dim6_AHWW_DPB; (G Ga, O H, G Wm, G Wp), Dim6_AHWW_DPW 1, Anom_Dim6_AHWW_DPW; (G Ga, O H, G Wm, G Wp), Dim6_AHWW_DW 1, Anom_Dim6_AHWW_DW; (O H, G Wm, G Wp, G Z), Dim6_HWWZ_DW 1, Anom_Dim6_HWWZ_DW; (O H, G Wm, G Wp, G Z), Dim6_HWWZ_DDPW 1, Anom_Dim6_HWWZ_DDPW; (O H, G Wm, G Wp, G Z), Dim6_HWWZ_DPW 1, Anom_Dim6_HWWZ_DPW; (O H, G Wm, G Wp, G Z), Dim6_HWWZ_DPB 1, Anom_Dim6_HWWZ_DPB; (G Ga, O H, O H, G Z), Dim6_AHHZ_D 1, Anom_Dim6_AHHZ_D; (G Ga, O H, O H, G Z), Dim6_AHHZ_DP 1, Anom_Dim6_AHHZ_DP; (G Ga, O H, O H, G Z), Dim6_AHHZ_PB 1, Anom_Dim6_AHHZ_PB; (O H, O H, G Ga, G Ga), Dim6_Scalar2_Vector2_PB 1, Anom_Dim6_HHAA; (O H, O H, G Wm, G Wp), Dim6_Scalar2_Vector2_D 1, Anom_Dim6_HHWW_DW; (O H, O H, G Wm, G Wp), Dim6_Scalar2_Vector2_DP 1, Anom_Dim6_HHWW_DPW; (O H, O H, G Z, G Z), Dim6_HHZZ_T 1, Anom_Dim6_HHZZ_T; (O H, O H, G Z, G Z), Dim6_Scalar2_Vector2_D 1, Anom_Dim6_HHZZ_D; (O H, O H, G Z, G Z), Dim6_Scalar2_Vector2_DP 1, Anom_Dim6_HHZZ_DP; (O H, O H, G Z, G Z), Dim6_Scalar2_Vector2_PB 1, Anom_Dim6_HHZZ_PB ] let anomalous_higgs = [] let anomalous_dim6_higgs = [(O H, O H, O H), Scalar_Scalar_Scalar 1, Dim6_vev3; (O H, O H, O H), Dim6_HHH 1, Dim6_Cphi ] let higgs_triangle_vertices = if Flags.higgs_triangle then [ (O H, G Ga, G Ga), Dim5_Scalar_Gauge2 1, G_HGaGa; (O H, G Ga, G Z), Dim5_Scalar_Gauge2 1, G_HGaZ; (O H, G Gl, G Gl), Dim5_Scalar_Gauge2 1, G_Hgg ] else [] let anomalous_higgs4 = [] let anomalous_dim6_higgs4 = [(O H, O H, O H, O H), Scalar4 1, Anom_Dim6_H4_v2; (O H, O H, O H, O H), Dim6_H4_P2 1, Anom_Dim6_H4_P2] let gauge_higgs = if Flags.higgs_anom then standard_gauge_higgs @ anomalous_gauge_higgs else if Flags.dim6 then standard_gauge_higgs @ anomalous_dim6_gauge_higgs else standard_gauge_higgs let gauge_higgs4 = if Flags.higgs_anom then standard_gauge_higgs4 @ anomalous_gauge_higgs4 else if Flags.dim6 then standard_gauge_higgs4 @ anomalous_dim6_gauge_higgs4 else standard_gauge_higgs4 let higgs = if Flags.higgs_anom then standard_higgs @ anomalous_higgs else if Flags.dim6 then standard_higgs @ anomalous_dim6_higgs else standard_higgs let higgs4 = if Flags.higgs_anom then standard_higgs4 @ anomalous_higgs4 else if Flags.dim6 then standard_higgs4 @ anomalous_dim6_higgs4 else standard_higgs4 let goldstone_vertices = [ ((O Phi0, G Wm, G Wp), Scalar_Vector_Vector 1, I_G_ZWW); ((O Phip, G Ga, G Wm), Scalar_Vector_Vector 1, I_Q_W); ((O Phip, G Z, G Wm), Scalar_Vector_Vector 1, I_G_ZWW); ((O Phim, G Wp, G Ga), Scalar_Vector_Vector 1, I_Q_W); ((O Phim, G Wp, G Z), Scalar_Vector_Vector 1, I_G_ZWW) ] (* Anomalous trilinear interactions $f_i f_j V$ and $ttH$: \begin{equation} \Delta\mathcal{L}_{tt\gamma} = - e \frac{\upsilon}{\Lambda^2} \bar{t} i\sigma^{\mu\nu} k_\nu (d_V(k^2) + i d_A(k^2) \gamma_5) t A_\mu \end{equation} \begin{equation} \Delta\mathcal{L}_{tc\gamma} = - e \frac{\upsilon}{\Lambda^2} \bar{t} i\sigma^{\mu\nu} k_\nu (d_V(k^2) + i d_A(k^2) \gamma_5) c A_\mu \,\text{+\,h.c.} \end{equation} *) let anomalous_ttA = if Flags.top_anom then [ ((M (U (-3)), G Ga, M (U 3)), FBF (1, Psibar, TVAM, Psi), G_TVA_ttA); ((M (U (-3)), G Ga, M (U 2)), FBF (1, Psibar, TVAM, Psi), G_TVA_tcA); ((M (U (-2)), G Ga, M (U 3)), FBF (1, Psibar, TVAM, Psi), G_TVA_tcA); ((M (U (-3)), G Ga, M (U 1)), FBF (1, Psibar, TVAM, Psi), G_TVA_tuA); ((M (U (-1)), G Ga, M (U 3)), FBF (1, Psibar, TVAM, Psi), G_TVA_tuA)] else [] let tt_threshold_ttA = if Flags.tt_threshold then [ ((M (U (-3)), G Ga, M (U 3)), FBF (1, Psibar, VAM, Psi), VA_ILC_ttA) ] else [] (* \begin{equation} \Delta\mathcal{L}_{bb\gamma} = - e \frac{\upsilon}{\Lambda^2} \bar{b} i\sigma^{\mu\nu} k_\nu (d_V(k^2) + i d_A(k^2) \gamma_5) b A_\mu \end{equation} *) let anomalous_bbA = if Flags.top_anom then [ ((M (D (-3)), G Ga, M (D 3)), FBF (1, Psibar, TVAM, Psi), G_TVA_bbA) ] else [] (* \begin{equation} \Delta\mathcal{L}_{ttg} = - g_s \frac{\upsilon}{\Lambda^2} \bar{t}\lambda^a i\sigma^{\mu\nu}k_\nu (d_V(k^2)+id_A(k^2)\gamma_5)tG^a_\mu \end{equation} \begin{equation} \Delta\mathcal{L}_{tcg} = - g_s \frac{\upsilon}{\Lambda^2} \bar{t}\lambda^a i\sigma^{\mu\nu}k_\nu (d_V(k^2)+id_A(k^2)\gamma_5)cG^a_\mu\,\text{+\,h.c.} \end{equation} *) let anomalous_ttG = if Flags.top_anom then [ ((M (U (-3)), G Gl, M (U 3)), FBF (1, Psibar, TVAM, Psi), G_TVA_ttG); ((M (U (-3)), G Gl, M (U 2)), FBF (1, Psibar, TVAM, Psi), G_TVA_tcG); ((M (U (-2)), G Gl, M (U 3)), FBF (1, Psibar, TVAM, Psi), G_TVA_tcG); ((M (U (-3)), G Gl, M (U 1)), FBF (1, Psibar, TVAM, Psi), G_TVA_tuG); ((M (U (-1)), G Gl, M (U 3)), FBF (1, Psibar, TVAM, Psi), G_TVA_tuG)] else [] (* \begin{equation} \Delta\mathcal{L}_{ttZ} = - \frac{g}{2 c_W} \frac{\upsilon^2}{\Lambda^2}\left\lbrack \bar{t} \fmslash{Z} (X_L(k^2) P_L + X_R(k^2) P_R) t + \bar{t}\frac{i\sigma^{\mu\nu}k_\nu}{m_Z} (d_V(k^2)+id_A(k^2)\gamma_5)tZ_\mu\right\rbrack \end{equation} \begin{equation} \Delta\mathcal{L}_{tcZ} = - \frac{g}{2 c_W} \frac{\upsilon^2}{\Lambda^2}\left\lbrack \bar{t} \fmslash{Z} (X_L(k^2) P_L + X_R(k^2) P_R) c + \bar{t}\frac{i\sigma^{\mu\nu}k_\nu}{m_Z} (d_V(k^2)+id_A(k^2)\gamma_5)cZ_\mu\right\rbrack \,\text{+\,h.c.} \end{equation} *) let anomalous_ttZ = if Flags.top_anom then [ ((M (U (-3)), G Z, M (U 3)), FBF (1, Psibar, VLRM, Psi), G_VLR_ttZ); ((M (U (-3)), G Z, M (U 2)), FBF (1, Psibar, VLRM, Psi), G_VLR_tcZ); ((M (U (-2)), G Z, M (U 3)), FBF (1, Psibar, VLRM, Psi), G_VLR_tcZ); ((M (U (-3)), G Z, M (U 1)), FBF (1, Psibar, VLRM, Psi), G_VLR_tuZ); ((M (U (-1)), G Z, M (U 3)), FBF (1, Psibar, VLRM, Psi), G_VLR_tuZ); ((M (U (-3)), G Z, M (U 3)), FBF (1, Psibar, TVAM, Psi), G_TVA_ttZ); ((M (U (-2)), G Z, M (U 3)), FBF (1, Psibar, TVAM, Psi), G_TVA_tcZ); ((M (U (-3)), G Z, M (U 2)), FBF (1, Psibar, TVAM, Psi), G_TVA_tcZ); ((M (U (-1)), G Z, M (U 3)), FBF (1, Psibar, TVAM, Psi), G_TVA_tuZ); ((M (U (-3)), G Z, M (U 1)), FBF (1, Psibar, TVAM, Psi), G_TVA_tuZ)] else [] let tt_threshold_ttZ = if Flags.tt_threshold then [ ((M (U (-3)), G Z, M (U 3)), FBF (1, Psibar, VAM, Psi), VA_ILC_ttZ) ] else [] (* \begin{equation} \Delta\mathcal{L}_{bbZ} = - \frac{g}{2 c_W} \frac{\upsilon^2}{\Lambda^2} \bar{b}\frac{i\sigma^{\mu\nu}k_\nu}{m_Z} (d_V(k^2)+id_A(k^2)\gamma_5)bZ_\mu \end{equation} *) let anomalous_bbZ = if Flags.top_anom then [ ((M (D (-3)), G Z, M (D 3)), FBF (1, Psibar, TVAM, Psi), G_TVA_bbZ) ] else [] (* \begin{equation} \Delta\mathcal{L}_{tbW} = - \frac{g}{\sqrt{2}} \frac{\upsilon^2}{\Lambda^2}\left\lbrack \bar{b}\fmslash{W}^-(V_L(k^2) P_L+V_R(k^2) P_R) t + \bar{b}\frac{i\sigma^{\mu\nu}k_\nu}{m_W} (g_L(k^2)P_L+g_R(k^2)P_R)tW^-_\mu\right\rbrack \,\text{+\,h.c.} \end{equation} *) let anomalous_tbW = if Flags.top_anom then [ ((M (D (-3)), G Wm, M (U 3)), FBF (1, Psibar, VLRM, Psi), G_VLR_btW); ((M (U (-3)), G Wp, M (D 3)), FBF (1, Psibar, VLRM, Psi), G_VLR_tbW); ((M (D (-3)), G Wm, M (U 3)), FBF (1, Psibar, TLRM, Psi), G_TLR_btW); ((M (U (-3)), G Wp, M (D 3)), FBF (1, Psibar, TRLM, Psi), G_TRL_tbW) ] else [] (* \begin{equation} \Delta\mathcal{L}_{ttH} = - \frac{1}{\sqrt{2}} \bar{t} (Y_V(k^2)+iY_A(k^2)\gamma_5)t H \end{equation} *) let anomalous_ttH = if Flags.top_anom then [ ((M (U (-3)), O H, M (U 3)), FBF (1, Psibar, SPM, Psi), G_SP_ttH) ] else [] (* quartic fermion-gauge interactions $f_i f_j V_1 V_2$ emerging from gauge-invariant effective operators: \begin{equation} \Delta\mathcal{L}_{ttgg} = - \frac{g_s^2}{2} f_{abc} \frac{\upsilon}{\Lambda^2} \bar{t} \lambda^a \sigma^{\mu\nu} (d_V(k^2)+id_A(k^2)\gamma_5)t G^b_\mu G^c_\nu \end{equation} \begin{equation} \Delta\mathcal{L}_{tcgg} = - \frac{g_s^2}{2} f_{abc} \frac{\upsilon}{\Lambda^2} \bar{t} \lambda^a \sigma^{\mu\nu} (d_V(k^2)+id_A(k^2)\gamma_5)c G^b_\mu G^c_\nu \,\text{+\,h.c.} \end{equation} *) let anomalous_ttGG = if Flags.top_anom then [ ((M (U (-3)), O (Aux_top (2,1,0,true,TTGG)), M (U 3)), FBF (1, Psibar, TVA, Psi), G_TVA_ttGG); ((M (U (-3)), O (Aux_top (2,1,0,true,TCGG)), M (U 2)), FBF (1, Psibar, TVA, Psi), G_TVA_tcGG); ((M (U (-2)), O (Aux_top (2,1,0,true,TCGG)), M (U 3)), FBF (1, Psibar, TVA, Psi), G_TVA_tcGG); ((M (U (-3)), O (Aux_top (2,1,0,true,TUGG)), M (U 1)), FBF (1, Psibar, TVA, Psi), G_TVA_tuGG); ((M (U (-1)), O (Aux_top (2,1,0,true,TUGG)), M (U 3)), FBF (1, Psibar, TVA, Psi), G_TVA_tuGG); ((O (Aux_top (2,1,0,false,TTGG)), G Gl, G Gl), Aux_Gauge_Gauge 1, I_Gs); ((O (Aux_top (2,1,0,false,TCGG)), G Gl, G Gl), Aux_Gauge_Gauge 1, I_Gs); ((O (Aux_top (2,1,0,false,TUGG)), G Gl, G Gl), Aux_Gauge_Gauge 1, I_Gs)] else [] (* \begin{equation} \Delta\mathcal{L}_{tbWA} = - i\sin\theta_w \frac{g^2}{2\sqrt{2}} \frac{\upsilon^2}{\Lambda^2}\left\lbrack \bar{b}\frac{\sigma^{\mu\nu}}{m_W} (g_L(k^2)P_L+g_R(k^2)P_R)t A_\mu W^-_\nu \right\rbrack \,\text{+\,h.c.} \end{equation} *) let anomalous_tbWA = if Flags.top_anom then [ ((M (D (-3)), O (Aux_top (2,0,-1,true,TBWA)), M (U 3)), FBF (1, Psibar, TLR, Psi), G_TLR_btWA); ((O (Aux_top (2,0,1,false,TBWA)), G Ga, G Wm), Aux_Gauge_Gauge 1, I_G_weak); ((M (U (-3)), O (Aux_top (2,0,1,true,TBWA)), M (D 3)), FBF (1, Psibar, TRL, Psi), G_TRL_tbWA); ((O (Aux_top (2,0,-1,false,TBWA)), G Wp, G Ga), Aux_Gauge_Gauge 1, I_G_weak) ] else [] (* \begin{equation} \Delta\mathcal{L}_{tbWZ} = - i\cos\theta_w \frac{g^2}{2\sqrt{2}} \frac{\upsilon^2}{\Lambda^2}\left\lbrack \bar{b}\frac{\sigma^{\mu\nu}}{m_W} (g_L(k^2)P_L+g_R(k^2)P_R)t Z_\mu W^-_\nu \right\rbrack \,\text{+\,h.c.} \end{equation} *) let anomalous_tbWZ = if Flags.top_anom then [ ((M (D (-3)), O (Aux_top (2,0,-1,true,TBWZ)), M (U 3)), FBF (1, Psibar, TLR, Psi), G_TLR_btWZ); ((O (Aux_top (2,0,1,false,TBWZ)), G Z, G Wm), Aux_Gauge_Gauge 1, I_G_weak); ((M (U (-3)), O (Aux_top (2,0,1,true,TBWZ)), M (D 3)), FBF (1, Psibar, TRL, Psi), G_TRL_tbWZ); ((O (Aux_top (2,0,-1,false,TBWZ)), G Wp, G Z), Aux_Gauge_Gauge 1, I_G_weak) ] else [] (* \begin{equation} \Delta\mathcal{L}_{ttWW} = - i \frac{g^2}{2} \frac{\upsilon^2}{\Lambda^2} \bar{t} \frac{\sigma^{\mu\nu}}{m_W} (d_V(k^2)+id_A(k^2)\gamma_5)t W^-_\mu W^+_\nu \end{equation} *) let anomalous_ttWW = if Flags.top_anom then [ ((M (U (-3)), O (Aux_top (2,0,0,true,TTWW)), M (U 3)), FBF (1, Psibar, TVA, Psi), G_TVA_ttWW); ((O (Aux_top (2,0,0,false,TTWW)), G Wm, G Wp), Aux_Gauge_Gauge 1, I_G_weak) ] else [] (* \begin{equation} \Delta\mathcal{L}_{bbWW} = - i \frac{g^2}{2} \frac{\upsilon^2}{\Lambda^2} \bar{b} \frac{\sigma^{\mu\nu}}{m_W} (d_V(k^2)+id_A(k^2)\gamma_5)b W^-_\mu W^+_\nu \end{equation} *) let anomalous_bbWW = if Flags.top_anom then [ ((M (D (-3)), O (Aux_top (2,0,0,true,BBWW)), M (D 3)), FBF (1, Psibar, TVA, Psi), G_TVA_bbWW); ((O (Aux_top (2,0,0,false,BBWW)), G Wm, G Wp), Aux_Gauge_Gauge 1, I_G_weak) ] else [] (* 4-fermion contact terms emerging from operator rewriting: *) let anomalous_top_qGuG_tt = [ ((M (U (-3)), O (Aux_top (1,1,0,true,QGUG)), M (U 3)), FBF (1, Psibar, VLR, Psi), G_VLR_qGuG) ] let anomalous_top_qGuG_ff n = List.map mom [ ((U (-n), Aux_top (1,1,0,false,QGUG), U n), FBF (1, Psibar, V, Psi), Unit); ((D (-n), Aux_top (1,1,0,false,QGUG), D n), FBF (1, Psibar, V, Psi), Unit) ] let anomalous_top_qGuG = if Flags.top_anom_4f then anomalous_top_qGuG_tt @ ThoList.flatmap anomalous_top_qGuG_ff [1;2;3] else [] let anomalous_top_qBuB_tt = [ ((M (U (-3)), O (Aux_top (1,0,0,true,QBUB)), M (U 3)), FBF (1, Psibar, VLR, Psi), G_VLR_qBuB) ] let anomalous_top_qBuB_ff n = List.map mom [ ((U (-n), Aux_top (1,0,0,false,QBUB), U n), FBF (1, Psibar, VLR, Psi), G_VLR_qBuB_u); ((D (-n), Aux_top (1,0,0,false,QBUB), D n), FBF (1, Psibar, VLR, Psi), G_VLR_qBuB_d); ((L (-n), Aux_top (1,0,0,false,QBUB), L n), FBF (1, Psibar, VLR, Psi), G_VLR_qBuB_e); ((N (-n), Aux_top (1,0,0,false,QBUB), N n), FBF (1, Psibar, VL, Psi), G_VL_qBuB_n) ] let anomalous_top_qBuB = if Flags.top_anom_4f then anomalous_top_qBuB_tt @ ThoList.flatmap anomalous_top_qBuB_ff [1;2;3] else [] let anomalous_top_qW_tq = [ ((M (U (-3)), O (Aux_top (1,0,0,true,QW)), M (U 3)), FBF (1, Psibar, VL, Psi), G_VL_qW); ((M (D (-3)), O (Aux_top (1,0,-1,true,QW)), M (U 3)), FBF (1, Psibar, VL, Psi), G_VL_qW); ((M (U (-3)), O (Aux_top (1,0,1,true,QW)), M (D 3)), FBF (1, Psibar, VL, Psi), G_VL_qW) ] let anomalous_top_qW_ff n = List.map mom [ ((U (-n), Aux_top (1,0,0,false,QW), U n), FBF (1, Psibar, VL, Psi), G_VL_qW_u); ((D (-n), Aux_top (1,0,0,false,QW), D n), FBF (1, Psibar, VL, Psi), G_VL_qW_d); ((N (-n), Aux_top (1,0,0,false,QW), N n), FBF (1, Psibar, VL, Psi), G_VL_qW_u); ((L (-n), Aux_top (1,0,0,false,QW), L n), FBF (1, Psibar, VL, Psi), G_VL_qW_d); ((D (-n), Aux_top (1,0,-1,false,QW), U n), FBF (1, Psibar, VL, Psi), Half); ((U (-n), Aux_top (1,0,1,false,QW), D n), FBF (1, Psibar, VL, Psi), Half); ((L (-n), Aux_top (1,0,-1,false,QW), N n), FBF (1, Psibar, VL, Psi), Half); ((N (-n), Aux_top (1,0,1,false,QW), L n), FBF (1, Psibar, VL, Psi), Half) ] let anomalous_top_qW = if Flags.top_anom_4f then anomalous_top_qW_tq @ ThoList.flatmap anomalous_top_qW_ff [1;2;3] else [] let anomalous_top_DuDd = if Flags.top_anom_4f then [ ((M (U (-3)), O (Aux_top (0,0,0,true,DR)), M (U 3)), FBF (1, Psibar, SR, Psi), Half); ((M (U (-3)), O (Aux_top (0,0,0,false,DR)), M (U 3)), FBF (1, Psibar, SL, Psi), G_SL_DttR); ((M (D (-3)), O (Aux_top (0,0,0,false,DR)), M (D 3)), FBF (1, Psibar, SR, Psi), G_SR_DttR); ((M (U (-3)), O (Aux_top (0,0,0,true,DL)), M (U 3)), FBF (1, Psibar, SL, Psi), Half); ((M (D (-3)), O (Aux_top (0,0,0,false,DL)), M (D 3)), FBF (1, Psibar, SL, Psi), G_SL_DttL); ((M (D (-3)), O (Aux_top (0,0,-1,true,DR)), M (U 3)), FBF (1, Psibar, SR, Psi), Half); ((M (U (-3)), O (Aux_top (0,0,1,false,DR)), M (D 3)), FBF (1, Psibar, SLR, Psi), G_SLR_DbtR); ((M (D (-3)), O (Aux_top (0,0,-1,true,DL)), M (U 3)), FBF (1, Psibar, SL, Psi), Half); ((M (U (-3)), O (Aux_top (0,0,1,false,DL)), M (D 3)), FBF (1, Psibar, SL, Psi), G_SL_DbtL) ] else [] let anomalous_top_quqd1_tq = [ ((M (D (-3)), O (Aux_top (0,0,-1,true,QUQD1R)), M (U 3)), FBF (1, Psibar, SR, Psi), C_quqd1R_bt); ((M (U (-3)), O (Aux_top (0,0, 1,true,QUQD1R)), M (D 3)), FBF (1, Psibar, SL, Psi), C_quqd1R_tb); ((M (D (-3)), O (Aux_top (0,0,-1,true,QUQD1L)), M (U 3)), FBF (1, Psibar, SL, Psi), C_quqd1L_bt); ((M (U (-3)), O (Aux_top (0,0, 1,true,QUQD1L)), M (D 3)), FBF (1, Psibar, SR, Psi), C_quqd1L_tb) ] let anomalous_top_quqd1_ff n = List.map mom [ ((U (-n), Aux_top (0,0, 1,false,QUQD1R), D n), FBF (1, Psibar, SR, Psi), Half); ((D (-n), Aux_top (0,0,-1,false,QUQD1R), U n), FBF (1, Psibar, SL, Psi), Half); ((U (-n), Aux_top (0,0, 1,false,QUQD1L), D n), FBF (1, Psibar, SL, Psi), Half); ((D (-n), Aux_top (0,0,-1,false,QUQD1L), U n), FBF (1, Psibar, SR, Psi), Half) ] let anomalous_top_quqd1 = if Flags.top_anom_4f then anomalous_top_quqd1_tq @ ThoList.flatmap anomalous_top_quqd1_ff [1;2;3] else [] let anomalous_top_quqd8_tq = [ ((M (D (-3)), O (Aux_top (0,1,-1,true,QUQD8R)), M (U 3)), FBF (1, Psibar, SR, Psi), C_quqd8R_bt); ((M (U (-3)), O (Aux_top (0,1, 1,true,QUQD8R)), M (D 3)), FBF (1, Psibar, SL, Psi), C_quqd8R_tb); ((M (D (-3)), O (Aux_top (0,1,-1,true,QUQD8L)), M (U 3)), FBF (1, Psibar, SL, Psi), C_quqd8L_bt); ((M (U (-3)), O (Aux_top (0,1, 1,true,QUQD8L)), M (D 3)), FBF (1, Psibar, SR, Psi), C_quqd8L_tb) ] let anomalous_top_quqd8_ff n = List.map mom [ ((U (-n), Aux_top (0,1, 1,false,QUQD8R), D n), FBF (1, Psibar, SR, Psi), Half); ((D (-n), Aux_top (0,1,-1,false,QUQD8R), U n), FBF (1, Psibar, SL, Psi), Half); ((U (-n), Aux_top (0,1, 1,false,QUQD8L), D n), FBF (1, Psibar, SL, Psi), Half); ((D (-n), Aux_top (0,1,-1,false,QUQD8L), U n), FBF (1, Psibar, SR, Psi), Half) ] let anomalous_top_quqd8 = if Flags.top_anom_4f then anomalous_top_quqd8_tq @ ThoList.flatmap anomalous_top_quqd8_ff [1;2;3] else [] let vertices3 = (ThoList.flatmap electromagnetic_currents [1;2;3] @ ThoList.flatmap color_currents [1;2;3] @ ThoList.flatmap neutral_currents [1;2;3] @ (if Flags.ckm_present then charged_currents_ckm else charged_currents_triv) @ yukawa @ triple_gauge @ gauge_higgs @ higgs @ higgs_triangle_vertices @ goldstone_vertices @ tt_threshold_ttA @ tt_threshold_ttZ @ anomalous_ttA @ anomalous_bbA @ anomalous_ttZ @ anomalous_bbZ @ anomalous_tbW @ anomalous_tbWA @ anomalous_tbWZ @ anomalous_ttWW @ anomalous_bbWW @ anomalous_ttG @ anomalous_ttGG @ anomalous_ttH @ anomalous_top_qGuG @ anomalous_top_qBuB @ anomalous_top_qW @ anomalous_top_DuDd @ anomalous_top_quqd1 @ anomalous_top_quqd8) let vertices4 = quartic_gauge @ gauge_higgs4 @ higgs4 let vertices () = (vertices3, vertices4, []) (* For efficiency, make sure that [F.of_vertices vertices] is evaluated only once. *) let table = F.of_vertices (vertices ()) let fuse2 = F.fuse2 table let fuse3 = F.fuse3 table let fuse = F.fuse table let max_degree () = 4 let flavor_of_string = function | "e-" -> M (L 1) | "e+" -> M (L (-1)) | "mu-" -> M (L 2) | "mu+" -> M (L (-2)) | "tau-" -> M (L 3) | "tau+" -> M (L (-3)) | "nue" -> M (N 1) | "nuebar" -> M (N (-1)) | "numu" -> M (N 2) | "numubar" -> M (N (-2)) | "nutau" -> M (N 3) | "nutaubar" -> M (N (-3)) | "u" -> M (U 1) | "ubar" -> M (U (-1)) | "c" -> M (U 2) | "cbar" -> M (U (-2)) | "t" -> M (U 3) | "tbar" -> M (U (-3)) | "d" -> M (D 1) | "dbar" -> M (D (-1)) | "s" -> M (D 2) | "sbar" -> M (D (-2)) | "b" -> M (D 3) | "bbar" -> M (D (-3)) | "g" | "gl" -> G Gl | "A" -> G Ga | "Z" | "Z0" -> G Z | "W+" -> G Wp | "W-" -> G Wm | "H" -> O H + | "phi+" -> O Phip + | "phi0" -> O Phi0 + | "phi-" -> O Phim | "Aux_t_ttGG0" -> O (Aux_top (2,1, 0,true,TTGG)) | "Aux_ttGG0" -> O (Aux_top (2,1, 0,false,TTGG)) | "Aux_t_tcGG0" -> O (Aux_top (2,1, 0,true,TCGG)) | "Aux_tcGG0" -> O (Aux_top (2,1, 0,false,TCGG)) | "Aux_t_tbWA+" -> O (Aux_top (2,0, 1,true,TBWA)) | "Aux_tbWA+" -> O (Aux_top (2,0, 1,false,TBWA)) | "Aux_t_tbWA-" -> O (Aux_top (2,0,-1,true,TBWA)) | "Aux_tbWA-" -> O (Aux_top (2,0,-1,false,TBWA)) | "Aux_t_tbWZ+" -> O (Aux_top (2,0, 1,true,TBWZ)) | "Aux_tbWZ+" -> O (Aux_top (2,0, 1,false,TBWZ)) | "Aux_t_tbWZ-" -> O (Aux_top (2,0,-1,true,TBWZ)) | "Aux_tbWZ-" -> O (Aux_top (2,0,-1,false,TBWZ)) | "Aux_t_ttWW0" -> O (Aux_top (2,0, 0,true,TTWW)) | "Aux_ttWW0" -> O (Aux_top (2,0, 0,false,TTWW)) | "Aux_t_bbWW0" -> O (Aux_top (2,0, 0,true,BBWW)) | "Aux_bbWW0" -> O (Aux_top (2,0, 0,false,BBWW)) | "Aux_t_qGuG0" -> O (Aux_top (1,1, 0,true,QGUG)) | "Aux_qGuG0" -> O (Aux_top (1,1, 0,false,QGUG)) | "Aux_t_qBuB0" -> O (Aux_top (1,0, 0,true,QBUB)) | "Aux_qBuB0" -> O (Aux_top (1,0, 0,false,QBUB)) | "Aux_t_qW0" -> O (Aux_top (1,0, 0,true,QW)) | "Aux_qW0" -> O (Aux_top (1,0, 0,false,QW)) | "Aux_t_qW+" -> O (Aux_top (1,0, 1,true,QW)) | "Aux_qW+" -> O (Aux_top (1,0, 1,false,QW)) | "Aux_t_qW-" -> O (Aux_top (1,0,-1,true,QW)) | "Aux_qW-" -> O (Aux_top (1,0,-1,false,QW)) | "Aux_t_dL0" -> O (Aux_top (0,0, 0,true,DL)) | "Aux_dL0" -> O (Aux_top (0,0, 0,false,DL)) | "Aux_t_dL+" -> O (Aux_top (0,0, 1,true,DL)) | "Aux_dL+" -> O (Aux_top (0,0, 1,false,DL)) | "Aux_t_dL-" -> O (Aux_top (0,0,-1,true,DL)) | "Aux_dL-" -> O (Aux_top (0,0,-1,false,DL)) | "Aux_t_dR0" -> O (Aux_top (0,0, 0,true,DR)) | "Aux_dR0" -> O (Aux_top (0,0, 0,false,DR)) | "Aux_t_dR+" -> O (Aux_top (0,0, 1,true,DR)) | "Aux_dR+" -> O (Aux_top (0,0, 1,false,DR)) | "Aux_t_dR-" -> O (Aux_top (0,0,-1,true,DR)) | "Aux_dR-" -> O (Aux_top (0,0,-1,false,DR)) | "Aux_t_quqd1L+" -> O (Aux_top (0,0, 1,true,QUQD1L)) | "Aux_quqd1L+" -> O (Aux_top (0,0, 1,false,QUQD1L)) | "Aux_t_quqd1L-" -> O (Aux_top (0,0,-1,true,QUQD1L)) | "Aux_quqd1L-" -> O (Aux_top (0,0,-1,false,QUQD1L)) | "Aux_t_quqd1R+" -> O (Aux_top (0,0, 1,true,QUQD1R)) | "Aux_quqd1R+" -> O (Aux_top (0,0, 1,false,QUQD1R)) | "Aux_t_quqd1R-" -> O (Aux_top (0,0,-1,true,QUQD1R)) | "Aux_quqd1R-" -> O (Aux_top (0,0,-1,false,QUQD1R)) | "Aux_t_quqd8L+" -> O (Aux_top (0,1, 1,true,QUQD8L)) | "Aux_quqd8L+" -> O (Aux_top (0,1, 1,false,QUQD8L)) | "Aux_t_quqd8L-" -> O (Aux_top (0,1,-1,true,QUQD8L)) | "Aux_quqd8L-" -> O (Aux_top (0,1,-1,false,QUQD8L)) | "Aux_t_quqd8R+" -> O (Aux_top (0,1, 1,true,QUQD8R)) | "Aux_quqd8R+" -> O (Aux_top (0,1, 1,false,QUQD8R)) | "Aux_t_quqd8R-" -> O (Aux_top (0,1,-1,true,QUQD8R)) | "Aux_quqd8R-" -> O (Aux_top (0,1,-1,false,QUQD8R)) | _ -> invalid_arg "Modellib.SM.flavor_of_string" let flavor_to_string = function | M f -> begin match f with | L 1 -> "e-" | L (-1) -> "e+" | L 2 -> "mu-" | L (-2) -> "mu+" | L 3 -> "tau-" | L (-3) -> "tau+" | L _ -> invalid_arg "Modellib.SM.flavor_to_string: invalid lepton" | N 1 -> "nue" | N (-1) -> "nuebar" | N 2 -> "numu" | N (-2) -> "numubar" | N 3 -> "nutau" | N (-3) -> "nutaubar" | N _ -> invalid_arg "Modellib.SM.flavor_to_string: invalid neutrino" | U 1 -> "u" | U (-1) -> "ubar" | U 2 -> "c" | U (-2) -> "cbar" | U 3 -> "t" | U (-3) -> "tbar" | U _ -> invalid_arg "Modellib.SM.flavor_to_string: invalid up type quark" | D 1 -> "d" | D (-1) -> "dbar" | D 2 -> "s" | D (-2) -> "sbar" | D 3 -> "b" | D (-3) -> "bbar" | D _ -> invalid_arg "Modellib.SM.flavor_to_string: invalid down type quark" end | G f -> begin match f with | Gl -> "gl" | Ga -> "A" | Z -> "Z" | Wp -> "W+" | Wm -> "W-" end | O f -> begin match f with | Phip -> "phi+" | Phim -> "phi-" | Phi0 -> "phi0" | H -> "H" | Aux_top (_,_,ch,n,v) -> "Aux_" ^ (if n then "t_" else "") ^ ( begin match v with | TTGG -> "ttGG" | TBWA -> "tbWA" | TBWZ -> "tbWZ" | TTWW -> "ttWW" | BBWW -> "bbWW" | TCGG -> "tcgg" | TUGG -> "tugg" | QGUG -> "qGuG" | QBUB -> "qBuB" | QW -> "qW" | DL -> "dL" | DR -> "dR" | QUQD1L -> "quqd1L" | QUQD1R -> "quqd1R" | QUQD8L -> "quqd8L" | QUQD8R -> "quqd8R" end ) ^ ( if ch > 0 then "+" else if ch < 0 then "-" else "0" ) end let flavor_to_TeX = function | M f -> begin match f with | L 1 -> "e^-" | L (-1) -> "e^+" | L 2 -> "\\mu^-" | L (-2) -> "\\mu^+" | L 3 -> "\\tau^-" | L (-3) -> "\\tau^+" | L _ -> invalid_arg "Modellib.SM.flavor_to_TeX: invalid lepton" | N 1 -> "\\nu_e" | N (-1) -> "\\bar{\\nu}_e" | N 2 -> "\\nu_\\mu" | N (-2) -> "\\bar{\\nu}_\\mu" | N 3 -> "\\nu_\\tau" | N (-3) -> "\\bar{\\nu}_\\tau" | N _ -> invalid_arg "Modellib.SM.flavor_to_TeX: invalid neutrino" | U 1 -> "u" | U (-1) -> "\\bar{u}" | U 2 -> "c" | U (-2) -> "\\bar{c}" | U 3 -> "t" | U (-3) -> "\\bar{t}" | U _ -> invalid_arg "Modellib.SM.flavor_to_TeX: invalid up type quark" | D 1 -> "d" | D (-1) -> "\\bar{d}" | D 2 -> "s" | D (-2) -> "\\bar{s}" | D 3 -> "b" | D (-3) -> "\\bar{b}" | D _ -> invalid_arg "Modellib.SM.flavor_to_TeX: invalid down type quark" end | G f -> begin match f with | Gl -> "g" | Ga -> "\\gamma" | Z -> "Z" | Wp -> "W^+" | Wm -> "W^-" end | O f -> begin match f with | Phip -> "\\phi^+" | Phim -> "\\phi^-" | Phi0 -> "\\phi^0" | H -> "H" | Aux_top (_,_,ch,n,v) -> "\\textnormal{Aux_" ^ (if n then "t_" else "") ^ ( begin match v with | TTGG -> "ttGG" | TBWA -> "tbWA" | TBWZ -> "tbWZ" | TTWW -> "ttWW" | BBWW -> "bbWW" | TCGG -> "tcgg" | TUGG -> "tugg" | QGUG -> "qGuG" | QBUB -> "qBuB" | QW -> "qW" | DL -> "dL" | DR -> "dR" | QUQD1L -> "quqd1L" | QUQD1R -> "quqd1R" | QUQD8L -> "quqd8L" | QUQD8R -> "quqd8R" end ) ^ ( if ch > 0 then "^+" else if ch < 0 then "^-" else "^0" ) ^ "}" end let flavor_symbol = function | M f -> begin match f with | L n when n > 0 -> "l" ^ string_of_int n | L n -> "l" ^ string_of_int (abs n) ^ "b" | N n when n > 0 -> "n" ^ string_of_int n | N n -> "n" ^ string_of_int (abs n) ^ "b" | U n when n > 0 -> "u" ^ string_of_int n | U n -> "u" ^ string_of_int (abs n) ^ "b" | D n when n > 0 -> "d" ^ string_of_int n | D n -> "d" ^ string_of_int (abs n) ^ "b" end | G f -> begin match f with | Gl -> "gl" | Ga -> "a" | Z -> "z" | Wp -> "wp" | Wm -> "wm" end | O f -> begin match f with | Phip -> "pp" | Phim -> "pm" | Phi0 -> "p0" | H -> "h" | Aux_top (_,_,ch,n,v) -> "aux_" ^ (if n then "t_" else "") ^ ( begin match v with | TTGG -> "ttgg" | TBWA -> "tbwa" | TBWZ -> "tbwz" | TTWW -> "ttww" | BBWW -> "bbww" | TCGG -> "tcgg" | TUGG -> "tugg" | QGUG -> "qgug" | QBUB -> "qbub" | QW -> "qw" | DL -> "dl" | DR -> "dr" | QUQD1L -> "quqd1l" | QUQD1R -> "quqd1r" | QUQD8L -> "quqd8l" | QUQD8R -> "quqd8r" end ) ^ "_" ^ ( if ch > 0 then "p" else if ch < 0 then "m" else "0" ) end let pdg = function | M f -> begin match f with | L n when n > 0 -> 9 + 2*n | L n -> - 9 + 2*n | N n when n > 0 -> 10 + 2*n | N n -> - 10 + 2*n | U n when n > 0 -> 2*n | U n -> 2*n | D n when n > 0 -> - 1 + 2*n | D n -> 1 + 2*n end | G f -> begin match f with | Gl -> 21 | Ga -> 22 | Z -> 23 | Wp -> 24 | Wm -> (-24) end | O f -> begin match f with | Phip | Phim -> 27 | Phi0 -> 26 | H -> 25 | Aux_top (_,_,ch,t,f) -> let n = begin match f with | QW -> 0 | QUQD1R -> 1 | QUQD1L -> 2 | QUQD8R -> 3 | QUQD8L -> 4 | _ -> 5 end in (602 + 3*n - ch) * ( if t then (1) else (-1) ) end let mass_symbol f = if ( Flags.tt_threshold && (abs (pdg f)) == 6 ) then "ttv_mtpole(p12*p12)" else "mass(" ^ string_of_int (abs (pdg f)) ^ ")" let width_symbol f = "width(" ^ string_of_int (abs (pdg f)) ^ ")" let constant_symbol = function | Unit -> "unit" | Half -> "half" | Pi -> "PI" | Alpha_QED -> "alpha" | E -> "e" | G_weak -> "g" | Vev -> "vev" | I_G_weak -> "ig" | Sin2thw -> "sin2thw" | Sinthw -> "sinthw" | Costhw -> "costhw" | Q_lepton -> "qlep" | Q_up -> "qup" | Q_down -> "qdwn" | G_NC_lepton -> "gnclep" | G_NC_neutrino -> "gncneu" | G_NC_up -> "gncup" | G_NC_down -> "gncdwn" | G_TVA_ttA -> "gtva_tta" | G_TVA_bbA -> "gtva_bba" | G_VLR_ttZ -> "gvlr_ttz" | G_TVA_ttZ -> "gtva_ttz" | G_VLR_tcZ -> "gvlr_tcz" | G_TVA_tcZ -> "gtva_tcz" | G_VLR_tuZ -> "gvlr_tuz" | G_TVA_tuZ -> "gtva_tuz" | G_TVA_bbZ -> "gtva_bbz" | G_TVA_tcA -> "gtva_tca" | G_TVA_tuA -> "gtva_tua" | VA_ILC_ttA -> "va_ilc_tta" | VA_ILC_ttZ -> "va_ilc_ttz" | G_VLR_btW -> "gvlr_btw" | G_VLR_tbW -> "gvlr_tbw" | G_TLR_btW -> "gtlr_btw" | G_TRL_tbW -> "gtrl_tbw" | G_TLR_btWA -> "gtlr_btwa" | G_TRL_tbWA -> "gtrl_tbwa" | G_TLR_btWZ -> "gtlr_btwz" | G_TRL_tbWZ -> "gtrl_tbwz" | G_TVA_ttWW -> "gtva_ttww" | G_TVA_bbWW -> "gtva_bbww" | G_TVA_ttG -> "gtva_ttg" | G_TVA_ttGG -> "gtva_ttgg" | G_TVA_tcG -> "gtva_tcg" | G_TVA_tcGG -> "gtva_tcgg" | G_TVA_tuG -> "gtva_tug" | G_TVA_tuGG -> "gtva_tugg" | G_SP_ttH -> "gsp_tth" | G_VLR_qGuG -> "gvlr_qgug" | G_VLR_qBuB -> "gvlr_qbub" | G_VLR_qBuB_u -> "gvlr_qbub_u" | G_VLR_qBuB_d -> "gvlr_qbub_d" | G_VLR_qBuB_e -> "gvlr_qbub_e" | G_VL_qBuB_n -> "gvl_qbub_n" | G_VL_qW -> "gvl_qw" | G_VL_qW_u -> "gvl_qw_u" | G_VL_qW_d -> "gvl_qw_d" | G_SL_DttR -> "gsl_dttr" | G_SR_DttR -> "gsr_dttr" | G_SL_DttL -> "gsl_dttl" | G_SLR_DbtR -> "gslr_dbtr" | G_SL_DbtL -> "gsl_dbtl" | C_quqd1R_bt -> "c_quqd1_1" | C_quqd1R_tb -> "conjg(c_quqd1_1)" | C_quqd1L_bt -> "conjg(c_quqd1_2)" | C_quqd1L_tb -> "c_quqd1_2" | C_quqd8R_bt -> "c_quqd8_1" | C_quqd8R_tb -> "conjg(c_quqd8_1)" | C_quqd8L_bt -> "conjg(c_quqd8_2)" | C_quqd8L_tb -> "c_quqd8_2" | G_CC -> "gcc" | G_CCQ (n1,n2) -> "gccq" ^ string_of_int n1 ^ string_of_int n2 | I_Q_W -> "iqw" | I_G_ZWW -> "igzww" | G_WWWW -> "gw4" | G_ZZWW -> "gzzww" | G_AZWW -> "gazww" | G_AAWW -> "gaaww" | I_G1_AWW -> "ig1a" | I_G1_ZWW -> "ig1z" | I_G1_plus_kappa_plus_G4_AWW -> "ig1pkpg4a" | I_G1_plus_kappa_plus_G4_ZWW -> "ig1pkpg4z" | I_G1_plus_kappa_minus_G4_AWW -> "ig1pkmg4a" | I_G1_plus_kappa_minus_G4_ZWW -> "ig1pkmg4z" | I_G1_minus_kappa_plus_G4_AWW -> "ig1mkpg4a" | I_G1_minus_kappa_plus_G4_ZWW -> "ig1mkpg4z" | I_G1_minus_kappa_minus_G4_AWW -> "ig1mkmg4a" | I_G1_minus_kappa_minus_G4_ZWW -> "ig1mkmg4z" | I_lambda_AWW -> "ila" | I_lambda_ZWW -> "ilz" | G5_AWW -> "rg5a" | G5_ZWW -> "rg5z" | I_kappa5_AWW -> "ik5a" | I_kappa5_ZWW -> "ik5z" | I_lambda5_AWW -> "il5a" | I_lambda5_ZWW -> "il5z" | Alpha_WWWW0 -> "alww0" | Alpha_WWWW2 -> "alww2" | Alpha_ZZWW0 -> "alzw0" | Alpha_ZZWW1 -> "alzw1" | Alpha_ZZZZ -> "alzz" | D_Alpha_ZZWW0_S -> "dalzz0_s(gkm,mkm," | D_Alpha_ZZWW0_T -> "dalzz0_t(gkm,mkm," | D_Alpha_ZZWW1_S -> "dalzz1_s(gkm,mkm," | D_Alpha_ZZWW1_T -> "dalzz1_t(gkm,mkm," | D_Alpha_ZZWW1_U -> "dalzz1_u(gkm,mkm," | D_Alpha_WWWW0_S -> "dalww0_s(gkm,mkm," | D_Alpha_WWWW0_T -> "dalww0_t(gkm,mkm," | D_Alpha_WWWW0_U -> "dalww0_u(gkm,mkm," | D_Alpha_WWWW2_S -> "dalww2_s(gkm,mkm," | D_Alpha_WWWW2_T -> "dalww2_t(gkm,mkm," | D_Alpha_ZZZZ_S -> "dalz4_s(gkm,mkm," | D_Alpha_ZZZZ_T -> "dalz4_t(gkm,mkm," | G_HWW -> "ghww" | G_HZZ -> "ghzz" | G_HHWW -> "ghhww" | G_HHZZ -> "ghhzz" | G_Htt -> "ghtt" | G_Hbb -> "ghbb" | G_Hss -> "ghss" | G_Hee -> "ghee" | G_Htautau -> "ghtautau" | G_Hcc -> "ghcc" | G_Hmm -> "ghmm" | G_HGaZ -> "ghgaz" | G_HGaGa -> "ghgaga" | G_Hgg -> "ghgg" | G_HGaGa_anom -> "ghgaga_ac" | G_HGaZ_anom -> "ghgaz_ac" | G_HZZ_anom -> "ghzz_ac" | G_HWW_anom -> "ghww_ac" | G_HGaZ_u -> "ghgaz_u" | G_HZZ_u -> "ghzz_u" | G_HWW_u -> "ghww_u" | G_H3 -> "gh3" | G_H4 -> "gh4" | Gs -> "gs" | I_Gs -> "igs" | G2 -> "gs**2" | Mass f -> "mass" ^ flavor_symbol f | Width f -> "width" ^ flavor_symbol f | K_Matrix_Coeff i -> "kc" ^ string_of_int i | K_Matrix_Pole i -> "kp" ^ string_of_int i | G_HZZ6_V3 -> "ghzz6v3" | G_HZZ6_D ->"ghzz6d" | G_HZZ6_DP ->"ghzz6dp" | G_HZZ6_PB ->"ghzz6pb" | G_HGaZ6_D -> "ghaz6d" | G_HGaZ6_DP -> "ghaz6dp" | G_HGaZ6_PB -> "ghaz6pb" | G_HGaGa6 -> "ghgaga6" | G_HWW_6_D -> "ghww6d" | G_HWW_6_DP ->"ghww6dp" | I_Dim6_AWW_Gauge -> "dim6awwgauge" | I_Dim6_AWW_GGG -> "dim6awwggg" | I_Dim6_AWW_DP -> "dim6awwdp" | I_Dim6_AWW_DW -> "dim6awwdw" | I_Dim6_WWZ_W -> "dim6wwzw" | I_Dim6_WWZ_DPWDW -> "dim6wwzdpwdw" | I_Dim6_WWZ_DW -> "dim6wwzdw" | I_Dim6_WWZ_D -> "dim6wwzd" | Dim6_vev3 -> "dim6vev3" | Dim6_Cphi -> "dim6cphi" (*i | I_Dim6_GGG_G -> "dim6gggg" | I_Dim6_GGG_CG -> "dim6gggcg" i*) | Anom_Dim6_H4_v2 -> "adim6h4v2" | Anom_Dim6_H4_P2 -> "adim6h4p2" | Anom_Dim6_AHWW_DPB -> "adim6ahwwdpb" | Anom_Dim6_AHWW_DPW -> "adim6ahwwdpw" | Anom_Dim6_AHWW_DW -> "adim6ahwwdw" | Anom_Dim6_AAWW_DW -> "adim6aawwdw" | Anom_Dim6_AAWW_W -> "adim6aawww" | Anom_Dim6_HHWW_DW -> "adim6hhwwdw" | Anom_Dim6_HHWW_DPW -> "adim6hhwwdpw" | Anom_Dim6_HWWZ_DW -> "adim6hwwzdw" | Anom_Dim6_HWWZ_DDPW -> "adim6hwwzddpw" | Anom_Dim6_HWWZ_DPW -> "adim6hwwzdpw" | Anom_Dim6_HWWZ_DPB -> "adim6hwwzdpb" | Anom_Dim6_AHHZ_D -> "adim6ahhzd" | Anom_Dim6_AHHZ_DP -> "adim6ahhzdp" | Anom_Dim6_AHHZ_PB -> "adim6ahhzpb" | Anom_Dim6_AZWW_W -> "adim6azwww" | Anom_Dim6_AZWW_DWDPW -> "adim6azwwdwdpw" | Anom_Dim6_WWWW_W -> "adim6wwwww" | Anom_Dim6_WWWW_DWDPW -> "adim6wwwwdwdpw" | Anom_Dim6_WWZZ_W -> "adim6wwzzw" | Anom_Dim6_WWZZ_DWDPW -> "adim6wwzzdwdpw" | Anom_Dim6_HHAA -> "adim6hhaa" | Anom_Dim6_HHZZ_D -> "adim6hhzzd" | Anom_Dim6_HHZZ_DP -> "adim6hhzzdp" | Anom_Dim6_HHZZ_PB -> "adim6hhzzpb" | Anom_Dim6_HHZZ_T -> "adim6hhzzt" end (* \thocwmodulesection{Incomplete Standard Model in $R_\xi$ Gauge} *) (* \begin{dubious} At the end of the day, we want a functor mapping from gauge models in unitarity gauge to $R_\xi$ gauge and vice versa. For this, we will need a more abstract implementation of (spontaneously broken) gauge theories. \end{dubious} *) module SM_Rxi = struct open Coupling module SM = SM(SM_no_anomalous) let options = SM.options let caveats = SM.caveats type flavor = SM.flavor let flavors = SM.flavors let external_flavors = SM.external_flavors (* Later: [type orders = SM.orders] *) type constant = SM.constant (* Later: [let orders = SM.orders] *) let lorentz = SM.lorentz let color = SM.color let nc = SM.nc let goldstone = SM.goldstone let conjugate = SM.conjugate let fermion = SM.fermion (* \begin{dubious} Check if it makes sense to have separate gauge fixing parameters for each vector boson. There's probably only one independent parameter for each group factor. \end{dubious} *) type gauge = | XiA | XiZ | XiW let gauge_symbol = function | XiA -> "xia" | XiZ -> "xi0" | XiW -> "xipm" (* Change the gauge boson propagators and make the Goldstone bosons propagating. *) let propagator = function | SM.G SM.Ga -> Prop_Gauge XiA | SM.G SM.Z -> Prop_Rxi XiZ | SM.G SM.Wp | SM.G SM.Wm -> Prop_Rxi XiW | SM.O SM.Phip | SM.O SM.Phim | SM.O SM.Phi0 -> Prop_Scalar | f -> SM.propagator f let width = SM.width module Ch = Charges.QQ let charges = SM.charges module F = Modeltools.Fusions (struct type f = flavor type c = constant let compare = compare let conjugate = conjugate end) let vertices = SM.vertices let table = F.of_vertices (vertices ()) let fuse2 = F.fuse2 table let fuse3 = F.fuse3 table let fuse = F.fuse table let max_degree () = 3 let parameters = SM.parameters let flavor_of_string = SM.flavor_of_string let flavor_to_string = SM.flavor_to_string let flavor_to_TeX = SM.flavor_to_TeX let flavor_symbol = SM.flavor_symbol let pdg = SM.pdg let mass_symbol = SM.mass_symbol let width_symbol = SM.width_symbol let constant_symbol = SM.constant_symbol end (* \thocwmodulesection{Groves} *) module Groves (M : Model.Gauge) : Model.Gauge with module Ch = M.Ch = struct let max_generations = 5 let options = M.options let caveats = M.caveats type matter_field = M.matter_field * int type gauge_boson = M.gauge_boson type other = M.other type field = | Matter of matter_field | Gauge of gauge_boson | Other of other type flavor = M of matter_field | G of gauge_boson | O of other let matter_field (f, g) = M (f, g) let gauge_boson f = G f let other f = O f let field = function | M f -> Matter f | G f -> Gauge f | O f -> Other f let project = function | M (f, _) -> M.matter_field f | G f -> M.gauge_boson f | O f -> M.other f let inject g f = match M.field f with | M.Matter f -> M (f, g) | M.Gauge f -> G f | M.Other f -> O f type gauge = M.gauge let gauge_symbol = M.gauge_symbol let color f = M.color (project f) let nc () = 3 let pdg f = M.pdg (project f) let lorentz f = M.lorentz (project f) let propagator f = M.propagator (project f) let fermion f = M.fermion (project f) let width f = M.width (project f) let mass_symbol f = M.mass_symbol (project f) let width_symbol f = M.width_symbol (project f) let flavor_symbol f = M.flavor_symbol (project f) type constant = M.constant (* Later: [type orders = M.orders] *) let constant_symbol = M.constant_symbol let max_degree = M.max_degree let parameters = M.parameters (* Later: [let orders = M.orders] *) let conjugate = function | M (_, g) as f -> inject g (M.conjugate (project f)) | f -> inject 0 (M.conjugate (project f)) let read_generation s = try let offset = String.index s '/' in (int_of_string (String.sub s (succ offset) (String.length s - offset - 1)), String.sub s 0 offset) with | Not_found -> (1, s) let format_generation c s = s ^ "/" ^ string_of_int c let flavor_of_string s = let g, s = read_generation s in inject g (M.flavor_of_string s) let flavor_to_string = function | M (_, g) as f -> format_generation g (M.flavor_to_string (project f)) | f -> M.flavor_to_string (project f) let flavor_to_TeX = function | M (_, g) as f -> format_generation g (M.flavor_to_TeX (project f)) | f -> M.flavor_to_TeX (project f) let goldstone = function | G _ as f -> begin match M.goldstone (project f) with | None -> None | Some (f, c) -> Some (inject 0 f, c) end | M _ | O _ -> None let clone generations flavor = match M.field flavor with | M.Matter f -> List.map (fun g -> M (f, g)) generations | M.Gauge f -> [G f] | M.Other f -> [O f] let generations = ThoList.range 1 max_generations let flavors () = ThoList.flatmap (clone generations) (M.flavors ()) let external_flavors () = List.map (fun (s, fl) -> (s, ThoList.flatmap (clone generations) fl)) (M.external_flavors ()) module Ch = M.Ch let charges f = M.charges (project f) module F = Modeltools.Fusions (struct type f = flavor type c = constant let compare = compare let conjugate = conjugate end) (* In the following functions, we might replace [_] by [(M.Gauge _ | M.Other _)], in order to allow the compiler to check completeness. However, this makes the code much less readable. *) let clone3 ((f1, f2, f3), v, c) = match M.field f1, M.field f2, M.field f3 with | M.Matter _, M.Matter _, M.Matter _ -> invalid_arg "Modellib.Groves().vertices: three matter fields!" | M.Matter f1', M.Matter f2', _ -> List.map (fun g -> ((M (f1', g), M (f2', g), inject 0 f3), v, c)) generations | M.Matter f1', _, M.Matter f3' -> List.map (fun g -> ((M (f1', g), inject 0 f2, M (f3', g)), v, c)) generations | _, M.Matter f2', M.Matter f3' -> List.map (fun g -> ((inject 0 f1, M (f2', g), M (f3', g)), v, c)) generations | M.Matter _, _, _ | _, M.Matter _, _ | _, _, M.Matter _ -> invalid_arg "Modellib.Groves().vertices: lone matter field!" | _, _, _ -> [(inject 0 f1, inject 0 f2, inject 0 f3), v, c] let clone4 ((f1, f2, f3, f4), v, c) = match M.field f1, M.field f2, M.field f3, M.field f4 with | M.Matter _, M.Matter _, M.Matter _, M.Matter _ -> invalid_arg "Modellib.Groves().vertices: four matter fields!" | M.Matter _, M.Matter _, M.Matter _, _ | M.Matter _, M.Matter _, _, M.Matter _ | M.Matter _, _, M.Matter _, M.Matter _ | _, M.Matter _, M.Matter _, M.Matter _ -> invalid_arg "Modellib.Groves().vertices: three matter fields!" | M.Matter f1', M.Matter f2', _, _ -> List.map (fun g -> ((M (f1', g), M (f2', g), inject 0 f3, inject 0 f4), v, c)) generations | M.Matter f1', _, M.Matter f3', _ -> List.map (fun g -> ((M (f1', g), inject 0 f2, M (f3', g), inject 0 f4), v, c)) generations | M.Matter f1', _, _, M.Matter f4' -> List.map (fun g -> ((M (f1', g), inject 0 f2, inject 0 f3, M (f4', g)), v, c)) generations | _, M.Matter f2', M.Matter f3', _ -> List.map (fun g -> ((inject 0 f1, M (f2', g), M (f3', g), inject 0 f4), v, c)) generations | _, M.Matter f2', _, M.Matter f4' -> List.map (fun g -> ((inject 0 f1, M (f2', g), inject 0 f3, M (f4', g)), v, c)) generations | _, _, M.Matter f3', M.Matter f4' -> List.map (fun g -> ((inject 0 f1, inject 0 f2, M (f3', g), M (f4', g)), v, c)) generations | M.Matter _, _, _, _ | _, M.Matter _, _, _ | _, _, M.Matter _, _ | _, _, _, M.Matter _ -> invalid_arg "Modellib.Groves().vertices: lone matter field!" | _, _, _, _ -> [(inject 0 f1, inject 0 f2, inject 0 f3, inject 0 f4), v, c] let clonen (fl, v, c) = match List.map M.field fl with | _ -> failwith "Modellib.Groves().vertices: incomplete" let vertices () = let vertices3, vertices4, verticesn = M.vertices () in (ThoList.flatmap clone3 vertices3, ThoList.flatmap clone4 vertices4, ThoList.flatmap clonen verticesn) let table = F.of_vertices (vertices ()) let fuse2 = F.fuse2 table let fuse3 = F.fuse3 table let fuse = F.fuse table (* \begin{dubious} The following (incomplete) alternative implementations are included for illustrative purposes only: \end{dubious} *) let injectl g fcl = List.map (fun (f, c) -> (inject g f, c)) fcl let alt_fuse2 f1 f2 = match f1, f2 with | M (f1', g1'), M (f2', g2') -> if g1' = g2' then injectl 0 (M.fuse2 (M.matter_field f1') (M.matter_field f2')) else [] | M (f1', g'), _ -> injectl g' (M.fuse2 (M.matter_field f1') (project f2)) | _, M (f2', g') -> injectl g' (M.fuse2 (project f1) (M.matter_field f2')) | _, _ -> injectl 0 (M.fuse2 (project f1) (project f2)) let alt_fuse3 f1 f2 f3 = match f1, f2, f3 with | M (f1', g1'), M (f2', g2'), M (f3', g3') -> invalid_arg "Modellib.Groves().fuse3: three matter fields!" | M (f1', g1'), M (f2', g2'), _ -> if g1' = g2' then injectl 0 (M.fuse3 (M.matter_field f1') (M.matter_field f2') (project f3)) else [] | M (f1', g1'), _, M (f3', g3') -> if g1' = g3' then injectl 0 (M.fuse3 (M.matter_field f1') (project f2) (M.matter_field f3')) else [] | _, M (f2', g2'), M (f3', g3') -> if g2' = g3' then injectl 0 (M.fuse3 (project f1) (M.matter_field f2') (M.matter_field f3')) else [] | M (f1', g'), _, _ -> injectl g' (M.fuse3 (M.matter_field f1') (project f2) (project f3)) | _, M (f2', g'), _ -> injectl g' (M.fuse3 (project f1) (M.matter_field f2') (project f3)) | _, _, M (f3', g') -> injectl g' (M.fuse3 (project f1) (project f2) (M.matter_field f3')) | _, _, _ -> injectl 0 (M.fuse3 (project f1) (project f2) (project f3)) end (* \thocwmodulesection{MSM With Cloned Families} *) module SM_clones = Groves(SM(SM_no_anomalous)) Index: trunk/omega/src/omega_SM_Majorana_legacy.ml =================================================================== --- trunk/omega/src/omega_SM_Majorana_legacy.ml (revision 8491) +++ trunk/omega/src/omega_SM_Majorana_legacy.ml (revision 8492) @@ -1,36 +1,36 @@ (* omega_SM_Maj.ml -- - Copyright (C) 1999-2019 by + Copyright (C) 1999-2020 by Wolfgang Kilian Thorsten Ohl Juergen Reuter with contributions from Christian Speckner WHIZARD 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 2, or (at your option) any later version. WHIZARD 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, write to the Free Software Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. *) module O = Omega.Make (Fusion_vintage.Mixed23_Majorana)(Targets.Fortran_Majorana) (Modellib_SM.SM(Modellib_SM.SM_no_anomalous)) let _ = O.main () (*i * Local Variables: * mode:caml * indent-tabs-mode:nil * page-delimiter:"^(\\* .*\n" * End: i*) Index: trunk/omega/src/dirac.mli =================================================================== --- trunk/omega/src/dirac.mli (revision 8491) +++ trunk/omega/src/dirac.mli (revision 8492) @@ -1,71 +1,76 @@ (* dirac.mli -- Copyright (C) 1999-2017 by Wolfgang Kilian Thorsten Ohl Juergen Reuter with contributions from Christian Speckner WHIZARD 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 2, or (at your option) any later version. WHIZARD 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, write to the Free Software Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. *) (* \thocwmodulesection{Dirac $\gamma$-matrices} *) module type T = sig (* Matrices with complex rational entries. *) type qc = Algebra.QC.t type t = qc array array (* Complex rational constants. *) val zero : qc val one : qc val minus_one : qc val i : qc val minus_i : qc (* Basic $\gamma$-matrices. *) val unit : t val null : t val gamma0 : t val gamma1 : t val gamma2 : t val gamma3 : t val gamma5 : t (* $(\gamma_0,\gamma_1,\gamma_2,\gamma_3)$ *) val gamma : t array (* Charge conjugation *) val cc : t (* Algebraic operations on $\gamma$-matrices *) val neg : t -> t val add : t -> t -> t val sub : t -> t -> t val mul : t -> t -> t val times : qc -> t -> t val transpose : t -> t val adjoint : t -> t val conj : t -> t val product : t list -> t + (* Toplevel *) + val pp : Format.formatter -> t -> unit + (* Unit tests *) val test_suite : OUnit.test end module Chiral : T +module Dirac : T +module Majorana : T Index: trunk/omega/src/compare_majorana.sh =================================================================== --- trunk/omega/src/compare_majorana.sh (revision 8491) +++ trunk/omega/src/compare_majorana.sh (revision 8492) @@ -1,42 +1,43 @@ #! /bin/sh ######################################################################## # This script is for developers only and needs not to be portable. # This script takes TO's directory structure for granted. ######################################################################## # tl;dr : don't try this at home, kids ;) ######################################################################## case "$#" in 2) mode="$1" process="$2" ;; *) echo "usage: $0 [-scatter|-decay] process" 1>&2 exit 2 ;; esac jobs=12 width=1000 width=80 root=$HOME/physics/whizard build=$root/_build/default OCAMLFLAGS="-w -D -warn-error +P" make OCAMLFLAGS="$OCAMLFLAGS" -j $jobs -C $build/omega/src || exit 1 make -j $jobs -C $build/omega/bin \ omega_SM.opt omega_SM_Majorana.opt || exit 1 omega_dirac="$build/omega/bin/omega_SM.opt -target:width $width" omega_majorana="$build/omega/bin/omega_SM_Majorana.opt -target:width $width" $omega_dirac "$mode" "$process" > omega_amplitude_dirac.f90 2>/dev/null $omega_majorana "$mode" "$process" > omega_amplitude_majorana.f90 2>/dev/null if grep -q 'integer, parameter :: n_prt = 0' omega_amplitude_dirac.f90; then echo "O'Mega Dirac empty: $mode $process" 1>&2; elif grep -q 'integer, parameter :: n_prt = 0' omega_amplitude_majorana.f90; then echo "O'Mega Majorana empty: $mode $process" 1>&2; else - diff -u omega_amplitude_dirac.f90 omega_amplitude_majorana.f90 + wdiff -n omega_amplitude_dirac.f90 omega_amplitude_majorana.f90 \ + | colordiff --difftype=wdiff | sed 's/\({+\|+}\|\[-\|-\]\)//g' fi Index: trunk/omega/src/UFO_targets.ml =================================================================== --- trunk/omega/src/UFO_targets.ml (revision 8491) +++ trunk/omega/src/UFO_targets.ml (revision 8492) @@ -1,1384 +1,1551 @@ (* UFO_targets.ml -- Copyright (C) 1999-2017 by Wolfgang Kilian Thorsten Ohl Juergen Reuter with contributions from Christian Speckner WHIZARD 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 2, or (at your option) any later version. WHIZARD 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, write to the Free Software Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. *) let (@@) f g x = f (g x) (* \thocwmodulesection{Generating Code for UFO Lorentz Structures} *) (* O'Caml before 4.02 had a module typing bug that forces us to put this definition outside [Lorentz_Fusion]. *) module Q = Algebra.Q module QC = Algebra.QC module type T = sig (* [lorentz formatter name spins v] writes a representation of the Lorentz structure [v] of particles with the Lorentz representations [spins] as a (Fortran) function [name] to [formatter]. *) val lorentz : Format_Fortran.formatter -> string -> Coupling.lorentz array -> UFO_Lorentz.t -> unit val propagator : Format_Fortran.formatter -> string -> string -> string list -> Coupling.lorentz * Coupling.lorentz -> UFO_Lorentz.t -> UFO_Lorentz.t -> unit val fusion_name : string -> Permutation.Default.t -> Coupling.fermion_lines -> string val fuse : Algebra.QC.t -> string -> Coupling.lorentzn -> Coupling.fermion_lines -> string -> string list -> string list -> Coupling.fusen -> unit val eps4_g4_g44_decl : Format_Fortran.formatter -> unit -> unit val eps4_g4_g44_init : Format_Fortran.formatter -> unit -> unit val inner_product_functions : Format_Fortran.formatter -> unit -> unit module type Test = sig val suite : OUnit.test end module Test : Test end module Fortran : T = struct open Format_Fortran let pp_divide ?(indent=0) ff () = fprintf ff "%*s! %s" indent "" (String.make (70 - indent) '-'); pp_newline ff () let conjugate = function | Coupling.Spinor -> Coupling.ConjSpinor | Coupling.ConjSpinor -> Coupling.Spinor | r -> r let spin_mnemonic = function | Coupling.Scalar -> "phi" | Coupling.Spinor -> "psi" | Coupling.ConjSpinor -> "psibar" | Coupling.Majorana -> "chi" | Coupling.Maj_Ghost -> invalid_arg "UFO_targets: Maj_Ghost" | Coupling.Vector -> "a" | Coupling.Massive_Vector -> "v" | Coupling.Vectorspinor -> "grav" (* itino *) | Coupling.Tensor_1 -> invalid_arg "UFO_targets: Tensor_1" | Coupling.Tensor_2 -> "h" | Coupling.BRS l -> invalid_arg "UFO_targets: BRS" let fortran_type = function | Coupling.Scalar -> "complex(kind=default)" | Coupling.Spinor -> "type(spinor)" | Coupling.ConjSpinor -> "type(conjspinor)" | Coupling.Majorana -> "type(bispinor)" | Coupling.Maj_Ghost -> invalid_arg "UFO_targets: Maj_Ghost" | Coupling.Vector -> "type(vector)" | Coupling.Massive_Vector -> "type(vector)" | Coupling.Vectorspinor -> "type(vectorspinor)" | Coupling.Tensor_1 -> invalid_arg "UFO_targets: Tensor_1" | Coupling.Tensor_2 -> "type(tensor)" | Coupling.BRS l -> invalid_arg "UFO_targets: BRS" (* The \texttt{omegalib} separates time from space. Maybe not a good idea after all. Mend it locally \ldots *) type wf = { pos : int; spin : Coupling.lorentz; name : string; local_array : string option; momentum : string; momentum_array : string; fortran_type : string } let wf_table spins = Array.mapi (fun i s -> let spin = if i = 0 then conjugate s else s in let pos = succ i in let i = string_of_int pos in let name = spin_mnemonic s ^ i in let local_array = begin match spin with | Coupling.Vector | Coupling.Massive_Vector -> Some (name ^ "a") | _ -> None end in { pos; spin; name; local_array; momentum = "k" ^ i; momentum_array = "p" ^ i; fortran_type = fortran_type spin } ) spins module L = UFO_Lorentz (* Format rational ([Q.t]) and complex rational ([QC.t]) numbers as fortran values. *) let format_rational q = if Q.is_integer q then string_of_int (Q.to_integer q) else let n, d = Q.to_ratio q in Printf.sprintf "%d.0_default/%d" n d let format_complex_rational cq = let real = QC.real cq and imag = QC.imag cq in if Q.is_null imag then begin if Q.is_negative real then "(" ^ format_rational real ^ ")" else format_rational real end else if Q.is_integer real && Q.is_integer imag then Printf.sprintf "(%d,%d)" (Q.to_integer real) (Q.to_integer imag) else Printf.sprintf "cmplx(%s,%s,kind=default)" (format_rational real) (format_rational imag) (* Optimize the representation if used as a prefactor of a summand in a sum. *) let format_rational_factor q = if Q.is_unit q then "+ " else if Q.is_unit (Q.neg q) then "- " else if Q.is_negative q then "- " ^ format_rational (Q.neg q) ^ "*" else "+ " ^ format_rational q ^ "*" let format_complex_rational_factor cq = let real = QC.real cq and imag = QC.imag cq in if Q.is_null imag then begin if Q.is_unit real then "+ " else if Q.is_unit (Q.neg real) then "- " else if Q.is_negative real then "- " ^ format_rational (Q.neg real) ^ "*" else "+ " ^ format_rational real ^ "*" end else if Q.is_integer real && Q.is_integer imag then Printf.sprintf "+ (%d,%d)*" (Q.to_integer real) (Q.to_integer imag) else Printf.sprintf "+ cmplx(%s,%s,kind=default)*" (format_rational real) (format_rational imag) (* Append a formatted list of indices to [name]. *) let append_indices name = function | [] -> name | indices -> name ^ "(" ^ String.concat "," (List.map string_of_int indices) ^ ")" (* Dirac string variables and their names. *) type dsv = | Ket of int | Bra of int | Braket of int let dsv_name = function | Ket n -> Printf.sprintf "ket%02d" n | Bra n -> Printf.sprintf "bra%02d" n | Braket n -> Printf.sprintf "bkt%02d" n let dirac_dimension dsv indices = let tail ilist = String.concat "," (List.map (fun _ -> "0:3") ilist) ^ ")" in match dsv, indices with | Braket _, [] -> "" | (Ket _ | Bra _), [] -> ", dimension(1:4)" | Braket _, indices -> ", dimension(" ^ tail indices | (Ket _ | Bra _), indices -> ", dimension(1:4," ^ tail indices (* Write Fortran code to [decl] and [eval]: apply the Dirac matrix [gamma] with complex rational entries to the spinor [ket] from the left. [ket] must be the name of a scalar variable and cannot be an array element. The result is stored in [dsv_name (Ket n)] which can have additional [indices]. Return [Ket n] for further processing. *) let dirac_ket_to_fortran_decl ff n indices = let printf fmt = fprintf ff fmt and nl = pp_newline ff in let dsv = Ket n in printf " @[<2>complex(kind=default)%s ::@ %s@]" (dirac_dimension dsv indices) (dsv_name dsv); nl () let dirac_ket_to_fortran_eval ff n indices gamma ket = let printf fmt = fprintf ff fmt and nl = pp_newline ff in let dsv = Ket n in for i = 0 to 3 do let name = append_indices (dsv_name dsv) (succ i :: indices) in - printf " @[<%d>%s = 0" (String.length name + 5) name; + printf " @[<%d>%s = 0" (String.length name + 4) name; for j = 0 to 3 do - if gamma.(i).(j) <> QC.null then + if not (QC.is_null gamma.(i).(j)) then printf "@ %s%s%%a(%d)" (format_complex_rational_factor gamma.(i).(j)) ket.name (succ j) done; printf "@]"; nl () done; dsv - (* The same as [dirac_bra_to_fortran], but apply the Dirac matrix + (* The same as [dirac_ket_to_fortran], but apply the Dirac matrix [gamma] to [bra] from the right and return [Bra n]. *) let dirac_bra_to_fortran_decl ff n indices = let printf fmt = fprintf ff fmt and nl = pp_newline ff in let dsv = Bra n in printf " @[<2>complex(kind=default)%s ::@ %s@]" (dirac_dimension dsv indices) (dsv_name dsv); nl () let dirac_bra_to_fortran_eval ff n indices bra gamma = let printf fmt = fprintf ff fmt and nl = pp_newline ff in let dsv = Bra n in for j = 0 to 3 do let name = append_indices (dsv_name dsv) (succ j :: indices) in - printf " @[<%d>%s = 0" (String.length name + 5) name; + printf " @[<%d>%s = 0" (String.length name + 4) name; for i = 0 to 3 do - if gamma.(i).(j) <> QC.null then + if not (QC.is_null gamma.(i).(j)) then printf "@ %s%s%%a(%d)" (format_complex_rational_factor gamma.(i).(j)) bra.name (succ i) done; printf "@]"; nl () done; dsv (* More of the same, but evaluating a spinor sandwich and returning [Braket n]. *) let dirac_braket_to_fortran_decl ff n indices = let printf fmt = fprintf ff fmt and nl = pp_newline ff in let dsv = Braket n in printf " @[<2>complex(kind=default)%s ::@ %s@]" (dirac_dimension dsv indices) (dsv_name dsv); nl () let dirac_braket_to_fortran_eval ff n indices bra gamma ket = let printf fmt = fprintf ff fmt and nl = pp_newline ff in let dsv = Braket n in let name = append_indices (dsv_name dsv) indices in - printf " @[<%d>%s = 0" (String.length name + 5) name; + printf " @[<%d>%s = 0" (String.length name + 4) name; for i = 0 to 3 do for j = 0 to 3 do - if gamma.(i).(j) <> QC.null then + if not (QC.is_null gamma.(i).(j)) then printf "@ %s%s%%a(%d)*%s%%a(%d)" (format_complex_rational_factor gamma.(i).(j)) bra.name (succ i) ket.name (succ j) done done; printf "@]"; nl (); dsv (* Choose among the previous functions according to the position of [bra] and [ket] among the wavefunctions. If any is in the first position evaluate the spinor expression with the corresponding spinor removed, otherwise evaluate the spinir sandwich. *) let dirac_bra_or_ket_to_fortran_decl ff n indices bra ket = if bra = 1 then dirac_ket_to_fortran_decl ff n indices else if ket = 1 then dirac_bra_to_fortran_decl ff n indices else dirac_braket_to_fortran_decl ff n indices let dirac_bra_or_ket_to_fortran_eval ff n indices wfs bra gamma ket = if bra = 1 then dirac_ket_to_fortran_eval ff n indices gamma wfs.(pred ket) else if ket = 1 then dirac_bra_to_fortran_eval ff n indices wfs.(pred bra) gamma else dirac_braket_to_fortran_eval ff n indices wfs.(pred bra) gamma wfs.(pred ket) (* UFO summation indices are negative integers. Derive a valid Fortran variable name. *) let prefix_summation = "mu" let prefix_polarization = "nu" let index_spinor = "alpha" let index_tensor = "nu" let index_variable mu = if mu < 0 then Printf.sprintf "%s%d" prefix_summation (- mu) else if mu == 0 then prefix_polarization else Printf.sprintf "%s%d" prefix_polarization mu let format_indices indices = String.concat "," (List.map index_variable indices) module IntPM = Partial.Make (struct type t = int let compare = compare end) type tensor = | DS of dsv | V of string | T of UFOx.Lorentz_Atom.vector | S of UFOx.Lorentz_Atom.scalar | Inv of UFOx.Lorentz_Atom.scalar (* Transform the Dirac strings if we have Majorana fermions involved, in order to implement the algorithm from JRR's thesis. NB: The following is for reference only, to better understand what JRR was doing\ldots *) (* If the vertex is (suppressing the Lorentz indices of~$\phi_2$ and~$\Gamma$) \begin{equation} - \bar\psi_1 \Gamma\phi_2 \psi_3 - = \Gamma_{\alpha\beta} \bar\psi_{1,\alpha} \phi_2 \psi_{3,\beta}\,, + \label{eq:FVF-Vertex} + \bar\psi \Gamma\phi \psi + = \Gamma_{\alpha\beta} \bar\psi_{\alpha} \phi \psi_{\beta} \end{equation} + (cf.~[Coupling.FBF] in the hardcoded O'Mega models), then this is the version implemented by [fuse] below. *) let tho_print_dirac_current f c wf1 wf2 fusion = match fusion with - | [1; 3] -> printf "%s_ff(%s,%s,%s)" f c wf1 wf2 (* $\Gamma_{\alpha\beta} \bar\psi_{1,\alpha} \psi_{3,\beta}$ *) - | [3; 1] -> printf "%s_ff(%s,%s,%s)" f c wf2 wf1 (* $\Gamma_{\alpha\beta} \bar\psi_{1,\alpha} \psi_{3,\beta}$ *) - | [2; 3] -> printf "f_%sf(%s,%s,%s)" f c wf1 wf2 (* $\Gamma_{\alpha\beta} \phi_2 \psi_{3,\beta}$ *) - | [3; 2] -> printf "f_%sf(%s,%s,%s)" f c wf2 wf1 (* $\Gamma_{\alpha\beta} \phi_2 \psi_{3,\beta}$ *) + | [1; 3] -> printf "%s_ff(%s,%s,%s)" f c wf1 wf2 (* $\Gamma_{\alpha\beta} \bar\psi_{1,\alpha} \psi_{2,\beta}$ *) + | [3; 1] -> printf "%s_ff(%s,%s,%s)" f c wf2 wf1 (* $\Gamma_{\alpha\beta} \bar\psi_{1,\alpha} \psi_{2,\beta}$ *) + | [2; 3] -> printf "f_%sf(%s,%s,%s)" f c wf1 wf2 (* $\Gamma_{\alpha\beta} \phi_1 \psi_{2,\beta}$ *) + | [3; 2] -> printf "f_%sf(%s,%s,%s)" f c wf2 wf1 (* $\Gamma_{\alpha\beta} \phi_1 \psi_{2,\beta}$ *) | [1; 2] -> printf "f_f%s(%s,%s,%s)" f c wf1 wf2 (* $\Gamma_{\alpha\beta} \bar\psi_{1,\alpha} \phi_2$ *) | [2; 1] -> printf "f_f%s(%s,%s,%s)" f c wf2 wf1 (* $\Gamma_{\alpha\beta} \bar\psi_{1,\alpha} \phi_2$ *) | _ -> () + (* The corresponding UFO [fuse] exchanges the arguments in the case + of two fermions. This is the natural choice for cyclic permutations. *) + + let tho_print_FBF_current f c wf1 wf2 fusion = + match fusion with + | [3; 1] -> printf "f%sf_p120(%s,%s,%s)" f c wf1 wf2 (* $\Gamma_{\alpha\beta} \psi_{1,\beta} \bar\psi_{2,\alpha}$ *) + | [1; 3] -> printf "f%sf_p120(%s,%s,%s)" f c wf2 wf1 (* $\Gamma_{\alpha\beta} \psi_{1,\beta} \bar\psi_{2,\alpha}$ *) + | [2; 3] -> printf "f%sf_p012(%s,%s,%s)" f c wf1 wf2 (* $\Gamma_{\alpha\beta} \phi_1 \psi_{2,\beta}$ *) + | [3; 2] -> printf "f%sf_p012(%s,%s,%s)" f c wf2 wf1 (* $\Gamma_{\alpha\beta} \phi_1 \psi_{2,\beta}$ *) + | [1; 2] -> printf "f%sf_p201(%s,%s,%s)" f c wf1 wf2 (* $\Gamma_{\alpha\beta} \bar\psi_{1,\alpha} \phi_2$ *) + | [2; 1] -> printf "f%sf_p201(%s,%s,%s)" f c wf2 wf1 (* $\Gamma_{\alpha\beta} \bar\psi_{1,\alpha} \phi_2$ *) + | _ -> () + (* This is how JRR implemented (see subsection~\ref{sec:dirac-matrices-jrr}) the Dirac matrices that don't change sign under $C\Gamma^T C^{-1} = \Gamma$, i.\,e.~$\mathbf{1}$, $\gamma_5$ and~$\gamma_5\gamma_\mu$ (see [Targets.Fortran_Majorana_Fermions.print_fermion_current]) \begin{itemize} \item In the case of two fermions, the second wave - function [wf2] is always put into the right slot, + function [wf2] is always put into the second slot, as described in JRR's thesis. \label{pg:JRR-Fusions} \item In the case of a boson and a fermion, there is no need for both ["f_%sf"] and ["f_f%s"], since the latter can be obtained by exchanging arguments. \end{itemize} *) let jrr_print_majorana_current_S_P_A f c wf1 wf2 fusion = match fusion with | [1; 3] -> printf "%s_ff(%s,%s,%s)" f c wf1 wf2 (* - $(C\Gamma)_{\alpha\beta} \bar\psi_{1,\alpha} \psi_{3,\beta} \cong + $(C\Gamma)_{\alpha\beta} \bar\psi_{1,\alpha} \psi_{2,\beta} \cong C\Gamma $ *) | [3; 1] -> printf "%s_ff(%s,%s,%s)" f c wf1 wf2 (* - $(C\Gamma)_{\alpha\beta} \psi_{3,\alpha} \bar\psi_{1,\beta} \cong + $(C\Gamma)_{\alpha\beta} \psi_{1,\alpha} \bar\psi_{2,\beta} \cong C\Gamma = C\,C\Gamma^T C^{-1} $ *) | [2; 3] -> printf "f_%sf(%s,%s,%s)" f c wf1 wf2 (* - $\Gamma_{\alpha\beta} \phi_2 \psi_{3,\beta} \cong + $\Gamma_{\alpha\beta} \phi_1 \psi_{2,\beta} \cong \Gamma $ *) | [3; 2] -> printf "f_%sf(%s,%s,%s)" f c wf2 wf1 (* - $\Gamma_{\alpha\beta} \phi_2 \psi_{3,\beta} \cong + $\Gamma_{\alpha\beta} \phi_1 \psi_{2,\beta} \cong \Gamma $ *) | [1; 2] -> printf "f_%sf(%s,%s,%s)" f c wf2 wf1 (* - $\Gamma_{\alpha\beta} \phi_2 \bar\psi_{1,\beta} \cong + $\Gamma_{\alpha\beta} \phi_1 \bar\psi_{2,\beta} \cong \Gamma = C\Gamma^T C^{-1} $ *) | [2; 1] -> printf "f_%sf(%s,%s,%s)" f c wf1 wf2 (* - $\Gamma_{\alpha\beta} \phi_2 \bar\psi_{1,\beta} \cong + $\Gamma_{\alpha\beta} \phi_1 \bar\psi_{2,\beta} \cong \Gamma = C\Gamma^T C^{-1} $ *) | _ -> () (* This is how JRR implemented the Dirac matrices that do change sign under $C\Gamma^T C^{-1} = - \Gamma$, i.\,e.~$\gamma_\mu$ and~$\sigma_{\mu\nu}$ (see [Targets.Fortran_Majorana_Fermions.print_fermion_current_vector]). *) let jrr_print_majorana_current_V f c wf1 wf2 fusion = match fusion with | [1; 3] -> printf "%s_ff( %s,%s,%s)" f c wf1 wf2 (* - $ (C\Gamma)_{\alpha\beta} \bar\psi_{1,\alpha} \psi_{3,\beta} \cong + $ (C\Gamma)_{\alpha\beta} \bar\psi_{1,\alpha} \psi_{2,\beta} \cong C\Gamma $ *) | [3; 1] -> printf "%s_ff(-%s,%s,%s)" f c wf1 wf2 (* - $-(C\Gamma)_{\alpha\beta} \psi_{3,\alpha} \bar\psi_{1,\beta} \cong + $-(C\Gamma)_{\alpha\beta} \psi_{1,\alpha} \bar\psi_{2,\beta} \cong -C\Gamma = C\,C\Gamma^T C^{-1} $ *) | [2; 3] -> printf "f_%sf( %s,%s,%s)" f c wf1 wf2 (* - $ \Gamma_{\alpha\beta} \phi_2 \psi_{3,\beta} \cong + $ \Gamma_{\alpha\beta} \phi_1 \psi_{2,\beta} \cong \Gamma $ *) | [3; 2] -> printf "f_%sf( %s,%s,%s)" f c wf2 wf1 (* - $ \Gamma_{\alpha\beta} \phi_2 \psi_{3,\beta} \cong + $ \Gamma_{\alpha\beta} \phi_1 \psi_{2,\beta} \cong \Gamma $ *) | [1; 2] -> printf "f_%sf(-%s,%s,%s)" f c wf2 wf1 (* - $-\Gamma_{\alpha\beta} \phi_2 \bar\psi_{1,\beta} \cong + $-\Gamma_{\alpha\beta} \phi_1 \bar\psi_{2,\beta} \cong -\Gamma = C\Gamma^T C^{-1} $ *) | [2; 1] -> printf "f_%sf(-%s,%s,%s)" f c wf1 wf2 (* - $-\Gamma_{\alpha\beta} \phi_2 \bar\psi_{1,\beta} \cong + $-\Gamma_{\alpha\beta} \phi_1 \bar\psi_{2,\beta} \cong -\Gamma = C\Gamma^T C^{-1} $ *) | _ -> () (* These two can be unified, if the \texttt{\_c} functions implement~$\Gamma'=C\Gamma^T C^{-1}$, but we \emph{must} make sure that the multiplication with~$C$ from the left happens \emph{after} the transformation~$\Gamma\to\Gamma'$. *) let jrr_print_majorana_current f c wf1 wf2 fusion = match fusion with | [1; 3] -> printf "%s_ff (%s,%s,%s)" f c wf1 wf2 (* - $ (C\Gamma)_{\alpha\beta} \bar\psi_{1,\alpha} \psi_{3,\beta} \cong + $ (C\Gamma)_{\alpha\beta} \bar\psi_{1,\alpha} \psi_{2,\beta} \cong C\Gamma $ *) | [3; 1] -> printf "%s_ff_c(%s,%s,%s)" f c wf1 wf2 (* - $(C\Gamma')_{\alpha\beta} \psi_{3,\alpha} \bar\psi_{1,\beta} \cong + $(C\Gamma')_{\alpha\beta} \psi_{1,\alpha} \bar\psi_{2,\beta} \cong C\Gamma' = C\,C\Gamma^T C^{-1} $ *) | [2; 3] -> printf "f_%sf (%s,%s,%s)" f c wf1 wf2 (* - $ \Gamma_{\alpha\beta} \phi_2 \psi_{3,\beta} \cong + $ \Gamma_{\alpha\beta} \phi_1 \psi_{2,\beta} \cong \Gamma $ *) | [3; 2] -> printf "f_%sf (%s,%s,%s)" f c wf2 wf1 (* - $ \Gamma_{\alpha\beta} \phi_2 \psi_{3,\beta} \cong + $ \Gamma_{\alpha\beta} \phi_1 \psi_{2,\beta} \cong \Gamma $ *) | [1; 2] -> printf "f_%sf_c(%s,%s,%s)" f c wf2 wf1 (* - $\Gamma'_{\alpha\beta} \phi_2 \bar\psi_{1,\beta} \cong + $\Gamma'_{\alpha\beta} \phi_1 \bar\psi_{2,\beta} \cong \Gamma' = C\Gamma^T C^{-1} $ *) | [2; 1] -> printf "f_%sf_c(%s,%s,%s)" f c wf1 wf2 (* - $\Gamma'_{\alpha\beta} \phi_2 \bar\psi_{1,\beta} \cong + $\Gamma'_{\alpha\beta} \phi_1 \bar\psi_{2,\beta} \cong \Gamma' = C\Gamma^T C^{-1} $ *) | _ -> () (* Since we may assume~$C^{-1}=-C=C^T$, this can be rewritten if the \texttt{\_c} functions implement \begin{equation} \Gamma^{\prime\,T} = \left(C\Gamma^T C^{-1}\right)^T - = \left(C^{-1}\right)^T \Gamma \left(C\right)^T + = \left(C^{-1}\right)^T \Gamma C^T = C \Gamma C^{-1} \end{equation} instead. *) + let jrr_print_majorana_current_transposing f c wf1 wf2 fusion = match fusion with | [1; 3] -> printf "%s_ff (%s,%s,%s)" f c wf1 wf2 (* - $ (C\Gamma)_{\alpha\beta} \bar\psi_{1,\alpha} \psi_{3,\beta} \cong + $ (C\Gamma)_{\alpha\beta} \bar\psi_{1,\alpha} \psi_{2,\beta} \cong C\Gamma $ *) | [3; 1] -> printf "%s_ff_c(%s,%s,%s)" f c wf2 wf1 (* - $(C\Gamma')^T_{\alpha\beta} - \bar\psi_{1,\alpha} \psi_{3,\beta} \cong + $(C\Gamma')^T_{\alpha\beta} \bar\psi_{1,\alpha} \psi_{2,\beta} \cong (C\Gamma')^T = - C\Gamma $ *) | [2; 3] -> printf "f_%sf (%s,%s,%s)" f c wf1 wf2 (* - $ \Gamma_{\alpha\beta} \phi_2 \psi_{3,\beta} \cong + $ \Gamma_{\alpha\beta} \phi_1 \psi_{2,\beta} \cong \Gamma $ *) | [3; 2] -> printf "f_%sf (%s,%s,%s)" f c wf2 wf1 (* - $ \Gamma_{\alpha\beta} \phi_2 \psi_{3,\beta} \cong + $ \Gamma_{\alpha\beta} \phi_1 \psi_{2,\beta} \cong \Gamma $ *) | [1; 2] -> printf "f_f%s_c(%s,%s,%s)" f c wf1 wf2 (* $\Gamma^{\prime\,T}_{\alpha\beta} \bar\psi_{1,\alpha} \phi_2 \cong \Gamma^{\prime\,T} = C\Gamma C^{-1}$ *) | [2; 1] -> printf "f_f%s_c(%s,%s,%s)" f c wf2 wf1 (* $\Gamma^{\prime\,T}_{\alpha\beta} \bar\psi_{1,\alpha} \phi_2 \cong \Gamma^{\prime\,T} = C\Gamma C^{-1} $ *) | _ -> () (* where we have used \begin{equation} - (C\Gamma')^T = \Gamma^{\prime,T}C^T = C\Gamma C^{-1} C^T = - C\Gamma\,. + (C\Gamma')^T = \Gamma^{\prime,T}C^T + = C\Gamma C^{-1} C^T = C\Gamma C^{-1} (-C) = - C\Gamma\,. \end{equation} *) (* This puts the arguments in the same slots as [tho_print_dirac_current] above and can be implemented by [fuse], iff we inject the proper - transformations in [dennerize] below. *) + transformations in [dennerize] below. + We notice that we do \emph{not} need the conjugated version for + all combinations, but only for the case of two fermions. + In the two cases of one column spinor~$\psi$, only the original + version appears and in the two cases of one row spinor~$\bar\psi$, + only the conjugated version appears. *) + + (* Before we continue, we must however generalize from the + assumption~\eqref{eq:FVF-Vertex} that the fields in the + vertex are always ordered as in~[Coupling.FBF]. First, + even in this case the slots of the fermions must be exchanged + to accomodate the cyclic permutations. Therefore we exchange the + arguments of the [[1; 3]] and [[3; 1]] fusions. *) + + let jrr_print_majorana_FBF f c wf1 wf2 fusion = + match fusion with (* [fline = (3, 1)] *) + | [3; 1] -> printf "f%sf_p120_c(%s,%s,%s)" f c wf1 wf2 (* + $(C\Gamma')^T_{\alpha\beta} + \psi_{1,\beta} \bar\psi_{2,\alpha} \cong + (C\Gamma')^T = - C\Gamma $ *) + | [1; 3] -> printf "f%sf_p120 (%s,%s,%s)" f c wf2 wf1 (* + $ (C\Gamma)_{\alpha\beta} \psi_{1,\beta} \bar\psi_{2,\alpha} \cong + C\Gamma $ *) + | [2; 3] -> printf "f%sf_p012 (%s,%s,%s)" f c wf1 wf2 (* + $ \Gamma_{\alpha\beta} \phi_1 \psi_{2,\beta} \cong + \Gamma $ *) + | [3; 2] -> printf "f%sf_p012 (%s,%s,%s)" f c wf2 wf1 (* + $ \Gamma_{\alpha\beta} \phi_1 \psi_{2,\beta} \cong + \Gamma $ *) + | [1; 2] -> printf "f%sf_p201 (%s,%s,%s)" f c wf1 wf2 (* + $\Gamma^{\prime\,T}_{\alpha\beta} \bar\psi_{1,\alpha} \phi_2 \cong + \Gamma^{\prime\,T} = C\Gamma C^{-1}$ *) + | [2; 1] -> printf "f%sf_p201 (%s,%s,%s)" f c wf2 wf1 (* + $\Gamma^{\prime\,T}_{\alpha\beta} \bar\psi_{1,\alpha} \phi_2 \cong + \Gamma^{\prime\,T} = C\Gamma C^{-1} $ *) + | _ -> () + + (* The other two permutations: *) + + let jrr_print_majorana_FFB f c wf1 wf2 fusion = + match fusion with (* [fline = (1, 2)] *) + | [3; 1] -> printf "ff%s_p120 (%s,%s,%s)" f c wf1 wf2 (* + $ \Gamma_{\alpha\beta} \phi_1 \psi_{2,\beta} \cong + \Gamma $ *) + | [1; 3] -> printf "ff%s_p120 (%s,%s,%s)" f c wf2 wf1 (* + $ \Gamma_{\alpha\beta} \phi_1 \psi_{2,\beta} \cong + \Gamma $ *) + | [2; 3] -> printf "ff%s_p012 (%s,%s,%s)" f c wf1 wf2 (* + $\Gamma^{\prime\,T}_{\alpha\beta} \bar\psi_{1,\alpha} \phi_2 \cong + \Gamma^{\prime\,T} = C\Gamma C^{-1}$ *) + | [3; 2] -> printf "ff%s_p012 (%s,%s,%s)" f c wf2 wf1 (* + $\Gamma^{\prime\,T}_{\alpha\beta} \bar\psi_{1,\alpha} \phi_2 \cong + \Gamma^{\prime\,T} = C\Gamma C^{-1} $ *) + | [1; 2] -> printf "ff%s_p201 (%s,%s,%s)" f c wf1 wf2 (* + $ (C\Gamma)_{\alpha\beta} \psi_{1,\beta} \bar\psi_{2,\alpha} \cong + C\Gamma $ *) + | [2; 1] -> printf "ff%s_p201_c(%s,%s,%s)" f c wf2 wf1 (* + $(C\Gamma')^T_{\alpha\beta} + \psi_{1,\beta} \bar\psi_{2,\alpha} \cong + (C\Gamma')^T = - C\Gamma $ *) + | _ -> () + + let jrr_print_majorana_BFF f c wf1 wf2 fusion = + match fusion with (* [fline = (2, 3)] *) + | [3; 1] -> printf "%sff_p120 (%s,%s,%s)" f c wf1 wf2 (* + $\Gamma^{\prime\,T}_{\alpha\beta} \bar\psi_{1,\alpha} \phi_2 \cong + \Gamma^{\prime\,T} = C\Gamma C^{-1} $ *) + | [1; 3] -> printf "%sff_p120 (%s,%s,%s)" f c wf2 wf1 (* + $\Gamma^{\prime\,T}_{\alpha\beta} \bar\psi_{1,\alpha} \phi_2 \cong + \Gamma^{\prime\,T} = C\Gamma C^{-1}$ *) + | [2; 3] -> printf "%sff_p012 (%s,%s,%s)" f c wf1 wf2 (* + $ (C\Gamma)_{\alpha\beta} \psi_{1,\beta} \bar\psi_{2,\alpha} \cong + C\Gamma $ *) + | [3; 2] -> printf "%sff_p012_c(%s,%s,%s)" f c wf2 wf1 (* + $(C\Gamma')^T_{\alpha\beta} \psi_{1,\beta} \bar\psi_{2,\alpha} \cong + (C\Gamma')^T = - C\Gamma $ *) + | [1; 2] -> printf "%sff_p201 (%s,%s,%s)" f c wf1 wf2 (* + $ \Gamma_{\alpha\beta} \phi_1 \psi_{2,\beta} \cong + \Gamma $ *) + | [2; 1] -> printf "%sff_p201 (%s,%s,%s)" f c wf2 wf1 (* + $ \Gamma_{\alpha\beta} \phi_1 \psi_{2,\beta} \cong + \Gamma $ *) + | _ -> () + + (* \begin{dubious} + Now we want to test \emph{only} if the [fermion_line] + matches the inverted [fusion]. Why does [jrr_print_majorana_FBF] + differ from the others? Must be a typo. + \end{dubious} *) + + (* In the model, the necessary + information is provided as [Coupling.fermion_lines], encoded as + [(right,left)] in the usual direction of the lines. + E.\,g.~the case of~\eqref{eq:FVF-Vertex} is~[(3,1)]. + Equivalent information is available + as~[(ket, bra)] in [UFO_Lorentz.dirac_string]. *) let is_majorana = function | Coupling.Majorana | Coupling.Vectorspinor | Coupling.Maj_Ghost -> true | _ -> false let is_dirac = function | Coupling.Spinor | Coupling.ConjSpinor -> true | _ -> false let dennerize ~eval wfs atom = let printf fmt = fprintf eval fmt and nl = pp_newline eval in if is_majorana wfs.(pred atom.L.bra).spin || is_majorana wfs.(pred atom.L.ket).spin then if atom.L.bra = 1 then (* Fusing one or more bosons with a ket like fermion: $\chi \leftarrow \Gamma\chi$. *) (* Don't do anything, as per subsection~\ref{sec:dirac-matrices-jrr}. *) atom else if atom.L.ket = 1 then (* We fuse one or more bosons with a bra like fermion: $\bar\chi \leftarrow \bar\chi\Gamma$. *) - (* $\Gamma\to C\Gamma C^{-1}$. *) + (* $\Gamma\to C \Gamma C^{-1}$. *) begin let atom = L.conjugate atom in printf " ! conjugated for Majorana"; nl (); printf " ! %s" (L.dirac_string_to_string atom); nl (); atom end - else if atom.L.ket < atom.L.bra then + else if not atom.L.conjugated then (* We fuse zero or more bosons with a sandwich of fermions. $\phi \leftarrow \bar\chi\gamma\chi$.*) (* Multiply by~$C$ from the left, as per subsection~\ref{sec:dirac-matrices-jrr}. *) begin let atom = L.cc_times atom in printf " ! multiplied by CC for Majorana"; nl (); printf " ! %s" (L.dirac_string_to_string atom); nl (); atom end else (* Transposed: multiply by~$-C$ from the left. *) begin let atom = L.minus (L.cc_times atom) in - printf " ! multiplied by negative CC for Majorana"; nl (); + printf " ! multiplied by -CC for Majorana"; nl (); printf " ! %s" (L.dirac_string_to_string atom); nl (); atom end else atom (* Write the [i]th Dirac string [ds] as Fortran code to [eval], including a shorthand representation as a comment. Return [ds] with [ds.L.atom] replaced by the dirac string variable, i,\,e.~[DS dsv] annotated with the internal and external indices. In addition write the declaration to [decl]. *) let dirac_string_to_fortran ~decl ~eval i wfs ds = let printf fmt = fprintf eval fmt and nl = pp_newline eval in let bra = ds.L.atom.L.bra and ket = ds.L.atom.L.ket in pp_divide ~indent:4 eval (); printf " ! %s" (L.dirac_string_to_string ds.L.atom); nl (); let atom = dennerize ~eval wfs ds.L.atom in begin match ds.L.indices with | [] -> let gamma = L.dirac_string_to_matrix (fun _ -> 0) atom in dirac_bra_or_ket_to_fortran_decl decl i [] bra ket; let dsv = dirac_bra_or_ket_to_fortran_eval eval i [] wfs bra gamma ket in L.map_atom (fun _ -> DS dsv) ds | indices -> dirac_bra_or_ket_to_fortran_decl decl i indices bra ket; let combinations = Product.power (List.length indices) [0; 1; 2; 3] in let dsv = List.map (fun combination -> let substitution = IntPM.of_lists indices combination in let substitute = IntPM.apply substitution in let indices = List.map substitute indices in let gamma = L.dirac_string_to_matrix substitute atom in dirac_bra_or_ket_to_fortran_eval eval i indices wfs bra gamma ket) combinations in begin match ThoList.uniq (List.sort compare dsv) with | [dsv] -> L.map_atom (fun _ -> DS dsv) ds | _ -> failwith "dirac_string_to_fortran: impossible" end end (* Write the Dirac strings in the list [ds_list] as Fortran code to [eval], including shorthand representations as comments. Return the list of variables and corresponding indices to be contracted. *) let dirac_strings_to_fortran ~decl ~eval wfs last ds_list = List.fold_left (fun (i, acc) ds -> let i = succ i in (i, dirac_string_to_fortran ~decl ~eval i wfs ds :: acc)) (last, []) ds_list (* Perform a nested sum of terms, as printed by [print_term] (which takes the number of spaces to indent as only argument) of the cartesian product of [indices] running from 0 to 3. *) let nested_sums ~decl ~eval initial_indent indices print_term = let rec nested_sums' indent = function | [] -> print_term indent | index :: indices -> let var = index_variable index in fprintf eval "%*s@[<2>do %s = 0, 3@]" indent "" var; pp_newline eval (); nested_sums' (indent + 2) indices; pp_newline eval (); fprintf eval "%*s@[<2>end do@]" indent "" in nested_sums' (initial_indent + 2) indices (* Polarization indices also need to be summed over, but they appear only once. *) let indices_of_contractions contractions = let index_pairs, polarizations = L.classify_indices (ThoList.flatmap (fun ds -> ds.L.indices) contractions) in try ThoList.pairs index_pairs @ ThoList.uniq (List.sort compare polarizations) with | Invalid_argument s -> invalid_arg ("indices_of_contractions: " ^ ThoList.to_string string_of_int index_pairs) (*i Printf.eprintf "indices_of_contractions: %s / %s\n" (ThoList.to_string string_of_int index_pairs) (ThoList.to_string string_of_int polarizations); i*) let format_dsv dsv indices = match dsv, indices with | Braket _, [] -> dsv_name dsv | Braket _, ilist -> Printf.sprintf "%s(%s)" (dsv_name dsv) (format_indices indices) | (Bra _ | Ket _), [] -> Printf.sprintf "%s(%s)" (dsv_name dsv) index_spinor | (Bra _ | Ket _), ilist -> Printf.sprintf "%s(%s,%s)" (dsv_name dsv) index_spinor (format_indices indices) let denominator_name = "denom_" let mass_name = "m_" let width_name = "w_" let format_tensor t = let indices = t.L.indices in match t.L.atom with | DS dsv -> format_dsv dsv indices | V vector -> Printf.sprintf "%s(%s)" vector (format_indices indices) | T UFOx.Lorentz_Atom.P (mu, n) -> Printf.sprintf "p%d(%s)" n (index_variable mu) | T UFOx.Lorentz_Atom.Epsilon (mu1, mu2, mu3, mu4) -> Printf.sprintf "eps4_(%s)" (format_indices [mu1; mu2; mu3; mu4]) | T UFOx.Lorentz_Atom.Metric (mu1, mu2) -> if mu1 > 0 && mu2 > 0 then Printf.sprintf "g44_(%s)" (format_indices [mu1; mu2]) else failwith "format_tensor: compress_metrics has failed!" | S (UFOx.Lorentz_Atom.Mass _) -> mass_name | S (UFOx.Lorentz_Atom.Width _) -> width_name | S (UFOx.Lorentz_Atom.P2 i) -> Printf.sprintf "g2_(p%d)" i | S (UFOx.Lorentz_Atom.P12 (i, j)) -> Printf.sprintf "g12_(p%d,p%d)" i j | Inv (UFOx.Lorentz_Atom.Mass _) -> "1/" ^ mass_name | Inv (UFOx.Lorentz_Atom.Width _) -> "1/" ^ width_name | Inv (UFOx.Lorentz_Atom.P2 i) -> Printf.sprintf "1/g2_(p%d)" i | Inv (UFOx.Lorentz_Atom.P12 (i, j)) -> Printf.sprintf "1/g12_(p%d,p%d)" i j | S (UFOx.Lorentz_Atom.Variable s) -> s | Inv (UFOx.Lorentz_Atom.Variable s) -> "1/" ^ s | S (UFOx.Lorentz_Atom.Coeff c) -> UFOx.Value.to_string c | Inv (UFOx.Lorentz_Atom.Coeff c) -> "1/(" ^ UFOx.Value.to_string c ^ ")" let rec multiply_tensors ~decl ~eval = function | [] -> fprintf eval "1"; | [t] -> fprintf eval "%s" (format_tensor t) | t :: tensors -> fprintf eval "%s@,*" (format_tensor t); multiply_tensors ~decl ~eval tensors let pseudo_wfs_for_denominator = Array.init 2 (fun i -> let ii = string_of_int i in { pos = i; spin = Coupling.Scalar; name = denominator_name; local_array = None; momentum = "k" ^ ii; momentum_array = "p" ^ ii; fortran_type = fortran_type Coupling.Scalar }) let contract_indices ~decl ~eval indent wf_indices wfs (fusion, contractees) = let printf fmt = fprintf eval fmt and nl = pp_newline eval in let sum_var = begin match wf_indices with | [] -> wfs.(0).name | ilist -> let indices = String.concat "," ilist in begin match wfs.(0).local_array with | None -> let component = begin match wfs.(0).spin with | Coupling.Spinor | Coupling.ConjSpinor | Coupling.Majorana -> "a" | Coupling.Tensor_2 -> "t" | Coupling.Vector | Coupling.Massive_Vector -> failwith "contract_indices: expected local_array for vectors" | _ -> failwith "contract_indices: unexpected spin" end in Printf.sprintf "%s%%%s(%s)" wfs.(0).name component indices | Some a -> Printf.sprintf "%s(%s)" a indices end end in let indices = List.filter (fun i -> UFOx.Index.position i <> 1) (indices_of_contractions contractees) in nested_sums ~decl ~eval indent indices (fun indent -> printf "%*s@[<2>%s = %s" indent "" sum_var sum_var; printf "@ %s" (format_complex_rational_factor fusion.L.coeff); List.iter (fun i -> printf "@,g4_(%s)*" (index_variable i)) indices; printf "@,("; multiply_tensors ~decl ~eval contractees; printf ")"; begin match fusion.L.denominator with | [] -> () | d -> printf " / %s" denominator_name end; printf "@]"); printf "@]"; nl () let scalar_expression1 ~decl ~eval fusion = let printf fmt = fprintf eval fmt in match fusion.L.dirac, fusion.L.vector with | [], [] -> let scalars = List.map (fun t -> { L.atom = S t; L.indices = [] }) fusion.L.scalar and inverses = List.map (fun t -> { L.atom = Inv t; L.indices = [] }) fusion.L.inverse in let contractees = scalars @ inverses in printf "@ %s" (format_complex_rational_factor fusion.L.coeff); multiply_tensors ~decl ~eval contractees | _, [] -> invalid_arg "UFO_targets.Fortran.scalar_expression1: unexpected spinor indices" | [], _ -> invalid_arg "UFO_targets.Fortran.scalar_expression1: unexpected vector indices" | _, _ -> invalid_arg "UFO_targets.Fortran.scalar_expression1: unexpected indices" let scalar_expression ~decl ~eval indent name fusions = let printf fmt = fprintf eval fmt and nl = pp_newline eval in let sum_var = name in printf "%*s@[<2>%s =" indent "" sum_var; List.iter (scalar_expression1 ~decl ~eval) fusions; printf "@]"; nl () let local_vector_copies ~decl ~eval wfs = begin match wfs.(0).local_array with | None -> () | Some a -> fprintf decl " @[<2>complex(kind=default),@ dimension(0:3) ::@ %s@]" a; pp_newline decl () end; let n = Array.length wfs in for i = 1 to n - 1 do match wfs.(i).local_array with | None -> () | Some a -> fprintf decl " @[<2>complex(kind=default),@ dimension(0:3) ::@ %s@]" a; pp_newline decl (); fprintf eval " @[<2>%s(0) = %s%%t@]" a wfs.(i).name; pp_newline eval (); fprintf eval " @[<2>%s(1:3) = %s%%x@]" a wfs.(i).name; pp_newline eval () done let return_vector ff wfs = let printf fmt = fprintf ff fmt and nl = pp_newline ff in match wfs.(0).local_array with | None -> () | Some a -> pp_divide ~indent:4 ff (); printf " @[<2>%s%%t = %s(0)@]" wfs.(0).name a; nl (); printf " @[<2>%s%%x = %s(1:3)@]" wfs.(0).name a; nl () let multiply_coupling_and_scalars ff g_opt wfs = let printf fmt = fprintf ff fmt and nl = pp_newline ff in pp_divide ~indent:4 ff (); let g = match g_opt with | None -> "" | Some g -> g ^ "*" in let wfs0name = match wfs.(0).local_array with | None -> wfs.(0).name | Some a -> a in printf " @[<2>%s = %s%s" wfs0name g wfs0name; for i = 1 to Array.length wfs - 1 do match wfs.(i).spin with | Coupling.Scalar -> printf "@,*%s" wfs.(i).name | _ -> () done; printf "@]"; nl () let local_momentum_copies ~decl ~eval wfs = let n = Array.length wfs in fprintf decl " @[<2>real(kind=default),@ dimension(0:3) ::@ %s" wfs.(0).momentum_array; for i = 1 to n - 1 do fprintf decl ",@ %s" wfs.(i).momentum_array; fprintf eval " @[<2>%s(0) = %s%%t@]" wfs.(i).momentum_array wfs.(i).momentum; pp_newline eval (); fprintf eval " @[<2>%s(1:3) = %s%%x@]" wfs.(i).momentum_array wfs.(i).momentum; pp_newline eval () done; fprintf eval " @[<2>%s =" wfs.(0).momentum_array; for i = 1 to n - 1 do fprintf eval "@ - %s" wfs.(i).momentum_array done; fprintf decl "@]"; pp_newline decl (); fprintf eval "@]"; pp_newline eval () let contractees_of_fusion ~decl ~eval wfs (max_dsv, indices_seen, contractees) fusion = let max_dsv', dirac_strings = dirac_strings_to_fortran ~decl ~eval wfs max_dsv fusion.L.dirac and vectors = List.fold_left (fun acc wf -> match wf.spin, wf.local_array with | Coupling.Tensor_2, None -> { L.atom = V (Printf.sprintf "%s%d%%t" (spin_mnemonic wf.spin) wf.pos); L.indices = [UFOx.Index.pack wf.pos 1; UFOx.Index.pack wf.pos 2] } :: acc | _, None -> acc | _, Some a -> { L.atom = V a; L.indices = [wf.pos] } :: acc) [] (List.tl (Array.to_list wfs)) and tensors = List.map (L.map_atom (fun t -> T t)) fusion.L.vector and scalars = List.map (fun t -> { L.atom = S t; L.indices = [] }) fusion.L.scalar and inverses = List.map (fun t -> { L.atom = Inv t; L.indices = [] }) fusion.L.inverse in let contractees' = dirac_strings @ vectors @ tensors @ scalars @ inverses in let indices_seen' = Sets.Int.of_list (indices_of_contractions contractees') in (max_dsv', Sets.Int.union indices_seen indices_seen', (fusion, contractees') :: contractees) let local_name wf = match wf.local_array with | Some a -> a | None -> match wf.spin with | Coupling.Spinor | Coupling.ConjSpinor | Coupling.Majorana -> wf.name ^ "%a" | Coupling.Scalar -> wf.name | Coupling.Tensor_2 -> wf.name ^ "%t" | Coupling.Vector | Coupling.Massive_Vector -> failwith "UFO_targets.Fortran.local_name: unexpected spin 1" | _ -> failwith "UFO_targets.Fortran.local_name: unhandled spin" let external_wf_loop ~decl ~eval ~indent wfs (fusion, _ as contractees) = pp_divide ~indent eval (); fprintf eval "%*s! %s" indent "" (L.to_string [fusion]); pp_newline eval (); pp_divide ~indent eval (); begin match fusion.L.denominator with | [] -> () | denominator -> scalar_expression ~decl ~eval 4 denominator_name denominator end; match wfs.(0).spin with | Coupling.Scalar -> contract_indices ~decl ~eval 2 [] wfs contractees | Coupling.Spinor | Coupling.ConjSpinor | Coupling.Majorana -> let idx = index_spinor in fprintf eval "%*s@[<2>do %s = 1, 4@]" indent "" idx; pp_newline eval (); contract_indices ~decl ~eval 4 [idx] wfs contractees; fprintf eval "%*send do@]" indent ""; pp_newline eval () | Coupling.Vector | Coupling.Massive_Vector -> let idx = index_variable 1 in fprintf eval "%*s@[<2>do %s = 0, 3@]" indent "" idx; pp_newline eval (); contract_indices ~decl ~eval 4 [idx] wfs contractees; fprintf eval "%*send do@]" indent ""; pp_newline eval () | Coupling.Tensor_2 -> let idx1 = index_variable (UFOx.Index.pack 1 1) and idx2 = index_variable (UFOx.Index.pack 1 2) in fprintf eval "%*s@[<2>do %s = 0, 3@]" indent "" idx1; pp_newline eval (); fprintf eval "%*s@[<2>do %s = 0, 3@]" (indent + 2) "" idx2; pp_newline eval (); contract_indices ~decl ~eval 6 [idx1; idx2] wfs contractees; fprintf eval "%*send do@]" (indent + 2) ""; pp_newline eval (); fprintf eval "%*send do@]" indent ""; pp_newline eval () | Coupling.Vectorspinor -> failwith "external_wf_loop: Vectorspinor not supported yet!" | Coupling.Maj_Ghost -> failwith "external_wf_loop: unexpected Maj_Ghost" | Coupling.Tensor_1 -> failwith "external_wf_loop: unexpected Tensor_1" | Coupling.BRS _ -> failwith "external_wf_loop: unexpected BRS" let fusions_to_fortran ~decl ~eval wfs ?(denominator=[]) ?coupling fusions = local_vector_copies ~decl ~eval wfs; local_momentum_copies ~decl ~eval wfs; begin match denominator with | [] -> () | _ -> fprintf decl " @[<2>complex(kind=default) :: %s@]" denominator_name; pp_newline decl () end; let max_dsv, indices_used, contractions = List.fold_left (contractees_of_fusion ~decl ~eval wfs) (0, Sets.Int.empty, []) fusions in Sets.Int.iter (fun index -> fprintf decl " @[<2>integer ::@ %s@]" (index_variable index); pp_newline decl ()) indices_used; begin match wfs.(0).spin with | Coupling.Spinor | Coupling.ConjSpinor | Coupling.Majorana -> fprintf decl " @[<2>integer ::@ %s@]" index_spinor; pp_newline decl () | _ -> () end; pp_divide ~indent:4 eval (); let wfs0name = local_name wfs.(0) in fprintf eval " %s = 0" wfs0name; pp_newline eval (); List.iter (external_wf_loop ~decl ~eval ~indent:4 wfs) contractions; multiply_coupling_and_scalars eval coupling wfs; begin match denominator with | [] -> () | denominator -> pp_divide ~indent:4 eval (); fprintf eval "%*s! %s" 4 "" (L.to_string denominator); pp_newline eval (); scalar_expression ~decl ~eval 4 denominator_name denominator; fprintf eval " @[<2>%s =@ %s / %s@]" wfs0name wfs0name denominator_name; pp_newline eval () end; return_vector eval wfs (* TODO: eventually, we should include the momentum among the arguments only if required. But this can wait for another day. *) let lorentz ff name spins lorentz = let printf fmt = fprintf ff fmt and nl = pp_newline ff in let wfs = wf_table spins in let n = Array.length wfs in printf " @[<4>pure function %s@ (g,@ " name; for i = 1 to n - 2 do printf "%s,@ %s,@ " wfs.(i).name wfs.(i).momentum done; printf "%s,@ %s" wfs.(n - 1).name wfs.(n - 1).momentum; printf ")@ result (%s)@]" wfs.(0).name; nl (); printf " @[<2>%s ::@ %s@]" wfs.(0).fortran_type wfs.(0).name; nl(); printf " @[<2>complex(kind=default),@ intent(in) ::@ g@]"; nl(); for i = 1 to n - 1 do printf " @[<2>%s, intent(in) :: %s@]" wfs.(i).fortran_type wfs.(i).name; nl(); done; printf " @[<2>type(momentum), intent(in) ::@ %s" wfs.(1).momentum; for i = 2 to n - 1 do printf ",@ %s" wfs.(i).momentum done; printf "@]"; nl (); let width = 80 in (* get this from the default formatter instead! *) let decl_buf = Buffer.create 1024 and eval_buf = Buffer.create 1024 in let decl = formatter_of_buffer ~width decl_buf and eval = formatter_of_buffer ~width eval_buf in fusions_to_fortran ~decl ~eval ~coupling:"g" wfs lorentz; pp_flush decl (); pp_flush eval (); pp_divide ~indent:4 ff (); (*i printf " ! %s" (L.to_string lorentz); nl (); pp_divide ~indent:4 ff (); i*) printf "%s" (Buffer.contents decl_buf); pp_divide ~indent:4 ff (); printf " if (g == 0) then"; nl (); printf " call set_zero (%s)" wfs.(0).name; nl (); printf " return"; nl (); printf " end if"; nl (); pp_divide ~indent:4 ff (); printf "%s" (Buffer.contents eval_buf); printf " end function %s@]" name; nl (); Buffer.reset decl_buf; Buffer.reset eval_buf; () let use_variables ff parameter_module variables = let printf fmt = fprintf ff fmt and nl = pp_newline ff in match variables with | [] -> () | v :: v_list -> printf " @[<2>use %s, only: %s" parameter_module v; List.iter (fun s -> printf ", %s" s) v_list; printf "@]"; nl () let propagator ff name parameter_module variables (bra_spin, ket_spin) numerator denominator = let printf fmt = fprintf ff fmt and nl = pp_newline ff in let width = 80 in (* get this from the default formatter instead! *) let wf_name = spin_mnemonic ket_spin and wf_type = fortran_type ket_spin in let wfs = wf_table [| ket_spin; ket_spin |] in printf " @[<4>pure function pr_U_%s@ (k2, %s, %s, %s2)" name mass_name width_name wf_name; printf " result (%s1)@]" wf_name; nl (); use_variables ff parameter_module variables; printf " %s :: %s1" wf_type wf_name; nl (); printf " type(momentum), intent(in) :: k2"; nl (); printf " real(kind=default), intent(in) :: %s, %s" mass_name width_name; nl (); printf " %s, intent(in) :: %s2" wf_type wf_name; nl (); let decl_buf = Buffer.create 1024 and eval_buf = Buffer.create 1024 in let decl = formatter_of_buffer ~width decl_buf and eval = formatter_of_buffer ~width eval_buf in fusions_to_fortran ~decl ~eval wfs ~denominator numerator; pp_flush decl (); pp_flush eval (); pp_divide ~indent:4 ff (); printf "%s" (Buffer.contents decl_buf); pp_divide ~indent:4 ff (); printf "%s" (Buffer.contents eval_buf); printf " end function pr_U_%s@]" name; nl (); Buffer.reset decl_buf; Buffer.reset eval_buf; () let scale_coupling c g = if c = 1 then g else if c = -1 then "-" ^ g else Printf.sprintf "%d*%s" c g let scale_coupling z g = format_complex_rational_factor z ^ g (* As a prototypical example consider the vertex + \begin{subequations} + \label{eq:cyclic-UFO-fusions} \begin{equation} \bar\psi\fmslash{A}\psi = \tr\left(\psi\otimes\bar\psi\fmslash{A}\right) \end{equation} encoded as \texttt{FFV} in the SM UFO file. This example is useful, because all three fields have different type and we can use the Fortran compiler to check our implementation. In this case we need to generate the following function calls with the arguments in the following order \begin{center} \begin{tabular}{lcl} \texttt{F12}:&$\psi_1\bar\psi_2\to A$& \texttt{FFV\_p201(g,psi1,p1,psibar2,p2)} \\ \texttt{F21}:&$\bar\psi_1\psi_2\to A$& \texttt{FFV\_p201(g,psi2,p2,psibar1,p1)} \\ \texttt{F23}:&$\bar\psi_1 A_2 \to \bar\psi$& \texttt{FFV\_p012(g,psibar1,p1,A2,p2)} \\ \texttt{F32}:&$A_1\bar\psi_2 \to \bar\psi$& \texttt{FFV\_p012(g,psibar2,p2,A1,p1)} \\ \texttt{F31}:&$A_1\psi_2\to \psi$& \texttt{FFV\_p120(g,A1,p1,psi2,p2)} \\ \texttt{F13}:&$\psi_1A_2\to \psi$& \texttt{FFV\_p120(g,A2,p2,psi1,p1)} \end{tabular} \end{center} *) (* Fortunately, all Fermi signs have been taken care of by [Fusions] and we can concentrate on injecting the wave functions into the correct slots. *) + (* The other possible cases are + \begin{equation} + \bar\psi\fmslash{A}\psi + \end{equation} + which would be encoded as \texttt{FVF} in a UFO file + \begin{center} + \begin{tabular}{lcl} + \texttt{F12}:&$\bar\psi_1 A_2 \to \bar\psi$& + \texttt{FVF\_p201(g,psibar1,p1,A2,p2)} \\ + \texttt{F21}:&$A_1\bar\psi_2 \to \bar\psi$& + \texttt{FVF\_p201(g,psibar2,p2,A1,p1)} \\ + \texttt{F23}:&$A_1\psi_2\to \psi$& + \texttt{FVF\_p012(g,A1,p1,psi2,p2)} \\ + \texttt{F32}:&$\psi_1A_2\to \psi$& + \texttt{FVF\_p012(g,A2,p2,psi1,p1)} \\ + \texttt{F31}:&$\psi_1\bar\psi_2\to A$& + \texttt{FVF\_p120(g,psi1,p1,psibar2,p2)} \\ + \texttt{F13}:&$\bar\psi_1\psi_2\to A$& + \texttt{FVF\_p120(g,psi2,p2,psibar1,p1)} + \end{tabular} + \end{center} + and + \begin{equation} + \bar\psi\fmslash{A}\psi = + \tr\left(\fmslash{A}\psi\otimes\bar\psi\right)\,, + \end{equation} + corresponding to \texttt{VFF} + \begin{center} + \begin{tabular}{lcl} + \texttt{F12}:&$A_1\psi_2\to \psi$& + \texttt{VFF\_p201(g,A1,p1,psi2,p2)} \\ + \texttt{F21}:&$\psi_1A_2\to \psi$& + \texttt{VFF\_p201(g,A2,p2,psi1,p1)} \\ + \texttt{F23}:&$\psi_1\bar\psi_2\to A$& + \texttt{VFF\_p012(g,psi1,p1,psibar2,p2)} \\ + \texttt{F32}:&$\bar\psi_1\psi_2\to A$& + \texttt{VFF\_p012(g,psi2,p2,psibar1,p1)} \\ + \texttt{F31}:&$\bar\psi_1 A_2 \to \bar\psi$& + \texttt{VFF\_p120(g,psibar1,p1,A2,p2)} \\ + \texttt{F13}:&$A_1\bar\psi_2 \to \bar\psi$& + \texttt{VFF\_p120(g,psibar2,p2,A1,p1)} + \end{tabular} + \end{center} + \end{subequations} *) + (* \begin{dubious} - Eventually, we should use the reverted lists everywhere - to become a bit more efficient. + Once the Majorana code generation is fully debugged, + we should replace the lists by reverted lists everywhere + in order to become a bit more efficient. \end{dubious} *) module P = Permutation.Default let factor_cyclic f12__n = let f12__, fn = ThoList.split_last f12__n in let cyclic = ThoList.cycle_until fn (List.sort compare f12__n) in (P.of_list (List.map pred cyclic), P.of_lists (List.tl cyclic) f12__) let ccs_to_string ccs = String.concat "" (List.map (fun (f, i) -> Printf.sprintf "_c%x%x" i f) ccs) let fusion_name v perm ccs = Printf.sprintf "%s_p%s%s" v (P.to_string perm) (ccs_to_string ccs) let fuse_dirac c v s fl g wfs ps fusion = let g = scale_coupling c g and cyclic, factor = factor_cyclic fusion in let wfs_ps = List.map2 (fun wf p -> (wf, p)) wfs ps in let args = P.list (P.inverse factor) wfs_ps in let args_string = String.concat "," (List.map (fun (wf, p) -> wf ^ "," ^ p) args) in printf "%s(%s,%s)" (fusion_name v cyclic []) g args_string (* We need to look at the permuted fermion lines in order to decide wether to apply charge conjugations. *) (* It is not enough to look at the cyclic permutation used to move the fields into the correct arguments of the fusions \ldots *) let map_indices perm unit = let pmap = IntPM.of_lists unit (P.list perm unit) in IntPM.apply pmap (* \ldots{} we also need to inspect the full permutation of the fields. *) let map_indices2 perm unit = let pmap = IntPM.of_lists unit (1 :: P.list (P.inverse perm) (List.tl unit)) in IntPM.apply pmap (* This is a more direct implementation of the composition of [map_indices2] and [map_indices], that is used in the unit tests. *) let map_indices_raw fusion = let unit = ThoList.range 1 (List.length fusion) in let f12__, fn = ThoList.split_last fusion in let fusion = fn :: f12__ in let map_index = IntPM.of_lists fusion unit in IntPM.apply map_index (* Map the fermion line indices in [fl] according to [map_index]. *) let map_fermion_lines map_index fl = List.map (fun (i, f) -> (map_index i, map_index f)) fl (* Map the fermion line indices in [fl] according to [map_index], but keep a copy of the original. *) let map_fermion_lines2 map_index fl = List.map (fun (i, f) -> ((i, f), (map_index i, map_index f))) fl let permute_fermion_lines cyclic unit fl = map_fermion_lines (map_indices cyclic unit) fl let permute_fermion_lines2 cyclic factor unit fl = map_fermion_lines2 (map_indices2 factor unit) (map_fermion_lines (map_indices cyclic unit) fl) (* \begin{dubious} TODO: this needs more more work for the fully general case. \end{dubious} *) let charge_conjugations fl2 = ThoList.filtermap (fun ((i, f), (i', f')) -> match (i, f), (i', f') with | (1, 2), _ | (2, 1), _ -> Some (f, i) (* $\chi^T\Gamma'$ *) | _, (2, 3) -> Some (f, i) (* $\chi^T(C\Gamma')\chi$ *) | _ -> None) fl2 (*i let fuse_majorana c v s fl g wfs ps fusion = let g = scale_coupling c g and cyclic, factor = factor_cyclic fusion in let wfs_ps = List.map2 (fun wf p -> (wf, p)) wfs ps in let wfs_ps_string = String.concat "," (List.map (fun (wf, p) -> wf ^ "," ^ p) wfs_ps) in let args = P.list (P.inverse factor) wfs_ps in let args_string = String.concat "," (List.map (fun (wf, p) -> wf ^ "," ^ p) args) in let f12__, fn = ThoList.split_last fusion in Printf.eprintf "fusion : %d < %s\n" fn (ThoList.to_string string_of_int f12__); Printf.eprintf "cyclic : %s\n" (P.to_string cyclic); Printf.eprintf "factor : %s\n" (P.to_string factor); let unit = ThoList.range 1 (List.length fusion) in Printf.eprintf "permutation : %s -> %s\n" (ThoList.to_string string_of_int unit) (ThoList.to_string string_of_int (List.map (map_indices cyclic unit) unit)); Printf.eprintf "permutation raw : %s -> %s\n" (ThoList.to_string string_of_int unit) (ThoList.to_string string_of_int (List.map (map_indices_raw fusion) unit)); Printf.eprintf "fermion lines : %s\n" (ThoList.to_string (fun (i, f) -> Printf.sprintf "%d>%d" i f) fl); let fl2 = permute_fermion_lines2 cyclic factor unit fl in let fl = permute_fermion_lines cyclic unit fl in Printf.eprintf "permuted : %s\n" (ThoList.to_string (fun (i, f) -> Printf.sprintf "%d>%d" i f) fl); Printf.eprintf "arguments : %s\n" wfs_ps_string; Printf.eprintf "permuted : %s\n" args_string; Printf.eprintf ">> %s(%s,%s)\n" (fusion_name v cyclic (charge_conjugations fl2)) g args_string; printf "%s(%s,%s)" (fusion_name v cyclic (charge_conjugations fl2)) g args_string i*) + let charge_conjugations fl2 = + ThoList.filtermap + (fun ((i, f), (i', f')) -> + match (i, f), (i', f') with + | _, (2, 3) -> Some (f, i) + | _ -> None) + fl2 + let fuse_majorana c v s fl g wfs ps fusion = let g = scale_coupling c g and cyclic, factor = factor_cyclic fusion in let wfs_ps = List.map2 (fun wf p -> (wf, p)) wfs ps in let args = P.list (P.inverse factor) wfs_ps in let args_string = String.concat "," (List.map (fun (wf, p) -> wf ^ "," ^ p) args) in let unit = ThoList.range 1 (List.length fusion) in let ccs = charge_conjugations (permute_fermion_lines2 cyclic factor unit fl) in printf "%s(%s,%s)" (fusion_name v cyclic ccs) g args_string let fuse c v s fl g wfs ps fusion = if List.exists is_majorana s then fuse_majorana c v s fl g wfs ps fusion else fuse_dirac c v s fl g wfs ps fusion let eps4_g4_g44_decl ff () = let printf fmt = fprintf ff fmt and nl = pp_newline ff in printf " @[<2>integer,@ dimension(0:3)"; printf ",@ save,@ private ::@ g4_@]"; nl (); printf " @[<2>integer,@ dimension(0:3,0:3)"; printf ",@ save,@ private ::@ g44_@]"; nl (); printf " @[<2>integer,@ dimension(0:3,0:3,0:3,0:3)"; printf ",@ save,@ private ::@ eps4_@]"; nl () let eps4_g4_g44_init ff () = let printf fmt = fprintf ff fmt and nl = pp_newline ff in printf " @[<2>data g4_@ /@ 1, -1, -1, -1 /@]"; nl (); printf " @[<2>data g44_(0,:)@ /@ 1, 0, 0, 0 /@]"; nl (); printf " @[<2>data g44_(1,:)@ /@ 0, -1, 0, 0 /@]"; nl (); printf " @[<2>data g44_(2,:)@ /@ 0, 0, -1, 0 /@]"; nl (); printf " @[<2>data g44_(3,:)@ /@ 0, 0, 0, -1 /@]"; nl (); for mu1 = 0 to 3 do for mu2 = 0 to 3 do for mu3 = 0 to 3 do printf " @[<2>data eps4_(%d,%d,%d,:)@ /@ " mu1 mu2 mu3; for mu4 = 0 to 3 do if mu4 <> 0 then printf ",@ "; let mus = [mu1; mu2; mu3; mu4] in if List.sort compare mus = [0; 1; 2; 3] then printf "%2d" (Combinatorics.sign mus) else printf "%2d" 0; done; printf " /@]"; nl () done done done let inner_product_functions ff () = let printf fmt = fprintf ff fmt and nl = pp_newline ff in printf " pure function g2_ (p) result (p2)"; nl(); printf " real(kind=default), dimension(0:3), intent(in) :: p"; nl(); printf " real(kind=default) :: p2"; nl(); printf " p2 = p(0)*p(0) - p(1)*p(1) - p(2)*p(2) - p(3)*p(3)"; nl(); printf " end function g2_"; nl(); printf " pure function g12_ (p1, p2) result (p12)"; nl(); printf " real(kind=default), dimension(0:3), intent(in) :: p1, p2"; nl(); printf " real(kind=default) :: p12"; nl(); printf " p12 = p1(0)*p2(0) - p1(1)*p2(1) - p1(2)*p2(2) - p1(3)*p2(3)"; nl(); printf " end function g12_"; nl() module type Test = sig val suite : OUnit.test end module Test : Test = struct open OUnit let assert_mappings fusion = let unit = ThoList.range 1 (List.length fusion) in let cyclic, factor = factor_cyclic fusion in let raw = map_indices_raw fusion and map1 = map_indices cyclic unit and map2 = map_indices2 factor unit in let map i = map2 (map1 i) in assert_equal ~printer:(ThoList.to_string string_of_int) (List.map raw unit) (List.map map unit) let suite_mappings = "mappings" >::: [ "1<-2" >:: (fun () -> List.iter assert_mappings (Combinatorics.permute [1;2;3])); "1<-3" >:: (fun () -> List.iter assert_mappings (Combinatorics.permute [1;2;3;4])) ] let suite = "UFO_targets" >::: [suite_mappings] end end