Index: trunk/omega/tests/qqggg.phs =================================================================== --- trunk/omega/tests/qqggg.phs (revision 8743) +++ trunk/omega/tests/qqggg.phs (revision 8744) @@ -1,67 +1,63 @@ u:d ubar:dbar -> gl gl gl u ubar -> gl gl gl :: u[1]: { (ubar[2],{ (gl[3/4/5]:(gl[3/4]:gl[3],gl[4]),gl[5]) \ | (gl[3/4/5]:(gl[3/5]:gl[3],gl[5]),gl[4]) \ - | (gl[3/4/5]:(gl[4/5]:gl[4],gl[5]),gl[3]) \ - | (gl[3/4/5]:gl[3],gl[4],gl[5]) }) \ + | (gl[3/4/5]:(gl[4/5]:gl[4],gl[5]),gl[3]) }) \ | ((ubar[2/5]:ubar[2],gl[5]),(gl[3/4]:gl[3],gl[4])) \ | ((ubar[2/4]:ubar[2],gl[4]),(gl[3/5]:gl[3],gl[5])) \ | ((ubar[2/3]:ubar[2],gl[3]),(gl[4/5]:gl[4],gl[5])) \ | (gl[3],{ (ubar[2/4/5]:(gl[4/5]:gl[4],gl[5]),ubar[2]) \ | (ubar[2/4/5]:(ubar[2/4]:ubar[2],gl[4]),gl[5]) \ | (ubar[2/4/5]:(ubar[2/5]:ubar[2],gl[5]),gl[4]) }) \ | (gl[4],{ (ubar[2/3/5]:(gl[3/5]:gl[3],gl[5]),ubar[2]) \ | (ubar[2/3/5]:(ubar[2/3]:ubar[2],gl[3]),gl[5]) \ | (ubar[2/3/5]:(ubar[2/5]:ubar[2],gl[5]),gl[3]) }) \ | (gl[5],{ (ubar[2/3/4]:(gl[3/4]:gl[3],gl[4]),ubar[2]) \ | (ubar[2/3/4]:(ubar[2/3]:ubar[2],gl[3]),gl[4]) \ | (ubar[2/3/4]:(ubar[2/4]:ubar[2],gl[4]),gl[3]) }) } ubar[2]: { (u[1],{ (gl[3/4/5]:(gl[3/4]:gl[3],gl[4]),gl[5]) \ | (gl[3/4/5]:(gl[3/5]:gl[3],gl[5]),gl[4]) \ - | (gl[3/4/5]:(gl[4/5]:gl[4],gl[5]),gl[3]) \ - | (gl[3/4/5]:gl[3],gl[4],gl[5]) }) \ + | (gl[3/4/5]:(gl[4/5]:gl[4],gl[5]),gl[3]) }) \ | ((u[1/5]:u[1],gl[5]),(gl[3/4]:gl[3],gl[4])) \ | ((u[1/4]:u[1],gl[4]),(gl[3/5]:gl[3],gl[5])) \ | ((u[1/3]:u[1],gl[3]),(gl[4/5]:gl[4],gl[5])) \ | (gl[3],{ (u[1/4/5]:(u[1/4]:u[1],gl[4]),gl[5]) \ | (u[1/4/5]:(u[1/5]:u[1],gl[5]),gl[4]) \ | (u[1/4/5]:(gl[4/5]:gl[4],gl[5]),u[1]) }) \ | (gl[4],{ (u[1/3/5]:(u[1/3]:u[1],gl[3]),gl[5]) \ | (u[1/3/5]:(u[1/5]:u[1],gl[5]),gl[3]) \ | (u[1/3/5]:(gl[3/5]:gl[3],gl[5]),u[1]) }) \ | (gl[5],{ (u[1/3/4]:(u[1/3]:u[1],gl[3]),gl[4]) \ | (u[1/3/4]:(u[1/4]:u[1],gl[4]),gl[3]) \ | (u[1/3/4]:(gl[3/4]:gl[3],gl[4]),u[1]) }) } d dbar -> gl gl gl :: d[1]: { (dbar[2],{ (gl[3/4/5]:(gl[3/4]:gl[3],gl[4]),gl[5]) \ | (gl[3/4/5]:(gl[3/5]:gl[3],gl[5]),gl[4]) \ - | (gl[3/4/5]:(gl[4/5]:gl[4],gl[5]),gl[3]) \ - | (gl[3/4/5]:gl[3],gl[4],gl[5]) }) \ + | (gl[3/4/5]:(gl[4/5]:gl[4],gl[5]),gl[3]) }) \ | ((dbar[2/5]:dbar[2],gl[5]),(gl[3/4]:gl[3],gl[4])) \ | ((dbar[2/4]:dbar[2],gl[4]),(gl[3/5]:gl[3],gl[5])) \ | ((dbar[2/3]:dbar[2],gl[3]),(gl[4/5]:gl[4],gl[5])) \ | (gl[3],{ (dbar[2/4/5]:(gl[4/5]:gl[4],gl[5]),dbar[2]) \ | (dbar[2/4/5]:(dbar[2/4]:dbar[2],gl[4]),gl[5]) \ | (dbar[2/4/5]:(dbar[2/5]:dbar[2],gl[5]),gl[4]) }) \ | (gl[4],{ (dbar[2/3/5]:(gl[3/5]:gl[3],gl[5]),dbar[2]) \ | (dbar[2/3/5]:(dbar[2/3]:dbar[2],gl[3]),gl[5]) \ | (dbar[2/3/5]:(dbar[2/5]:dbar[2],gl[5]),gl[3]) }) \ | (gl[5],{ (dbar[2/3/4]:(gl[3/4]:gl[3],gl[4]),dbar[2]) \ | (dbar[2/3/4]:(dbar[2/3]:dbar[2],gl[3]),gl[4]) \ | (dbar[2/3/4]:(dbar[2/4]:dbar[2],gl[4]),gl[3]) }) } dbar[2]: { (d[1],{ (gl[3/4/5]:(gl[3/4]:gl[3],gl[4]),gl[5]) \ | (gl[3/4/5]:(gl[3/5]:gl[3],gl[5]),gl[4]) \ - | (gl[3/4/5]:(gl[4/5]:gl[4],gl[5]),gl[3]) \ - | (gl[3/4/5]:gl[3],gl[4],gl[5]) }) \ + | (gl[3/4/5]:(gl[4/5]:gl[4],gl[5]),gl[3]) }) \ | ((d[1/5]:d[1],gl[5]),(gl[3/4]:gl[3],gl[4])) \ | ((d[1/4]:d[1],gl[4]),(gl[3/5]:gl[3],gl[5])) \ | ((d[1/3]:d[1],gl[3]),(gl[4/5]:gl[4],gl[5])) \ | (gl[3],{ (d[1/4/5]:(d[1/4]:d[1],gl[4]),gl[5]) \ | (d[1/4/5]:(d[1/5]:d[1],gl[5]),gl[4]) \ | (d[1/4/5]:(gl[4/5]:gl[4],gl[5]),d[1]) }) \ | (gl[4],{ (d[1/3/5]:(d[1/3]:d[1],gl[3]),gl[5]) \ | (d[1/3/5]:(d[1/5]:d[1],gl[5]),gl[3]) \ | (d[1/3/5]:(gl[3/5]:gl[3],gl[5]),d[1]) }) \ | (gl[5],{ (d[1/3/4]:(d[1/3]:d[1],gl[3]),gl[4]) \ | (d[1/3/4]:(d[1/4]:d[1],gl[4]),gl[3]) \ | (d[1/3/4]:(gl[3/4]:gl[3],gl[4]),d[1]) }) } Index: trunk/omega/src/omega_NMSSM.ml =================================================================== --- trunk/omega/src/omega_NMSSM.ml (revision 8743) +++ trunk/omega/src/omega_NMSSM.ml (revision 8744) @@ -1,35 +1,26 @@ (* omega_NMSSM.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. *) -module O = Omega.Make(Fusion_vintage.Mixed23_Majorana)(Targets.Fortran_Majorana) - (Modellib_NMSSM.NMSSM_func(Modellib_NMSSM.NMSSM)) +module O = Omega.Mixed23_Majorana_vintage(Targets.Fortran_Majorana)(Modellib_NMSSM.NMSSM_func(Modellib_NMSSM.NMSSM)) let _ = O.main () - -(*i - * Local Variables: - * mode:caml - * indent-tabs-mode:nil - * page-delimiter:"^(\\* .*\n" - * End: -i*) Index: trunk/omega/src/fusion.mli =================================================================== --- trunk/omega/src/fusion.mli (revision 8743) +++ trunk/omega/src/fusion.mli (revision 8744) @@ -1,385 +1,389 @@ (* fusion.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 type T = sig val options : Options.t (* JRR's implementation of Majoranas needs a special case. *) val vintage : bool (* Wavefunctions are an abstract data type, containing a momentum~[p] and additional quantum numbers, collected in~[flavor]. *) type wf val conjugate : wf -> wf (* Obviously, [flavor] is not restricted to the physical notion of flavor, but can carry spin, color, etc. *) type flavor val flavor : wf -> flavor type flavor_sans_color val flavor_sans_color : wf -> flavor_sans_color (* Momenta are represented by an abstract datatype (defined in~[Momentum]) that is optimized for performance. They can be accessed either abstractly or as lists of indices of the external momenta. These indices are assigned sequentially by [amplitude] below. *) type p val momentum : wf -> p val momentum_list : wf -> int list (* At tree level, the wave functions are uniquely specified by [flavor] and momentum. If loops are included, we need to distinguish among orders. Also, if we build a result from an incomplete sum of diagrams, we need to add a distinguishing mark. At the moment, we assume that a [string] that can be attached to the symbol suffices. *) val wf_tag : wf -> string option (* Coupling constants *) type constant (* and right hand sides of assignments. The latter are formed from a sign from Fermi statistics, a coupling (constand and Lorentz structure) and wave functions. *) 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 (* In renormalized perturbation theory, couplings come in different orders of the loop expansion. Be prepared: [val order : rhs -> int] *) (* \begin{dubious} This is here only for the benefit of [Target] and shall become [val children : rhs -> wf children] later \ldots \end{dubious} *) val children : rhs -> wf list (* Fusions come in two types: fusions of wave functions to off-shell wave functions: \begin{equation*} \phi(p+q) = \phi(p)\phi(q) \end{equation*} *) type fusion val lhs : fusion -> wf val rhs : fusion -> rhs list (* and products at the keystones: \begin{equation*} \phi(-p-q)\cdot\phi(p)\phi(q) \end{equation*} *) type braket val bra : braket -> wf val ket : braket -> rhs list (* [amplitude goldstones incoming outgoing] calculates the amplitude for scattering of [incoming] to [outgoing]. If [goldstones] is true, also non-propagating off-shell Goldstone amplitudes are included to allow the checking of Slavnov-Taylor identities. *) 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 (* We should be precise regarding the semantics of the following functions, since modules implementating [Target] must not make any mistakes interpreting the return values. Instead of calculating the amplitude \begin{subequations} \begin{equation} \label{eq:physical-amplitude} \Braket{f_3,p_3,f_4,p_4,\ldots|T|f_1,p_1,f_2,p_2} \end{equation} directly, O'Mega calculates the---equivalent, but more symmetrical---crossed amplitude \begin{equation} \Braket{\bar f_1,-p_1,\bar f_2,-p_2,f_3,p_3,f_4,p_4,\ldots|T|0} \end{equation} Internally, all flavors are represented by their charge conjugates \begin{equation} \label{eq:internal-amplitude} A(f_1,-p_1,f_2,-p_2,\bar f_3,p_3,\bar f_4,p_4,\ldots) \end{equation} \end{subequations} The correspondence of vertex and term in the lagrangian \begin{equation} \parbox{26\unitlength}{% \fmfframe(5,3)(5,3){% \begin{fmfgraph*}(15,20) \fmfleft{v} \fmfright{p,A,e} \fmflabel{$\mathrm{e}^-$}{e} \fmflabel{$\mathrm{e}^+$}{p} \fmflabel{$\mathrm{A}$}{A} \fmf{fermion}{p,v,e} \fmf{photon}{A,v} \fmfdot{v} \end{fmfgraph*}}}: \bar\psi\fmslash{A}\psi \end{equation} suggests to denote the \emph{outgoing} particle by the flavor of the \emph{anti}particle and the \emph{outgoing} \emph{anti}particle by the flavor of the particle, since this choice allows to represent the vertex by a triple \begin{equation} \bar\psi\fmslash{A}\psi: (\mathrm{e}^+,A,\mathrm{e}^-) \end{equation} which is more intuitive than the alternative $(\mathrm{e}^-,A,\mathrm{e}^+)$. Also, when thinking in terms of building wavefunctions from the outside in, the outgoing \emph{antiparticle} is represented by a \emph{particle} propagator and vice versa\footnote{Even if this choice will appear slightly counter-intuitive on the [Target] side, one must keep in mind that much more people are expected to prepare [Model]s.}. [incoming] and [outgoing] are the physical flavors as in~(\ref{eq:physical-amplitude}) *) val incoming : amplitude -> flavor list val outgoing : amplitude -> flavor list (* [externals] are flavors and momenta as in~(\ref{eq:internal-amplitude}) *) 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 (*i (* \thocwmodulesubsection{Performance Hacks} *) val initialize_cache : string -> unit val set_cache_name : string -> unit i*) (* \thocwmodulesubsection{Diagnostics} *) 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 (* \thocwmodulesubsection{WHIZARD} *) val phase_space_channels : out_channel -> amplitude_sans_color -> unit val phase_space_channels_flipped : out_channel -> amplitude_sans_color -> unit end (* There is more than one way to make fusions. *) 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 (*i If we want or need to expose [Make], here's how to do it: module type Stat = sig type flavor type stat exception Impossible val stat : flavor -> int -> stat val stat_fuse : stat -> stat -> flavor -> stat val stat_sign : stat -> int end module type Stat_Maker = functor (M : Model.T) -> Stat with type flavor = M.flavor module Make : functor (PT : Tuple.Poly) (Stat : Stat_Maker) (T : Topology.T with type 'a children = 'a PT.t) -> Maker i*) (* Straightforward Dirac fermions vs. slightly more complicated Majorana fermions: *) exception Majorana module Binary : Maker module Binary_Majorana : Maker module Mixed23 : Maker module Mixed23_Majorana : Maker module Nary : functor (B : Tuple.Bound) -> Maker module Nary_Majorana : functor (B : Tuple.Bound) -> Maker (* We can also proceed \'a la~\cite{HELAC:2000}. Empirically, this will use slightly~($O(10\%)$) fewer fusions than the symmetric factorization. Our implementation uses significantly~($O(50\%)$) fewer fusions than reported by~\cite{HELAC:2000}. Our pruning of the DAG might be responsible for this. *) +module Helac_Binary : Maker +module Helac_Binary_Majorana : Maker +module Helac_Mixed23 : Maker +module Helac_Mixed23_Majorana : Maker module Helac : functor (B : Tuple.Bound) -> Maker module Helac_Majorana : functor (B : Tuple.Bound) -> Maker (* \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 (* Construct all possible color flow amplitudes for a given process. *) val amplitudes : bool -> int option -> exclusions -> selectors -> process list -> amplitudes val empty : amplitudes (*i (* Precompute the vertex table cache. *) val initialize_cache : string -> unit val set_cache_name : string -> unit i*) (* The list of all combinations of incoming and outgoing particles with a nonvanishing scattering amplitude. *) val flavors : amplitudes -> process list (* The list of all combinations of incoming and outgoing particles that don't lead to any color flow with non vanishing scattering amplitude. *) val vanishing_flavors : amplitudes -> process list (* The list of all color flows with a nonvanishing scattering amplitude. *) val color_flows : amplitudes -> Color.Flow.t list (* The list of all valid helicity combinations. *) val helicities : amplitudes -> (int list * int list) list (* The list of all amplitudes. *) val processes : amplitudes -> amplitude list (* [(process_table a).(f).(c)] returns the amplitude for the [f]th allowed flavor combination and the [c]th allowed color flow as an [amplitude option]. *) val process_table : amplitudes -> amplitude option array array (* The list of all non redundant fusions together with the amplitudes they came from. *) val fusions : amplitudes -> (fusion * amplitude) list (* If there's more than external flavor state, the wavefunctions are \emph{not} uniquely specified by [flavor] and [Momentum.t]. This function can be used to determine how many variables must be allocated. *) val multiplicity : amplitudes -> wf -> int (* This function can be used to disambiguate wavefunctions with the same combination of [flavor] and [Momentum.t]. *) val dictionary : amplitudes -> amplitude -> wf -> int (* [(color_factors a).(c1).(c2)] power of~$N_C$ for the given product of color flows. *) val color_factors : amplitudes -> Color.Flow.factor array array (* A description of optional diagram selectors. *) 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 : Multi_Maker (* \thocwmodulesection{Tags} *) (* It appears that there are useful applications for tagging couplings and wave functions, e.\,g.~skeleton expansion and diagram selections. We can abstract this in a [Tags] signature: *) 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 module Tagged_Binary : Tagged_Maker (*i * Local Variables: * mode:caml * indent-tabs-mode:nil * page-delimiter:"^(\\* .*\n" * End: i*) Index: trunk/omega/src/modeltools.ml =================================================================== --- trunk/omega/src/modeltools.ml (revision 8743) +++ trunk/omega/src/modeltools.ml (revision 8744) @@ -1,575 +1,688 @@ (* modeltools.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. *) (* \thocwmodulesection{Compilation} *) (* Flavors and coupling constants: flavors can be tested for equality and charge conjugation is defined. *) module type Flavor = sig type f type c val compare : f -> f -> int val conjugate : f -> f end (* Compiling fusions from a list of vertices: *) module type Fusions = sig type t type f type c val fuse2 : t -> f -> f -> (f * c Coupling.t) list val fuse3 : t -> f -> f -> f -> (f * c Coupling.t) list val fuse : t -> f list -> (f * c Coupling.t) list val of_vertices : (((f * f * f) * c Coupling.vertex3 * c) list * ((f * f * f * f) * c Coupling.vertex4 * c) list * (f list * c Coupling.vertexn * c) list) -> t end module Fusions (F : Flavor) : Fusions with type f = F.f and type c = F.c = struct type f = F.f type c = F.c module F2 = struct type t = f * f let hash = Hashtbl.hash let compare (f1, f2) (f1', f2') = let c1 = F.compare f1 f1' in if c1 <> 0 then c1 else F.compare f2 f2' let equal f f' = compare f f' = 0 end module F3 = struct type t = f * f * f let hash = Hashtbl.hash let compare (f1, f2, f3) (f1', f2', f3') = let c1 = F.compare f1 f1' in if c1 <> 0 then c1 else let c2 = F.compare f2 f2' in if c2 <> 0 then c2 else F.compare f3 f3' let equal f f' = compare f f' = 0 end module Fn = struct type t = f list let hash = Hashtbl.hash let compare f f' = ThoList.compare ~cmp:F.compare f f' let equal f f' = compare f f' = 0 end module H2 = Hashtbl.Make (F2) module H3 = Hashtbl.Make (F3) module Hn = Hashtbl.Make (Fn) type t = { v3 : (f * c Coupling.t) list H2.t; v4 : (f * c Coupling.t) list H3.t; vn : (f * c Coupling.t) list Hn.t } let lookup_fuse2 table f1 f2 = try H2.find table.v3 (f1, f2) with Not_found -> [] let lookup_fuse3 table f1 f2 f3 = try H3.find table.v4 (f1, f2, f3) with Not_found -> [] let lookup_fusen table f = try Hn.find table.vn f with Not_found -> [] let fuse2 table f1 f2 = List.rev_append (lookup_fusen table [f1; f2]) (lookup_fuse2 table f1 f2) let fuse3 table f1 f2 f3 = List.rev_append (lookup_fusen table [f1; f2; f3]) (lookup_fuse3 table f1 f2 f3) let fusen table f = lookup_fusen table f let fuse table = function | [] | [_] -> invalid_arg "Fusions().fuse" | [f1; f2] -> fuse2 table f1 f2 | [f1; f2; f3] -> fuse3 table f1 f2 f3 | f -> fusen table f (* Note that a pair or a triplet can appear more than once (e.\,g.~$e^+e^-\to \gamma$ and~$e^+e^-\to Z$). Therefore don't replace the entry, but augment it instead. *) let add_fusion2 table f1 f2 fusions = H2.add table.v3 (f1, f2) (fusions :: lookup_fuse2 table f1 f2) let add_fusion3 table f1 f2 f3 fusions = H3.add table.v4 (f1, f2, f3) (fusions :: lookup_fuse3 table f1 f2 f3) let add_fusionn table f fusions = Hn.add table.vn f (fusions :: lookup_fusen table f) (* \begin{dubious} Do we need to take into account the charge conjugation of the coupling constants here? \end{dubious} *) (* If some flavors are identical, we must not introduce the same vertex more than once: *) open Coupling let permute3 (f1, f2, f3) = [ (f1, f2), F.conjugate f3, F12; (f2, f1), F.conjugate f3, F21; (f2, f3), F.conjugate f1, F23; (f3, f2), F.conjugate f1, F32; (f3, f1), F.conjugate f2, F31; (f1, f3), F.conjugate f2, F13 ] (* Here we add identical permutations of pairs only once: *) module F2' = Set.Make (F2) let add_permute3 table v c set ((f1, f2 as f12), f, p) = if F2'.mem f12 set then set else begin add_fusion2 table f1 f2 (f, V3 (v, p, c)); F2'.add f12 set end let add_vertex3 table (f123, v, c) = ignore (List.fold_left (fun set f -> add_permute3 table v c set f) F2'.empty (permute3 f123)) (* \begin{dubious} Handling all the cases explicitely is OK for cubic vertices, but starts to become questionable already for quartic couplings. The advantage remains that we can check completeness in [Targets]. \end{dubious} *) let permute4 (f1, f2, f3, f4) = [ (f1, f2, f3), F.conjugate f4, F123; (f2, f3, f1), F.conjugate f4, F231; (f3, f1, f2), F.conjugate f4, F312; (f2, f1, f3), F.conjugate f4, F213; (f3, f2, f1), F.conjugate f4, F321; (f1, f3, f2), F.conjugate f4, F132; (f1, f2, f4), F.conjugate f3, F124; (f2, f4, f1), F.conjugate f3, F241; (f4, f1, f2), F.conjugate f3, F412; (f2, f1, f4), F.conjugate f3, F214; (f4, f2, f1), F.conjugate f3, F421; (f1, f4, f2), F.conjugate f3, F142; (f1, f3, f4), F.conjugate f2, F134; (f3, f4, f1), F.conjugate f2, F341; (f4, f1, f3), F.conjugate f2, F413; (f3, f1, f4), F.conjugate f2, F314; (f4, f3, f1), F.conjugate f2, F431; (f1, f4, f3), F.conjugate f2, F143; (f2, f3, f4), F.conjugate f1, F234; (f3, f4, f2), F.conjugate f1, F342; (f4, f2, f3), F.conjugate f1, F423; (f3, f2, f4), F.conjugate f1, F324; (f4, f3, f2), F.conjugate f1, F432; (f2, f4, f3), F.conjugate f1, F243 ] (* Add identical permutations of triplets only once: *) module F3' = Set.Make (F3) let add_permute4 table v c set ((f1, f2, f3 as f123), f, p) = if F3'.mem f123 set then set else begin add_fusion3 table f1 f2 f3 (f, V4 (v, p, c)); F3'.add f123 set end let add_vertex4 table (f1234, v, c) = ignore (List.fold_left (fun set f -> add_permute4 table v c set f) F3'.empty (permute4 f1234)) module Fn' = Set.Make (Fn) let permuten = function | [] -> invalid_arg "Modeltools.permuten" | f -> List.map (fun f' -> match List.split f' with | i :: i_list, f :: f_list -> (f_list, F.conjugate f, i_list @ [i]) | _ -> failwith "Modeltools.permuten: impossible") (Combinatorics.permute (ThoList.enumerate 1 f)) (* This is for debugging: it provides the same permutations than the legacy version. *) let permutations = function | [f1; f2; f3] -> [ [f1; f2; f3]; [f2; f1; f3]; [f2; f3; f1]; [f3; f2; f1]; [f3; f1; f2]; [f1; f3; f2] ] | [f1; f2; f3; f4] -> [ [f1; f2; f3; f4]; [f1; f2; f4; f3]; [f1; f3; f2; f4]; [f1; f3; f4; f2]; [f1; f4; f2; f3]; [f1; f4; f3; f2]; [f2; f1; f3; f4]; [f2; f1; f4; f3]; [f2; f3; f1; f4]; [f2; f3; f4; f1]; [f2; f4; f1; f3]; [f2; f4; f3; f1]; [f3; f1; f2; f4]; [f3; f1; f4; f2]; [f3; f2; f1; f4]; [f3; f2; f4; f1]; [f3; f4; f1; f2]; [f3; f4; f2; f1]; [f4; f1; f2; f3]; [f4; f1; f3; f2]; [f4; f2; f1; f3]; [f4; f2; f3; f1]; [f4; f3; f1; f2]; [f4; f3; f2; f1] ] | flist -> Combinatorics.permute flist let permutations = Combinatorics.permute let permuten = function | [] -> invalid_arg "Modeltools.permuten" | f -> List.map (fun f' -> match List.split (List.rev f') with | i_list, f :: f_list -> (* [Printf.eprintf "permuten: %s\n" (ThoList.to_string string_of_int (List.rev i_list));] *) (List.rev f_list, F.conjugate f, List.rev i_list) | _ -> failwith "Modeltools.permuten: impossible") (permutations (ThoList.enumerate 1 f)) let add_permuten table v c set (f12__n, f, p) = if Fn'.mem f12__n set then set else begin add_fusionn table f12__n (f, Vn (v, p, c)); Fn'.add f12__n set end (* \begin{dubious} We could apply any necessary permutations to objects that are hidden inside of the vertex [v] here instead of in [Fusion.stat_fuse] and [Colorize.fuse]. \end{dubious} *) let add_vertexn table (f12__n, v, c) = ignore (List.fold_left (fun set f -> add_permuten table v c set f) Fn'.empty (permuten f12__n)) let of_vertices (vlist3, vlist4, vlistn) = let table = { v3 = H2.create 37; v4 = H3.create 37; vn = Hn.create 37 } in List.iter (add_vertex3 table) vlist3; List.iter (add_vertex4 table) vlist4; List.iter (add_vertexn table) vlistn; table end module type Constant = sig type t val of_string : string -> t end module Constant (M : Model.T) : Constant with type t = M.constant = struct type t = M.constant module String_Key = struct type t = string let hash = Hashtbl.hash let equal = (=) end module String_Hash = Hashtbl.Make (String_Key) let table = String_Hash.create 37 let fill_table table vs = List.iter (fun (_, _, c) -> String_Hash.add table (M.constant_symbol c) c) vs (* Delay loading of the tables until the first use, so that [M.vertices] can be initialized from a file. *) let tables_filled = ref false let fill_tables () = if not !tables_filled then begin let (v3, v4, vn) = M.vertices () in fill_table table v3; fill_table table v4; fill_table table vn; tables_filled := true end let of_string name = try fill_tables (); String_Hash.find table name with | Not_found -> invalid_arg ("Constant(Model).of_string: unknown coupling constant: " ^ name) end (* \thocwmodulesection{Mutable Models} *) module Mutable (FGC : sig type f and g and c end) : Model.Mutable with type flavor = FGC.f and type gauge = FGC.g and type constant = FGC.c = struct type flavor = FGC.f type gauge = FGC.g type constant = FGC.c let init () = () let options = Options.empty let caveats () = [] module Ch = Charges.Null let charges _ = () exception Uninitialized of string let uninitialized name = raise (Uninitialized name) (* Note that [lookup] works, by the magic of currying, for any arity. But we need to supply one argument to delay evaluation. *) (* Also note that the references are \emph{not} shared among results of functor applications. Simple module renaming causes sharing. *) let declare template = let reference = ref template in let update fct = reference := fct and lookup arg = !reference arg in (update, lookup) let set_color, color = declare (fun f -> uninitialized "color") let set_nc, nc = declare (fun f -> uninitialized "nc") let set_pdg, pdg = declare (fun f -> uninitialized "pdg") let set_lorentz, lorentz = declare (fun f -> uninitialized "lorentz") let set_propagator, propagator = declare (fun f -> uninitialized "propagator") let set_width, width = declare (fun f -> uninitialized "width") let set_goldstone, goldstone = declare (fun f -> uninitialized "goldstone") let set_conjugate, conjugate = declare (fun f -> uninitialized "conjugate") let set_fermion, fermion = declare (fun f -> uninitialized "fermion") let set_max_degree, max_degree = declare (fun () -> uninitialized "max_degree") let set_vertices, vertices = declare (fun () -> uninitialized "vertices") let set_fuse2, fuse2 = declare (fun f1 f2 -> uninitialized "fuse2") let set_fuse3, fuse3 = declare (fun f1 f2 f3 -> uninitialized "fuse3") let set_fuse, fuse = declare (fun f -> uninitialized "fuse") let set_flavors, flavors = declare (fun () -> []) let set_external_flavors, external_flavors = declare (fun () -> [("uninitialized", [])]) let set_parameters, parameters = declare (fun () -> uninitialized "parameters") let set_flavor_of_string, flavor_of_string = declare (fun f -> uninitialized "flavor_of_string") let set_flavor_to_string, flavor_to_string = declare (fun f -> uninitialized "flavor_to_string") let set_flavor_to_TeX, flavor_to_TeX = declare (fun f -> uninitialized "flavor_to_TeX") let set_flavor_symbol, flavor_symbol = declare (fun f -> uninitialized "flavor_symbol") let set_gauge_symbol, gauge_symbol = declare (fun g -> uninitialized "gauge_symbol") let set_mass_symbol, mass_symbol = declare (fun f -> uninitialized "mass_symbol") let set_width_symbol, width_symbol = declare (fun f -> uninitialized "width_symbol") let set_constant_symbol, constant_symbol = declare (fun c -> uninitialized "constant_symbol") module F = Fusions (struct type f = flavor type c = constant let compare = compare let conjugate = conjugate end) let max_degree_of_vertices (v3, v4, vn) = List.fold_left (fun acc (p, _, _) -> max acc (List.length p)) (max (match v3 with [] -> 0 | _ -> 3) (match v4 with [] -> 0 | _ -> 4)) vn let setup ~color ~nc ~pdg ~lorentz ~propagator ~width ~goldstone ~conjugate ~fermion ~vertices ~flavors ~parameters ~flavor_of_string ~flavor_to_string ~flavor_to_TeX ~flavor_symbol ~gauge_symbol ~mass_symbol ~width_symbol ~constant_symbol = set_color color; set_nc nc; set_pdg pdg; set_lorentz lorentz; set_propagator propagator; set_width width; set_goldstone goldstone; set_conjugate conjugate; set_fermion fermion; let v = vertices () in let max_degree = max_degree_of_vertices v in set_max_degree (fun () -> max_degree); set_vertices (fun () -> v); let table = F.of_vertices v in set_fuse2 (F.fuse2 table); set_fuse3 (F.fuse3 table); set_fuse (F.fuse table); set_external_flavors (fun () -> flavors); let flavors = ThoList.flatmap snd flavors in set_flavors (fun () -> flavors); set_parameters parameters; set_flavor_of_string flavor_of_string; set_flavor_to_string flavor_to_string; set_flavor_to_TeX flavor_to_TeX; set_flavor_symbol flavor_symbol; set_gauge_symbol gauge_symbol; set_mass_symbol mass_symbol; set_width_symbol width_symbol; set_constant_symbol constant_symbol end module Static (M : Model.T) = struct type flavor = M.flavor type gauge = M.gauge type constant = M.constant module Ch = M.Ch let color = M.color let nc = M.nc let charges = M.charges let pdg = M.pdg let lorentz = M.lorentz let propagator = M.propagator let width = M.width let conjugate = M.conjugate let fermion = M.fermion let max_degree = M.max_degree let vertices = M.vertices let fuse2 = M.fuse2 let fuse3 = M.fuse3 let fuse = M.fuse let flavors = M.flavors let external_flavors = M.external_flavors let goldstone = M.goldstone 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 mass_symbol = M.mass_symbol let width_symbol = M.width_symbol let constant_symbol = M.constant_symbol let options = M.options let caveats = M.caveats let init () = () let setup ~color ~nc ~pdg ~lorentz ~propagator ~width ~goldstone ~conjugate ~fermion ~vertices ~flavors ~parameters ~flavor_of_string ~flavor_to_string ~flavor_to_TeX ~flavor_symbol ~gauge_symbol ~mass_symbol ~width_symbol ~constant_symbol = () end + +(* \thocwmodulesection{Topology Only} *) + +(* UFO models can have more than one Lorentz structure for a + given flavor combination. This messes up the phase space + generation. There we need to be able to ignore the redundant + flavor combinations. *) + +(* Filter vertices with more than one Lorentz structure + for a combination of flavors. Only the first Lorentz + structure is kept. *) +let filter_couplings flavor_coupling_list = + List.map + (fun (f, c_list) -> (f, List.hd c_list)) + (ThoList.factorize flavor_coupling_list) + +let triple_to_nested (a, b, c) = (a, (b, c)) + +let nested_to_triple (a, (b, c)) = (a, b, c) + +let filter_couplings_triples fc = + List.map + nested_to_triple + (filter_couplings (List.map triple_to_nested fc)) + +(* \begin{dubious} + It would be clearer to replace [constant Coupling.t] by + [unit] in the resultig model, but that would require + much more code duplication. + \end{dubious} *) + +module Topology (M : Model.T) = + struct + type flavor = M.flavor + type gauge = M.gauge + type constant = M.constant + module Ch = M.Ch + let color = M.color + let nc = M.nc + let charges = M.charges + let pdg = M.pdg + let lorentz = M.lorentz + let propagator = M.propagator + let width = M.width + let conjugate = M.conjugate + let fermion = M.fermion + let max_degree = M.max_degree + let vertices () = + let (v3, v4, vn) = M.vertices () in + (filter_couplings_triples v3, + filter_couplings_triples v4, + filter_couplings_triples vn) + let fuse2 f1 f2 = filter_couplings (M.fuse2 f1 f2) + let fuse3 f1 f2 f3 = filter_couplings (M.fuse3 f1 f2 f3) + let fuse f_list = filter_couplings (M.fuse f_list) + let flavors = M.flavors + let external_flavors = M.external_flavors + let goldstone = M.goldstone + 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 mass_symbol = M.mass_symbol + let width_symbol = M.width_symbol + let constant_symbol = M.constant_symbol + let options = M.options + let caveats = M.caveats + end + +module Topology3 (M : Model.T) = + struct + type flavor = M.flavor + type gauge = M.gauge + type constant = M.constant + module Ch = M.Ch + let color = M.color + let nc = M.nc + let charges = M.charges + let pdg = M.pdg + let lorentz = M.lorentz + let propagator = M.propagator + let width = M.width + let conjugate = M.conjugate + let fermion = M.fermion + let max_degree = M.max_degree + let vertices () = + let (v3, _, vn) = M.vertices () in + (filter_couplings_triples v3, + [], + filter_couplings_triples + (List.filter (fun (f, _, _) -> List.length f < 3) vn)) + let fuse2 f1 f2 = filter_couplings (M.fuse2 f1 f2) + let fuse3 f1 f2 f3 = [] + let fuse = function + | [_; _] as f_list -> filter_couplings (M.fuse f_list) + | _ -> [] + let flavors = M.flavors + let external_flavors = M.external_flavors + let goldstone = M.goldstone + 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 mass_symbol = M.mass_symbol + let width_symbol = M.width_symbol + let constant_symbol = M.constant_symbol + let options = M.options + let caveats = M.caveats + end Index: trunk/omega/src/omega_QED_VM.ml =================================================================== --- trunk/omega/src/omega_QED_VM.ml (revision 8743) +++ trunk/omega/src/omega_QED_VM.ml (revision 8744) @@ -1,34 +1,26 @@ (* omega_QED_VM.ml -- 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. *) -module O = Omega.Make(Fusion.Binary)(Targets.VM)(Modellib_SM.QED) +module O = Omega.Binary(Targets.VM)(Modellib_SM.QED) let _ = O.main () - -(*i - * Local Variables: - * mode:caml - * indent-tabs-mode:nil - * page-delimiter:"^(\\* .*\n" - * End: -i*) Index: trunk/omega/src/omega_SM_Majorana_legacy.ml =================================================================== --- trunk/omega/src/omega_SM_Majorana_legacy.ml (revision 8743) +++ trunk/omega/src/omega_SM_Majorana_legacy.ml (revision 8744) @@ -1,36 +1,26 @@ (* omega_SM_Maj.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. *) -module O = Omega.Make - (Fusion_vintage.Mixed23_Majorana)(Targets.Fortran_Majorana) - (Modellib_SM.SM(Modellib_SM.SM_no_anomalous)) +module O = Omega.Mixed23_Majorana_vintage(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/omega_SM_ac_CKM.ml =================================================================== --- trunk/omega/src/omega_SM_ac_CKM.ml (revision 8743) +++ trunk/omega/src/omega_SM_ac_CKM.ml (revision 8744) @@ -1,35 +1,35 @@ (* omega_SM_ac_CKM.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. *) -module O = Omega.Make(Fusion.Mixed23)(Targets.Fortran) +module O = Omega.Mixed23(Targets.Fortran) (Modellib_SM.SM(Modellib_SM.SM_anomalous_ckm)) let _ = O.main () (*i * Local Variables: * mode:caml * indent-tabs-mode:nil * page-delimiter:"^(\\* .*\n" * End: i*) Index: trunk/omega/src/omega_SSC_AltT.ml =================================================================== --- trunk/omega/src/omega_SSC_AltT.ml (revision 8743) +++ trunk/omega/src/omega_SSC_AltT.ml (revision 8744) @@ -1,36 +1,36 @@ (* omega_SSC.ml -- Copyright (C) 1999-2015 by Wolfgang Kilian Thorsten Ohl Juergen Reuter with contributions from Marco Sekulla 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.Mixed23)(Targets.Fortran) +module O = Omega.Mixed23(Targets.Fortran) (Modellib_BSM.SSC_AltT(Modellib_BSM.SSC_kmatrix_2)) let _ = O.main () (*i * Local Variables: * mode:caml * indent-tabs-mode:nil * page-delimiter:"^(\\* .*\n" * End: i*) Index: trunk/omega/src/omega_Threeshl.ml =================================================================== --- trunk/omega/src/omega_Threeshl.ml (revision 8743) +++ trunk/omega/src/omega_Threeshl.ml (revision 8744) @@ -1,35 +1,35 @@ (* omega_Threeshl.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. *) -module O = Omega.Make(Fusion.Mixed23)(Targets.Fortran) +module O = Omega.Mixed23(Targets.Fortran) (Modellib_BSM.Threeshl(Modellib_BSM.Threeshl_no_ckm)) let _ = O.main () (*i * Local Variables: * mode:caml * indent-tabs-mode:nil * page-delimiter:"^(\\* .*\n" * End: i*) Index: trunk/omega/src/omega_MSSM.ml =================================================================== --- trunk/omega/src/omega_MSSM.ml (revision 8743) +++ trunk/omega/src/omega_MSSM.ml (revision 8744) @@ -1,35 +1,26 @@ (* omega_MSSM.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. *) -module O = Omega.Make(Fusion_vintage.Mixed23_Majorana)(Targets.Fortran_Majorana) - (Modellib_MSSM.MSSM(Modellib_MSSM.MSSM_no_4)) +module O = Omega.Mixed23_Majorana_vintage(Targets.Fortran_Majorana)(Modellib_MSSM.MSSM(Modellib_MSSM.MSSM_no_4)) let _ = O.main () - -(*i - * Local Variables: - * mode:caml - * indent-tabs-mode:nil - * page-delimiter:"^(\\* .*\n" - * End: -i*) Index: trunk/omega/src/omega_SM.ml =================================================================== --- trunk/omega/src/omega_SM.ml (revision 8743) +++ trunk/omega/src/omega_SM.ml (revision 8744) @@ -1,27 +1,26 @@ (* omega_SM.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. *) -module O = Omega.Make(Fusion.Mixed23)(Targets.Fortran) - (Modellib_SM.SM(Modellib_SM.SM_no_anomalous)) +module O = Omega.Mixed23(Targets.Fortran)(Modellib_SM.SM(Modellib_SM.SM_no_anomalous)) let _ = O.main () Index: trunk/omega/src/omega_UFO.ml =================================================================== --- trunk/omega/src/omega_UFO.ml (revision 8743) +++ trunk/omega/src/omega_UFO.ml (revision 8744) @@ -1,42 +1,30 @@ (* omega_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. *) -module Bound (M : Model.T) : Tuple.Bound = - struct - (* \begin{dubious} - Above [max_degree = 6], the performance drops \emph{dramatically}! - \end{dubious} *) - let max_arity () = - pred (M.max_degree ()) - end - -module Omega_Dirac = - Omega.Make(Fusion.Nary(Bound(UFO.Model)))(Targets.Fortran)(UFO.Model) - -module Omega_Majorana = - Omega.Make(Fusion.Nary_Majorana(Bound(UFO.Model)))(Targets.Fortran_Majorana)(UFO.Model) +module Omega_Dirac = Omega.Nary(Targets.Fortran)(UFO.Model) +module Omega_Majorana = Omega.Nary_Majorana(Targets.Fortran_Majorana)(UFO.Model) let _ = try Omega_Dirac.main () with | Fusion.Majorana -> Omega_Majorana.main () Index: trunk/omega/src/omega_SM_Higgs_CKM.ml =================================================================== --- trunk/omega/src/omega_SM_Higgs_CKM.ml (revision 8743) +++ trunk/omega/src/omega_SM_Higgs_CKM.ml (revision 8744) @@ -1,35 +1,35 @@ (* omega_SM_Higgs_CKM.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. *) -module O = Omega.Make(Fusion.Mixed23)(Targets.Fortran) +module O = Omega.Mixed23(Targets.Fortran) (Modellib_SM.SM(Modellib_SM.SM_Higgs_CKM)) let _ = O.main () (*i * Local Variables: * mode:caml * indent-tabs-mode:nil * page-delimiter:"^(\\* .*\n" * End: i*) Index: trunk/omega/src/omega_THDM_VM.ml =================================================================== --- trunk/omega/src/omega_THDM_VM.ml (revision 8743) +++ trunk/omega/src/omega_THDM_VM.ml (revision 8744) @@ -1,36 +1,36 @@ (* omega_THDM_VM.ml -- 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. *) -module O = Omega.Make(Fusion.Mixed23)(Targets.VM) +module O = Omega.Mixed23(Targets.VM) (Modellib_BSM.TwoHiggsDoublet(Modellib_BSM.THDM)) let _ = O.main () (*i * Local Variables: * mode:caml * indent-tabs-mode:nil * page-delimiter:"^(\\* .*\n" * End: i*) Index: trunk/omega/src/omega_SM_Higgs_VM.ml =================================================================== --- trunk/omega/src/omega_SM_Higgs_VM.ml (revision 8743) +++ trunk/omega/src/omega_SM_Higgs_VM.ml (revision 8744) @@ -1,35 +1,35 @@ (* omega_SM_Higgs_VM.ml -- 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. *) -module O = Omega.Make(Fusion.Mixed23)(Targets.VM) +module O = Omega.Mixed23(Targets.VM) (Modellib_SM.SM(Modellib_SM.SM_Higgs)) let _ = O.main () (*i * Local Variables: * mode:caml * indent-tabs-mode:nil * page-delimiter:"^(\\* .*\n" * End: i*) Index: trunk/omega/src/omega_Phi4.ml =================================================================== --- trunk/omega/src/omega_Phi4.ml (revision 8743) +++ trunk/omega/src/omega_Phi4.ml (revision 8744) @@ -1,34 +1,34 @@ (* omega_Phi4.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. *) -module O = Omega.Make(Fusion.Mixed23)(Targets.Fortran)(Modellib_SM.Phi4) +module O = Omega.Mixed23(Targets.Fortran)(Modellib_SM.Phi4) let _ = O.main () (*i * Local Variables: * mode:caml * indent-tabs-mode:nil * page-delimiter:"^(\\* .*\n" * End: i*) Index: trunk/omega/src/omega_NMSSM_CKM.ml =================================================================== --- trunk/omega/src/omega_NMSSM_CKM.ml (revision 8743) +++ trunk/omega/src/omega_NMSSM_CKM.ml (revision 8744) @@ -1,35 +1,26 @@ (* omega_NMSSM_CKM.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. *) -module O = Omega.Make(Fusion_vintage.Mixed23_Majorana)(Targets.Fortran_Majorana) - (Modellib_NMSSM.NMSSM_func(Modellib_NMSSM.NMSSM_CKM)) +module O = Omega.Mixed23_Majorana_vintage(Targets.Fortran_Majorana)(Modellib_NMSSM.NMSSM_func(Modellib_NMSSM.NMSSM_CKM)) let _ = O.main () - -(*i - * Local Variables: - * mode:caml - * indent-tabs-mode:nil - * page-delimiter:"^(\\* .*\n" - * End: -i*) Index: trunk/omega/src/omega_UFO_Dirac.ml =================================================================== --- trunk/omega/src/omega_UFO_Dirac.ml (revision 8743) +++ trunk/omega/src/omega_UFO_Dirac.ml (revision 8744) @@ -1,35 +1,26 @@ (* omega_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. *) -module Bound (M : Model.T) : Tuple.Bound = - struct - (* \begin{dubious} - Above [max_degree = 6], the performance drops \emph{dramatically}! - \end{dubious} *) - let max_arity () = - pred (M.max_degree ()) - end - -module O = Omega.Make(Fusion.Nary(Bound(UFO.Model)))(Targets.Fortran)(UFO.Model) +module O = Omega.Nary(Targets.Fortran)(UFO.Model) let _ = O.main () Index: trunk/omega/src/omega_MSSM_Grav.ml =================================================================== --- trunk/omega/src/omega_MSSM_Grav.ml (revision 8743) +++ trunk/omega/src/omega_MSSM_Grav.ml (revision 8744) @@ -1,35 +1,34 @@ (* omega_MSSM_Grav.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. *) -module O = Omega.Make(Fusion_vintage.Mixed23_Majorana)(Targets.Fortran_Majorana) - (Modellib_MSSM.MSSM(Modellib_MSSM.MSSM_Grav)) +module O = Omega.Mixed23_Majorana_vintage(Targets.Fortran_Majorana)(Modellib_MSSM.MSSM(Modellib_MSSM.MSSM_Grav)) let _ = O.main () (*i * Local Variables: * mode:caml * indent-tabs-mode:nil * page-delimiter:"^(\\* .*\n" * End: i*) Index: trunk/omega/src/omega_SM_dim6.ml =================================================================== --- trunk/omega/src/omega_SM_dim6.ml (revision 8743) +++ trunk/omega/src/omega_SM_dim6.ml (revision 8744) @@ -1,36 +1,36 @@ (* omega_SM_dim6.ml -- Copyright (C) 1999-2015 by Wolfgang Kilian Thorsten Ohl Juergen Reuter with contributions from Christian Speckner So-young Shim (only 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. *) -module O = Omega.Make(Fusion.Mixed23)(Targets.Fortran) +module O = Omega.Mixed23(Targets.Fortran) (Modellib_SM.SM(Modellib_SM.SM_dim6)) let _ = O.main () (*i * Local Variables: * mode:caml * indent-tabs-mode:nil * page-delimiter:"^(\\* .*\n" * End: i*) Index: trunk/omega/src/omega_Xdim.ml =================================================================== --- trunk/omega/src/omega_Xdim.ml (revision 8743) +++ trunk/omega/src/omega_Xdim.ml (revision 8744) @@ -1,35 +1,35 @@ (* omega_Xdim.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. *) -module O = Omega.Make(Fusion.Mixed23)(Targets.Fortran) +module O = Omega.Mixed23(Targets.Fortran) (Modellib_BSM.Xdim(Modellib_BSM.BSM_bsm)) let _ = O.main () (*i * Local Variables: * mode:caml * indent-tabs-mode:nil * page-delimiter:"^(\\* .*\n" * End: i*) Index: trunk/omega/src/omega_PSSSM.ml =================================================================== --- trunk/omega/src/omega_PSSSM.ml (revision 8743) +++ trunk/omega/src/omega_PSSSM.ml (revision 8744) @@ -1,35 +1,34 @@ (* omega_PSSSM.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. *) -module O = Omega.Make(Fusion_vintage.Mixed23_Majorana)(Targets.Fortran_Majorana) - (Modellib_PSSSM.ExtMSSM(Modellib_PSSSM.PSSSM)) +module O = Omega.Mixed23_Majorana_vintage(Targets.Fortran_Majorana)(Modellib_PSSSM.ExtMSSM(Modellib_PSSSM.PSSSM)) let _ = O.main () (*i * Local Variables: * mode:caml * indent-tabs-mode:nil * page-delimiter:"^(\\* .*\n" * End: i*) Index: trunk/omega/src/omega_QCD_VM.ml =================================================================== --- trunk/omega/src/omega_QCD_VM.ml (revision 8743) +++ trunk/omega/src/omega_QCD_VM.ml (revision 8744) @@ -1,36 +1,27 @@ (* omega_QCD_VM.ml -- 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. *) -module O = Omega.Make(Fusion.Mixed23)(Targets.VM)(Modellib_SM.QCD) +module O = Omega.Mixed23(Targets.VM)(Modellib_SM.QCD) let _ = O.main () - - -(*i - * Local Variables: - * mode:caml - * indent-tabs-mode:nil - * page-delimiter:"^(\\* .*\n" - * End: -i*) Index: trunk/omega/src/omega_MSSM_CKM.ml =================================================================== --- trunk/omega/src/omega_MSSM_CKM.ml (revision 8743) +++ trunk/omega/src/omega_MSSM_CKM.ml (revision 8744) @@ -1,35 +1,26 @@ (* omega_MSSM_CKM.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. *) -module O = Omega.Make(Fusion_vintage.Mixed23_Majorana)(Targets.Fortran_Majorana) - (Modellib_MSSM.MSSM(Modellib_MSSM.MSSM_no_4_ckm)) +module O = Omega.Mixed23_Majorana_vintage(Targets.Fortran_Majorana)(Modellib_MSSM.MSSM(Modellib_MSSM.MSSM_no_4_ckm)) let _ = O.main () - -(*i - * Local Variables: - * mode:caml - * indent-tabs-mode:nil - * page-delimiter:"^(\\* .*\n" - * End: -i*) Index: trunk/omega/src/omega_SM_CKM.ml =================================================================== --- trunk/omega/src/omega_SM_CKM.ml (revision 8743) +++ trunk/omega/src/omega_SM_CKM.ml (revision 8744) @@ -1,35 +1,35 @@ (* omega_SM_CKM.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. *) -module O = Omega.Make(Fusion.Mixed23)(Targets.Fortran) +module O = Omega.Mixed23(Targets.Fortran) (Modellib_SM.SM(Modellib_SM.SM_no_anomalous_ckm)) let _ = O.main () (*i * Local Variables: * mode:caml * indent-tabs-mode:nil * page-delimiter:"^(\\* .*\n" * End: i*) Index: trunk/omega/src/omega_NMSSM_Hgg.ml =================================================================== --- trunk/omega/src/omega_NMSSM_Hgg.ml (revision 8743) +++ trunk/omega/src/omega_NMSSM_Hgg.ml (revision 8744) @@ -1,36 +1,27 @@ (* omega_NMSSM.ml -- Copyright (C) 1999-2021 by Wolfgang Kilian Thorsten Ohl Juergen Reuter with contributions from Christian Speckner and Felix Braam (parts of this file only) 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_NMSSM.NMSSM_func(Modellib_NMSSM.NMSSM_Hgg)) +module O = Omega.Mixed23_Majorana_vintage(Targets.Fortran_Majorana)(Modellib_NMSSM.NMSSM_func(Modellib_NMSSM.NMSSM_Hgg)) let _ = O.main () - -(*i - * Local Variables: - * mode:caml - * indent-tabs-mode:nil - * page-delimiter:"^(\\* .*\n" - * End: -i*) Index: trunk/omega/src/omega_SM_ac.ml =================================================================== --- trunk/omega/src/omega_SM_ac.ml (revision 8743) +++ trunk/omega/src/omega_SM_ac.ml (revision 8744) @@ -1,35 +1,35 @@ (* omega_SM_ac.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. *) -module O = Omega.Make(Fusion.Mixed23)(Targets.Fortran) +module O = Omega.Mixed23(Targets.Fortran) (Modellib_SM.SM(Modellib_SM.SM_anomalous)) let _ = O.main () (*i * Local Variables: * mode:caml * indent-tabs-mode:nil * page-delimiter:"^(\\* .*\n" * End: i*) Index: trunk/omega/src/omega_NoH_rx.ml =================================================================== --- trunk/omega/src/omega_NoH_rx.ml (revision 8743) +++ trunk/omega/src/omega_NoH_rx.ml (revision 8744) @@ -1,36 +1,36 @@ (* omega_NoH_rx.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. *) -module O = Omega.Make(Fusion.Mixed23)(Targets.Fortran) +module O = Omega.Mixed23(Targets.Fortran) (Modellib_NoH.NoH(Modellib_NoH.NoH_k_matrix)) let _ = O.main () (*i * Local Variables: * mode:caml * indent-tabs-mode:nil * page-delimiter:"^(\\* .*\n" * End: i*) Index: trunk/omega/src/omega_SM_Higgs.ml =================================================================== --- trunk/omega/src/omega_SM_Higgs.ml (revision 8743) +++ trunk/omega/src/omega_SM_Higgs.ml (revision 8744) @@ -1,35 +1,35 @@ (* omega_SM_Higgs.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. *) -module O = Omega.Make(Fusion.Mixed23)(Targets.Fortran) +module O = Omega.Mixed23(Targets.Fortran) (Modellib_SM.SM(Modellib_SM.SM_Higgs)) let _ = O.main () (*i * Local Variables: * mode:caml * indent-tabs-mode:nil * page-delimiter:"^(\\* .*\n" * End: i*) Index: trunk/omega/src/omega_Littlest.ml =================================================================== --- trunk/omega/src/omega_Littlest.ml (revision 8743) +++ trunk/omega/src/omega_Littlest.ml (revision 8744) @@ -1,35 +1,35 @@ (* omega_Littlest.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. *) -module O = Omega.Make(Fusion.Mixed23)(Targets.Fortran_Majorana) +module O = Omega.Mixed23(Targets.Fortran_Majorana) (Modellib_BSM.Littlest(Modellib_BSM.BSM_bsm)) let _ = O.main () (*i * Local Variables: * mode:caml * indent-tabs-mode:nil * page-delimiter:"^(\\* .*\n" * End: i*) Index: trunk/omega/src/omega_MSSM_Hgg.ml =================================================================== --- trunk/omega/src/omega_MSSM_Hgg.ml (revision 8743) +++ trunk/omega/src/omega_MSSM_Hgg.ml (revision 8744) @@ -1,35 +1,34 @@ (* omega_MSSM_Hgg.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. *) -module O = Omega.Make(Fusion_vintage.Mixed23_Majorana)(Targets.Fortran_Majorana) - (Modellib_MSSM.MSSM(Modellib_MSSM.MSSM_Hgg)) +module O = Omega.Mixed23_Majorana_vintage(Targets.Fortran_Majorana)(Modellib_MSSM.MSSM(Modellib_MSSM.MSSM_Hgg)) let _ = O.main () (*i * Local Variables: * mode:caml * indent-tabs-mode:nil * page-delimiter:"^(\\* .*\n" * End: i*) Index: trunk/omega/src/omega_SM_CKM_VM.ml =================================================================== --- trunk/omega/src/omega_SM_CKM_VM.ml (revision 8743) +++ trunk/omega/src/omega_SM_CKM_VM.ml (revision 8744) @@ -1,35 +1,35 @@ (* omega_SM_CKM_VM.ml -- 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. *) -module O = Omega.Make(Fusion.Mixed23)(Targets.VM) +module O = Omega.Mixed23(Targets.VM) (Modellib_SM.SM(Modellib_SM.SM_no_anomalous_ckm)) let _ = O.main () (*i * Local Variables: * mode:caml * indent-tabs-mode:nil * page-delimiter:"^(\\* .*\n" * End: i*) Index: trunk/omega/src/omega_UED.ml =================================================================== --- trunk/omega/src/omega_UED.ml (revision 8743) +++ trunk/omega/src/omega_UED.ml (revision 8744) @@ -1,35 +1,35 @@ (* omega_UED.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. *) -module O = Omega.Make(Fusion.Mixed23)(Targets.Fortran) +module O = Omega.Mixed23(Targets.Fortran) (Modellib_BSM.UED(Modellib_BSM.BSM_bsm)) let _ = O.main () (*i * Local Variables: * mode:caml * indent-tabs-mode:nil * page-delimiter:"^(\\* .*\n" * End: i*) Index: trunk/omega/src/omega_SM_VM.ml =================================================================== --- trunk/omega/src/omega_SM_VM.ml (revision 8743) +++ trunk/omega/src/omega_SM_VM.ml (revision 8744) @@ -1,35 +1,26 @@ (* omega_SM_VM.ml -- 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. *) -module O = Omega.Make(Fusion.Mixed23)(Targets.VM) - (Modellib_SM.SM(Modellib_SM.SM_no_anomalous)) +module O = Omega.Mixed23(Targets.VM)(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/omega_WZW.ml =================================================================== --- trunk/omega/src/omega_WZW.ml (revision 8743) +++ trunk/omega/src/omega_WZW.ml (revision 8744) @@ -1,35 +1,35 @@ (* omega_WZW.ml -- Copyright (C) 1999-2015 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.Mixed23)(Targets.Fortran) +module O = Omega.Mixed23(Targets.Fortran) (Modellib_WZW.WZW(Modellib_WZW.SM_no_anomalous)) let _ = O.main () (*i * Local Variables: * mode:caml * indent-tabs-mode:nil * page-delimiter:"^(\\* .*\n" * End: i*) Index: trunk/omega/src/omega_AltH.ml =================================================================== --- trunk/omega/src/omega_AltH.ml (revision 8743) +++ trunk/omega/src/omega_AltH.ml (revision 8744) @@ -1,36 +1,36 @@ (* omega_AltH.ml -- Copyright (C) 1999-2021 by Wolfgang Kilian Thorsten Ohl Juergen Reuter with contributions from Marco Sekulla 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.Mixed23)(Targets.Fortran) +module O = Omega.Mixed23(Targets.Fortran) (Modellib_NoH.AltH(Modellib_NoH.NoH_k_matrix)) let _ = O.main () (*i * Local Variables: * mode:caml * indent-tabs-mode:nil * page-delimiter:"^(\\* .*\n" * End: i*) Index: trunk/omega/src/omega_SM_top.ml =================================================================== --- trunk/omega/src/omega_SM_top.ml (revision 8743) +++ trunk/omega/src/omega_SM_top.ml (revision 8744) @@ -1,629 +1,629 @@ (* omega_SM_top.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. *) (* \thocwmodulesection{SM with charge $4/3$ top} *) module type SM_flags = sig val include_anomalous : bool val k_matrix : bool end module SM_no_anomalous : SM_flags = struct let include_anomalous = false let k_matrix = false end module SM_gluons : SM_flags = struct let include_anomalous = false let k_matrix = false end module Anomtop (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"; "running_width", Arg.Unit (fun () -> default_width := Running), "use running width" ] let caveats () = [] 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 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 "Models.Anomtop.gauge_symbol: internal error" let family n = List.map matter_field [ L n; N n; U n; D n ] 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", [O H]; "Goldstone Bosons", List.map other [Phip; Phim; Phi0] ] let flavors () = ThoList.flatmap snd (external_flavors ()) let spinor n = if n >= 0 then Spinor else ConjSpinor 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 -> Scalar 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 | _ -> Color.Singlet let nc () = 3 let prop_spinor n = if n >= 0 then Prop_Spinor else Prop_ConjSpinor 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 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 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_top.generation': " ^ string_of_int n) let generation f = 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 (1|2) -> 2//3 | U ((-1)|(-2)) -> -2//3 | U 3 -> -4//3 | U (-3) -> 4//3 | U n -> invalid_arg ("SM_top.charge: up quark " ^ string_of_int n) | 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 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 | Pi | Alpha_QED | Sin2thw | Sinthw | Costhw | E | G_weak | Vev | Q_lepton | Q_up | Q_down | Q_top | G_CC | G_NC_neutrino | G_NC_lepton | G_NC_up | G_NC_down | G_NC_top | I_Q_W | I_G_ZWW | G_WWWW | G_ZZWW | G_AZWW | G_AAWW | G_HWW | G_HHWW | G_HZZ | G_HHZZ | G_Htt | G_Hbb | G_Hcc | G_Htautau | G_H3 | G_H4 | Gs | I_Gs | G2 | Mass of flavor | Width of flavor (* Two integer counters for the QCD and EW order of the couplings. *) type orders = int * int let orders = function | _ -> (0,0) let input_parameters = [] let derived_parameters = [] let derived_parameter_arrays = [] 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 electromagnetic_currents' n = List.map mgm [ ((L (-n), Ga, L n), FBF (1, Psibar, V, Psi), Q_lepton); ((D (-n), Ga, D n), FBF (1, Psibar, V, Psi), Q_down) ] let em_up_type_currents = List.map mgm [ ((U (-1), Ga, U 1), FBF (1, Psibar, V, Psi), Q_up); ((U (-2), Ga, U 2), FBF (1, Psibar, V, Psi), Q_up); ((U (-3), Ga, U 3), FBF (1, Psibar, V, Psi), Q_top)] let electromagnetic_currents = ThoList.flatmap electromagnetic_currents' [1;2;3] @ em_up_type_currents 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); ((D (-n), Z, D n), FBF (1, Psibar, VA, Psi), G_NC_down) ] let neutral_up_type_currents = List.map mgm [ ((U (-1), Z, U 1), FBF (1, Psibar, VA, Psi), G_NC_up); ((U (-2), Z, U 2), FBF (1, Psibar, VA, Psi), G_NC_up); ((U (-3), Z, U 3), FBF (1, Psibar, VA, Psi), G_NC_top) ] let neutral_currents = ThoList.flatmap neutral_currents' [1;2;3] @ neutral_up_type_currents (* \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_up_currents = List.map mgm [ ((U (-1), Wp, D 1), FBF (1, Psibar, VL, Psi), G_CC); ((U (-2), Wp, D 2), FBF (1, Psibar, VL, Psi), G_CC); ((U (-3), Wm, D 3), FBF (1, Psibar, VL, Psi), G_CC); ((D (-1), Wm, U 1), FBF (1, Psibar, VL, Psi), G_CC); ((D (-2), Wm, U 2), FBF (1, Psibar, VL, Psi), G_CC); ((D (-3), Wp, U 3), FBF (1, Psibar, VL, Psi), G_CC) ] let charged_currents = ThoList.flatmap charged_currents' [1;2;3] @ charged_up_currents 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) ] (* \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 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)] 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 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 ] let 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 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 higgs = [ (O H, O H, O H), Scalar_Scalar_Scalar 1, G_H3 ] let higgs4 = [ (O H, O H, O H, O H), Scalar4 1, G_H4 ] 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) ] let vertices3 = (electromagnetic_currents @ ThoList.flatmap color_currents [1;2;3] @ neutral_currents @ charged_currents @ yukawa @ triple_gauge @ gauge_higgs @ higgs @ goldstone_vertices) 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 | _ -> invalid_arg "Models.Anomtop.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 "Models.Anomtop.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 "Models.Anomtop.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 "Models.Anomtop.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 "Models.Anomtop.flavor_to_string: invalid down type quark" end | G f -> begin match f with | Gl -> "g" | Ga -> "A" | Z -> "Z" | Wp -> "W+" | Wm -> "W-" end | O f -> begin match f with | Phip -> "phi+" | Phim -> "phi-" | Phi0 -> "phi0" | H -> "H" 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 "Models.Anomtop.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 "Models.Anomtop.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 "Models.Anomtop.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 "Models.Anomtop.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 -> "phi0" | H -> "H" 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" 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 end 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 | Unit -> "unit" | Pi -> "PI" | Alpha_QED -> "alpha" | E -> "e" | G_weak -> "g" | Vev -> "vev" | Sin2thw -> "sin2thw" | Sinthw -> "sinthw" | Costhw -> "costhw" | Q_lepton -> "qlep" | Q_up -> "qup" | Q_down -> "qdwn" | Q_top -> "qtop" | G_NC_lepton -> "gnclep" | G_NC_neutrino -> "gncneu" | G_NC_up -> "gncup" | G_NC_down -> "gncdwn" | G_NC_top -> "gnctop" | G_CC -> "gcc" | I_Q_W -> "iqw" | I_G_ZWW -> "igzww" | G_WWWW -> "gw4" | G_ZZWW -> "gzzww" | G_AZWW -> "gazww" | G_AAWW -> "gaaww" | G_HWW -> "ghww" | G_HZZ -> "ghzz" | G_HHWW -> "ghhww" | G_HHZZ -> "ghhzz" | G_Htt -> "ghtt" | G_Hbb -> "ghbb" | G_Htautau -> "ghtautau" | G_Hcc -> "ghcc" | 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 end -module O = Omega.Make(Fusion.Mixed23)(Targets.Fortran) +module O = Omega.Mixed23(Targets.Fortran) (Anomtop(SM_no_anomalous)) let _ = O.main () (*i * Local Variables: * mode:caml * indent-tabs-mode:nil * page-delimiter:"^(\\* .*\n" * End: i*) Index: trunk/omega/src/omega_Zprime.ml =================================================================== --- trunk/omega/src/omega_Zprime.ml (revision 8743) +++ trunk/omega/src/omega_Zprime.ml (revision 8744) @@ -1,35 +1,35 @@ (* omega_Zprime.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. *) -module O = Omega.Make(Fusion.Mixed23)(Targets.Fortran) +module O = Omega.Mixed23(Targets.Fortran) (Modellib_Zprime.Zprime(Modellib_Zprime.SM_no_anomalous)) let _ = O.main () (*i * Local Variables: * mode:caml * indent-tabs-mode:nil * page-delimiter:"^(\\* .*\n" * End: i*) Index: trunk/omega/src/omega_Zprime_VM.ml =================================================================== --- trunk/omega/src/omega_Zprime_VM.ml (revision 8743) +++ trunk/omega/src/omega_Zprime_VM.ml (revision 8744) @@ -1,32 +1,32 @@ (* omega_Zprime_VM.ml -- 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. *) -module O = Omega.Make(Fusion.Mixed23)(Targets.VM) +module O = Omega.Mixed23(Targets.VM) (Modellib_Zprime.Zprime(Modellib_Zprime.SM_no_anomalous)) let _ = O.main () (*i * Local Variables: * mode:caml i*) Index: trunk/omega/src/omega_SM_clones.ml =================================================================== --- trunk/omega/src/omega_SM_clones.ml (revision 8743) +++ trunk/omega/src/omega_SM_clones.ml (revision 8744) @@ -1,35 +1,35 @@ (* omega_SM_clones.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. *) -module O = Omega.Make(Fusion.Mixed23)(Targets.Fortran)(Modellib_SM.SM_clones) +module O = Omega.Mixed23(Targets.Fortran)(Modellib_SM.SM_clones) let _ = O.main () (*i * Local Variables: * mode:caml * indent-tabs-mode:nil * page-delimiter:"^(\\* .*\n" * End: i*) Index: trunk/omega/src/omega_THDM_CKM.ml =================================================================== --- trunk/omega/src/omega_THDM_CKM.ml (revision 8743) +++ trunk/omega/src/omega_THDM_CKM.ml (revision 8744) @@ -1,36 +1,36 @@ (* omega_THDM_CKM.ml -- 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. *) -module O = Omega.Make(Fusion.Mixed23)(Targets.Fortran) +module O = Omega.Mixed23(Targets.Fortran) (Modellib_BSM.TwoHiggsDoublet(Modellib_BSM.THDM_CKM)) let _ = O.main () (*i * Local Variables: * mode:caml * indent-tabs-mode:nil * page-delimiter:"^(\\* .*\n" * End: i*) Index: trunk/omega/src/omega_SM_Majorana.ml =================================================================== --- trunk/omega/src/omega_SM_Majorana.ml (revision 8743) +++ trunk/omega/src/omega_SM_Majorana.ml (revision 8744) @@ -1,36 +1,26 @@ (* omega_SM_Maj.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. *) -module O = Omega.Make - (Fusion.Mixed23_Majorana)(Targets.Fortran_Majorana) - (Modellib_SM.SM(Modellib_SM.SM_no_anomalous)) +module O = Omega.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/omega_THDM_CKM_VM.ml =================================================================== --- trunk/omega/src/omega_THDM_CKM_VM.ml (revision 8743) +++ trunk/omega/src/omega_THDM_CKM_VM.ml (revision 8744) @@ -1,36 +1,36 @@ (* omega_THDM_CKM_VM.ml -- 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. *) -module O = Omega.Make(Fusion.Mixed23)(Targets.VM) +module O = Omega.Mixed23(Targets.VM) (Modellib_BSM.TwoHiggsDoublet(Modellib_BSM.THDM_CKM)) let _ = O.main () (*i * Local Variables: * mode:caml * indent-tabs-mode:nil * page-delimiter:"^(\\* .*\n" * End: i*) Index: trunk/omega/src/omega_Threeshl_nohf.ml =================================================================== --- trunk/omega/src/omega_Threeshl_nohf.ml (revision 8743) +++ trunk/omega/src/omega_Threeshl_nohf.ml (revision 8744) @@ -1,35 +1,35 @@ (* omega_Threeshl_nohf.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. *) -module O = Omega.Make(Fusion.Mixed23)(Targets.Fortran) +module O = Omega.Mixed23(Targets.Fortran) (Modellib_BSM.Threeshl(Modellib_BSM.Threeshl_no_ckm_no_hf)) let _ = O.main () (*i * Local Variables: * mode:caml * indent-tabs-mode:nil * page-delimiter:"^(\\* .*\n" * End: i*) Index: trunk/omega/src/omega.mli =================================================================== --- trunk/omega/src/omega.mli (revision 8743) +++ trunk/omega/src/omega.mli (revision 8744) @@ -1,49 +1,56 @@ (* omega.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 type T = sig val main : unit -> unit (* \begin{dubious} This used to be only intended for debugging O'Giga, but might live longer \ldots \end{dubious} *) type flavor val diagrams : flavor -> flavor -> flavor list -> ((flavor * Momentum.Default.t) * (flavor * Momentum.Default.t, flavor * Momentum.Default.t) Tree.t) list end -module Make (FM : Fusion.Maker) (TM : Target.Maker) (M : Model.T) : - T with type flavor = M.flavor -(*i - * Local Variables: - * mode:caml - * indent-tabs-mode:nil - * page-delimiter:"^(\\* .*\n" - * End: -i*) +(* Wrap the two instances of [Fusion.Maker] for + amplitudes and phase space into a single functor to + make sure that the Dirac and Majorana versions match. + Don't export the slightly unsafe + [module Make (FM : Fusion.Maker) (PM : Fusion.Maker) + (TM : Target.Maker) (M : Model.T) : T with type flavor = M.flavor]. *) + +module Binary (TM : Target.Maker) (M : Model.T) : T with type flavor = M.flavor +module Binary_Majorana (TM : Target.Maker) (M : Model.T) : T with type flavor = M.flavor + +module Mixed23 (TM : Target.Maker) (M : Model.T) : T with type flavor = M.flavor +module Mixed23_Majorana (TM : Target.Maker) (M : Model.T) : T with type flavor = M.flavor +module Mixed23_Majorana_vintage (TM : Target.Maker) (M : Model.T) : T with type flavor = M.flavor + +module Nary (TM : Target.Maker) (M : Model.T) : T with type flavor = M.flavor +module Nary_Majorana (TM : Target.Maker) (M : Model.T) : T with type flavor = M.flavor Index: trunk/omega/src/omega_Littlest_Zprime.ml =================================================================== --- trunk/omega/src/omega_Littlest_Zprime.ml (revision 8743) +++ trunk/omega/src/omega_Littlest_Zprime.ml (revision 8744) @@ -1,972 +1,972 @@ (* omega_Littlest_Zprime.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. *) (* \thocwmodulesection{SM with Littlest Higgs Z'} *) module type SM_flags = sig val include_gluons : bool val include_anomalous : bool val include_supp : bool val k_matrix : bool end module SM_no_anomalous : SM_flags = struct let include_gluons = false let include_anomalous = false let include_supp = false let k_matrix = false end module SM_anomalous : SM_flags = struct let include_gluons = false let include_anomalous = true let include_supp = false let k_matrix = false end module SM_k_matrix : SM_flags = struct let include_gluons = false let include_anomalous = false let include_supp = false let k_matrix = true end module SM_gluons : SM_flags = struct let include_gluons = true let include_anomalous = false let include_supp = false let k_matrix = false end module SM_supp : SM_flags = struct let include_gluons = false let include_anomalous = false let include_supp = true let k_matrix = false end module Zprime (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"; "running_width", Arg.Unit (fun () -> default_width := Running), "use running width" ] (* We do not introduce the Goldstones for the heavy vectors here. *) type matter_field = L of int | N of int | U of int | D of int | TopH | TopHq | DH | DHq type gauge_boson = Ga | Wp | Wm | Z | Gl | Gl_aux | Xp | Xm | X0 | Y0 | ZH type other = Phip | Phim | Phi0 | H | Eta 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 "Models.Zprime.gauge_symbol: internal error" let family n = List.map matter_field [ L n; N n; U n; D n ] let external_flavors () = [ "1st Generation", ThoList.flatmap family [1; -1]; "2nd Generation", ThoList.flatmap family [2; -2]; "3rd Generation", ThoList.flatmap family [3; -3]; "Heavy Quarks", List.map matter_field [TopH; TopHq; DH; DHq]; "Gauge Bosons", List.map gauge_boson [Ga; Z; Wp; Wm; Gl; Xp; Xm; X0; Y0; ZH]; "Higgs", List.map other [H; Eta]; "Goldstone Bosons", List.map other [Phip; Phim; Phi0] ] let flavors () = ThoList.flatmap snd (external_flavors ()) @ [ G Gl_aux] let squ = function | x -> Pow (Atom x, 2) let spinor n = if n >= 0 then Spinor else ConjSpinor 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 | TopH -> Spinor | TopHq -> ConjSpinor | DH -> Spinor | DHq -> ConjSpinor end | G f -> begin match f with | Ga | Gl -> Vector | Wp | Wm | Z | Xp | Xm | X0 | Y0 | ZH -> Massive_Vector | Gl_aux -> Tensor_1 end | O f -> Scalar 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) | M TopH -> Color.SUN 3 | M TopHq -> Color.SUN (-3) | M DH -> Color.SUN 3 | M DHq -> Color.SUN (-3) | G Gl | G Gl_aux -> Color.AdjSUN 3 | _ -> Color.Singlet let prop_spinor n = if n >= 0 then Prop_Spinor else Prop_ConjSpinor 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 | TopH -> Prop_Spinor | TopHq -> Prop_ConjSpinor | DH -> Prop_Spinor | DHq -> Prop_ConjSpinor end | G f -> begin match f with | Ga | Gl -> Prop_Feynman | Wp | Wm | Z | Xp | Xm | X0 | Y0 | ZH -> Prop_Unitarity | Gl_aux -> Aux_Tensor_1 end | O f -> begin match f with | Phip | Phim | Phi0 -> Only_Insertion | H | Eta -> Prop_Scalar 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)) | M TopH | M TopHq | M DH | M DHq -> Fudged | _ -> !default_width else !default_width let goldstone = function | G f -> begin match f with | Wp -> Some (O Phip, Coupling.Const 1) | Wm -> Some (O Phim, Coupling.Const 1) | Z -> Some (O Phi0, Coupling.Const 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) | TopH -> TopHq | TopHq -> TopH | DH -> DHq | DHq -> DH end) | G f -> G (begin match f with | Gl -> Gl | Ga -> Ga | Z -> Z | Wp -> Wm | Wm -> Wp | Xp -> Xm | Xm -> Xp | X0 -> X0 | Y0 -> Y0 | ZH -> ZH | Gl_aux -> Gl_aux end) | O f -> O (begin match f with | Phip -> Phim | Phim -> Phip | Phi0 -> Phi0 | H -> H | Eta -> Eta 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 | TopH -> 1 | TopHq -> -1 | DH -> 1 | DHq -> -1 end | G f -> begin match f with | Gl | Ga | Z | Wp | Wm | Gl_aux | Xp | Xm | X0 | Y0 | ZH -> 0 end | O _ -> 0 type constant = | Unit | Pi | Alpha_QED | Sin2thw | Sinthw | Costhw | E | G_weak | Vev | VHeavy | Supp | Supp2 | Sinpsi | Cospsi | Atpsi | Sccs (* Mixing angles of SU(2) *) | Q_lepton | Q_up | Q_down | Q_Z_up | G_CC | G_NC_neutrino | G_NC_lepton | G_NC_up | G_NC_down | G_NC_h_neutrino | G_NC_h_lepton | G_NC_h_up | G_NC_h_down | G_CC_heavy | G_zhthth | G_CC_supp1 | G_CC_supp2 | I_Q_W | I_G_ZWW | I_G_WWW | I_G_Z1 | I_G_Z2 | I_G_Z3 | I_G_Z4 | I_Q_H | I_Q_ZH | G_over4 | G_over4_sup | G_CC_sup | G_WWWW | G_ZZWW | G_AZWW | G_AAWW | I_G1_AWW | I_G1_ZWW | I_G1_plus_kappa_AWW | I_G1_plus_kappa_ZWW | I_G1_minus_kappa_AWW | I_G1_minus_kappa_ZWW | I_kappa_minus_G1_AWW | I_kappa_minus_G1_ZWW | I_lambda_AWW | I_lambda_ZWW | Alpha_WWWW0 | Alpha_ZZWW1 | Alpha_WWWW2 | Alpha_ZZWW0 | Alpha_ZZZZ | G_HWW | G_HHWW | G_HZZ | G_HHZZ | G_heavy_HVV | G_heavy_HWW | G_heavy_HZZ | G_heavy_HHVV | G_Htt | G_Hbb | G_Hcc | G_Htautau | G_H3 | G_H4 | G_Hthth | G_Htht | G_Ethth | G_Etht | G_Ett | G_Ebb | G_ZEH | G_ZHEH | G_XEH | G_HGaGa | G_HGaZ | G_EGaGa | G_EGaZ | G_EGlGl | G_strong | Mass of flavor | Width of flavor | K_Matrix_Coeff of int | K_Matrix_Pole of int (* \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} *) let input_parameters = [ Alpha_QED, 1. /. 137.0359895; Sin2thw, 0.23124; VHeavy, 2000.0; 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 ] (* hier, Hier, hallo, hier Higgs couplings still missing. *) let derived_parameters = [ Real E, Sqrt (Prod [Const 4; Atom Pi; Atom Alpha_QED]); Real Sinthw, Sqrt (Atom Sin2thw); Real Costhw, Sqrt (Diff (Const 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 [Const 2; Atom (Mass (G Wp))], Atom G_weak); Real Supp, Quot (Atom Vev, Atom VHeavy); Real Supp2, squ Supp; Real Atpsi, Quot (Atom Cospsi, Atom Sinpsi); Real Sccs, Prod [Atom Sinpsi; Atom Cospsi; Diff (squ Cospsi, squ Sinpsi)]; Real Q_lepton, Atom E; Real Q_up, Prod [Quot (Const (-2), Const 3); Atom E]; Real Q_down, Prod [Quot (Const 1, Const 3); Atom E]; Real G_CC, Neg (Quot (Atom G_weak, Prod [Const 2; Sqrt (Const 2)])); Real G_CC_heavy, Prod [Atom G_CC; Atom Atpsi]; (* Real G_NC_heavy, Quot (Prod [Atom G_weak; Atom Atpsi], Const 4); *) Complex I_Q_W, Prod [I; Atom E]; Complex I_G_ZWW, Prod [I; Atom G_weak; Atom Costhw]; Complex I_G_WWW, Prod [I; Atom G_weak]; Complex I_Q_ZH, Neg (Prod [I; Atom G_weak; Atom Supp2; Atom Sccs ]); Complex I_Q_H, Quot (Atom I_Q_ZH, Atom Costhw) ] (* \begin{equation} - \frac{g}{2\cos\theta_w} \end{equation} *) let g_over_2_costh = Quot (Neg (Atom G_weak), Prod [Const 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 [Const 2; q; Atom Sin2thw])]; Prod [g_over_2_costh; t3]]) let half = Quot (Const 1, Const 2) let derived_parameter_arrays = [ nc_coupling G_NC_neutrino half (Const 0); nc_coupling G_NC_lepton (Neg half) (Const (-1)); nc_coupling G_NC_up half (Quot (Const 2, Const 3)); nc_coupling G_NC_down (Neg half) (Quot (Const (-1), Const 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 = if Flags.include_gluons then List.map mgm [ ((U (-n), Gl, U n), FBF (1, Psibar, V, Psi), G_strong); ((D (-n), Gl, D n), FBF (1, Psibar, V, Psi), G_strong) ] else [] (* \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) ] (* The sign of this coupling is just the one of the T3, being -(1/2) for leptons and down quarks, and +(1/2) for neutrinos and up quarks. *) (* This version is the canonical Little Higgs which is universal couplings of the heavy Z to the SM fermions. let neutral_heavy_currents n = List.map mgm [ ((L (-n), ZH, L n), FBF (1, Psibar, VL, Psi), G_NC_heavy); ((N (-n), ZH, N n), FBF ((-1), Psibar, VL, Psi), G_NC_heavy); ((U (-n), ZH, U n), FBF ((-1), Psibar, VL, Psi), G_NC_heavy); ((D (-n), ZH, D n), FBF (1, Psibar, VL, Psi), G_NC_heavy) ] We want to allow for (almost) completely general couplings but maintain universality (generation independence). Maybe we should also separate the coupling to the top quark since the third generation is somewhat special. *) let neutral_heavy_currents n = List.map mgm [ ((L (-n), ZH, L n), FBF (1, Psibar, VLR, Psi), G_NC_h_lepton); ((N (-n), ZH, N n), FBF ((-1), Psibar, VLR, Psi), G_NC_h_neutrino); ((U (-n), ZH, U n), FBF ((-1), Psibar, VLR, Psi), G_NC_h_up); ((D (-n), ZH, D n), FBF (1, Psibar, VLR, Psi), G_NC_h_down); ] let heavy_top_currents = List.map mgm [ ((TopHq, Ga, TopH), FBF (1, Psibar, V, Psi), Q_up); ((DHq, Ga, DH), FBF (1, Psibar, V, Psi), Q_down); ((TopHq, Z, TopH), FBF (4, Psibar, V, Psi), Q_Z_up); ((DHq, Z, DH), FBF (1, Psibar, V, Psi), Q_Z_up); ((DHq, X0, D 1), FBF (1, Psibar, VL, Psi), G_over4); ((D (-1), X0, DH), FBF (1, Psibar, VL, Psi), G_over4); ((DHq, Y0, D 1), FBF (1, Psibar, VL, Psi), G_over4); ((D (-1), Y0, DH), FBF ((-1), Psibar, VL, Psi), G_over4); ((DHq, Xm, U 1), FBF (1, Psibar, VL, Psi), G_CC); ((U (-1), Xp, DH), FBF (1, Psibar, VL, Psi), G_CC); ((U (-3), X0, U 3), FBF (2, Psibar, VL, Psi), G_over4_sup); ((U (-3), Y0, U 3), FBF (2, Psibar, VL, Psi), G_over4_sup); ((U (-3), Xp, D 3), FBF (1, Psibar, VL, Psi), G_CC_sup); ((D (-3), Xm, U 3), FBF (1, Psibar, VL, Psi), G_CC_sup)] let neutral_supp_currents = List.map mgm [ ((TopHq, ZH, TopH), FBF (1, Psibar, VL, Psi), G_zhthth); ((DHq, ZH, DH), FBF (1, Psibar, VL, Psi), G_zhthth)] (* \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); ((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_heavy_currents n = List.map mgm [ ((L (-n), Xm, N n), FBF (1, Psibar, VL, Psi), G_CC_heavy); ((N (-n), Xp, L n), FBF (1, Psibar, VL, Psi), G_CC_heavy); ((D (-n), Xm, U n), FBF (1, Psibar, VL, Psi), G_CC_heavy); ((U (-n), Xp, D n), FBF (1, Psibar, VL, Psi), G_CC_heavy) ] (* let charged_supp_currents = List.map mgm [ ((TopHq, WHp, D 3), FBF (1, Psibar, VL, Psi), G_CC_supp1); ((D (-3), WHm, TopH), FBF (1, Psibar, VL, Psi), G_CC_supp1); ((TopHq, Wp, D 3), FBF (1, Psibar, VL, Psi), G_CC_supp2); ((D (-3), Wm, TopH), FBF (1, Psibar, VL, Psi), G_CC_supp2)] *) 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) ] let yukawa_add = [ ((M TopHq, O H, M TopH), FBF (1, Psibar, S, Psi), G_Hthth); ((M TopHq, O H, M (U 3)), FBF (1, Psibar, SLR, Psi), G_Htht); ((M (U (-3)), O H, M TopH), FBF (1, Psibar, SLR, Psi), G_Htht); ((M (U (-3)), O Eta, M (U 3)), FBF (1, Psibar, P, Psi), G_Ett); ((M TopHq, O Eta, M (U 3)), FBF (1, Psibar, SLR, Psi), G_Etht); ((M DHq, O Eta, M (D 1)), FBF (1, Psibar, SL, Psi), G_Ett); ((M (D (-3)), O Eta, M (D 3)), FBF (1, Psibar, P, Psi), G_Ebb); ((M (D (-1)), O Eta, M DH), FBF (1, Psibar, SR, Psi), G_Ett); ((M (U (-3)), O Eta, M TopH), FBF (1, Psibar, SLR, Psi), G_Etht)] (* \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) ] let heavy_triple_gauge = List.map tgc [ ((Ga, Xm, Xp), Gauge_Gauge_Gauge 1, I_Q_W); ((Z, Xm, Xp), Gauge_Gauge_Gauge 1, I_Q_ZH); ((Z, X0, Y0), Gauge_Gauge_Gauge 1, I_G_Z1); ((ZH, X0, Y0), Gauge_Gauge_Gauge 1, I_G_Z2); ((Y0, Wm, Xp), Gauge_Gauge_Gauge 1, I_G_Z3); ((Y0, Wp, Xm), Gauge_Gauge_Gauge (-1), I_G_Z3); ((X0, Wm, Xp), Gauge_Gauge_Gauge 1, I_G_Z4); ((X0, Wp, Xm), Gauge_Gauge_Gauge 1, I_G_Z4); ] let triple_gluon = if Flags.include_gluons then List.map tgc [ ((Gl, Gl, Gl), Gauge_Gauge_Gauge 1, G_strong); ((Gl_aux, Gl, Gl), Aux_Gauge_Gauge 1, G_strong) ] else [] (* \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} *) let anomalous_triple_gauge = List.map tgc [ ((Ga, Wp, Wm), Dim4_Vector_Vector_Vector_T 1, I_G1_AWW); ((Z, Wp, Wm), Dim4_Vector_Vector_Vector_T 1, I_G1_ZWW); ((Wp, Wm, Ga), Dim4_Vector_Vector_Vector_T 1, I_G1_plus_kappa_AWW); ((Wp, Wm, Z), Dim4_Vector_Vector_Vector_T 1, I_G1_plus_kappa_ZWW); ((Wp, Wm, Ga), Dim4_Vector_Vector_Vector_L 1, I_G1_minus_kappa_AWW); ((Wp, Wm, Z), Dim4_Vector_Vector_Vector_L 1, I_G1_minus_kappa_ZWW); ((Wm, Ga, Wp), Dim4_Vector_Vector_Vector_T 1, I_G1_plus_kappa_AWW); ((Wm, Z, Wp), Dim4_Vector_Vector_Vector_T 1, I_G1_plus_kappa_ZWW); ((Wm, Ga, Wp), Dim4_Vector_Vector_Vector_L 1, I_kappa_minus_G1_AWW); ((Wm, Z, Wp), Dim4_Vector_Vector_Vector_L 1, I_kappa_minus_G1_ZWW); ((Ga, Wp, Wm), Dim6_Gauge_Gauge_Gauge 1, I_lambda_AWW); ((Z, Wp, Wm), Dim6_Gauge_Gauge_Gauge 1, I_lambda_ZWW) ] let triple_gauge = if Flags.include_anomalous then anomalous_triple_gauge else standard_triple_gauge @ heavy_triple_gauge 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 ] let anomalous_quartic_gauge = if Flags.include_anomalous 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 [] (* 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_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_WWWW0); ((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_WWWW0); ((Wm, Z, Wp, Z), Vector4_K_Matrix_tho (0, [K_Matrix_Coeff 1, K_Matrix_Pole 1]), Alpha_WWWW0); ((Z, Z, Z, Z), Vector4_K_Matrix_tho (0, [K_Matrix_Coeff 0, K_Matrix_Pole 0]), Alpha_WWWW0) ] else [] let heavy_quartic_gauge = [] let quartic_gauge = standard_quartic_gauge @ anomalous_quartic_gauge @ k_matrix_quartic_gauge @ heavy_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 heavy_gauge_higgs = [ ((O H, G Wp, G Xm), Scalar_Vector_Vector 1, G_heavy_HWW); ((O H, G Wm, G Xp), Scalar_Vector_Vector 1, G_heavy_HWW); ((O H, G Z, G X0), Scalar_Vector_Vector 1, G_heavy_HVV); ((O H, G ZH, G X0), Scalar_Vector_Vector 1, G_heavy_HVV)] let standard_gauge_higgs = standard_gauge_higgs' @ heavy_gauge_higgs 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_heavy_gauge_higgs4 = [ (O H, O H, G WHp, G Wm), Scalar2_Vector2 1, G_heavy_HHVV; (O H, O H, G Wp, G WHm), Scalar2_Vector2 1, G_heavy_HHVV; (O H, O H, G Z, G ZH), Scalar2_Vector2 1, G_heavy_HHVV ] *) let standard_higgs = [ (O H, O H, O H), Scalar_Scalar_Scalar 1, G_H3 ] let anomaly_higgs = [ (* (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 Eta, G Gl, G Gl), Dim5_Scalar_Gauge2_Skew 1, G_EGlGl; (O Eta, G Ga, G Ga), Dim5_Scalar_Gauge2_Skew 1, G_EGaGa; (O Eta, G Ga, G Z), Dim5_Scalar_Gauge2_Skew 1, G_EGaZ] let standard_higgs4 = [ (O H, O H, O H, O H), Scalar4 1, G_H4 ] let anomalous_gauge_higgs = [] let anomalous_gauge_higgs4 = [] let anomalous_higgs = [] let anomalous_higgs4 = [] let gauge_higgs = if Flags.include_anomalous then standard_gauge_higgs @ anomalous_gauge_higgs else standard_gauge_higgs let gauge_higgs4 = if Flags.include_anomalous then standard_gauge_higgs4 @ anomalous_gauge_higgs4 else standard_gauge_higgs4 let higgs = if Flags.include_anomalous then standard_higgs @ anomalous_higgs else standard_higgs let eta_higgs_gauge = [ (G Z, O Eta, O H), Vector_Scalar_Scalar 1, G_ZEH; (G ZH, O Eta, O H), Vector_Scalar_Scalar 1, G_ZHEH; (G X0, O Eta, O H), Vector_Scalar_Scalar 1, G_XEH ] let higgs4 = if Flags.include_anomalous then standard_higgs4 @ anomalous_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) ] let vertices3' = (ThoList.flatmap electromagnetic_currents [1;2;3] @ ThoList.flatmap color_currents [1;2;3] @ ThoList.flatmap neutral_currents [1;2;3] @ ThoList.flatmap neutral_heavy_currents [1;2;3] @ ThoList.flatmap charged_currents [1;2;3] @ anomaly_higgs @ (* ThoList.flatmap charged_heavy_currents [1;2;3] @ *) heavy_top_currents @ eta_higgs_gauge @ yukawa @ yukawa_add @ triple_gauge @ triple_gluon @ gauge_higgs @ higgs @ goldstone_vertices) let vertices3 = if Flags.include_supp then vertices3' @ neutral_supp_currents (* @ charged_supp_currents *) else vertices3' 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)) | "th" -> M TopH | "thbar" -> M TopHq | "dh" -> M DH | "dhbar" -> M DHq | "eta" | "Eta" -> O Eta | "g" -> G Gl | "A" -> G Ga | "Z" | "Z0" -> G Z | "ZH" | "ZH0" | "Zh" | "Zh0" -> G ZH | "W+" -> G Wp | "W-" -> G Wm | "X+" -> G Xp | "X-" -> G Xm | "X0" -> G X0 | "Y0" -> G Y0 | "H" -> O H | _ -> invalid_arg "Models.Zprime.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 "Models.Zprime.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 "Models.Zprime.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 "Models.Zprime.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 "Models.Zprime.flavor_to_string: invalid down type quark" | TopH -> "th" | TopHq -> "thbar" | DH -> "dh" | DHq -> "dhbar" end | G f -> begin match f with | Gl -> "g" | Ga -> "A" | Z -> "Z" | Wp -> "W+" | Wm -> "W-" | Xp -> "X+" | Xm -> "X-" | X0 -> "X0" | Y0 -> "Y0" | ZH -> "ZH" | Gl_aux -> "gx" end | O f -> begin match f with | Phip -> "phi+" | Phim -> "phi-" | Phi0 -> "phi0" | H -> "H" | Eta -> "Eta" 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" | TopH -> "th" | TopHq -> "thb" | DH -> "dh" | DHq -> "dhb" end | G f -> begin match f with | Gl -> "gl" | Ga -> "a" | Z -> "z" | Wp -> "wp" | Wm -> "wm" | Xp -> "xp" | Xm -> "xm" | X0 -> "x0" | Y0 -> "y0" | ZH -> "zh" | Gl_aux -> "gx" end | O f -> begin match f with | Phip -> "pp" | Phim -> "pm" | Phi0 -> "p0" | H -> "h" | Eta -> "eta" end (* There are PDG numbers for Z', Z'', W', 32-34, respectively. We just introduce a number 38 for Y0 as a Z'''. As well, there is the number 8 for a t'. But we cheat a little bit and take the number 35 which is reserved for a heavy scalar Higgs for the Eta scalar. *) 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 | DH -> 7 | DHq -> (-7) | TopH -> 8 | TopHq -> (-8) end | G f -> begin match f with | Gl -> 21 | Ga -> 22 | Z -> 23 | Wp -> 24 | Wm -> (-24) | Xp -> 34 | Xm -> (-34) | ZH -> 32 | X0 -> 33 | Y0 -> 38 | Gl_aux -> 21 end | O f -> begin match f with | Phip | Phim -> 27 | Phi0 -> 26 | H -> 25 | Eta -> 36 end 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 | Unit -> "unit" | Pi -> "PI" | VHeavy -> "vheavy" | Alpha_QED -> "alpha" | E -> "e" | G_weak -> "g" | Vev -> "vev" | Sin2thw -> "sin2thw" | Sinthw -> "sinthw" | Costhw -> "costhw" | Sinpsi -> "sinpsi" | Cospsi -> "cospsi" | Atpsi -> "atpsi" | Sccs -> "sccs" | Supp -> "vF" | Supp2 -> "v2F2" | Q_lepton -> "qlep" | Q_up -> "qup" | Q_down -> "qdwn" | Q_Z_up -> "qzup" | G_over4 -> "gov4" | G_over4_sup -> "gov4sup" | G_CC_sup -> "gccsup" | G_zhthth -> "gzhthth" | G_NC_lepton -> "gnclep" | G_NC_neutrino -> "gncneu" | G_NC_up -> "gncup" | G_NC_down -> "gncdwn" | G_CC -> "gcc" | G_CC_heavy -> "gcch" | G_CC_supp1 -> "gsupp1" | G_CC_supp2 -> "gsupp2" | G_NC_h_lepton -> "gnchlep" | G_NC_h_neutrino -> "gnchneu" | G_NC_h_up -> "gnchup" | G_NC_h_down -> "gnchdwn" (* | G_NC_heavy -> "gnch" *) | I_Q_W -> "iqw" | I_G_ZWW -> "igzww" | I_G_WWW -> "igwww" | I_Q_H -> "iqh" | I_Q_ZH -> "iqzh" | I_G_Z1 -> "igz1" | I_G_Z2 -> "igz2" | I_G_Z3 -> "igz3" | I_G_Z4 -> "igz4" | G_WWWW -> "gw4" | G_ZZWW -> "gzzww" | G_AZWW -> "gazww" | G_AAWW -> "gaaww" | I_G1_AWW -> "ig1a" | I_G1_ZWW -> "ig1z" | I_G1_plus_kappa_AWW -> "ig1pka" | I_G1_plus_kappa_ZWW -> "ig1pkz" | I_G1_minus_kappa_AWW -> "ig1mka" | I_G1_minus_kappa_ZWW -> "ig1mkz" | I_kappa_minus_G1_AWW -> "ikmg1a" | I_kappa_minus_G1_ZWW -> "ikmg1z" | I_lambda_AWW -> "ila" | I_lambda_ZWW -> "ilz" | Alpha_WWWW0 -> "alww0" | Alpha_WWWW2 -> "alww2" | Alpha_ZZWW0 -> "alzw0" | Alpha_ZZWW1 -> "alzw1" | Alpha_ZZZZ -> "alzz" | G_HWW -> "ghww" | G_HZZ -> "ghzz" | G_heavy_HVV -> "ghyhvv" | G_heavy_HWW -> "ghyhww" | G_heavy_HZZ -> "ghyhzz" | G_HHWW -> "ghhww" | G_HHZZ -> "ghhzz" | G_heavy_HHVV -> "ghyhhvv" | G_Htt -> "ghtt" | G_Hbb -> "ghbb" | G_Htautau -> "ghtautau" | G_Hcc -> "ghcc" | G_Hthth -> "ghthth" | G_Htht -> "ghtht" | G_Ethth -> "gethth" | G_Etht -> "getht" | G_Ett -> "gett" | G_Ebb -> "gebb" | G_HGaGa -> "ghaa" | G_HGaZ -> "ghaz" | G_EGaGa -> "geaa" | G_EGaZ -> "geaz" | G_EGlGl -> "gegg" | G_ZEH -> "gzeh" | G_ZHEH -> "gzheh" | G_XEH -> "gxeh" | G_H3 -> "gh3" | G_H4 -> "gh4" | G_strong -> "gs" | 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 end -module O = Omega.Make(Fusion.Mixed23)(Targets.Fortran) +module O = Omega.Mixed23(Targets.Fortran) (Zprime(SM_no_anomalous)) let _ = O.main () (*i * Local Variables: * mode:caml * indent-tabs-mode:nil * page-delimiter:"^(\\* .*\n" * End: i*) Index: trunk/omega/src/omega_SM_Higgs_CKM_VM.ml =================================================================== --- trunk/omega/src/omega_SM_Higgs_CKM_VM.ml (revision 8743) +++ trunk/omega/src/omega_SM_Higgs_CKM_VM.ml (revision 8744) @@ -1,35 +1,35 @@ (* omega_SM_Higgs_CKM_VM.ml -- 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. *) -module O = Omega.Make(Fusion.Mixed23)(Targets.VM) +module O = Omega.Mixed23(Targets.VM) (Modellib_SM.SM(Modellib_SM.SM_Higgs_CKM)) let _ = O.main () (*i * Local Variables: * mode:caml * indent-tabs-mode:nil * page-delimiter:"^(\\* .*\n" * End: i*) Index: trunk/omega/src/omega_Littlest_Eta.ml =================================================================== --- trunk/omega/src/omega_Littlest_Eta.ml (revision 8743) +++ trunk/omega/src/omega_Littlest_Eta.ml (revision 8744) @@ -1,35 +1,35 @@ (* omega_Littlest_Eta.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. *) -module O = Omega.Make(Fusion.Mixed23)(Targets.Fortran_Majorana) +module O = Omega.Mixed23(Targets.Fortran_Majorana) (Modellib_BSM.Littlest(Modellib_BSM.BSM_ungauged)) let _ = O.main () (*i * Local Variables: * mode:caml * indent-tabs-mode:nil * page-delimiter:"^(\\* .*\n" * End: i*) Index: trunk/omega/src/omega_Simplest.ml =================================================================== --- trunk/omega/src/omega_Simplest.ml (revision 8743) +++ trunk/omega/src/omega_Simplest.ml (revision 8744) @@ -1,35 +1,35 @@ (* omega_Simplest.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. *) -module O = Omega.Make(Fusion.Mixed23)(Targets.Fortran_Majorana) +module O = Omega.Mixed23(Targets.Fortran_Majorana) (Modellib_BSM.Simplest(Modellib_BSM.BSM_bsm)) let _ = O.main () (*i * Local Variables: * mode:caml * indent-tabs-mode:nil * page-delimiter:"^(\\* .*\n" * End: i*) Index: trunk/omega/src/omega_Simplest_univ.ml =================================================================== --- trunk/omega/src/omega_Simplest_univ.ml (revision 8743) +++ trunk/omega/src/omega_Simplest_univ.ml (revision 8744) @@ -1,35 +1,35 @@ (* omega_Simplest_univ.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. *) -module O = Omega.Make(Fusion.Mixed23)(Targets.Fortran_Majorana) +module O = Omega.Mixed23(Targets.Fortran_Majorana) (Modellib_BSM.Simplest(Modellib_BSM.BSM_anom)) let _ = O.main () (*i * Local Variables: * mode:caml * indent-tabs-mode:nil * page-delimiter:"^(\\* .*\n" * End: i*) Index: trunk/omega/src/omega_SYM.ml =================================================================== --- trunk/omega/src/omega_SYM.ml (revision 8743) +++ trunk/omega/src/omega_SYM.ml (revision 8744) @@ -1,334 +1,334 @@ (* omega_SYM.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. *) module SYM = struct open Coupling let options = Options.empty let caveats () = [] let nc = 3 type flavor = | Q of int | SQ of int | G of int | SG of int | Phi let generations = ThoList.range 1 1 let generations_pairs = List.map (function [a;b] -> (a, b) | _ -> failwith "omega_SYM.generations_pairs") (Product.power 2 generations) let generations_triples = List.map (function [a;b;c] -> (a, b, c) | _ -> failwith "omega_SYM.generations_triples") (Product.power 3 generations) let generations_quadruples = List.map (function [a;b;c;d] -> (a, b, c, d) | _ -> failwith "omega_SYM.generations_quadruples") (Product.power 4 generations) let external_flavors () = [ "Quarks", List.map (fun i -> Q i) generations; "Anti-Quarks", List.map (fun i -> Q (-i)) generations; "SQuarks", List.map (fun i -> SQ i) generations; "Anti-SQuarks", List.map (fun i -> SQ (-i)) generations; "Gluons", List.map (fun i -> G i) generations; "SGluons", List.map (fun i -> SG i) generations; "Other", [Phi]] let flavors () = ThoList.flatmap snd (external_flavors ()) type gauge = unit type constant = | G_saa of int * int | G_saaa of int * int * int | G3 of int * int * int | I_G3 of int * int * int | G4 of int * int * int * int type orders = unit let orders = function | _ -> () let lorentz = function | Q i -> if i > 0 then Spinor else if i < 0 then ConjSpinor else invalid_arg "SYM.lorentz (Q 0)" | SQ _ | Phi -> Scalar | G _ -> Vector | SG _ -> Majorana let color = function | Q i | SQ i -> Color.SUN (if i > 0 then nc else if i < 0 then -nc else invalid_arg "SYM.color (Q 0)") | G _ | SG _ -> Color.AdjSUN nc | Phi -> Color.Singlet let nc () = nc let propagator = function | Q i -> if i > 0 then Prop_Spinor else if i < 0 then Prop_ConjSpinor else invalid_arg "SYM.lorentz (Q 0)" | SQ _ | Phi -> Prop_Scalar | G _ -> Prop_Feynman | SG _ -> Prop_Majorana (*i let propagator _ = Only_Insertion i*) let width _ = Timelike let goldstone _ = None let conjugate = function | Q i -> Q (-i) | SQ i -> SQ (-i) | (G _ | SG _ | Phi) as p -> p let fermion = function | Q i -> if i > 0 then 1 else if i < 0 then -1 else invalid_arg "SYM.fermion (Q 0)" | SQ _ | G _ | Phi -> 0 | SG _ -> 2 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 quark_current = List.map (fun (i, j, k) -> ((Q (-i), G j, Q k), FBF (-1, Psibar, V, Psi), G3 (i, j, k))) generations_triples let squark_current = List.map (fun (i, j, k) -> ((G j, SQ i, SQ (-k)), Vector_Scalar_Scalar 1, G3 (i, j, k))) generations_triples let three_gluon = List.map (fun (i, j, k) -> ((G i, G j, G k), Gauge_Gauge_Gauge 1, I_G3 (i, j, k))) generations_triples let gluon2_phi = List.map (fun (i, j) -> ((Phi, G i, G j), Dim5_Scalar_Gauge2 1, G_saa (i, j))) generations_pairs let vertices3 = quark_current @ squark_current @ three_gluon @ gluon2_phi let gauge4 = Vector4 [(2, C_13_42); (-1, C_12_34); (-1, C_14_23)] let squark_seagull = List.map (fun (i, j, k, l) -> ((SQ i, SQ (-j), G k, G l), Scalar2_Vector2 1, G4 (i, j, k, l))) generations_quadruples let four_gluon = List.map (fun (i, j, k, l) -> ((G i, G j, G k, G l), gauge4, G4 (i, j, k, l))) generations_quadruples (*i let gluon3_phi = List.map (fun (i, j, k) -> ((Phi, G i, G j, G k), Dim6_Scalar_Gauge3 1, G_saaa (i, j, k))) generations_triples i*) (* \begin{dubious} We need at least a [Dim6_Scalar_Gauge3] vertex to support this. \end{dubious} *) let gluon3_phi = [] let vertices4 = squark_seagull @ four_gluon @ gluon3_phi 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 = []; derived = []; derived_arrays = [] } let invalid_flavor s = invalid_arg ("omega_SYM.flavor_of_string: " ^ s) let flavor_of_string s = let l = String.length s in if l < 2 then invalid_flavor s else if l = 2 then if String.sub s 0 1 = "q" then Q (int_of_string (String.sub s 1 1)) else if String.sub s 0 1 = "Q" then Q (- (int_of_string (String.sub s 1 1))) else if String.sub s 0 1 = "g" then G (int_of_string (String.sub s 1 1)) else invalid_flavor s else if l = 3 then if s = "phi" then Phi else if String.sub s 0 2 = "sq" then SQ (int_of_string (String.sub s 2 1)) else if String.sub s 0 2 = "sQ" then SQ (- (int_of_string (String.sub s 2 1))) else if String.sub s 0 2 = "sg" then SG (int_of_string (String.sub s 2 1)) else invalid_flavor s else invalid_flavor s let flavor_to_string = function | Q i -> if i > 0 then "q" ^ string_of_int i else if i < 0 then "Q" ^ string_of_int (-i) else invalid_arg "SYM.flavor_to_string (Q 0)" | SQ i -> if i > 0 then "sq" ^ string_of_int i else if i < 0 then "sQ" ^ string_of_int (-i) else invalid_arg "SYM.flavor_to_string (SQ 0)" | G i -> "g" ^ string_of_int i | SG i -> "sg" ^ string_of_int i | Phi -> "phi" let flavor_to_TeX = function | Q i -> if i > 0 then "q_{" ^ string_of_int i ^ "}" else if i < 0 then "{\bar q}_{" ^ string_of_int (-i) ^ "}" else invalid_arg "SYM.flavor_to_string (Q 0)" | SQ i -> if i > 0 then "{\tilde q}_{" ^ string_of_int i ^ "}" else if i < 0 then "{\bar{\tilde q}}_{" ^ string_of_int (-i) ^ "}" else invalid_arg "SYM.flavor_to_string (SQ 0)" | G i -> "g_{" ^ string_of_int i ^ "}" | SG i -> "{\tilde g}_{" ^ string_of_int i ^ "}" | Phi -> "phi" let flavor_symbol = function | Q i -> if i > 0 then "q" ^ string_of_int i else if i < 0 then "qbar" ^ string_of_int (-i) else invalid_arg "SYM.flavor_to_string (Q 0)" | SQ i -> if i > 0 then "sq" ^ string_of_int i else if i < 0 then "sqbar" ^ string_of_int (-i) else invalid_arg "SYM.flavor_to_string (SQ 0)" | G i -> "g" ^ string_of_int i | SG i -> "sg" ^ string_of_int i | Phi -> "phi" let gauge_symbol () = failwith "omega_SYM.gauge_symbol: internal error" let pdg _ = 0 let mass_symbol _ = "0.0_default" let width_symbol _ = "0.0_default" let string_of_int_list int_list = "(" ^ String.concat "," (List.map string_of_int int_list) ^ ")" let constant_symbol = function | G_saa (i, j) -> "g_saa" ^ string_of_int_list [i;j] | G_saaa (i, j, k) -> "g_saaa" ^ string_of_int_list [i;j;k] | G3 (i, j, k) -> "g3" ^ string_of_int_list [i;j;k] | I_G3 (i, j, k) -> "ig3" ^ string_of_int_list [i;j;k] | G4 (i, j, k, l) -> "g4" ^ string_of_int_list [i;j;k;l] end -module O = Omega.Make(Fusion.Mixed23)(Targets.Fortran_Majorana)(SYM) +module O = Omega.Mixed23(Targets.Fortran_Majorana)(SYM) let _ = O.main () (*i * Local Variables: * mode:caml * indent-tabs-mode:nil * page-delimiter:"^(\\* .*\n" * End: i*) Index: trunk/omega/src/omega_SSC_2.ml =================================================================== --- trunk/omega/src/omega_SSC_2.ml (revision 8743) +++ trunk/omega/src/omega_SSC_2.ml (revision 8744) @@ -1,36 +1,36 @@ (* omega_SSC.ml -- Copyright (C) 1999-2021 by Wolfgang Kilian Thorsten Ohl Juergen Reuter with contributions from Marco Sekulla 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.Mixed23)(Targets.Fortran) +module O = Omega.Mixed23(Targets.Fortran) (Modellib_BSM.SSC(Modellib_BSM.SSC_kmatrix_2)) let _ = O.main () (*i * Local Variables: * mode:caml * indent-tabs-mode:nil * page-delimiter:"^(\\* .*\n" * End: i*) Index: trunk/omega/src/omega_Template.ml =================================================================== --- trunk/omega/src/omega_Template.ml (revision 8743) +++ trunk/omega/src/omega_Template.ml (revision 8744) @@ -1,35 +1,35 @@ (* omega_Template.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. *) -module O = Omega.Make(Fusion.Mixed23)(Targets.Fortran_Majorana) +module O = Omega.Mixed23(Targets.Fortran_Majorana) (Modellib_BSM.Template(Modellib_BSM.BSM_bsm)) let _ = O.main () (*i * Local Variables: * mode:caml * indent-tabs-mode:nil * page-delimiter:"^(\\* .*\n" * End: i*) Index: trunk/omega/src/omega_SM_top_anom.ml =================================================================== --- trunk/omega/src/omega_SM_top_anom.ml (revision 8743) +++ trunk/omega/src/omega_SM_top_anom.ml (revision 8744) @@ -1,36 +1,36 @@ (* omega_SM_top_anom.ml -- Copyright (C) 1999-2021 by Wolfgang Kilian Thorsten Ohl Juergen Reuter with contributions from Christian Speckner Fabian Bach (only 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. *) -module O = Omega.Make(Fusion.Mixed23)(Targets.Fortran) +module O = Omega.Mixed23(Targets.Fortran) (Modellib_SM.SM(Modellib_SM.SM_anomalous_top)) let _ = O.main () (*i * Local Variables: * mode:caml * indent-tabs-mode:nil * page-delimiter:"^(\\* .*\n" * End: i*) Index: trunk/omega/src/omega_Littlest_Tpar.ml =================================================================== --- trunk/omega/src/omega_Littlest_Tpar.ml (revision 8743) +++ trunk/omega/src/omega_Littlest_Tpar.ml (revision 8744) @@ -1,35 +1,35 @@ (* omega_Littlest_Tpar.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. *) -module O = Omega.Make(Fusion.Mixed23)(Targets.Fortran) +module O = Omega.Mixed23(Targets.Fortran) (Modellib_BSM.Littlest_Tpar(Modellib_BSM.BSM_bsm)) let _ = O.main () (*i * Local Variables: * mode:caml * indent-tabs-mode:nil * page-delimiter:"^(\\* .*\n" * End: i*) Index: trunk/omega/src/omega_HSExt_VM.ml =================================================================== --- trunk/omega/src/omega_HSExt_VM.ml (revision 8743) +++ trunk/omega/src/omega_HSExt_VM.ml (revision 8744) @@ -1,35 +1,35 @@ (* omega_HSExt_VM.ml -- 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. *) -module O = Omega.Make(Fusion.Mixed23)(Targets.VM) +module O = Omega.Mixed23(Targets.VM) (Modellib_BSM.HSExt(Modellib_BSM.BSM_bsm)) let _ = O.main () (*i * Local Variables: * mode:caml * indent-tabs-mode:nil * page-delimiter:"^(\\* .*\n" * End: i*) Index: trunk/omega/src/omega_SM_tt_threshold.ml =================================================================== --- trunk/omega/src/omega_SM_tt_threshold.ml (revision 8743) +++ trunk/omega/src/omega_SM_tt_threshold.ml (revision 8744) @@ -1,27 +1,27 @@ (* omega_SM_tt_threshold.ml -- Copyright (C) 1999-2021 by Wolfgang Kilian Thorsten Ohl Juergen Reuter Christian Speckner Fabian Bach (only 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. *) -module O = Omega.Make(Fusion.Mixed23)(Targets.Fortran) +module O = Omega.Mixed23(Targets.Fortran) (Modellib_SM.SM(Modellib_SM.SM_tt_threshold)) let _ = O.main () Index: trunk/omega/src/omega_SM_ul.ml =================================================================== --- trunk/omega/src/omega_SM_ul.ml (revision 8743) +++ trunk/omega/src/omega_SM_ul.ml (revision 8744) @@ -1,36 +1,36 @@ (* omega_SM_ul.ml -- Copyright (C) 1999-2021 by Wolfgang Kilian Thorsten Ohl Juergen Reuter with contributions from Marco Sekulla 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.Mixed23)(Targets.Fortran) +module O = Omega.Mixed23(Targets.Fortran) (Modellib_SM.SM(Modellib_SM.SM_k_matrix)) let _ = O.main () (*i * Local Variables: * mode:caml * indent-tabs-mode:nil * page-delimiter:"^(\\* .*\n" * End: i*) Index: trunk/omega/src/omega.ml =================================================================== --- trunk/omega/src/omega.ml (revision 8743) +++ trunk/omega/src/omega.ml (revision 8744) @@ -1,716 +1,747 @@ (* omega.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 (<<) f g x = f (g x) let (>>) f g x = g (f x) module P = Momentum.Default module P_Whizard = Momentum.DefaultW module type T = sig val main : unit -> unit type flavor val diagrams : flavor -> flavor -> flavor list -> ((flavor * Momentum.Default.t) * (flavor * Momentum.Default.t, flavor * Momentum.Default.t) Tree.t) list end -module Make (Fusion_Maker : Fusion.Maker) (Target_Maker : Target.Maker) (M : Model.T) = +module Make (Fusion_Maker : Fusion.Maker) (PHS_Maker : Fusion.Maker) + (Target_Maker : Target.Maker) (M : Model.T) = struct module CM = Colorize.It(M) type flavor = M.flavor module Proc = Process.Make(M) (* \begin{dubious} We must have initialized the vertices \emph{before} applying [Fusion_Maker], at least if we want to continue using the vertex cache! \end{dubious} *) (* \begin{dubious} NB: this causes the constant initializers in [Fusion_Maker] more than once. Such side effects must be avoided if the initializers involve expensive computations. \emph{Relying on the fact that the functor will be called only once is not a good idea!} \end{dubious} *) module F = Fusion_Maker(P)(M) module CF = Fusion.Multi(Fusion_Maker)(P)(M) module T = Target_Maker(Fusion_Maker)(P)(M) module W = Whizard.Make(Fusion_Maker)(P)(P_Whizard)(M) module C = Cascade.Make(M)(P) module VSet = Set.Make (struct type t = F.constant Coupling.t let compare = compare end) (* For the phase space, we need asymmetric DAGs. Since we will not use this to compute amplitudes, there's no need to supply the proper statistics module and we may always use Majorana fermions to be as general as possible. In principle, we could expose in [Fusion.T] the [Fusion.Stat_Maker] used by [Fusion_Maker] to construct it, but that is just not worth the effort. \begin{dubious} For the phase space, we should be able to work on the uncolored model. \end{dubious} *) - module PHS = - Fusion.Helac_Majorana(struct let max_arity () = pred (M.max_degree ()) end)(P)(M) + module MT = Modeltools.Topology3(M) + module PHS = PHS_Maker(P)(MT) + module CT = Cascade.Make(MT)(P) (* Form a ['a list] from a ['a option array], containing the elements that are not [None] in order. *) let opt_array_to_list a = let rec opt_array_to_list' acc i a = if i < 0 then acc else begin match a.(i) with | None -> opt_array_to_list' acc (pred i) a | Some x -> opt_array_to_list' (x :: acc) (pred i) a end in opt_array_to_list' [] (Array.length a - 1) a (* Return a list of [CF.amplitude list]s, corresponig to the diagrams for a specific color flow for each flavor combination. *) let amplitudes_by_flavor amplitudes = List.map opt_array_to_list (Array.to_list (CF.process_table amplitudes)) (* \begin{dubious} If we plan to distiguish different couplings later on, we can no long map all instances of [coupling option] in the tree to [None]. In this case, we will need to normalize different fusion orders [Coupling.fuse2], [Coupling.fuse3] or [Coupling.fusen], because they would otherwise lead to inequivalent diagrams. Unfortunately, this stuff packaged deep in [Fusion.Tagged_Coupling]. \end{dubious} *) (*i let strip_fuse' = function | Coupling.V3 (v, f, c) -> Coupling.V3 (v, Coupling.F12, c) | Coupling.V4 (v, f, c) -> Coupling.V4 (v, Coupling.F123, c) | Coupling.Vn (v, f, c) -> Coupling.Vn (v, [], c) let strip_fuse = function | Some c -> Some (strip_fuse' c) | None -> None i*) (* \begin{dubious} The [Tree.canonicalize] below should be necessary to remove topologically equivalent duplicates. \end{dubious} *) (* Take a [CF.amplitude list] assumed to correspond to the same external states after stripping the color and return a pair of the list of external particles and the corresponding Feynman diagrams without color. *) let wf1 amplitude = match F.externals amplitude with | wf :: _ -> wf | [] -> failwith "Omega.forest_sans_color: no external particles" let uniq l = ThoList.uniq (List.sort compare l) let forest_sans_color = function | amplitude :: _ as amplitudes -> let externals = F.externals amplitude in let prune_color wf = (F.flavor_sans_color wf, F.momentum_list wf) in let prune_color_and_couplings (wf, c) = (prune_color wf, None) in (List.map prune_color externals, uniq (List.map (fun t -> Tree.canonicalize (Tree.map prune_color_and_couplings prune_color t)) (ThoList.flatmap (fun a -> F.forest (wf1 a) a) amplitudes))) | [] -> ([], []) let dag_sans_color = function | amplitude :: _ as amplitudes -> let prune a = a in List.map prune amplitudes | [] -> [] 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 format_p wf = String.concat "" (List.map p2s (F.momentum_list wf)) let variable wf = M.flavor_to_string (F.flavor_sans_color wf) ^ "[" ^ format_p wf ^ "]" let variable' wf = CM.flavor_to_TeX (F.flavor wf) ^ "(" ^ format_p wf ^ ")" let feynmf_style propagator color = { Tree.style = begin match propagator with | Coupling.Prop_Feynman | Coupling.Prop_Gauge _ -> begin match color with | Color.AdjSUN _ -> Some ("gluon", "") | _ -> Some ("boson", "") end | Coupling.Prop_Col_Feynman -> Some ("gluon", "") | Coupling.Prop_Unitarity | Coupling.Prop_Rxi _ -> Some ("dbl_wiggly", "") | Coupling.Prop_Spinor | Coupling.Prop_ConjSpinor -> Some ("fermion", "") | _ -> None end; Tree.rev = begin match propagator with | Coupling.Prop_Spinor -> true | Coupling.Prop_ConjSpinor -> false | _ -> false end; Tree.label = None; Tree.tension = None } let header incoming outgoing = "$ " ^ String.concat " " (List.map (CM.flavor_to_TeX << F.flavor) incoming) ^ " \\to " ^ String.concat " " (List.map (CM.flavor_to_TeX << CM.conjugate << F.flavor) outgoing) ^ " $" let header_sans_color incoming outgoing = "$ " ^ String.concat " " (List.map (M.flavor_to_TeX << fst) incoming) ^ " \\to " ^ String.concat " " (List.map (M.flavor_to_TeX << M.conjugate << fst) outgoing) ^ " $" let diagram incoming tree = let fmf wf = let f = F.flavor wf in feynmf_style (CM.propagator f) (CM.color f) in Tree.map (fun (n, _) -> let n' = fmf n in if List.mem n incoming then { n' with Tree.rev = not n'.Tree.rev } else n') (fun l -> if List.mem l incoming then l else F.conjugate l) tree let diagram_sans_color incoming (tree) = let fmf (f, p) = feynmf_style (M.propagator f) (M.color f) in Tree.map (fun (n, c) -> let n' = fmf n in if List.mem n incoming then { n' with Tree.rev = not n'.Tree.rev } else n') (fun (f, p) -> if List.mem (f, p) incoming then (f, p) else (M.conjugate f, p)) tree let feynmf_set amplitude = match F.externals amplitude with | wf1 :: wf2 :: wfs -> let incoming = [wf1; wf2] in { Tree.header = header incoming wfs; Tree.incoming = incoming; Tree.diagrams = List.map (diagram incoming) (F.forest wf1 amplitude) } | _ -> failwith "less than two external particles" let feynmf_set_sans_color (externals, trees) = match externals with | wf1 :: wf2 :: wfs -> let incoming = [wf1; wf2] in { Tree.header = header_sans_color incoming wfs; Tree.incoming = incoming; Tree.diagrams = List.map (diagram_sans_color incoming) trees } | _ -> failwith "less than two external particles" let feynmf_set_sans_color_empty (externals, trees) = match externals with | wf1 :: wf2 :: wfs -> let incoming = [wf1; wf2] in { Tree.header = header_sans_color incoming wfs; Tree.incoming = incoming; Tree.diagrams = [] } | _ -> failwith "less than two external particles" let uncolored_colored amplitudes = { Tree.outer = feynmf_set_sans_color (forest_sans_color amplitudes); Tree.inner = List.map feynmf_set amplitudes } let uncolored_only amplitudes = { Tree.outer = feynmf_set_sans_color (forest_sans_color amplitudes); Tree.inner = [] } let colored_only amplitudes = { Tree.outer = feynmf_set_sans_color_empty (forest_sans_color amplitudes); Tree.inner = List.map feynmf_set amplitudes } let momentum_to_TeX (_, p) = String.concat "" (List.map p2s p) let wf_to_TeX (f, _ as wf) = M.flavor_to_TeX f ^ "(" ^ momentum_to_TeX wf ^ ")" let amplitudes_to_feynmf latex name amplitudes = Tree.feynmf_sets_wrapped latex name wf_to_TeX momentum_to_TeX variable' format_p (List.map uncolored_colored (amplitudes_by_flavor amplitudes)) let amplitudes_to_feynmf_sans_color latex name amplitudes = Tree.feynmf_sets_wrapped latex name wf_to_TeX momentum_to_TeX variable' format_p (List.map uncolored_only (amplitudes_by_flavor amplitudes)) let amplitudes_to_feynmf_color_only latex name amplitudes = Tree.feynmf_sets_wrapped latex name wf_to_TeX momentum_to_TeX variable' format_p (List.map colored_only (amplitudes_by_flavor amplitudes)) let debug (str, descr, opt, var) = [ "-warning:" ^ str, Arg.Unit (fun () -> var := (opt, false):: !var), " check " ^ descr ^ " and print warning on error"; "-error:" ^ str, Arg.Unit (fun () -> var := (opt, true):: !var), " check " ^ descr ^ " and terminate on error" ] let rec include_goldstones = function | [] -> false | (T.Gauge, _) :: _ -> true | _ :: rest -> include_goldstones rest let read_lines_rev file = let ic = open_in file in let rev_lines = ref [] in let rec slurp () = rev_lines := input_line ic :: !rev_lines; slurp () in try slurp () with | End_of_file -> close_in ic; !rev_lines let read_lines file = List.rev (read_lines_rev file) (*i type cache_mode = | Cache_Default | Cache_Initialize of string let cache_option = ref Cache_Default i*) let unphysical_polarization = ref None (* \thocwmodulesection{Main Program} *) let main () = (* Delay evaluation of [M.external_flavors ()]! *) let usage () = "usage: " ^ Sys.argv.(0) ^ " [options] [" ^ String.concat "|" (List.map M.flavor_to_string (ThoList.flatmap snd (M.external_flavors ()))) ^ "]" and rev_scatterings = ref [] and rev_decays = ref [] and cascades = ref [] and checks = ref [] and output_file = ref None and print_forest = ref false and template = ref false and diagrams_all = ref None and diagrams_sans_color = ref None and diagrams_color_only = ref None and diagrams_LaTeX = ref false and quiet = ref false and write = ref true and params = ref false and poles = ref false and dag_out = ref None and dag0_out = ref None and phase_space_out = ref None in Options.parse (Options.cmdline "-target:" T.options @ Options.cmdline "-model:" M.options @ Options.cmdline "-fusion:" CF.options @ ThoList.flatmap debug ["a", "arguments", T.All, checks; "n", "# of input arguments", T.Arguments, checks; "m", "input momenta", T.Momenta, checks; "g", "internal Ward identities", T.Gauge, checks] @ [("-o", Arg.String (fun s -> output_file := Some s), "file write to given file instead of /dev/stdout"); ("-scatter", Arg.String (fun s -> rev_scatterings := s :: !rev_scatterings), "expr in1 in2 -> out1 out2 ..."); ("-scatter_file", Arg.String (fun s -> rev_scatterings := read_lines_rev s @ !rev_scatterings), "name each line: in1 in2 -> out1 out2 ..."); ("-decay", Arg.String (fun s -> rev_decays := s :: !rev_decays), "expr in -> out1 out2 ..."); ("-decay_file", Arg.String (fun s -> rev_decays := read_lines_rev s @ !rev_decays), "name each line: in -> out1 out2 ..."); ("-cascade", Arg.String (fun s -> cascades := s :: !cascades), "expr select diagrams"); (*i ("-initialize", Arg.String (fun s -> cache_option := Cache_Initialize s), "dir precompute lookup tables and store them in directory"); i*) ("-unphysical", Arg.Int (fun i -> unphysical_polarization := Some i), "n use unphysical polarization for n-th particle / test WIs"); ("-template", Arg.Set template, " write a template for handwritten amplitudes"); ("-forest", Arg.Set print_forest, " Diagrammatic expansion"); ("-diagrams", Arg.String (fun s -> diagrams_sans_color := Some s), "file produce FeynMP output for Feynman diagrams"); ("-diagrams:c", Arg.String (fun s -> diagrams_color_only := Some s), "file produce FeynMP output for color flow diagrams"); ("-diagrams:C", Arg.String (fun s -> diagrams_all := Some s), "file produce FeynMP output for Feynman and color flow diagrams"); ("-diagrams_LaTeX", Arg.Set diagrams_LaTeX, " enclose FeynMP output in LaTeX wrapper"); ("-quiet", Arg.Set quiet, " don't print a summary"); ("-summary", Arg.Clear write, " print only a summary"); ("-params", Arg.Set params, " print the model parameters"); ("-poles", Arg.Set poles, " print the Monte Carlo poles"); ("-dag", Arg.String (fun s -> dag_out := Some s), " print minimal DAG"); ("-full_dag", Arg.String (fun s -> dag0_out := Some s), " print complete DAG"); ("-phase_space", Arg.String (fun s -> phase_space_out := Some s), " print minimal DAG for phase space")]) (*i ("-T", Arg.Int Topology.Binary.debug_triplet, ""); ("-P", Arg.Int Topology.Binary.debug_partition, "")]) i*) (fun _ -> prerr_endline (usage ()); exit 1) usage; let cmdline = String.concat " " (List.map ThoString.quote (Array.to_list Sys.argv)) in let output_channel, close_output_channel = match !output_file with | None -> (stdout, fun () -> ()) | Some name -> let oc = open_out name in (oc, fun () -> close_out oc) in let processes = try ThoList.uniq (List.sort compare (match List.rev !rev_scatterings, List.rev !rev_decays with | [], [] -> [] | scatterings, [] -> Proc.expand_scatterings (List.map Proc.parse_scattering scatterings) | [], decays -> Proc.expand_decays (List.map Proc.parse_decay decays) | scatterings, decays -> invalid_arg "mixed scattering and decay!")) with | Invalid_argument s -> begin Printf.eprintf "O'Mega: invalid process specification: %s!\n" s; flush stderr; [] end in (* \begin{dubious} This is still crude. Eventually, we want to catch \emph{all} exceptions and write an empty (but compilable) amplitude unless one of the special options is selected. \end{dubious} *) (*i begin match processes, !cache_option, !params with | [], Cache_Initialize dir, false -> (* [F.initialize_cache dir;] *) exit 0 | _, _, true -> if !write then T.parameters_to_channel output_channel; exit 0 | [], _, false -> if !write then T.amplitudes_to_channel cmdline output_channel !checks CF.empty; exit 0 | _, _, false -> i*) begin match processes, !params with | _, true -> if !write then T.parameters_to_channel output_channel; exit 0 | [], false -> if !write then T.amplitudes_to_channel cmdline output_channel !checks CF.empty; exit 0 | _, false -> let selectors = let fin, fout = List.hd processes in C.to_selectors (C.of_string_list (List.length fin + List.length fout) !cascades) in let amplitudes = try begin match F.check_charges () with | [] -> () | violators -> let violator_strings = String.concat ", " (List.map (fun flist -> "(" ^ String.concat "," (List.map M.flavor_to_string flist) ^ ")") violators) in failwith ("charge violating vertices: " ^ violator_strings) end; CF.amplitudes (include_goldstones !checks) !unphysical_polarization CF.no_exclusions selectors processes with | Fusion.Majorana -> begin Printf.eprintf "O'Mega: found Majorana fermions, switching representation!\n"; flush stderr; close_output_channel (); Arg.current := 0; raise Fusion.Majorana end | exc -> begin Printf.eprintf "O'Mega: exception %s in amplitude construction!\n" (Printexc.to_string exc); flush stderr; CF.empty; end in if !write then T.amplitudes_to_channel cmdline output_channel !checks amplitudes; if not !quiet then begin List.iter (fun amplitude -> Printf.eprintf "SUMMARY: %d fusions, %d propagators" (F.count_fusions amplitude) (F.count_propagators amplitude); flush stderr; Printf.eprintf ", %d diagrams" (F.count_diagrams amplitude); Printf.eprintf "\n") (CF.processes amplitudes); let couplings = List.fold_left (fun acc p -> let fusions = ThoList.flatmap F.rhs (F.fusions p) and brakets = ThoList.flatmap F.ket (F.brakets p) in let couplings = VSet.of_list (List.map F.coupling (fusions @ brakets)) in VSet.union acc couplings) VSet.empty (CF.processes amplitudes) in Printf.eprintf "SUMMARY: %d vertices\n" (VSet.cardinal couplings); let ufo_couplings = VSet.fold (fun v acc -> match v with | Coupling.Vn (Coupling.UFO (_, v, _, _, _), _, _) -> Sets.String.add v acc | _ -> acc) couplings Sets.String.empty in if not (Sets.String.is_empty ufo_couplings) then Printf.eprintf "SUMMARY: %d UFO vertices: %s\n" (Sets.String.cardinal ufo_couplings) (String.concat ", " (Sets.String.elements ufo_couplings)) end; if !poles then begin List.iter (fun amplitude -> W.write output_channel "omega" (W.merge (W.trees amplitude))) (CF.processes amplitudes) end; begin match !dag0_out with | Some name -> let ch = open_out name in List.iter (F.tower_to_dot ch) (CF.processes amplitudes); close_out ch | None -> () end; begin match !dag_out with | Some name -> let ch = open_out name in List.iter (F.amplitude_to_dot ch) (CF.processes amplitudes); close_out ch | None -> () end; begin match !phase_space_out with | Some name -> + let selectors = + let fin, fout = List.hd processes in + CT.to_selectors (CT.of_string_list (List.length fin + List.length fout) !cascades) in let ch = open_out name in begin try List.iter (fun (fin, fout) -> Printf.fprintf ch "%s -> %s ::\n" (String.concat " " (List.map M.flavor_to_string fin)) (String.concat " " (List.map M.flavor_to_string fout)); match fin with | [] -> failwith "Omega(): phase space: no incoming particles" | [f] -> PHS.phase_space_channels ch (PHS.amplitude_sans_color false PHS.no_exclusions selectors fin fout) | [f1; f2] -> PHS.phase_space_channels ch (PHS.amplitude_sans_color false PHS.no_exclusions selectors fin fout); PHS.phase_space_channels_flipped ch (PHS.amplitude_sans_color false PHS.no_exclusions selectors [f2; f1] fout) | _ -> failwith "Omega(): phase space: 3 or more incoming particles") processes; close_out ch with | exc -> begin close_out ch; Printf.eprintf "O'Mega: exception %s in phase space construction!\n" (Printexc.to_string exc); flush stderr end end | None -> () end; if !print_forest then List.iter (fun amplitude -> List.iter (fun t -> Printf.eprintf "%s\n" (Tree.to_string (Tree.map (fun (wf, _) -> variable wf) (fun _ -> "") t))) (F.forest (List.hd (F.externals amplitude)) amplitude)) (CF.processes amplitudes); begin match !diagrams_all with | Some name -> amplitudes_to_feynmf !diagrams_LaTeX name amplitudes | None -> () end; begin match !diagrams_sans_color with | Some name -> amplitudes_to_feynmf_sans_color !diagrams_LaTeX name amplitudes | None -> () end; begin match !diagrams_color_only with | Some name -> amplitudes_to_feynmf_color_only !diagrams_LaTeX name amplitudes | None -> () end; close_output_channel (); exit 0 end (* \begin{dubious} This was only intended for debugging O'Giga \ldots \end{dubious} *) let decode wf = (F.flavor wf, (F.momentum wf : Momentum.Default.t)) let diagrams in1 in2 out = match F.amplitudes false F.no_exclusions C.no_cascades [in1; in2] out with | a :: _ -> let wf1 = List.hd (F.externals a) and wf2 = List.hd (List.tl (F.externals a)) in let wf2 = decode wf2 in List.map (fun t -> (wf2, Tree.map (fun (wf, _) -> decode wf) decode t)) (F.forest wf1 a) | [] -> [] let diagrams in1 in2 out = failwith "Omega().diagrams: disabled" end + +module Binary (TM : Target.Maker) (M : Model.T) = + Make(Fusion.Binary)(Fusion.Helac_Binary)(TM)(M) +module Binary_Majorana (TM : Target.Maker) (M : Model.T) = + Make(Fusion.Binary_Majorana)(Fusion.Helac_Binary_Majorana)(TM)(M) +module Mixed23 (TM : Target.Maker) (M : Model.T) = + Make(Fusion.Mixed23)(Fusion.Helac_Mixed23)(TM)(M) +module Mixed23_Majorana (TM : Target.Maker) (M : Model.T) = + Make(Fusion.Mixed23_Majorana)(Fusion.Helac_Mixed23_Majorana)(TM)(M) +module Mixed23_Majorana_vintage (TM : Target.Maker) (M : Model.T) = + Make(Fusion_vintage.Mixed23_Majorana)(Fusion.Helac_Mixed23_Majorana)(TM)(M) + +module Bound (M : Model.T) : Tuple.Bound = + struct + (* \begin{dubious} + Above [max_degree = 6], the performance drops \emph{dramatically}! + \end{dubious} *) + let max_arity () = + pred (M.max_degree ()) + end + +module Nary (TM : Target.Maker) (M : Model.T) = + Make(Fusion.Nary(Bound(M)))(Fusion.Helac(Bound(M)))(TM)(M) +module Nary_Majorana (TM : Target.Maker) (M : Model.T) = + Make(Fusion.Nary_Majorana(Bound(M)))(Fusion.Helac_Majorana(Bound(M)))(TM)(M) + Index: trunk/omega/src/UFO.ml =================================================================== --- trunk/omega/src/UFO.ml (revision 8743) +++ trunk/omega/src/UFO.ml (revision 8744) @@ -1,2919 +1,2935 @@ (* 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) exception File_missing of string let parse_file name = let ic = try open_in name with | Sys_error msg as exc -> if msg = name ^ ": No such file or directory" then raise (File_missing name) else raise exc 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 filename stem = Filename.concat dir (stem ^ ".py") in let parse stem = parse_file (filename stem) in let parse_optional stem = try parse stem with File_missing _ -> [] in { particles = parse "particles"; couplings = parse "couplings"; coupling_orders = parse_optional "coupling_orders"; vertices = parse "vertices"; lorentz = parse "lorentz"; parameters = parse "parameters"; propagators = parse_optional "propagators"; decays = parse_optional "decays" } 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 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 (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 (*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). *) (* 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.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 = + let vertex_to_string model v = + String.concat + " " + (List.map + (fun s -> + "\"" ^ (SMap.find s model.particles).Particle.name ^ "\"") + (Array.to_list v.Vertex.particles)) + + let write_vertices3 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) + if Array.length v.Vertex.particles = 3 then + Printf.printf "vertex %s\n" (vertex_to_string model v)) (values vertices); Printf.printf "\n" + let write_vertices_higher model vertices = + Printf.printf + "# Higher Order Vertices (ignored by phasespace generation)\n"; + List.iter + (fun v -> + if Array.length v.Vertex.particles <> 3 then + Printf.printf "# vertex %s\n" (vertex_to_string model v)) + (values vertices); + Printf.printf "\n" + + let write_vertices model vertices = + write_vertices3 model vertices; + write_vertices_higher model vertices + 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/omega_SM_rx.ml =================================================================== --- trunk/omega/src/omega_SM_rx.ml (revision 8743) +++ trunk/omega/src/omega_SM_rx.ml (revision 8744) @@ -1,36 +1,36 @@ (* omega_SM_rx.ml -- Copyright (C) 1999-2021 by Wolfgang Kilian Thorsten Ohl Juergen Reuter with contributions from Marco Sekulla 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.Mixed23)(Targets.Fortran) +module O = Omega.Mixed23(Targets.Fortran) (Modellib_SM.SM(Modellib_SM.SM_k_matrix)) let _ = O.main () (*i * Local Variables: * mode:caml * indent-tabs-mode:nil * page-delimiter:"^(\\* .*\n" * End: i*) Index: trunk/omega/src/omega_SSC.ml =================================================================== --- trunk/omega/src/omega_SSC.ml (revision 8743) +++ trunk/omega/src/omega_SSC.ml (revision 8744) @@ -1,36 +1,36 @@ (* omega_SSC.ml -- Copyright (C) 1999-2021 by Wolfgang Kilian Thorsten Ohl Juergen Reuter with contributions from Marco Sekulla 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.Mixed23)(Targets.Fortran) +module O = Omega.Mixed23(Targets.Fortran) (Modellib_BSM.SSC(Modellib_BSM.SSC_kmatrix)) let _ = O.main () (*i * Local Variables: * mode:caml * indent-tabs-mode:nil * page-delimiter:"^(\\* .*\n" * End: i*) Index: trunk/omega/src/omega_HSExt.ml =================================================================== --- trunk/omega/src/omega_HSExt.ml (revision 8743) +++ trunk/omega/src/omega_HSExt.ml (revision 8744) @@ -1,35 +1,35 @@ (* omega_HSExt.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. *) -module O = Omega.Make(Fusion.Mixed23)(Targets.Fortran) +module O = Omega.Mixed23(Targets.Fortran) (Modellib_BSM.HSExt(Modellib_BSM.BSM_bsm)) let _ = O.main () (*i * Local Variables: * mode:caml * indent-tabs-mode:nil * page-delimiter:"^(\\* .*\n" * End: i*) Index: trunk/omega/src/fusion.ml =================================================================== --- trunk/omega/src/fusion.ml (revision 8743) +++ trunk/omega/src/fusion.ml (revision 8744) @@ -1,3580 +1,3587 @@ (* 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 (*i val initialize_cache : string -> unit val set_cache_name : string -> unit i*) 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 and consistency checks \ldots *) val stat_to_string : stat -> string val equal : stat -> stat -> bool 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 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 "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 (* 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 "{ fermions=%s, antifermions=%s, state=%s, #=%d }" (ThoList.to_string (fun (i, f) -> Printf.sprintf "%d@%d" f i) (IMap.bindings p.fermions)) (ThoList.to_string (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 "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 = 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 "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 = 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 "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 "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 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 [ (*i "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"; i*) "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 (* \begin{dubious} This is \emph{very} inefficient for [max_degree > 6]. Find a better approach that avoids precomputing the huge lookup table! \end{dubious} \begin{dubious} I should revive the above Idea to use [M.vertices] instead directly, instead of rebuilding it from [M.fuse2], [M.fuse3] and [M.fuse]! \end{dubious} *) let vertices_nocache max_degree flavors : vertices = VSet.fold (fun f rhs v -> (f, rhs) :: v) (PT.power_fold ~truncate:(pred max_degree) 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 (*i 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 i*) let vertices = vertices_nocache let vertices' max_degree flavors = Printf.eprintf ">>> vertices %d ..." max_degree; flush stderr; let v = vertices max_degree flavors in Printf.eprintf " done.\n"; flush stderr; v (* 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.saturated legacy) then failwith (Printf.sprintf "Fusion.stat_keystone: legacy incomplete: %s!" (S.stat_to_string legacy)) end; 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 (min n (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 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) (* 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 | 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 saturated = function | Boson _ -> true | 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" (* 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. *) (* \thocwmodulesubsection{Merge Fermion Lines for Legacy Models with Implied Fermion Connections} *) (* 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 | 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), (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.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, (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. *) 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 the [int -> int] map [fermions]. \end{enumerate} *) let empty_partial = { stat = Boson []; fermions = IMap.empty; n = 0 } (* Only for debugging: *) let partial_to_string p = Printf.sprintf "{ fermions=%s, stat=%s, #=%d }" (ThoList.to_string (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') (* 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 "add_lines_to_partial: unexpected Fermion" | AntiFermion (p, l) -> invalid_arg "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 } | 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 } | 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" (* 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 is_incoming p i && is_incoming p j then saturate_fermion_line p i j else if is_incoming p i then pass_through_fermion_line p i else if is_incoming p j then pass_through_fermion_line p j else failwith "match_fermion_line: both lines outgoing" let match_fermion_line_logging p (i, j) = Printf.eprintf "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 _ = (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 "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 "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 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 (* \thocwmodulesubsection{Final Step using Explicit Fermion Connections} *) let stat_keystone_new flines slist f = match slist with | [] -> 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)) +module B2 = struct let max_arity () = 2 end +module B3 = struct let max_arity () = 3 end +module Helac_Binary = Helac(B2) +module Helac_Binary_Majorana = Helac(B2) +module Helac_Mixed23 = Helac(B3) +module Helac_Mixed23_Majorana = Helac(B3) + (* \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 (*i val initialize_cache : string -> unit val set_cache_name : string -> unit i*) 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 } (*i let initialize_cache = F.initialize_cache let set_cache_name = F.set_cache_name i*) 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/omega_THDM.ml =================================================================== --- trunk/omega/src/omega_THDM.ml (revision 8743) +++ trunk/omega/src/omega_THDM.ml (revision 8744) @@ -1,36 +1,36 @@ (* omega_THDM.ml -- 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. *) -module O = Omega.Make(Fusion.Mixed23)(Targets.Fortran) +module O = Omega.Mixed23(Targets.Fortran) (Modellib_BSM.TwoHiggsDoublet(Modellib_BSM.THDM)) let _ = O.main () (*i * Local Variables: * mode:caml * indent-tabs-mode:nil * page-delimiter:"^(\\* .*\n" * End: i*) Index: trunk/omega/src/omega_GravTest.ml =================================================================== --- trunk/omega/src/omega_GravTest.ml (revision 8743) +++ trunk/omega/src/omega_GravTest.ml (revision 8744) @@ -1,35 +1,26 @@ (* omega_GravTest.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. *) -module O = Omega.Make(Fusion_vintage.Mixed23_Majorana)(Targets.Fortran_Majorana) - (Modellib_BSM.GravTest(Modellib_BSM.BSM_bsm)) +module O = Omega.Mixed23_Majorana_vintage(Targets.Fortran_Majorana)(Modellib_BSM.GravTest(Modellib_BSM.BSM_bsm)) let _ = O.main () - -(*i - * Local Variables: - * mode:caml - * indent-tabs-mode:nil - * page-delimiter:"^(\\* .*\n" - * End: -i*) Index: trunk/omega/src/omega_UFO_Majorana.ml =================================================================== --- trunk/omega/src/omega_UFO_Majorana.ml (revision 8743) +++ trunk/omega/src/omega_UFO_Majorana.ml (revision 8744) @@ -1,42 +1,26 @@ (* omega_UFO_Majorana.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. *) -module Bound (M : Model.T) : Tuple.Bound = - struct - (* \begin{dubious} - Above [max_degree = 6], the performance drops \emph{dramatically}! - \end{dubious} *) - let max_arity () = - pred (M.max_degree ()) - end - -module O = Omega.Make(Fusion.Nary_Majorana(Bound(UFO.Model)))(Targets.Fortran_Majorana)(UFO.Model) +module O = Omega.Nary_Majorana(Targets.Fortran_Majorana)(UFO.Model) let _ = O.main () - -(*i - * Local Variables: - * indent-tabs-mode:nil - * page-delimiter:"^(\\* .*\n" - * End: -i*) Index: trunk/omega/src/omega_QCD.ml =================================================================== --- trunk/omega/src/omega_QCD.ml (revision 8743) +++ trunk/omega/src/omega_QCD.ml (revision 8744) @@ -1,36 +1,36 @@ (* omega_QCD.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. *) -module O = Omega.Make(Fusion.Mixed23)(Targets.Fortran)(Modellib_SM.QCD) +module O = Omega.Mixed23(Targets.Fortran)(Modellib_SM.QCD) let _ = O.main () (*i * Local Variables: * mode:caml * indent-tabs-mode:nil * page-delimiter:"^(\\* .*\n" * End: i*) Index: trunk/omega/src/omega_QED.ml =================================================================== --- trunk/omega/src/omega_QED.ml (revision 8743) +++ trunk/omega/src/omega_QED.ml (revision 8744) @@ -1,34 +1,26 @@ (* omega_QED.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. *) -module O = Omega.Make(Fusion.Binary)(Targets.Fortran)(Modellib_SM.QED) +module O = Omega.Binary(Targets.Fortran)(Modellib_SM.QED) let _ = O.main () - -(*i - * Local Variables: - * mode:caml - * indent-tabs-mode:nil - * page-delimiter:"^(\\* .*\n" - * End: -i*) Index: trunk/omega/src/modeltools.mli =================================================================== --- trunk/omega/src/modeltools.mli (revision 8743) +++ trunk/omega/src/modeltools.mli (revision 8744) @@ -1,80 +1,84 @@ (* modeltools.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. *) (* \thocwmodulesection{Compilation} *) module type Flavor = sig type f type c val compare : f -> f -> int val conjugate : f -> f end module type Fusions = sig type t type f type c val fuse2 : t -> f -> f -> (f * c Coupling.t) list val fuse3 : t -> f -> f -> f -> (f * c Coupling.t) list val fuse : t -> f list -> (f * c Coupling.t) list val of_vertices : (((f * f * f) * c Coupling.vertex3 * c) list * ((f * f * f * f) * c Coupling.vertex4 * c) list * (f list * c Coupling.vertexn * c) list) -> t end module Fusions : functor (F : Flavor) -> Fusions with type f = F.f and type c = F.c (* \thocwmodulesection{Coupling Constants} *) (* There is no [Model.constant_of_string] function, but we can construct one by inverting [Model.constant_symbol] on the set of all coupling constants appearing in the vertices. *) module type Constant = sig type t val of_string : string -> t end module Constant : functor (M : Model.T) -> Constant with type t = M.constant (* \thocwmodulesection{Mutable Models} *) module Mutable : functor (FGC : sig type f and g and c end) -> Model.Mutable with type flavor = FGC.f and type gauge = FGC.g and type constant = FGC.c module Static (M : Model.T) : Model.Mutable -(*i - * Local Variables: - * mode:caml - * indent-tabs-mode:nil - * page-delimiter:"^(\\* .*\n" - * End: -i*) +(* \thocwmodulesection{Topology Only} *) + +module Topology (M : Model.T) : Model.T + with type flavor = M.flavor + and type gauge = M.gauge + and type constant = M.constant + +module Topology3 (M : Model.T) : Model.T + with type flavor = M.flavor + and type gauge = M.gauge + and type constant = M.constant Index: trunk/share/tests/functional_tests/ref-output/bjet_cluster.ref =================================================================== --- trunk/share/tests/functional_tests/ref-output/bjet_cluster.ref (revision 8743) +++ trunk/share/tests/functional_tests/ref-output/bjet_cluster.ref (revision 8744) @@ -1,111 +1,111 @@ ?openmp_logging = false ?vis_history = false ?integration_timer = false ?pacify = true ?omega_write_phs_output = true | Switching to model 'SM', scheme 'default' SM.alphas => 1.18000E-01 ?alphas_is_fixed = false ?alphas_from_mz = true ?alphas_from_lambda_qcd = false alphas_nf = 5 SM.ms => 0.00000E+00 SM.mc => 0.00000E+00 [user variable] lightjet = PDG(2, -2, 1, -1, 3, -3, 4, -4, 21) [user variable] jet = PDG(2, -2, 1, -1, 3, -3, 4, -4, 21, 5, -5) $phs_method = "fast_wood" $restrictions = "!H" | Process library 'bjet_cluster_lib': recorded process 'bjet_cluster_p1' seed = 1234 sqrts = 1.00000E+03 jet_algorithm = 2 jet_r = 5.00000E-01 | Integrate: current process library needs compilation | Process library 'bjet_cluster_lib': compiling ... | Process library 'bjet_cluster_lib': writing makefile | Process library 'bjet_cluster_lib': removing old files | Process library 'bjet_cluster_lib': writing driver | Process library 'bjet_cluster_lib': creating source code | Process library 'bjet_cluster_lib': compiling sources | Process library 'bjet_cluster_lib': linking | Process library 'bjet_cluster_lib': loading | Process library 'bjet_cluster_lib': ... success. | Integrate: compilation done | QCD alpha: using a running strong coupling | RNG: Initializing TAO random-number generator | RNG: Setting seed for random-number generator to 1234 | Initializing integration for process bjet_cluster_p1: | Beam structure: [any particles] | Beam data (collision): | e- (mass = 5.1099700E-04 GeV) | e+ (mass = 5.1099700E-04 GeV) | sqrts = 1.000000000000E+03 GeV | Phase space: generating configuration ... | Phase space: ... success. | Phase space: writing configuration file 'bjet_cluster_p1.i1.phs' | ------------------------------------------------------------------------ | Process [scattering]: 'bjet_cluster_p1' | Library name = 'bjet_cluster_lib' | Process index = 1 | Process components: | 1: 'bjet_cluster_p1_i1': e-, e+ => b, bbar, u:ubar:d:dbar:s:sbar:c:cbar:gl, u:ubar:d:dbar:s:sbar:c:cbar:gl [omega] | ------------------------------------------------------------------------ | Phase space: 68 channels, 8 dimensions | Phase space: found 68 channels, collected in 12 groves. | Phase space: Using 104 equivalences between channels. | Phase space: wood | Applying user-defined cuts. | Using user-defined general scale. | Starting integration for process 'bjet_cluster_p1' | Integrate: iterations = 1:760:"gw" | Integrator: 12 chains, 68 channels, 8 dimensions | Integrator: Using VAMP channel equivalences | Integrator: 760 initial calls, 20 bins, stratified = T | Integrator: VAMP |=============================================================================| | It Calls Integral[fb] Error[fb] Err[%] Acc Eff[%] Chi2 N[It] | |=============================================================================| - 1 748 2.862E+01 2.22E+01 77.61 21.23 9.7 + 1 748 3.021E+01 2.23E+01 73.79 20.18 9.5 |-----------------------------------------------------------------------------| - 1 748 2.862E+01 2.22E+01 77.61 21.23 9.7 + 1 748 3.021E+01 2.23E+01 73.79 20.18 9.5 |=============================================================================| | QCD alpha: using a running strong coupling | RNG: Initializing TAO random-number generator | RNG: Setting seed for random-number generator to 1235 | Initializing integration for process bjet_cluster_p1: | Beam structure: [any particles] | Beam data (collision): | e- (mass = 5.1099700E-04 GeV) | e+ (mass = 5.1099700E-04 GeV) | sqrts = 1.000000000000E+03 GeV | Phase space: generating configuration ... | Phase space: ... success. | Phase space: writing configuration file 'bjet_cluster_p1.i1.phs' | ------------------------------------------------------------------------ | Process [scattering]: 'bjet_cluster_p1' | Library name = 'bjet_cluster_lib' | Process index = 1 | Process components: | 1: 'bjet_cluster_p1_i1': e-, e+ => b, bbar, u:ubar:d:dbar:s:sbar:c:cbar:gl, u:ubar:d:dbar:s:sbar:c:cbar:gl [omega] | ------------------------------------------------------------------------ | Phase space: 68 channels, 8 dimensions | Phase space: found 68 channels, collected in 12 groves. | Phase space: Using 104 equivalences between channels. | Phase space: wood | Applying user-defined cuts. | Using user-defined general scale. | Starting integration for process 'bjet_cluster_p1' | Integrate: iterations = 1:760:"gw" | Integrator: 12 chains, 68 channels, 8 dimensions | Integrator: Using VAMP channel equivalences | Integrator: 760 initial calls, 20 bins, stratified = T | Integrator: VAMP |=============================================================================| | It Calls Integral[fb] Error[fb] Err[%] Acc Eff[%] Chi2 N[It] | |=============================================================================| - 1 748 2.517E+01 4.46E+00 17.72 4.85 13.0 + 1 748 2.365E+01 4.13E+00 17.46 4.78 13.6 |-----------------------------------------------------------------------------| - 1 748 2.517E+01 4.46E+00 17.72 4.85 13.0 + 1 748 2.365E+01 4.13E+00 17.46 4.78 13.6 |=============================================================================| | WHIZARD run finished. |=============================================================================| Index: trunk/share/tests/unit_tests/ref-output/models_9.ref =================================================================== --- trunk/share/tests/unit_tests/ref-output/models_9.ref (revision 8743) +++ trunk/share/tests/unit_tests/ref-output/models_9.ref (revision 8744) @@ -1,264 +1,256 @@ * Test output: models_9 * Purpose: enable the UFO Standard Model (test version) * Generate and read UFO model model "SM" ! model derived from UFO source parameter aEWM1 = 1.279000000000E+02 slha_entry SMINPUTS 1 parameter Gf = 1.166370000000E-05 slha_entry SMINPUTS 2 parameter aS = 1.184000000000E-01 slha_entry SMINPUTS 3 parameter ymdo = 5.040000000000E-03 slha_entry YUKAWA 1 parameter ymup = 2.550000000000E-03 slha_entry YUKAWA 2 parameter yms = 1.010000000000E-01 slha_entry YUKAWA 3 parameter ymc = 1.270000000000E+00 slha_entry YUKAWA 4 parameter ymb = 4.700000000000E+00 slha_entry YUKAWA 5 parameter ymt = 1.720000000000E+02 slha_entry YUKAWA 6 parameter yme = 5.110000000000E-04 slha_entry YUKAWA 11 parameter ymm = 1.056600000000E-01 slha_entry YUKAWA 13 parameter ymtau = 1.777000000000E+00 slha_entry YUKAWA 15 parameter MZ = 9.118760000000E+01 slha_entry MASS 23 parameter Me = 5.110000000000E-04 slha_entry MASS 11 parameter MMU = 1.056600000000E-01 slha_entry MASS 13 parameter MTA = 1.777000000000E+00 slha_entry MASS 15 parameter MU = 2.550000000000E-03 slha_entry MASS 2 parameter MC = 1.270000000000E+00 slha_entry MASS 4 parameter MT = 1.720000000000E+02 slha_entry MASS 6 parameter MD = 5.040000000000E-03 slha_entry MASS 1 parameter MS = 1.010000000000E-01 slha_entry MASS 3 parameter MB = 4.700000000000E+00 slha_entry MASS 5 parameter MH = 1.250000000000E+02 slha_entry MASS 25 parameter WZ = 2.495200000000E+00 slha_entry DECAY 23 parameter WW = 2.085000000000E+00 slha_entry DECAY 24 parameter WT = 1.508340000000E+00 slha_entry DECAY 6 parameter WH = 4.070000000000E-03 slha_entry DECAY 25 derived aEW = 7.818608287725E-03 derived G = 8.625132696777E-01 derived MW = 7.982435974620E+01 derived ee = 3.134510000495E-01 derived sw2 = 2.336991334218E-01 derived cw = 8.753861242778E-01 derived sw = 4.834243823204E-01 derived g1 = 3.580717027107E-01 derived gw = 6.483971671950E-01 derived vev = 2.462205690735E+02 derived lam = 1.288668963082E-01 derived yb = 2.699532280412E-02 derived yc = 7.294480842816E-03 derived ydo = 2.894817594314E-05 derived ye = 2.935023394235E-06 derived ym = 6.068778313795E-04 derived ys = 5.801122560035E-04 derived yt = 9.879139409168E-01 derived ytau = 1.020652949424E-02 derived yup = 1.464639854266E-05 derived muH = 8.838834764832E+01 derived I1a11 = 2.894817594314E-05 derived I1a22 = 5.801122560035E-04 derived I1a33 = 2.699532280412E-02 derived I2a11 = 1.464639854266E-05 derived I2a22 = 7.294480842816E-03 derived I2a33 = 9.879139409168E-01 derived I3a11 = 1.464639854266E-05 derived I3a22 = 7.294480842816E-03 derived I3a33 = 9.879139409168E-01 derived I4a11 = 2.894817594314E-05 derived I4a22 = 5.801122560035E-04 derived I4a33 = 2.699532280412E-02 particle vt 16 name "vt" anti "vt~" tex_name "vt" tex_anti "vt~" spin 1/2 particle vm 14 name "vm" anti "vm~" tex_name "vm" tex_anti "vm~" spin 1/2 particle ve 12 name "ve" anti "ve~" tex_name "ve" tex_anti "ve~" spin 1/2 particle u 2 name "u" anti "u~" tex_name "u" tex_anti "u~" spin 1/2 charge 2/3 color 3 mass MU particle ta- 15 name "ta-" anti "ta+" tex_name "ta-" tex_anti "ta+" spin 1/2 charge -1 mass MTA particle t 6 name "t" anti "t~" tex_name "t" tex_anti "t~" spin 1/2 charge 2/3 color 3 mass MT width WT particle s 3 name "s" anti "s~" tex_name "s" tex_anti "s~" spin 1/2 charge -1/3 color 3 mass MS particle mu- 13 name "mu-" anti "mu+" tex_name "mu-" tex_anti "mu+" spin 1/2 charge -1 mass MMU particle g 21 name "g" tex_name "g" spin 1 color 8 particle e- 11 name "e-" anti "e+" tex_name "e-" tex_anti "e+" spin 1/2 charge -1 mass Me particle d 1 name "d" anti "d~" tex_name "d" tex_anti "d~" spin 1/2 charge -1/3 color 3 mass MD particle c 4 name "c" anti "c~" tex_name "c" tex_anti "c~" spin 1/2 charge 2/3 color 3 mass MC particle b 5 name "b" anti "b~" tex_name "b" tex_anti "b~" spin 1/2 charge -1/3 color 3 mass MB particle a 22 name "a" tex_name "a" spin 1 particle Z 23 name "Z" tex_name "Z" spin 1 mass MZ width WZ particle W+ 24 name "W+" anti "W-" tex_name "W+" tex_anti "W-" spin 1 charge 1 mass MW width WW particle H 25 name "H" tex_name "H" spin 0 mass MH width WH particle PROTON 2212 name "p" "p+" anti "pbar" "p-" spin 1/2 charge 1 particle HADRON_REMNANT 90 name "hr" tex_name "had_r" spin -1/2 particle HADRON_REMNANT_SINGLET 91 name "hr1" tex_name "had_r^{(1)}" spin -1/2 particle HADRON_REMNANT_TRIPLET 92 name "hr3" anti "hr3bar" tex_name "had_r^{(3)}" tex_anti "had_r^{(\bar 3)}" spin -1/2 color 3 particle HADRON_REMNANT_OCTET 93 name "hr8" tex_name "had_r^{(8)}" spin -1/2 color 8 vertex "Z" "Z" "H" - vertex "Z" "Z" "H" "H" - vertex "a" "W-" "W+" "Z" vertex "H" "H" "H" - vertex "W-" "W-" "W+" "W+" vertex "W-" "W+" "Z" - vertex "a" "a" "W-" "W+" vertex "W-" "W+" "H" - vertex "W-" "W+" "H" "H" vertex "a" "W-" "W+" vertex "t~" "t" "H" vertex "c~" "c" "H" vertex "u~" "u" "H" - vertex "H" "H" "H" "H" vertex "ta+" "ta-" "H" vertex "mu+" "mu-" "H" vertex "e+" "e-" "H" vertex "b~" "b" "H" vertex "s~" "s" "H" vertex "d~" "d" "H" - vertex "g" "g" "g" "g" vertex "g" "g" "g" vertex "ta+" "ta-" "Z" vertex "mu+" "mu-" "Z" vertex "e+" "e-" "Z" vertex "vt~" "vt" "Z" vertex "vm~" "vm" "Z" vertex "ve~" "ve" "Z" vertex "b~" "b" "Z" vertex "s~" "s" "Z" vertex "d~" "d" "Z" vertex "t~" "t" "Z" vertex "c~" "c" "Z" vertex "u~" "u" "Z" vertex "vt~" "ta-" "W+" vertex "vm~" "mu-" "W+" vertex "ve~" "e-" "W+" vertex "ta+" "vt" "W-" vertex "mu+" "vm" "W-" vertex "e+" "ve" "W-" vertex "t~" "b" "W+" vertex "c~" "s" "W+" vertex "u~" "d" "W+" vertex "b~" "t" "W-" vertex "s~" "c" "W-" vertex "d~" "u" "W-" vertex "b~" "b" "g" vertex "s~" "s" "g" vertex "d~" "d" "g" vertex "t~" "t" "g" vertex "c~" "c" "g" vertex "u~" "u" "g" vertex "b~" "b" "a" vertex "s~" "s" "a" vertex "d~" "d" "a" vertex "t~" "t" "a" vertex "c~" "c" "a" vertex "u~" "u" "a" vertex "ta+" "ta-" "a" vertex "mu+" "mu-" "a" vertex "e+" "e-" "a" - vertex "W-" "W+" "Z" "Z" * Cleanup * Test output end: models_9