Index: trunk/omega/src/UFO_targets.ml =================================================================== --- trunk/omega/src/UFO_targets.ml (revision 8475) +++ trunk/omega/src/UFO_targets.ml (revision 8476) @@ -1,1298 +1,1303 @@ (* UFO_targets.ml -- Copyright (C) 1999-2017 by Wolfgang Kilian Thorsten Ohl Juergen Reuter with contributions from Christian Speckner WHIZARD is free software; you can redistribute it and/or modify it under the terms of the GNU General Public License as published by the Free Software Foundation; either version 2, or (at your option) any later version. WHIZARD is distributed in the hope that it will be useful, but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License for more details. You should have received a copy of the GNU General Public License along with this program; if not, write to the Free Software Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. *) let (@@) f g x = f (g x) (* \thocwmodulesection{Generating Code for UFO Lorentz Structures} *) (* O'Caml before 4.02 had a module typing bug that forces us to put this definition outside [Lorentz_Fusion]. *) module Q = Algebra.Q module QC = Algebra.QC module type T = sig (* [lorentz formatter name spins v] writes a representation of the Lorentz structure [v] of particles with the Lorentz representations [spins] as a (Fortran) function [name] to [formatter]. *) val lorentz : Format_Fortran.formatter -> string -> Coupling.lorentz array -> UFO_Lorentz.t -> unit val propagator : Format_Fortran.formatter -> string -> Coupling.lorentz * Coupling.lorentz -> UFO_Lorentz.t -> UFO_Lorentz.t -> unit val fusion_name : string -> Permutation.Default.t -> Coupling.fermion_lines -> string val fuse : Algebra.QC.t -> string -> Coupling.lorentzn -> Coupling.fermion_lines -> string -> string list -> string list -> Coupling.fusen -> unit val eps4_g4_g44_decl : Format_Fortran.formatter -> unit -> unit val eps4_g4_g44_init : Format_Fortran.formatter -> unit -> unit module type Test = sig val suite : OUnit.test end module Test : Test end module Fortran : T = struct open Format_Fortran let pp_divide ?(indent=0) ff () = fprintf ff "%*s! %s" indent "" (String.make (70 - indent) '-'); pp_newline ff () let conjugate = function | Coupling.Spinor -> Coupling.ConjSpinor | Coupling.ConjSpinor -> Coupling.Spinor | r -> r let spin_mnemonic = function | Coupling.Scalar -> "phi" | Coupling.Spinor -> "psi" | Coupling.ConjSpinor -> "psibar" | Coupling.Majorana -> "chi" | Coupling.Maj_Ghost -> invalid_arg "UFO_targets: Maj_Ghost" | Coupling.Vector -> "a" | Coupling.Massive_Vector -> "v" | Coupling.Vectorspinor -> "grav" (* itino *) | Coupling.Tensor_1 -> invalid_arg "UFO_targets: Tensor_1" | Coupling.Tensor_2 -> "h" | Coupling.BRS l -> invalid_arg "UFO_targets: BRS" let fortran_type = function | Coupling.Scalar -> "complex(kind=default)" | Coupling.Spinor -> "type(spinor)" | Coupling.ConjSpinor -> "type(conjspinor)" | Coupling.Majorana -> "type(bispinor)" | Coupling.Maj_Ghost -> invalid_arg "UFO_targets: Maj_Ghost" | Coupling.Vector -> "type(vector)" | Coupling.Massive_Vector -> "type(vector)" | Coupling.Vectorspinor -> "type(vectorspinor)" | Coupling.Tensor_1 -> invalid_arg "UFO_targets: Tensor_1" | Coupling.Tensor_2 -> "type(tensor)" | Coupling.BRS l -> invalid_arg "UFO_targets: BRS" (* The \texttt{omegalib} separates time from space. Maybe not a good idea after all. Mend it locally \ldots *) type wf = { pos : int; spin : Coupling.lorentz; name : string; local_array : string option; momentum : string; momentum_array : string; fortran_type : string } let wf_table spins = Array.mapi (fun i s -> let spin = if i = 0 then conjugate s else s in let pos = succ i in let i = string_of_int pos in let name = spin_mnemonic s ^ i in let local_array = begin match spin with | Coupling.Vector | Coupling.Massive_Vector -> Some (name ^ "a") | _ -> None end in { pos; spin; name; local_array; momentum = "k" ^ i; momentum_array = "p" ^ i; fortran_type = fortran_type spin } ) spins module L = UFO_Lorentz (* Format rational ([Q.t]) and complex rational ([QC.t]) numbers as fortran values. *) let format_rational q = if Q.is_integer q then string_of_int (Q.to_integer q) else let n, d = Q.to_ratio q in Printf.sprintf "%d.0_default/%d" n d let format_complex_rational cq = let real = QC.real cq and imag = QC.imag cq in if Q.is_null imag then begin if Q.is_negative real then "(" ^ format_rational real ^ ")" else format_rational real end else if Q.is_integer real && Q.is_integer imag then Printf.sprintf "(%d,%d)" (Q.to_integer real) (Q.to_integer imag) else Printf.sprintf "cmplx(%s,%s,kind=default)" (format_rational real) (format_rational imag) (* Optimize the representation if used as a prefactor of a summand in a sum. *) let format_rational_factor q = if Q.is_unit q then "+" else if Q.is_unit (Q.neg q) then "-" else if Q.is_negative q then "-" ^ format_rational (Q.neg q) ^ "*" else "+" ^ format_rational q ^ "*" let format_complex_rational_factor cq = let real = QC.real cq and imag = QC.imag cq in if Q.is_null imag then begin if Q.is_unit real then "+" else if Q.is_unit (Q.neg real) then "-" else if Q.is_negative real then "-" ^ format_rational (Q.neg real) ^ "*" else "+" ^ format_rational real ^ "*" end else if Q.is_integer real && Q.is_integer imag then Printf.sprintf "+(%d,%d)*" (Q.to_integer real) (Q.to_integer imag) else Printf.sprintf "+cmplx(%s,%s,kind=default)*" (format_rational real) (format_rational imag) (* Append a formatted list of indices to [name]. *) let append_indices name = function | [] -> name | indices -> name ^ "(" ^ String.concat "," (List.map string_of_int indices) ^ ")" (* Dirac string variables and their names. *) type dsv = | Ket of int | Bra of int | Braket of int let dsv_name = function | Ket n -> Printf.sprintf "ket%02d" n | Bra n -> Printf.sprintf "bra%02d" n | Braket n -> Printf.sprintf "bkt%02d" n let dirac_dimension dsv indices = let tail ilist = String.concat "," (List.map (fun _ -> "0:3") ilist) ^ ")" in match dsv, indices with | Braket _, [] -> "" | (Ket _ | Bra _), [] -> ", dimension(1:4)" | Braket _, indices -> ", dimension(" ^ tail indices | (Ket _ | Bra _), indices -> ", dimension(1:4," ^ tail indices (* Write Fortran code to [decl] and [eval]: apply the Dirac matrix [gamma] with complex rational entries to the spinor [ket] from the left. [ket] must be the name of a scalar variable and cannot be an array element. The result is stored in [dsv_name (Ket n)] which can have additional [indices]. Return [Ket n] for further processing. *) let dirac_ket_to_fortran_decl ff n indices = let printf fmt = fprintf ff fmt and nl = pp_newline ff in let dsv = Ket n in printf " @[<2>complex(kind=default)%s ::@ %s@]" (dirac_dimension dsv indices) (dsv_name dsv); nl () let dirac_ket_to_fortran_eval ff n indices gamma ket = let printf fmt = fprintf ff fmt and nl = pp_newline ff in let dsv = Ket n in for i = 0 to 3 do let name = append_indices (dsv_name dsv) (succ i :: indices) in printf " @[<%d>%s = 0" (String.length name + 5) name; for j = 0 to 3 do if gamma.(i).(j) <> QC.null then printf "@,%s%s%%a(%d)" (format_complex_rational_factor gamma.(i).(j)) ket.name (succ j) done; printf "@]"; nl () done; dsv (* The same as [dirac_bra_to_fortran], but apply the Dirac matrix [gamma] to [bra] from the right and return [Bra n]. *) let dirac_bra_to_fortran_decl ff n indices = let printf fmt = fprintf ff fmt and nl = pp_newline ff in let dsv = Bra n in printf " @[<2>complex(kind=default)%s ::@ %s@]" (dirac_dimension dsv indices) (dsv_name dsv); nl () let dirac_bra_to_fortran_eval ff n indices bra gamma = let printf fmt = fprintf ff fmt and nl = pp_newline ff in let dsv = Bra n in for j = 0 to 3 do let name = append_indices (dsv_name dsv) (succ j :: indices) in printf " @[<%d>%s = 0" (String.length name + 5) name; for i = 0 to 3 do if gamma.(i).(j) <> QC.null then printf "@,%s%s%%a(%d)" (format_complex_rational_factor gamma.(i).(j)) bra.name (succ i) done; printf "@]"; nl () done; dsv (* More of the same, but evaluating a spinor sandwich and returning [Braket n]. *) let dirac_braket_to_fortran_decl ff n indices = let printf fmt = fprintf ff fmt and nl = pp_newline ff in let dsv = Braket n in printf " @[<2>complex(kind=default)%s ::@ %s@]" (dirac_dimension dsv indices) (dsv_name dsv); nl () let dirac_braket_to_fortran_eval ff n indices bra gamma ket = let printf fmt = fprintf ff fmt and nl = pp_newline ff in let dsv = Braket n in let name = append_indices (dsv_name dsv) indices in printf " @[<%d>%s = 0" (String.length name + 5) name; for i = 0 to 3 do for j = 0 to 3 do if gamma.(i).(j) <> QC.null then printf "@,%s%s%%a(%d)*%s%%a(%d)" (format_complex_rational_factor gamma.(i).(j)) bra.name (succ i) ket.name (succ j) done done; printf "@]"; nl (); dsv (* Choose among the previous functions according to the position of [bra] and [ket] among the wavefunctions. If any is in the first position evaluate the spinor expression with the corresponding spinor removed, otherwise evaluate the spinir sandwich. *) let dirac_bra_or_ket_to_fortran_decl ff n indices bra ket = if bra = 1 then dirac_ket_to_fortran_decl ff n indices else if ket = 1 then dirac_bra_to_fortran_decl ff n indices else dirac_braket_to_fortran_decl ff n indices let dirac_bra_or_ket_to_fortran_eval ff n indices wfs bra gamma ket = if bra = 1 then dirac_ket_to_fortran_eval ff n indices gamma wfs.(pred ket) else if ket = 1 then dirac_bra_to_fortran_eval ff n indices wfs.(pred bra) gamma else dirac_braket_to_fortran_eval ff n indices wfs.(pred bra) gamma wfs.(pred ket) (* UFO summation indices are negative integers. Derive a valid Fortran variable name. *) let prefix_summation = "mu" let prefix_polarization = "nu" let index_spinor = "alpha" let index_tensor = "nu" let index_variable mu = if mu < 0 then Printf.sprintf "%s%d" prefix_summation (- mu) else if mu == 0 then prefix_polarization else Printf.sprintf "%s%d" prefix_polarization mu let format_indices indices = String.concat "," (List.map index_variable indices) module IntPM = Partial.Make (struct type t = int let compare = compare end) type tensor = | DS of dsv | V of string | T of UFOx.Lorentz_Atom.vector | S of UFOx.Lorentz_Atom.scalar | Inv of UFOx.Lorentz_Atom.scalar (* Transform the Dirac strings if we have Majorana fermions involved, in order to implement the algorithm from JRR's thesis. NB: The following is for reference only, to better understand what JRR was doing\ldots *) (* If the vertex is (suppressing the Lorentz indices of~$\phi_2$ and~$\Gamma$) \begin{equation} \bar\psi_1 \Gamma\phi_2 \psi_3 = \Gamma_{\alpha\beta} \bar\psi_{1,\alpha} \phi_2 \psi_{3,\beta}\,, \end{equation} then this is the version implemented by [fuse] below. *) let tho_print_dirac_current f c wf1 wf2 fusion = match fusion with | [1; 3] -> printf "%s_ff(%s,%s,%s)" f c wf1 wf2 (* $\Gamma_{\alpha\beta} \bar\psi_{1,\alpha} \psi_{3,\beta}$ *) | [3; 1] -> printf "%s_ff(%s,%s,%s)" f c wf2 wf1 (* $\Gamma_{\alpha\beta} \bar\psi_{1,\alpha} \psi_{3,\beta}$ *) | [2; 3] -> printf "f_%sf(%s,%s,%s)" f c wf1 wf2 (* $\Gamma_{\alpha\beta} \phi_2 \psi_{3,\beta}$ *) | [3; 2] -> printf "f_%sf(%s,%s,%s)" f c wf2 wf1 (* $\Gamma_{\alpha\beta} \phi_2 \psi_{3,\beta}$ *) | [1; 2] -> printf "f_f%s(%s,%s,%s)" f c wf1 wf2 (* $\Gamma_{\alpha\beta} \bar\psi_{1,\alpha} \phi_2$ *) | [2; 1] -> printf "f_f%s(%s,%s,%s)" f c wf2 wf1 (* $\Gamma_{\alpha\beta} \bar\psi_{1,\alpha} \phi_2$ *) | _ -> () (* This is how JRR implemented (see subsection~\ref{sec:dirac-matrices-jrr}) the Dirac matrices that don't change sign under $C\Gamma^T C^{-1} = \Gamma$, i.\,e.~$\mathbf{1}$, $\gamma_5$ and~$\gamma_5\gamma_\mu$ (see [Targets.Fortran_Majorana_Fermions.print_fermion_current]) \begin{itemize} \item In the case of two fermions, the second wave function [wf2] is always put into the right slot, as described in JRR's thesis. \label{pg:JRR-Fusions} \item In the case of a boson and a fermion, there is no need for both ["f_%sf"] and ["f_f%s"], since the latter can be obtained by exchanging arguments. \end{itemize} *) let jrr_print_majorana_current_S_P_A f c wf1 wf2 fusion = match fusion with | [1; 3] -> printf "%s_ff(%s,%s,%s)" f c wf1 wf2 (* $(C\Gamma)_{\alpha\beta} \bar\psi_{1,\alpha} \psi_{3,\beta} \cong C\Gamma $ *) | [3; 1] -> printf "%s_ff(%s,%s,%s)" f c wf1 wf2 (* $(C\Gamma)_{\alpha\beta} \psi_{3,\alpha} \bar\psi_{1,\beta} \cong C\Gamma = C\,C\Gamma^T C^{-1} $ *) | [2; 3] -> printf "f_%sf(%s,%s,%s)" f c wf1 wf2 (* $\Gamma_{\alpha\beta} \phi_2 \psi_{3,\beta} \cong \Gamma $ *) | [3; 2] -> printf "f_%sf(%s,%s,%s)" f c wf2 wf1 (* $\Gamma_{\alpha\beta} \phi_2 \psi_{3,\beta} \cong \Gamma $ *) | [1; 2] -> printf "f_%sf(%s,%s,%s)" f c wf2 wf1 (* $\Gamma_{\alpha\beta} \phi_2 \bar\psi_{1,\beta} \cong \Gamma = C\Gamma^T C^{-1} $ *) | [2; 1] -> printf "f_%sf(%s,%s,%s)" f c wf1 wf2 (* $\Gamma_{\alpha\beta} \phi_2 \bar\psi_{1,\beta} \cong \Gamma = C\Gamma^T C^{-1} $ *) | _ -> () (* This is how JRR implemented the Dirac matrices that do change sign under $C\Gamma^T C^{-1} = - \Gamma$, i.\,e.~$\gamma_\mu$ and~$\sigma_{\mu\nu}$ (see [Targets.Fortran_Majorana_Fermions.print_fermion_current_vector]). *) let jrr_print_majorana_current_V f c wf1 wf2 fusion = match fusion with | [1; 3] -> printf "%s_ff( %s,%s,%s)" f c wf1 wf2 (* $ (C\Gamma)_{\alpha\beta} \bar\psi_{1,\alpha} \psi_{3,\beta} \cong C\Gamma $ *) | [3; 1] -> printf "%s_ff(-%s,%s,%s)" f c wf1 wf2 (* $-(C\Gamma)_{\alpha\beta} \psi_{3,\alpha} \bar\psi_{1,\beta} \cong -C\Gamma = C\,C\Gamma^T C^{-1} $ *) | [2; 3] -> printf "f_%sf( %s,%s,%s)" f c wf1 wf2 (* $ \Gamma_{\alpha\beta} \phi_2 \psi_{3,\beta} \cong \Gamma $ *) | [3; 2] -> printf "f_%sf( %s,%s,%s)" f c wf2 wf1 (* $ \Gamma_{\alpha\beta} \phi_2 \psi_{3,\beta} \cong \Gamma $ *) | [1; 2] -> printf "f_%sf(-%s,%s,%s)" f c wf2 wf1 (* $-\Gamma_{\alpha\beta} \phi_2 \bar\psi_{1,\beta} \cong -\Gamma = C\Gamma^T C^{-1} $ *) | [2; 1] -> printf "f_%sf(-%s,%s,%s)" f c wf1 wf2 (* $-\Gamma_{\alpha\beta} \phi_2 \bar\psi_{1,\beta} \cong -\Gamma = C\Gamma^T C^{-1} $ *) | _ -> () (* These two can be unified, if the \texttt{\_c} functions implement~$\Gamma'=C\Gamma^T C^{-1}$, but we \emph{must} make sure that the multiplication with~$C$ from the left happens \emph{after} the transformation~$\Gamma\to\Gamma'$. *) let jrr_print_majorana_current f c wf1 wf2 fusion = match fusion with | [1; 3] -> printf "%s_ff (%s,%s,%s)" f c wf1 wf2 (* $ (C\Gamma)_{\alpha\beta} \bar\psi_{1,\alpha} \psi_{3,\beta} \cong C\Gamma $ *) | [3; 1] -> printf "%s_ff_c(%s,%s,%s)" f c wf1 wf2 (* $(C\Gamma')_{\alpha\beta} \psi_{3,\alpha} \bar\psi_{1,\beta} \cong C\Gamma' = C\,C\Gamma^T C^{-1} $ *) | [2; 3] -> printf "f_%sf (%s,%s,%s)" f c wf1 wf2 (* $ \Gamma_{\alpha\beta} \phi_2 \psi_{3,\beta} \cong \Gamma $ *) | [3; 2] -> printf "f_%sf (%s,%s,%s)" f c wf2 wf1 (* $ \Gamma_{\alpha\beta} \phi_2 \psi_{3,\beta} \cong \Gamma $ *) | [1; 2] -> printf "f_%sf_c(%s,%s,%s)" f c wf2 wf1 (* $\Gamma'_{\alpha\beta} \phi_2 \bar\psi_{1,\beta} \cong \Gamma' = C\Gamma^T C^{-1} $ *) | [2; 1] -> printf "f_%sf_c(%s,%s,%s)" f c wf1 wf2 (* $\Gamma'_{\alpha\beta} \phi_2 \bar\psi_{1,\beta} \cong \Gamma' = C\Gamma^T C^{-1} $ *) | _ -> () (* Since we may assume~$C^{-1}=-C=C^T$, this can be rewritten if the \texttt{\_c} functions implement \begin{equation} \Gamma^{\prime\,T} = \left(C\Gamma^T C^{-1}\right)^T = \left(C^{-1}\right)^T \Gamma \left(C\right)^T = C \Gamma C^{-1} \end{equation} instead. *) let jrr_print_majorana_current_transposing f c wf1 wf2 fusion = match fusion with | [1; 3] -> printf "%s_ff (%s,%s,%s)" f c wf1 wf2 (* $ (C\Gamma)_{\alpha\beta} \bar\psi_{1,\alpha} \psi_{3,\beta} \cong C\Gamma $ *) | [3; 1] -> printf "%s_ff_c(%s,%s,%s)" f c wf2 wf1 (* $(C\Gamma')^T_{\alpha\beta} \bar\psi_{1,\alpha} \psi_{3,\beta} \cong (C\Gamma')^T = - C\Gamma $ *) | [2; 3] -> printf "f_%sf (%s,%s,%s)" f c wf1 wf2 (* $ \Gamma_{\alpha\beta} \phi_2 \psi_{3,\beta} \cong \Gamma $ *) | [3; 2] -> printf "f_%sf (%s,%s,%s)" f c wf2 wf1 (* $ \Gamma_{\alpha\beta} \phi_2 \psi_{3,\beta} \cong \Gamma $ *) | [1; 2] -> printf "f_f%s_c(%s,%s,%s)" f c wf1 wf2 (* $\Gamma^{\prime\,T}_{\alpha\beta} \bar\psi_{1,\alpha} \phi_2 \cong \Gamma^{\prime\,T} = C\Gamma C^{-1}$ *) | [2; 1] -> printf "f_f%s_c(%s,%s,%s)" f c wf2 wf1 (* $\Gamma^{\prime\,T}_{\alpha\beta} \bar\psi_{1,\alpha} \phi_2 \cong \Gamma^{\prime\,T} = C\Gamma C^{-1} $ *) | _ -> () (* where we have used \begin{equation} (C\Gamma')^T = \Gamma^{\prime,T}C^T = C\Gamma C^{-1} C^T = - C\Gamma\,. \end{equation} *) (* This puts the arguments in the same slots as [tho_print_dirac_current] above and can be implemented by [fuse], iff we inject the proper transformations in [dennerize] below. *) let is_majorana = function | Coupling.Majorana | Coupling.Vectorspinor | Coupling.Maj_Ghost -> true | _ -> false let is_dirac = function | Coupling.Spinor | Coupling.ConjSpinor -> true | _ -> false let dennerize ~eval wfs atom = let printf fmt = fprintf eval fmt and nl = pp_newline eval in if is_majorana wfs.(pred atom.L.bra).spin || is_majorana wfs.(pred atom.L.ket).spin then if atom.L.bra = 1 then (* Fusing one or more bosons with a ket like fermion: $\chi \leftarrow \Gamma\chi$. *) (* Don't do anything, as per subsection~\ref{sec:dirac-matrices-jrr}. *) atom else if atom.L.ket = 1 then (* We fuse one or more bosons with a bra like fermion: $\bar\chi \leftarrow \bar\chi\Gamma$. *) (* $\Gamma\to C\Gamma C^{-1}$. *) begin let atom = L.conjugate atom in printf " ! conjugated for Majorana"; nl (); printf " ! %s" (L.dirac_string_to_string atom); nl (); atom end else if atom.L.ket < atom.L.bra then (* We fuse zero or more bosons with a sandwich of fermions. $\phi \leftarrow \bar\chi\gamma\chi$.*) (* Multiply by~$C$ from the left, as per subsection~\ref{sec:dirac-matrices-jrr}. *) begin let atom = L.cc_times atom in printf " ! multiplied by CC for Majorana"; nl (); printf " ! %s" (L.dirac_string_to_string atom); nl (); atom end else (* Transposed: multiply by~$-C$ from the left. *) begin let atom = L.minus (L.cc_times atom) in printf " ! multiplied by negative CC for Majorana"; nl (); printf " ! %s" (L.dirac_string_to_string atom); nl (); atom end else atom (* Write the [i]th Dirac string [ds] as Fortran code to [eval], including a shorthand representation as a comment. Return [ds] with [ds.L.atom] replaced by the dirac string variable, i,\,e.~[DS dsv] annotated with the internal and external indices. In addition write the declaration to [decl]. *) let dirac_string_to_fortran ~decl ~eval i wfs ds = let printf fmt = fprintf eval fmt and nl = pp_newline eval in let bra = ds.L.atom.L.bra and ket = ds.L.atom.L.ket in pp_divide ~indent:4 eval (); printf " ! %s" (L.dirac_string_to_string ds.L.atom); nl (); let atom = dennerize ~eval wfs ds.L.atom in begin match ds.L.indices with | [] -> let gamma = L.dirac_string_to_matrix (fun _ -> 0) atom in dirac_bra_or_ket_to_fortran_decl decl i [] bra ket; let dsv = dirac_bra_or_ket_to_fortran_eval eval i [] wfs bra gamma ket in L.map_atom (fun _ -> DS dsv) ds | indices -> dirac_bra_or_ket_to_fortran_decl decl i indices bra ket; let combinations = Product.power (List.length indices) [0; 1; 2; 3] in let dsv = List.map (fun combination -> let substitution = IntPM.of_lists indices combination in let substitute = IntPM.apply substitution in let indices = List.map substitute indices in let gamma = L.dirac_string_to_matrix substitute atom in dirac_bra_or_ket_to_fortran_eval eval i indices wfs bra gamma ket) combinations in begin match ThoList.uniq (List.sort compare dsv) with | [dsv] -> L.map_atom (fun _ -> DS dsv) ds | _ -> failwith "dirac_string_to_fortran: impossible" end end (* Write the Dirac strings in the list [ds_list] as Fortran code to [eval], including shorthand representations as comments. Return the list of variables and corresponding indices to be contracted. *) let dirac_strings_to_fortran ~decl ~eval wfs last ds_list = List.fold_left (fun (i, acc) ds -> let i = succ i in (i, dirac_string_to_fortran ~decl ~eval i wfs ds :: acc)) (last, []) ds_list (* Perform a nested sum of terms, as printed by [print_term] (which takes the number of spaces to indent as only argument) of the cartesian product of [indices] running from 0 to 3. *) let nested_sums ~decl ~eval initial_indent indices print_term = let rec nested_sums' indent = function | [] -> print_term indent | index :: indices -> let var = index_variable index in fprintf eval "%*s@[<2>do %s = 0, 3@]" indent "" var; pp_newline eval (); nested_sums' (indent + 2) indices; pp_newline eval (); fprintf eval "%*s@[<2>end do@]" indent "" in nested_sums' (initial_indent + 2) indices (* Polarization indices also need to be summed over, but they appear only once. *) let indices_of_contractions contractions = let index_pairs, polarizations = L.classify_indices (ThoList.flatmap (fun ds -> ds.L.indices) contractions) in try ThoList.pairs index_pairs @ ThoList.uniq (List.sort compare polarizations) with | Invalid_argument s -> invalid_arg ("indices_of_contractions: " ^ ThoList.to_string string_of_int index_pairs) (*i Printf.eprintf "indices_of_contractions: %s / %s\n" (ThoList.to_string string_of_int index_pairs) (ThoList.to_string string_of_int polarizations); i*) let format_dsv dsv indices = match dsv, indices with | Braket _, [] -> dsv_name dsv | Braket _, ilist -> Printf.sprintf "%s(%s)" (dsv_name dsv) (format_indices indices) | (Bra _ | Ket _), [] -> Printf.sprintf "%s(%s)" (dsv_name dsv) index_spinor | (Bra _ | Ket _), ilist -> Printf.sprintf "%s(%s,%s)" (dsv_name dsv) index_spinor (format_indices indices) let format_tensor t = let indices = t.L.indices in match t.L.atom with | DS dsv -> format_dsv dsv indices | V vector -> Printf.sprintf "%s(%s)" vector (format_indices indices) | T UFOx.Lorentz_Atom.P (mu, n) -> Printf.sprintf "p%d(%s)" n (index_variable mu) | T UFOx.Lorentz_Atom.Epsilon (mu1, mu2, mu3, mu4) -> Printf.sprintf "eps4_(%s)" (format_indices [mu1; mu2; mu3; mu4]) | T UFOx.Lorentz_Atom.Metric (mu1, mu2) -> if mu1 > 0 && mu2 > 0 then Printf.sprintf "g44_(%s)" (format_indices [mu1; mu2]) else failwith "format_tensor: compress_metrics has failed!" | S (UFOx.Lorentz_Atom.Mass _) -> "m" | S (UFOx.Lorentz_Atom.Width _) -> "w" | Inv (UFOx.Lorentz_Atom.Mass _) -> "1/m" | Inv (UFOx.Lorentz_Atom.Width _) -> "1/w" let rec multiply_tensors ~decl ~eval = function | [] -> fprintf eval "1"; | [t] -> fprintf eval "%s" (format_tensor t) | t :: tensors -> fprintf eval "%s@,*" (format_tensor t); multiply_tensors ~decl ~eval tensors let contract_indices ~decl ~eval indent wf_indices wfs (fusion, contractees) = let printf fmt = fprintf eval fmt and nl = pp_newline eval in let sum_var = begin match wf_indices with | [] -> wfs.(0).name | ilist -> let indices = String.concat "," ilist in begin match wfs.(0).local_array with | None -> let component = begin match wfs.(0).spin with | Coupling.Spinor | Coupling.ConjSpinor | Coupling.Majorana -> "a" | Coupling.Tensor_2 -> "t" | Coupling.Vector | Coupling.Massive_Vector -> failwith "contract_indices: expected local_array for vectors" | _ -> failwith "contract_indices: unexpected spin" end in Printf.sprintf "%s%%%s(%s)" wfs.(0).name component indices | Some a -> Printf.sprintf "%s(%s)" a indices end end in let indices = List.filter (fun i -> UFOx.Index.position i <> 1) (indices_of_contractions contractees) in nested_sums ~decl ~eval indent indices (fun indent -> printf "%*s@[<2>%s = %s" indent "" sum_var sum_var; printf "@,%s" (format_complex_rational_factor fusion.L.coeff); List.iter (fun i -> printf "@,g4_(%s)*" (index_variable i)) indices; printf "@,("; multiply_tensors ~decl ~eval contractees; printf ")@]"); printf "@]"; nl () let external_wf_loop ~decl ~eval ~indent wfs (fusion, _ as contractees) = pp_divide ~indent eval (); fprintf eval "%*s! %s\n" indent "" (L.to_string [fusion]); pp_divide ~indent eval (); match wfs.(0).spin with | Coupling.Scalar -> contract_indices ~decl ~eval 2 [] wfs contractees | Coupling.Spinor | Coupling.ConjSpinor | Coupling.Majorana -> let idx = index_spinor in fprintf eval "%*s@[<2>do %s = 1, 4@]" indent "" idx; pp_newline eval (); contract_indices ~decl ~eval 4 [idx] wfs contractees; fprintf eval "%*send do@]" indent ""; pp_newline eval () | Coupling.Vector | Coupling.Massive_Vector -> let idx = index_variable 1 in fprintf eval "%*s@[<2>do %s = 0, 3@]" indent "" idx; pp_newline eval (); contract_indices ~decl ~eval 4 [idx] wfs contractees; fprintf eval "%*send do@]" indent ""; pp_newline eval () | Coupling.Tensor_2 -> let idx1 = index_variable (UFOx.Index.pack 1 1) and idx2 = index_variable (UFOx.Index.pack 1 2) in fprintf eval "%*s@[<2>do %s = 0, 3@]" indent "" idx1; pp_newline eval (); fprintf eval "%*s@[<2>do %s = 0, 3@]" (indent + 2) "" idx2; pp_newline eval (); contract_indices ~decl ~eval 6 [idx1; idx2] wfs contractees; fprintf eval "%*send do@]" (indent + 2) ""; pp_newline eval (); fprintf eval "%*send do@]" indent ""; pp_newline eval () | Coupling.Vectorspinor -> failwith "external_wf_loop: Vectorspinor not supported yet!" | Coupling.Maj_Ghost -> failwith "external_wf_loop: unexpected Maj_Ghost" | Coupling.Tensor_1 -> failwith "external_wf_loop: unexpected Tensor_1" | Coupling.BRS _ -> failwith "external_wf_loop: unexpected BRS" let local_vector_copies ~decl ~eval wfs = begin match wfs.(0).local_array with | None -> () | Some a -> fprintf decl " @[<2>complex(kind=default),@ dimension(0:3) ::@ %s@]" a; pp_newline decl () end; let n = Array.length wfs in for i = 1 to n - 1 do match wfs.(i).local_array with | None -> () | Some a -> fprintf decl " @[<2>complex(kind=default),@ dimension(0:3) ::@ %s@]" a; pp_newline decl (); fprintf eval " @[<2>%s(0) = %s%%t@]" a wfs.(i).name; pp_newline eval (); fprintf eval " @[<2>%s(1:3) = %s%%x@]" a wfs.(i).name; pp_newline eval () done let return_vector ff wfs = let printf fmt = fprintf ff fmt and nl = pp_newline ff in match wfs.(0).local_array with | None -> () | Some a -> pp_divide ~indent:4 ff (); printf " @[<2>%s%%t = %s(0)@]" wfs.(0).name a; nl (); printf " @[<2>%s%%x = %s(1:3)@]" wfs.(0).name a; nl () let multiply_coupling_and_scalars ff g_opt wfs = let printf fmt = fprintf ff fmt and nl = pp_newline ff in pp_divide ~indent:4 ff (); let g = match g_opt with | None -> "" | Some g -> g ^ "*" in let wfs0name = match wfs.(0).local_array with | None -> wfs.(0).name | Some a -> a in printf " @[<2>%s = %s%s" wfs0name g wfs0name; for i = 1 to Array.length wfs - 1 do match wfs.(i).spin with | Coupling.Scalar -> printf "@,*%s" wfs.(i).name | _ -> () done; printf "@]"; nl () let local_momentum_copies ~decl ~eval wfs = let n = Array.length wfs in fprintf decl " @[<2>real(kind=default),@ dimension(0:3) ::@ %s" wfs.(0).momentum_array; for i = 1 to n - 1 do fprintf decl ",@ %s" wfs.(i).momentum_array; fprintf eval " @[<2>%s(0) = %s%%t@]" wfs.(i).momentum_array wfs.(i).momentum; pp_newline eval (); fprintf eval " @[<2>%s(1:3) = %s%%x@]" wfs.(i).momentum_array wfs.(i).momentum; pp_newline eval () done; fprintf eval " @[<2>%s =" wfs.(0).momentum_array; for i = 1 to n - 1 do fprintf eval "@ - %s" wfs.(i).momentum_array done; fprintf decl "@]"; pp_newline decl (); fprintf eval "@]"; pp_newline eval () let contractees_of_fusion ~decl ~eval wfs (max_dsv, indices_seen, contractees) fusion = let max_dsv', dirac_strings = dirac_strings_to_fortran ~decl ~eval wfs max_dsv fusion.L.dirac and vectors = List.fold_left (fun acc wf -> match wf.spin, wf.local_array with | Coupling.Tensor_2, None -> { L.atom = V (Printf.sprintf "%s%d%%t" (spin_mnemonic wf.spin) wf.pos); L.indices = [UFOx.Index.pack wf.pos 1; UFOx.Index.pack wf.pos 2] } :: acc | _, None -> acc | _, Some a -> { L.atom = V a; L.indices = [wf.pos] } :: acc) [] (List.tl (Array.to_list wfs)) and tensors = List.map (L.map_atom (fun t -> T t)) fusion.L.vector and scalars = List.map (fun t -> { L.atom = S t; L.indices = [] }) fusion.L.scalar and inverses = List.map (fun t -> { L.atom = Inv t; L.indices = [] }) fusion.L.inverse in let contractees' = dirac_strings @ vectors @ tensors @ scalars @ inverses in let indices_seen' = Sets.Int.of_list (indices_of_contractions contractees') in (max_dsv', Sets.Int.union indices_seen indices_seen', (fusion, contractees') :: contractees) let local_name wf = match wf.local_array with | Some a -> a | None -> match wf.spin with | Coupling.Spinor | Coupling.ConjSpinor | Coupling.Majorana -> wf.name ^ "%a" | Coupling.Scalar -> wf.name | Coupling.Tensor_2 -> wf.name ^ "%t" | Coupling.Vector | Coupling.Massive_Vector -> failwith "UFO_targets.Fortran.local_name: unexpected spin 1" | _ -> failwith "UFO_targets.Fortran.local_name: unhandled spin" let pseudo_wfs_for_denominator = Array.init 2 (fun i -> let ii = string_of_int i in { pos = i; spin = Coupling.Scalar; name = "den"; local_array = None; momentum = "k" ^ ii; momentum_array = "p" ^ ii; fortran_type = fortran_type Coupling.Scalar }) let fusions_to_fortran ~decl ~eval wfs ?(denominator=[]) ?coupling fusions = local_vector_copies ~decl ~eval wfs; local_momentum_copies ~decl ~eval wfs; let max_dsv, indices_used, contractions = List.fold_left (contractees_of_fusion ~decl ~eval wfs) (0, Sets.Int.empty, []) fusions in let _, indices_used, denominator_contractions = List.fold_left (contractees_of_fusion ~decl ~eval pseudo_wfs_for_denominator) (max_dsv, indices_used, []) denominator in Sets.Int.iter (fun index -> fprintf decl " @[<2>integer ::@ %s@]" (index_variable index); pp_newline decl ()) indices_used; begin match wfs.(0).spin with | Coupling.Spinor | Coupling.ConjSpinor | Coupling.Majorana -> fprintf decl " @[<2>integer ::@ %s@]" index_spinor; pp_newline decl () | _ -> () end; pp_divide ~indent:4 eval (); let wfs0name = local_name wfs.(0) in fprintf eval " %s = 0" wfs0name; pp_newline eval (); List.iter (external_wf_loop ~decl ~eval ~indent:4 wfs) contractions; multiply_coupling_and_scalars eval coupling wfs; begin match denominator_contractions with | [] -> () | contractions -> fprintf decl " @[<2>complex(kind=default) :: den@]"; pp_newline decl (); pp_divide ~indent:4 eval (); fprintf eval " @[<2>den = 0@]"; pp_newline eval (); List.iter (external_wf_loop ~decl ~eval ~indent:4 pseudo_wfs_for_denominator) contractions; pp_divide ~indent:4 eval (); fprintf eval " @[<2>%s =@ %s / den@]" wfs0name wfs0name; pp_newline eval () end; return_vector eval wfs (* TODO: eventually, we should include the momentum among the arguments only if required. But this can wait for another day. *) let lorentz ff name spins lorentz = let printf fmt = fprintf ff fmt and nl = pp_newline ff in let wfs = wf_table spins in let n = Array.length wfs in printf " @[<4>pure function %s@ (g,@ " name; for i = 1 to n - 2 do printf "%s,@ %s,@ " wfs.(i).name wfs.(i).momentum done; printf "%s,@ %s" wfs.(n - 1).name wfs.(n - 1).momentum; printf ")@ result (%s)@]" wfs.(0).name; nl (); printf " @[<2>%s ::@ %s@]" wfs.(0).fortran_type wfs.(0).name; nl(); printf " @[<2>complex(kind=default),@ intent(in) ::@ g@]"; nl(); for i = 1 to n - 1 do printf " @[<2>%s, intent(in) :: %s@]" wfs.(i).fortran_type wfs.(i).name; nl(); done; printf " @[<2>type(momentum), intent(in) ::@ %s" wfs.(1).momentum; for i = 2 to n - 1 do printf ",@ %s" wfs.(i).momentum done; printf "@]"; nl (); let width = 80 in (* get this from the default formatter instead! *) let decl_buf = Buffer.create 1024 and eval_buf = Buffer.create 1024 in let decl = formatter_of_buffer ~width decl_buf and eval = formatter_of_buffer ~width eval_buf in fusions_to_fortran ~decl ~eval ~coupling:"g" wfs lorentz; pp_flush decl (); pp_flush eval (); pp_divide ~indent:4 ff (); (*i printf " ! %s" (L.to_string lorentz); nl (); pp_divide ~indent:4 ff (); i*) printf "%s" (Buffer.contents decl_buf); pp_divide ~indent:4 ff (); + printf " if (g == 0) then"; nl (); + printf " call set_zero (%s)" wfs.(0).name; nl (); + printf " return"; nl (); + printf " end if"; nl (); + pp_divide ~indent:4 ff (); printf "%s" (Buffer.contents eval_buf); printf " end function %s@]" name; nl (); Buffer.reset decl_buf; Buffer.reset eval_buf; () let propagator ff name (bra_spin, ket_spin) numerator denominator = let printf fmt = fprintf ff fmt and nl = pp_newline ff in let width = 80 in (* get this from the default formatter instead! *) let wf_name = spin_mnemonic ket_spin and wf_type = fortran_type ket_spin in let wfs = wf_table [| ket_spin; ket_spin |] in printf " @[<4>pure function pr_U_%s@ (k2, m, w, %s2)" name wf_name; printf " result (%s1)@]" wf_name; nl (); printf " %s :: %s1" wf_type wf_name; nl (); printf " type(momentum), intent(in) :: k2"; nl (); printf " real(kind=default), intent(in) :: m, w"; nl (); printf " %s, intent(in) :: %s2" wf_type wf_name; nl (); let decl_buf = Buffer.create 1024 and eval_buf = Buffer.create 1024 in let decl = formatter_of_buffer ~width decl_buf and eval = formatter_of_buffer ~width eval_buf in fusions_to_fortran ~decl ~eval wfs ~denominator numerator; pp_flush decl (); pp_flush eval (); pp_divide ~indent:4 ff (); printf "%s" (Buffer.contents decl_buf); pp_divide ~indent:4 ff (); printf "%s" (Buffer.contents eval_buf); printf " end function pr_U_%s@]" name; nl (); Buffer.reset decl_buf; Buffer.reset eval_buf; () let scale_coupling c g = if c = 1 then g else if c = -1 then "-" ^ g else Printf.sprintf "%d*%s" c g let scale_coupling z g = format_complex_rational_factor z ^ g (* As a prototypical example consider the vertex \begin{equation} \bar\psi\fmslash{A}\psi = \tr\left(\psi\otimes\bar\psi\fmslash{A}\right) \end{equation} encoded as \texttt{FFV} in the SM UFO file. This example is useful, because all three fields have different type and we can use the Fortran compiler to check our implementation. In this case we need to generate the following function calls with the arguments in the following order \begin{center} \begin{tabular}{lcl} \texttt{F12}:&$\psi_1\bar\psi_2\to A$& \texttt{FFV\_p201(g,psi1,p1,psibar2,p2)} \\ \texttt{F21}:&$\bar\psi_1\psi_2\to A$& \texttt{FFV\_p201(g,psi2,p2,psibar1,p1)} \\ \texttt{F23}:&$\bar\psi_1 A_2 \to \bar\psi$& \texttt{FFV\_p012(g,psibar1,p1,A2,p2)} \\ \texttt{F32}:&$A_1\bar\psi_2 \to \bar\psi$& \texttt{FFV\_p012(g,psibar2,p2,A1,p1)} \\ \texttt{F31}:&$A_1\psi_2\to \psi$& \texttt{FFV\_p120(g,A1,p1,psi2,p2)} \\ \texttt{F13}:&$\psi_1A_2\to \psi$& \texttt{FFV\_p120(g,A2,p2,psi1,p1)} \end{tabular} \end{center} *) (* Fortunately, all Fermi signs have been taken care of by [Fusions] and we can concentrate on injecting the wave functions into the correct slots. *) (* \begin{dubious} Eventually, we should use the reverted lists everywhere to become a bit more efficient. \end{dubious} *) module P = Permutation.Default let factor_cyclic f12__n = let f12__, fn = ThoList.split_last f12__n in let cyclic = ThoList.cycle_until fn (List.sort compare f12__n) in (P.of_list (List.map pred cyclic), P.of_lists (List.tl cyclic) f12__) let ccs_to_string ccs = String.concat "" (List.map (fun (f, i) -> Printf.sprintf "_c%x%x" i f) ccs) let fusion_name v perm ccs = Printf.sprintf "%s_p%s%s" v (P.to_string perm) (ccs_to_string ccs) let fuse_dirac c v s fl g wfs ps fusion = let g = scale_coupling c g and cyclic, factor = factor_cyclic fusion in let wfs_ps = List.map2 (fun wf p -> (wf, p)) wfs ps in let args = P.list (P.inverse factor) wfs_ps in let args_string = String.concat "," (List.map (fun (wf, p) -> wf ^ "," ^ p) args) in printf "%s(%s,%s)" (fusion_name v cyclic []) g args_string (* We need to look at the permuted fermion lines in order to decide wether to apply charge conjugations. *) (* It is not enough to look at the cyclic permutation used to move the fields into the correct arguments of the fusions \ldots *) let map_indices perm unit = let pmap = IntPM.of_lists unit (P.list perm unit) in IntPM.apply pmap (* \ldots{} we also need to inspect the full permutation of the fields. *) let map_indices2 perm unit = let pmap = IntPM.of_lists unit (1 :: P.list (P.inverse perm) (List.tl unit)) in IntPM.apply pmap (* This is a more direct implementation of the composition of [map_indices2] and [map_indices], that is used in the unit tests. *) let map_indices_raw fusion = let unit = ThoList.range 1 (List.length fusion) in let f12__, fn = ThoList.split_last fusion in let fusion = fn :: f12__ in let map_index = IntPM.of_lists fusion unit in IntPM.apply map_index (* Map the fermion line indices in [fl] according to [map_index]. *) let map_fermion_lines map_index fl = List.map (fun (i, f) -> (map_index i, map_index f)) fl (* Map the fermion line indices in [fl] according to [map_index], but keep a copy of the original. *) let map_fermion_lines2 map_index fl = List.map (fun (i, f) -> ((i, f), (map_index i, map_index f))) fl let permute_fermion_lines cyclic unit fl = map_fermion_lines (map_indices cyclic unit) fl let permute_fermion_lines2 cyclic factor unit fl = map_fermion_lines2 (map_indices2 factor unit) (map_fermion_lines (map_indices cyclic unit) fl) (* \begin{dubious} TODO: this needs more more work for the fully general case. \end{dubious} *) let charge_conjugations fl2 = ThoList.filtermap (fun ((i, f), (i', f')) -> match (i, f), (i', f') with | (1, 2), _ | (2, 1), _ -> Some (f, i) (* $\chi^T\Gamma'$ *) | _, (2, 3) -> Some (f, i) (* $\chi^T(C\Gamma')\chi$ *) | _ -> None) fl2 (*i let fuse_majorana c v s fl g wfs ps fusion = let g = scale_coupling c g and cyclic, factor = factor_cyclic fusion in let wfs_ps = List.map2 (fun wf p -> (wf, p)) wfs ps in let wfs_ps_string = String.concat "," (List.map (fun (wf, p) -> wf ^ "," ^ p) wfs_ps) in let args = P.list (P.inverse factor) wfs_ps in let args_string = String.concat "," (List.map (fun (wf, p) -> wf ^ "," ^ p) args) in let f12__, fn = ThoList.split_last fusion in Printf.eprintf "fusion : %d < %s\n" fn (ThoList.to_string string_of_int f12__); Printf.eprintf "cyclic : %s\n" (P.to_string cyclic); Printf.eprintf "factor : %s\n" (P.to_string factor); let unit = ThoList.range 1 (List.length fusion) in Printf.eprintf "permutation : %s -> %s\n" (ThoList.to_string string_of_int unit) (ThoList.to_string string_of_int (List.map (map_indices cyclic unit) unit)); Printf.eprintf "permutation raw : %s -> %s\n" (ThoList.to_string string_of_int unit) (ThoList.to_string string_of_int (List.map (map_indices_raw fusion) unit)); Printf.eprintf "fermion lines : %s\n" (ThoList.to_string (fun (i, f) -> Printf.sprintf "%d>%d" i f) fl); let fl2 = permute_fermion_lines2 cyclic factor unit fl in let fl = permute_fermion_lines cyclic unit fl in Printf.eprintf "permuted : %s\n" (ThoList.to_string (fun (i, f) -> Printf.sprintf "%d>%d" i f) fl); Printf.eprintf "arguments : %s\n" wfs_ps_string; Printf.eprintf "permuted : %s\n" args_string; Printf.eprintf ">> %s(%s,%s)\n" (fusion_name v cyclic (charge_conjugations fl2)) g args_string; printf "%s(%s,%s)" (fusion_name v cyclic (charge_conjugations fl2)) g args_string i*) let fuse_majorana c v s fl g wfs ps fusion = let g = scale_coupling c g and cyclic, factor = factor_cyclic fusion in let wfs_ps = List.map2 (fun wf p -> (wf, p)) wfs ps in let args = P.list (P.inverse factor) wfs_ps in let args_string = String.concat "," (List.map (fun (wf, p) -> wf ^ "," ^ p) args) in let unit = ThoList.range 1 (List.length fusion) in let ccs = charge_conjugations (permute_fermion_lines2 cyclic factor unit fl) in printf "%s(%s,%s)" (fusion_name v cyclic ccs) g args_string let fuse c v s fl g wfs ps fusion = if List.exists is_majorana s then fuse_majorana c v s fl g wfs ps fusion else fuse_dirac c v s fl g wfs ps fusion let eps4_g4_g44_decl ff () = let printf fmt = fprintf ff fmt and nl = pp_newline ff in printf " @[<2>integer,@ dimension(0:3)"; printf ",@ save,@ private ::@ g4_@]"; nl (); printf " @[<2>integer,@ dimension(0:3,0:3)"; printf ",@ save,@ private ::@ g44_@]"; nl (); printf " @[<2>integer,@ dimension(0:3,0:3,0:3,0:3)"; printf ",@ save,@ private ::@ eps4_@]"; nl () let eps4_g4_g44_init ff () = let printf fmt = fprintf ff fmt and nl = pp_newline ff in printf " @[<2>data g4_@ /@ 1, -1, -1, -1 /@]"; nl (); printf " @[<2>data g44_(0,:)@ /@ 1, 0, 0, 0 /@]"; nl (); printf " @[<2>data g44_(1,:)@ /@ 0, -1, 0, 0 /@]"; nl (); printf " @[<2>data g44_(2,:)@ /@ 0, 0, -1, 0 /@]"; nl (); printf " @[<2>data g44_(3,:)@ /@ 0, 0, 0, -1 /@]"; nl (); for mu1 = 0 to 3 do for mu2 = 0 to 3 do for mu3 = 0 to 3 do printf " @[<2>data eps4_(%d,%d,%d,:)@ /@ " mu1 mu2 mu3; for mu4 = 0 to 3 do if mu4 <> 0 then printf ",@ "; let mus = [mu1; mu2; mu3; mu4] in if List.sort compare mus = [0; 1; 2; 3] then printf "%2d" (Combinatorics.sign mus) else printf "%2d" 0; done; printf " /@]"; nl () done done done module type Test = sig val suite : OUnit.test end module Test : Test = struct open OUnit let assert_mappings fusion = let unit = ThoList.range 1 (List.length fusion) in let cyclic, factor = factor_cyclic fusion in let raw = map_indices_raw fusion and map1 = map_indices cyclic unit and map2 = map_indices2 factor unit in let map i = map2 (map1 i) in assert_equal ~printer:(ThoList.to_string string_of_int) (List.map raw unit) (List.map map unit) let suite_mappings = "mappings" >::: [ "1<-2" >:: (fun () -> List.iter assert_mappings (Combinatorics.permute [1;2;3])); "1<-3" >:: (fun () -> List.iter assert_mappings (Combinatorics.permute [1;2;3;4])) ] let suite = "UFO_targets" >::: [suite_mappings] end end Index: trunk/omega/src/omegalib.nw =================================================================== --- trunk/omega/src/omegalib.nw (revision 8475) +++ trunk/omega/src/omegalib.nw (revision 8476) @@ -1,14120 +1,14215 @@ % -*- ess-noweb-default-code-mode: f90-mode; noweb-default-code-mode: f90-mode; -*- % omegalib.nw -- % % Copyright (C) 1999-2020 by % Wolfgang Kilian % Thorsten Ohl % Juergen Reuter % with contributions from % Fabian Bach % Bijan Chokoufe Nejad % 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. % %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% @ \section{Trivia} <<[[omega_spinors.f90]]>>= <> module omega_spinors use kinds use constants implicit none private public :: operator (*), operator (+), operator (-) - public :: abs + public :: abs, set_zero <<[[intrinsic :: abs]]>> type, public :: conjspinor ! private (omegalib needs access, but DON'T TOUCH IT!) complex(kind=default), dimension(4) :: a end type conjspinor type, public :: spinor ! private (omegalib needs access, but DON'T TOUCH IT!) complex(kind=default), dimension(4) :: a end type spinor <> integer, parameter, public :: omega_spinors_2010_01_A = 0 contains <> end module omega_spinors @ <<[[intrinsic :: abs]] (if working)>>= intrinsic :: abs @ <<[[intrinsic :: conjg]] (if working)>>= intrinsic :: conjg @ well, the Intel Fortran Compiler chokes on these with an internal error: <<[[intrinsic :: abs]]>>= @ <<[[intrinsic :: conjg]]>>= @ To reenable the pure functions that have been removed for OpenMP, one should set this chunk to [[pure &]] <<[[pure]] unless OpenMP>>= @ \subsection{Inner Product} <>= interface operator (*) module procedure conjspinor_spinor end interface private :: conjspinor_spinor @ \begin{equation} \bar\psi\psi' \end{equation} NB: [[dot_product]] conjugates its first argument, we can either cancel this or inline [[dot_product]]: <>= pure function conjspinor_spinor (psibar, psi) result (psibarpsi) complex(kind=default) :: psibarpsi type(conjspinor), intent(in) :: psibar type(spinor), intent(in) :: psi psibarpsi = psibar%a(1)*psi%a(1) + psibar%a(2)*psi%a(2) & + psibar%a(3)*psi%a(3) + psibar%a(4)*psi%a(4) end function conjspinor_spinor @ \subsection{Spinor Vector Space} +<>= +interface set_zero + module procedure set_zero_spinor, set_zero_conjspinor +end interface +private :: set_zero_spinor, set_zero_conjspinor +@ +<>= +elemental subroutine set_zero_spinor (x) + type(spinor), intent(out) :: x + x%a = 0 +end subroutine set_zero_spinor +@ +<>= +elemental subroutine set_zero_conjspinor (x) + type(conjspinor), intent(out) :: x + x%a = 0 +end subroutine set_zero_conjspinor +@ \subsubsection{Scalar Multiplication} <>= interface operator (*) module procedure integer_spinor, spinor_integer, & real_spinor, double_spinor, & complex_spinor, dcomplex_spinor, & spinor_real, spinor_double, & spinor_complex, spinor_dcomplex end interface private :: integer_spinor, spinor_integer, real_spinor, & double_spinor, complex_spinor, dcomplex_spinor, & spinor_real, spinor_double, spinor_complex, spinor_dcomplex @ <>= pure function integer_spinor (x, y) result (xy) integer, intent(in) :: x type(spinor), intent(in) :: y type(spinor) :: xy xy%a = x * y%a end function integer_spinor @ <>= pure function real_spinor (x, y) result (xy) real(kind=single), intent(in) :: x type(spinor), intent(in) :: y type(spinor) :: xy xy%a = x * y%a end function real_spinor pure function double_spinor (x, y) result (xy) real(kind=default), intent(in) :: x type(spinor), intent(in) :: y type(spinor) :: xy xy%a = x * y%a end function double_spinor pure function complex_spinor (x, y) result (xy) complex(kind=single), intent(in) :: x type(spinor), intent(in) :: y type(spinor) :: xy xy%a = x * y%a end function complex_spinor pure function dcomplex_spinor (x, y) result (xy) complex(kind=default), intent(in) :: x type(spinor), intent(in) :: y type(spinor) :: xy xy%a = x * y%a end function dcomplex_spinor pure function spinor_integer (y, x) result (xy) integer, intent(in) :: x type(spinor), intent(in) :: y type(spinor) :: xy xy%a = x * y%a end function spinor_integer pure function spinor_real (y, x) result (xy) real(kind=single), intent(in) :: x type(spinor), intent(in) :: y type(spinor) :: xy xy%a = x * y%a end function spinor_real pure function spinor_double (y, x) result (xy) real(kind=default), intent(in) :: x type(spinor), intent(in) :: y type(spinor) :: xy xy%a = x * y%a end function spinor_double pure function spinor_complex (y, x) result (xy) complex(kind=single), intent(in) :: x type(spinor), intent(in) :: y type(spinor) :: xy xy%a = x * y%a end function spinor_complex pure function spinor_dcomplex (y, x) result (xy) complex(kind=default), intent(in) :: x type(spinor), intent(in) :: y type(spinor) :: xy xy%a = x * y%a end function spinor_dcomplex @ <>= interface operator (*) module procedure integer_conjspinor, conjspinor_integer, & real_conjspinor, double_conjspinor, & complex_conjspinor, dcomplex_conjspinor, & conjspinor_real, conjspinor_double, & conjspinor_complex, conjspinor_dcomplex end interface private :: integer_conjspinor, conjspinor_integer, real_conjspinor, & double_conjspinor, complex_conjspinor, dcomplex_conjspinor, & conjspinor_real, conjspinor_double, conjspinor_complex, & conjspinor_dcomplex @ <>= pure function integer_conjspinor (x, y) result (xy) integer, intent(in) :: x type(conjspinor), intent(in) :: y type(conjspinor) :: xy xy%a = x * y%a end function integer_conjspinor pure function real_conjspinor (x, y) result (xy) real(kind=single), intent(in) :: x type(conjspinor), intent(in) :: y type(conjspinor) :: xy xy%a = x * y%a end function real_conjspinor pure function double_conjspinor (x, y) result (xy) real(kind=default), intent(in) :: x type(conjspinor), intent(in) :: y type(conjspinor) :: xy xy%a = x * y%a end function double_conjspinor pure function complex_conjspinor (x, y) result (xy) complex(kind=single), intent(in) :: x type(conjspinor), intent(in) :: y type(conjspinor) :: xy xy%a = x * y%a end function complex_conjspinor pure function dcomplex_conjspinor (x, y) result (xy) complex(kind=default), intent(in) :: x type(conjspinor), intent(in) :: y type(conjspinor) :: xy xy%a = x * y%a end function dcomplex_conjspinor pure function conjspinor_integer (y, x) result (xy) integer, intent(in) :: x type(conjspinor), intent(in) :: y type(conjspinor) :: xy xy%a = x * y%a end function conjspinor_integer pure function conjspinor_real (y, x) result (xy) real(kind=single), intent(in) :: x type(conjspinor), intent(in) :: y type(conjspinor) :: xy xy%a = x * y%a end function conjspinor_real pure function conjspinor_double (y, x) result (xy) real(kind=default), intent(in) :: x type(conjspinor), intent(in) :: y type(conjspinor) :: xy xy%a = x * y%a end function conjspinor_double pure function conjspinor_complex (y, x) result (xy) complex(kind=single), intent(in) :: x type(conjspinor), intent(in) :: y type(conjspinor) :: xy xy%a = x * y%a end function conjspinor_complex pure function conjspinor_dcomplex (y, x) result (xy) complex(kind=default), intent(in) :: x type(conjspinor), intent(in) :: y type(conjspinor) :: xy xy%a = x * y%a end function conjspinor_dcomplex @ \subsubsection{Unary Plus and Minus} <>= interface operator (+) module procedure plus_spinor, plus_conjspinor end interface private :: plus_spinor, plus_conjspinor interface operator (-) module procedure neg_spinor, neg_conjspinor end interface private :: neg_spinor, neg_conjspinor @ <>= pure function plus_spinor (x) result (plus_x) type(spinor), intent(in) :: x type(spinor) :: plus_x plus_x%a = x%a end function plus_spinor pure function neg_spinor (x) result (neg_x) type(spinor), intent(in) :: x type(spinor) :: neg_x neg_x%a = - x%a end function neg_spinor @ <>= pure function plus_conjspinor (x) result (plus_x) type(conjspinor), intent(in) :: x type(conjspinor) :: plus_x plus_x%a = x%a end function plus_conjspinor pure function neg_conjspinor (x) result (neg_x) type(conjspinor), intent(in) :: x type(conjspinor) :: neg_x neg_x%a = - x%a end function neg_conjspinor @ \subsubsection{Addition and Subtraction} <>= interface operator (+) module procedure add_spinor, add_conjspinor end interface private :: add_spinor, add_conjspinor interface operator (-) module procedure sub_spinor, sub_conjspinor end interface private :: sub_spinor, sub_conjspinor @ <>= pure function add_spinor (x, y) result (xy) type(spinor), intent(in) :: x, y type(spinor) :: xy xy%a = x%a + y%a end function add_spinor pure function sub_spinor (x, y) result (xy) type(spinor), intent(in) :: x, y type(spinor) :: xy xy%a = x%a - y%a end function sub_spinor @ <>= pure function add_conjspinor (x, y) result (xy) type(conjspinor), intent(in) :: x, y type(conjspinor) :: xy xy%a = x%a + y%a end function add_conjspinor pure function sub_conjspinor (x, y) result (xy) type(conjspinor), intent(in) :: x, y type(conjspinor) :: xy xy%a = x%a - y%a end function sub_conjspinor @ \subsection{Norm} <>= interface abs module procedure abs_spinor, abs_conjspinor end interface private :: abs_spinor, abs_conjspinor @ <>= pure function abs_spinor (psi) result (x) type(spinor), intent(in) :: psi real(kind=default) :: x x = sqrt (real (dot_product (psi%a, psi%a))) end function abs_spinor @ <>= pure function abs_conjspinor (psibar) result (x) real(kind=default) :: x type(conjspinor), intent(in) :: psibar x = sqrt (real (dot_product (psibar%a, psibar%a))) end function abs_conjspinor @ \section{Spinors Revisited} <<[[omega_bispinors.f90]]>>= <> module omega_bispinors use kinds use constants implicit none private public :: operator (*), operator (+), operator (-) - public :: abs + public :: abs, set_zero type, public :: bispinor ! private (omegalib needs access, but DON'T TOUCH IT!) complex(kind=default), dimension(4) :: a end type bispinor <> integer, parameter, public :: omega_bispinors_2010_01_A = 0 contains <> end module omega_bispinors @ <>= interface operator (*) module procedure spinor_product end interface private :: spinor_product @ \begin{equation} \bar\psi\psi' \end{equation} NB: [[dot_product]] conjugates its first argument, we have to cancel this. <>= pure function spinor_product (psil, psir) result (psilpsir) complex(kind=default) :: psilpsir type(bispinor), intent(in) :: psil, psir type(bispinor) :: psidum psidum%a(1) = psir%a(2) psidum%a(2) = - psir%a(1) psidum%a(3) = - psir%a(4) psidum%a(4) = psir%a(3) psilpsir = dot_product (conjg (psil%a), psidum%a) end function spinor_product @ \subsection{Spinor Vector Space} +<>= +interface set_zero + module procedure set_zero_bispinor +end interface +private :: set_zero_bispinor +@ +<>= +elemental subroutine set_zero_bispinor (x) + type(bispinor), intent(out) :: x + x%a = 0 +end subroutine set_zero_bispinor +@ \subsubsection{Scalar Multiplication} <>= interface operator (*) module procedure integer_bispinor, bispinor_integer, & real_bispinor, double_bispinor, & complex_bispinor, dcomplex_bispinor, & bispinor_real, bispinor_double, & bispinor_complex, bispinor_dcomplex end interface private :: integer_bispinor, bispinor_integer, real_bispinor, & double_bispinor, complex_bispinor, dcomplex_bispinor, & bispinor_real, bispinor_double, bispinor_complex, bispinor_dcomplex @ <>= pure function integer_bispinor (x, y) result (xy) type(bispinor) :: xy integer, intent(in) :: x type(bispinor), intent(in) :: y xy%a = x * y%a end function integer_bispinor @ <>= pure function real_bispinor (x, y) result (xy) type(bispinor) :: xy real(kind=single), intent(in) :: x type(bispinor), intent(in) :: y xy%a = x * y%a end function real_bispinor @ <>= pure function double_bispinor (x, y) result (xy) type(bispinor) :: xy real(kind=default), intent(in) :: x type(bispinor), intent(in) :: y xy%a = x * y%a end function double_bispinor @ <>= pure function complex_bispinor (x, y) result (xy) type(bispinor) :: xy complex(kind=single), intent(in) :: x type(bispinor), intent(in) :: y xy%a = x * y%a end function complex_bispinor @ <>= pure function dcomplex_bispinor (x, y) result (xy) type(bispinor) :: xy complex(kind=default), intent(in) :: x type(bispinor), intent(in) :: y xy%a = x * y%a end function dcomplex_bispinor @ <>= pure function bispinor_integer (y, x) result (xy) type(bispinor) :: xy integer, intent(in) :: x type(bispinor), intent(in) :: y xy%a = x * y%a end function bispinor_integer @ <>= pure function bispinor_real (y, x) result (xy) type(bispinor) :: xy real(kind=single), intent(in) :: x type(bispinor), intent(in) :: y xy%a = x * y%a end function bispinor_real @ <>= pure function bispinor_double (y, x) result (xy) type(bispinor) :: xy real(kind=default), intent(in) :: x type(bispinor), intent(in) :: y xy%a = x * y%a end function bispinor_double @ <>= pure function bispinor_complex (y, x) result (xy) type(bispinor) :: xy complex(kind=single), intent(in) :: x type(bispinor), intent(in) :: y xy%a = x * y%a end function bispinor_complex @ <>= pure function bispinor_dcomplex (y, x) result (xy) type(bispinor) :: xy complex(kind=default), intent(in) :: x type(bispinor), intent(in) :: y xy%a = x * y%a end function bispinor_dcomplex @ \subsubsection{Unary Plus and Minus} <>= interface operator (+) module procedure plus_bispinor end interface private :: plus_bispinor interface operator (-) module procedure neg_bispinor end interface private :: neg_bispinor @ <>= pure function plus_bispinor (x) result (plus_x) type(bispinor) :: plus_x type(bispinor), intent(in) :: x plus_x%a = x%a end function plus_bispinor @ <>= pure function neg_bispinor (x) result (neg_x) type(bispinor) :: neg_x type(bispinor), intent(in) :: x neg_x%a = - x%a end function neg_bispinor @ \subsubsection{Addition and Subtraction} <>= interface operator (+) module procedure add_bispinor end interface private :: add_bispinor interface operator (-) module procedure sub_bispinor end interface private :: sub_bispinor @ <>= pure function add_bispinor (x, y) result (xy) type(bispinor) :: xy type(bispinor), intent(in) :: x, y xy%a = x%a + y%a end function add_bispinor @ <>= pure function sub_bispinor (x, y) result (xy) type(bispinor) :: xy type(bispinor), intent(in) :: x, y xy%a = x%a - y%a end function sub_bispinor @ \subsection{Norm} <>= interface abs module procedure abs_bispinor end interface private :: abs_bispinor @ <>= pure function abs_bispinor (psi) result (x) real(kind=default) :: x type(bispinor), intent(in) :: psi x = sqrt (real (dot_product (psi%a, psi%a))) end function abs_bispinor @ \section{Vectorspinors} <<[[omega_vectorspinors.f90]]>>= <> module omega_vectorspinors use kinds use constants use omega_bispinors use omega_vectors implicit none private public :: operator (*), operator (+), operator (-) - public :: abs + public :: abs, set_zero type, public :: vectorspinor ! private (omegalib needs access, but DON'T TOUCH IT!) type(bispinor), dimension(4) :: psi end type vectorspinor <> integer, parameter, public :: omega_vectorspinors_2010_01_A = 0 contains <> end module omega_vectorspinors @ <>= interface operator (*) module procedure vspinor_product end interface private :: vspinor_product @ \begin{equation} \bar\psi^\mu\psi'_\mu \end{equation} <>= pure function vspinor_product (psil, psir) result (psilpsir) complex(kind=default) :: psilpsir type(vectorspinor), intent(in) :: psil, psir psilpsir = psil%psi(1) * psir%psi(1) & - psil%psi(2) * psir%psi(2) & - psil%psi(3) * psir%psi(3) & - psil%psi(4) * psir%psi(4) end function vspinor_product @ \subsection{Vectorspinor Vector Space} +<>= +interface set_zero + module procedure set_zero_vectorspinor +end interface +private :: set_zero_vectorspinor +@ +<>= +elemental subroutine set_zero_vectorspinor (x) + type(vectorspinor), intent(out) :: x + call set_zero (x%psi) +end subroutine set_zero_vectorspinor +@ \subsubsection{Scalar Multiplication} <>= interface operator (*) module procedure integer_vectorspinor, vectorspinor_integer, & real_vectorspinor, double_vectorspinor, & complex_vectorspinor, dcomplex_vectorspinor, & vectorspinor_real, vectorspinor_double, & vectorspinor_complex, vectorspinor_dcomplex, & momentum_vectorspinor, vectorspinor_momentum end interface private :: integer_vectorspinor, vectorspinor_integer, real_vectorspinor, & double_vectorspinor, complex_vectorspinor, dcomplex_vectorspinor, & vectorspinor_real, vectorspinor_double, vectorspinor_complex, & vectorspinor_dcomplex @ <>= pure function integer_vectorspinor (x, y) result (xy) type(vectorspinor) :: xy integer, intent(in) :: x type(vectorspinor), intent(in) :: y integer :: k do k = 1,4 xy%psi(k) = x * y%psi(k) end do end function integer_vectorspinor @ <>= pure function real_vectorspinor (x, y) result (xy) type(vectorspinor) :: xy real(kind=single), intent(in) :: x type(vectorspinor), intent(in) :: y integer :: k do k = 1,4 xy%psi(k) = x * y%psi(k) end do end function real_vectorspinor @ <>= pure function double_vectorspinor (x, y) result (xy) type(vectorspinor) :: xy real(kind=default), intent(in) :: x type(vectorspinor), intent(in) :: y integer :: k do k = 1,4 xy%psi(k) = x * y%psi(k) end do end function double_vectorspinor @ <>= pure function complex_vectorspinor (x, y) result (xy) type(vectorspinor) :: xy complex(kind=single), intent(in) :: x type(vectorspinor), intent(in) :: y integer :: k do k = 1,4 xy%psi(k) = x * y%psi(k) end do end function complex_vectorspinor @ <>= pure function dcomplex_vectorspinor (x, y) result (xy) type(vectorspinor) :: xy complex(kind=default), intent(in) :: x type(vectorspinor), intent(in) :: y integer :: k do k = 1,4 xy%psi(k) = x * y%psi(k) end do end function dcomplex_vectorspinor @ <>= pure function vectorspinor_integer (y, x) result (xy) type(vectorspinor) :: xy integer, intent(in) :: x type(vectorspinor), intent(in) :: y integer :: k do k = 1,4 xy%psi(k) = y%psi(k) * x end do end function vectorspinor_integer @ <>= pure function vectorspinor_real (y, x) result (xy) type(vectorspinor) :: xy real(kind=single), intent(in) :: x type(vectorspinor), intent(in) :: y integer :: k do k = 1,4 xy%psi(k) = y%psi(k) * x end do end function vectorspinor_real @ <>= pure function vectorspinor_double (y, x) result (xy) type(vectorspinor) :: xy real(kind=default), intent(in) :: x type(vectorspinor), intent(in) :: y integer :: k do k = 1,4 xy%psi(k) = y%psi(k) * x end do end function vectorspinor_double @ <>= pure function vectorspinor_complex (y, x) result (xy) type(vectorspinor) :: xy complex(kind=single), intent(in) :: x type(vectorspinor), intent(in) :: y integer :: k do k = 1,4 xy%psi(k) = y%psi(k) * x end do end function vectorspinor_complex @ <>= pure function vectorspinor_dcomplex (y, x) result (xy) type(vectorspinor) :: xy complex(kind=default), intent(in) :: x type(vectorspinor), intent(in) :: y integer :: k do k = 1,4 xy%psi(k) = y%psi(k) * x end do end function vectorspinor_dcomplex @ <>= pure function momentum_vectorspinor (y, x) result (xy) type(bispinor) :: xy type(momentum), intent(in) :: y type(vectorspinor), intent(in) :: x integer :: k do k = 1,4 xy%a(k) = y%t * x%psi(1)%a(k) - y%x(1) * x%psi(2)%a(k) - & y%x(2) * x%psi(3)%a(k) - y%x(3) * x%psi(4)%a(k) end do end function momentum_vectorspinor @ <>= pure function vectorspinor_momentum (y, x) result (xy) type(bispinor) :: xy type(momentum), intent(in) :: x type(vectorspinor), intent(in) :: y integer :: k do k = 1,4 xy%a(k) = x%t * y%psi(1)%a(k) - x%x(1) * y%psi(2)%a(k) - & x%x(2) * y%psi(3)%a(k) - x%x(3) * y%psi(4)%a(k) end do end function vectorspinor_momentum @ \subsubsection{Unary Plus and Minus} <>= interface operator (+) module procedure plus_vectorspinor end interface private :: plus_vectorspinor interface operator (-) module procedure neg_vectorspinor end interface private :: neg_vectorspinor @ <>= pure function plus_vectorspinor (x) result (plus_x) type(vectorspinor) :: plus_x type(vectorspinor), intent(in) :: x integer :: k do k = 1,4 plus_x%psi(k) = + x%psi(k) end do end function plus_vectorspinor @ <>= pure function neg_vectorspinor (x) result (neg_x) type(vectorspinor) :: neg_x type(vectorspinor), intent(in) :: x integer :: k do k = 1,4 neg_x%psi(k) = - x%psi(k) end do end function neg_vectorspinor @ \subsubsection{Addition and Subtraction} <>= interface operator (+) module procedure add_vectorspinor end interface private :: add_vectorspinor interface operator (-) module procedure sub_vectorspinor end interface private :: sub_vectorspinor @ <>= pure function add_vectorspinor (x, y) result (xy) type(vectorspinor) :: xy type(vectorspinor), intent(in) :: x, y integer :: k do k = 1,4 xy%psi(k) = x%psi(k) + y%psi(k) end do end function add_vectorspinor @ <>= pure function sub_vectorspinor (x, y) result (xy) type(vectorspinor) :: xy type(vectorspinor), intent(in) :: x, y integer :: k do k = 1,4 xy%psi(k) = x%psi(k) - y%psi(k) end do end function sub_vectorspinor @ \subsection{Norm} <>= interface abs module procedure abs_vectorspinor end interface private :: abs_vectorspinor @ <>= pure function abs_vectorspinor (psi) result (x) real(kind=default) :: x type(vectorspinor), intent(in) :: psi x = sqrt (real (dot_product (psi%psi(1)%a, psi%psi(1)%a) & - dot_product (psi%psi(2)%a, psi%psi(2)%a) & - dot_product (psi%psi(3)%a, psi%psi(3)%a) & - dot_product (psi%psi(4)%a, psi%psi(4)%a))) end function abs_vectorspinor @ \section{Vectors and Tensors} Condensed representation of antisymmetric rank-2 tensors: \begin{equation} \begin{pmatrix} T^{00} & T^{01} & T^{02} & T^{03} \\ T^{10} & T^{11} & T^{12} & T^{13} \\ T^{20} & T^{21} & T^{22} & T^{23} \\ T^{30} & T^{31} & T^{32} & T^{33} \end{pmatrix} = \begin{pmatrix} 0 & T_e^1 & T_e^2 & T_e^3 \\ -T_e^1 & 0 & T_b^3 & -T_b^2 \\ -T_e^2 & -T_b^3 & 0 & T_b^1 \\ -T_e^3 & T_b^2 & -T_b^1 & 0 \end{pmatrix} \end{equation} <<[[omega_vectors.f90]]>>= <> module omega_vectors use kinds use constants implicit none private public :: assignment (=), operator(==) public :: operator (*), operator (+), operator (-), operator (.wedge.) - public :: abs, conjg + public :: abs, conjg, set_zero public :: random_momentum <<[[intrinsic :: abs]]>> <<[[intrinsic :: conjg]]>> type, public :: momentum ! private (omegalib needs access, but DON'T TOUCH IT!) real(kind=default) :: t real(kind=default), dimension(3) :: x end type momentum type, public :: vector ! private (omegalib needs access, but DON'T TOUCH IT!) complex(kind=default) :: t complex(kind=default), dimension(3) :: x end type vector type, public :: tensor2odd ! private (omegalib needs access, but DON'T TOUCH IT!) complex(kind=default), dimension(3) :: e complex(kind=default), dimension(3) :: b end type tensor2odd <> integer, parameter, public :: omega_vectors_2010_01_A = 0 contains <> end module omega_vectors @ \subsection{Constructors} <>= interface assignment (=) module procedure momentum_of_array, vector_of_momentum, & vector_of_array, vector_of_double_array, & array_of_momentum, array_of_vector end interface private :: momentum_of_array, vector_of_momentum, vector_of_array, & vector_of_double_array, array_of_momentum, array_of_vector @ <>= pure subroutine momentum_of_array (m, p) type(momentum), intent(out) :: m real(kind=default), dimension(0:), intent(in) :: p m%t = p(0) m%x = p(1:3) end subroutine momentum_of_array pure subroutine array_of_momentum (p, v) real(kind=default), dimension(0:), intent(out) :: p type(momentum), intent(in) :: v p(0) = v%t p(1:3) = v%x end subroutine array_of_momentum @ <>= pure subroutine vector_of_array (v, p) type(vector), intent(out) :: v complex(kind=default), dimension(0:), intent(in) :: p v%t = p(0) v%x = p(1:3) end subroutine vector_of_array pure subroutine vector_of_double_array (v, p) type(vector), intent(out) :: v real(kind=default), dimension(0:), intent(in) :: p v%t = p(0) v%x = p(1:3) end subroutine vector_of_double_array pure subroutine array_of_vector (p, v) complex(kind=default), dimension(0:), intent(out) :: p type(vector), intent(in) :: v p(0) = v%t p(1:3) = v%x end subroutine array_of_vector @ <>= pure subroutine vector_of_momentum (v, p) type(vector), intent(out) :: v type(momentum), intent(in) :: p v%t = p%t v%x = p%x end subroutine vector_of_momentum @ <>= interface operator(==) module procedure momentum_eq end interface @ <>= elemental function momentum_eq (lhs, rhs) result (yorn) logical :: yorn type(momentum), intent(in) :: lhs type(momentum), intent(in) :: rhs yorn = all (abs(lhs%x - rhs%x) < eps0) .and. abs(lhs%t - rhs%t) < eps0 end function momentum_eq @ \subsection{Inner Products} <>= interface operator (*) module procedure momentum_momentum, vector_vector, & vector_momentum, momentum_vector, tensor2odd_tensor2odd end interface private :: momentum_momentum, vector_vector, vector_momentum, & momentum_vector, tensor2odd_tensor2odd @ <>= pure function momentum_momentum (x, y) result (xy) type(momentum), intent(in) :: x type(momentum), intent(in) :: y real(kind=default) :: xy xy = x%t*y%t - x%x(1)*y%x(1) - x%x(2)*y%x(2) - x%x(3)*y%x(3) end function momentum_momentum pure function momentum_vector (x, y) result (xy) type(momentum), intent(in) :: x type(vector), intent(in) :: y complex(kind=default) :: xy xy = x%t*y%t - x%x(1)*y%x(1) - x%x(2)*y%x(2) - x%x(3)*y%x(3) end function momentum_vector pure function vector_momentum (x, y) result (xy) type(vector), intent(in) :: x type(momentum), intent(in) :: y complex(kind=default) :: xy xy = x%t*y%t - x%x(1)*y%x(1) - x%x(2)*y%x(2) - x%x(3)*y%x(3) end function vector_momentum pure function vector_vector (x, y) result (xy) type(vector), intent(in) :: x type(vector), intent(in) :: y complex(kind=default) :: xy xy = x%t*y%t - x%x(1)*y%x(1) - x%x(2)*y%x(2) - x%x(3)*y%x(3) end function vector_vector @ Just like classical electrodynamics: \begin{equation} \frac{1}{2} T_{\mu\nu} U^{\mu\nu} = \frac{1}{2} \left( - T^{0i} U^{0i} - T^{i0} U^{i0} + T^{ij} U^{ij} \right) = T_b^k U_b^k - T_e^k U_e^k \end{equation} <>= pure function tensor2odd_tensor2odd (x, y) result (xy) type(tensor2odd), intent(in) :: x type(tensor2odd), intent(in) :: y complex(kind=default) :: xy xy = x%b(1)*y%b(1) + x%b(2)*y%b(2) + x%b(3)*y%b(3) & - x%e(1)*y%e(1) - x%e(2)*y%e(2) - x%e(3)*y%e(3) end function tensor2odd_tensor2odd @ \subsection{Not Entirely Inner Products} <>= interface operator (*) module procedure momentum_tensor2odd, tensor2odd_momentum, & vector_tensor2odd, tensor2odd_vector end interface private :: momentum_tensor2odd, tensor2odd_momentum, vector_tensor2odd, & tensor2odd_vector @ \begin{subequations} \begin{align} y^\nu = x_\mu T^{\mu\nu}: & y^0 = - x^i T^{i0} = x^i T^{0i} \\ & y^1 = x^0 T^{01} - x^2 T^{21} - x^3 T^{31} \\ & y^2 = x^0 T^{02} - x^1 T^{12} - x^3 T^{32} \\ & y^3 = x^0 T^{03} - x^1 T^{13} - x^2 T^{23} \end{align} \end{subequations} <>= pure function vector_tensor2odd (x, t2) result (xt2) type(vector), intent(in) :: x type(tensor2odd), intent(in) :: t2 type(vector) :: xt2 xt2%t = x%x(1)*t2%e(1) + x%x(2)*t2%e(2) + x%x(3)*t2%e(3) xt2%x(1) = x%t*t2%e(1) + x%x(2)*t2%b(3) - x%x(3)*t2%b(2) xt2%x(2) = x%t*t2%e(2) + x%x(3)*t2%b(1) - x%x(1)*t2%b(3) xt2%x(3) = x%t*t2%e(3) + x%x(1)*t2%b(2) - x%x(2)*t2%b(1) end function vector_tensor2odd pure function momentum_tensor2odd (x, t2) result (xt2) type(momentum), intent(in) :: x type(tensor2odd), intent(in) :: t2 type(vector) :: xt2 xt2%t = x%x(1)*t2%e(1) + x%x(2)*t2%e(2) + x%x(3)*t2%e(3) xt2%x(1) = x%t*t2%e(1) + x%x(2)*t2%b(3) - x%x(3)*t2%b(2) xt2%x(2) = x%t*t2%e(2) + x%x(3)*t2%b(1) - x%x(1)*t2%b(3) xt2%x(3) = x%t*t2%e(3) + x%x(1)*t2%b(2) - x%x(2)*t2%b(1) end function momentum_tensor2odd @ \begin{subequations} \begin{align} y^\mu = T^{\mu\nu} x_\nu : & y^0 = - T^{0i} x^i \\ & y^1 = T^{10} x^0 - T^{12} x^2 - T^{13} x^3 \\ & y^2 = T^{20} x^0 - T^{21} x^1 - T^{23} x^3 \\ & y^3 = T^{30} x^0 - T^{31} x^1 - T^{32} x^2 \end{align} \end{subequations} <>= pure function tensor2odd_vector (t2, x) result (t2x) type(tensor2odd), intent(in) :: t2 type(vector), intent(in) :: x type(vector) :: t2x t2x%t = - t2%e(1)*x%x(1) - t2%e(2)*x%x(2) - t2%e(3)*x%x(3) t2x%x(1) = - t2%e(1)*x%t + t2%b(2)*x%x(3) - t2%b(3)*x%x(2) t2x%x(2) = - t2%e(2)*x%t + t2%b(3)*x%x(1) - t2%b(1)*x%x(3) t2x%x(3) = - t2%e(3)*x%t + t2%b(1)*x%x(2) - t2%b(2)*x%x(1) end function tensor2odd_vector pure function tensor2odd_momentum (t2, x) result (t2x) type(tensor2odd), intent(in) :: t2 type(momentum), intent(in) :: x type(vector) :: t2x t2x%t = - t2%e(1)*x%x(1) - t2%e(2)*x%x(2) - t2%e(3)*x%x(3) t2x%x(1) = - t2%e(1)*x%t + t2%b(2)*x%x(3) - t2%b(3)*x%x(2) t2x%x(2) = - t2%e(2)*x%t + t2%b(3)*x%x(1) - t2%b(1)*x%x(3) t2x%x(3) = - t2%e(3)*x%t + t2%b(1)*x%x(2) - t2%b(2)*x%x(1) end function tensor2odd_momentum @ \subsection{Outer Products} <>= interface operator (.wedge.) module procedure momentum_wedge_momentum, & momentum_wedge_vector, vector_wedge_momentum, vector_wedge_vector end interface private :: momentum_wedge_momentum, momentum_wedge_vector, & vector_wedge_momentum, vector_wedge_vector @ <>= pure function momentum_wedge_momentum (x, y) result (t2) type(momentum), intent(in) :: x type(momentum), intent(in) :: y type(tensor2odd) :: t2 t2%e = x%t * y%x - x%x * y%t t2%b(1) = x%x(2) * y%x(3) - x%x(3) * y%x(2) t2%b(2) = x%x(3) * y%x(1) - x%x(1) * y%x(3) t2%b(3) = x%x(1) * y%x(2) - x%x(2) * y%x(1) end function momentum_wedge_momentum pure function momentum_wedge_vector (x, y) result (t2) type(momentum), intent(in) :: x type(vector), intent(in) :: y type(tensor2odd) :: t2 t2%e = x%t * y%x - x%x * y%t t2%b(1) = x%x(2) * y%x(3) - x%x(3) * y%x(2) t2%b(2) = x%x(3) * y%x(1) - x%x(1) * y%x(3) t2%b(3) = x%x(1) * y%x(2) - x%x(2) * y%x(1) end function momentum_wedge_vector pure function vector_wedge_momentum (x, y) result (t2) type(vector), intent(in) :: x type(momentum), intent(in) :: y type(tensor2odd) :: t2 t2%e = x%t * y%x - x%x * y%t t2%b(1) = x%x(2) * y%x(3) - x%x(3) * y%x(2) t2%b(2) = x%x(3) * y%x(1) - x%x(1) * y%x(3) t2%b(3) = x%x(1) * y%x(2) - x%x(2) * y%x(1) end function vector_wedge_momentum pure function vector_wedge_vector (x, y) result (t2) type(vector), intent(in) :: x type(vector), intent(in) :: y type(tensor2odd) :: t2 t2%e = x%t * y%x - x%x * y%t t2%b(1) = x%x(2) * y%x(3) - x%x(3) * y%x(2) t2%b(2) = x%x(3) * y%x(1) - x%x(1) * y%x(3) t2%b(3) = x%x(1) * y%x(2) - x%x(2) * y%x(1) end function vector_wedge_vector @ \subsection{Vector Space} +<>= +interface set_zero + module procedure set_zero_vector, set_zero_momentum, & + set_zero_tensor2odd, set_zero_real, set_zero_complex +end interface +private :: set_zero_vector, set_zero_momentum, set_zero_tensor2odd +@ +<>= +elemental subroutine set_zero_vector (x) + type(vector), intent(out) :: x + x%t = 0 + x%x = 0 +end subroutine set_zero_vector +@ +<>= +elemental subroutine set_zero_momentum (x) + type(momentum), intent(out) :: x + x%t = 0 + x%x = 0 +end subroutine set_zero_momentum +@ +<>= +elemental subroutine set_zero_tensor2odd (x) + type(tensor2odd), intent(out) :: x + x%e = 0 + x%b = 0 +end subroutine set_zero_tensor2odd +@ +Doesn't really belong here, but there is no better place \ldots +<>= +elemental subroutine set_zero_real (x) + real(kind=default), intent(out) :: x + x = 0 +end subroutine set_zero_real +@ +<>= +elemental subroutine set_zero_complex (x) + complex(kind=default), intent(out) :: x + x = 0 +end subroutine set_zero_complex +@ \subsubsection{Scalar Multiplication} <>= interface operator (*) module procedure integer_momentum, real_momentum, double_momentum, & complex_momentum, dcomplex_momentum, & integer_vector, real_vector, double_vector, & complex_vector, dcomplex_vector, & integer_tensor2odd, real_tensor2odd, double_tensor2odd, & complex_tensor2odd, dcomplex_tensor2odd, & momentum_integer, momentum_real, momentum_double, & momentum_complex, momentum_dcomplex, & vector_integer, vector_real, vector_double, & vector_complex, vector_dcomplex, & tensor2odd_integer, tensor2odd_real, tensor2odd_double, & tensor2odd_complex, tensor2odd_dcomplex end interface private :: integer_momentum, real_momentum, double_momentum, & complex_momentum, dcomplex_momentum, integer_vector, real_vector, & double_vector, complex_vector, dcomplex_vector, & integer_tensor2odd, real_tensor2odd, double_tensor2odd, & complex_tensor2odd, dcomplex_tensor2odd, momentum_integer, & momentum_real, momentum_double, momentum_complex, & momentum_dcomplex, vector_integer, vector_real, vector_double, & vector_complex, vector_dcomplex, tensor2odd_integer, & tensor2odd_real, tensor2odd_double, tensor2odd_complex, & tensor2odd_dcomplex @ <>= pure function integer_momentum (x, y) result (xy) integer, intent(in) :: x type(momentum), intent(in) :: y type(momentum) :: xy xy%t = x * y%t xy%x = x * y%x end function integer_momentum pure function real_momentum (x, y) result (xy) real(kind=single), intent(in) :: x type(momentum), intent(in) :: y type(momentum) :: xy xy%t = x * y%t xy%x = x * y%x end function real_momentum pure function double_momentum (x, y) result (xy) real(kind=default), intent(in) :: x type(momentum), intent(in) :: y type(momentum) :: xy xy%t = x * y%t xy%x = x * y%x end function double_momentum pure function complex_momentum (x, y) result (xy) complex(kind=single), intent(in) :: x type(momentum), intent(in) :: y type(vector) :: xy xy%t = x * y%t xy%x = x * y%x end function complex_momentum pure function dcomplex_momentum (x, y) result (xy) complex(kind=default), intent(in) :: x type(momentum), intent(in) :: y type(vector) :: xy xy%t = x * y%t xy%x = x * y%x end function dcomplex_momentum @ <>= pure function integer_vector (x, y) result (xy) integer, intent(in) :: x type(vector), intent(in) :: y type(vector) :: xy xy%t = x * y%t xy%x = x * y%x end function integer_vector pure function real_vector (x, y) result (xy) real(kind=single), intent(in) :: x type(vector), intent(in) :: y type(vector) :: xy xy%t = x * y%t xy%x = x * y%x end function real_vector pure function double_vector (x, y) result (xy) real(kind=default), intent(in) :: x type(vector), intent(in) :: y type(vector) :: xy xy%t = x * y%t xy%x = x * y%x end function double_vector pure function complex_vector (x, y) result (xy) complex(kind=single), intent(in) :: x type(vector), intent(in) :: y type(vector) :: xy xy%t = x * y%t xy%x = x * y%x end function complex_vector pure function dcomplex_vector (x, y) result (xy) complex(kind=default), intent(in) :: x type(vector), intent(in) :: y type(vector) :: xy xy%t = x * y%t xy%x = x * y%x end function dcomplex_vector @ <>= pure function integer_tensor2odd (x, t2) result (xt2) integer, intent(in) :: x type(tensor2odd), intent(in) :: t2 type(tensor2odd) :: xt2 xt2%e = x * t2%e xt2%b = x * t2%b end function integer_tensor2odd pure function real_tensor2odd (x, t2) result (xt2) real(kind=single), intent(in) :: x type(tensor2odd), intent(in) :: t2 type(tensor2odd) :: xt2 xt2%e = x * t2%e xt2%b = x * t2%b end function real_tensor2odd pure function double_tensor2odd (x, t2) result (xt2) real(kind=default), intent(in) :: x type(tensor2odd), intent(in) :: t2 type(tensor2odd) :: xt2 xt2%e = x * t2%e xt2%b = x * t2%b end function double_tensor2odd pure function complex_tensor2odd (x, t2) result (xt2) complex(kind=single), intent(in) :: x type(tensor2odd), intent(in) :: t2 type(tensor2odd) :: xt2 xt2%e = x * t2%e xt2%b = x * t2%b end function complex_tensor2odd pure function dcomplex_tensor2odd (x, t2) result (xt2) complex(kind=default), intent(in) :: x type(tensor2odd), intent(in) :: t2 type(tensor2odd) :: xt2 xt2%e = x * t2%e xt2%b = x * t2%b end function dcomplex_tensor2odd @ <>= pure function momentum_integer (y, x) result (xy) integer, intent(in) :: x type(momentum), intent(in) :: y type(momentum) :: xy xy%t = x * y%t xy%x = x * y%x end function momentum_integer pure function momentum_real (y, x) result (xy) real(kind=single), intent(in) :: x type(momentum), intent(in) :: y type(momentum) :: xy xy%t = x * y%t xy%x = x * y%x end function momentum_real pure function momentum_double (y, x) result (xy) real(kind=default), intent(in) :: x type(momentum), intent(in) :: y type(momentum) :: xy xy%t = x * y%t xy%x = x * y%x end function momentum_double pure function momentum_complex (y, x) result (xy) complex(kind=single), intent(in) :: x type(momentum), intent(in) :: y type(vector) :: xy xy%t = x * y%t xy%x = x * y%x end function momentum_complex pure function momentum_dcomplex (y, x) result (xy) complex(kind=default), intent(in) :: x type(momentum), intent(in) :: y type(vector) :: xy xy%t = x * y%t xy%x = x * y%x end function momentum_dcomplex @ <>= pure function vector_integer (y, x) result (xy) integer, intent(in) :: x type(vector), intent(in) :: y type(vector) :: xy xy%t = x * y%t xy%x = x * y%x end function vector_integer pure function vector_real (y, x) result (xy) real(kind=single), intent(in) :: x type(vector), intent(in) :: y type(vector) :: xy xy%t = x * y%t xy%x = x * y%x end function vector_real pure function vector_double (y, x) result (xy) real(kind=default), intent(in) :: x type(vector), intent(in) :: y type(vector) :: xy xy%t = x * y%t xy%x = x * y%x end function vector_double pure function vector_complex (y, x) result (xy) complex(kind=single), intent(in) :: x type(vector), intent(in) :: y type(vector) :: xy xy%t = x * y%t xy%x = x * y%x end function vector_complex pure function vector_dcomplex (y, x) result (xy) complex(kind=default), intent(in) :: x type(vector), intent(in) :: y type(vector) :: xy xy%t = x * y%t xy%x = x * y%x end function vector_dcomplex @ <>= pure function tensor2odd_integer (t2, x) result (t2x) type(tensor2odd), intent(in) :: t2 integer, intent(in) :: x type(tensor2odd) :: t2x t2x%e = x * t2%e t2x%b = x * t2%b end function tensor2odd_integer pure function tensor2odd_real (t2, x) result (t2x) type(tensor2odd), intent(in) :: t2 real(kind=single), intent(in) :: x type(tensor2odd) :: t2x t2x%e = x * t2%e t2x%b = x * t2%b end function tensor2odd_real pure function tensor2odd_double (t2, x) result (t2x) type(tensor2odd), intent(in) :: t2 real(kind=default), intent(in) :: x type(tensor2odd) :: t2x t2x%e = x * t2%e t2x%b = x * t2%b end function tensor2odd_double pure function tensor2odd_complex (t2, x) result (t2x) type(tensor2odd), intent(in) :: t2 complex(kind=single), intent(in) :: x type(tensor2odd) :: t2x t2x%e = x * t2%e t2x%b = x * t2%b end function tensor2odd_complex pure function tensor2odd_dcomplex (t2, x) result (t2x) type(tensor2odd), intent(in) :: t2 complex(kind=default), intent(in) :: x type(tensor2odd) :: t2x t2x%e = x * t2%e t2x%b = x * t2%b end function tensor2odd_dcomplex @ \subsubsection{Unary Plus and Minus} <>= interface operator (+) module procedure plus_momentum, plus_vector, plus_tensor2odd end interface private :: plus_momentum, plus_vector, plus_tensor2odd interface operator (-) module procedure neg_momentum, neg_vector, neg_tensor2odd end interface private :: neg_momentum, neg_vector, neg_tensor2odd @ <>= pure function plus_momentum (x) result (plus_x) type(momentum), intent(in) :: x type(momentum) :: plus_x plus_x = x end function plus_momentum pure function neg_momentum (x) result (neg_x) type(momentum), intent(in) :: x type(momentum) :: neg_x neg_x%t = - x%t neg_x%x = - x%x end function neg_momentum @ <>= pure function plus_vector (x) result (plus_x) type(vector), intent(in) :: x type(vector) :: plus_x plus_x = x end function plus_vector pure function neg_vector (x) result (neg_x) type(vector), intent(in) :: x type(vector) :: neg_x neg_x%t = - x%t neg_x%x = - x%x end function neg_vector @ <>= pure function plus_tensor2odd (x) result (plus_x) type(tensor2odd), intent(in) :: x type(tensor2odd) :: plus_x plus_x = x end function plus_tensor2odd pure function neg_tensor2odd (x) result (neg_x) type(tensor2odd), intent(in) :: x type(tensor2odd) :: neg_x neg_x%e = - x%e neg_x%b = - x%b end function neg_tensor2odd @ \subsubsection{Addition and Subtraction} <>= interface operator (+) module procedure add_momentum, add_vector, & add_vector_momentum, add_momentum_vector, add_tensor2odd end interface private :: add_momentum, add_vector, add_vector_momentum, & add_momentum_vector, add_tensor2odd interface operator (-) module procedure sub_momentum, sub_vector, & sub_vector_momentum, sub_momentum_vector, sub_tensor2odd end interface private :: sub_momentum, sub_vector, sub_vector_momentum, & sub_momentum_vector, sub_tensor2odd @ <>= pure function add_momentum (x, y) result (xy) type(momentum), intent(in) :: x, y type(momentum) :: xy xy%t = x%t + y%t xy%x = x%x + y%x end function add_momentum pure function add_vector (x, y) result (xy) type(vector), intent(in) :: x, y type(vector) :: xy xy%t = x%t + y%t xy%x = x%x + y%x end function add_vector pure function add_momentum_vector (x, y) result (xy) type(momentum), intent(in) :: x type(vector), intent(in) :: y type(vector) :: xy xy%t = x%t + y%t xy%x = x%x + y%x end function add_momentum_vector pure function add_vector_momentum (x, y) result (xy) type(vector), intent(in) :: x type(momentum), intent(in) :: y type(vector) :: xy xy%t = x%t + y%t xy%x = x%x + y%x end function add_vector_momentum pure function add_tensor2odd (x, y) result (xy) type(tensor2odd), intent(in) :: x, y type(tensor2odd) :: xy xy%e = x%e + y%e xy%b = x%b + y%b end function add_tensor2odd @ <>= pure function sub_momentum (x, y) result (xy) type(momentum), intent(in) :: x, y type(momentum) :: xy xy%t = x%t - y%t xy%x = x%x - y%x end function sub_momentum pure function sub_vector (x, y) result (xy) type(vector), intent(in) :: x, y type(vector) :: xy xy%t = x%t - y%t xy%x = x%x - y%x end function sub_vector pure function sub_momentum_vector (x, y) result (xy) type(momentum), intent(in) :: x type(vector), intent(in) :: y type(vector) :: xy xy%t = x%t - y%t xy%x = x%x - y%x end function sub_momentum_vector pure function sub_vector_momentum (x, y) result (xy) type(vector), intent(in) :: x type(momentum), intent(in) :: y type(vector) :: xy xy%t = x%t - y%t xy%x = x%x - y%x end function sub_vector_momentum pure function sub_tensor2odd (x, y) result (xy) type(tensor2odd), intent(in) :: x, y type(tensor2odd) :: xy xy%e = x%e - y%e xy%b = x%b - y%b end function sub_tensor2odd @ \subsection{Norm} \emph{Not} the covariant length! <>= interface abs module procedure abs_momentum, abs_vector, abs_tensor2odd end interface private :: abs_momentum, abs_vector, abs_tensor2odd @ <>= pure function abs_momentum (x) result (absx) type(momentum), intent(in) :: x real(kind=default) :: absx absx = sqrt (real (x%t*x%t + dot_product (x%x, x%x))) end function abs_momentum pure function abs_vector (x) result (absx) type(vector), intent(in) :: x real(kind=default) :: absx absx = sqrt (real (conjg(x%t)*x%t + dot_product (x%x, x%x))) end function abs_vector pure function abs_tensor2odd (x) result (absx) type(tensor2odd), intent(in) :: x real(kind=default) :: absx absx = sqrt (real (dot_product (x%e, x%e) + dot_product (x%b, x%b))) end function abs_tensor2odd @ \subsection{Conjugation} <>= interface conjg module procedure conjg_momentum, conjg_vector, conjg_tensor2odd end interface private :: conjg_momentum, conjg_vector, conjg_tensor2odd @ <>= pure function conjg_momentum (x) result (conjg_x) type(momentum), intent(in) :: x type(momentum) :: conjg_x conjg_x = x end function conjg_momentum pure function conjg_vector (x) result (conjg_x) type(vector), intent(in) :: x type(vector) :: conjg_x conjg_x%t = conjg (x%t) conjg_x%x = conjg (x%x) end function conjg_vector pure function conjg_tensor2odd (t2) result (conjg_t2) type(tensor2odd), intent(in) :: t2 type(tensor2odd) :: conjg_t2 conjg_t2%e = conjg (t2%e) conjg_t2%b = conjg (t2%b) end function conjg_tensor2odd @ \subsection{$\epsilon$-Tensors} \begin{equation} \epsilon_{0123} = 1 = - \epsilon^{0123} \end{equation} in particular \begin{equation} \epsilon(p_1,p_2,p_3,p_4) = \epsilon_{\mu_1\mu_2\mu_3\mu_4} p_1^{\mu_1}p_2^{\mu_2}p_3^{\mu_3}p_4^{\mu_4} = p_1^0 p_2^1 p_3^2 p_4^3 \pm \ldots \end{equation} <>= interface pseudo_scalar module procedure pseudo_scalar_momentum, pseudo_scalar_vector, & pseudo_scalar_vec_mom end interface public :: pseudo_scalar private :: pseudo_scalar_momentum, pseudo_scalar_vector @ <>= pure function pseudo_scalar_momentum (p1, p2, p3, p4) result (eps1234) type(momentum), intent(in) :: p1, p2, p3, p4 real(kind=default) :: eps1234 eps1234 = & p1%t * p2%x(1) * (p3%x(2) * p4%x(3) - p3%x(3) * p4%x(2)) & + p1%t * p2%x(2) * (p3%x(3) * p4%x(1) - p3%x(1) * p4%x(3)) & + p1%t * p2%x(3) * (p3%x(1) * p4%x(2) - p3%x(2) * p4%x(1)) & - p1%x(1) * p2%x(2) * (p3%x(3) * p4%t - p3%t * p4%x(3)) & - p1%x(1) * p2%x(3) * (p3%t * p4%x(2) - p3%x(2) * p4%t ) & - p1%x(1) * p2%t * (p3%x(2) * p4%x(3) - p3%x(3) * p4%x(2)) & + p1%x(2) * p2%x(3) * (p3%t * p4%x(1) - p3%x(1) * p4%t ) & + p1%x(2) * p2%t * (p3%x(1) * p4%x(3) - p3%x(3) * p4%x(1)) & + p1%x(2) * p2%x(1) * (p3%x(3) * p4%t - p3%t * p4%x(3)) & - p1%x(3) * p2%t * (p3%x(1) * p4%x(2) - p3%x(2) * p4%x(1)) & - p1%x(3) * p2%x(1) * (p3%x(2) * p4%t - p3%t * p4%x(2)) & - p1%x(3) * p2%x(2) * (p3%t * p4%x(1) - p3%x(1) * p4%t ) end function pseudo_scalar_momentum @ <>= pure function pseudo_scalar_vector (p1, p2, p3, p4) result (eps1234) type(vector), intent(in) :: p1, p2, p3, p4 complex(kind=default) :: eps1234 eps1234 = & p1%t * p2%x(1) * (p3%x(2) * p4%x(3) - p3%x(3) * p4%x(2)) & + p1%t * p2%x(2) * (p3%x(3) * p4%x(1) - p3%x(1) * p4%x(3)) & + p1%t * p2%x(3) * (p3%x(1) * p4%x(2) - p3%x(2) * p4%x(1)) & - p1%x(1) * p2%x(2) * (p3%x(3) * p4%t - p3%t * p4%x(3)) & - p1%x(1) * p2%x(3) * (p3%t * p4%x(2) - p3%x(2) * p4%t ) & - p1%x(1) * p2%t * (p3%x(2) * p4%x(3) - p3%x(3) * p4%x(2)) & + p1%x(2) * p2%x(3) * (p3%t * p4%x(1) - p3%x(1) * p4%t ) & + p1%x(2) * p2%t * (p3%x(1) * p4%x(3) - p3%x(3) * p4%x(1)) & + p1%x(2) * p2%x(1) * (p3%x(3) * p4%t - p3%t * p4%x(3)) & - p1%x(3) * p2%t * (p3%x(1) * p4%x(2) - p3%x(2) * p4%x(1)) & - p1%x(3) * p2%x(1) * (p3%x(2) * p4%t - p3%t * p4%x(2)) & - p1%x(3) * p2%x(2) * (p3%t * p4%x(1) - p3%x(1) * p4%t ) end function pseudo_scalar_vector @ <>= pure function pseudo_scalar_vec_mom (p1, v1, p2, v2) result (eps1234) type(momentum), intent(in) :: p1, p2 type(vector), intent(in) :: v1, v2 complex(kind=default) :: eps1234 eps1234 = & p1%t * v1%x(1) * (p2%x(2) * v2%x(3) - p2%x(3) * v2%x(2)) & + p1%t * v1%x(2) * (p2%x(3) * v2%x(1) - p2%x(1) * v2%x(3)) & + p1%t * v1%x(3) * (p2%x(1) * v2%x(2) - p2%x(2) * v2%x(1)) & - p1%x(1) * v1%x(2) * (p2%x(3) * v2%t - p2%t * v2%x(3)) & - p1%x(1) * v1%x(3) * (p2%t * v2%x(2) - p2%x(2) * v2%t ) & - p1%x(1) * v1%t * (p2%x(2) * v2%x(3) - p2%x(3) * v2%x(2)) & + p1%x(2) * v1%x(3) * (p2%t * v2%x(1) - p2%x(1) * v2%t ) & + p1%x(2) * v1%t * (p2%x(1) * v2%x(3) - p2%x(3) * v2%x(1)) & + p1%x(2) * v1%x(1) * (p2%x(3) * v2%t - p2%t * v2%x(3)) & - p1%x(3) * v1%t * (p2%x(1) * v2%x(2) - p2%x(2) * v2%x(1)) & - p1%x(3) * v1%x(1) * (p2%x(2) * v2%t - p2%t * v2%x(2)) & - p1%x(3) * v1%x(2) * (p2%t * v2%x(1) - p2%x(1) * v2%t ) end function pseudo_scalar_vec_mom @ \begin{equation} \epsilon_\mu(p_1,p_2,p_3) = \epsilon_{\mu\mu_1\mu_2\mu_3} p_1^{\mu_1}p_2^{\mu_2}p_3^{\mu_3} \end{equation} i.\,e. \begin{subequations} \begin{align} \epsilon_0(p_1,p_2,p_3) &= p_1^1 p_2^2 p_3^3 \pm \ldots \\ \epsilon_1(p_1,p_2,p_3) &= p_1^2 p_2^3 p_3^0 \pm \ldots \\ \epsilon_2(p_1,p_2,p_3) &= - p_1^3 p_2^0 p_3^1 \pm \ldots \\ \epsilon_3(p_1,p_2,p_3) &= p_1^0 p_2^1 p_3^2 \pm \ldots \end{align} \end{subequations} <>= interface pseudo_vector module procedure pseudo_vector_momentum, pseudo_vector_vector, & pseudo_vector_vec_mom end interface public :: pseudo_vector private :: pseudo_vector_momentum, pseudo_vector_vector @ <>= pure function pseudo_vector_momentum (p1, p2, p3) result (eps123) type(momentum), intent(in) :: p1, p2, p3 type(momentum) :: eps123 eps123%t = & + p1%x(1) * (p2%x(2) * p3%x(3) - p2%x(3) * p3%x(2)) & + p1%x(2) * (p2%x(3) * p3%x(1) - p2%x(1) * p3%x(3)) & + p1%x(3) * (p2%x(1) * p3%x(2) - p2%x(2) * p3%x(1)) eps123%x(1) = & + p1%x(2) * (p2%x(3) * p3%t - p2%t * p3%x(3)) & + p1%x(3) * (p2%t * p3%x(2) - p2%x(2) * p3%t ) & + p1%t * (p2%x(2) * p3%x(3) - p2%x(3) * p3%x(2)) eps123%x(2) = & - p1%x(3) * (p2%t * p3%x(1) - p2%x(1) * p3%t ) & - p1%t * (p2%x(1) * p3%x(3) - p2%x(3) * p3%x(1)) & - p1%x(1) * (p2%x(3) * p3%t - p2%t * p3%x(3)) eps123%x(3) = & + p1%t * (p2%x(1) * p3%x(2) - p2%x(2) * p3%x(1)) & + p1%x(1) * (p2%x(2) * p3%t - p2%t * p3%x(2)) & + p1%x(2) * (p2%t * p3%x(1) - p2%x(1) * p3%t ) end function pseudo_vector_momentum @ <>= pure function pseudo_vector_vector (p1, p2, p3) result (eps123) type(vector), intent(in) :: p1, p2, p3 type(vector) :: eps123 eps123%t = & + p1%x(1) * (p2%x(2) * p3%x(3) - p2%x(3) * p3%x(2)) & + p1%x(2) * (p2%x(3) * p3%x(1) - p2%x(1) * p3%x(3)) & + p1%x(3) * (p2%x(1) * p3%x(2) - p2%x(2) * p3%x(1)) eps123%x(1) = & + p1%x(2) * (p2%x(3) * p3%t - p2%t * p3%x(3)) & + p1%x(3) * (p2%t * p3%x(2) - p2%x(2) * p3%t ) & + p1%t * (p2%x(2) * p3%x(3) - p2%x(3) * p3%x(2)) eps123%x(2) = & - p1%x(3) * (p2%t * p3%x(1) - p2%x(1) * p3%t ) & - p1%t * (p2%x(1) * p3%x(3) - p2%x(3) * p3%x(1)) & - p1%x(1) * (p2%x(3) * p3%t - p2%t * p3%x(3)) eps123%x(3) = & + p1%t * (p2%x(1) * p3%x(2) - p2%x(2) * p3%x(1)) & + p1%x(1) * (p2%x(2) * p3%t - p2%t * p3%x(2)) & + p1%x(2) * (p2%t * p3%x(1) - p2%x(1) * p3%t ) end function pseudo_vector_vector @ <>= pure function pseudo_vector_vec_mom (p1, p2, v) result (eps123) type(momentum), intent(in) :: p1, p2 type(vector), intent(in) :: v type(vector) :: eps123 eps123%t = & + p1%x(1) * (p2%x(2) * v%x(3) - p2%x(3) * v%x(2)) & + p1%x(2) * (p2%x(3) * v%x(1) - p2%x(1) * v%x(3)) & + p1%x(3) * (p2%x(1) * v%x(2) - p2%x(2) * v%x(1)) eps123%x(1) = & + p1%x(2) * (p2%x(3) * v%t - p2%t * v%x(3)) & + p1%x(3) * (p2%t * v%x(2) - p2%x(2) * v%t ) & + p1%t * (p2%x(2) * v%x(3) - p2%x(3) * v%x(2)) eps123%x(2) = & - p1%x(3) * (p2%t * v%x(1) - p2%x(1) * v%t ) & - p1%t * (p2%x(1) * v%x(3) - p2%x(3) * v%x(1)) & - p1%x(1) * (p2%x(3) * v%t - p2%t * v%x(3)) eps123%x(3) = & + p1%t * (p2%x(1) * v%x(2) - p2%x(2) * v%x(1)) & + p1%x(1) * (p2%x(2) * v%t - p2%t * v%x(2)) & + p1%x(2) * (p2%t * v%x(1) - p2%x(1) * v%t ) end function pseudo_vector_vec_mom @ \subsection{Utilities} <>= @ <>= subroutine random_momentum (p, pabs, m) type(momentum), intent(out) :: p real(kind=default), intent(in) :: pabs, m real(kind=default), dimension(2) :: r real(kind=default) :: phi, cos_th call random_number (r) phi = 2*PI * r(1) cos_th = 2 * r(2) - 1 p%t = sqrt (pabs**2 + m**2) p%x = pabs * (/ cos_th * cos(phi), cos_th * sin(phi), sqrt (1 - cos_th**2) /) end subroutine random_momentum @ \section{Polarization vectors} <<[[omega_polarizations.f90]]>>= <> module omega_polarizations use kinds use constants use omega_vectors implicit none private <> integer, parameter, public :: omega_polarizations_2010_01_A = 0 contains <> end module omega_polarizations @ Here we use a phase convention for the polarization vectors compatible with the angular momentum coupling to spin 3/2 and spin 2. \begin{subequations} \begin{align} \epsilon^\mu_1(k) &= \frac{1}{|\vec k|\sqrt{k_x^2+k_y^2}} \left(0; k_z k_x, k_y k_z, - k_x^2 - k_y^2\right) \\ \epsilon^\mu_2(k) &= \frac{1}{\sqrt{k_x^2+k_y^2}} \left(0; -k_y, k_x, 0\right) \\ \epsilon^\mu_3(k) &= \frac{k_0}{m|\vec k|} \left({\vec k}^2/k_0; k_x, k_y, k_z\right) \end{align} \end{subequations} and \begin{subequations} \begin{align} \epsilon^\mu_\pm(k) &= \frac{1}{\sqrt{2}} (\epsilon^\mu_1(k) \pm \ii\epsilon^\mu_2(k) ) \\ \epsilon^\mu_0(k) &= \epsilon^\mu_3(k) \end{align} \end{subequations} i.\,e. \begin{subequations} \begin{align} \epsilon^\mu_+(k) &= \frac{1}{\sqrt{2}\sqrt{k_x^2+k_y^2}} \left(0; \frac{k_zk_x}{|\vec k|} - \ii k_y, \frac{k_yk_z}{|\vec k|} + \ii k_x, - \frac{k_x^2+k_y^2}{|\vec k|}\right) \\ \epsilon^\mu_-(k) &= \frac{1}{\sqrt{2}\sqrt{k_x^2+k_y^2}} \left(0; \frac{k_zk_x}{|\vec k|} + \ii k_y, \frac{k_yk_z}{|\vec k|} - \ii k_x, -\frac{k_x^2+k_y^2}{|\vec k|}\right) \\ \epsilon^\mu_0(k) &= \frac{k_0}{m|\vec k|} \left({\vec k}^2/k_0; k_x, k_y, k_z\right) \end{align} \end{subequations} Determining the mass from the momenta is a numerically haphazardous for light particles. Therefore, we accept some redundancy and pass the mass explicitely. <>= public :: eps @ <>= pure function eps (m, k, s) result (e) type(vector) :: e real(kind=default), intent(in) :: m type(momentum), intent(in) :: k integer, intent(in) :: s real(kind=default) :: kt, kabs, kabs2, sqrt2 sqrt2 = sqrt (2.0_default) kabs2 = dot_product (k%x, k%x) e%t = 0 e%x = 0 if (kabs2 > 0) then kabs = sqrt (kabs2) select case (s) case (1) kt = sqrt (k%x(1)**2 + k%x(2)**2) if (abs(kt) <= epsilon(kt) * kabs) then if (k%x(3) > 0) then e%x(1) = cmplx ( 1, 0, kind=default) / sqrt2 e%x(2) = cmplx ( 0, 1, kind=default) / sqrt2 else e%x(1) = cmplx ( - 1, 0, kind=default) / sqrt2 e%x(2) = cmplx ( 0, 1, kind=default) / sqrt2 end if else e%x(1) = cmplx ( k%x(3)*k%x(1)/kabs, & - k%x(2), kind=default) / kt / sqrt2 e%x(2) = cmplx ( k%x(2)*k%x(3)/kabs, & k%x(1), kind=default) / kt / sqrt2 e%x(3) = - kt / kabs / sqrt2 end if case (-1) kt = sqrt (k%x(1)**2 + k%x(2)**2) if (abs(kt) <= epsilon(kt) * kabs) then if (k%x(3) > 0) then e%x(1) = cmplx ( 1, 0, kind=default) / sqrt2 e%x(2) = cmplx ( 0, - 1, kind=default) / sqrt2 else e%x(1) = cmplx ( -1, 0, kind=default) / sqrt2 e%x(2) = cmplx ( 0, - 1, kind=default) / sqrt2 end if else e%x(1) = cmplx ( k%x(3)*k%x(1)/kabs, & k%x(2), kind=default) / kt / sqrt2 e%x(2) = cmplx ( k%x(2)*k%x(3)/kabs, & - k%x(1), kind=default) / kt / sqrt2 e%x(3) = - kt / kabs / sqrt2 end if case (0) if (m > 0) then e%t = kabs / m e%x = k%t / (m*kabs) * k%x end if case (3) e = (0,1) * k case (4) if (m > 0) then e = (1 / m) * k else e = (1 / k%t) * k end if end select else !!! for particles in their rest frame defined to be !!! polarized along the 3-direction select case (s) case (1) e%x(1) = cmplx ( 1, 0, kind=default) / sqrt2 e%x(2) = cmplx ( 0, 1, kind=default) / sqrt2 case (-1) e%x(1) = cmplx ( 1, 0, kind=default) / sqrt2 e%x(2) = cmplx ( 0, - 1, kind=default) / sqrt2 case (0) if (m > 0) then e%x(3) = 1 end if case (4) if (m > 0) then e = (1 / m) * k else e = (1 / k%t) * k end if end select end if end function eps @ \section{Polarization vectors revisited} <<[[omega_polarizations_madgraph.f90]]>>= <> module omega_polarizations_madgraph use kinds use constants use omega_vectors implicit none private <> integer, parameter, public :: omega_pols_madgraph_2010_01_A = 0 contains <> end module omega_polarizations_madgraph @ This set of polarization vectors is compatible with HELAS~\cite{HELAS}: \begin{subequations} \begin{align} \epsilon^\mu_1(k) &= \frac{1}{|\vec k|\sqrt{k_x^2+k_y^2}} \left(0; k_z k_x, k_y k_z, - k_x^2 - k_y^2\right) \\ \epsilon^\mu_2(k) &= \frac{1}{\sqrt{k_x^2+k_y^2}} \left(0; -k_y, k_x, 0\right) \\ \epsilon^\mu_3(k) &= \frac{k_0}{m|\vec k|} \left({\vec k}^2/k_0; k_x, k_y, k_z\right) \end{align} \end{subequations} and \begin{subequations} \begin{align} \epsilon^\mu_\pm(k) &= \frac{1}{\sqrt{2}} (\mp \epsilon^\mu_1(k) - \ii\epsilon^\mu_2(k) ) \\ \epsilon^\mu_0(k) &= \epsilon^\mu_3(k) \end{align} \end{subequations} i.\,e. \begin{subequations} \begin{align} \epsilon^\mu_+(k) &= \frac{1}{\sqrt{2}\sqrt{k_x^2+k_y^2}} \left(0; -\frac{k_zk_x}{|\vec k|} + \ii k_y, -\frac{k_yk_z}{|\vec k|} - \ii k_x, \frac{k_x^2+k_y^2}{|\vec k|}\right) \\ \epsilon^\mu_-(k) &= \frac{1}{\sqrt{2}\sqrt{k_x^2+k_y^2}} \left(0; \frac{k_zk_x}{|\vec k|} + \ii k_y, \frac{k_yk_z}{|\vec k|} - \ii k_x, -\frac{k_x^2+k_y^2}{|\vec k|}\right) \\ \epsilon^\mu_0(k) &= \frac{k_0}{m|\vec k|} \left({\vec k}^2/k_0; k_x, k_y, k_z\right) \end{align} \end{subequations} Fortunately, for comparing with squared matrix generated by Madgraph we can also use the modified version, since the difference is only a phase and does \emph{not} mix helicity states. @ Determining the mass from the momenta is a numerically haphazardous for light particles. Therefore, we accept some redundancy and pass the mass explicitely. <>= public :: eps @ <>= pure function eps (m, k, s) result (e) type(vector) :: e real(kind=default), intent(in) :: m type(momentum), intent(in) :: k integer, intent(in) :: s real(kind=default) :: kt, kabs, kabs2, sqrt2 sqrt2 = sqrt (2.0_default) kabs2 = dot_product (k%x, k%x) e%t = 0 e%x = 0 if (kabs2 > 0) then kabs = sqrt (kabs2) select case (s) case (1) kt = sqrt (k%x(1)**2 + k%x(2)**2) if (abs(kt) <= epsilon(kt) * kabs) then if (k%x(3) > 0) then e%x(1) = cmplx ( - 1, 0, kind=default) / sqrt2 e%x(2) = cmplx ( 0, - 1, kind=default) / sqrt2 else e%x(1) = cmplx ( 1, 0, kind=default) / sqrt2 e%x(2) = cmplx ( 0, - 1, kind=default) / sqrt2 end if else e%x(1) = cmplx ( - k%x(3)*k%x(1)/kabs, & k%x(2), kind=default) / kt / sqrt2 e%x(2) = cmplx ( - k%x(2)*k%x(3)/kabs, & - k%x(1), kind=default) / kt / sqrt2 e%x(3) = kt / kabs / sqrt2 end if case (-1) kt = sqrt (k%x(1)**2 + k%x(2)**2) if (abs(kt) <= epsilon(kt) * kabs) then if (k%x(3) > 0) then e%x(1) = cmplx ( 1, 0, kind=default) / sqrt2 e%x(2) = cmplx ( 0, - 1, kind=default) / sqrt2 else e%x(1) = cmplx ( -1, 0, kind=default) / sqrt2 e%x(2) = cmplx ( 0, - 1, kind=default) / sqrt2 end if else e%x(1) = cmplx ( k%x(3)*k%x(1)/kabs, & k%x(2), kind=default) / kt / sqrt2 e%x(2) = cmplx ( k%x(2)*k%x(3)/kabs, & - k%x(1), kind=default) / kt / sqrt2 e%x(3) = - kt / kabs / sqrt2 end if case (0) if (m > 0) then e%t = kabs / m e%x = k%t / (m*kabs) * k%x end if case (3) e = (0,1) * k case (4) if (m > 0) then e = (1 / m) * k else e = (1 / k%t) * k end if end select else !!! for particles in their rest frame defined to be !!! polarized along the 3-direction select case (s) case (1) e%x(1) = cmplx ( - 1, 0, kind=default) / sqrt2 e%x(2) = cmplx ( 0, - 1, kind=default) / sqrt2 case (-1) e%x(1) = cmplx ( 1, 0, kind=default) / sqrt2 e%x(2) = cmplx ( 0, - 1, kind=default) / sqrt2 case (0) if (m > 0) then e%x(3) = 1 end if case (4) if (m > 0) then e = (1 / m) * k else e = (1 / k%t) * k end if end select end if end function eps @ \section{Symmetric Tensors} Spin-2 polarization tensors are symmetric, transversal and traceless \begin{subequations} \begin{align} \epsilon^{\mu\nu}_{m}(k) &= \epsilon^{\nu\mu}_{m}(k) \\ k_\mu \epsilon^{\mu\nu}_{m}(k) &= k_\nu \epsilon^{\mu\nu}_{m}(k) = 0 \\ \epsilon^{\mu}_{m,\mu}(k) &= 0 \end{align} \end{subequations} with $m=1,2,3,4,5$. Our current representation is redundant and does \emph{not} enforce symmetry or tracelessness. <<[[omega_tensors.f90]]>>= <> module omega_tensors use kinds use constants use omega_vectors implicit none private public :: operator (*), operator (+), operator (-), & operator (.tprod.) - public :: abs, conjg + public :: abs, conjg, set_zero <<[[intrinsic :: abs]]>> <<[[intrinsic :: conjg]]>> type, public :: tensor ! private (omegalib needs access, but DON'T TOUCH IT!) complex(kind=default), dimension(0:3,0:3) :: t end type tensor <> integer, parameter, public :: omega_tensors_2010_01_A = 0 contains <> end module omega_tensors @ \subsection{Vector Space} +<>= +interface set_zero + module procedure set_zero_tensor +end interface +private :: set_zero_tensor +@ +<>= +elemental subroutine set_zero_tensor (x) + type(tensor), intent(out) :: x + x%t = 0 +end subroutine set_zero_tensor +@ \subsubsection{Scalar Multliplication} <>= interface operator (*) module procedure integer_tensor, real_tensor, double_tensor, & complex_tensor, dcomplex_tensor end interface private :: integer_tensor, real_tensor, double_tensor private :: complex_tensor, dcomplex_tensor @ <>= pure function integer_tensor (x, y) result (xy) integer, intent(in) :: x type(tensor), intent(in) :: y type(tensor) :: xy xy%t = x * y%t end function integer_tensor pure function real_tensor (x, y) result (xy) real(kind=single), intent(in) :: x type(tensor), intent(in) :: y type(tensor) :: xy xy%t = x * y%t end function real_tensor pure function double_tensor (x, y) result (xy) real(kind=default), intent(in) :: x type(tensor), intent(in) :: y type(tensor) :: xy xy%t = x * y%t end function double_tensor pure function complex_tensor (x, y) result (xy) complex(kind=single), intent(in) :: x type(tensor), intent(in) :: y type(tensor) :: xy xy%t = x * y%t end function complex_tensor pure function dcomplex_tensor (x, y) result (xy) complex(kind=default), intent(in) :: x type(tensor), intent(in) :: y type(tensor) :: xy xy%t = x * y%t end function dcomplex_tensor @ \subsubsection{Addition and Subtraction} <>= interface operator (+) module procedure plus_tensor end interface private :: plus_tensor interface operator (-) module procedure neg_tensor end interface private :: neg_tensor @ <>= pure function plus_tensor (t1) result (t2) type(tensor), intent(in) :: t1 type(tensor) :: t2 t2 = t1 end function plus_tensor pure function neg_tensor (t1) result (t2) type(tensor), intent(in) :: t1 type(tensor) :: t2 t2%t = - t1%t end function neg_tensor @ <>= interface operator (+) module procedure add_tensor end interface private :: add_tensor interface operator (-) module procedure sub_tensor end interface private :: sub_tensor @ <>= pure function add_tensor (x, y) result (xy) type(tensor), intent(in) :: x, y type(tensor) :: xy xy%t = x%t + y%t end function add_tensor pure function sub_tensor (x, y) result (xy) type(tensor), intent(in) :: x, y type(tensor) :: xy xy%t = x%t - y%t end function sub_tensor @ <>= interface operator (.tprod.) module procedure out_prod_vv, out_prod_vm, & out_prod_mv, out_prod_mm end interface private :: out_prod_vv, out_prod_vm, & out_prod_mv, out_prod_mm @ <>= pure function out_prod_vv (v, w) result (t) type(tensor) :: t type(vector), intent(in) :: v, w integer :: i, j t%t(0,0) = v%t * w%t t%t(0,1:3) = v%t * w%x t%t(1:3,0) = v%x * w%t do i = 1, 3 do j = 1, 3 t%t(i,j) = v%x(i) * w%x(j) end do end do end function out_prod_vv @ <>= pure function out_prod_vm (v, m) result (t) type(tensor) :: t type(vector), intent(in) :: v type(momentum), intent(in) :: m integer :: i, j t%t(0,0) = v%t * m%t t%t(0,1:3) = v%t * m%x t%t(1:3,0) = v%x * m%t do i = 1, 3 do j = 1, 3 t%t(i,j) = v%x(i) * m%x(j) end do end do end function out_prod_vm @ <>= pure function out_prod_mv (m, v) result (t) type(tensor) :: t type(vector), intent(in) :: v type(momentum), intent(in) :: m integer :: i, j t%t(0,0) = m%t * v%t t%t(0,1:3) = m%t * v%x t%t(1:3,0) = m%x * v%t do i = 1, 3 do j = 1, 3 t%t(i,j) = m%x(i) * v%x(j) end do end do end function out_prod_mv @ <>= pure function out_prod_mm (m, n) result (t) type(tensor) :: t type(momentum), intent(in) :: m, n integer :: i, j t%t(0,0) = m%t * n%t t%t(0,1:3) = m%t * n%x t%t(1:3,0) = m%x * n%t do i = 1, 3 do j = 1, 3 t%t(i,j) = m%x(i) * n%x(j) end do end do end function out_prod_mm @ <>= interface abs module procedure abs_tensor end interface private :: abs_tensor @ <>= pure function abs_tensor (t) result (abs_t) type(tensor), intent(in) :: t real(kind=default) :: abs_t abs_t = sqrt (sum ((abs (t%t))**2)) end function abs_tensor @ <>= interface conjg module procedure conjg_tensor end interface private :: conjg_tensor @ <>= pure function conjg_tensor (t) result (conjg_t) type(tensor), intent(in) :: t type(tensor) :: conjg_t conjg_t%t = conjg (t%t) end function conjg_tensor @ <>= interface operator (*) module procedure tensor_tensor, vector_tensor, tensor_vector, & momentum_tensor, tensor_momentum end interface private :: tensor_tensor, vector_tensor, tensor_vector, & momentum_tensor, tensor_momentum @ <>= pure function tensor_tensor (t1, t2) result (t1t2) type(tensor), intent(in) :: t1 type(tensor), intent(in) :: t2 complex(kind=default) :: t1t2 integer :: i1, i2 t1t2 = t1%t(0,0)*t2%t(0,0) & - dot_product (conjg (t1%t(0,1:)), t2%t(0,1:)) & - dot_product (conjg (t1%t(1:,0)), t2%t(1:,0)) do i1 = 1, 3 do i2 = 1, 3 t1t2 = t1t2 + t1%t(i1,i2)*t2%t(i1,i2) end do end do end function tensor_tensor @ <>= pure function tensor_vector (t, v) result (tv) type(tensor), intent(in) :: t type(vector), intent(in) :: v type(vector) :: tv tv%t = t%t(0,0) * v%t - dot_product (conjg (t%t(0,1:)), v%x) tv%x(1) = t%t(0,1) * v%t - dot_product (conjg (t%t(1,1:)), v%x) tv%x(2) = t%t(0,2) * v%t - dot_product (conjg (t%t(2,1:)), v%x) tv%x(3) = t%t(0,3) * v%t - dot_product (conjg (t%t(3,1:)), v%x) end function tensor_vector @ <>= pure function vector_tensor (v, t) result (vt) type(vector), intent(in) :: v type(tensor), intent(in) :: t type(vector) :: vt vt%t = v%t * t%t(0,0) - dot_product (conjg (v%x), t%t(1:,0)) vt%x(1) = v%t * t%t(0,1) - dot_product (conjg (v%x), t%t(1:,1)) vt%x(2) = v%t * t%t(0,2) - dot_product (conjg (v%x), t%t(1:,2)) vt%x(3) = v%t * t%t(0,3) - dot_product (conjg (v%x), t%t(1:,3)) end function vector_tensor @ <>= pure function tensor_momentum (t, p) result (tp) type(tensor), intent(in) :: t type(momentum), intent(in) :: p type(vector) :: tp tp%t = t%t(0,0) * p%t - dot_product (conjg (t%t(0,1:)), p%x) tp%x(1) = t%t(0,1) * p%t - dot_product (conjg (t%t(1,1:)), p%x) tp%x(2) = t%t(0,2) * p%t - dot_product (conjg (t%t(2,1:)), p%x) tp%x(3) = t%t(0,3) * p%t - dot_product (conjg (t%t(3,1:)), p%x) end function tensor_momentum @ <>= pure function momentum_tensor (p, t) result (pt) type(momentum), intent(in) :: p type(tensor), intent(in) :: t type(vector) :: pt pt%t = p%t * t%t(0,0) - dot_product (p%x, t%t(1:,0)) pt%x(1) = p%t * t%t(0,1) - dot_product (p%x, t%t(1:,1)) pt%x(2) = p%t * t%t(0,2) - dot_product (p%x, t%t(1:,2)) pt%x(3) = p%t * t%t(0,3) - dot_product (p%x, t%t(1:,3)) end function momentum_tensor @ \section{Symmetric Polarization Tensors} \begin{subequations} \begin{align} \epsilon^{\mu\nu}_{+2}(k) &= \epsilon^{\mu}_{+}(k)\epsilon^{\nu}_{+}(k) \\ \epsilon^{\mu\nu}_{+1}(k) &= \frac{1}{\sqrt{2}} \left( \epsilon^{\mu}_{+}(k)\epsilon^{\nu}_{0}(k) + \epsilon^{\mu}_{0}(k)\epsilon^{\nu}_{+}(k) \right) \\ \epsilon^{\mu\nu}_{0}(k) &= \frac{1}{\sqrt{6}} \left( \epsilon^{\mu}_{+}(k)\epsilon^{\nu}_{-}(k) + \epsilon^{\mu}_{-}(k)\epsilon^{\nu}_{+}(k) - 2 \epsilon^{\mu}_{0}(k)\epsilon^{\nu}_{0}(k) \right) \\ \epsilon^{\mu\nu}_{-1}(k) &= \frac{1}{\sqrt{2}} \left( \epsilon^{\mu}_{-}(k)\epsilon^{\nu}_{0}(k) + \epsilon^{\mu}_{0}(k)\epsilon^{\nu}_{-}(k) \right) \\ \epsilon^{\mu\nu}_{-2}(k) &= \epsilon^{\mu}_{-}(k)\epsilon^{\nu}_{-}(k) \end{align} \end{subequations} Note that~$\epsilon^{\mu}_{\pm2,\mu}(k) = \epsilon^{\mu}_{\pm}(k)\epsilon_{\pm,\mu}(k) \propto \epsilon^{\mu}_{\pm}(k)\epsilon_{\mp,\mu}^{*}(k) = 0$ and that the sign in $\epsilon^{\mu\nu}_{0}(k)$ insures its tracelessness\footnote{ On the other hand, with the shift operator $L_{-}\ket{+}=\ee^{\ii\phi}\ket{0}$ and $L_{-}\ket{0}=\ee^{\ii\chi}\ket{-}$, we find \begin{equation*} L_{-}^{2}\ket{++} = 2\ee^{2\ii\phi}\ket{00} + \ee^{\ii(\phi+\chi)}(\ket{+-}+\ket{-+}) \end{equation*} i.\,e.~$\chi-\phi=\pi$, if we want to identify $\epsilon^{\mu}_{-,0,+}$ with $\ket{-,0,+}$.}. <<[[omega_tensor_polarizations.f90]]>>= <> module omega_tensor_polarizations use kinds use constants use omega_vectors use omega_tensors use omega_polarizations implicit none private <> integer, parameter, public :: omega_tensor_pols_2010_01_A = 0 contains <> end module omega_tensor_polarizations @ <>= public :: eps2 @ <>= pure function eps2 (m, k, s) result (t) type(tensor) :: t real(kind=default), intent(in) :: m type(momentum), intent(in) :: k integer, intent(in) :: s type(vector) :: ep, em, e0 t%t = 0 select case (s) case (2) ep = eps (m, k, 1) t = ep.tprod.ep case (1) ep = eps (m, k, 1) e0 = eps (m, k, 0) t = (1 / sqrt (2.0_default)) & * ((ep.tprod.e0) + (e0.tprod.ep)) case (0) ep = eps (m, k, 1) e0 = eps (m, k, 0) em = eps (m, k, -1) t = (1 / sqrt (6.0_default)) & * ((ep.tprod.em) + (em.tprod.ep) - 2*(e0.tprod.e0)) case (-1) e0 = eps (m, k, 0) em = eps (m, k, -1) t = (1 / sqrt (2.0_default)) & * ((em.tprod.e0) + (e0.tprod.em)) case (-2) em = eps (m, k, -1) t = em.tprod.em end select end function eps2 @ \section{Couplings} <<[[omega_couplings.f90]]>>= <> module omega_couplings use kinds use constants use omega_vectors use omega_tensors implicit none private <> <> integer, parameter, public :: omega_couplings_2010_01_A = 0 contains <> <> end module omega_couplings @ <>= public :: wd_tl @ <>= public :: wd_run @ <>= public :: gauss @ \begin{equation} \Theta(p^2)\Gamma \end{equation} <>= pure function wd_tl (p, w) result (width) real(kind=default) :: width type(momentum), intent(in) :: p real(kind=default), intent(in) :: w if (p*p > 0) then width = w else width = 0 end if end function wd_tl @ \begin{equation} \frac{p^2}{m^2} \Gamma \end{equation} <>= pure function wd_run (p, m, w) result (width) real(kind=default) :: width type(momentum), intent(in) :: p real(kind=default), intent(in) :: m real(kind=default), intent(in) :: w if (p*p > 0) then width = w * (p*p) / m**2 else width = 0 end if end function wd_run @ <>= pure function gauss (x, mu, w) result (gg) real(kind=default) :: gg real(kind=default), intent(in) :: x, mu, w if (w > 0) then gg = exp(-(x - mu**2)**2/4.0_default/mu**2/w**2) * & sqrt(sqrt(PI/2)) / w / mu else gg = 1.0_default end if end function gauss @ <>= public :: pr_phi, pr_unitarity, pr_feynman, pr_gauge, pr_rxi public :: pr_vector_pure public :: pj_phi, pj_unitarity public :: pg_phi, pg_unitarity @ \begin{equation} \frac{\ii}{p^2-m^2+\ii m\Gamma}\phi \end{equation} <>= pure function pr_phi (p, m, w, phi) result (pphi) complex(kind=default) :: pphi type(momentum), intent(in) :: p real(kind=default), intent(in) :: m, w complex(kind=default), intent(in) :: phi pphi = (1 / cmplx (p*p - m**2, m*w, kind=default)) * phi end function pr_phi @ \begin{equation} \sqrt{\frac{\pi}{M\Gamma}} \phi \end{equation} <>= pure function pj_phi (m, w, phi) result (pphi) complex(kind=default) :: pphi real(kind=default), intent(in) :: m, w complex(kind=default), intent(in) :: phi pphi = (0, -1) * sqrt (PI / m / w) * phi end function pj_phi @ <>= pure function pg_phi (p, m, w, phi) result (pphi) complex(kind=default) :: pphi type(momentum), intent(in) :: p real(kind=default), intent(in) :: m, w complex(kind=default), intent(in) :: phi pphi = ((0, 1) * gauss (p*p, m, w)) * phi end function pg_phi @ \begin{equation} \frac{\ii}{p^2-m^2+\ii m\Gamma} \left( -g_{\mu\nu} + \frac{p_\mu p_\nu}{m^2} \right) \epsilon^\nu(p) \end{equation} NB: the explicit cast to [[vector]] is required here, because a specific [[complex_momentum]] procedure for [[operator (*)]] would introduce ambiguities. NB: we used to use the constructor [[vector (p%t, p%x)]] instead of the temporary variable, but the Intel Fortran Compiler choked on it. <>= pure function pr_unitarity (p, m, w, cms, e) result (pe) type(vector) :: pe type(momentum), intent(in) :: p real(kind=default), intent(in) :: m, w type(vector), intent(in) :: e logical, intent(in) :: cms type(vector) :: pv complex(kind=default) :: c_mass2 pv = p if (cms) then c_mass2 = cmplx (m**2, -m*w, kind=default) else c_mass2 = m**2 end if pe = - (1 / cmplx (p*p - m**2, m*w, kind=default)) & * (e - (p*e / c_mass2) * pv) end function pr_unitarity @ \begin{equation} \sqrt{\frac{\pi}{M\Gamma}} \left( -g_{\mu\nu} + \frac{p_\mu p_\nu}{m^2} \right) \epsilon^\nu(p) \end{equation} <>= pure function pj_unitarity (p, m, w, e) result (pe) type(vector) :: pe type(momentum), intent(in) :: p real(kind=default), intent(in) :: m, w type(vector), intent(in) :: e type(vector) :: pv pv = p pe = (0, 1) * sqrt (PI / m / w) * (e - (p*e / m**2) * pv) end function pj_unitarity @ <>= pure function pg_unitarity (p, m, w, e) result (pe) type(vector) :: pe type(momentum), intent(in) :: p real(kind=default), intent(in) :: m, w type(vector), intent(in) :: e type(vector) :: pv pv = p pe = - gauss (p*p, m, w) & * (e - (p*e / m**2) * pv) end function pg_unitarity @ \begin{equation} \frac{-i}{p^2} \epsilon^\nu(p) \end{equation} <>= pure function pr_feynman (p, e) result (pe) type(vector) :: pe type(momentum), intent(in) :: p type(vector), intent(in) :: e pe = - (1 / (p*p)) * e end function pr_feynman @ \begin{equation} \frac{\ii}{p^2} \left( -g_{\mu\nu} + (1-\xi)\frac{p_\mu p_\nu}{p^2} \right) \epsilon^\nu(p) \end{equation} <>= pure function pr_gauge (p, xi, e) result (pe) type(vector) :: pe type(momentum), intent(in) :: p real(kind=default), intent(in) :: xi type(vector), intent(in) :: e real(kind=default) :: p2 type(vector) :: pv p2 = p*p pv = p pe = - (1 / p2) * (e - ((1 - xi) * (p*e) / p2) * pv) end function pr_gauge @ \begin{equation} \frac{\ii}{p^2-m^2+\ii m\Gamma} \left( -g_{\mu\nu} + (1-\xi)\frac{p_\mu p_\nu}{p^2-\xi m^2} \right) \epsilon^\nu(p) \end{equation} <>= pure function pr_rxi (p, m, w, xi, e) result (pe) type(vector) :: pe type(momentum), intent(in) :: p real(kind=default), intent(in) :: m, w, xi type(vector), intent(in) :: e real(kind=default) :: p2 type(vector) :: pv p2 = p*p pv = p pe = - (1 / cmplx (p2 - m**2, m*w, kind=default)) & * (e - ((1 - xi) * (p*e) / (p2 - xi * m**2)) * pv) end function pr_rxi @ \begin{equation} \frac{\ii}{p^2-m^2+\ii m\Gamma} \left( -g_{\mu\nu} \right) \epsilon^\nu(p) \end{equation} <>= pure function pr_vector_pure (p, m, w, e) result (pe) type(vector) :: pe type(momentum), intent(in) :: p real(kind=default), intent(in) :: m, w type(vector), intent(in) :: e real(kind=default) :: p2 type(vector) :: pv p2 = p*p pv = p pe = - (1 / cmplx (p2 - m**2, m*w, kind=default)) * e end function pr_vector_pure @ <>= public :: pr_tensor, pr_tensor_pure @ \begin{subequations} \begin{equation} \frac{\ii P^{\mu\nu,\rho\sigma}(p,m)}{p^2-m^2+\ii m\Gamma} T_{\rho\sigma} \end{equation} with \begin{multline} P^{\mu\nu,\rho\sigma}(p,m) = \frac{1}{2} \left(g^{\mu\rho}-\frac{p^{\mu}p^{\nu}}{m^2}\right) \left(g^{\nu\sigma}-\frac{p^{\nu}p^{\sigma}}{m^2}\right) + \frac{1}{2} \left(g^{\mu\sigma}-\frac{p^{\mu}p^{\sigma}}{m^2}\right) \left(g^{\nu\rho}-\frac{p^{\nu}p^{\rho}}{m^2}\right) \\ - \frac{1}{3} \left(g^{\mu\nu}-\frac{p^{\mu}p^{\nu}}{m^2}\right) \left(g^{\rho\sigma}-\frac{p^{\rho}p^{\sigma}}{m^2}\right) \end{multline} \end{subequations} Be careful with raising and lowering of indices: \begin{subequations} \begin{align} g^{\mu\nu}-\frac{k^{\mu}k^{\nu}}{m^2} &= \begin{pmatrix} 1 - k^0k^0 / m^2 & - k^0 \vec k / m^2 \\ - \vec k k^0 / m^2 & - \mathbf{1} - \vec k \otimes \vec k / m^2 \end{pmatrix} \\ g^{\mu}_{\hphantom{\mu}\nu}-\frac{k^{\mu}k_{\nu}}{m^2} &= \begin{pmatrix} 1 - k^0k^0 / m^2 & k^0 \vec k / m^2 \\ - \vec k k^0 / m^2 & \mathbf{1} + \vec k \otimes \vec k / m^2 \end{pmatrix} \end{align} \end{subequations} <>= pure function pr_tensor (p, m, w, t) result (pt) type(tensor) :: pt type(momentum), intent(in) :: p real(kind=default), intent(in) :: m, w type(tensor), intent(in) :: t complex(kind=default) :: p_dd_t real(kind=default), dimension(0:3,0:3) :: p_uu, p_ud, p_du, p_dd integer :: i, j p_uu(0,0) = 1 - p%t * p%t / m**2 p_uu(0,1:3) = - p%t * p%x / m**2 p_uu(1:3,0) = p_uu(0,1:3) do i = 1, 3 do j = 1, 3 p_uu(i,j) = - p%x(i) * p%x(j) / m**2 end do end do do i = 1, 3 p_uu(i,i) = - 1 + p_uu(i,i) end do p_ud(:,0) = p_uu(:,0) p_ud(:,1:3) = - p_uu(:,1:3) p_du = transpose (p_ud) p_dd(:,0) = p_du(:,0) p_dd(:,1:3) = - p_du(:,1:3) p_dd_t = 0 do i = 0, 3 do j = 0, 3 p_dd_t = p_dd_t + p_dd(i,j) * t%t(i,j) end do end do pt%t = matmul (p_ud, matmul (0.5_default * (t%t + transpose (t%t)), p_du)) & - (p_dd_t / 3.0_default) * p_uu pt%t = pt%t / cmplx (p*p - m**2, m*w, kind=default) end function pr_tensor @ \begin{subequations} \begin{equation} \frac{\ii P_p^{\mu\nu,\rho\sigma}}{p^2-m^2+\ii m\Gamma} T_{\rho\sigma} \end{equation} with \begin{multline} P_p^{\mu\nu,\rho\sigma} = \frac{1}{2} g^{\mu\rho} g^{\nu\sigma} + \frac{1}{2} g^{\mu\sigma} g^{\nu\rho} - \frac{1}{2} g^{\mu\nu}g^{\rho\sigma} \end{multline} \end{subequations} <>= pure function pr_tensor_pure (p, m, w, t) result (pt) type(tensor) :: pt type(momentum), intent(in) :: p real(kind=default), intent(in) :: m, w type(tensor), intent(in) :: t complex(kind=default) :: p_dd_t real(kind=default), dimension(0:3,0:3) :: g_uu integer :: i, j g_uu(0,0) = 1 g_uu(0,1:3) = 0 g_uu(1:3,0) = g_uu(0,1:3) do i = 1, 3 do j = 1, 3 g_uu(i,j) = 0 end do end do do i = 1, 3 g_uu(i,i) = - 1 end do p_dd_t = t%t(0,0) - t%t(1,1) - t%t(2,2) - t%t(3,3) pt%t = 0.5_default * ((t%t + transpose (t%t)) & - p_dd_t * g_uu ) pt%t = pt%t / cmplx (p*p - m**2, m*w, kind=default) end function pr_tensor_pure @ \subsection{Triple Gauge Couplings} <>= public :: g_gg @ According to~(\ref{eq:fuse-gauge}) \begin{multline} A^{a,\mu}(k_1+k_2) = - \ii g \bigl( (k_1^{\mu}-k_2^{\mu})A^{a_1}(k_1) \cdot A^{a_2}(k_2) \\ + (2k_2+k_1)\cdot A^{a_1}(k_1)A^{a_2,\mu}(k_2) - A^{a_1,\mu}(k_1)A^{a_2}(k_2)\cdot(2k_1+k_2) \bigr) \end{multline} <>= pure function g_gg (g, a1, k1, a2, k2) result (a) complex(kind=default), intent(in) :: g type(vector), intent(in) :: a1, a2 type(momentum), intent(in) :: k1, k2 type(vector) :: a a = (0, -1) * g * ((k1 - k2) * (a1 * a2) & + ((2*k2 + k1) * a1) * a2 - a1 * ((2*k1 + k2) * a2)) end function g_gg @ \subsection{Quadruple Gauge Couplings} <>= public :: x_gg, g_gx @ \begin{equation} T^{a,\mu\nu}(k_1+k_2) = g \bigl( A^{a_1,\mu}(k_1) A^{a_2,\nu}(k_2) - A^{a_1,\nu}(k_1) A^{a_2,\mu}(k_2) \bigr) \end{equation} <>= pure function x_gg (g, a1, a2) result (x) complex(kind=default), intent(in) :: g type(vector), intent(in) :: a1, a2 type(tensor2odd) :: x x = g * (a1 .wedge. a2) end function x_gg @ \begin{equation} A^{a,\mu}(k_1+k_2) = g A^{a_1}_\nu(k_1) T^{a_2,\nu\mu}(k_2) \end{equation} <>= pure function g_gx (g, a1, x) result (a) complex(kind=default), intent(in) :: g type(vector), intent(in) :: a1 type(tensor2odd), intent(in) :: x type(vector) :: a a = g * (a1 * x) end function g_gx @ \subsection{Scalar Current} <>= public :: v_ss, s_vs @ \begin{equation} V^\mu(k_1+k_2) = g(k_1^\mu - k_2^\mu)\phi_1(k_1)\phi_2(k_2) \end{equation} <>= pure function v_ss (g, phi1, k1, phi2, k2) result (v) complex(kind=default), intent(in) :: g, phi1, phi2 type(momentum), intent(in) :: k1, k2 type(vector) :: v v = (k1 - k2) * (g * phi1 * phi2) end function v_ss @ \begin{equation} \phi(k_1+k_2) = g(k_1^\mu + 2k_2^\mu)V_\mu(k_1)\phi(k_2) \end{equation} <>= pure function s_vs (g, v1, k1, phi2, k2) result (phi) complex(kind=default), intent(in) :: g, phi2 type(vector), intent(in) :: v1 type(momentum), intent(in) :: k1, k2 complex(kind=default) :: phi phi = g * ((k1 + 2*k2) * v1) * phi2 end function s_vs @ \subsection{Transversal Scalar-Vector Coupling} <>= public :: s_vv_t, v_sv_t @ \begin{equation} phi(k_1+k_2) = g((V_1(k_1) V_2(k_2))(k_1 k_2) - (V_1(k_1) k_2)(V_2(k_2) k_1)) \end{equation} <>= pure function s_vv_t (g, v1, k1, v2, k2) result (phi) complex(kind=default), intent(in) :: g type(vector), intent(in) :: v1, v2 type(momentum), intent(in) :: k1, k2 complex(kind=default) :: phi phi = g * ((v1*v2) * (k1*k2) - (v1*k2) * (v2*k1)) end function s_vv_t @ \begin{equation} V_1^\mu(k_\phi+k_V) = g phi(((k_\phi+k_V)k_V)V_2^\mu- (k_\phi+k_V)V_2)k_V^\mu ) \end{equation} <>= pure function v_sv_t (g, phi, kphi,v, kv) result (vout) complex(kind=default), intent(in) :: g, phi type(vector), intent(in) :: v type(momentum), intent(in) :: kv, kphi type(momentum) :: kout type(vector) :: vout kout = - (kv + kphi) vout = g * phi * ((kout*kv) * v - (v * kout) * kv) end function v_sv_t @ \subsection{Transversal TensorScalar-Vector Coupling} <>= public :: tphi_vv, tphi_vv_cf, v_tphiv, v_tphiv_cf @ \begin{equation} phi(k_1 + k_2) = g (V_1(k_1) (k_1 +k_2)) * ( V_2(k_2) (k_1 + k_2)) \end{equation} <>= pure function tphi_vv (g, v1, k1, v2, k2) result (phi) complex(kind=default), intent(in) :: g type(vector), intent(in) :: v1, v2 type(momentum), intent(in) :: k1, k2 complex(kind=default) :: phi type(momentum) :: k k = - (k1 + k2) phi = 2 * g * (v1*k) * (v2*k) end function tphi_vv @ \begin{equation} phi(k_1+k_2) = g((V_1(k_1) V_2(k_2))(k_1 + k_2)^2) \end{equation} <>= pure function tphi_vv_cf (g, v1, k1, v2, k2) result (phi) complex(kind=default), intent(in) :: g type(vector), intent(in) :: v1, v2 type(momentum), intent(in) :: k1, k2 complex(kind=default) :: phi type(momentum) :: k k = - (k1 + k2) phi = - g/2 * (v1*v2) * (k*k) end function tphi_vv_cf @ \begin{equation} V_1^\mu(k_\phi+k_V) = g phi ((k_\phi+k_V)V_2) (k_\phi+k_V)^\mu \end{equation} <>= pure function v_tphiv (g, phi, kphi,v, kv) result (vout) complex(kind=default), intent(in) :: g, phi type(vector), intent(in) :: v type(momentum), intent(in) :: kv, kphi type(momentum) :: kout type(vector) :: vout kout = - (kv + kphi) vout = 2 * g * phi * ((v * kout) * kout) end function v_tphiv @ \begin{equation} V_1^\mu(k_\phi+k_V) = g phi((k_\phi+k_V)(k_\phi+k_V))V_2^\mu \end{equation} <>= pure function v_tphiv_cf (g, phi, kphi,v, kv) result (vout) complex(kind=default), intent(in) :: g, phi type(vector), intent(in) :: v type(momentum), intent(in) :: kv, kphi type(momentum) :: kout type(vector) :: vout kout = - (kv + kphi) vout = -g/2 * phi * (kout*kout) * v end function v_tphiv_cf @ \subsection{Triple Vector Couplings} <>= public :: tkv_vv, lkv_vv, tv_kvv, lv_kvv, kg_kgkg public :: t5kv_vv, l5kv_vv, t5v_kvv, l5v_kvv, kg5_kgkg, kg_kg5kg public :: dv_vv, v_dvv, dv_vv_cf, v_dvv_cf @ \begin{equation} V^\mu(k_1+k_2) = \ii g(k_1-k_2)^\mu V_1^\nu(k_1)V_{2,\nu}(k_2) \end{equation} <>= pure function tkv_vv (g, v1, k1, v2, k2) result (v) complex(kind=default), intent(in) :: g type(vector), intent(in) :: v1, v2 type(momentum), intent(in) :: k1, k2 type(vector) :: v v = (k1 - k2) * ((0, 1) * g * (v1*v2)) end function tkv_vv @ \begin{equation} V^\mu(k_1+k_2) = \ii g \epsilon^{\mu\nu\rho\sigma} (k_1-k_2)_{\nu} V_{1,\rho}(k_1)V_{2,\sigma}(k_2) \end{equation} <>= pure function t5kv_vv (g, v1, k1, v2, k2) result (v) complex(kind=default), intent(in) :: g type(vector), intent(in) :: v1, v2 type(momentum), intent(in) :: k1, k2 type(vector) :: v type(vector) :: k k = k1 - k2 v = (0, 1) * g * pseudo_vector (k, v1, v2) end function t5kv_vv @ \begin{equation} V^\mu(k_1+k_2) = \ii g(k_1+k_2)^\mu V_1^\nu(k_1)V_{2,\nu}(k_2) \end{equation} <>= pure function lkv_vv (g, v1, k1, v2, k2) result (v) complex(kind=default), intent(in) :: g type(vector), intent(in) :: v1, v2 type(momentum), intent(in) :: k1, k2 type(vector) :: v v = (k1 + k2) * ((0, 1) * g * (v1*v2)) end function lkv_vv @ \begin{equation} V^\mu(k_1+k_2) = \ii g \epsilon^{\mu\nu\rho\sigma} (k_1+k_2)_{\nu} V_{1,\rho}(k_1)V_{2,\sigma}(k_2) \end{equation} <>= pure function l5kv_vv (g, v1, k1, v2, k2) result (v) complex(kind=default), intent(in) :: g type(vector), intent(in) :: v1, v2 type(momentum), intent(in) :: k1, k2 type(vector) :: v type(vector) :: k k = k1 + k2 v = (0, 1) * g * pseudo_vector (k, v1, v2) end function l5kv_vv @ \begin{equation} V^\mu(k_1+k_2) = \ii g (k_2-k)^\nu V_{1,\nu}(k_1)V_2^\mu(k_2) = \ii g (2k_2+k_1)^\nu V_{1,\nu}(k_1)V_2^\mu(k_2) \end{equation} using $k=-k_1-k_2$ <>= pure function tv_kvv (g, v1, k1, v2, k2) result (v) complex(kind=default), intent(in) :: g type(vector), intent(in) :: v1, v2 type(momentum), intent(in) :: k1, k2 type(vector) :: v v = v2 * ((0, 1) * g * ((2*k2 + k1)*v1)) end function tv_kvv @ \begin{equation} V^\mu(k_1+k_2) = \ii g \epsilon^{\mu\nu\rho\sigma} (2k_2+k_1)_{\nu} V_{1,\rho}(k_1)V_{2,\sigma}(k_2) \end{equation} <>= pure function t5v_kvv (g, v1, k1, v2, k2) result (v) complex(kind=default), intent(in) :: g type(vector), intent(in) :: v1, v2 type(momentum), intent(in) :: k1, k2 type(vector) :: v type(vector) :: k k = k1 + 2*k2 v = (0, 1) * g * pseudo_vector (k, v1, v2) end function t5v_kvv @ \begin{equation} V^\mu(k_1+k_2) = - \ii g k_1^\nu V_{1,\nu}(k_1)V_2^\mu(k_2) \end{equation} using $k=-k_1-k_2$ <>= pure function lv_kvv (g, v1, k1, v2) result (v) complex(kind=default), intent(in) :: g type(vector), intent(in) :: v1, v2 type(momentum), intent(in) :: k1 type(vector) :: v v = v2 * ((0, -1) * g * (k1*v1)) end function lv_kvv @ \begin{equation} V^\mu(k_1+k_2) = - \ii g \epsilon^{\mu\nu\rho\sigma} k_{1,\nu} V_{1,\rho}(k_1)V_{2,\sigma}(k_2) \end{equation} <>= pure function l5v_kvv (g, v1, k1, v2) result (v) complex(kind=default), intent(in) :: g type(vector), intent(in) :: v1, v2 type(momentum), intent(in) :: k1 type(vector) :: v type(vector) :: k k = k1 v = (0, -1) * g * pseudo_vector (k, v1, v2) end function l5v_kvv @ \begin{equation} A^\mu(k_1+k_2) = \ii g k^\nu \Bigl( F_{1,\nu}^{\hphantom{1,\nu}\rho}(k_1)F_{2,\rho\mu}(k_2) - F_{1,\mu}^{\hphantom{1,\mu}\rho}(k_1)F_{2,\rho\nu}(k_2) \Bigr) \end{equation} with $k=-k_1-k_2$, i.\,e. \begin{multline} A^\mu(k_1+k_2) = -\ii g \Bigl( [(kk_2)(k_1A_2) - (k_1k_2)(kA_2)] A_1^\mu \\ + [(k_1k_2)(kA_1) - (kk_1)(k_2A_1)] A_2^\mu \\ + [(k_2A_1)(kA_2) - (kk_2)(A_1A_2)] k_1^\mu \\ + [(kk_1)(A_1A_2) - (kA_1)(k_1A_2)] k_2^\mu \Bigr) \end{multline} <>= pure function kg_kgkg (g, a1, k1, a2, k2) result (a) complex(kind=default), intent(in) :: g type(vector), intent(in) :: a1, a2 type(momentum), intent(in) :: k1, k2 type(vector) :: a real(kind=default) :: k1k1, k2k2, k1k2, kk1, kk2 complex(kind=default) :: a1a2, k2a1, ka1, k1a2, ka2 k1k1 = k1 * k1 k1k2 = k1 * k2 k2k2 = k2 * k2 kk1 = k1k1 + k1k2 kk2 = k1k2 + k2k2 k2a1 = k2 * a1 ka1 = k2a1 + k1 * a1 k1a2 = k1 * a2 ka2 = k1a2 + k2 * a2 a1a2 = a1 * a2 a = (0, -1) * g * ( (kk2 * k1a2 - k1k2 * ka2 ) * a1 & + (k1k2 * ka1 - kk1 * k2a1) * a2 & + (ka2 * k2a1 - kk2 * a1a2) * k1 & + (kk1 * a1a2 - ka1 * k1a2) * k2 ) end function kg_kgkg @ \begin{equation} A^\mu(k_1+k_2) = \ii g \epsilon^{\mu\nu\rho\sigma} k_{\nu} F_{1,\rho}^{\hphantom{1,\rho}\lambda}(k_1)F_{2,\lambda\sigma}(k_2) \end{equation} with $k=-k_1-k_2$, i.\,e. \begin{multline} A^\mu(k_1+k_2) = -2\ii g \epsilon^{\mu\nu\rho\sigma} k_{\nu} \Bigl( (k_2A_1) k_{1,\rho} A_{2,\sigma} + (k_1A_2) A_{1,\rho} k_{2,\sigma} \\ - (A_1A_2) k_{1,\rho} k_{2,\sigma} - (k_1k_2) A_{1,\rho} A_{2,\sigma} \Bigr) \end{multline} <>= pure function kg5_kgkg (g, a1, k1, a2, k2) result (a) complex(kind=default), intent(in) :: g type(vector), intent(in) :: a1, a2 type(momentum), intent(in) :: k1, k2 type(vector) :: a type(vector) :: kv, k1v, k2v kv = - k1 - k2 k1v = k1 k2v = k2 a = (0, -2) * g * ( (k2*A1) * pseudo_vector (kv, k1v, a2 ) & + (k1*A2) * pseudo_vector (kv, A1 , k2v) & - (A1*A2) * pseudo_vector (kv, k1v, k2v) & - (k1*k2) * pseudo_vector (kv, a1 , a2 ) ) end function kg5_kgkg @ \begin{equation} A^\mu(k_1+k_2) = \ii g k_{\nu} \Bigl( \epsilon^{\mu\rho\lambda\sigma} F_{1,\hphantom{\nu}\rho}^{\hphantom{1,}\nu} - \epsilon^{\nu\rho\lambda\sigma} F_{1,\hphantom{\mu}\rho}^{\hphantom{1,}\mu} \Bigr) \frac{1}{2} F_{1,\lambda\sigma} \end{equation} with $k=-k_1-k_2$, i.\,e. \begin{multline} A^\mu(k_1+k_2) = -\ii g \Bigl( \epsilon^{\mu\rho\lambda\sigma} (kk_2) A_{2,\rho} - \epsilon^{\mu\rho\lambda\sigma} (kA_2) k_{2,\rho} - k_2^\mu \epsilon^{\nu\rho\lambda\sigma} k_nu A_{2,\rho} + A_2^\mu \epsilon^{\nu\rho\lambda\sigma} k_nu k_{2,\rho} \Bigr) k_{1,\lambda} A_{1,\sigma} \end{multline} \begin{dubious} This is not the most efficienct way of doing it: $\epsilon^{\mu\nu\rho\sigma}F_{1,\rho\sigma}$ should be cached! \end{dubious} <>= pure function kg_kg5kg (g, a1, k1, a2, k2) result (a) complex(kind=default), intent(in) :: g type(vector), intent(in) :: a1, a2 type(momentum), intent(in) :: k1, k2 type(vector) :: a type(vector) :: kv, k1v, k2v kv = - k1 - k2 k1v = k1 k2v = k2 a = (0, -1) * g * ( (kv*k2v) * pseudo_vector (a2 , k1v, a1) & - (kv*a2 ) * pseudo_vector (k2v, k1v, a1) & - k2v * pseudo_scalar (kv, a2, k1v, a1) & + a2 * pseudo_scalar (kv, k2v, k1v, a1) ) end function kg_kg5kg @ \begin{equation} V^\mu(k_1+k_2) = - g ((k_1+k_2) V_{1}) V_{2}^\mu + ((k_1+k_2) V_{2}) V_{1}^\mu \end{equation} <>= pure function dv_vv (g, v1, k1, v2, k2) result (v) complex(kind=default), intent(in) :: g type(vector), intent(in) :: v1, v2 type(momentum), intent(in) :: k1, k2 type(vector) :: v type(vector) :: k k = -(k1 + k2) v = g * ((k * v1) * v2 + (k * v2) * v1) end function dv_vv @ \begin{equation} V^\mu(k_1+k_2) = \frac{g}{2} ( V_{1} (k_{1}) V_{2} (k_{2}) ) (k_{1}+k_{2})^\mu \end{equation} <>= pure function dv_vv_cf (g, v1, k1, v2, k2) result (v) complex(kind=default), intent(in) :: g type(vector), intent(in) :: v1, v2 type(momentum), intent(in) :: k1, k2 type(vector) :: v type(vector) :: k k = -(k1 + k2) v = - g/2 * (v1 * v2) * k end function dv_vv_cf @ \begin{equation} V_{1}^\mu = g * ( k V_{2}) V (k) + ( V V_{2}) k \end{equation} <>= pure function v_dvv (g, v, k, v2) result (v1) complex(kind=default), intent(in) :: g type(vector), intent(in) :: v, v2 type(momentum), intent(in) :: k type(vector) :: v1 v1 = g * ((v * v2) * k + (k * v2) * v) end function v_dvv @ \begin{equation} V_{1}^\mu = -\frac{g}{2} ( V (k) k ) V_{2}^\mu \end{equation} <>= pure function v_dvv_cf (g, v, k, v2) result (v1) complex(kind=default), intent(in) :: g type(vector), intent(in) :: v, v2 type(momentum), intent(in) :: k type(vector) :: v1 v1 = - g/2 * (v * k) * v2 end function v_dvv_cf @ \section{Tensorvector - Scalar coupling } <>= public :: dv_phi2,phi_dvphi, dv_phi2_cf, phi_dvphi_cf @ \begin{equation} V^\mu (k_1 + k_2 ) = g* ((k_1 k_2 + k_2 k_2) k_1^\mu + (k_1 k_2 + k_1 k_1) k_2^\mu ) * phi_1 (k_1) phi_2 (k_2) \end{equation} <>= pure function dv_phi2 (g, phi1, k1, phi2, k2) result (v) complex(kind=default), intent(in) :: g, phi1, phi2 type(momentum), intent(in) :: k1, k2 type(vector) :: v v = g * phi1 * phi2 * ( & (k1 * k2 + k2 * k2 ) * k1 + & (k1 * k2 + k1 * k1 ) * k2 ) end function dv_phi2 @ \begin{equation} V^\mu (k_1 + k_2 ) = - \frac{g}{2} * (k_1 k_2) * (k_1 + k_2 )^\mu * phi_1 (k_1) phi_2 (k_2) \end{equation} <>= pure function dv_phi2_cf (g, phi1, k1, phi2, k2) result (v) complex(kind=default), intent(in) :: g, phi1, phi2 type(momentum), intent(in) :: k1, k2 type(vector) :: v v = - g/2 * phi1 * phi2 * (k1 * k2) * (k1 + k2) end function dv_phi2_cf @ \begin{equation} phi_1 (k_1) = g * ((k_1 k_2 + k_2 k_2) (k_1 * V(-k_1 - k_2) ) + (k_1 k_2 + k_1 k_1) (k_2 * V(-k_1 - k_2) ) ) * phi_2 (k_2) \end{equation} <>= pure function phi_dvphi (g, v, k, phi2, k2) result (phi1) complex(kind=default), intent(in) :: g, phi2 type(vector), intent(in) :: v type(momentum), intent(in) :: k, k2 complex(kind=default) :: phi1 type(momentum) :: k1 k1 = - (k + k2) phi1 = g * phi2 * ( & (k1 * k2 + k2 * k2 ) * ( k1 * V ) + & (k1 * k2 + k1 * k1 ) * ( k2 * V ) ) end function phi_dvphi @ \begin{equation} phi_1 (k_1 ) = - \frac{g}{2} * (k_1 k_2) * ((k_1 + k_2 ) V(- k_1 - k_2)) \end{equation} <>= pure function phi_dvphi_cf (g, v, k, phi2, k2) result (phi1) complex(kind=default), intent(in) :: g, phi2 type(vector), intent(in) :: v type(momentum), intent(in) :: k, k2 complex(kind=default) :: phi1 type(momentum) :: k1 k1 = -(k + k2) phi1 = - g/2 * phi2 * (k1 * k2) * ((k1 + k2) * v) end function phi_dvphi_cf @ \section{Scalar-Vector Dim-5 Couplings} <>= public :: phi_vv, v_phiv, phi_u_vv, v_u_phiv @ <>= pure function phi_vv (g, k1, k2, v1, v2) result (phi) complex(kind=default), intent(in) :: g type(momentum), intent(in) :: k1, k2 type(vector), intent(in) :: v1, v2 complex(kind=default) :: phi phi = g * pseudo_scalar (k1, v1, k2, v2) end function phi_vv @ <>= pure function v_phiv (g, phi, k1, k2, v) result (w) complex(kind=default), intent(in) :: g, phi type(vector), intent(in) :: v type(momentum), intent(in) :: k1, k2 type(vector) :: w w = g * phi * pseudo_vector (k1, k2, v) end function v_phiv @ <>= pure function phi_u_vv (g, k1, k2, v1, v2) result (phi) complex(kind=default), intent(in) :: g type(momentum), intent(in) :: k1, k2 type(vector), intent(in) :: v1, v2 complex(kind=default) :: phi phi = g * ((k1*v2)*((-(k1+k2))*v1) + & (k2*v1)*((-(k1+k2))*v2) + & (((k1+k2)*(k1+k2)) * (v1*v2))) end function phi_u_vv @ <>= pure function v_u_phiv (g, phi, k1, k2, v) result (w) complex(kind=default), intent(in) :: g, phi type(vector), intent(in) :: v type(momentum), intent(in) :: k1, k2 type(vector) :: w w = g * phi * ((k1*v)*k2 + & ((-(k1+k2))*v)*k1 + & ((k1*k1)*v)) end function v_u_phiv @ \section{Dim-6 Anoumalous Couplings with Higgs} <>= public :: s_vv_6D, v_sv_6D, s_vv_6DP, v_sv_6DP, a_hz_D, h_az_D, z_ah_D, & a_hz_DP, h_az_DP, z_ah_DP, h_hh_6 <>= pure function s_vv_6D (g, v1, k1, v2, k2) result (phi) complex(kind=default), intent(in) :: g type(vector), intent(in) :: v1, v2 type(momentum), intent(in) :: k1, k2 complex(kind=default) :: phi phi = g * (-(k1 * v1) * (k1 * v2) - (k2 * v1) * (k2 * v2) & + ((k1 * k1) + (k2 * k2)) * (v1 * v2)) end function s_vv_6D <>= pure function v_sv_6D (g, phi, kphi, v, kv) result (vout) complex(kind=default), intent(in) :: g complex(kind=default), intent(in) :: phi type(vector), intent(in) :: v type(momentum), intent(in) :: kphi, kv type(vector) :: vout vout = g * ( - phi * (kv * v) * kv - phi * ((kphi + kv) * v) * (kphi + kv) & + phi * (kv * kv) * v + phi * ((kphi + kv)*(kphi + kv)) * v) end function v_sv_6D <>= pure function s_vv_6DP (g, v1, k1, v2, k2) result (phi) complex(kind=default), intent(in) :: g type(vector), intent(in) :: v1, v2 type(momentum), intent(in) :: k1, k2 complex(kind=default) :: phi phi = g * ( (-(k1+k2)*v1) * (k1*v2) - ((k1+k2)*v2) * (k2*v1) + & ((k1+k2)*(k1+k2))*(v1*v2) ) end function s_vv_6DP <>= pure function v_sv_6DP (g, phi, kphi, v, kv) result (vout) complex(kind=default), intent(in) :: g complex(kind=default), intent(in) :: phi type(vector), intent(in) :: v type(momentum), intent(in) :: kphi, kv type(vector) :: vout vout = g * phi * ((-(kphi + kv)*v) * kphi + (kphi * v) * kv + & (kphi*kphi) * v ) end function v_sv_6DP <>= pure function a_hz_D (g, h1, k1, v2, k2) result (vout) complex(kind=default), intent(in) :: g complex(kind=default), intent(in) :: h1 type(vector), intent(in) :: v2 type(momentum), intent(in) :: k1, k2 type(vector) :: vout vout = g * h1 * (((k1 + k2) * v2) * (k1 + k2) + & ((k1 + k2) * (k1 + k2)) * v2) end function a_hz_D <>= pure function h_az_D (g, v1, k1, v2, k2) result (hout) complex(kind=default), intent(in) :: g type(vector), intent(in) :: v1, v2 type(momentum), intent(in) :: k1, k2 complex(kind=default) :: hout hout = g * ((k1 * v1) * (k1 * v2) + (k1 * k1) * (v1 * v2)) end function h_az_D <>= pure function z_ah_D (g, v1, k1, h2, k2) result (vout) complex(kind=default), intent(in) :: g complex(kind=default), intent(in) :: h2 type(vector), intent(in) :: v1 type(momentum), intent(in) :: k1, k2 type(vector) :: vout vout = g * h2 * ((k1 * v1) * k1 + ((k1 * k1)) *v1) end function z_ah_D <>= pure function a_hz_DP (g, h1, k1, v2, k2) result (vout) complex(kind=default), intent(in) :: g complex(kind=default), intent(in) :: h1 type(vector), intent(in) :: v2 type(momentum), intent(in) :: k1, k2 type(vector) :: vout vout = g * ((- h1 * (k1 + k2) * v2) * (k1) & + h1 * ((k1 + k2) * (k1)) *v2) end function a_hz_DP <>= pure function h_az_DP (g, v1, k1, v2, k2) result (hout) complex(kind=default), intent(in) :: g type(vector), intent(in) :: v1, v2 type(momentum), intent(in) :: k1, k2 complex(kind=default) :: hout hout = g * (- (k1 * v2) * ((k1 + k2) * v1) + (k1 * (k1 + k2)) * (v1 * v2)) end function h_az_DP <>= pure function z_ah_DP (g, v1, k1, h2, k2) result (vout) complex(kind=default), intent(in) :: g complex(kind=default), intent(in) :: h2 type(vector), intent(in) :: v1 type(momentum), intent(in) :: k1, k2 type(vector) :: vout vout = g * h2* ((k2 * v1) * k1 - (k1 * k2) * v1) end function z_ah_DP <>= pure function h_hh_6 (g, h1, k1, h2, k2) result (hout) complex(kind=default), intent(in) :: g complex(kind=default), intent(in) :: h1, h2 type(momentum), intent(in) :: k1, k2 complex(kind=default) :: hout hout = g * ((k1* k1) + (k2 * k2) + (k1* k2)) * h1 * h2 end function h_hh_6 @ \section{Dim-6 Anoumalous Couplings without Higgs} <>= public :: g_gg_13, g_gg_23, g_gg_6, kg_kgkg_i <>= pure function g_gg_23 (g, v1, k1, v2, k2) result (vout) complex(kind=default), intent(in) :: g type(vector), intent(in) :: v1, v2 type(momentum), intent(in) :: k1, k2 type(vector) :: vout vout = g * (v1 * (-2*(k1*v2)) + v2 * (2*k2 * v1) + (k1 - k2) * (v1*v2)) end function g_gg_23 <>= pure function g_gg_13 (g, v1, k1, v2, k2) result (vout) complex(kind=default), intent(in) :: g type(vector), intent(in) :: v1, v2 type(momentum), intent(in) :: k1, k2 type(vector) :: vout vout = g * (v1 * (2*(k1 + k2)*v2) - v2 * ((k1 + 2*k2) * v1) + 2*k2 * (v1 * v2)) end function g_gg_13 <>= pure function g_gg_6 (g, v1, k1, v2, k2) result (vout) complex(kind=default), intent(in) :: g type(vector), intent(in) :: v1, v2 type(momentum), intent(in) :: k1, k2 type(vector) :: vout vout = g * & ( k1 * ((-(k1 + k2) * v2) * (k2 * v1) + ((k1 + k2) * k2) * (v1 * v2)) & + k2 * (((k1 + k2) * v1) * (k1 * v2) - ((k1 + k2) * k1) * (v1 * v2)) & + v1 * (-((k1 + k2) * k2) * (k1 * v2) + (k1 * k2) * ((k1 + k2) * v2)) & + v2 * (((k1 + k2) * k1) * (k2 * v1) - (k1 * k2) * ((k1 + k2) * v1))) end function g_gg_6 <>= pure function kg_kgkg_i (g, a1, k1, a2, k2) result (a) complex(kind=default), intent(in) :: g type(vector), intent(in) :: a1, a2 type(momentum), intent(in) :: k1, k2 type(vector) :: a real(kind=default) :: k1k1, k2k2, k1k2, kk1, kk2 complex(kind=default) :: a1a2, k2a1, ka1, k1a2, ka2 k1k1 = k1 * k1 k1k2 = k1 * k2 k2k2 = k2 * k2 kk1 = k1k1 + k1k2 kk2 = k1k2 + k2k2 k2a1 = k2 * a1 ka1 = k2a1 + k1 * a1 k1a2 = k1 * a2 ka2 = k1a2 + k2 * a2 a1a2 = a1 * a2 a = (-1) * g * ( (kk2 * k1a2 - k1k2 * ka2 ) * a1 & + (k1k2 * ka1 - kk1 * k2a1) * a2 & + (ka2 * k2a1 - kk2 * a1a2) * k1 & + (kk1 * a1a2 - ka1 * k1a2) * k2 ) end function kg_kgkg_i @ \section{Dim-6 Anoumalous Couplings with AWW} <>= public ::a_ww_DP, w_aw_DP, a_ww_DW <>= pure function a_ww_DP (g, v1, k1, v2, k2) result (vout) complex(kind=default), intent(in) :: g type(vector), intent(in) :: v1, v2 type(momentum), intent(in) :: k1, k2 type(vector) :: vout vout = g * ( - ((k1 + k2) * v2) * v1 + ((k1 + k2) * v1) * v2) end function a_ww_DP <>= pure function w_aw_DP (g, v1, k1, v2, k2) result (vout) complex(kind=default), intent(in) :: g type(vector), intent(in) :: v1, v2 type(momentum), intent(in) :: k1, k2 type(vector) :: vout vout = g * ((k1 * v2) * v1 - (v1 * v2) * k1) end function w_aw_DP <>= pure function a_ww_DW (g, v1, k1, v2, k2) result (vout) complex(kind=default), intent(in) :: g type(vector), intent(in) :: v1, v2 type(momentum), intent(in) :: k1, k2 type(vector) :: vout vout = g * (v1 * (- (4*k1 + 2*k2) * v2) & + v2 * ( (2*k1 + 4*k2) * v1) & + (k1 - k2) * (2*v1*v2)) end function a_ww_DW <>= public :: w_wz_DPW, z_ww_DPW, w_wz_DW, z_ww_DW, w_wz_D, z_ww_D <>= pure function w_wz_DPW (g, v1, k1, v2, k2) result (vout) complex(kind=default), intent(in) :: g type(vector), intent(in) :: v1, v2 type(momentum), intent(in) :: k1, k2 type(vector) :: vout vout = g * (v1 * (-(k1+k2)*v2 - k1*v2) + v2 * ((k1+k2)*v1) + k1 * (v1*v2)) end function w_wz_DPW <>= pure function z_ww_DPW (g, v1, k1, v2, k2) result (vout) complex(kind=default), intent(in) :: g type(vector), intent(in) :: v1, v2 type(momentum), intent(in) :: k1, k2 type(vector) :: vout vout = g * (k1*(v1*v2) - k2*(v1*v2) - v1*(k1*v2) + v2*(k2*v1)) end function z_ww_DPW <>= pure function w_wz_DW (g, v1, k1, v2, k2) result (vout) complex(kind=default), intent(in) :: g type(vector), intent(in) :: v1, v2 type(momentum), intent(in) :: k1, k2 type(vector) :: vout vout = g * (v2 * (v1 * k2) - k2 * (v1 * v2)) end function w_wz_DW <>= pure function z_ww_DW (g, v1, k1, v2, k2) result (vout) complex(kind=default), intent(in) :: g type(vector), intent(in) :: v1, v2 type(momentum), intent(in) :: k1, k2 type(vector) :: vout vout = g * (v1 * ((-1)*(k1+k2) * v2) + v2 * ((k1+k2) * v1)) end function z_ww_DW <>= pure function w_wz_D (g, v1, k1, v2, k2) result (vout) complex(kind=default), intent(in) :: g type(vector), intent(in) :: v1, v2 type(momentum), intent(in) :: k1, k2 type(vector) :: vout vout = g * (v2 * (k2*v1) - k2 * (v1*v2)) end function w_wz_D <>= pure function z_ww_D (g, v1, k1, v2, k2) result (vout) complex(kind=default), intent(in) :: g type(vector), intent(in) :: v1, v2 type(momentum), intent(in) :: k1, k2 type(vector) :: vout vout = g * (v1 * (- (k1 + k2) * v2) + v2 * ((k1 + k2) * v1)) end function z_ww_D @ \section{Dim-6 Quartic Couplings} <>= public :: hhhh_p2, a_hww_DPB, h_aww_DPB, w_ahw_DPB, a_hww_DPW, h_aww_DPW, & w_ahw_DPW, a_hww_DW, h_aww_DW, w3_ahw_DW, w4_ahw_DW <>= pure function hhhh_p2 (g, h1, k1, h2, k2, h3, k3) result (hout) complex(kind=default), intent(in) :: g complex(kind=default), intent(in) :: h1, h2, h3 type(momentum), intent(in) :: k1, k2, k3 complex(kind=default) :: hout hout = g * h1*h2*h3* (k1*k1 + k2*k2 +k3*k3 + k1*k3 + k1*k2 + k2*k3) end function hhhh_p2 <>= pure function a_hww_DPB (g, h1, k1, v2, k2, v3, k3) result (vout) complex(kind=default), intent(in) :: g complex(kind=default), intent(in) :: h1 type(vector), intent(in) :: v2, v3 type(momentum), intent(in) :: k1, k2, k3 type(vector) :: vout vout = g * h1 * (v3*((k1+k2+k3)*v2) - v2*((k1+k2+k3)*v3)) end function a_hww_DPB <>= pure function h_aww_DPB (g, v1, k1, v2, k2, v3, k3) result (hout) complex(kind=default), intent(in) :: g type(vector), intent(in) :: v1, v2, v3 type(momentum), intent(in) :: k1, k2, k3 complex(kind=default) :: hout hout = g * ((k1 * v3) * (v1 * v2) - (k1 * v2) * (v1 * v3)) end function h_aww_DPB <>= pure function w_ahw_DPB (g, v1, k1, h2, k2, v3, k3) result (vout) complex(kind=default), intent(in) :: g complex(kind=default), intent(in) :: h2 type(vector), intent(in) :: v1, v3 type(momentum), intent(in) :: k1, k2, k3 type(vector) :: vout vout = g * h2 * (v1 * (k1 * v3) - k1 * (v1 * v3)) end function w_ahw_DPB <>= pure function a_hww_DPW (g, h1, k1, v2, k2, v3, k3) result (vout) complex(kind=default), intent(in) :: g complex(kind=default), intent(in) :: h1 type(vector), intent(in) :: v2, v3 type(momentum), intent(in) :: k1, k2, k3 type(vector) :: vout vout = g * h1 * (v3 * ((2*k1+k2+k3)*v2) - v2 * ((2*k1+k2+k3)*v3)) end function a_hww_DPW <>= pure function h_aww_DPW (g, v1, k1, v2, k2, v3, k3) result (hout) complex(kind=default), intent(in) :: g type(vector), intent(in) :: v1, v2, v3 type(momentum), intent(in) :: k1, k2, k3 complex(kind=default) :: hout hout = g * ((-(2*k1+k2+k3)*v2)*(v1*v3)+((2*k1+k2+k3)*v3)*(v1*v2)) end function h_aww_DPW <>= pure function w_ahw_DPW (g, v1, k1, h2, k2, v3, k3) result (vout) complex(kind=default), intent(in) :: g complex(kind=default), intent(in) :: h2 type(vector), intent(in) :: v1, v3 type(momentum), intent(in) :: k1, k2, k3 type(vector) :: vout vout = g * h2 * ((k2 - k1) * (v1 * v3) + v1 * ((k1 - k2) * v3)) end function w_ahw_DPW <>= pure function a_hww_DW (g, h1, k1, v2, k2, v3, k3) result (vout) complex(kind=default), intent(in) :: g complex(kind=default), intent(in) :: h1 type(vector), intent(in) :: v2, v3 type(momentum), intent(in) :: k1, k2, k3 type(vector) :: vout vout = g * h1 * ( v2 * (-(3*k1 + 4*k2 + 4*k3) * v3) & + v3 * ((3*k1 + 2*k2 + 4*k3) * v2) & + (k2 - k3) *2*(v2 * v3)) end function a_hww_DW <>= pure function h_aww_DW (g, v1, k1, v2, k2, v3, k3) result (hout) complex(kind=default), intent(in) :: g type(vector), intent(in) :: v1, v2, v3 type(momentum), intent(in) :: k1, k2, k3 complex(kind=default) :: hout hout = g * ((v1*v2) * ((3*k1 - k2 - k3)*v3) & + (v1*v3) * ((-3*k1 - k2 + k3)*v2) & + (v2*v3) * (2*(k2-k3)*v1)) end function h_aww_DW <>= pure function w3_ahw_DW (g, v1, k1, h2, k2, v3, k3) result (vout) complex(kind=default), intent(in) :: g complex(kind=default), intent(in) :: h2 type(vector), intent(in) :: v1, v3 type(momentum), intent(in) :: k1, k2, k3 type(vector) :: vout vout = g * h2 * (v1 * ((4*k1 + k2) * v3) & +v3 * (-2*(k1 + k2 + 2*k3) * v1) & +(-2*k1 + k2 + 2*k3) * (v1*v3)) end function w3_ahw_DW <>= pure function w4_ahw_DW (g, v1, k1, h2, k2, v3, k3) result (vout) complex(kind=default), intent(in) :: g complex(kind=default), intent(in) :: h2 type(vector), intent(in) :: v1, v3 type(momentum), intent(in) :: k1, k2, k3 type(vector) :: vout vout = g * h2 * (v1 * (-(4*k1 + k2 + 2*k3) * v3) & + v3 * (2*(k1 + k2 + 2*k3) * v1) & +(4*k1 + k2) * (v1*v3)) end function w4_ahw_DW <>= public ::a_aww_DW, w_aaw_DW, a_aww_W, w_aaw_W <>= pure function a_aww_DW (g, v1, k1, v2, k2, v3, k3) result (vout) complex(kind=default), intent(in) :: g type(vector), intent(in) :: v1, v2, v3 type(momentum), intent(in) :: k1, k2, k3 type(vector) :: vout vout = g * (2*v1*(v2*v3) - v2*(v1*v3) - v3*(v1*v2)) end function a_aww_DW pure function w_aaw_DW (g, v1, k1, v2, k2, v3, k3) result (vout) complex(kind=default), intent(in) :: g type(vector), intent(in) :: v1, v2, v3 type(momentum), intent(in) :: k1, k2, k3 type(vector) :: vout vout = g * (2*v3*(v1*v2) - v2*(v1*v3) - v1*(v2*v3)) end function w_aaw_DW pure function a_aww_W (g, v1, k1, v2, k2, v3, k3) result (vout) complex(kind=default), intent(in) :: g type(vector), intent(in) :: v1, v2, v3 type(momentum), intent(in) :: k1, k2, k3 type(vector) :: vout vout = g * (v1*((-(k2+k3)*v2)*(k2*v3) + (-(k2+k3)*v3)*(k3*v2)) & +v2*((-((k2-k3)*v1)*(k1+k2+k3)*v3) - (k1*v3)*(k2*v1) & + ((k1+k2+k3)*v1)*(k2*v3)) & +v3*(((k2-k3)*v1)*((k1+k2+k3)*v2) - (k1*v2)*(k3*v1) & + ((k1+k2+k3)*v1)*(k3*v2)) & +(v1*v2)*(((2*k1+k2+k3)*v3)*k2 - (k2*v3)*k1 -(k1*v3)*k3) & +(v1*v3)*(((2*k1+k2+k3)*v2)*k3 - (k3*v2)*k1 - (k1*v2)*k3) & +(v2*v3)*((-(k1+k2+k3)*v1)*(k2+k3) + ((k2+k3)*v1)*k1) & +(-(k1+k2+k3)*k3 +k1*k2)*((v1*v3)*v2 - (v2*v3)*v1) & +(-(k1+k2+k3)*k2 + k1*k3)*((v1*v2)*v3 - (v2*v3)*v1)) end function a_aww_W pure function w_aaw_W (g, v1, k1, v2, k2, v3, k3) result (vout) complex(kind=default), intent(in) :: g type(vector), intent(in) :: v1, v2, v3 type(momentum), intent(in) :: k1, k2, k3 type(vector) :: vout vout = g * (v1*((k1*v3)*(-(k1+k2+2*k3)*v2) + (k2*v3)*((k1+k2+k3)*v2) & + (k1*v2)*((k1+k2+k3)*v3)) & + v2*(((k1-k2)*v3)*((k1+k2+k3)*v1) - (k2*v3)*(k3*v1) & + (k2*v1)*((k1+k2+k3)*v3)) & + v3*((k1*v2)*(-(k1+k2)*v1) + (k2*v1)*(-(k1+k2)*v2)) & + (v1*v2)*((k1+k2)*(-(k1+k2+k3)*v3) + k3*((k1+k2)*v3))& + (v1*v3)*(-k2*(k3*v2) - k3*(k1*v2) + k1*((k1+k2+2*k3)*v2)) & + (v2*v3)*(-k1*(k3*v1) - k3*(k2*v1) + k2*((k1+k2+2*k3)*v1)) & + (-k2*(k1+k2+k3) + k1*k3)*(v1*(v2*v3) - v3*(v1*v2)) & + (-k1*(k1+k2+k3) + k2*k3)*(v2*(v1*v3) - v3*(v1*v2)) ) end function w_aaw_W <>= public :: h_hww_D, w_hhw_D, h_hww_DP, w_hhw_DP, h_hvv_PB, v_hhv_PB <>= pure function h_hww_D (g, h1, k1, v2, k2, v3, k3) result (hout) complex(kind=default), intent(in) :: g complex(kind=default), intent(in) :: h1 type(vector), intent(in) :: v2, v3 type(momentum), intent(in) :: k1, k2, k3 complex(kind=default) :: hout hout = g * h1 * ((v2*v3)*((k2*k2)+(k3*k3)) - (k2*v2)*(k2*v3) & - (k3*v2)*(k3*v3)) end function h_hww_D <>= pure function w_hhw_D (g, h1, k1, h2, k2, v3, k3) result (vout) complex(kind=default), intent(in) :: g complex(kind=default), intent(in) :: h1, h2 type(vector), intent(in) :: v3 type(momentum), intent(in) :: k1, k2, k3 type(vector) :: vout vout = g * h1 * h2 * (v3 * ((k1+k2+k3)*(k1+k2+k3)+(k3*k3)) & - (k1+k2+k3) * ((k1+k2+k3)*v3) - k3 * (k3*v3)) end function w_hhw_D <>= pure function h_hww_DP (g, h1, k1, v2, k2, v3, k3) result (hout) complex(kind=default), intent(in) :: g complex(kind=default), intent(in) :: h1 type(vector), intent(in) :: v2, v3 type(momentum), intent(in) :: k1, k2, k3 complex(kind=default) :: hout hout = g * h1 * (-((k2+k3)*v2)*(k2*v3) - & ((k2+k3)*v3)*(k3*v2)+ (v2*v3)*((k2+k3)*(k2+k3))) end function h_hww_DP <>= pure function w_hhw_DP (g, h1, k1, h2, k2, v3, k3) result (vout) complex(kind=default), intent(in) :: g complex(kind=default), intent(in) :: h1, h2 type(vector), intent(in) :: v3 type(momentum), intent(in) :: k1, k2, k3 type(vector) :: vout vout = g * h1 * h2 * (k3*((k1+k2)*v3) + (k1+k2)*(-(k1+k2+k3)*v3) & + v3*((k1+k2)*(k1+k2))) end function w_hhw_DP <>= pure function h_hvv_PB (g, h1, k1, v2, k2, v3, k3) result (hout) complex(kind=default), intent(in) :: g complex(kind=default), intent(in) :: h1 type(vector), intent(in) :: v2, v3 type(momentum), intent(in) :: k1, k2, k3 complex(kind=default) :: hout hout = g * h1 * ((k2*v3)*(k3*v2) - (k2*k3)*(v2*v3)) end function h_hvv_PB <>= pure function v_hhv_PB (g, h1, k1, h2, k2, v3, k3) result (vout) complex(kind=default), intent(in) :: g complex(kind=default), intent(in) :: h1, h2 type(vector), intent(in) :: v3 type(momentum), intent(in) :: k1, k2, k3 type(vector) :: vout vout = g * h1 * h2 * ((-(k1+k2+k3)*v3)*k3 + ((k1+k2+k3)*k3)*v3) end function v_hhv_PB <>= public :: a_hhz_D, h_ahz_D, z_ahh_D, a_hhz_DP, h_ahz_DP, z_ahh_DP, & a_hhz_PB, h_ahz_PB, z_ahh_PB <>= pure function a_hhz_D (g, h1, k1, h2, k2, v3, k3) result (vout) complex(kind=default), intent(in) :: g complex(kind=default), intent(in) :: h1, h2 type(vector), intent(in) :: v3 type(momentum), intent(in) :: k1, k2, k3 type(vector) :: vout vout = g * h1 * h2 * ((k1+k2+k3) * ((k1+k2+k3)*v3) & - v3 * ((k1+k2+k3)*(k1+k2+k3))) end function a_hhz_D <>= pure function h_ahz_D (g, v1, k1, h2, k2, v3, k3) result (hout) complex(kind=default), intent(in) :: g complex(kind=default), intent(in) :: h2 type(vector), intent(in) :: v1, v3 type(momentum), intent(in) :: k1, k2, k3 complex(kind=default) :: hout hout = g * h2 * ((k1*v1)*(k1*v3) - (k1*k1)*(v1*v3)) end function h_ahz_D <>= pure function z_ahh_D (g, v1, k1, h2, k2, h3, k3) result (vout) complex(kind=default), intent(in) :: g type(vector), intent(in) :: v1 complex(kind=default), intent(in) :: h2, h3 type(momentum), intent(in) :: k1, k2, k3 type(vector) :: vout vout = g * h2 * h3 * ((k1*v1)*k1 - (k1*k1)*v1) end function z_ahh_D <>= pure function a_hhz_DP (g, h1, k1, h2, k2, v3, k3) result (vout) complex(kind=default), intent(in) :: g complex(kind=default), intent(in) :: h1, h2 type(vector), intent(in) :: v3 type(momentum), intent(in) :: k1, k2, k3 type(vector) :: vout vout = g * h1 * h2 * ((-(k1+k2+k3)*v3)*(k1+k2) + ((k1+k2+k3)*(k1+k2))*v3) end function a_hhz_DP <>= pure function h_ahz_DP (g, v1, k1, h2, k2, v3, k3) result (hout) complex(kind=default), intent(in) :: g complex(kind=default), intent(in) :: h2 type(vector), intent(in) :: v1, v3 type(momentum), intent(in) :: k1, k2, k3 complex(kind=default) :: hout hout = g * h2 * ( (k1*v3)*(-(k1+k3)*v1) + (k1*(k1+k3))*(v1*v3) ) end function h_ahz_DP <>= pure function z_ahh_DP (g, v1, k1, h2, k2, h3, k3) result (vout) complex(kind=default), intent(in) :: g type(vector), intent(in) :: v1 complex(kind=default), intent(in) :: h2, h3 type(momentum), intent(in) :: k1, k2, k3 type(vector) :: vout vout = g * h2 * h3 * (k1*((k2+k3)*v1) - v1*(k1*(k2+k3))) end function z_ahh_DP <>= pure function a_hhz_PB (g, h1, k1, h2, k2, v3, k3) result (vout) complex(kind=default), intent(in) :: g complex(kind=default), intent(in) :: h1, h2 type(vector), intent(in) :: v3 type(momentum), intent(in) :: k1, k2, k3 type(vector) :: vout vout = g * h1 * h2 * (k3*((k1+k2+k3)*v3) - v3*((k1+k2+k3)*k3)) end function a_hhz_PB <>= pure function h_ahz_PB (g, v1, k1, h2, k2, v3, k3) result (hout) complex(kind=default), intent(in) :: g complex(kind=default), intent(in) :: h2 type(vector), intent(in) :: v1, v3 type(momentum), intent(in) :: k1, k2, k3 complex(kind=default) :: hout hout = g * h2 * ((-k1*v3)*(k3*v1) + (k1*k3)*(v1*v3)) end function h_ahz_PB <>= pure function z_ahh_PB (g, v1, k1, h2, k2, h3, k3) result (vout) complex(kind=default), intent(in) :: g type(vector), intent(in) :: v1 complex(kind=default), intent(in) :: h2, h3 type(momentum), intent(in) :: k1, k2, k3 type(vector) :: vout vout = g * h2 * h3 * (k1*((k1+k2+k3)*v1) - v1*(k1*(k1+k2+k3))) end function z_ahh_PB <>= public :: h_wwz_DW, w_hwz_DW, z_hww_DW, h_wwz_DPB, w_hwz_DPB, z_hww_DPB public :: h_wwz_DDPW, w_hwz_DDPW, z_hww_DDPW, h_wwz_DPW, w_hwz_DPW, z_hww_DPW <>= pure function h_wwz_DW (g, v1, k1, v2, k2, v3, k3) result (hout) complex(kind=default), intent(in) :: g type(vector), intent(in) :: v1, v2, v3 type(momentum), intent(in) :: k1, k2, k3 complex(kind=default) :: hout hout = g * (((k1-k2)*v3)*(v1*v2)-((2*k1+k2)*v2)*(v1*v3) + & ((k1+2*k2)*v1)*(v2*v3)) end function h_wwz_DW <>= pure function w_hwz_DW (g, h1, k1, v2, k2, v3, k3) result (vout) complex(kind=default), intent(in) :: g complex(kind=default), intent(in) :: h1 type(vector), intent(in) :: v2, v3 type(momentum), intent(in) :: k1, k2, k3 type(vector) :: vout vout = g * h1 * ( v2*(-(k1+2*k2+k3)*v3) + v3*((2*k1+k2+2*k3)*v2) - & (k1 - k2 + k3)*(v2*v3)) end function w_hwz_DW <>= pure function z_hww_DW (g, h1, k1, v2, k2, v3, k3) result (vout) complex(kind=default), intent(in) :: g complex(kind=default), intent(in) :: h1 type(vector), intent(in) :: v2, v3 type(momentum), intent(in) :: k1, k2, k3 type(vector) :: vout vout = g * h1 * ((k2-k3)*(v2*v3) - v2*((2*k2+k3)*v3) + v3*((k2+2*k3)*v2)) end function z_hww_DW <>= pure function h_wwz_DPB (g, v1, k1, v2, k2, v3, k3) result (hout) complex(kind=default), intent(in) :: g type(vector), intent(in) :: v1, v2, v3 type(momentum), intent(in) :: k1, k2, k3 complex(kind=default) :: hout hout = g * ((k3*v1)*(v2*v3) - (k3*v2)*(v1*v3)) end function h_wwz_DPB <>= pure function w_hwz_DPB (g, h1, k1, v2, k2, v3, k3) result (vout) complex(kind=default), intent(in) :: g complex(kind=default), intent(in) :: h1 type(vector), intent(in) :: v2, v3 type(momentum), intent(in) :: k1, k2, k3 type(vector) :: vout vout = g * h1 * (k3*(v2*v3) - v3*(k3*v2)) end function w_hwz_DPB <>= pure function z_hww_DPB (g, h1, k1, v2, k2, v3, k3) result (vout) complex(kind=default), intent(in) :: g complex(kind=default), intent(in) :: h1 type(vector), intent(in) :: v2, v3 type(momentum), intent(in) :: k1, k2, k3 type(vector) :: vout vout = g * h1 * (((k1+k2+k3)*v3)*v2 - ((k1+k2+k3)*v2)*v3) end function z_hww_DPB <>= pure function h_wwz_DDPW (g, v1, k1, v2, k2, v3, k3) result (hout) complex(kind=default), intent(in) :: g type(vector), intent(in) :: v1, v2, v3 type(momentum), intent(in) :: k1, k2, k3 complex(kind=default) :: hout hout = g * (((k1-k2)*v3)*(v1*v2)-((k1-k3)*v2)*(v1*v3)+((k2-k3)*v1)*(v2*v3)) end function h_wwz_DDPW <>= pure function w_hwz_DDPW (g, h1, k1, v2, k2, v3, k3) result (vout) complex(kind=default), intent(in) :: g complex(kind=default), intent(in) :: h1 type(vector), intent(in) :: v2, v3 type(momentum), intent(in) :: k1, k2, k3 type(vector) :: vout vout = g * h1 * ((-(k1+2*k2+k3)*v3)*v2 + ((k1+k2+2*k3)*v2)*v3 + & (v2*v3)*(k2-k3)) end function w_hwz_DDPW <>= pure function z_hww_DDPW (g, h1, k1, v2, k2, v3, k3) result (vout) complex(kind=default), intent(in) :: g complex(kind=default), intent(in) :: h1 type(vector), intent(in) :: v2, v3 type(momentum), intent(in) :: k1, k2, k3 type(vector) :: vout vout = g * h1 * ((v2*v3)*(k2-k3) - ((k1+2*k2+k3)*v3) *v2 + & ((k1+k2+2*k3)*v2)*v3 ) end function z_hww_DDPW <>= pure function h_wwz_DPW (g, v1, k1, v2, k2, v3, k3) result (hout) complex(kind=default), intent(in) :: g type(vector), intent(in) :: v1, v2, v3 type(momentum), intent(in) :: k1, k2, k3 complex(kind=default) :: hout hout = g * (((k1-k2)*v3)*(v1*v2) + (-(2*k1+k2+k3)*v2)*(v1*v3) + & ((k1+2*k2+k3)*v1)*(v2*v3)) end function h_wwz_DPW <>= pure function w_hwz_DPW (g, h1, k1, v2, k2, v3, k3) result (vout) complex(kind=default), intent(in) :: g complex(kind=default), intent(in) :: h1 type(vector), intent(in) :: v2, v3 type(momentum), intent(in) :: k1, k2, k3 type(vector) :: vout vout = g * h1 * ((-(k1+2*k2+k3)*v3)*v2 + ((2*k1+k2+k3)*v2)*v3 + & (v2*v3)*(k2-k1)) end function w_hwz_DPW <>= pure function z_hww_DPW (g, h1, k1, v2, k2, v3, k3) result (vout) complex(kind=default), intent(in) :: g complex(kind=default), intent(in) :: h1 type(vector), intent(in) :: v2, v3 type(momentum), intent(in) :: k1, k2, k3 type(vector) :: vout vout = g * h1 * ((v2*v3)*(k2-k3) + ((k1-k2)*v3)*v2 + ((k3-k1)*v2)*v3) end function z_hww_DPW @ \section{Scalar3 Dim-5 Couplings} <>= public :: phi_dim5s2 @ \begin{equation} \phi_1(k_1) = g (k_2 \cdot k_3) \phi_2 (k_2) \phi_3 (k_3) \end{equation} <>= pure function phi_dim5s2 (g, phi2, k2, phi3, k3) result (phi1) complex(kind=default), intent(in) :: g, phi2, phi3 type(momentum), intent(in) :: k2, k3 complex(kind=default) :: phi1 phi1 = g * phi2 * phi3 * (k2 * k3) end function phi_dim5s2 @ \section{Tensorscalar-Scalar Couplings} <>= public :: tphi_ss, tphi_ss_cf, s_tphis, s_tphis_cf @ \begin{equation} \phi(k_1 + k_2) = 2 g ((k_1 \cdot k_2) + (k_1 \cdot k_1)) ((k_1 \cdot k_2) + (k_2 \cdot k_2)) \phi_1 (k_1) \phi_2 (k_2) \end{equation} <>= pure function tphi_ss (g, phi1, k1, phi2, k2) result (phi) complex(kind=default), intent(in) :: g, phi1, phi2 type(momentum), intent(in) :: k1, k2 complex(kind=default) :: phi phi = 2 * g * phi1 * phi2 * & ((k1 * k2)+ (k1 * k1)) * & ((k1 * k2)+ (k2 * k2)) end function tphi_ss @ \begin{equation} \phi(k_1 + k_2) = - g/2 (k_1 \cdot k_2) ((k_1 + k_2) \cdot (k_1 + k_2)) \phi_1 (k_1) \phi_2 (k_2) \end{equation} <>= pure function tphi_ss_cf (g, phi1, k1, phi2, k2) result (phi) complex(kind=default), intent(in) :: g, phi1, phi2 type(momentum), intent(in) :: k1, k2 complex(kind=default) :: phi phi = - g/2 * phi1 * phi2 * & (k1 * k2) * & ((k1 + k2) * (k1 + k2)) end function tphi_ss_cf @ \begin{equation} \phi_1(k_1) = 2 g ((k_1 \cdot k_2) + (k_1 \cdot k_1)) ((k_1 \cdot k_2) + (k_2 \cdot k_2)) \phi(k_2-k_1) \phi_2 (k_2) \end{equation} <>= pure function s_tphis (g, phi, k, phi2, k2) result (phi1) complex(kind=default), intent(in) :: g, phi, phi2 type(momentum), intent(in) :: k, k2 complex(kind=default) :: phi1 type(momentum) :: k1 k1 = - ( k + k2) phi1 = 2 * g * phi * phi2 * & ((k1 * k2)+ (k1 * k1)) * & ((k1 * k2)+ (k2 * k2)) end function s_tphis @ \begin{equation} \phi_1(k_1) = - g/2 (k_1 \cdot k_2) ((k_1 + k_2) \cdot (k_1 + k_2)) \phi (k_2 -k_1) \phi_2 (k_2) \end{equation} <>= pure function s_tphis_cf (g, phi, k, phi2, k2) result (phi1) complex(kind=default), intent(in) :: g, phi, phi2 type(momentum), intent(in) :: k, k2 complex(kind=default) :: phi1 type(momentum) :: k1 k1 = - ( k + k2) phi1 = - g/2 * phi * phi2 * & (k1 * k2) * & ((k1 + k2) * (k1 + k2)) end function s_tphis_cf @ \section{Scalar2-Vector2 Dim-8 Couplings} <>= public :: phi_phi2v_1, v_phi2v_1, phi_phi2v_2, v_phi2v_2 @ \begin{equation} \phi_2(k_2) = g \left (\left ( k_1 \cdot V_1 \right ) \left ( k_2 \cdot V_2 \right ) + \left ( k_1 \cdot V_1 \right )\left ( k_1 \cdot V_2 \right ) \right ) \phi_1 (k_1) \end{equation} <>= pure function phi_phi2v_1 (g, phi1, k1, v1, k_v1, v2, k_v2) result (phi2) complex(kind=default), intent(in) :: g, phi1 type(momentum), intent(in) :: k1, k_v1, k_v2 type(momentum) :: k2 type(vector), intent(in) :: v1, v2 complex(kind=default) :: phi2 k2 = - k1 - k_v1 - k_v2 phi2 = g * phi1 * & ( (k1 * v1) * (k2 * v2) + (k1 * v2) * (k2 * v1) ) end function phi_phi2v_1 @ \begin{equation} V_2^\mu =g \left ( k_1^\mu \left ( k_2 \cdot V_1 \right ) + k_2^\mu \left ( k_1 \cdot V_1 \right ) \right ) \phi_1 (k_1) \phi_2 (k_2) \end{equation} <>= pure function v_phi2v_1 (g, phi1, k1, phi2, k2, v1) result (v2) complex(kind=default), intent(in) :: g, phi1, phi2 type(momentum), intent(in) :: k1, k2 type(vector), intent(in) :: v1 type(vector) :: v2 v2 = g * phi1 * phi2 * & ( k1 * (k2 * v1) + k2 * (k1 * v1) ) end function v_phi2v_1 @ \begin{equation} \phi_2(k_2) = g \left ( k_1 \cdot k_2 \right ) \left ( V_1\cdot V_2 \right) \phi_1 (k_1) \end{equation} <>= pure function phi_phi2v_2 (g, phi1, k1, v1,k_v1, v2, k_v2) result (phi2) complex(kind=default), intent(in) :: g, phi1 type(momentum), intent(in) :: k1, k_v1, k_v2 type(vector), intent(in) :: v1, v2 type(momentum) :: k2 complex(kind=default) :: phi2 k2 = - k1 - k_v1 - k_v2 phi2 = g * phi1 * (k1 * k2) * (v1 * v2) end function phi_phi2v_2 @ \begin{equation} V_2^\mu = g V_1^\mu \left ( k_1 \cdot k_2 \right ) \phi_1 \phi_2 \end{equation} <>= pure function v_phi2v_2 (g, phi1, k1, phi2, k2, v1) result (v2) complex(kind=default), intent(in) :: g, phi1, phi2 type(momentum), intent(in) :: k1, k2 type(vector), intent(in) :: v1 type(vector) :: v2 v2 = g * phi1 * phi2 * & ( k1 * k2 ) * v1 end function v_phi2v_2 @ \section{Scalar4 Dim-8 Couplings} <>= public :: s_dim8s3 @ \begin{equation} \phi(k_1) = g \left [ \left ( k_1 \cdot k_2 \right ) \left ( k_3 \cdot k_4 \right )+ \left ( k_1 \cdot k_3 \right ) \left ( k_2 \cdot k_4 \right ) + \left ( k_1 \cdot k_4 \right )\left ( k_2 \cdot k_3 \right ) \right ] \phi_2 (k_2) \phi_3 (k_3) \phi_4 (k_4) \end{equation} <>= pure function s_dim8s3 (g, phi2, k2, phi3, k3, phi4, k4) result (phi1) complex(kind=default), intent(in) :: g, phi2, phi3, phi4 type(momentum), intent(in) :: k2, k3, k4 type(momentum) :: k1 complex(kind=default) :: phi1 k1 = - k2 - k3 - k4 phi1 = g * ( (k1 * k2) * (k3 * k4) + (k1 * k3) * (k2 * k4) & + (k1 * k4) * (k2 * k3) ) * phi2 * phi3 * phi4 end function s_dim8s3 @ \section{Mixed Scalar2-Vector2 Dim-8 Couplings} <>= public :: phi_phi2v_m_0, v_phi2v_m_0, phi_phi2v_m_1, v_phi2v_m_1, phi_phi2v_m_7, v_phi2v_m_7 @ \begin{equation} \phi_2(k_2) = g \left (\left ( V_1 \cdot k_{V_2} \right ) \left ( V_2 \cdot k_{V_1} \right ) \left ( k_1 \cdot k_2 \right ) - (\left ( V_1 \cdot V_2 \right ) \left ( k_{V_1} \cdot k_{V_2} \right ) \left ( k_1 \cdot k_2 \right ) \right ) \phi_1 (k_1) \end{equation} <>= pure function phi_phi2v_m_0 (g, phi1, k1, v1, k_v1, v2, k_v2) result (phi2) complex(kind=default), intent(in) :: g, phi1 type(momentum), intent(in) :: k1, k_v1, k_v2 type(momentum) :: k2 type(vector), intent(in) :: v1, v2 complex(kind=default) :: phi2 k2 = - k1 - k_v1 - k_v2 phi2 = g * phi1 * & ( (v1 * k_v2) * (v2 * k_v1) * (k1 * k2) & - (v1 * v2) * (k_v1 * k_v2) * (k1 * k2) ) end function phi_phi2v_m_0 @ \begin{equation} V_2^\mu =g \left ( k_{V_1}^\mu \left ( V_1 \cdot k_{V_2} \right ) \left ( k_1 \cdot k_2 \right ) - V_1^\mu \left ( k_{V_1} \cdot k_{V_2} \right ) \left ( k_1 \cdot k_2 \right ) \right ) \phi_1 (k_1) \phi_2 (k_2)) \end{equation} <>= pure function v_phi2v_m_0 (g, phi1, k1, phi2, k2, v1, k_v1) result (v2) complex(kind=default), intent(in) :: g, phi1, phi2 type(momentum), intent(in) :: k1, k2, k_v1 type(vector), intent(in) :: v1 type(momentum) :: k_v2 type(vector) :: v2 k_v2 = - k_v1 - k1 - k2 v2 = g * phi1 * phi2 * & ( k_v1 * (v1 * k_v2) * (k1 * k2) & - v1 * (k_v2 * k_v1) * (k1 * k2) ) end function v_phi2v_m_0 @ \begin{equation} \phi_2(k_2) = g \left (\left ( V_1 \cdot V_2 \right ) \left ( k_1 \cdot k_{V_2} \right ) \left ( k_2 \cdot k_{V_1} \right ) + (\left ( V_1 \cdot V_2 \right ) \left ( k_1 \cdot k_{V_1} \right ) \left ( k_2 \cdot k_{V_2} \right ) \\ + (\left ( V_1 \cdot k_2 \right ) \left ( V_2 \cdot k_1 \right ) \left ( k_{V_1} \cdot k_{V_2} \right ) + (\left ( V_1 \cdot k_1 \right ) \left ( V_2 \cdot k_2 \right ) \left ( k_{V_1} \cdot k_{V_2} \right ) \\ - (\left ( V_1 \cdot k_{V_2} \right ) \left ( V_2 \cdot k_2 \right ) \left ( k_1 \cdot k_{V_1} \right ) - (\left ( V_1 \cdot k_2 \right ) \left ( V_2 \cdot k_{V_1} \right ) \left ( k_1 \cdot k_{V_2} \right ) \\ - (\left ( V_1 \cdot k_{V_2} \right ) \left ( V_2 \cdot k_1 \right ) \left ( k_2 \cdot k_{V_1} \right ) - (\left ( V_1 \cdot k_1 \right ) \left ( V_2 \cdot k_{V_1} \right ) \left ( k_2 \cdot k_{V_2} \right ) \right ) \phi_1 (k_1) \end{equation} <>= pure function phi_phi2v_m_1 (g, phi1, k1, v1, k_v1, v2, k_v2) result (phi2) complex(kind=default), intent(in) :: g, phi1 type(momentum), intent(in) :: k1, k_v1, k_v2 type(momentum) :: k2 type(vector), intent(in) :: v1, v2 complex(kind=default) :: phi2 k2 = - k1 - k_v1 - k_v2 phi2 = g * phi1 * & ( (v1 * v2) * (k1 * k_v2) * (k2 * k_v1) & + (v1 * v2) * (k1 * k_v1) * (k2 * k_v2) & + (v1 * k2) * (v2 * k1) * (k_v1 * k_v2) & + (v1 * k1) * (v2 * k2) * (k_v1 * k_v2) & - (v1 * k_v2) * (v2 * k2) * (k1 * k_v1) & - (v1 * k2) * (v2 * k_v1) * (k1 * k_v2) & - (v1 * k_v2) * (v2 * k1) * (k2 * k_v1) & - (v1 * k1) * (v2 * k_v1) * (k2 * k_v2) ) end function phi_phi2v_m_1 @ \begin{equation} V_2^\mu =g \left ( k_1^\mu \left ( V_1 \cdot k_2 \right ) \left ( k_{V_1} \cdot k_{V_2} \right ) \\ + k_2^\mu \left ( V_1 \cdot k_1 \right ) \left ( k_{V_1} \cdot k_{V_2} \right ) \\ + V_1^\mu \left ( k_{V_1} \cdot k_1 \right ) \left ( k_{V_2} \cdot k_2 \right ) \\ + V_1^\mu \left ( k_{V_1} \cdot k_2 \right ) \left ( k_{V_2} \cdot k_1 \right ) \\ - k_1^\mu \left ( V_1 \cdot k_{V_2} \right ) \left ( k_{V_1} \cdot k_2 \right ) \\ - k_2^\mu \left ( V_1 \cdot k_{V_2} \right ) \left ( k_{V_1} \cdot k_1 \right ) \\ - k_{V_1}^\mu \left ( V_1 \cdot k_1 \right ) \left ( k_{V_2} \cdot k_2 \right ) \\ - k_{V_1}^\mu \left ( V_1 \cdot k_2 \right ) \left ( k_{V_2} \cdot k_1 \right ) \right ) \\ \phi_1 (k_1) \phi_2 (k_2) \end{equation} <>= pure function v_phi2v_m_1 (g, phi1, k1, phi2, k2, v1, k_v1) result (v2) complex(kind=default), intent(in) :: g, phi1, phi2 type(momentum), intent(in) :: k1, k2, k_v1 type(vector), intent(in) :: v1 type(momentum) :: k_v2 type(vector) :: v2 k_v2 = - k_v1 - k1 - k2 v2 = g * phi1 * phi2 * & ( k1 * (v1 * k2) * (k_v1 * k_v2) & + k2 * (v1 * k1) * (k_v1 * k_v2) & + v1 * (k_v1 * k1) * (k_v2 * k2) & + v1 * (k_v1 * k2) * (k_v2 * k1) & - k1 * (v1 * k_v2) * (k_v1 * k2) & - k2 * (v1 * k_v2) * (k_v1 * k1) & - k_v1 * (v1 * k1) * (k_v2 * k2) & - k_v1 * (v1 * k2) * (k_v2 * k1) ) end function v_phi2v_m_1 @ \begin{equation} \phi_2(k_2) = g \left (\left ( V_1 \cdot k_{V_2} \right ) \left ( k_1 \cdot V_2 \right ) \left ( k_2 \cdot k_{V_1} \right ) + (\left ( V_1 \cdot k_{V_2} \right ) \left ( k_1 \cdot k_{V_1} \right ) \left ( k_2 \cdot k_{V_2} \right ) \\ + (\left ( V_1 \cdot k_1 \right ) \left ( V_2 \cdot k_{V_1} \right ) \left ( k_2 \cdot k_{V_2} \right ) + (\left ( V_1 \cdot k_2 \right ) \left ( V_2 \cdot k_{V_1} \right ) \left ( k_1 \cdot k_{V_2} \right ) \\ - (\left ( V_1 \cdot V_2 \right ) \left ( k_1 \cdot k_{V_2} \right ) \left ( k_2 \cdot k_{V_1} \right ) - (\left ( V_1 \cdot V_2 \right ) \left ( k_1 \cdot k_{V_1} \right ) \left ( k_2 \cdot k_{V_2} \right ) \\ - (\left ( V_1 \cdot k_2 \right ) \left ( V_2 \cdot k_1 \right ) \left ( k_{V_1} \cdot k_{V_2} \right ) - (\left ( V_1 \cdot k_1 \right ) \left ( V_2 \cdot k_2 \right ) \left ( k_{V_1} \cdot k_{V_2} \right ) \right ) \phi_1 (k_1) \end{equation} <>= pure function phi_phi2v_m_7 (g, phi1, k1, v1, k_v1, v2, k_v2) result (phi2) complex(kind=default), intent(in) :: g, phi1 type(momentum), intent(in) :: k1, k_v1, k_v2 type(momentum) :: k2 type(vector), intent(in) :: v1, v2 complex(kind=default) :: phi2 k2 = - k1 - k_v1 - k_v2 phi2 = g * phi1 * & ( (v1 * k_v2) * (k1 * v2) * (k2 * k_v1) & + (v1 * k_v2) * (k1 * k_v1) * (k2 * v2) & + (v1 * k1) * (v2 * k_v1) * (k2 * k_v2) & + (v1 * k2) * (v2 * k_v1) * (k1 * k_v2) & - (v1 * v2) * (k1 * k_v2) * (k2 * k_v1) & - (v1 * v2) * (k1 * k_v1) * (k2 * k_v2) & - (v1 * k2) * (v2 * k1) * (k_v1 * k_v2) & - (v1 * k1) * (v2 * k2) * (k_v1 * k_v2) ) end function phi_phi2v_m_7 @ \begin{equation} V_2^\mu =g \left ( k_1^\mu \left ( V_1 \cdot k_{V_2} \right ) \left ( k_2 \cdot k_{V_1} \right ) \\ + k_2^\mu \left ( V_1 \cdot k_{V_2} \right ) \left ( k_1 \cdot k_{V_1} \right ) \\ + k_{V_1}^\mu \left ( V_1 \cdot k_1 \right ) \left ( k_2 \cdot k_{V_2} \right ) \\ + k_{V_1}^\mu \left ( V_1 \cdot k_2 \right ) \left ( k_1 \cdot k_{V_2} \right ) \\ - k_1^\mu \left ( V_1 \cdot k_2 \right ) \left ( k_{V_1} \cdot k_{V_2} \right ) \\ - k_2^\mu \left ( V_1 \cdot k_1 \right ) \left ( k_{V_1} \cdot k_{V_2} \right ) \\ - k_{V_1}^\mu \left ( k_1 \cdot k_{V_2} \right ) \left ( k_2 \cdot k_{V_1} \right ) \\ - k_{V_1}^\mu \left ( k_1 \cdot k_{V_1} \right ) \left ( k_2 \cdot k_{V_2} \right ) \right ) \\ \phi_1 (k_1) \phi_2 (k_2) \end{equation} <>= pure function v_phi2v_m_7 (g, phi1, k1, phi2, k2, v1, k_v1) result (v2) complex(kind=default), intent(in) :: g, phi1, phi2 type(momentum), intent(in) :: k1, k2, k_v1 type(vector), intent(in) :: v1 type(momentum) :: k_v2 type(vector) :: v2 k_v2 = - k_v1 - k1 - k2 v2 = g * phi1 * phi2 * & ( k1 * (v1 * k_v2) * (k2 * k_v1) & + k2 * (v1 * k_v2) * (k1 * k_v1) & + k_v1 * (v1 * k1) * (k2 * k_v2) & + k_v1 * (v1 * k2) * (k1 * k_v2) & - k1 * (v1 * k2) * (k_v1 * k_v2) & - k2 * (v1 * k1) * (k_v1 * k_v2) & - v1 * (k1 * k_v2) * (k2 * k_v1) & - v1 * (k1 * k_v1) * (k2 * k_v2) ) end function v_phi2v_m_7 @ \section{Transversal Gauge4 Dim-8 Couplings} <>= public :: g_dim8g3_t_0, g_dim8g3_t_1, g_dim8g3_t_2 @ \begin{equation} V_1^\mu = g \left [ k_2^\mu \left ( k_1 \cdot V_2 \right ) - V_2^\mu \left ( k_1 \cdot k_2 \right ) \right ] \left [ \left ( k_3 \cdot V_4 \right) \left ( k_4 \cdot V_3 \right ) - \left (V_3 \cdot V_4 \right ) \left ( k_3 \cdot k_4 \right ) \right ] \end{equation} <>= pure function g_dim8g3_t_0 (g, v2, k2, v3, k3, v4, k4) result (v1) complex(kind=default), intent(in) :: g type(vector), intent(in) :: v2, v3, v4 type(momentum), intent(in) :: k2, k3, k4 type(vector) :: v1 type(momentum) :: k1 k1 = - k2 - k3 - k4 v1 = g * (k2 * (k1 * v2) - v2 * (k1 * k2)) & * ((k3 * v4) * (k4 * v3) - (v3 * v4) * (k3 * k4)) end function g_dim8g3_t_0 @ \begin{equation} V_1^\mu = g \left [ k_2^\mu \left ( k_1 \cdot V_2 \right ) - V_2^\mu \left ( k_1 \cdot k_2 \right ) \right ] \left [ \left ( k_3 \cdot V_4 \right) \left ( k_4 \cdot V_3 \right ) - \left (V_3 \cdot V_4 \right ) \left ( k_3 \cdot k_4 \right ) \right ] \end{equation} <>= pure function g_dim8g3_t_1 (g, v2, k2, v3, k3, v4, k4) result (v1) complex(kind=default), intent(in) :: g type(vector), intent(in) :: v2, v3, v4 type(momentum), intent(in) :: k2, k3, k4 type(vector) :: v1 type(momentum) :: k1 k1 = - k2 - k3 - k4 v1 = g * (v3 * (v2 * k4) * (k1 * k3) * (k2 * v4) & + v4 * (v2 * k3) * (k1 * k4) * (k2 * v3) & + k3 * (v2 * v4) * (k1 * v3) * (k2 * k4) & + k4 * (v2 * v3) * (k1 * v4) * (k2 * k3) & - v3 * (v2 * v4) * (k1 * k3) * (k2 * k4) & - v4 * (v2 * v3) * (k1 * k4) * (k2 * k3) & - k3 * (v2 * k4) * (k1 * v3) * (k2 * v4) & - k4 * (v2 * k3) * (k1 * v4) * (k2 * v3)) end function g_dim8g3_t_1 @ \begin{equation} V_1^\mu = g \left [ k_2^\mu \left (V_2 \cdot k_3\right ) \left (V_3 \cdot k_4\right ) \left (V_4 \cdot k_1\right ) \\ + k_3^\mu \left (V_2 \cdot k_1\right ) \left (V_3 \cdot k_4\right ) \left (V_4 \cdot k_2\right ) \\ + k_2^\mu \left (V_2 \cdot k_4\right ) \left (V_3 \cdot k_1\right ) \left (V_4 \cdot k_3\right ) \\ + k_4^\mu \left (V_2 \cdot k_1\right ) \left (V_3 \cdot k_2\right ) \left (V_4 \cdot k_3\right ) \\ + k_4^\mu \left (V_2 \cdot k_3\right ) \left (V_3 \cdot V_4\right ) \left (k_1 \cdot k_2\right ) \\ + k_3^\mu \left (V_2 \cdot k_4\right ) \left (V_3 \cdot V_4\right ) \left (k_1 \cdot k_2\right ) \\ - k_3^\mu \left (V_2 \cdot V_4\right ) \left (V_3 \cdot k_4\right ) \left (k_1 \cdot k_2\right ) \\ - V_4^\mu \left (V_2 \cdot k_3\right ) \left (V_3 \cdot k_4\right ) \left (k_1 \cdot k_2\right ) \\ - k_4^\mu \left (V_2 \cdot V_3\right ) \left (V_4 \cdot k_3\right ) \left (k_1 \cdot k_2\right ) \\ - V_3^\mu \left (V_2 \cdot k_4\right ) \left (V_4 \cdot k_3\right ) \left (k_1 \cdot k_2\right ) \\ - k_2^\mu \left (V_2 \cdot k_4\right ) \left (V_3 \cdot V_4\right ) \left (k_1 \cdot k_3\right ) \\ + k_2^\mu \left (V_2 \cdot V_4\right ) \left (V_3 \cdot k_4\right ) \left (k_1 \cdot k_3\right ) \\ - V_2^\mu \left (V_3 \cdot k_4\right ) \left (V_4 \cdot k_2\right ) \left (k_1 \cdot k_3\right ) \\ - k_2^\mu \left (V_2 \cdot k_3\right ) \left (V_3 \cdot V_4\right ) \left (k_1 \cdot k_4\right ) \\ + k_2^\mu \left (V_2 \cdot V_3\right ) \left (V_4 \cdot k_3\right ) \left (k_1 \cdot k_4\right ) \\ - V_2^\mu \left (V_3 \cdot k_2\right ) \left (V_4 \cdot k_3\right ) \left (k_1 \cdot k_4\right ) \\ - k_4^\mu \left (V_2 \cdot k_1\right ) \left (V_3 \cdot V_4\right ) \left (k_2 \cdot k_3\right ) \\ + V_4^\mu \left (V_2 \cdot k_1\right ) \left (V_3 \cdot k_4\right ) \left (k_2 \cdot k_3\right ) \\ - V_2^\mu \left (V_3 \cdot k_4\right ) \left (V_4 \cdot k_1\right ) \left (k_2 \cdot k_3\right ) \\ + V_2^\mu \left (V_3 \cdot V_4\right ) \left (k_1 \cdot k_4\right ) \left (k_2 \cdot k_3\right ) \\ - k_3^\mu \left (V_2 \cdot k_1\right ) \left (V_3 \cdot V_4\right ) \left (k_2 \cdot k_4\right ) \\ + V_3^\mu \left (V_2 \cdot k_1\right ) \left (V_4 \cdot k_3\right ) \left (k_2 \cdot k_4\right ) \\ - V_2^\mu \left (V_3 \cdot k_1\right ) \left (V_4 \cdot k_3\right ) \left (k_2 \cdot k_4\right ) \\ + V_2^\mu \left (V_3 \cdot V_4\right ) \left (k_1 \cdot k_3\right ) \left (k_2 \cdot k_4\right ) \\ - k_2^\mu \left (V_2 \cdot V_4\right ) \left (V_3 \cdot k_1\right ) \left (k_3 \cdot k_4\right ) \\ - V_4^\mu \left (V_2 \cdot k_1\right ) \left (V_3 \cdot k_2\right ) \left (k_3 \cdot k_4\right ) \\ - k_2^\mu \left (V_2 \cdot V_3\right ) \left (V_4 \cdot k_1\right ) \left (k_3 \cdot k_4\right ) \\ + V_2^\mu \left (V_3 \cdot k_2\right ) \left (V_4 \cdot k_1\right ) \left (k_3 \cdot k_4\right ) \\ - V_3^\mu \left (V_2 \cdot k_1\right ) \left (V_4 \cdot k_2\right ) \left (k_3 \cdot k_4\right ) \\ + V_2^\mu \left (V_3 \cdot k_1\right ) \left (V_4 \cdot k_2\right ) \left (k_3 \cdot k_4\right ) \\ + V_4^\mu \left (V_2 \cdot V_3\right ) \left (k_1 \cdot k_2\right ) \left (k_3 \cdot k_4\right ) \\ + V_3^\mu \left (V_2 \cdot V_4\right ) \left (k_1 \cdot k_2\right ) \left (k_3 \cdot k_4\right ) \right ] \end{equation} <>= pure function g_dim8g3_t_2 (g, v2, k2, v3, k3, v4, k4) result (v1) complex(kind=default), intent(in) :: g type(vector), intent(in) :: v2, v3, v4 type(momentum), intent(in) :: k2, k3, k4 type(vector) :: v1 type(momentum) :: k1 k1 = - k2 - k3 - k4 v1 = g * (k2 * (v2 * k3) * (v3 * k4) * (v4 * k1) & + k3 * (v2 * k1) * (v3 * k4) * (v4 * k2) & + k2 * (v2 * k4) * (v3 * k1) * (v4 * k3) & + k4 * (v2 * k1) * (v3 * k2) * (v4 * k3) & + k4 * (v2 * k3) * (v3 * v4) * (k1 * k2) & + k3 * (v2 * k4) * (v3 * v4) * (k1 * k2) & - k3 * (v2 * v4) * (v3 * k4) * (k1 * k2) & - v4 * (v2 * k3) * (v3 * k4) * (k1 * k2) & - k4 * (v2 * v3) * (v4 * k3) * (k1 * k2) & - v3 * (v2 * k4) * (v4 * k3) * (k1 * k2) & - k2 * (v2 * k4) * (v3 * v4) * (k1 * k3) & + k2 * (v2 * v4) * (v3 * k4) * (k1 * k3) & - v2 * (v3 * k4) * (v4 * k2) * (k1 * k3) & - k2 * (v2 * k3) * (v3 * v4) * (k1 * k4) & + k2 * (v2 * v3) * (v4 * k3) * (k1 * k4) & - v2 * (v3 * k2) * (v4 * k3) * (k1 * k4) & - k4 * (v2 * k1) * (v3 * v4) * (k2 * k3) & + v4 * (v2 * k1) * (v3 * k4) * (k2 * k3) & - v2 * (v3 * k4) * (v4 * k1) * (k2 * k3) & + v2 * (v3 * v4) * (k1 * k4) * (k2 * k3) & - k3 * (v2 * k1) * (v3 * v4) * (k2 * k4) & + v3 * (v2 * k1) * (v4 * k3) * (k2 * k4) & - v2 * (v3 * k1) * (v4 * k3) * (k2 * k4) & + v2 * (v3 * v4) * (k1 * k3) * (k2 * k4) & - k2 * (v2 * v4) * (v3 * k1) * (k3 * k4) & - v4 * (v2 * k1) * (v3 * k2) * (k3 * k4) & - k2 * (v2 * v3) * (v4 * k1) * (k3 * k4) & + v2 * (v3 * k2) * (v4 * k1) * (k3 * k4) & - v3 * (v2 * k1) * (v4 * k2) * (k3 * k4) & + v2 * (v3 * k1) * (v4 * k2) * (k3 * k4) & + v4 * (v2 * v3) * (k1 * k2) * (k3 * k4) & + v3 * (v2 * v4) * (k1 * k2) * (k3 * k4)) end function g_dim8g3_t_2 @ \section{Mixed Gauge4 Dim-8 Couplings} <>= public :: g_dim8g3_m_0, g_dim8g3_m_1, g_dim8g3_m_7 @ \begin{equation} V_1^\mu = g_1 \left [ V_2^\mu \left (V_3 \cdot V_4\right ) \left (k_1 \cdot k_2\right ) \\ - k_2^\mu \left (V_2 \cdot k_1\right ) \left (V_3 \cdot V_4\right ) \\ \right ] \\ + g_2 \left [ V_2^\mu \left (V_3 \cdot V_4\right ) \left (k_3 \cdot k_4\right ) \\ - V_2^\mu \left (V_3 \cdot k_4\right ) \left (V_4 \cdot k_3\right ) \\ \right ] \end{equation} <>= pure function g_dim8g3_m_0 (g1, g2, v2, k2, v3, k3, v4, k4) result (v1) complex(kind=default), intent(in) :: g1, g2 type(vector), intent(in) :: v2, v3, v4 type(momentum), intent(in) :: k2, k3, k4 type(vector) :: v1 type(momentum) :: k1 k1 = - k2 - k3 - k4 v1 = g1 * (v2 * (v3 * v4) * (k1 * k2) & - k2 * (v2 * k1) * (v3 * v4)) & + g2 * (v2 * (v3 * v4) * (k3 * k4) & - v2 * (v3 * k4) * (v4 * k3)) end function g_dim8g3_m_0 @ \begin{equation} V_1^\mu = g_1 \left [ k_2^\mu \left (V_2 \cdot V_4\right ) \left (V_3 \cdot k_1\right ) \\ + V_4^\mu \left (V_2 \cdot k_1\right ) \left (V_3 \cdot k_2\right ) \\ + k_2^\mu \left (V_2 \cdot V_3\right ) \left (V_4 \cdot k_1\right ) \\ + V_3^\mu \left (V_2 \cdot k_1\right ) \left (V_4 \cdot k_2\right ) \\ - V_2^\mu \left (V_3 \cdot k_2\right ) \left (V_4 \cdot k_1\right ) \\ - V_2^\mu \left (V_3 \cdot k_1\right ) \left (V_4 \cdot k_2\right ) \\ - V_4^\mu \left (V_2 \cdot V_3\right ) \left (k_1 \cdot k_2\right ) \\ - V_3^\mu \left (V_2 \cdot V_4\right ) \left (k_1 \cdot k_2\right ) \\ \right ] \\ + g_2 \left [ k_3^\mu \left (V_2 \cdot V_4\right ) \left (V_3 \cdot k_4\right ) \\ - k_4^\mu \left (V_2 \cdot k_3\right ) \left (V_3 \cdot V_4\right ) \\ - k_3^\mu \left (V_2 \cdot k_4\right ) \left (V_3 \cdot V_4\right ) \\ + V_4^\mu \left (V_2 \cdot k_3\right ) \left (V_3 \cdot k_4\right ) \\ + k_4^\mu \left (V_2 \cdot V_3\right ) \left (V_4 \cdot k_3\right ) \\ + V_3^\mu \left (V_2 \cdot k_4\right ) \left (V_4 \cdot k_3\right ) \\ - V_4^\mu \left (V_2 \cdot V_3\right ) \left (k_3 \cdot k_4\right ) \\ - V_3^\mu \left (V_2 \cdot V_4\right ) \left (k_3 \cdot k_4\right ) \\ \right ] \end{equation} <>= pure function g_dim8g3_m_1 (g1, g2, v2, k2, v3, k3, v4, k4) result (v1) complex(kind=default), intent(in) :: g1, g2 type(vector), intent(in) :: v2, v3, v4 type(momentum), intent(in) :: k2, k3, k4 type(vector) :: v1 type(momentum) :: k1 k1 = - k2 - k3 - k4 v1 = g1 * (k2 * (v2 * v4) * (v3 * k1) & + v4 * (v2 * k1) * (v3 * k2) & + k2 * (v2 * v3) * (v4 * k1) & + v3 * (v2 * k1) * (v4 * k2) & - v2 * (v3 * k2) * (v4 * k1) & - v2 * (v3 * k1) * (v4 * k2) & - v4 * (v2 * v3) * (k1 * k2) & - v3 * (v2 * v4) * (k1 * k2)) & + g2 * (k3 * (v2 * v4) * (v3 * k4) & - k4 * (v2 * k3) * (v3 * v4) & - k3 * (v2 * k4) * (v3 * v4) & + v4 * (v2 * k3) * (v3 * k4) & + k4 * (v2 * v3) * (v4 * k3) & + v3 * (v2 * k4) * (v4 * k3) & - v4 * (v2 * v3) * (k3 * k4) & - v3 * (v2 * v4) * (k3 * k4)) end function g_dim8g3_m_1 @ \begin{equation} V_1^\mu = g_1 \left [ V_2^\mu \left (V_3 \cdot k_2\right ) \left (V_4 \cdot k_1\right ) \\ + V_2^\mu \left (V_4 \cdot k_1\right ) \left (V_4 \cdot k_2\right ) \\ + V_4^\mu \left (V_2 \cdot V_3\right ) \left (k_1 \cdot k_2\right ) \\ + V_3^\mu \left (V_2 \cdot V_4\right ) \left (k_1 \cdot k_2\right ) \\ - k_2^\mu \left (V_2 \cdot V_4\right ) \left (V_3 \cdot k_1\right ) \\ - V_4^\mu \left (V_2 \cdot k_1\right ) \left (V_3 \cdot k_2\right ) \\ - k_2^\mu \left (V_2 \cdot V_3\right ) \left (V_4 \cdot k_1\right ) \\ - V_3^\mu \left (V_2 \cdot k_1\right ) \left (V_4 \cdot k_2\right ) \\ \right ] \\ + g_2 \left [ k_3^\mu \left (V_2 \cdot k_1\right ) \left (V_3 \cdot V_4\right ) \\ + k_4^\mu \left (V_2 \cdot k_1\right ) \left (V_3 \cdot V_4\right ) \\ + k_2^\mu \left (V_2 \cdot k_3\right ) \left (V_3 \cdot V_4\right ) \\ + k_2^\mu \left (V_2 \cdot k_4\right ) \left (V_3 \cdot V_4\right ) \\ + V_4^\mu \left (V_2 \cdot k_4\right ) \left (V_3 \cdot k_1\right ) \\ + k_4^\mu \left (V_2 \cdot V_4\right ) \left (V_3 \cdot k_2\right ) \\ + V_3^\mu \left (V_2 \cdot k_3\right ) \left (V_4 \cdot k_1\right ) \\ + V_2^\mu \left (V_3 \cdot k_4\right ) \left (V_4 \cdot k_1\right ) \\ + V_3^\mu \left (V_2 \cdot V_3\right ) \left (V_4 \cdot k_2\right ) \\ + V_2^\mu \left (V_3 \cdot k_4\right ) \left (V_4 \cdot k_2\right ) \\ + V_2^\mu \left (V_3 \cdot k_1\right ) \left (V_4 \cdot k_3\right ) \\ + V_2^\mu \left (V_3 \cdot k_2\right ) \left (V_4 \cdot k_3\right ) \\ + V_4^\mu \left (V_2 \cdot V_3\right ) \left (k_1 \cdot k_3\right ) \\ + V_3^\mu \left (V_2 \cdot V_4\right ) \left (k_1 \cdot k_4\right ) \\ + V_3^\mu \left (V_2 \cdot V_4\right ) \left (k_2 \cdot k_3\right ) \\ + V_4^\mu \left (V_2 \cdot V_3\right ) \left (k_2 \cdot k_4\right ) \\ - k_4^\mu \left (V_2 \cdot V_4\right ) \left (V_3 \cdot k_1\right ) \\ - V_4^\mu \left (V_2 \cdot k_3\right ) \left (V_3 \cdot k_1\right ) \\ - k_3^\mu \left (V_2 \cdot V_4\right ) \left (V_3 \cdot k_2\right ) \\ - V_4^\mu \left (V_2 \cdot k_4\right ) \left (V_3 \cdot k_2\right ) \\ - k_2^\mu \left (V_2 \cdot V_4\right ) \left (V_3 \cdot k_4\right ) \\ - V_4^\mu \left (V_2 \cdot k_1\right ) \left (V_3 \cdot k_4\right ) \\ - k_3^\mu \left (V_2 \cdot V_3\right ) \left (V_4 \cdot k_1\right ) \\ - V_3^\mu \left (V_2 \cdot k_4\right ) \left (V_4 \cdot k_1\right ) \\ - k_4^\mu \left (V_2 \cdot V_3\right ) \left (V_4 \cdot k_2\right ) \\ - V_3^\mu \left (V_2 \cdot k_3\right ) \left (V_4 \cdot k_2\right ) \\ - k_2^\mu \left (V_2 \cdot V_3\right ) \left (V_4 \cdot k_3\right ) \\ - V_3^\mu \left (V_2 \cdot k_1\right ) \left (V_4 \cdot k_3\right ) \\ - V_2^\mu \left (V_3 \cdot V_4\right ) \left (k_1 \cdot k_3\right ) \\ - V_2^\mu \left (V_3 \cdot V_4\right ) \left (k_1 \cdot k_4\right ) \\ - V_2^\mu \left (V_3 \cdot V_4\right ) \left (k_2 \cdot k_3\right ) \\ - V_2^\mu \left (V_3 \cdot V_4\right ) \left (k_2 \cdot k_4\right ) \\ \right ] + g_3 \left [ k_4^\mu \left (V_2 \cdot k_3\right ) \left (V_3 \cdot V_4\right ) \\ + k_3^\mu \left (V_2 \cdot k_4\right ) \left (V_3 \cdot V_4\right ) \\ + V_4^\mu \left (V_2 \cdot V_3\right ) \left (k_3 \cdot k_4\right ) \\ + V_3^\mu \left (V_2 \cdot V_4\right ) \left (k_3 \cdot k_4\right ) \\ - k_3^\mu \left (V_2 \cdot V_4\right ) \left (V_3 \cdot k_4\right ) \\ - V_4^\mu \left (V_2 \cdot k_3\right ) \left (V_3 \cdot k_4\right ) \\ - k_4^\mu \left (V_2 \cdot V_3\right ) \left (V_4 \cdot k_3\right ) \\ - V_3^\mu \left (V_2 \cdot k_4\right ) \left (V_4 \cdot k_3\right ) \\ \right ] \end{equation} <>= pure function g_dim8g3_m_7 (g1, g2, g3, v2, k2, v3, k3, v4, k4) result (v1) complex(kind=default), intent(in) :: g1, g2, g3 type(vector), intent(in) :: v2, v3, v4 type(momentum), intent(in) :: k2, k3, k4 type(vector) :: v1 type(momentum) :: k1 k1 = - k2 - k3 - k4 v1 = g1 * (v2 * (v3 * k2) * (v4 * k1) & + v2 * (v3 * k1) * (v4 * k2) & + v4 * (v2 * v3) * (k1 * k2) & + v3 * (v2 * v4) * (k1 * k2) & - k2 * (v2 * v4) * (v3 * k1) & - v4 * (v2 * k1) * (v3 * k2) & - k2 * (v2 * v3) * (v4 * k1) & - v3 * (v2 * k1) * (v4 * k2)) & + g2 * (k3 * (v2 * k1) * (v3 * v4) & + k4 * (v2 * k1) * (v3 * v4) & + k2 * (v2 * k3) * (v3 * v4) & + k2 * (v2 * k4) * (v3 * v4) & + v4 * (v2 * k4) * (v3 * k1) & + k4 * (v2 * v4) * (v3 * k2) & + v3 * (v2 * k3) * (v4 * k1) & + v2 * (v3 * k4) * (v4 * k1) & + k3 * (v2 * v3) * (v4 * k2) & + v2 * (v3 * k4) * (v4 * k2) & + v2 * (v3 * k1) * (v4 * k3) & + v2 * (v3 * k2) * (v4 * k3) & + v4 * (v2 * v3) * (k1 * k3) & + v3 * (v2 * v4) * (k1 * k4) & + v3 * (v2 * v4) * (k2 * k3) & + v4 * (v2 * v3) * (k2 * k4) & - k4 * (v2 * v4) * (v3 * k1) & - v4 * (v2 * k3) * (v3 * k1) & - k3 * (v2 * v4) * (v3 * k2) & - v4 * (v2 * k4) * (v3 * k2) & - k2 * (v2 * v4) * (v3 * k4) & - v4 * (v2 * k1) * (v3 * k4) & - k3 * (v2 * v3) * (v4 * k1) & - v3 * (v2 * k4) * (v4 * k1) & - k4 * (v2 * v3) * (v4 * k2) & - v3 * (v2 * k3) * (v4 * k2) & - k2 * (v2 * v3) * (v4 * k3) & - v3 * (v2 * k1) * (v4 * k3) & - v2 * (v3 * v4) * (k1 * k3) & - v2 * (v3 * v4) * (k1 * k4) & - v2 * (v3 * v4) * (k2 * k3) & - v2 * (v3 * v4) * (k2 * k4)) & + g3 * (k4 * (v2 * k3) * (v3 * v4) & + k3 * (v2 * k4) * (v3 * v4) & + v4 * (v2 * v3) * (k3 * k4) & + v3 * (v2 * v4) * (k3 * k4) & - k3 * (v2 * v4) * (v3 * k4) & - v4 * (v2 * k3) * (v3 * k4) & - k4 * (v2 * v3) * (v4 * k3) & - v3 * (v2 * k4) * (v4 * k3)) end function g_dim8g3_m_7 @ \section{Graviton Couplings} <>= public :: s_gravs, v_gravv, grav_ss, grav_vv @ <>= pure function s_gravs (g, m, k1, k2, t, s) result (phi) complex(kind=default), intent(in) :: g, s real(kind=default), intent(in) :: m type(momentum), intent(in) :: k1, k2 type(tensor), intent(in) :: t complex(kind=default) :: phi, t_tr t_tr = t%t(0,0) - t%t(1,1) - t%t(2,2) - t%t(3,3) phi = g * s * (((t*k1)*k2) + ((t*k2)*k1) & - g * (m**2 + (k1*k2))*t_tr)/2.0_default end function s_gravs @ <>= pure function grav_ss (g, m, k1, k2, s1, s2) result (t) complex(kind=default), intent(in) :: g, s1, s2 real(kind=default), intent(in) :: m type(momentum), intent(in) :: k1, k2 type(tensor) :: t_metric, t t_metric%t = 0 t_metric%t(0,0) = 1.0_default t_metric%t(1,1) = - 1.0_default t_metric%t(2,2) = - 1.0_default t_metric%t(3,3) = - 1.0_default t = g*s1*s2/2.0_default * (-(m**2 + (k1*k2)) * t_metric & + (k1.tprod.k2) + (k2.tprod.k1)) end function grav_ss @ <>= pure function v_gravv (g, m, k1, k2, t, v) result (vec) complex(kind=default), intent(in) :: g real(kind=default), intent(in) :: m type(momentum), intent(in) :: k1, k2 type(vector), intent(in) :: v type(tensor), intent(in) :: t complex(kind=default) :: t_tr real(kind=default) :: xi type(vector) :: vec xi = 1.0_default t_tr = t%t(0,0) - t%t(1,1) - t%t(2,2) - t%t(3,3) vec = (-g)/ 2.0_default * (((k1*k2) + m**2) * & (t*v + v*t - t_tr * v) + t_tr * (k1*v) * k2 & - (k1*v) * ((k2*t) + (t*k2)) & - ((k1*(t*v)) + (v*(t*k1))) * k2 & + ((k1*(t*k2)) + (k2*(t*k1))) * v) !!! Unitarity gauge: xi -> Infinity !!! + (1.0_default/xi) * (t_tr * ((k1*v)*k2) + & !!! (k2*v)*k2 + (k2*v)*k1 - (k1*(t*v))*k1 + & !!! (k2*v)*(k2*t) - (v*(t*k1))*k1 - (k2*v)*(t*k2))) end function v_gravv @ <>= pure function grav_vv (g, m, k1, k2, v1, v2) result (t) complex(kind=default), intent(in) :: g type(momentum), intent(in) :: k1, k2 real(kind=default), intent(in) :: m real(kind=default) :: xi type(vector), intent (in) :: v1, v2 type(tensor) :: t_metric, t xi = 0.00001_default t_metric%t = 0 t_metric%t(0,0) = 1.0_default t_metric%t(1,1) = - 1.0_default t_metric%t(2,2) = - 1.0_default t_metric%t(3,3) = - 1.0_default t = (-g)/2.0_default * ( & ((k1*k2) + m**2) * ( & (v1.tprod.v2) + (v2.tprod.v1) - (v1*v2) * t_metric) & + (v1*k2)*(v2*k1)*t_metric & - (k2*v1)*((v2.tprod.k1) + (k1.tprod.v2)) & - (k1*v2)*((v1.tprod.k2) + (k2.tprod.v1)) & + (v1*v2)*((k1.tprod.k2) + (k2.tprod.k1))) !!! Unitarity gauge: xi -> Infinity !!! + (1.0_default/xi) * ( & !!! ((k1*v1)*(k1*v2) + (k2*v1)*(k2*v2) + (k1*v1)*(k2*v2))* & !!! t_metric) - (k1*v1) * ((k1.tprod.v2) + (v2.tprod.k1)) & !!! - (k2*v2) * ((k2.tprod.v1) + (v1.tprod.k2))) end function grav_vv @ \section{Tensor Couplings} <>= public :: t2_vv, v_t2v, t2_vv_cf, v_t2v_cf, & t2_vv_1, v_t2v_1, t2_vv_t, v_t2v_t, & t2_phi2, phi_t2phi, t2_phi2_cf, phi_t2phi_cf @ \begin{equation} T_{\mu\nu} = g * V_{1 \,\mu} V_{2\,\nu} + V_{1\,\nu} V_{2\,\mu} \end{equation} <>= pure function t2_vv (g, v1, v2) result (t) complex(kind=default), intent(in) :: g type(vector), intent(in) :: v1, v2 type(tensor) :: t type(tensor) :: tmp tmp = v1.tprod.v2 t%t = g * (tmp%t + transpose (tmp%t)) end function t2_vv @ \begin{equation} V_{1\,\mu} = g * T_{\mu \nu} V_{2}^{\nu}+ T_{\nu \mu} V_{2}^{\nu} \end{equation} <>= pure function v_t2v (g, t, v) result (tv) complex(kind=default), intent(in) :: g type(tensor), intent(in) :: t type(vector), intent(in) :: v type(vector) :: tv type(tensor) :: tmp tmp%t = t%t + transpose (t%t) tv = g * (tmp * v) end function v_t2v @ \begin{equation} T_{\mu\nu} =- \frac{g}{2} V_1^\rho V_{2 \,\rho} \end{equation} <>= pure function t2_vv_cf (g, v1, v2) result (t) complex(kind=default), intent(in) :: g complex(kind=default) :: tmp_s type(vector), intent(in) :: v1, v2 type(tensor) :: t_metric, t t_metric%t = 0 t_metric%t(0,0) = 1.0_default t_metric%t(1,1) = - 1.0_default t_metric%t(2,2) = - 1.0_default t_metric%t(3,3) = - 1.0_default tmp_s = v1 * v2 t%t = - (g /2.0_default) * tmp_s * t_metric%t end function t2_vv_cf @ \begin{equation} V_{1\,\mu} = -\frac{g}{2} T^{\nu}_{ \nu} V_{2}^{\mu} \end{equation} <>= pure function v_t2v_cf (g, t, v) result (tv) complex(kind=default), intent(in) :: g type(tensor), intent(in) :: t type(vector), intent(in) :: v type(vector) :: tv, tmp_tv tmp_tv = ( t%t(0,0)-t%t(1,1)-t%t(2,2)-t%t(3,3) ) * v tv = - ( g /2.0_default) * tmp_tv end function v_t2v_cf @ \begin{equation} T_{\mu\nu} = g * \left ( k_{1 \,\mu} k_{2\,\nu} + k_{1\,\nu} k_{2\,\mu} \right ) \phi_1 \left ( k_1 \right ) \phi_1 \left ( k_2 \right ) \end{equation} <>= pure function t2_phi2 (g, phi1, k1, phi2, k2) result (t) complex(kind=default), intent(in) :: g, phi1, phi2 type(momentum), intent(in) :: k1, k2 type(tensor) :: t type(tensor) :: tmp tmp = k1.tprod.k2 t%t = g * (tmp%t + transpose (tmp%t)) * phi1 * phi2 end function t2_phi2 @ \begin{equation} \phi_{1} (k_1) =g * \left ( T_{\mu \nu} k_{1}^{\mu}k_{2}^{\nu} + T_{\nu \mu} k_{2}^{\mu}k_{1}^{\nu} \right ) \phi_2 \left (k_2 \right ) \end{equation} <>= pure function phi_t2phi (g, t, kt, phi2, k2) result (phi1) complex(kind=default), intent(in) :: g, phi2 type(tensor), intent(in) :: t type(momentum), intent(in) :: kt, k2 type(momentum) :: k1 complex(kind=default) :: phi1 type(tensor) :: tmp k1 = -kt - k2 tmp%t = t%t + transpose (t%t) phi1 = g * ( (tmp * k2) * k1) * phi2 end function phi_t2phi @ \begin{equation} T_{\mu\nu} =- \frac{g}{2} k_1^\rho k_{2 \,\rho} \phi_1 \left ( k_1 \right ) \phi_2 \left ( k_2 \right ) \end{equation} <>= pure function t2_phi2_cf (g, phi1, k1, phi2, k2) result (t) complex(kind=default), intent(in) :: g, phi1, phi2 complex(kind=default) :: tmp_s type(momentum), intent(in) :: k1, k2 type(tensor) :: t_metric, t t_metric%t = 0 t_metric%t(0,0) = 1.0_default t_metric%t(1,1) = - 1.0_default t_metric%t(2,2) = - 1.0_default t_metric%t(3,3) = - 1.0_default tmp_s = (k1 * k2) * phi1 * phi2 t%t = - (g /2.0_default) * tmp_s * t_metric%t end function t2_phi2_cf @ \begin{equation} \phi_1 (k_1) = - \frac{g}{2} T^{\nu}_{ \nu} \left (k_1 \cdot k_2 \right ) \phi_2 (k_2) \end{equation} <>= pure function phi_t2phi_cf (g, t, kt, phi2, k2) result (phi1) complex(kind=default), intent(in) :: g, phi2 type(tensor), intent(in) :: t type(momentum), intent(in) :: kt, k2 type(momentum) :: k1 complex(kind=default) :: tmp_ts, phi1 k1 = - kt - k2 tmp_ts = ( t%t(0,0)-t%t(1,1)-t%t(2,2)-t%t(3,3) ) phi1 = - ( g /2.0_default) * tmp_ts * (k1 * k2) * phi2 end function phi_t2phi_cf @ <>= pure function t2_vv_1 (g, v1, v2) result (t) complex(kind=default), intent(in) :: g complex(kind=default) :: tmp_s type(vector), intent(in) :: v1, v2 type(tensor) :: tmp type(tensor) :: t_metric, t t_metric%t = 0 t_metric%t(0,0) = 1.0_default t_metric%t(1,1) = - 1.0_default t_metric%t(2,2) = - 1.0_default t_metric%t(3,3) = - 1.0_default tmp = v1.tprod.v2 tmp_s = v1 * v2 t%t = g * (tmp%t + transpose (tmp%t) - tmp_s * t_metric%t ) end function t2_vv_1 @ <>= pure function v_t2v_1 (g, t, v) result (tv) complex(kind=default), intent(in) :: g type(tensor), intent(in) :: t type(vector), intent(in) :: v type(vector) :: tv, tmp_tv type(tensor) :: tmp tmp_tv = ( t%t(0,0)-t%t(1,1)-t%t(2,2)-t%t(3,3) ) * v tmp%t = t%t + transpose (t%t) tv = g * (tmp * v - tmp_tv) end function v_t2v_1 @ <>= pure function t2_vv_t (g, v1, k1, v2, k2) result (t) complex(kind=default), intent(in) :: g complex(kind=default) :: tmp_s type(vector), intent(in) :: v1, v2 type(momentum), intent(in) :: k1, k2 type(tensor) :: tmp, tmp_v1k2, tmp_v2k1, tmp_k1k2, tmp2 type(tensor) :: t_metric, t t_metric%t = 0 t_metric%t(0,0) = 1.0_default t_metric%t(1,1) = - 1.0_default t_metric%t(2,2) = - 1.0_default t_metric%t(3,3) = - 1.0_default tmp = v1.tprod.v2 tmp_s = v1 * v2 tmp_v1k2 = (v2 * k1) * (v1.tprod.k2) tmp_v2k1 = (v1 * k2) * (v2.tprod.k1) tmp_k1k2 = tmp_s * (k1.tprod.k2) tmp2%t = tmp_v1k2%t + tmp_v2k1%t - tmp_k1k2%t t%t = g * ( (k1*k2) * (tmp%t + transpose (tmp%t) - tmp_s * t_metric%t ) & + ((v1 * k2) * (v2 * k1)) * t_metric%t & - tmp2%t - transpose(tmp2%t)) end function t2_vv_t @ <>= pure function v_t2v_t (g, t, kt, v, kv) result (tv) complex(kind=default), intent(in) :: g type(tensor), intent(in) :: t type(vector), intent(in) :: v type(momentum), intent(in) :: kt, kv type(momentum) :: kout type(vector) :: tv, tmp_tv type(tensor) :: tmp kout = - (kt + kv) tmp_tv = ( t%t(0,0)-t%t(1,1)-t%t(2,2)-t%t(3,3) ) * v tmp%t = t%t + transpose (t%t) tv = g * ( (tmp * v - tmp_tv) * (kv * kout )& + ( t%t(0,0)-t%t(1,1)-t%t(2,2)-t%t(3,3) ) * (kout * v ) * kv & - (kout * v) * ( tmp * kv) & - (v* (t * kout) + kout * (t * v)) * kv & + (kout* (t * kv) + kv * (t * kout)) * v) end function v_t2v_t @ <>= public :: t2_vv_d5_1, v_t2v_d5_1 @ <>= pure function t2_vv_d5_1 (g, v1, k1, v2, k2) result (t) complex(kind=default), intent(in) :: g type(vector), intent(in) :: v1, v2 type(momentum), intent(in) :: k1, k2 type(tensor) :: t t = (g * (v1 * v2)) * (k1-k2).tprod.(k1-k2) end function t2_vv_d5_1 @ <>= pure function v_t2v_d5_1 (g, t1, k1, v2, k2) result (tv) complex(kind=default), intent(in) :: g type(tensor), intent(in) :: t1 type(vector), intent(in) :: v2 type(momentum), intent(in) :: k1, k2 type(vector) :: tv tv = (g * ((k1+2*k2).tprod.(k1+2*k2) * t1)) * v2 end function v_t2v_d5_1 @ <>= public :: t2_vv_d5_2, v_t2v_d5_2 @ <>= pure function t2_vv_d5_2 (g, v1, k1, v2, k2) result (t) complex(kind=default), intent(in) :: g type(vector), intent(in) :: v1, v2 type(momentum), intent(in) :: k1, k2 type(tensor) :: t t = (g * (k2 * v1)) * (k2-k1).tprod.v2 t%t = t%t + transpose (t%t) end function t2_vv_d5_2 @ <>= pure function v_t2v_d5_2 (g, t1, k1, v2, k2) result (tv) complex(kind=default), intent(in) :: g type(tensor), intent(in) :: t1 type(vector), intent(in) :: v2 type(momentum), intent(in) :: k1, k2 type(vector) :: tv type(tensor) :: tmp type(momentum) :: k1_k2, k1_2k2 k1_k2 = k1 + k2 k1_2k2 = k1_k2 + k2 tmp%t = t1%t + transpose (t1%t) tv = (g * (k1_k2 * v2)) * (k1_2k2 * tmp) end function v_t2v_d5_2 @ <>= public :: t2_vv_d7, v_t2v_d7 @ <>= pure function t2_vv_d7 (g, v1, k1, v2, k2) result (t) complex(kind=default), intent(in) :: g type(vector), intent(in) :: v1, v2 type(momentum), intent(in) :: k1, k2 type(tensor) :: t t = (g * (k2 * v1) * (k1 * v2)) * (k1-k2).tprod.(k1-k2) end function t2_vv_d7 @ <>= pure function v_t2v_d7 (g, t1, k1, v2, k2) result (tv) complex(kind=default), intent(in) :: g type(tensor), intent(in) :: t1 type(vector), intent(in) :: v2 type(momentum), intent(in) :: k1, k2 type(vector) :: tv type(vector) :: k1_k2, k1_2k2 k1_k2 = k1 + k2 k1_2k2 = k1_k2 + k2 tv = (- g * (k1_k2 * v2) * (k1_2k2.tprod.k1_2k2 * t1)) * k2 end function v_t2v_d7 @ \section{Spinor Couplings} <<[[omega_spinor_couplings.f90]]>>= <> module omega_spinor_couplings use kinds use constants use omega_spinors use omega_vectors use omega_tensors use omega_couplings implicit none private <> <> <> <> integer, parameter, public :: omega_spinor_cpls_2010_01_A = 0 contains <> <> <> <> end module omega_spinor_couplings @ See table~\ref{tab:fermionic-currents} for the names of Fortran functions. We could have used long names instead, but this would increase the chance of running past continuation line limits without adding much to the legibility. @ \subsection{Fermionic Vector and Axial Couplings} There's more than one chiral representation. This one is compatible with HELAS~\cite{HELAS}. \begin{equation} \gamma^0 = \begin{pmatrix} 0 & \mathbf{1} \\ \mathbf{1} & 0 \end{pmatrix},\; \gamma^i = \begin{pmatrix} 0 & \sigma^i \\ -\sigma^i & 0 \end{pmatrix},\; \gamma_5 = i\gamma^0\gamma^1\gamma^2\gamma^3 = \begin{pmatrix} -\mathbf{1} & 0 \\ 0 & \mathbf{1} \end{pmatrix} \end{equation} Therefore \begin{subequations} \begin{align} g_S + g_P\gamma_5 &= \begin{pmatrix} g_S - g_P & 0 & 0 & 0 \\ 0 & g_S - g_P & 0 & 0 \\ 0 & 0 & g_S + g_P & 0 \\ 0 & 0 & 0 & g_S + g_P \end{pmatrix} \\ g_V\gamma^0 - g_A\gamma^0\gamma_5 &= \begin{pmatrix} 0 & 0 & g_V - g_A & 0 \\ 0 & 0 & 0 & g_V - g_A \\ g_V + g_A & 0 & 0 & 0 \\ 0 & g_V + g_A & 0 & 0 \end{pmatrix} \\ g_V\gamma^1 - g_A\gamma^1\gamma_5 &= \begin{pmatrix} 0 & 0 & 0 & g_V - g_A \\ 0 & 0 & g_V - g_A & 0 \\ 0 & - g_V - g_A & 0 & 0 \\ - g_V - g_A & 0 & 0 & 0 \end{pmatrix} \\ g_V\gamma^2 - g_A\gamma^2\gamma_5 &= \begin{pmatrix} 0 & 0 & 0 & -\ii(g_V - g_A) \\ 0 & 0 & \ii(g_V - g_A) & 0 \\ 0 & \ii(g_V + g_A) & 0 & 0 \\ -\ii(g_V + g_A) & 0 & 0 & 0 \end{pmatrix} \\ g_V\gamma^3 - g_A\gamma^3\gamma_5 &= \begin{pmatrix} 0 & 0 & g_V - g_A & 0 \\ 0 & 0 & 0 & - g_V + g_A \\ - g_V - g_A & 0 & 0 & 0 \\ 0 & g_V + g_A & 0 & 0 \end{pmatrix} \end{align} \end{subequations} \begin{table} \begin{center} \begin{tabular}{>{$}l<{$}|>{$}l<{$}} \bar\psi(g_V\gamma^\mu - g_A\gamma^\mu\gamma_5)\psi & \text{\texttt{va\_ff}}(g_V,g_A,\bar\psi,\psi) \\ g_V\bar\psi\gamma^\mu\psi & \text{\texttt{v\_ff}}(g_V,\bar\psi,\psi) \\ g_A\bar\psi\gamma_5\gamma^\mu\psi & \text{\texttt{a\_ff}}(g_A,\bar\psi,\psi) \\ g_L\bar\psi\gamma^\mu(1-\gamma_5)\psi & \text{\texttt{vl\_ff}}(g_L,\bar\psi,\psi) \\ g_R\bar\psi\gamma^\mu(1+\gamma_5)\psi & \text{\texttt{vr\_ff}}(g_R,\bar\psi,\psi) \\\hline \fmslash{V}(g_V - g_A\gamma_5)\psi & \text{\texttt{f\_vaf}}(g_V,g_A,V,\psi) \\ g_V\fmslash{V}\psi & \text{\texttt{f\_vf}}(g_V,V,\psi) \\ g_A\gamma_5\fmslash{V}\psi & \text{\texttt{f\_af}}(g_A,V,\psi) \\ g_L\fmslash{V}(1-\gamma_5)\psi & \text{\texttt{f\_vlf}}(g_L,V,\psi) \\ g_R\fmslash{V}(1+\gamma_5)\psi & \text{\texttt{f\_vrf}}(g_R,V,\psi) \\\hline \bar\psi\fmslash{V}(g_V - g_A\gamma_5) & \text{\texttt{f\_fva}}(g_V,g_A,\bar\psi,V) \\ g_V\bar\psi\fmslash{V} & \text{\texttt{f\_fv}}(g_V,\bar\psi,V) \\ g_A\bar\psi\gamma_5\fmslash{V} & \text{\texttt{f\_fa}}(g_A,\bar\psi,V) \\ g_L\bar\psi\fmslash{V}(1-\gamma_5) & \text{\texttt{f\_fvl}}(g_L,\bar\psi,V) \\ g_R\bar\psi\fmslash{V}(1+\gamma_5) & \text{\texttt{f\_fvr}}(g_R,\bar\psi,V) \end{tabular} \end{center} \caption{\label{tab:fermionic-currents} Mnemonically abbreviated names of Fortran functions implementing fermionic vector and axial currents.} \end{table} \begin{table} \begin{center} \begin{tabular}{>{$}l<{$}|>{$}l<{$}} \bar\psi(g_S + g_P\gamma_5)\psi & \text{\texttt{sp\_ff}}(g_S,g_P,\bar\psi,\psi) \\ g_S\bar\psi\psi & \text{\texttt{s\_ff}}(g_S,\bar\psi,\psi) \\ g_P\bar\psi\gamma_5\psi & \text{\texttt{p\_ff}}(g_P,\bar\psi,\psi) \\ g_L\bar\psi(1-\gamma_5)\psi & \text{\texttt{sl\_ff}}(g_L,\bar\psi,\psi) \\ g_R\bar\psi(1+\gamma_5)\psi & \text{\texttt{sr\_ff}}(g_R,\bar\psi,\psi) \\\hline \phi(g_S + g_P\gamma_5)\psi & \text{\texttt{f\_spf}}(g_S,g_P,\phi,\psi) \\ g_S\phi\psi & \text{\texttt{f\_sf}}(g_S,\phi,\psi) \\ g_P\phi\gamma_5\psi & \text{\texttt{f\_pf}}(g_P,\phi,\psi) \\ g_L\phi(1-\gamma_5)\psi & \text{\texttt{f\_slf}}(g_L,\phi,\psi) \\ g_R\phi(1+\gamma_5)\psi & \text{\texttt{f\_srf}}(g_R,\phi,\psi) \\\hline \bar\psi\phi(g_S + g_P\gamma_5) & \text{\texttt{f\_fsp}}(g_S,g_P,\bar\psi,\phi) \\ g_S\bar\psi\phi & \text{\texttt{f\_fs}}(g_S,\bar\psi,\phi) \\ g_P\bar\psi\phi\gamma_5 & \text{\texttt{f\_fp}}(g_P,\bar\psi,\phi) \\ g_L\bar\psi\phi(1-\gamma_5) & \text{\texttt{f\_fsl}}(g_L,\bar\psi,\phi) \\ g_R\bar\psi\phi(1+\gamma_5) & \text{\texttt{f\_fsr}}(g_R,\bar\psi,\phi) \end{tabular} \end{center} \caption{\label{tab:fermionic-scalar currents} Mnemonically abbreviated names of Fortran functions implementing fermionic scalar and pseudo scalar ``currents''.} \end{table} <>= public :: va_ff, v_ff, a_ff, vl_ff, vr_ff, vlr_ff, grav_ff, va2_ff, & tva_ff, tlr_ff, trl_ff, tvam_ff, tlrm_ff, trlm_ff, va3_ff @ <>= pure function va_ff (gv, ga, psibar, psi) result (j) type(vector) :: j complex(kind=default), intent(in) :: gv, ga type(conjspinor), intent(in) :: psibar type(spinor), intent(in) :: psi complex(kind=default) :: gl, gr complex(kind=default) :: g13, g14, g23, g24, g31, g32, g41, g42 gl = gv + ga gr = gv - ga g13 = psibar%a(1)*psi%a(3) g14 = psibar%a(1)*psi%a(4) g23 = psibar%a(2)*psi%a(3) g24 = psibar%a(2)*psi%a(4) g31 = psibar%a(3)*psi%a(1) g32 = psibar%a(3)*psi%a(2) g41 = psibar%a(4)*psi%a(1) g42 = psibar%a(4)*psi%a(2) j%t = gr * ( g13 + g24) + gl * ( g31 + g42) j%x(1) = gr * ( g14 + g23) - gl * ( g32 + g41) j%x(2) = (gr * ( - g14 + g23) + gl * ( g32 - g41)) * (0, 1) j%x(3) = gr * ( g13 - g24) + gl * ( - g31 + g42) end function va_ff @ <>= pure function va2_ff (gva, psibar, psi) result (j) type(vector) :: j complex(kind=default), intent(in), dimension(2) :: gva type(conjspinor), intent(in) :: psibar type(spinor), intent(in) :: psi complex(kind=default) :: gl, gr complex(kind=default) :: g13, g14, g23, g24, g31, g32, g41, g42 gl = gva(1) + gva(2) gr = gva(1) - gva(2) g13 = psibar%a(1)*psi%a(3) g14 = psibar%a(1)*psi%a(4) g23 = psibar%a(2)*psi%a(3) g24 = psibar%a(2)*psi%a(4) g31 = psibar%a(3)*psi%a(1) g32 = psibar%a(3)*psi%a(2) g41 = psibar%a(4)*psi%a(1) g42 = psibar%a(4)*psi%a(2) j%t = gr * ( g13 + g24) + gl * ( g31 + g42) j%x(1) = gr * ( g14 + g23) - gl * ( g32 + g41) j%x(2) = (gr * ( - g14 + g23) + gl * ( g32 - g41)) * (0, 1) j%x(3) = gr * ( g13 - g24) + gl * ( - g31 + g42) end function va2_ff @ <>= pure function va3_ff (gv, ga, psibar, psi) result (j) type(vector) :: j complex(kind=default), intent(in) :: gv, ga type(conjspinor), intent(in) :: psibar type(spinor), intent(in) :: psi j = va_ff (gv, ga, psibar, psi) j%t = 0.0_default end function va3_ff @ <>= pure function tva_ff (gv, ga, psibar, psi) result (t) type(tensor2odd) :: t complex(kind=default), intent(in) :: gv, ga type(conjspinor), intent(in) :: psibar type(spinor), intent(in) :: psi complex(kind=default) :: gl, gr complex(kind=default) :: g12, g21, g1m2, g34, g43, g3m4 gr = gv + ga gl = gv - ga g12 = psibar%a(1)*psi%a(2) g21 = psibar%a(2)*psi%a(1) g1m2 = psibar%a(1)*psi%a(1) - psibar%a(2)*psi%a(2) g34 = psibar%a(3)*psi%a(4) g43 = psibar%a(4)*psi%a(3) g3m4 = psibar%a(3)*psi%a(3) - psibar%a(4)*psi%a(4) t%e(1) = (gl * ( - g12 - g21) + gr * ( g34 + g43)) * (0, 1) t%e(2) = gl * ( - g12 + g21) + gr * ( g34 - g43) t%e(3) = (gl * ( - g1m2 ) + gr * ( g3m4 )) * (0, 1) t%b(1) = gl * ( g12 + g21) + gr * ( g34 + g43) t%b(2) = (gl * ( - g12 + g21) + gr * ( - g34 + g43)) * (0, 1) t%b(3) = gl * ( g1m2 ) + gr * ( g3m4 ) end function tva_ff @ <>= pure function tlr_ff (gl, gr, psibar, psi) result (t) type(tensor2odd) :: t complex(kind=default), intent(in) :: gl, gr type(conjspinor), intent(in) :: psibar type(spinor), intent(in) :: psi t = tva_ff (gr+gl, gr-gl, psibar, psi) end function tlr_ff @ <>= pure function trl_ff (gr, gl, psibar, psi) result (t) type(tensor2odd) :: t complex(kind=default), intent(in) :: gl, gr type(conjspinor), intent(in) :: psibar type(spinor), intent(in) :: psi t = tva_ff (gr+gl, gr-gl, psibar, psi) end function trl_ff @ <>= pure function tvam_ff (gv, ga, psibar, psi, p) result (j) type(vector) :: j complex(kind=default), intent(in) :: gv, ga type(conjspinor), intent(in) :: psibar type(spinor), intent(in) :: psi type(momentum), intent(in) :: p j = (tva_ff(gv, ga, psibar, psi) * p) * (0,1) end function tvam_ff @ <>= pure function tlrm_ff (gl, gr, psibar, psi, p) result (j) type(vector) :: j complex(kind=default), intent(in) :: gl, gr type(conjspinor), intent(in) :: psibar type(spinor), intent(in) :: psi type(momentum), intent(in) :: p j = tvam_ff (gr+gl, gr-gl, psibar, psi, p) end function tlrm_ff @ <>= pure function trlm_ff (gr, gl, psibar, psi, p) result (j) type(vector) :: j complex(kind=default), intent(in) :: gl, gr type(conjspinor), intent(in) :: psibar type(spinor), intent(in) :: psi type(momentum), intent(in) :: p j = tvam_ff (gr+gl, gr-gl, psibar, psi, p) end function trlm_ff @ Special cases that avoid some multiplications <>= pure function v_ff (gv, psibar, psi) result (j) type(vector) :: j complex(kind=default), intent(in) :: gv type(conjspinor), intent(in) :: psibar type(spinor), intent(in) :: psi complex(kind=default) :: g13, g14, g23, g24, g31, g32, g41, g42 g13 = psibar%a(1)*psi%a(3) g14 = psibar%a(1)*psi%a(4) g23 = psibar%a(2)*psi%a(3) g24 = psibar%a(2)*psi%a(4) g31 = psibar%a(3)*psi%a(1) g32 = psibar%a(3)*psi%a(2) g41 = psibar%a(4)*psi%a(1) g42 = psibar%a(4)*psi%a(2) j%t = gv * ( g13 + g24 + g31 + g42) j%x(1) = gv * ( g14 + g23 - g32 - g41) j%x(2) = gv * ( - g14 + g23 + g32 - g41) * (0, 1) j%x(3) = gv * ( g13 - g24 - g31 + g42) end function v_ff @ <>= pure function a_ff (ga, psibar, psi) result (j) type(vector) :: j complex(kind=default), intent(in) :: ga type(conjspinor), intent(in) :: psibar type(spinor), intent(in) :: psi complex(kind=default) :: g13, g14, g23, g24, g31, g32, g41, g42 g13 = psibar%a(1)*psi%a(3) g14 = psibar%a(1)*psi%a(4) g23 = psibar%a(2)*psi%a(3) g24 = psibar%a(2)*psi%a(4) g31 = psibar%a(3)*psi%a(1) g32 = psibar%a(3)*psi%a(2) g41 = psibar%a(4)*psi%a(1) g42 = psibar%a(4)*psi%a(2) j%t = ga * ( - g13 - g24 + g31 + g42) j%x(1) = - ga * ( g14 + g23 + g32 + g41) j%x(2) = ga * ( g14 - g23 + g32 - g41) * (0, 1) j%x(3) = ga * ( - g13 + g24 - g31 + g42) end function a_ff @ <>= pure function vl_ff (gl, psibar, psi) result (j) type(vector) :: j complex(kind=default), intent(in) :: gl type(conjspinor), intent(in) :: psibar type(spinor), intent(in) :: psi complex(kind=default) :: gl2 complex(kind=default) :: g31, g32, g41, g42 gl2 = 2 * gl g31 = psibar%a(3)*psi%a(1) g32 = psibar%a(3)*psi%a(2) g41 = psibar%a(4)*psi%a(1) g42 = psibar%a(4)*psi%a(2) j%t = gl2 * ( g31 + g42) j%x(1) = - gl2 * ( g32 + g41) j%x(2) = gl2 * ( g32 - g41) * (0, 1) j%x(3) = gl2 * ( - g31 + g42) end function vl_ff @ <>= pure function vr_ff (gr, psibar, psi) result (j) type(vector) :: j complex(kind=default), intent(in) :: gr type(conjspinor), intent(in) :: psibar type(spinor), intent(in) :: psi complex(kind=default) :: gr2 complex(kind=default) :: g13, g14, g23, g24 gr2 = 2 * gr g13 = psibar%a(1)*psi%a(3) g14 = psibar%a(1)*psi%a(4) g23 = psibar%a(2)*psi%a(3) g24 = psibar%a(2)*psi%a(4) j%t = gr2 * ( g13 + g24) j%x(1) = gr2 * ( g14 + g23) j%x(2) = gr2 * ( - g14 + g23) * (0, 1) j%x(3) = gr2 * ( g13 - g24) end function vr_ff @ <>= pure function grav_ff (g, m, kb, k, psibar, psi) result (j) type(tensor) :: j complex(kind=default), intent(in) :: g real(kind=default), intent(in) :: m type(conjspinor), intent(in) :: psibar type(spinor), intent(in) :: psi type(momentum), intent(in) :: kb, k complex(kind=default) :: g2, g8, c_dum type(vector) :: v_dum type(tensor) :: t_metric t_metric%t = 0 t_metric%t(0,0) = 1.0_default t_metric%t(1,1) = - 1.0_default t_metric%t(2,2) = - 1.0_default t_metric%t(3,3) = - 1.0_default g2 = g/2.0_default g8 = g/8.0_default v_dum = v_ff(g8, psibar, psi) c_dum = (- m) * s_ff (g2, psibar, psi) - (kb+k)*v_dum j = c_dum*t_metric - (((kb+k).tprod.v_dum) + & (v_dum.tprod.(kb+k))) end function grav_ff @ \begin{equation} g_L\gamma_\mu(1-\gamma_5) + g_R\gamma_\mu(1+\gamma_5) = (g_L+g_R)\gamma_\mu - (g_L-g_R)\gamma_\mu\gamma_5 = g_V\gamma_\mu - g_A\gamma_\mu\gamma_5 \end{equation} \ldots{} give the compiler the benefit of the doubt that it will optimize the function all. If not, we could inline it \ldots <>= pure function vlr_ff (gl, gr, psibar, psi) result (j) type(vector) :: j complex(kind=default), intent(in) :: gl, gr type(conjspinor), intent(in) :: psibar type(spinor), intent(in) :: psi j = va_ff (gl+gr, gl-gr, psibar, psi) end function vlr_ff @ and \begin{equation} \fmslash{v} - \fmslash{a}\gamma_5 = \begin{pmatrix} 0 & 0 & v_- - a_- & - v^* + a^* \\ 0 & 0 & - v + a & v_+ - a_+ \\ v_+ + a_+ & v^* + a^* & 0 & 0 \\ v + a & v_- + a_- & 0 & 0 \end{pmatrix} \end{equation} with $v_\pm=v_0\pm v_3$, $a_\pm=a_0\pm a_3$, $v=v_1+\ii v_2$, $v^*=v_1-\ii v_2$, $a=a_1+\ii a_2$, and $a^*=a_1-\ii a_2$. But note that~$\cdot^*$ is \emph{not} complex conjugation for complex~$v_\mu$ or~$a_\mu$. <>= public :: f_vaf, f_vf, f_af, f_vlf, f_vrf, f_vlrf, f_va2f, & f_tvaf, f_tlrf, f_trlf, f_tvamf, f_tlrmf, f_trlmf, f_va3f @ <>= pure function f_vaf (gv, ga, v, psi) result (vpsi) type(spinor) :: vpsi complex(kind=default), intent(in) :: gv, ga type(vector), intent(in) :: v type(spinor), intent(in) :: psi complex(kind=default) :: gl, gr complex(kind=default) :: vp, vm, v12, v12s gl = gv + ga gr = gv - ga vp = v%t + v%x(3) vm = v%t - v%x(3) v12 = v%x(1) + (0,1)*v%x(2) v12s = v%x(1) - (0,1)*v%x(2) vpsi%a(1) = gr * ( vm * psi%a(3) - v12s * psi%a(4)) vpsi%a(2) = gr * ( - v12 * psi%a(3) + vp * psi%a(4)) vpsi%a(3) = gl * ( vp * psi%a(1) + v12s * psi%a(2)) vpsi%a(4) = gl * ( v12 * psi%a(1) + vm * psi%a(2)) end function f_vaf @ <>= pure function f_va2f (gva, v, psi) result (vpsi) type(spinor) :: vpsi complex(kind=default), intent(in), dimension(2) :: gva type(vector), intent(in) :: v type(spinor), intent(in) :: psi complex(kind=default) :: gl, gr complex(kind=default) :: vp, vm, v12, v12s gl = gva(1) + gva(2) gr = gva(1) - gva(2) vp = v%t + v%x(3) vm = v%t - v%x(3) v12 = v%x(1) + (0,1)*v%x(2) v12s = v%x(1) - (0,1)*v%x(2) vpsi%a(1) = gr * ( vm * psi%a(3) - v12s * psi%a(4)) vpsi%a(2) = gr * ( - v12 * psi%a(3) + vp * psi%a(4)) vpsi%a(3) = gl * ( vp * psi%a(1) + v12s * psi%a(2)) vpsi%a(4) = gl * ( v12 * psi%a(1) + vm * psi%a(2)) end function f_va2f @ <>= pure function f_va3f (gv, ga, v, psi) result (vpsi) type(spinor) :: vpsi complex(kind=default), intent(in) :: gv, ga type(vector), intent(in) :: v type(spinor), intent(in) :: psi complex(kind=default) :: gl, gr complex(kind=default) :: vp, vm, v12, v12s gl = gv + ga gr = gv - ga vp = v%x(3) !+ v%t vm = - v%x(3) !+ v%t v12 = v%x(1) + (0,1)*v%x(2) v12s = v%x(1) - (0,1)*v%x(2) vpsi%a(1) = gr * ( vm * psi%a(3) - v12s * psi%a(4)) vpsi%a(2) = gr * ( - v12 * psi%a(3) + vp * psi%a(4)) vpsi%a(3) = gl * ( vp * psi%a(1) + v12s * psi%a(2)) vpsi%a(4) = gl * ( v12 * psi%a(1) + vm * psi%a(2)) end function f_va3f @ <>= pure function f_tvaf (gv, ga, t, psi) result (tpsi) type(spinor) :: tpsi complex(kind=default), intent(in) :: gv, ga type(tensor2odd), intent(in) :: t type(spinor), intent(in) :: psi complex(kind=default) :: gl, gr complex(kind=default) :: e21, e21s, b12, b12s, be3, be3s gr = gv + ga gl = gv - ga e21 = t%e(2) + t%e(1)*(0,1) e21s = t%e(2) - t%e(1)*(0,1) b12 = t%b(1) + t%b(2)*(0,1) b12s = t%b(1) - t%b(2)*(0,1) be3 = t%b(3) + t%e(3)*(0,1) be3s = t%b(3) - t%e(3)*(0,1) tpsi%a(1) = 2*gl * ( psi%a(1) * be3 + psi%a(2) * ( e21 +b12s)) tpsi%a(2) = 2*gl * ( - psi%a(2) * be3 + psi%a(1) * (-e21s+b12 )) tpsi%a(3) = 2*gr * ( psi%a(3) * be3s + psi%a(4) * (-e21 +b12s)) tpsi%a(4) = 2*gr * ( - psi%a(4) * be3s + psi%a(3) * ( e21s+b12 )) end function f_tvaf @ <>= pure function f_tlrf (gl, gr, t, psi) result (tpsi) type(spinor) :: tpsi complex(kind=default), intent(in) :: gl, gr type(tensor2odd), intent(in) :: t type(spinor), intent(in) :: psi tpsi = f_tvaf (gr+gl, gr-gl, t, psi) end function f_tlrf @ <>= pure function f_trlf (gr, gl, t, psi) result (tpsi) type(spinor) :: tpsi complex(kind=default), intent(in) :: gl, gr type(tensor2odd), intent(in) :: t type(spinor), intent(in) :: psi tpsi = f_tvaf (gr+gl, gr-gl, t, psi) end function f_trlf @ <>= pure function f_tvamf (gv, ga, v, psi, k) result (vpsi) type(spinor) :: vpsi complex(kind=default), intent(in) :: gv, ga type(vector), intent(in) :: v type(spinor), intent(in) :: psi type(momentum), intent(in) :: k type(tensor2odd) :: t t = (v.wedge.k) * (0, 0.5) vpsi = f_tvaf(gv, ga, t, psi) end function f_tvamf @ <>= pure function f_tlrmf (gl, gr, v, psi, k) result (vpsi) type(spinor) :: vpsi complex(kind=default), intent(in) :: gl, gr type(vector), intent(in) :: v type(spinor), intent(in) :: psi type(momentum), intent(in) :: k vpsi = f_tvamf (gr+gl, gr-gl, v, psi, k) end function f_tlrmf @ <>= pure function f_trlmf (gr, gl, v, psi, k) result (vpsi) type(spinor) :: vpsi complex(kind=default), intent(in) :: gl, gr type(vector), intent(in) :: v type(spinor), intent(in) :: psi type(momentum), intent(in) :: k vpsi = f_tvamf (gr+gl, gr-gl, v, psi, k) end function f_trlmf @ <>= pure function f_vf (gv, v, psi) result (vpsi) type(spinor) :: vpsi complex(kind=default), intent(in) :: gv type(vector), intent(in) :: v type(spinor), intent(in) :: psi complex(kind=default) :: vp, vm, v12, v12s vp = v%t + v%x(3) vm = v%t - v%x(3) v12 = v%x(1) + (0,1)*v%x(2) v12s = v%x(1) - (0,1)*v%x(2) vpsi%a(1) = gv * ( vm * psi%a(3) - v12s * psi%a(4)) vpsi%a(2) = gv * ( - v12 * psi%a(3) + vp * psi%a(4)) vpsi%a(3) = gv * ( vp * psi%a(1) + v12s * psi%a(2)) vpsi%a(4) = gv * ( v12 * psi%a(1) + vm * psi%a(2)) end function f_vf @ <>= pure function f_af (ga, v, psi) result (vpsi) type(spinor) :: vpsi complex(kind=default), intent(in) :: ga type(vector), intent(in) :: v type(spinor), intent(in) :: psi complex(kind=default) :: vp, vm, v12, v12s vp = v%t + v%x(3) vm = v%t - v%x(3) v12 = v%x(1) + (0,1)*v%x(2) v12s = v%x(1) - (0,1)*v%x(2) vpsi%a(1) = ga * ( - vm * psi%a(3) + v12s * psi%a(4)) vpsi%a(2) = ga * ( v12 * psi%a(3) - vp * psi%a(4)) vpsi%a(3) = ga * ( vp * psi%a(1) + v12s * psi%a(2)) vpsi%a(4) = ga * ( v12 * psi%a(1) + vm * psi%a(2)) end function f_af @ <>= pure function f_vlf (gl, v, psi) result (vpsi) type(spinor) :: vpsi complex(kind=default), intent(in) :: gl type(vector), intent(in) :: v type(spinor), intent(in) :: psi complex(kind=default) :: gl2 complex(kind=default) :: vp, vm, v12, v12s gl2 = 2 * gl vp = v%t + v%x(3) vm = v%t - v%x(3) v12 = v%x(1) + (0,1)*v%x(2) v12s = v%x(1) - (0,1)*v%x(2) vpsi%a(1) = 0 vpsi%a(2) = 0 vpsi%a(3) = gl2 * ( vp * psi%a(1) + v12s * psi%a(2)) vpsi%a(4) = gl2 * ( v12 * psi%a(1) + vm * psi%a(2)) end function f_vlf @ <>= pure function f_vrf (gr, v, psi) result (vpsi) type(spinor) :: vpsi complex(kind=default), intent(in) :: gr type(vector), intent(in) :: v type(spinor), intent(in) :: psi complex(kind=default) :: gr2 complex(kind=default) :: vp, vm, v12, v12s gr2 = 2 * gr vp = v%t + v%x(3) vm = v%t - v%x(3) v12 = v%x(1) + (0,1)*v%x(2) v12s = v%x(1) - (0,1)*v%x(2) vpsi%a(1) = gr2 * ( vm * psi%a(3) - v12s * psi%a(4)) vpsi%a(2) = gr2 * ( - v12 * psi%a(3) + vp * psi%a(4)) vpsi%a(3) = 0 vpsi%a(4) = 0 end function f_vrf @ <>= pure function f_vlrf (gl, gr, v, psi) result (vpsi) type(spinor) :: vpsi complex(kind=default), intent(in) :: gl, gr type(vector), intent(in) :: v type(spinor), intent(in) :: psi vpsi = f_vaf (gl+gr, gl-gr, v, psi) end function f_vlrf @ <>= public :: f_fva, f_fv, f_fa, f_fvl, f_fvr, f_fvlr, f_fva2, & f_ftva, f_ftlr, f_ftrl, f_ftvam, f_ftlrm, f_ftrlm, f_fva3 @ <>= pure function f_fva (gv, ga, psibar, v) result (psibarv) type(conjspinor) :: psibarv complex(kind=default), intent(in) :: gv, ga type(conjspinor), intent(in) :: psibar type(vector), intent(in) :: v complex(kind=default) :: gl, gr complex(kind=default) :: vp, vm, v12, v12s gl = gv + ga gr = gv - ga vp = v%t + v%x(3) vm = v%t - v%x(3) v12 = v%x(1) + (0,1)*v%x(2) v12s = v%x(1) - (0,1)*v%x(2) psibarv%a(1) = gl * ( psibar%a(3) * vp + psibar%a(4) * v12) psibarv%a(2) = gl * ( psibar%a(3) * v12s + psibar%a(4) * vm ) psibarv%a(3) = gr * ( psibar%a(1) * vm - psibar%a(2) * v12) psibarv%a(4) = gr * ( - psibar%a(1) * v12s + psibar%a(2) * vp ) end function f_fva @ <>= pure function f_fva2 (gva, psibar, v) result (psibarv) type(conjspinor) :: psibarv complex(kind=default), intent(in), dimension(2) :: gva type(conjspinor), intent(in) :: psibar type(vector), intent(in) :: v complex(kind=default) :: gl, gr complex(kind=default) :: vp, vm, v12, v12s gl = gva(1) + gva(2) gr = gva(1) - gva(2) vp = v%t + v%x(3) vm = v%t - v%x(3) v12 = v%x(1) + (0,1)*v%x(2) v12s = v%x(1) - (0,1)*v%x(2) psibarv%a(1) = gl * ( psibar%a(3) * vp + psibar%a(4) * v12) psibarv%a(2) = gl * ( psibar%a(3) * v12s + psibar%a(4) * vm ) psibarv%a(3) = gr * ( psibar%a(1) * vm - psibar%a(2) * v12) psibarv%a(4) = gr * ( - psibar%a(1) * v12s + psibar%a(2) * vp ) end function f_fva2 @ <>= pure function f_fva3 (gv, ga, psibar, v) result (psibarv) type(conjspinor) :: psibarv complex(kind=default), intent(in) :: gv, ga type(conjspinor), intent(in) :: psibar type(vector), intent(in) :: v complex(kind=default) :: gl, gr complex(kind=default) :: vp, vm, v12, v12s gl = gv + ga gr = gv - ga vp = v%x(3) !+ v%t vm = - v%x(3) !+ v%t v12 = v%x(1) + (0,1)*v%x(2) v12s = v%x(1) - (0,1)*v%x(2) psibarv%a(1) = gl * ( psibar%a(3) * vp + psibar%a(4) * v12) psibarv%a(2) = gl * ( psibar%a(3) * v12s + psibar%a(4) * vm ) psibarv%a(3) = gr * ( psibar%a(1) * vm - psibar%a(2) * v12) psibarv%a(4) = gr * ( - psibar%a(1) * v12s + psibar%a(2) * vp ) end function f_fva3 @ <>= pure function f_ftva (gv, ga, psibar, t) result (psibart) type(conjspinor) :: psibart complex(kind=default), intent(in) :: gv, ga type(conjspinor), intent(in) :: psibar type(tensor2odd), intent(in) :: t complex(kind=default) :: gl, gr complex(kind=default) :: e21, e21s, b12, b12s, be3, be3s gr = gv + ga gl = gv - ga e21 = t%e(2) + t%e(1)*(0,1) e21s = t%e(2) - t%e(1)*(0,1) b12 = t%b(1) + t%b(2)*(0,1) b12s = t%b(1) - t%b(2)*(0,1) be3 = t%b(3) + t%e(3)*(0,1) be3s = t%b(3) - t%e(3)*(0,1) psibart%a(1) = 2*gl * ( psibar%a(1) * be3 + psibar%a(2) * (-e21s+b12 )) psibart%a(2) = 2*gl * ( - psibar%a(2) * be3 + psibar%a(1) * ( e21 +b12s)) psibart%a(3) = 2*gr * ( psibar%a(3) * be3s + psibar%a(4) * ( e21s+b12 )) psibart%a(4) = 2*gr * ( - psibar%a(4) * be3s + psibar%a(3) * (-e21 +b12s)) end function f_ftva @ <>= pure function f_ftlr (gl, gr, psibar, t) result (psibart) type(conjspinor) :: psibart complex(kind=default), intent(in) :: gl, gr type(conjspinor), intent(in) :: psibar type(tensor2odd), intent(in) :: t psibart = f_ftva (gr+gl, gr-gl, psibar, t) end function f_ftlr @ <>= pure function f_ftrl (gr, gl, psibar, t) result (psibart) type(conjspinor) :: psibart complex(kind=default), intent(in) :: gl, gr type(conjspinor), intent(in) :: psibar type(tensor2odd), intent(in) :: t psibart = f_ftva (gr+gl, gr-gl, psibar, t) end function f_ftrl @ <>= pure function f_ftvam (gv, ga, psibar, v, k) result (psibarv) type(conjspinor) :: psibarv complex(kind=default), intent(in) :: gv, ga type(conjspinor), intent(in) :: psibar type(vector), intent(in) :: v type(momentum), intent(in) :: k type(tensor2odd) :: t t = (v.wedge.k) * (0, 0.5) psibarv = f_ftva(gv, ga, psibar, t) end function f_ftvam @ <>= pure function f_ftlrm (gl, gr, psibar, v, k) result (psibarv) type(conjspinor) :: psibarv complex(kind=default), intent(in) :: gl, gr type(conjspinor), intent(in) :: psibar type(vector), intent(in) :: v type(momentum), intent(in) :: k psibarv = f_ftvam (gr+gl, gr-gl, psibar, v, k) end function f_ftlrm @ <>= pure function f_ftrlm (gr, gl, psibar, v, k) result (psibarv) type(conjspinor) :: psibarv complex(kind=default), intent(in) :: gl, gr type(conjspinor), intent(in) :: psibar type(vector), intent(in) :: v type(momentum), intent(in) :: k psibarv = f_ftvam (gr+gl, gr-gl, psibar, v, k) end function f_ftrlm @ <>= pure function f_fv (gv, psibar, v) result (psibarv) type(conjspinor) :: psibarv complex(kind=default), intent(in) :: gv type(conjspinor), intent(in) :: psibar type(vector), intent(in) :: v complex(kind=default) :: vp, vm, v12, v12s vp = v%t + v%x(3) vm = v%t - v%x(3) v12 = v%x(1) + (0,1)*v%x(2) v12s = v%x(1) - (0,1)*v%x(2) psibarv%a(1) = gv * ( psibar%a(3) * vp + psibar%a(4) * v12) psibarv%a(2) = gv * ( psibar%a(3) * v12s + psibar%a(4) * vm ) psibarv%a(3) = gv * ( psibar%a(1) * vm - psibar%a(2) * v12) psibarv%a(4) = gv * ( - psibar%a(1) * v12s + psibar%a(2) * vp ) end function f_fv @ <>= pure function f_fa (ga, psibar, v) result (psibarv) type(conjspinor) :: psibarv complex(kind=default), intent(in) :: ga type(vector), intent(in) :: v type(conjspinor), intent(in) :: psibar complex(kind=default) :: vp, vm, v12, v12s vp = v%t + v%x(3) vm = v%t - v%x(3) v12 = v%x(1) + (0,1)*v%x(2) v12s = v%x(1) - (0,1)*v%x(2) psibarv%a(1) = ga * ( psibar%a(3) * vp + psibar%a(4) * v12) psibarv%a(2) = ga * ( psibar%a(3) * v12s + psibar%a(4) * vm ) psibarv%a(3) = ga * ( - psibar%a(1) * vm + psibar%a(2) * v12) psibarv%a(4) = ga * ( psibar%a(1) * v12s - psibar%a(2) * vp ) end function f_fa @ <>= pure function f_fvl (gl, psibar, v) result (psibarv) type(conjspinor) :: psibarv complex(kind=default), intent(in) :: gl type(conjspinor), intent(in) :: psibar type(vector), intent(in) :: v complex(kind=default) :: gl2 complex(kind=default) :: vp, vm, v12, v12s gl2 = 2 * gl vp = v%t + v%x(3) vm = v%t - v%x(3) v12 = v%x(1) + (0,1)*v%x(2) v12s = v%x(1) - (0,1)*v%x(2) psibarv%a(1) = gl2 * ( psibar%a(3) * vp + psibar%a(4) * v12) psibarv%a(2) = gl2 * ( psibar%a(3) * v12s + psibar%a(4) * vm ) psibarv%a(3) = 0 psibarv%a(4) = 0 end function f_fvl @ <>= pure function f_fvr (gr, psibar, v) result (psibarv) type(conjspinor) :: psibarv complex(kind=default), intent(in) :: gr type(conjspinor), intent(in) :: psibar type(vector), intent(in) :: v complex(kind=default) :: gr2 complex(kind=default) :: vp, vm, v12, v12s gr2 = 2 * gr vp = v%t + v%x(3) vm = v%t - v%x(3) v12 = v%x(1) + (0,1)*v%x(2) v12s = v%x(1) - (0,1)*v%x(2) psibarv%a(1) = 0 psibarv%a(2) = 0 psibarv%a(3) = gr2 * ( psibar%a(1) * vm - psibar%a(2) * v12) psibarv%a(4) = gr2 * ( - psibar%a(1) * v12s + psibar%a(2) * vp ) end function f_fvr @ <>= pure function f_fvlr (gl, gr, psibar, v) result (psibarv) type(conjspinor) :: psibarv complex(kind=default), intent(in) :: gl, gr type(conjspinor), intent(in) :: psibar type(vector), intent(in) :: v psibarv = f_fva (gl+gr, gl-gr, psibar, v) end function f_fvlr @ \subsection{Fermionic Scalar and Pseudo Scalar Couplings} <>= public :: sp_ff, s_ff, p_ff, sl_ff, sr_ff, slr_ff @ <>= pure function sp_ff (gs, gp, psibar, psi) result (j) complex(kind=default) :: j complex(kind=default), intent(in) :: gs, gp type(conjspinor), intent(in) :: psibar type(spinor), intent(in) :: psi j = (gs - gp) * (psibar%a(1)*psi%a(1) + psibar%a(2)*psi%a(2)) & + (gs + gp) * (psibar%a(3)*psi%a(3) + psibar%a(4)*psi%a(4)) end function sp_ff @ <>= pure function s_ff (gs, psibar, psi) result (j) complex(kind=default) :: j complex(kind=default), intent(in) :: gs type(conjspinor), intent(in) :: psibar type(spinor), intent(in) :: psi j = gs * (psibar * psi) end function s_ff @ <>= pure function p_ff (gp, psibar, psi) result (j) complex(kind=default) :: j complex(kind=default), intent(in) :: gp type(conjspinor), intent(in) :: psibar type(spinor), intent(in) :: psi j = gp * ( psibar%a(3)*psi%a(3) + psibar%a(4)*psi%a(4) & - psibar%a(1)*psi%a(1) - psibar%a(2)*psi%a(2)) end function p_ff @ <>= pure function sl_ff (gl, psibar, psi) result (j) complex(kind=default) :: j complex(kind=default), intent(in) :: gl type(conjspinor), intent(in) :: psibar type(spinor), intent(in) :: psi j = 2 * gl * (psibar%a(1)*psi%a(1) + psibar%a(2)*psi%a(2)) end function sl_ff @ <>= pure function sr_ff (gr, psibar, psi) result (j) complex(kind=default) :: j complex(kind=default), intent(in) :: gr type(conjspinor), intent(in) :: psibar type(spinor), intent(in) :: psi j = 2 * gr * (psibar%a(3)*psi%a(3) + psibar%a(4)*psi%a(4)) end function sr_ff @ \begin{equation} g_L(1-\gamma_5) + g_R(1+\gamma_5) = (g_R+g_L) + (g_R-g_L)\gamma_5 = g_S + g_P\gamma_5 \end{equation} <>= pure function slr_ff (gl, gr, psibar, psi) result (j) complex(kind=default) :: j complex(kind=default), intent(in) :: gl, gr type(conjspinor), intent(in) :: psibar type(spinor), intent(in) :: psi j = sp_ff (gr+gl, gr-gl, psibar, psi) end function slr_ff @ <>= public :: f_spf, f_sf, f_pf, f_slf, f_srf, f_slrf @ <>= pure function f_spf (gs, gp, phi, psi) result (phipsi) type(spinor) :: phipsi complex(kind=default), intent(in) :: gs, gp complex(kind=default), intent(in) :: phi type(spinor), intent(in) :: psi phipsi%a(1:2) = ((gs - gp) * phi) * psi%a(1:2) phipsi%a(3:4) = ((gs + gp) * phi) * psi%a(3:4) end function f_spf @ <>= pure function f_sf (gs, phi, psi) result (phipsi) type(spinor) :: phipsi complex(kind=default), intent(in) :: gs complex(kind=default), intent(in) :: phi type(spinor), intent(in) :: psi phipsi%a = (gs * phi) * psi%a end function f_sf @ <>= pure function f_pf (gp, phi, psi) result (phipsi) type(spinor) :: phipsi complex(kind=default), intent(in) :: gp complex(kind=default), intent(in) :: phi type(spinor), intent(in) :: psi phipsi%a(1:2) = (- gp * phi) * psi%a(1:2) phipsi%a(3:4) = ( gp * phi) * psi%a(3:4) end function f_pf @ <>= pure function f_slf (gl, phi, psi) result (phipsi) type(spinor) :: phipsi complex(kind=default), intent(in) :: gl complex(kind=default), intent(in) :: phi type(spinor), intent(in) :: psi phipsi%a(1:2) = (2 * gl * phi) * psi%a(1:2) phipsi%a(3:4) = 0 end function f_slf @ <>= pure function f_srf (gr, phi, psi) result (phipsi) type(spinor) :: phipsi complex(kind=default), intent(in) :: gr complex(kind=default), intent(in) :: phi type(spinor), intent(in) :: psi phipsi%a(1:2) = 0 phipsi%a(3:4) = (2 * gr * phi) * psi%a(3:4) end function f_srf @ <>= pure function f_slrf (gl, gr, phi, psi) result (phipsi) type(spinor) :: phipsi complex(kind=default), intent(in) :: gl, gr complex(kind=default), intent(in) :: phi type(spinor), intent(in) :: psi phipsi = f_spf (gr+gl, gr-gl, phi, psi) end function f_slrf @ <>= public :: f_fsp, f_fs, f_fp, f_fsl, f_fsr, f_fslr @ <>= pure function f_fsp (gs, gp, psibar, phi) result (psibarphi) type(conjspinor) :: psibarphi complex(kind=default), intent(in) :: gs, gp type(conjspinor), intent(in) :: psibar complex(kind=default), intent(in) :: phi psibarphi%a(1:2) = ((gs - gp) * phi) * psibar%a(1:2) psibarphi%a(3:4) = ((gs + gp) * phi) * psibar%a(3:4) end function f_fsp @ <>= pure function f_fs (gs, psibar, phi) result (psibarphi) type(conjspinor) :: psibarphi complex(kind=default), intent(in) :: gs type(conjspinor), intent(in) :: psibar complex(kind=default), intent(in) :: phi psibarphi%a = (gs * phi) * psibar%a end function f_fs @ <>= pure function f_fp (gp, psibar, phi) result (psibarphi) type(conjspinor) :: psibarphi complex(kind=default), intent(in) :: gp type(conjspinor), intent(in) :: psibar complex(kind=default), intent(in) :: phi psibarphi%a(1:2) = (- gp * phi) * psibar%a(1:2) psibarphi%a(3:4) = ( gp * phi) * psibar%a(3:4) end function f_fp @ <>= pure function f_fsl (gl, psibar, phi) result (psibarphi) type(conjspinor) :: psibarphi complex(kind=default), intent(in) :: gl type(conjspinor), intent(in) :: psibar complex(kind=default), intent(in) :: phi psibarphi%a(1:2) = (2 * gl * phi) * psibar%a(1:2) psibarphi%a(3:4) = 0 end function f_fsl @ <>= pure function f_fsr (gr, psibar, phi) result (psibarphi) type(conjspinor) :: psibarphi complex(kind=default), intent(in) :: gr type(conjspinor), intent(in) :: psibar complex(kind=default), intent(in) :: phi psibarphi%a(1:2) = 0 psibarphi%a(3:4) = (2 * gr * phi) * psibar%a(3:4) end function f_fsr @ <>= pure function f_fslr (gl, gr, psibar, phi) result (psibarphi) type(conjspinor) :: psibarphi complex(kind=default), intent(in) :: gl, gr type(conjspinor), intent(in) :: psibar complex(kind=default), intent(in) :: phi psibarphi = f_fsp (gr+gl, gr-gl, psibar, phi) end function f_fslr <>= public :: f_gravf, f_fgrav @ <>= pure function f_gravf (g, m, kb, k, t, psi) result (tpsi) type(spinor) :: tpsi complex(kind=default), intent(in) :: g real(kind=default), intent(in) :: m type(spinor), intent(in) :: psi type(tensor), intent(in) :: t type(momentum), intent(in) :: kb, k complex(kind=default) :: g2, g8, t_tr type(vector) :: kkb kkb = k + kb g2 = g / 2.0_default g8 = g / 8.0_default t_tr = t%t(0,0) - t%t(1,1) - t%t(2,2) - t%t(3,3) tpsi = (- f_sf (g2, cmplx (m,0.0, kind=default), psi) & - f_vf ((g8*m), kkb, psi)) * t_tr - & f_vf (g8,(t*kkb + kkb*t),psi) end function f_gravf @ <>= pure function f_fgrav (g, m, kb, k, psibar, t) result (psibart) type(conjspinor) :: psibart complex(kind=default), intent(in) :: g real(kind=default), intent(in) :: m type(conjspinor), intent(in) :: psibar type(tensor), intent(in) :: t type(momentum), intent(in) :: kb, k type(vector) :: kkb complex(kind=default) :: g2, g8, t_tr kkb = k + kb g2 = g / 2.0_default g8 = g / 8.0_default t_tr = t%t(0,0) - t%t(1,1) - t%t(2,2) - t%t(3,3) psibart = (- f_fs (g2, psibar, cmplx (m, 0.0, kind=default)) & - f_fv ((g8 * m), psibar, kkb)) * t_tr - & f_fv (g8,psibar,(t*kkb + kkb*t)) end function f_fgrav @ \subsection{On Shell Wave Functions} <>= public :: u, ubar, v, vbar private :: chi_plus, chi_minus @ \begin{subequations} \begin{align} \chi_+(\vec p) &= \frac{1}{\sqrt{2|\vec p|(|\vec p|+p_3)}} \begin{pmatrix} |\vec p|+p_3 \\ p_1 + \ii p_2 \end{pmatrix} \\ \chi_-(\vec p) &= \frac{1}{\sqrt{2|\vec p|(|\vec p|+p_3)}} \begin{pmatrix} - p_1 + \ii p_2 \\ |\vec p|+p_3 \end{pmatrix} \end{align} \end{subequations} <>= pure function chi_plus (p) result (chi) complex(kind=default), dimension(2) :: chi type(momentum), intent(in) :: p real(kind=default) :: pabs pabs = sqrt (dot_product (p%x, p%x)) if (pabs + p%x(3) <= 1000 * epsilon (pabs) * pabs) then chi = (/ cmplx ( 0.0, 0.0, kind=default), & cmplx ( 1.0, 0.0, kind=default) /) else chi = 1 / sqrt (2*pabs*(pabs + p%x(3))) & * (/ cmplx (pabs + p%x(3), kind=default), & cmplx (p%x(1), p%x(2), kind=default) /) end if end function chi_plus @ <>= pure function chi_minus (p) result (chi) complex(kind=default), dimension(2) :: chi type(momentum), intent(in) :: p real(kind=default) :: pabs pabs = sqrt (dot_product (p%x, p%x)) if (pabs + p%x(3) <= 1000 * epsilon (pabs) * pabs) then chi = (/ cmplx (-1.0, 0.0, kind=default), & cmplx ( 0.0, 0.0, kind=default) /) else chi = 1 / sqrt (2*pabs*(pabs + p%x(3))) & * (/ cmplx (-p%x(1), p%x(2), kind=default), & cmplx (pabs + p%x(3), kind=default) /) end if end function chi_minus @ \begin{equation} u_\pm(p,|m|) = \begin{pmatrix} \sqrt{p_0\mp|\vec p|} \cdot \chi_\pm(\vec p) \\ \sqrt{p_0\pm|\vec p|} \cdot \chi_\pm(\vec p) \end{pmatrix}\qquad u_\pm(p,-|m|) = \begin{pmatrix} - i \sqrt{p_0\mp|\vec p|} \cdot \chi_\pm(\vec p) \\ + i \sqrt{p_0\pm|\vec p|} \cdot \chi_\pm(\vec p) \end{pmatrix} \end{equation} Determining the mass from the momenta is a numerically haphazardous for light particles. Therefore, we accept some redundancy and pass the mass explicitely. Even if the mass is not used in the chiral representation, we do so for symmetry with polarization vectors and to be prepared for other representations. <>= pure function u (mass, p, s) result (psi) type(spinor) :: psi real(kind=default), intent(in) :: mass type(momentum), intent(in) :: p integer, intent(in) :: s complex(kind=default), dimension(2) :: chi real(kind=default) :: pabs, delta, m m = abs(mass) pabs = sqrt (dot_product (p%x, p%x)) if (m < epsilon (m) * pabs) then delta = 0 else delta = sqrt (max (p%t - pabs, 0._default)) end if select case (s) case (1) chi = chi_plus (p) psi%a(1:2) = delta * chi psi%a(3:4) = sqrt (p%t + pabs) * chi case (-1) chi = chi_minus (p) psi%a(1:2) = sqrt (p%t + pabs) * chi psi%a(3:4) = delta * chi case default pabs = m ! make the compiler happy and use m psi%a = 0 end select if (mass < 0) then psi%a(1:2) = - imago * psi%a(1:2) psi%a(3:4) = + imago * psi%a(3:4) end if end function u @ <>= pure function ubar (m, p, s) result (psibar) type(conjspinor) :: psibar real(kind=default), intent(in) :: m type(momentum), intent(in) :: p integer, intent(in) :: s type(spinor) :: psi psi = u (m, p, s) psibar%a(1:2) = conjg (psi%a(3:4)) psibar%a(3:4) = conjg (psi%a(1:2)) end function ubar @ \begin{equation} v_\pm(p) = \begin{pmatrix} \mp\sqrt{p_0\pm|\vec p|} \cdot \chi_\mp(\vec p) \\ \pm\sqrt{p_0\mp|\vec p|} \cdot \chi_\mp(\vec p) \end{pmatrix} \end{equation} <>= pure function v (mass, p, s) result (psi) type(spinor) :: psi real(kind=default), intent(in) :: mass type(momentum), intent(in) :: p integer, intent(in) :: s complex(kind=default), dimension(2) :: chi real(kind=default) :: pabs, delta, m m = abs(mass) pabs = sqrt (dot_product (p%x, p%x)) if (m < epsilon (m) * pabs) then delta = 0 else delta = sqrt (max (p%t - pabs, 0._default)) end if select case (s) case (1) chi = chi_minus (p) psi%a(1:2) = - sqrt (p%t + pabs) * chi psi%a(3:4) = delta * chi case (-1) chi = chi_plus (p) psi%a(1:2) = delta * chi psi%a(3:4) = - sqrt (p%t + pabs) * chi case default pabs = m ! make the compiler happy and use m psi%a = 0 end select if (mass < 0) then psi%a(1:2) = - imago * psi%a(1:2) psi%a(3:4) = + imago * psi%a(3:4) end if end function v @ <>= pure function vbar (m, p, s) result (psibar) type(conjspinor) :: psibar real(kind=default), intent(in) :: m type(momentum), intent(in) :: p integer, intent(in) :: s type(spinor) :: psi psi = v (m, p, s) psibar%a(1:2) = conjg (psi%a(3:4)) psibar%a(3:4) = conjg (psi%a(1:2)) end function vbar @ \subsection{Off Shell Wave Functions} I've just taken this over from Christian Schwinn's version. <>= public :: brs_u, brs_ubar, brs_v, brs_vbar @ The off-shell wave functions needed for gauge checking are obtained from the LSZ-formulas: \begin{subequations} \begin{align} \Braket{\text{Out}|d^\dagger|\text{In}}&=i\int d^4x \bar v e^{-ikx}(i\fmslash\partial-m)\Braket{\text{Out}|\psi|\text{In}}\\ \Braket{\text{Out}|b|\text{In}}&=-i\int d^4x \bar u e^{ikx}(i\fmslash\partial-m)\Braket{\text{Out}|\psi|\text{In}}\\ \Braket{\text{Out}|d|\text{In}}&= i\int d^4x \Braket{\text{Out}|\bar \psi| \text{In}}(-i\fmslash{\overleftarrow\partial}-m)v e^{ikx}\\ \Braket{\text{Out}|b^\dagger|\text{In}}&= -i\int d^4x \Braket{\text{Out}|\bar \psi| \text{In}}(-i\fmslash{\overleftarrow\partial}-m)u e^{-ikx} \end{align} \end{subequations} Since the relative sign between fermions and antifermions is ignored for on-shell amplitudes we must also ignore it here, so all wavefunctions must have a $(-i)$ factor. In momentum space we have: \begin{equation} brs u(p)=(-i) (\fmslash p-m)u(p) \end{equation} <>= pure function brs_u (m, p, s) result (dpsi) type(spinor) :: dpsi,psi real(kind=default), intent(in) :: m type(momentum), intent(in) :: p integer, intent(in) :: s type (vector)::vp complex(kind=default), parameter :: one = (1, 0) vp=p psi=u(m,p,s) dpsi=cmplx(0.0,-1.0)*(f_vf(one,vp,psi)-m*psi) end function brs_u @ \begin{equation} brs v(p)=i (\fmslash p+m)v(p) \end{equation} <>= pure function brs_v (m, p, s) result (dpsi) type(spinor) :: dpsi, psi real(kind=default), intent(in) :: m type(momentum), intent(in) :: p integer, intent(in) :: s type (vector)::vp complex(kind=default), parameter :: one = (1, 0) vp=p psi=v(m,p,s) dpsi=cmplx(0.0,1.0)*(f_vf(one,vp,psi)+m*psi) end function brs_v @ \begin{equation} brs \bar{u}(p)=(-i)\bar u(p)(\fmslash p-m) \end{equation} <>= pure function brs_ubar (m, p, s)result (dpsibar) type(conjspinor) :: dpsibar, psibar real(kind=default), intent(in) :: m type(momentum), intent(in) :: p integer, intent(in) :: s type (vector)::vp complex(kind=default), parameter :: one = (1, 0) vp=p psibar=ubar(m,p,s) dpsibar=cmplx(0.0,-1.0)*(f_fv(one,psibar,vp)-m*psibar) end function brs_ubar @ \begin{equation} brs \bar{v}(p)=(i)\bar v(p)(\fmslash p+m) \end{equation} <>= pure function brs_vbar (m, p, s) result (dpsibar) type(conjspinor) :: dpsibar,psibar real(kind=default), intent(in) :: m type(momentum), intent(in) :: p integer, intent(in) :: s type(vector)::vp complex(kind=default), parameter :: one = (1, 0) vp=p psibar=vbar(m,p,s) dpsibar=cmplx(0.0,1.0)*(f_fv(one,psibar,vp)+m*psibar) end function brs_vbar @ NB: The remarks on momentum flow in the propagators don't apply here since the incoming momenta are flipped for the wave functions. @ \subsection{Propagators} NB: the common factor of~$\ii$ is extracted: <>= public :: pr_psi, pr_psibar public :: pj_psi, pj_psibar public :: pg_psi, pg_psibar @ \begin{equation} \frac{i(-\fmslash{p}+m)}{p^2-m^2+\ii m\Gamma}\psi \end{equation} NB: the sign of the momentum comes about because all momenta are treated as \emph{outgoing} and the particle charge flow is therefore opposite to the momentum. <>= pure function pr_psi (p, m, w, cms, psi) result (ppsi) type(spinor) :: ppsi type(momentum), intent(in) :: p real(kind=default), intent(in) :: m, w type(spinor), intent(in) :: psi logical, intent(in) :: cms type(vector) :: vp complex(kind=default), parameter :: one = (1, 0) complex(kind=default) :: num_mass vp = p if (cms) then num_mass = sqrt(cmplx(m**2, -m*w, kind=default)) else num_mass = cmplx (m, 0, kind=default) end if ppsi = (1 / cmplx (p*p - m**2, m*w, kind=default)) & * (- f_vf (one, vp, psi) + num_mass * psi) end function pr_psi @ \begin{equation} \sqrt{\frac{\pi}{M\Gamma}} (-\fmslash{p}+m)\psi \end{equation} <>= pure function pj_psi (p, m, w, psi) result (ppsi) type(spinor) :: ppsi type(momentum), intent(in) :: p real(kind=default), intent(in) :: m, w type(spinor), intent(in) :: psi type(vector) :: vp complex(kind=default), parameter :: one = (1, 0) vp = p ppsi = (0, -1) * sqrt (PI / m / w) * (- f_vf (one, vp, psi) + m * psi) end function pj_psi @ <>= pure function pg_psi (p, m, w, psi) result (ppsi) type(spinor) :: ppsi type(momentum), intent(in) :: p real(kind=default), intent(in) :: m, w type(spinor), intent(in) :: psi type(vector) :: vp complex(kind=default), parameter :: one = (1, 0) vp = p ppsi = gauss(p*p, m, w) * (- f_vf (one, vp, psi) + m * psi) end function pg_psi @ \begin{equation} \bar\psi \frac{i(\fmslash{p}+m)}{p^2-m^2+\ii m\Gamma} \end{equation} NB: the sign of the momentum comes about because all momenta are treated as \emph{outgoing} and the antiparticle charge flow is therefore parallel to the momentum. <>= pure function pr_psibar (p, m, w, cms, psibar) result (ppsibar) type(conjspinor) :: ppsibar type(momentum), intent(in) :: p real(kind=default), intent(in) :: m, w type(conjspinor), intent(in) :: psibar logical, intent(in) :: cms type(vector) :: vp complex(kind=default), parameter :: one = (1, 0) complex(kind=default) :: num_mass vp = p if (cms) then num_mass = sqrt(cmplx(m**2, -m*w, kind=default)) else num_mass = cmplx (m, 0, kind=default) end if ppsibar = (1 / cmplx (p*p - m**2, m*w, kind=default)) & * (f_fv (one, psibar, vp) + num_mass * psibar) end function pr_psibar @ \begin{equation} \sqrt{\frac{\pi}{M\Gamma}} \bar\psi (\fmslash{p}+m) \end{equation} NB: the sign of the momentum comes about because all momenta are treated as \emph{outgoing} and the antiparticle charge flow is therefore parallel to the momentum. <>= pure function pj_psibar (p, m, w, psibar) result (ppsibar) type(conjspinor) :: ppsibar type(momentum), intent(in) :: p real(kind=default), intent(in) :: m, w type(conjspinor), intent(in) :: psibar type(vector) :: vp complex(kind=default), parameter :: one = (1, 0) vp = p ppsibar = (0, -1) * sqrt (PI / m / w) * (f_fv (one, psibar, vp) + m * psibar) end function pj_psibar @ <>= pure function pg_psibar (p, m, w, psibar) result (ppsibar) type(conjspinor) :: ppsibar type(momentum), intent(in) :: p real(kind=default), intent(in) :: m, w type(conjspinor), intent(in) :: psibar type(vector) :: vp complex(kind=default), parameter :: one = (1, 0) vp = p ppsibar = gauss (p*p, m, w) * (f_fv (one, psibar, vp) + m * psibar) end function pg_psibar @ \begin{equation} \frac{i(-\fmslash{p}+m)}{p^2-m^2+\ii m\Gamma} \sum_n \psi_n\otimes\bar\psi_n \end{equation} NB: the temporary variables [[psi(1:4)]] are not nice, but the compilers should be able to optimize the unnecessary copies away. In any case, even if the copies are performed, they are (probably) negligible compared to the floating point multiplications anyway \ldots <<(Not used yet) Declaration of operations for spinors>>= type, public :: spinordyad ! private (omegalib needs access, but DON'T TOUCH IT!) complex(kind=default), dimension(4,4) :: a end type spinordyad @ <<(Not used yet) Implementation of spinor propagators>>= pure function pr_dyadleft (p, m, w, psipsibar) result (psipsibarp) type(spinordyad) :: psipsibarp type(momentum), intent(in) :: p real(kind=default), intent(in) :: m, w type(spinordyad), intent(in) :: psipsibar integer :: i type(vector) :: vp type(spinor), dimension(4) :: psi complex(kind=default) :: pole complex(kind=default), parameter :: one = (1, 0) vp = p pole = 1 / cmplx (p*p - m**2, m*w, kind=default) do i = 1, 4 psi(i)%a = psipsibar%a(:,i) psi(i) = pole * (- f_vf (one, vp, psi(i)) + m * psi(i)) psipsibarp%a(:,i) = psi(i)%a end do end function pr_dyadleft @ \begin{equation} \sum_n \psi_n\otimes\bar\psi_n \frac{i(\fmslash{p}+m)}{p^2-m^2+\ii m\Gamma} \end{equation} <<(Not used yet) Implementation of spinor propagators>>= pure function pr_dyadright (p, m, w, psipsibar) result (psipsibarp) type(spinordyad) :: psipsibarp type(momentum), intent(in) :: p real(kind=default), intent(in) :: m, w type(spinordyad), intent(in) :: psipsibar integer :: i type(vector) :: vp type(conjspinor), dimension(4) :: psibar complex(kind=default) :: pole complex(kind=default), parameter :: one = (1, 0) vp = p pole = 1 / cmplx (p*p - m**2, m*w, kind=default) do i = 1, 4 psibar(i)%a = psipsibar%a(i,:) psibar(i) = pole * (f_fv (one, psibar(i), vp) + m * psibar(i)) psipsibarp%a(i,:) = psibar(i)%a end do end function pr_dyadright @ \section{Spinor Couplings Revisited} <<[[omega_bispinor_couplings.f90]]>>= <> module omega_bispinor_couplings use kinds use constants use omega_bispinors use omega_vectorspinors use omega_vectors use omega_couplings implicit none private <> <> <> <> integer, parameter, public :: omega_bispinor_cpls_2010_01_A = 0 contains <> <> <> <> end module omega_bispinor_couplings @ See table~\ref{tab:fermionic-currents} for the names of Fortran functions. We could have used long names instead, but this would increase the chance of running past continuation line limits without adding much to the legibility. @ \subsection{Fermionic Vector and Axial Couplings} \label{sec:dirac-matrices-jrr} There's more than one chiral representation. This one is compatible with HELAS~\cite{HELAS}. \begin{subequations} \begin{align} & \gamma^0 = \begin{pmatrix} 0 & \mathbf{1} \\ \mathbf{1} & 0 \end{pmatrix},\; \gamma^i = \begin{pmatrix} 0 & \sigma^i \\ -\sigma^i & 0 \end{pmatrix},\; \gamma_5 = i\gamma^0\gamma^1\gamma^2\gamma^3 = \begin{pmatrix} -\mathbf{1} & 0 \\ 0 & \mathbf{1} \end{pmatrix}, \\ & C = \begin{pmatrix} \epsilon & 0 \\ 0 & - \epsilon \end{pmatrix} \; , \qquad \epsilon = \begin{pmatrix} 0 & 1 \\ -1 & 0 \end{pmatrix} . \end{align} \end{subequations} Therefore \begin{subequations} \begin{align} g_S + g_P\gamma_5 &= \begin{pmatrix} g_S - g_P & 0 & 0 & 0 \\ 0 & g_S - g_P & 0 & 0 \\ 0 & 0 & g_S + g_P & 0 \\ 0 & 0 & 0 & g_S + g_P \end{pmatrix} \\ g_V\gamma^0 - g_A\gamma^0\gamma_5 &= \begin{pmatrix} 0 & 0 & g_V - g_A & 0 \\ 0 & 0 & 0 & g_V - g_A \\ g_V + g_A & 0 & 0 & 0 \\ 0 & g_V + g_A & 0 & 0 \end{pmatrix} \\ g_V\gamma^1 - g_A\gamma^1\gamma_5 &= \begin{pmatrix} 0 & 0 & 0 & g_V - g_A \\ 0 & 0 & g_V - g_A & 0 \\ 0 & - g_V - g_A & 0 & 0 \\ - g_V - g_A & 0 & 0 & 0 \end{pmatrix} \\ g_V\gamma^2 - g_A\gamma^2\gamma_5 &= \begin{pmatrix} 0 & 0 & 0 & -\ii(g_V - g_A) \\ 0 & 0 & \ii(g_V - g_A) & 0 \\ 0 & \ii(g_V + g_A) & 0 & 0 \\ -\ii(g_V + g_A) & 0 & 0 & 0 \end{pmatrix} \\ g_V\gamma^3 - g_A\gamma^3\gamma_5 &= \begin{pmatrix} 0 & 0 & g_V - g_A & 0 \\ 0 & 0 & 0 & - g_V + g_A \\ - g_V - g_A & 0 & 0 & 0 \\ 0 & g_V + g_A & 0 & 0 \end{pmatrix} \end{align} \end{subequations} and \begin{subequations} \begin{align} C(g_S + g_P\gamma_5) &= \begin{pmatrix} 0 & g_S - g_P & 0 & 0 \\ - g_S + g_P & 0 & 0 & 0 \\ 0 & 0 & 0 & - g_S - g_P \\ 0 & 0 & g_S + g_P & 0 \end{pmatrix} \\ C(g_V\gamma^0 - g_A\gamma^0\gamma_5) &= \begin{pmatrix} 0 & 0 & 0 & g_V - g_A \\ 0 & 0 & - g_V + g_A & 0 \\ 0 & - g_V - g_A & 0 & 0 \\ g_V + g_A & 0 & 0 & 0 \end{pmatrix} \\ C(g_V\gamma^1 - g_A\gamma^1\gamma_5) &= \begin{pmatrix} 0 & 0 & g_V - g_A & 0 \\ 0 & 0 & 0 & - g_V + g_A \\ g_V + g_A & 0 & 0 & 0 \\ 0 & - g_V - g_A & 0 & 0 \end{pmatrix} \\ C(g_V\gamma^2 - g_A\gamma^2\gamma_5) &= \begin{pmatrix} 0 & 0 & \ii(g_V - g_A) & 0 \\ 0 & 0 & 0 & \ii(g_V - g_A) \\ \ii(g_V + g_A) & 0 & 0 & 0 \\ 0 & \ii(g_V + g_A) & 0 & 0 \end{pmatrix} \\ C(g_V\gamma^3 - g_A\gamma^3\gamma_5) &= \begin{pmatrix} 0 & 0 & 0 & - g_V + g_A \\ 0 & 0 & - g_V + g_A & 0 \\ 0 & - g_V - g_A & 0 & 0 \\ - g_V - g_A & 0 & 0 & 0 \end{pmatrix} \end{align} \end{subequations} <>= public :: va_ff, v_ff, a_ff, vl_ff, vr_ff, vlr_ff, va2_ff, tva_ff, tvam_ff, & tlr_ff, tlrm_ff @ <>= pure function va_ff (gv, ga, psil, psir) result (j) type(vector) :: j complex(kind=default), intent(in) :: gv, ga type(bispinor), intent(in) :: psil, psir complex(kind=default) :: gl, gr complex(kind=default) :: g13, g14, g23, g24, g31, g32, g41, g42 gl = gv + ga gr = gv - ga g13 = psil%a(1)*psir%a(3) g14 = psil%a(1)*psir%a(4) g23 = psil%a(2)*psir%a(3) g24 = psil%a(2)*psir%a(4) g31 = psil%a(3)*psir%a(1) g32 = psil%a(3)*psir%a(2) g41 = psil%a(4)*psir%a(1) g42 = psil%a(4)*psir%a(2) j%t = gr * ( g14 - g23) + gl * ( - g32 + g41) j%x(1) = gr * ( g13 - g24) + gl * ( g31 - g42) j%x(2) = (gr * ( g13 + g24) + gl * ( g31 + g42)) * (0, 1) j%x(3) = gr * ( - g14 - g23) + gl * ( - g32 - g41) end function va_ff @ <>= pure function va2_ff (gva, psil, psir) result (j) type(vector) :: j complex(kind=default), intent(in), dimension(2) :: gva type(bispinor), intent(in) :: psil, psir complex(kind=default) :: gl, gr complex(kind=default) :: g13, g14, g23, g24, g31, g32, g41, g42 gl = gva(1) + gva(2) gr = gva(1) - gva(2) g13 = psil%a(1)*psir%a(3) g14 = psil%a(1)*psir%a(4) g23 = psil%a(2)*psir%a(3) g24 = psil%a(2)*psir%a(4) g31 = psil%a(3)*psir%a(1) g32 = psil%a(3)*psir%a(2) g41 = psil%a(4)*psir%a(1) g42 = psil%a(4)*psir%a(2) j%t = gr * ( g14 - g23) + gl * ( - g32 + g41) j%x(1) = gr * ( g13 - g24) + gl * ( g31 - g42) j%x(2) = (gr * ( g13 + g24) + gl * ( g31 + g42)) * (0, 1) j%x(3) = gr * ( - g14 - g23) + gl * ( - g32 - g41) end function va2_ff @ <>= pure function v_ff (gv, psil, psir) result (j) type(vector) :: j complex(kind=default), intent(in) :: gv type(bispinor), intent(in) :: psil, psir complex(kind=default) :: g13, g14, g23, g24, g31, g32, g41, g42 g13 = psil%a(1)*psir%a(3) g14 = psil%a(1)*psir%a(4) g23 = psil%a(2)*psir%a(3) g24 = psil%a(2)*psir%a(4) g31 = psil%a(3)*psir%a(1) g32 = psil%a(3)*psir%a(2) g41 = psil%a(4)*psir%a(1) g42 = psil%a(4)*psir%a(2) j%t = gv * ( g14 - g23 - g32 + g41) j%x(1) = gv * ( g13 - g24 + g31 - g42) j%x(2) = gv * ( g13 + g24 + g31 + g42) * (0, 1) j%x(3) = gv * ( - g14 - g23 - g32 - g41) end function v_ff @ <>= pure function a_ff (ga, psil, psir) result (j) type(vector) :: j complex(kind=default), intent(in) :: ga type(bispinor), intent(in) :: psil, psir complex(kind=default) :: g13, g14, g23, g24, g31, g32, g41, g42 g13 = psil%a(1)*psir%a(3) g14 = psil%a(1)*psir%a(4) g23 = psil%a(2)*psir%a(3) g24 = psil%a(2)*psir%a(4) g31 = psil%a(3)*psir%a(1) g32 = psil%a(3)*psir%a(2) g41 = psil%a(4)*psir%a(1) g42 = psil%a(4)*psir%a(2) j%t = -ga * ( g14 - g23 + g32 - g41) j%x(1) = -ga * ( g13 - g24 - g31 + g42) j%x(2) = -ga * ( g13 + g24 - g31 - g42) * (0, 1) j%x(3) = -ga * ( - g14 - g23 + g32 + g41) end function a_ff @ <>= pure function vl_ff (gl, psil, psir) result (j) type(vector) :: j complex(kind=default), intent(in) :: gl type(bispinor), intent(in) :: psil, psir complex(kind=default) :: gl2 complex(kind=default) :: g31, g32, g41, g42 gl2 = 2 * gl g31 = psil%a(3)*psir%a(1) g32 = psil%a(3)*psir%a(2) g41 = psil%a(4)*psir%a(1) g42 = psil%a(4)*psir%a(2) j%t = gl2 * ( - g32 + g41) j%x(1) = gl2 * ( g31 - g42) j%x(2) = gl2 * ( g31 + g42) * (0, 1) j%x(3) = gl2 * ( - g32 - g41) end function vl_ff @ <>= pure function vr_ff (gr, psil, psir) result (j) type(vector) :: j complex(kind=default), intent(in) :: gr type(bispinor), intent(in) :: psil, psir complex(kind=default) :: gr2 complex(kind=default) :: g13, g14, g23, g24 gr2 = 2 * gr g13 = psil%a(1)*psir%a(3) g14 = psil%a(1)*psir%a(4) g23 = psil%a(2)*psir%a(3) g24 = psil%a(2)*psir%a(4) j%t = gr2 * ( g14 - g23) j%x(1) = gr2 * ( g13 - g24) j%x(2) = gr2 * ( g13 + g24) * (0, 1) j%x(3) = gr2 * ( - g14 - g23) end function vr_ff @ <>= pure function vlr_ff (gl, gr, psibar, psi) result (j) type(vector) :: j complex(kind=default), intent(in) :: gl, gr type(bispinor), intent(in) :: psibar type(bispinor), intent(in) :: psi j = va_ff (gl+gr, gl-gr, psibar, psi) end function vlr_ff @ <>= pure function tva_ff (gv, ga, psibar, psi) result (t) type(tensor2odd) :: t complex(kind=default), intent(in) :: gv, ga type(bispinor), intent(in) :: psibar type(bispinor), intent(in) :: psi complex(kind=default) :: gl, gr complex(kind=default) :: g11, g22, g33, g44, g1p2, g3p4 gr = gv + ga gl = gv - ga g11 = psibar%a(1)*psi%a(1) g22 = psibar%a(2)*psi%a(2) g1p2 = psibar%a(1)*psi%a(2) + psibar%a(2)*psi%a(1) g3p4 = psibar%a(3)*psi%a(4) + psibar%a(4)*psi%a(3) g33 = psibar%a(3)*psi%a(3) g44 = psibar%a(4)*psi%a(4) t%e(1) = (gl * ( - g11 + g22) + gr * ( - g33 + g44)) * (0, 1) t%e(2) = gl * ( g11 + g22) + gr * ( g33 + g44) t%e(3) = (gl * ( g1p2 ) + gr * ( g3p4 )) * (0, 1) t%b(1) = gl * ( g11 - g22) + gr * ( - g33 + g44) t%b(2) = (gl * ( g11 + g22) + gr * ( - g33 - g44)) * (0, 1) t%b(3) = gl * ( - g1p2 ) + gr * ( g3p4 ) end function tva_ff @ <>= pure function tlr_ff (gl, gr, psibar, psi) result (t) type(tensor2odd) :: t complex(kind=default), intent(in) :: gl, gr type(bispinor), intent(in) :: psibar type(bispinor), intent(in) :: psi t = tva_ff (gr+gl, gr-gl, psibar, psi) end function tlr_ff @ <>= pure function tvam_ff (gv, ga, psibar, psi, p) result (j) type(vector) :: j complex(kind=default), intent(in) :: gv, ga type(bispinor), intent(in) :: psibar type(bispinor), intent(in) :: psi type(momentum), intent(in) :: p j = (tva_ff(gv, ga, psibar, psi) * p) * (0,1) end function tvam_ff @ <>= pure function tlrm_ff (gl, gr, psibar, psi, p) result (j) type(vector) :: j complex(kind=default), intent(in) :: gl, gr type(bispinor), intent(in) :: psibar type(bispinor), intent(in) :: psi type(momentum), intent(in) :: p j = tvam_ff (gr+gl, gr-gl, psibar, psi, p) end function tlrm_ff @ and \begin{equation} \fmslash{v} - \fmslash{a}\gamma_5 = \begin{pmatrix} 0 & 0 & v_- - a_- & - v^* + a^* \\ 0 & 0 & - v + a & v_+ - a_+ \\ v_+ + a_+ & v^* + a^* & 0 & 0 \\ v + a & v_- + a_- & 0 & 0 \end{pmatrix} \end{equation} with $v_\pm=v_0\pm v_3$, $a_\pm=a_0\pm a_3$, $v=v_1+\ii v_2$, $v^*=v_1-\ii v_2$, $a=a_1+\ii a_2$, and $a^*=a_1-\ii a_2$. But note that~$\cdot^*$ is \emph{not} complex conjugation for complex~$v_\mu$ or~$a_\mu$. <>= public :: f_vaf, f_vf, f_af, f_vlf, f_vrf, f_vlrf, f_va2f, & f_tvaf, f_tlrf, f_tvamf, f_tlrmf @ <>= pure function f_vaf (gv, ga, v, psi) result (vpsi) type(bispinor) :: vpsi complex(kind=default), intent(in) :: gv, ga type(vector), intent(in) :: v type(bispinor), intent(in) :: psi complex(kind=default) :: gl, gr complex(kind=default) :: vp, vm, v12, v12s gl = gv + ga gr = gv - ga vp = v%t + v%x(3) vm = v%t - v%x(3) v12 = v%x(1) + (0,1)*v%x(2) v12s = v%x(1) - (0,1)*v%x(2) vpsi%a(1) = gr * ( vm * psi%a(3) - v12s * psi%a(4)) vpsi%a(2) = gr * ( - v12 * psi%a(3) + vp * psi%a(4)) vpsi%a(3) = gl * ( vp * psi%a(1) + v12s * psi%a(2)) vpsi%a(4) = gl * ( v12 * psi%a(1) + vm * psi%a(2)) end function f_vaf @ <>= pure function f_va2f (gva, v, psi) result (vpsi) type(bispinor) :: vpsi complex(kind=default), intent(in), dimension(2) :: gva type(vector), intent(in) :: v type(bispinor), intent(in) :: psi complex(kind=default) :: gl, gr complex(kind=default) :: vp, vm, v12, v12s gl = gva(1) + gva(2) gr = gva(1) - gva(2) vp = v%t + v%x(3) vm = v%t - v%x(3) v12 = v%x(1) + (0,1)*v%x(2) v12s = v%x(1) - (0,1)*v%x(2) vpsi%a(1) = gr * ( vm * psi%a(3) - v12s * psi%a(4)) vpsi%a(2) = gr * ( - v12 * psi%a(3) + vp * psi%a(4)) vpsi%a(3) = gl * ( vp * psi%a(1) + v12s * psi%a(2)) vpsi%a(4) = gl * ( v12 * psi%a(1) + vm * psi%a(2)) end function f_va2f @ <>= pure function f_vf (gv, v, psi) result (vpsi) type(bispinor) :: vpsi complex(kind=default), intent(in) :: gv type(vector), intent(in) :: v type(bispinor), intent(in) :: psi complex(kind=default) :: vp, vm, v12, v12s vp = v%t + v%x(3) vm = v%t - v%x(3) v12 = v%x(1) + (0,1)*v%x(2) v12s = v%x(1) - (0,1)*v%x(2) vpsi%a(1) = gv * ( vm * psi%a(3) - v12s * psi%a(4)) vpsi%a(2) = gv * ( - v12 * psi%a(3) + vp * psi%a(4)) vpsi%a(3) = gv * ( vp * psi%a(1) + v12s * psi%a(2)) vpsi%a(4) = gv * ( v12 * psi%a(1) + vm * psi%a(2)) end function f_vf @ <>= pure function f_af (ga, v, psi) result (vpsi) type(bispinor) :: vpsi complex(kind=default), intent(in) :: ga type(vector), intent(in) :: v type(bispinor), intent(in) :: psi complex(kind=default) :: vp, vm, v12, v12s vp = v%t + v%x(3) vm = v%t - v%x(3) v12 = v%x(1) + (0,1)*v%x(2) v12s = v%x(1) - (0,1)*v%x(2) vpsi%a(1) = ga * ( - vm * psi%a(3) + v12s * psi%a(4)) vpsi%a(2) = ga * ( v12 * psi%a(3) - vp * psi%a(4)) vpsi%a(3) = ga * ( vp * psi%a(1) + v12s * psi%a(2)) vpsi%a(4) = ga * ( v12 * psi%a(1) + vm * psi%a(2)) end function f_af @ <>= pure function f_vlf (gl, v, psi) result (vpsi) type(bispinor) :: vpsi complex(kind=default), intent(in) :: gl type(vector), intent(in) :: v type(bispinor), intent(in) :: psi complex(kind=default) :: gl2 complex(kind=default) :: vp, vm, v12, v12s gl2 = 2 * gl vp = v%t + v%x(3) vm = v%t - v%x(3) v12 = v%x(1) + (0,1)*v%x(2) v12s = v%x(1) - (0,1)*v%x(2) vpsi%a(1) = 0 vpsi%a(2) = 0 vpsi%a(3) = gl2 * ( vp * psi%a(1) + v12s * psi%a(2)) vpsi%a(4) = gl2 * ( v12 * psi%a(1) + vm * psi%a(2)) end function f_vlf @ <>= pure function f_vrf (gr, v, psi) result (vpsi) type(bispinor) :: vpsi complex(kind=default), intent(in) :: gr type(vector), intent(in) :: v type(bispinor), intent(in) :: psi complex(kind=default) :: gr2 complex(kind=default) :: vp, vm, v12, v12s gr2 = 2 * gr vp = v%t + v%x(3) vm = v%t - v%x(3) v12 = v%x(1) + (0,1)*v%x(2) v12s = v%x(1) - (0,1)*v%x(2) vpsi%a(1) = gr2 * ( vm * psi%a(3) - v12s * psi%a(4)) vpsi%a(2) = gr2 * ( - v12 * psi%a(3) + vp * psi%a(4)) vpsi%a(3) = 0 vpsi%a(4) = 0 end function f_vrf @ <>= pure function f_vlrf (gl, gr, v, psi) result (vpsi) type(bispinor) :: vpsi complex(kind=default), intent(in) :: gl, gr type(vector), intent(in) :: v type(bispinor), intent(in) :: psi vpsi = f_vaf (gl+gr, gl-gr, v, psi) end function f_vlrf @ <>= pure function f_tvaf (gv, ga, t, psi) result (tpsi) type(bispinor) :: tpsi complex(kind=default), intent(in) :: gv, ga type(tensor2odd), intent(in) :: t type(bispinor), intent(in) :: psi complex(kind=default) :: gl, gr complex(kind=default) :: e21, e21s, b12, b12s, be3, be3s gr = gv + ga gl = gv - ga e21 = t%e(2) + t%e(1)*(0,1) e21s = t%e(2) - t%e(1)*(0,1) b12 = t%b(1) + t%b(2)*(0,1) b12s = t%b(1) - t%b(2)*(0,1) be3 = t%b(3) + t%e(3)*(0,1) be3s = t%b(3) - t%e(3)*(0,1) tpsi%a(1) = 2*gl * ( psi%a(1) * be3 + psi%a(2) * ( e21 +b12s)) tpsi%a(2) = 2*gl * ( - psi%a(2) * be3 + psi%a(1) * (-e21s+b12 )) tpsi%a(3) = 2*gr * ( psi%a(3) * be3s + psi%a(4) * (-e21 +b12s)) tpsi%a(4) = 2*gr * ( - psi%a(4) * be3s + psi%a(3) * ( e21s+b12 )) end function f_tvaf @ <>= pure function f_tlrf (gl, gr, t, psi) result (tpsi) type(bispinor) :: tpsi complex(kind=default), intent(in) :: gl, gr type(tensor2odd), intent(in) :: t type(bispinor), intent(in) :: psi tpsi = f_tvaf (gr+gl, gr-gl, t, psi) end function f_tlrf @ <>= pure function f_tvamf (gv, ga, v, psi, k) result (vpsi) type(bispinor) :: vpsi complex(kind=default), intent(in) :: gv, ga type(vector), intent(in) :: v type(bispinor), intent(in) :: psi type(momentum), intent(in) :: k type(tensor2odd) :: t t = (v.wedge.k) * (0, 0.5) vpsi = f_tvaf(gv, ga, t, psi) end function f_tvamf @ <>= pure function f_tlrmf (gl, gr, v, psi, k) result (vpsi) type(bispinor) :: vpsi complex(kind=default), intent(in) :: gl, gr type(vector), intent(in) :: v type(bispinor), intent(in) :: psi type(momentum), intent(in) :: k vpsi = f_tvamf (gr+gl, gr-gl, v, psi, k) end function f_tlrmf @ \subsection{Fermionic Scalar and Pseudo Scalar Couplings} <>= public :: sp_ff, s_ff, p_ff, sl_ff, sr_ff, slr_ff @ <>= pure function sp_ff (gs, gp, psil, psir) result (j) complex(kind=default) :: j complex(kind=default), intent(in) :: gs, gp type(bispinor), intent(in) :: psil, psir j = (gs - gp) * (psil%a(1)*psir%a(2) - psil%a(2)*psir%a(1)) & + (gs + gp) * (- psil%a(3)*psir%a(4) + psil%a(4)*psir%a(3)) end function sp_ff @ <>= pure function s_ff (gs, psil, psir) result (j) complex(kind=default) :: j complex(kind=default), intent(in) :: gs type(bispinor), intent(in) :: psil, psir j = gs * (psil * psir) end function s_ff @ <>= pure function p_ff (gp, psil, psir) result (j) complex(kind=default) :: j complex(kind=default), intent(in) :: gp type(bispinor), intent(in) :: psil, psir j = gp * (- psil%a(1)*psir%a(2) + psil%a(2)*psir%a(1) & - psil%a(3)*psir%a(4) + psil%a(4)*psir%a(3)) end function p_ff @ <>= pure function sl_ff (gl, psil, psir) result (j) complex(kind=default) :: j complex(kind=default), intent(in) :: gl type(bispinor), intent(in) :: psil, psir j = 2 * gl * (psil%a(1)*psir%a(2) - psil%a(2)*psir%a(1)) end function sl_ff @ <>= pure function sr_ff (gr, psil, psir) result (j) complex(kind=default) :: j complex(kind=default), intent(in) :: gr type(bispinor), intent(in) :: psil, psir j = 2 * gr * (- psil%a(3)*psir%a(4) + psil%a(4)*psir%a(3)) end function sr_ff @ <>= pure function slr_ff (gl, gr, psibar, psi) result (j) complex(kind=default) :: j complex(kind=default), intent(in) :: gl, gr type(bispinor), intent(in) :: psibar type(bispinor), intent(in) :: psi j = sp_ff (gr+gl, gr-gl, psibar, psi) end function slr_ff @ <>= public :: f_spf, f_sf, f_pf, f_slf, f_srf, f_slrf @ <>= pure function f_spf (gs, gp, phi, psi) result (phipsi) type(bispinor) :: phipsi complex(kind=default), intent(in) :: gs, gp complex(kind=default), intent(in) :: phi type(bispinor), intent(in) :: psi phipsi%a(1:2) = ((gs - gp) * phi) * psi%a(1:2) phipsi%a(3:4) = ((gs + gp) * phi) * psi%a(3:4) end function f_spf @ <>= pure function f_sf (gs, phi, psi) result (phipsi) type(bispinor) :: phipsi complex(kind=default), intent(in) :: gs complex(kind=default), intent(in) :: phi type(bispinor), intent(in) :: psi phipsi%a = (gs * phi) * psi%a end function f_sf @ <>= pure function f_pf (gp, phi, psi) result (phipsi) type(bispinor) :: phipsi complex(kind=default), intent(in) :: gp complex(kind=default), intent(in) :: phi type(bispinor), intent(in) :: psi phipsi%a(1:2) = (- gp * phi) * psi%a(1:2) phipsi%a(3:4) = ( gp * phi) * psi%a(3:4) end function f_pf @ <>= pure function f_slf (gl, phi, psi) result (phipsi) type(bispinor) :: phipsi complex(kind=default), intent(in) :: gl complex(kind=default), intent(in) :: phi type(bispinor), intent(in) :: psi phipsi%a(1:2) = (2 * gl * phi) * psi%a(1:2) phipsi%a(3:4) = 0 end function f_slf @ <>= pure function f_srf (gr, phi, psi) result (phipsi) type(bispinor) :: phipsi complex(kind=default), intent(in) :: gr complex(kind=default), intent(in) :: phi type(bispinor), intent(in) :: psi phipsi%a(1:2) = 0 phipsi%a(3:4) = (2 * gr * phi) * psi%a(3:4) end function f_srf @ <>= pure function f_slrf (gl, gr, phi, psi) result (phipsi) type(bispinor) :: phipsi complex(kind=default), intent(in) :: gl, gr complex(kind=default), intent(in) :: phi type(bispinor), intent(in) :: psi phipsi = f_spf (gr+gl, gr-gl, phi, psi) end function f_slrf @ \subsection{Couplings for BRST Transformations} \subsubsection{3-Couplings} The lists of needed gamma matrices can be found in the next subsection with the gravitino couplings. <>= private :: vv_ff, f_vvf @ <>= public :: vmom_ff, mom_ff, mom5_ff, moml_ff, momr_ff, lmom_ff, rmom_ff @ <>= pure function vv_ff (psibar, psi, k) result (psibarpsi) type(vector) :: psibarpsi type(bispinor), intent(in) :: psibar, psi type(vector), intent(in) :: k complex(kind=default) :: kp, km, k12, k12s type(bispinor) :: kgpsi1, kgpsi2, kgpsi3, kgpsi4 kp = k%t + k%x(3) km = k%t - k%x(3) k12 = k%x(1) + (0,1)*k%x(2) k12s = k%x(1) - (0,1)*k%x(2) kgpsi1%a(1) = -k%x(3) * psi%a(1) - k12s * psi%a(2) kgpsi1%a(2) = -k12 * psi%a(1) + k%x(3) * psi%a(2) kgpsi1%a(3) = k%x(3) * psi%a(3) + k12s * psi%a(4) kgpsi1%a(4) = k12 * psi%a(3) - k%x(3) * psi%a(4) kgpsi2%a(1) = ((0,-1) * k%x(2)) * psi%a(1) - km * psi%a(2) kgpsi2%a(2) = - kp * psi%a(1) + ((0,1) * k%x(2)) * psi%a(2) kgpsi2%a(3) = ((0,-1) * k%x(2)) * psi%a(3) + kp * psi%a(4) kgpsi2%a(4) = km * psi%a(3) + ((0,1) * k%x(2)) * psi%a(4) kgpsi3%a(1) = (0,1) * (k%x(1) * psi%a(1) + km * psi%a(2)) kgpsi3%a(2) = (0,-1) * (kp * psi%a(1) + k%x(1) * psi%a(2)) kgpsi3%a(3) = (0,1) * (k%x(1) * psi%a(3) - kp * psi%a(4)) kgpsi3%a(4) = (0,1) * (km * psi%a(3) - k%x(1) * psi%a(4)) kgpsi4%a(1) = -k%t * psi%a(1) - k12s * psi%a(2) kgpsi4%a(2) = k12 * psi%a(1) + k%t * psi%a(2) kgpsi4%a(3) = k%t * psi%a(3) - k12s * psi%a(4) kgpsi4%a(4) = k12 * psi%a(3) - k%t * psi%a(4) psibarpsi%t = 2 * (psibar * kgpsi1) psibarpsi%x(1) = 2 * (psibar * kgpsi2) psibarpsi%x(2) = 2 * (psibar * kgpsi3) psibarpsi%x(3) = 2 * (psibar * kgpsi4) end function vv_ff @ <>= pure function f_vvf (v, psi, k) result (kvpsi) type(bispinor) :: kvpsi type(bispinor), intent(in) :: psi type(vector), intent(in) :: k, v complex(kind=default) :: kv30, kv21, kv01, kv31, kv02, kv32 complex(kind=default) :: ap, am, bp, bm, bps, bms kv30 = k%x(3) * v%t - k%t * v%x(3) kv21 = (0,1) * (k%x(2) * v%x(1) - k%x(1) * v%x(2)) kv01 = k%t * v%x(1) - k%x(1) * v%t kv31 = k%x(3) * v%x(1) - k%x(1) * v%x(3) kv02 = (0,1) * (k%t * v%x(2) - k%x(2) * v%t) kv32 = (0,1) * (k%x(3) * v%x(2) - k%x(2) * v%x(3)) ap = 2 * (kv30 + kv21) am = 2 * (-kv30 + kv21) bp = 2 * (kv01 + kv31 + kv02 + kv32) bm = 2 * (kv01 - kv31 + kv02 - kv32) bps = 2 * (kv01 + kv31 - kv02 - kv32) bms = 2 * (kv01 - kv31 - kv02 + kv32) kvpsi%a(1) = am * psi%a(1) + bms * psi%a(2) kvpsi%a(2) = bp * psi%a(1) - am * psi%a(2) kvpsi%a(3) = ap * psi%a(3) - bps * psi%a(4) kvpsi%a(4) = -bm * psi%a(3) - ap * psi%a(4) end function f_vvf @ <>= pure function vmom_ff (g, psibar, psi, k) result (psibarpsi) type(vector) :: psibarpsi complex(kind=default), intent(in) :: g type(bispinor), intent(in) :: psibar, psi type(momentum), intent(in) :: k type(vector) :: vk vk = k psibarpsi = g * vv_ff (psibar, psi, vk) end function vmom_ff @ <>= pure function mom_ff (g, m, psibar, psi, k) result (psibarpsi) complex(kind=default) :: psibarpsi type(bispinor), intent(in) :: psibar, psi type(momentum), intent(in) :: k complex(kind=default), intent(in) :: g, m type(bispinor) :: kmpsi complex(kind=default) :: kp, km, k12, k12s kp = k%t + k%x(3) km = k%t - k%x(3) k12 = k%x(1) + (0,1)*k%x(2) k12s = k%x(1) - (0,1)*k%x(2) kmpsi%a(1) = km * psi%a(3) - k12s * psi%a(4) kmpsi%a(2) = kp * psi%a(4) - k12 * psi%a(3) kmpsi%a(3) = kp * psi%a(1) + k12s * psi%a(2) kmpsi%a(4) = k12 * psi%a(1) + km * psi%a(2) psibarpsi = g * (psibar * kmpsi) + s_ff (m, psibar, psi) end function mom_ff @ <>= pure function mom5_ff (g, m, psibar, psi, k) result (psibarpsi) complex(kind=default) :: psibarpsi type(bispinor), intent(in) :: psibar, psi type(momentum), intent(in) :: k complex(kind=default), intent(in) :: g, m type(bispinor) :: g5psi g5psi%a(1:2) = - psi%a(1:2) g5psi%a(3:4) = psi%a(3:4) psibarpsi = mom_ff (g, m, psibar, g5psi, k) end function mom5_ff @ <>= pure function moml_ff (g, m, psibar, psi, k) result (psibarpsi) complex(kind=default) :: psibarpsi type(bispinor), intent(in) :: psibar, psi type(momentum), intent(in) :: k complex(kind=default), intent(in) :: g, m type(bispinor) :: leftpsi leftpsi%a(1:2) = 2 * psi%a(1:2) leftpsi%a(3:4) = 0 psibarpsi = mom_ff (g, m, psibar, leftpsi, k) end function moml_ff @ <>= pure function momr_ff (g, m, psibar, psi, k) result (psibarpsi) complex(kind=default) :: psibarpsi type(bispinor), intent(in) :: psibar, psi type(momentum), intent(in) :: k complex(kind=default), intent(in) :: g, m type(bispinor) :: rightpsi rightpsi%a(1:2) = 0 rightpsi%a(3:4) = 2 * psi%a(3:4) psibarpsi = mom_ff (g, m, psibar, rightpsi, k) end function momr_ff @ <>= pure function lmom_ff (g, m, psibar, psi, k) result (psibarpsi) complex(kind=default) :: psibarpsi type(bispinor), intent(in) :: psibar, psi type(momentum), intent(in) :: k complex(kind=default), intent(in) :: g, m psibarpsi = mom_ff (g, m, psibar, psi, k) + & mom5_ff (g,-m, psibar, psi, k) end function lmom_ff @ <>= pure function rmom_ff (g, m, psibar, psi, k) result (psibarpsi) complex(kind=default) :: psibarpsi type(bispinor), intent(in) :: psibar, psi type(momentum), intent(in) :: k complex(kind=default), intent(in) :: g, m psibarpsi = mom_ff (g, m, psibar, psi, k) - & mom5_ff (g,-m, psibar, psi, k) end function rmom_ff @ <>= public :: f_vmomf, f_momf, f_mom5f, f_momlf, f_momrf, f_lmomf, f_rmomf @ <>= pure function f_vmomf (g, v, psi, k) result (kvpsi) type(bispinor) :: kvpsi type(bispinor), intent(in) :: psi complex(kind=default), intent(in) :: g type(momentum), intent(in) :: k type(vector), intent(in) :: v type(vector) :: vk vk = k kvpsi = g * f_vvf (v, psi, vk) end function f_vmomf @ <>= pure function f_momf (g, m, phi, psi, k) result (kmpsi) type(bispinor) :: kmpsi type(bispinor), intent(in) :: psi complex(kind=default), intent(in) :: phi, g, m type(momentum), intent(in) :: k complex(kind=default) :: kp, km, k12, k12s kp = k%t + k%x(3) km = k%t - k%x(3) k12 = k%x(1) + (0,1)*k%x(2) k12s = k%x(1) - (0,1)*k%x(2) kmpsi%a(1) = km * psi%a(3) - k12s * psi%a(4) kmpsi%a(2) = -k12 * psi%a(3) + kp * psi%a(4) kmpsi%a(3) = kp * psi%a(1) + k12s * psi%a(2) kmpsi%a(4) = k12 * psi%a(1) + km * psi%a(2) kmpsi = g * (phi * kmpsi) + f_sf (m, phi, psi) end function f_momf @ <>= pure function f_mom5f (g, m, phi, psi, k) result (kmpsi) type(bispinor) :: kmpsi type(bispinor), intent(in) :: psi complex(kind=default), intent(in) :: phi, g, m type(momentum), intent(in) :: k type(bispinor) :: g5psi g5psi%a(1:2) = - psi%a(1:2) g5psi%a(3:4) = psi%a(3:4) kmpsi = f_momf (g, m, phi, g5psi, k) end function f_mom5f @ <>= pure function f_momlf (g, m, phi, psi, k) result (kmpsi) type(bispinor) :: kmpsi type(bispinor), intent(in) :: psi complex(kind=default), intent(in) :: phi, g, m type(momentum), intent(in) :: k type(bispinor) :: leftpsi leftpsi%a(1:2) = 2 * psi%a(1:2) leftpsi%a(3:4) = 0 kmpsi = f_momf (g, m, phi, leftpsi, k) end function f_momlf @ <>= pure function f_momrf (g, m, phi, psi, k) result (kmpsi) type(bispinor) :: kmpsi type(bispinor), intent(in) :: psi complex(kind=default), intent(in) :: phi, g, m type(momentum), intent(in) :: k type(bispinor) :: rightpsi rightpsi%a(1:2) = 0 rightpsi%a(3:4) = 2 * psi%a(3:4) kmpsi = f_momf (g, m, phi, rightpsi, k) end function f_momrf @ <>= pure function f_lmomf (g, m, phi, psi, k) result (kmpsi) type(bispinor) :: kmpsi type(bispinor), intent(in) :: psi complex(kind=default), intent(in) :: phi, g, m type(momentum), intent(in) :: k kmpsi = f_momf (g, m, phi, psi, k) + & f_mom5f (g,-m, phi, psi, k) end function f_lmomf @ <>= pure function f_rmomf (g, m, phi, psi, k) result (kmpsi) type(bispinor) :: kmpsi type(bispinor), intent(in) :: psi complex(kind=default), intent(in) :: phi, g, m type(momentum), intent(in) :: k kmpsi = f_momf (g, m, phi, psi, k) - & f_mom5f (g,-m, phi, psi, k) end function f_rmomf @ \subsubsection{4-Couplings} <>= public :: v2_ff, sv1_ff, sv2_ff, pv1_ff, pv2_ff, svl1_ff, svl2_ff, & svr1_ff, svr2_ff, svlr1_ff, svlr2_ff @ <>= pure function v2_ff (g, psibar, v, psi) result (v2) type(vector) :: v2 complex (kind=default), intent(in) :: g type(bispinor), intent(in) :: psibar, psi type(vector), intent(in) :: v v2 = (-g) * vv_ff (psibar, psi, v) end function v2_ff @ <>= pure function sv1_ff (g, psibar, v, psi) result (phi) complex(kind=default) :: phi type(bispinor), intent(in) :: psibar, psi type(vector), intent(in) :: v complex(kind=default), intent(in) :: g phi = psibar * f_vf (g, v, psi) end function sv1_ff @ <>= pure function sv2_ff (g, psibar, phi, psi) result (v) type(vector) :: v complex(kind=default), intent(in) :: phi, g type(bispinor), intent(in) :: psibar, psi v = phi * v_ff (g, psibar, psi) end function sv2_ff @ <>= pure function pv1_ff (g, psibar, v, psi) result (phi) complex(kind=default) :: phi type(bispinor), intent(in) :: psibar, psi type(vector), intent(in) :: v complex(kind=default), intent(in) :: g phi = - (psibar * f_af (g, v, psi)) end function pv1_ff @ <>= pure function pv2_ff (g, psibar, phi, psi) result (v) type(vector) :: v complex(kind=default), intent(in) :: phi, g type(bispinor), intent(in) :: psibar, psi v = -(phi * a_ff (g, psibar, psi)) end function pv2_ff @ <>= pure function svl1_ff (g, psibar, v, psi) result (phi) complex(kind=default) :: phi type(bispinor), intent(in) :: psibar, psi type(vector), intent(in) :: v complex(kind=default), intent(in) :: g phi = psibar * f_vlf (g, v, psi) end function svl1_ff @ <>= pure function svl2_ff (g, psibar, phi, psi) result (v) type(vector) :: v complex(kind=default), intent(in) :: phi, g type(bispinor), intent(in) :: psibar, psi v = phi * vl_ff (g, psibar, psi) end function svl2_ff @ <>= pure function svr1_ff (g, psibar, v, psi) result (phi) complex(kind=default) :: phi type(bispinor), intent(in) :: psibar, psi type(vector), intent(in) :: v complex(kind=default), intent(in) :: g phi = psibar * f_vrf (g, v, psi) end function svr1_ff @ <>= pure function svr2_ff (g, psibar, phi, psi) result (v) type(vector) :: v complex(kind=default), intent(in) :: phi, g type(bispinor), intent(in) :: psibar, psi v = phi * vr_ff (g, psibar, psi) end function svr2_ff @ <>= pure function svlr1_ff (gl, gr, psibar, v, psi) result (phi) complex(kind=default) :: phi type(bispinor), intent(in) :: psibar, psi type(vector), intent(in) :: v complex(kind=default), intent(in) :: gl, gr phi = psibar * f_vlrf (gl, gr, v, psi) end function svlr1_ff @ <>= pure function svlr2_ff (gl, gr, psibar, phi, psi) result (v) type(vector) :: v complex(kind=default), intent(in) :: phi, gl, gr type(bispinor), intent(in) :: psibar, psi v = phi * vlr_ff (gl, gr, psibar, psi) end function svlr2_ff @ <>= public :: f_v2f, f_svf, f_pvf, f_svlf, f_svrf, f_svlrf @ <>= pure function f_v2f (g, v1, v2, psi) result (vpsi) type(bispinor) :: vpsi complex(kind=default), intent(in) :: g type(bispinor), intent(in) :: psi type(vector), intent(in) :: v1, v2 vpsi = g * f_vvf (v2, psi, v1) end function f_v2f @ <>= pure function f_svf (g, phi, v, psi) result (pvpsi) type(bispinor) :: pvpsi complex(kind=default), intent(in) :: g, phi type(bispinor), intent(in) :: psi type(vector), intent(in) :: v pvpsi = phi * f_vf (g, v, psi) end function f_svf @ <>= pure function f_pvf (g, phi, v, psi) result (pvpsi) type(bispinor) :: pvpsi complex(kind=default), intent(in) :: g, phi type(bispinor), intent(in) :: psi type(vector), intent(in) :: v pvpsi = -(phi * f_af (g, v, psi)) end function f_pvf @ <>= pure function f_svlf (g, phi, v, psi) result (pvpsi) type(bispinor) :: pvpsi complex(kind=default), intent(in) :: g, phi type(bispinor), intent(in) :: psi type(vector), intent(in) :: v pvpsi = phi * f_vlf (g, v, psi) end function f_svlf @ <>= pure function f_svrf (g, phi, v, psi) result (pvpsi) type(bispinor) :: pvpsi complex(kind=default), intent(in) :: g, phi type(bispinor), intent(in) :: psi type(vector), intent(in) :: v pvpsi = phi * f_vrf (g, v, psi) end function f_svrf @ <>= pure function f_svlrf (gl, gr, phi, v, psi) result (pvpsi) type(bispinor) :: pvpsi complex(kind=default), intent(in) :: gl, gr, phi type(bispinor), intent(in) :: psi type(vector), intent(in) :: v pvpsi = phi * f_vlrf (gl, gr, v, psi) end function f_svlrf @ \subsection{Gravitino Couplings} <>= public :: pot_grf, pot_fgr, s_grf, s_fgr, p_grf, p_fgr, & sl_grf, sl_fgr, sr_grf, sr_fgr, slr_grf, slr_fgr @ <>= private :: fgvgr, fgvg5gr, fggvvgr, grkgf, grkggf, grkkggf, & fgkgr, fg5gkgr, grvgf, grg5vgf, grkgggf, fggkggr @ <>= pure function pot_grf (g, gravbar, psi) result (j) complex(kind=default) :: j complex(kind=default), intent(in) :: g type(vectorspinor), intent(in) :: gravbar type(bispinor), intent(in) :: psi type(vectorspinor) :: gamma_psi gamma_psi%psi(1)%a(1) = psi%a(3) gamma_psi%psi(1)%a(2) = psi%a(4) gamma_psi%psi(1)%a(3) = psi%a(1) gamma_psi%psi(1)%a(4) = psi%a(2) gamma_psi%psi(2)%a(1) = psi%a(4) gamma_psi%psi(2)%a(2) = psi%a(3) gamma_psi%psi(2)%a(3) = - psi%a(2) gamma_psi%psi(2)%a(4) = - psi%a(1) gamma_psi%psi(3)%a(1) = (0,-1) * psi%a(4) gamma_psi%psi(3)%a(2) = (0,1) * psi%a(3) gamma_psi%psi(3)%a(3) = (0,1) * psi%a(2) gamma_psi%psi(3)%a(4) = (0,-1) * psi%a(1) gamma_psi%psi(4)%a(1) = psi%a(3) gamma_psi%psi(4)%a(2) = - psi%a(4) gamma_psi%psi(4)%a(3) = - psi%a(1) gamma_psi%psi(4)%a(4) = psi%a(2) j = g * (gravbar * gamma_psi) end function pot_grf @ <>= pure function pot_fgr (g, psibar, grav) result (j) complex(kind=default) :: j complex(kind=default), intent(in) :: g type(bispinor), intent(in) :: psibar type(vectorspinor), intent(in) :: grav type(bispinor) :: gamma_grav gamma_grav%a(1) = grav%psi(1)%a(3) - grav%psi(2)%a(4) + & ((0,1)*grav%psi(3)%a(4)) - grav%psi(4)%a(3) gamma_grav%a(2) = grav%psi(1)%a(4) - grav%psi(2)%a(3) - & ((0,1)*grav%psi(3)%a(3)) + grav%psi(4)%a(4) gamma_grav%a(3) = grav%psi(1)%a(1) + grav%psi(2)%a(2) - & ((0,1)*grav%psi(3)%a(2)) + grav%psi(4)%a(1) gamma_grav%a(4) = grav%psi(1)%a(2) + grav%psi(2)%a(1) + & ((0,1)*grav%psi(3)%a(1)) - grav%psi(4)%a(2) j = g * (psibar * gamma_grav) end function pot_fgr @ <>= pure function grvgf (gravbar, psi, k) result (j) complex(kind=default) :: j complex(kind=default) :: kp, km, k12, k12s type(vectorspinor), intent(in) :: gravbar type(bispinor), intent(in) :: psi type(vector), intent(in) :: k type(vectorspinor) :: kg_psi kp = k%t + k%x(3) km = k%t - k%x(3) k12 = k%x(1) + (0,1)*k%x(2) k12s = k%x(1) - (0,1)*k%x(2) !!! Since we are taking the spinor product here, NO explicit !!! charge conjugation matrix is needed! kg_psi%psi(1)%a(1) = km * psi%a(1) - k12s * psi%a(2) kg_psi%psi(1)%a(2) = (-k12) * psi%a(1) + kp * psi%a(2) kg_psi%psi(1)%a(3) = kp * psi%a(3) + k12s * psi%a(4) kg_psi%psi(1)%a(4) = k12 * psi%a(3) + km * psi%a(4) kg_psi%psi(2)%a(1) = k12s * psi%a(1) - km * psi%a(2) kg_psi%psi(2)%a(2) = (-kp) * psi%a(1) + k12 * psi%a(2) kg_psi%psi(2)%a(3) = k12s * psi%a(3) + kp * psi%a(4) kg_psi%psi(2)%a(4) = km * psi%a(3) + k12 * psi%a(4) kg_psi%psi(3)%a(1) = (0,1) * (k12s * psi%a(1) + km * psi%a(2)) kg_psi%psi(3)%a(2) = (0,1) * (- kp * psi%a(1) - k12 * psi%a(2)) kg_psi%psi(3)%a(3) = (0,1) * (k12s * psi%a(3) - kp * psi%a(4)) kg_psi%psi(3)%a(4) = (0,1) * (km * psi%a(3) - k12 * psi%a(4)) kg_psi%psi(4)%a(1) = (-km) * psi%a(1) - k12s * psi%a(2) kg_psi%psi(4)%a(2) = k12 * psi%a(1) + kp * psi%a(2) kg_psi%psi(4)%a(3) = kp * psi%a(3) - k12s * psi%a(4) kg_psi%psi(4)%a(4) = k12 * psi%a(3) - km * psi%a(4) j = gravbar * kg_psi end function grvgf @ <>= pure function grg5vgf (gravbar, psi, k) result (j) complex(kind=default) :: j type(vectorspinor), intent(in) :: gravbar type(bispinor), intent(in) :: psi type(vector), intent(in) :: k type(bispinor) :: g5_psi g5_psi%a(1:2) = - psi%a(1:2) g5_psi%a(3:4) = psi%a(3:4) j = grvgf (gravbar, g5_psi, k) end function grg5vgf @ <>= pure function s_grf (g, gravbar, psi, k) result (j) complex(kind=default) :: j complex(kind=default), intent(in) :: g type(vectorspinor), intent(in) :: gravbar type(bispinor), intent(in) :: psi type(momentum), intent(in) :: k type(vector) :: vk vk = k j = g * grvgf (gravbar, psi, vk) end function s_grf @ <>= pure function sl_grf (gl, gravbar, psi, k) result (j) complex(kind=default) :: j complex(kind=default), intent(in) :: gl type(vectorspinor), intent(in) :: gravbar type(bispinor), intent(in) :: psi type(bispinor) :: psi_l type(momentum), intent(in) :: k psi_l%a(1:2) = psi%a(1:2) psi_l%a(3:4) = 0 j = s_grf (gl, gravbar, psi_l, k) end function sl_grf @ <>= pure function sr_grf (gr, gravbar, psi, k) result (j) complex(kind=default) :: j complex(kind=default), intent(in) :: gr type(vectorspinor), intent(in) :: gravbar type(bispinor), intent(in) :: psi type(bispinor) :: psi_r type(momentum), intent(in) :: k psi_r%a(1:2) = 0 psi_r%a(3:4) = psi%a(3:4) j = s_grf (gr, gravbar, psi_r, k) end function sr_grf @ <>= pure function slr_grf (gl, gr, gravbar, psi, k) result (j) complex(kind=default) :: j complex(kind=default), intent(in) :: gl, gr type(vectorspinor), intent(in) :: gravbar type(bispinor), intent(in) :: psi type(momentum), intent(in) :: k j = sl_grf (gl, gravbar, psi, k) + sr_grf (gr, gravbar, psi, k) end function slr_grf @ <>= pure function fgkgr (psibar, grav, k) result (j) complex(kind=default) :: j complex(kind=default) :: kp, km, k12, k12s type(bispinor), intent(in) :: psibar type(vectorspinor), intent(in) :: grav type(vector), intent(in) :: k type(bispinor) :: gk_grav kp = k%t + k%x(3) km = k%t - k%x(3) k12 = k%x(1) + (0,1)*k%x(2) k12s = k%x(1) - (0,1)*k%x(2) !!! Since we are taking the spinor product here, NO explicit !!! charge conjugation matrix is needed! gk_grav%a(1) = kp * grav%psi(1)%a(1) + k12s * grav%psi(1)%a(2) & - k12 * grav%psi(2)%a(1) - km * grav%psi(2)%a(2) & + (0,1) * k12 * grav%psi(3)%a(1) & + (0,1) * km * grav%psi(3)%a(2) & - kp * grav%psi(4)%a(1) - k12s * grav%psi(4)%a(2) gk_grav%a(2) = k12 * grav%psi(1)%a(1) + km * grav%psi(1)%a(2) & - kp * grav%psi(2)%a(1) - k12s * grav%psi(2)%a(2) & - (0,1) * kp * grav%psi(3)%a(1) & - (0,1) * k12s * grav%psi(3)%a(2) & + k12 * grav%psi(4)%a(1) + km * grav%psi(4)%a(2) gk_grav%a(3) = km * grav%psi(1)%a(3) - k12s * grav%psi(1)%a(4) & - k12 * grav%psi(2)%a(3) + kp * grav%psi(2)%a(4) & + (0,1) * k12 * grav%psi(3)%a(3) & - (0,1) * kp * grav%psi(3)%a(4) & + km * grav%psi(4)%a(3) - k12s * grav%psi(4)%a(4) gk_grav%a(4) = - k12 * grav%psi(1)%a(3) + kp * grav%psi(1)%a(4) & + km * grav%psi(2)%a(3) - k12s * grav%psi(2)%a(4) & + (0,1) * km * grav%psi(3)%a(3) & - (0,1) * k12s * grav%psi(3)%a(4) & + k12 * grav%psi(4)%a(3) - kp * grav%psi(4)%a(4) j = psibar * gk_grav end function fgkgr @ <>= pure function fg5gkgr (psibar, grav, k) result (j) complex(kind=default) :: j type(bispinor), intent(in) :: psibar type(vectorspinor), intent(in) :: grav type(vector), intent(in) :: k type(bispinor) :: psibar_g5 psibar_g5%a(1:2) = - psibar%a(1:2) psibar_g5%a(3:4) = psibar%a(3:4) j = fgkgr (psibar_g5, grav, k) end function fg5gkgr @ <>= pure function s_fgr (g, psibar, grav, k) result (j) complex(kind=default) :: j complex(kind=default), intent(in) :: g type(bispinor), intent(in) :: psibar type(vectorspinor), intent(in) :: grav type(momentum), intent(in) :: k type(vector) :: vk vk = k j = g * fgkgr (psibar, grav, vk) end function s_fgr @ <>= pure function sl_fgr (gl, psibar, grav, k) result (j) complex(kind=default) :: j complex(kind=default), intent(in) :: gl type(bispinor), intent(in) :: psibar type(bispinor) :: psibar_l type(vectorspinor), intent(in) :: grav type(momentum), intent(in) :: k psibar_l%a(1:2) = psibar%a(1:2) psibar_l%a(3:4) = 0 j = s_fgr (gl, psibar_l, grav, k) end function sl_fgr @ <>= pure function sr_fgr (gr, psibar, grav, k) result (j) complex(kind=default) :: j complex(kind=default), intent(in) :: gr type(bispinor), intent(in) :: psibar type(bispinor) :: psibar_r type(vectorspinor), intent(in) :: grav type(momentum), intent(in) :: k psibar_r%a(1:2) = 0 psibar_r%a(3:4) = psibar%a(3:4) j = s_fgr (gr, psibar_r, grav, k) end function sr_fgr @ @ <>= pure function slr_fgr (gl, gr, psibar, grav, k) result (j) complex(kind=default) :: j complex(kind=default), intent(in) :: gl, gr type(bispinor), intent(in) :: psibar type(vectorspinor), intent(in) :: grav type(momentum), intent(in) :: k j = sl_fgr (gl, psibar, grav, k) + sr_fgr (gr, psibar, grav, k) end function slr_fgr @ <>= pure function p_grf (g, gravbar, psi, k) result (j) complex(kind=default) :: j complex(kind=default), intent(in) :: g type(vectorspinor), intent(in) :: gravbar type(bispinor), intent(in) :: psi type(momentum), intent(in) :: k type(vector) :: vk vk = k j = g * grg5vgf (gravbar, psi, vk) end function p_grf @ <>= pure function p_fgr (g, psibar, grav, k) result (j) complex(kind=default) :: j complex(kind=default), intent(in) :: g type(bispinor), intent(in) :: psibar type(vectorspinor), intent(in) :: grav type(momentum), intent(in) :: k type(vector) :: vk vk = k j = g * fg5gkgr (psibar, grav, vk) end function p_fgr @ <>= public :: f_potgr, f_sgr, f_pgr, f_vgr, f_vlrgr, f_slgr, f_srgr, f_slrgr @ <>= pure function f_potgr (g, phi, psi) result (phipsi) type(bispinor) :: phipsi complex(kind=default), intent(in) :: g complex(kind=default), intent(in) :: phi type(vectorspinor), intent(in) :: psi phipsi%a(1) = (g * phi) * (psi%psi(1)%a(3) - psi%psi(2)%a(4) + & ((0,1)*psi%psi(3)%a(4)) - psi%psi(4)%a(3)) phipsi%a(2) = (g * phi) * (psi%psi(1)%a(4) - psi%psi(2)%a(3) - & ((0,1)*psi%psi(3)%a(3)) + psi%psi(4)%a(4)) phipsi%a(3) = (g * phi) * (psi%psi(1)%a(1) + psi%psi(2)%a(2) - & ((0,1)*psi%psi(3)%a(2)) + psi%psi(4)%a(1)) phipsi%a(4) = (g * phi) * (psi%psi(1)%a(2) + psi%psi(2)%a(1) + & ((0,1)*psi%psi(3)%a(1)) - psi%psi(4)%a(2)) end function f_potgr @ The slashed notation: \begin{equation} \fmslash{k} = \begin{pmatrix} 0 & 0 & k_- & - k^* \\ 0 & 0 & - k & k_+ \\ k_+ & k^* & 0 & 0 \\ k & k_- & 0 & 0 \end{pmatrix} , \qquad \fmslash{k}\gamma_5 = \begin{pmatrix} 0 & 0 & k_- & - k^* \\ 0 & 0 & - k & k_+ \\ - k_+ & - k^* & 0 & 0 \\ - k & - k_- & 0 & 0 \end{pmatrix} \end{equation} with $k_\pm=k_0\pm k_3$, $k=k_1+\ii k_2$, $k^*=k_1-\ii k_2$. But note that~$\cdot^*$ is \emph{not} complex conjugation for complex~$k_\mu$. \begin{subequations} \begin{alignat}{2} \gamma^0 \fmslash{k} &= \begin{pmatrix} k_+ & k^* & 0 & 0 \\ k & k_- & 0 & 0 \\ 0 & 0 & k_- & - k^* \\ 0 & 0 & - k & k_+ \end{pmatrix} , & \qquad \gamma^0 \fmslash{k} \gamma^5 & = \begin{pmatrix} - k_+ & - k^* & 0 & 0 \\ - k & - k_- & 0 & 0 \\ 0 & 0 & k_- & - k^* \\ 0 & 0 & - k & k_+ \end{pmatrix} \\ \gamma^1 \fmslash{k} &= \begin{pmatrix} k & k_- & 0 & 0 \\ k_+ & k^* & 0 & 0 \\ 0 & 0 & k & - k_+ \\ 0 & 0 & - k_- & k^* \end{pmatrix}, & \qquad \gamma^1 \fmslash{k} \gamma^5 & = \begin{pmatrix} - k & - k_- & 0 & 0 \\ - k_+ & - k^* & 0 & 0 \\ 0 & 0 & k & - k_+ \\ 0 & 0 & - k_- & k^* \end{pmatrix} \\ \gamma^2 \fmslash{k} &= \begin{pmatrix} - \ii k & - \ii k_- & 0 & 0 \\ \ii k_+ & \ii k^* & 0 & 0 \\ 0 & 0 & - \ii k & \ii k_+ \\ 0 & 0 & - \ii k_- & \ii k^* \end{pmatrix}, & \qquad \gamma^2 \fmslash{k} \gamma^5 & = \begin{pmatrix} \ii k & \ii k_- & 0 & 0 \\ - \ii k_+ & - \ii k^* & 0 & 0 \\ 0 & 0 & - \ii k & \ii k_+ \\ 0 & 0 & - \ii k_- & \ii k^* \end{pmatrix} \\ \gamma^3 \fmslash{k} &= \begin{pmatrix} k_+ & k^* & 0 & 0 \\ - k & - k_- & 0 & 0 \\ 0 & 0 & - k_- & k^* \\ 0 & 0 & - k & k_+ \end{pmatrix}, & \qquad \gamma^3 \fmslash{k} \gamma^5 & = \begin{pmatrix} - k_+ & - k^* & 0 & 0 \\ k & k_- & 0 & 0 \\ 0 & 0 & - k_- & k^* \\ 0 & 0 & - k & k_+ \end{pmatrix} \end{alignat} \end{subequations} and \begin{subequations} \begin{alignat}{2} \fmslash{k} \gamma^0&= \begin{pmatrix} k_- & - k^* & 0 & 0 \\ - k & k_+ & 0 & 0 \\ 0 & 0 & k_+ & k^* \\ 0 & 0 & k & k_- \end{pmatrix} , & \qquad \fmslash{k} \gamma^0 \gamma^5 & = \begin{pmatrix} - k_- & k^* & 0 & 0 \\ k & - k_+ & 0 & 0 \\ 0 & 0 & k_+ & k^* \\ 0 & 0 & k & k_- \end{pmatrix} \\ \fmslash{k} \gamma^1 &= \begin{pmatrix} k^* & - k_- & 0 & 0 \\ - k_+ & k & 0 & 0 \\ 0 & 0 & k^* & k_+ \\ 0 & 0 & k_- & k \end{pmatrix}, & \qquad \fmslash{k} \gamma^1 \gamma^5 & = \begin{pmatrix} - k^* & k_- & 0 & 0 \\ k_+ & - k & 0 & 0 \\ 0 & 0 & k^* & k_+ \\ 0 & 0 & k_- & k \end{pmatrix} \\ \fmslash{k} \gamma^2 &= \begin{pmatrix} \ii k^* & \ii k_- & 0 & 0 \\ - \ii k_+ & - \ii k & 0 & 0 \\ 0 & 0 & \ii k^* & - \ii k_+ \\ 0 & 0 & \ii k_- & - \ii k \end{pmatrix}, & \qquad \fmslash{k} \gamma^2 \gamma^5 & = \begin{pmatrix} - \ii k^* & - \ii k_- & 0 & 0 \\ \ii k_+ & \ii k & 0 & 0 \\ 0 & 0 & \ii k^* & - \ii k_+ \\ 0 & 0 & \ii k_- & - \ii k \end{pmatrix} \\ \fmslash{k} \gamma^3 &= \begin{pmatrix} - k_- & - k^* & 0 & 0 \\ k & k_+ & 0 & 0 \\ 0 & 0 & k_+ & - k^* \\ 0 & 0 & k & - k_- \end{pmatrix}, & \qquad \fmslash{k} \gamma^3 \gamma^5 & = \begin{pmatrix} k_- & k^* & 0 & 0 \\ - k & - k_+ & 0 & 0 \\ 0 & 0 & k_+ & - k^* \\ 0 & 0 & k & - k_- \end{pmatrix} \end{alignat} \end{subequations} and \begin{subequations} \begin{alignat}{2} C \gamma^0 \fmslash{k} &= \begin{pmatrix} k & k_- & 0 & 0 \\ - k_+ & - k^* & 0 & 0 \\ 0 & 0 & k & - k_+ \\ 0 & 0 & k_- & - k^* \end{pmatrix} , & \qquad C \gamma^0 \fmslash{k} \gamma^5 & = \begin{pmatrix} - k & - k_- & 0 & 0 \\ k_+ & k^* & 0 & 0 \\ 0 & 0 & k & - k_+ \\ 0 & 0 & k_- & - k^* \end{pmatrix} \\ C \gamma^1 \fmslash{k} &= \begin{pmatrix} k_+ & k^* & 0 & 0 \\ - k & - k_- & 0 & 0 \\ 0 & 0 & k_- & - k^* \\ 0 & 0 & k & - k_+ \end{pmatrix}, & \qquad C \gamma^1 \fmslash{k} \gamma^5 & = \begin{pmatrix} - k_+ & - k^* & 0 & 0 \\ k & k_- & 0 & 0 \\ 0 & 0 & k_- & - k^* \\ 0 & 0 & k & - k_+ \end{pmatrix} \\ C \gamma^2 \fmslash{k} &= \begin{pmatrix} \ii k_+ & \ii k^* & 0 & 0 \\ \ii k & \ii k_- & 0 & 0 \\ 0 & 0 & \ii k_- & - \ii k^* \\ 0 & 0 & - \ii k & \ii k_+ \end{pmatrix}, & \qquad C \gamma^2 \fmslash{k} \gamma^5 & = \begin{pmatrix} - \ii k_+ & - \ii k^* & 0 & 0 \\ - \ii k & - \ii k_- & 0 & 0 \\ 0 & 0 & \ii k_- & - \ii k^* \\ 0 & 0 & - \ii k & \ii k_+ \end{pmatrix} \\ C \gamma^3 \fmslash{k} &= \begin{pmatrix} - k & - k_- & 0 & 0 \\ - k_+ & - k^* & 0 & 0 \\ 0 & 0 & k & - k_+ \\ 0 & 0 & - k_- & k^* \end{pmatrix}, & \qquad C \gamma^3 \fmslash{k} \gamma^5 & = \begin{pmatrix} k & k_- & 0 & 0 \\ k_+ & k^* & 0 & 0 \\ 0 & 0 & k & - k_+ \\ 0 & 0 & - k_- & k^* \end{pmatrix} \end{alignat} \end{subequations} and \begin{subequations} \begin{alignat}{2} C \fmslash{k} \gamma^0&= \begin{pmatrix} - k & k^+ & 0 & 0 \\ - k_- & k^* & 0 & 0 \\ 0 & 0 & - k & - k_- \\ 0 & 0 & k_+ & k^* \end{pmatrix} , & \qquad C \fmslash{k} \gamma^0 \gamma^5 & = \begin{pmatrix} k & - k_+ & 0 & 0 \\ k_- & - k^* & 0 & 0 \\ 0 & 0 & - k & - k_- \\ 0 & 0 & k_+ & k^* \end{pmatrix} \\ C \fmslash{k} \gamma^1 &= \begin{pmatrix} - k_+ & k & 0 & 0 \\ - k^* & k_- & 0 & 0 \\ 0 & 0 & - k_- & - k \\ 0 & 0 & k^* & k_+ \end{pmatrix}, & \qquad C \fmslash{k} \gamma^1 \gamma^5 & = \begin{pmatrix} k_+ & - k & 0 & 0 \\ k^* & - k_- & 0 & 0 \\ 0 & 0 & - k_- & - k \\ 0 & 0 & k^* & k_+ \end{pmatrix} \\ C \fmslash{k} \gamma^2 &= \begin{pmatrix} - \ii k_+ & - \ii k & 0 & 0 \\ - \ii k^* & - \ii k_- & 0 & 0 \\ 0 & 0 & - \ii k_- & \ii k \\ 0 & 0 & \ii k^* & - \ii k_+ \end{pmatrix}, & \qquad C \fmslash{k} \gamma^2 \gamma^5 & = \begin{pmatrix} \ii k_+ & \ii k & 0 & 0 \\ \ii k^* & \ii k_- & 0 & 0 \\ 0 & 0 & - \ii k_- & \ii k \\ 0 & 0 & \ii k^* & - \ii k_+ \end{pmatrix} \\ C \fmslash{k} \gamma^3 &= \begin{pmatrix} k & k_+ & 0 & 0 \\ k_- & k^* & 0 & 0 \\ 0 & 0 & - k & k_- \\ 0 & 0 & k_+ & - k^* \end{pmatrix}, & \qquad C \fmslash{k} \gamma^3 \gamma^5 & = \begin{pmatrix} - k & - k_+ & 0 & 0 \\ - k_- & - k^* & 0 & 0 \\ 0 & 0 & - k & k_- \\ 0 & 0 & k_+ & - k^* \end{pmatrix} \end{alignat} \end{subequations} <>= pure function fgvgr (psi, k) result (kpsi) type(bispinor) :: kpsi complex(kind=default) :: kp, km, k12, k12s type(vector), intent(in) :: k type(vectorspinor), intent(in) :: psi kp = k%t + k%x(3) km = k%t - k%x(3) k12 = k%x(1) + (0,1)*k%x(2) k12s = k%x(1) - (0,1)*k%x(2) kpsi%a(1) = kp * psi%psi(1)%a(1) + k12s * psi%psi(1)%a(2) & - k12 * psi%psi(2)%a(1) - km * psi%psi(2)%a(2) & + (0,1) * k12 * psi%psi(3)%a(1) + (0,1) * km * psi%psi(3)%a(2) & - kp * psi%psi(4)%a(1) - k12s * psi%psi(4)%a(2) kpsi%a(2) = k12 * psi%psi(1)%a(1) + km * psi%psi(1)%a(2) & - kp * psi%psi(2)%a(1) - k12s * psi%psi(2)%a(2) & - (0,1) * kp * psi%psi(3)%a(1) - (0,1) * k12s * psi%psi(3)%a(2) & + k12 * psi%psi(4)%a(1) + km * psi%psi(4)%a(2) kpsi%a(3) = km * psi%psi(1)%a(3) - k12s * psi%psi(1)%a(4) & - k12 * psi%psi(2)%a(3) + kp * psi%psi(2)%a(4) & + (0,1) * k12 * psi%psi(3)%a(3) - (0,1) * kp * psi%psi(3)%a(4) & + km * psi%psi(4)%a(3) - k12s * psi%psi(4)%a(4) kpsi%a(4) = - k12 * psi%psi(1)%a(3) + kp * psi%psi(1)%a(4) & + km * psi%psi(2)%a(3) - k12s * psi%psi(2)%a(4) & + (0,1) * km * psi%psi(3)%a(3) - (0,1) * k12s * psi%psi(3)%a(4) & + k12 * psi%psi(4)%a(3) - kp * psi%psi(4)%a(4) end function fgvgr @ <>= pure function f_sgr (g, phi, psi, k) result (phipsi) type(bispinor) :: phipsi complex(kind=default), intent(in) :: g complex(kind=default), intent(in) :: phi type(momentum), intent(in) :: k type(vectorspinor), intent(in) :: psi type(vector) :: vk vk = k phipsi = (g * phi) * fgvgr (psi, vk) end function f_sgr @ <>= pure function f_slgr (gl, phi, psi, k) result (phipsi) type(bispinor) :: phipsi complex(kind=default), intent(in) :: gl complex(kind=default), intent(in) :: phi type(momentum), intent(in) :: k type(vectorspinor), intent(in) :: psi phipsi = f_sgr (gl, phi, psi, k) phipsi%a(3:4) = 0 end function f_slgr @ <>= pure function f_srgr (gr, phi, psi, k) result (phipsi) type(bispinor) :: phipsi complex(kind=default), intent(in) :: gr complex(kind=default), intent(in) :: phi type(momentum), intent(in) :: k type(vectorspinor), intent(in) :: psi phipsi = f_sgr (gr, phi, psi, k) phipsi%a(1:2) = 0 end function f_srgr @ <>= pure function f_slrgr (gl, gr, phi, psi, k) result (phipsi) type(bispinor) :: phipsi, phipsi_l, phipsi_r complex(kind=default), intent(in) :: gl, gr complex(kind=default), intent(in) :: phi type(momentum), intent(in) :: k type(vectorspinor), intent(in) :: psi phipsi_l = f_slgr (gl, phi, psi, k) phipsi_r = f_srgr (gr, phi, psi, k) phipsi%a(1:2) = phipsi_l%a(1:2) phipsi%a(3:4) = phipsi_r%a(3:4) end function f_slrgr @ <>= pure function fgvg5gr (psi, k) result (kpsi) type(bispinor) :: kpsi type(vector), intent(in) :: k type(vectorspinor), intent(in) :: psi type(bispinor) :: kpsi_dum kpsi_dum = fgvgr (psi, k) kpsi%a(1:2) = - kpsi_dum%a(1:2) kpsi%a(3:4) = kpsi_dum%a(3:4) end function fgvg5gr @ <>= pure function f_pgr (g, phi, psi, k) result (phipsi) type(bispinor) :: phipsi complex(kind=default), intent(in) :: g complex(kind=default), intent(in) :: phi type(momentum), intent(in) :: k type(vectorspinor), intent(in) :: psi type(vector) :: vk vk = k phipsi = (g * phi) * fgvg5gr (psi, vk) end function f_pgr @ The needed construction of gamma matrices involving the commutator of two gamma matrices. For the slashed terms we use as usual the abbreviations $k_\pm=k_0\pm k_3$, $k=k_1+\ii k_2$, $k^*=k_1-\ii k_2$ and analogous expressions for the vector $v^\mu$. We remind you that~$\cdot^*$ is \emph{not} complex conjugation for complex~$k_\mu$. Furthermore we introduce (in what follows the brackets around the vector indices have the usual meaning of antisymmetrizing with respect to the indices inside the brackets, here without a factor two in the denominator) \begin{subequations} \begin{alignat}{2} a_+ &= \; k_+ v_- + k v^* - k_- v_+ - k^* v & \; = & \; 2 (k_{[3} v_{0]} + \ii k_{[2} v_{1]}) \\ a_- &= \; k_- v_+ + k v^* - k_+ v_- - k^* v & \; = & \; 2 (-k_{[3} v_{0]} + \ii k_{[2} v_{1]}) \\ b_+ &= \; 2 (k_+ v - k v_+) & \; = & \; 2 (k_{[0} v_{1]} + k_{[3} v_{1]} + \ii k_{[0} v_{2]} + \ii k_{[3} v_{2]}) \\ b_- &= \; 2 (k_- v - k v_-) & \; = & \; 2 (k_{[0} v_{1]} - k_{[3} v_{1]} + \ii k_{[0} v_{2]} - \ii k_{[3} v_{2]}) \\ b_{+*} &= \; 2 (k_+ v^* - k^* v_+) & \; = & \; 2 (k_{[0} v_{1]} + k_{[3} v_{1]} - \ii k_{[0} v_{2]} - \ii k_{[3} v_{2]}) \\ b_{-*} &= \; 2 (k_- v^* - k^* v_-) & \; = & \; 2 (k_{[0} v_{1]} - k_{[3} v_{1]} - \ii k_{[0} v_{2]} + \ii k_{[3} v_{2]}) \end{alignat} \end{subequations} Of course, one could introduce a more advanced notation, but we don't want to become confused. \begin{subequations} \begin{align} \lbrack \fmslash{k} , \gamma^0 \rbrack &= \begin{pmatrix} -2k_3 & -2 k^* & 0 & 0 \\ -2k & 2k_3 & 0 & 0 \\ 0 & 0 & 2k_3 & 2k^* \\ 0 & 0 & 2k & -2k_3 \end{pmatrix} \\ \lbrack \fmslash{k} , \gamma^1 \rbrack &= \begin{pmatrix} -2\ii k_2 & -2k_- & 0 & 0 \\ -2k_+ & 2\ii k_2 & 0 & 0 \\ 0 & 0 & -2\ii k_2 & 2k_+ \\ 0 & 0 & 2k_- & 2\ii k_2 \end{pmatrix} \\ \lbrack \fmslash{k} , \gamma^2 \rbrack &= \begin{pmatrix} 2\ii k_1 & 2\ii k_- & 0 & 0 \\ -2\ii k_+ & -2\ii k_1 & 0 & 0 \\ 0 & 0 & 2\ii k_1 & -2\ii k_+ \\ 0 & 0 & 2\ii k_- & -2\ii k_1 \end{pmatrix} \\ \lbrack \fmslash{k} , \gamma^3 \rbrack &= \begin{pmatrix} -2k_0 & -2k^* & 0 & 0 \\ 2k & 2k_0 & 0 & 0 \\ 0 & 0 & 2k_0 & -2k^* \\ 0 & 0 & 2k & -2k_0 \end{pmatrix} \\ \lbrack \fmslash{k} , \fmslash{V} \rbrack &= \begin{pmatrix} a_- & b_{-*} & 0 & 0 \\ b_+ & -a_- & 0 & 0 \\ 0 & 0 & a_+ & -b_{+*} \\ 0 & 0 & -b_- & -a_+ \end{pmatrix} \\ \gamma^5\gamma^0 \lbrack \fmslash{k} , \fmslash{V} \rbrack &= \begin{pmatrix} 0 & 0 & - a_+ & b_{+*} \\ 0 & 0 & b_- & a_+ \\ a_- & b_{-*} & 0 & 0 \\ b_+ & - a_- & 0 & 0 \end{pmatrix} \\ \gamma^5\gamma^1 \lbrack \fmslash{k} , \fmslash{V} \rbrack &= \begin{pmatrix} 0 & 0 & b_- & a_+ \\ 0 & 0 & -a_+ & b_{+*} \\ -b_+ & a_- & 0 & 0 & \\ -a_- & -b_{-*} & 0 & 0 \end{pmatrix} \\ \gamma^5\gamma^2 \lbrack \fmslash{k} , \fmslash{V} \rbrack &= \begin{pmatrix} 0 & 0 & -\ii b_- & -\ii a_+ \\ 0 & 0 & -\ii a_+ & \ii b_{+*} \\ \ii b_+ & -\ii a_- & 0 & 0 \\ -\ii a_- & -\ii b_{-*} & 0 & 0 \end{pmatrix} \\ \gamma^5\gamma^3 \lbrack \fmslash{k} , \fmslash{V} \rbrack &= \begin{pmatrix} 0 & 0 & -a_+ & b_{+*} \\ 0 & 0 & -b_- & -a_+ \\ -a_- & -b_{-*} & 0 & 0 \\ b_+ & -a_- & 0 & 0 \end{pmatrix} \end{align} \end{subequations} and \begin{subequations} \begin{align} \lbrack \fmslash{k} , \fmslash{V} \rbrack \gamma^0 \gamma^5 &= \begin{pmatrix} 0 & 0 & a_- & b_{-*} \\ 0 & 0 & b_+ & -a_- \\ -a_+ & b_{+*} & 0 & 0 \\ b_- & a_+ & 0 & 0 \end{pmatrix} \\ \lbrack \fmslash{k} , \fmslash{V} \rbrack \gamma^1 \gamma^5 &= \begin{pmatrix} 0 & 0 & b_{-*} & a_- \\ 0 & 0 & -a_- & b_+ \\ -b_{+*} & a_+ & 0 & 0 \\ -a_+ & -b_- & 0 & 0 \end{pmatrix} \\ \lbrack \fmslash{k} , \fmslash{V} \rbrack \gamma^2 \gamma^5 &= \begin{pmatrix} 0 & 0 & \ii b_{-*} & -\ii a_- \\ 0 & 0 & -\ii a_- & -\ii b_+ \\ -\ii b_{+*} & -\ii a_+ & 0 & 0 \\ -\ii a_+ & \ii b_- & 0 & 0 \end{pmatrix} \\ \lbrack \fmslash{k} , \fmslash{V} \rbrack \gamma^3 \gamma^5 &= \begin{pmatrix} 0 & 0 & a_- & - b_{-*} \\ 0 & 0 & b_+ & a_- \\ a_+ & b_{+*} & 0 & 0 \\ -b_- & a_+ & 0 & 0 \end{pmatrix} \end{align} \end{subequations} In what follows $l$ always means twice the value of $k$, e.g. $l_+$ = $2 k_+$. We use the abbreviation $C^{\mu\nu} \equiv C \lbrack \fmslash{k}, \gamma^\mu \rbrack \gamma^\nu \gamma^5$. \begin{subequations} \begin{alignat}{2} C^{00} &= \begin{pmatrix} 0 & 0 & -l & -l_3 \\ 0 & 0 & l_3 & l^* \\ l & -l_3 & 0 & 0 \\ -l_3 & -l^* & 0 & 0 \end{pmatrix} , & \qquad C^{20} &= \begin{pmatrix} 0 & 0 & -\ii l_+ & -\ii l_1 \\ 0 & 0 & -\ii l_1 & -\ii l_- \\ \ii l_- & -\ii l_1 & 0 & 0 \\ -\ii l_1 & \ii l_+ & 0 & 0 \end{pmatrix} \\ C^{01} &= \begin{pmatrix} 0 & 0 & l_3 & -l \\ 0 & 0 & l^* & l_3 \\ l_3 & -l & 0 & 0 \\ l^* & l_3 & 0 & 0 \end{pmatrix} , & \qquad C^{21} &= \begin{pmatrix} 0 & 0 & -\ii l_1 & -\ii l_+ \\ 0 & 0 & -\ii l_- & -\ii l_1 \\ \ii l_1 & -\ii l_- & 0 & 0 \\ -\ii l_+ & \ii l_1 & 0 & 0 \end{pmatrix} \\ C^{02} &= \begin{pmatrix} 0 & 0 & \ii l_3 & \ii l \\ 0 & 0 & \ii l^* & -\ii l_3 \\ \ii l_3 & \ii l & 0 & 0 \\ \ii l^* & -\ii l_3 & 0 & 0 \end{pmatrix} , & \qquad C^{22} &= \begin{pmatrix} 0 & 0 & l_1 & -l_+ \\ 0 & 0 & l_- & -l_1 \\ -l_1 & -l_- & 0 & 0 \\ l_+ & l_1 & 0 & 0 \end{pmatrix} \\ C^{03} &= \begin{pmatrix} 0 & 0 & -l & -l_3 \\ 0 & 0 & l_3 & -l^* \\ -l & -l_3 & 0 & 0 \\ l_3 & -l^* & 0 & 0 \end{pmatrix} , & \qquad C^{23} &= \begin{pmatrix} 0 & 0 & -\ii l_+ & \ii l_1 \\ 0 & 0 & -\ii l_1 & \ii l_- \\ -\ii l_- & -\ii l_1 & 0 & 0 \\ \ii l_1 & \ii l_+ & 0 & 0 \end{pmatrix} \\ C^{10} &= \begin{pmatrix} 0 & 0 & -l_+ & \ii l_2 \\ 0 & 0 & \ii l_2 & l_- \\ l_- & \ii l_2 & 0 & 0 \\ \ii l_2 & -l_+ & 0 & 0 \end{pmatrix} , & \qquad C^{30} &= \begin{pmatrix} 0 & 0 & l & l_0 \\ 0 & 0 & l_0 & l^* \\ l & -l_0 & 0 & 0 \\ -l_0 & l^* & 0 & 0 \end{pmatrix} \\ C^{11} &= \begin{pmatrix} 0 & 0 & \ii l_2 & -l_+ \\ 0 & 0 & l_- & \ii l_2 \\ -\ii l_2 & -l_- & 0 & 0 \\ l_+ & -\ii l_2 & 0 & 0 \end{pmatrix} , & \qquad C^{31} &= \begin{pmatrix} 0 & 0 & l_0 & l \\ 0 & 0 & l^* & l_0 \\ l_0 & -l & 0 & 0 \\ -l^* & l_0 & 0 & 0 \end{pmatrix} \\ C^{12} &= \begin{pmatrix} 0 & 0 & -l_2 & \ii l_+ \\ 0 & 0 & \ii l_- & l_2 \\ l_2 & \ii l_- & 0 & 0 \\ \ii l_+ & -l_2 & 0 & 0 \end{pmatrix} , & \qquad C^{32} &= \begin{pmatrix} 0 & 0 & \ii l_0 & -\ii l \\ 0 & 0 & \ii l^* & -\ii l_0 \\ \ii l_0 & \ii l & 0 & 0 \\ -\ii l^* & -\ii l_0 & 0 & 0 \end{pmatrix} \\ C^{13} &= \begin{pmatrix} 0 & 0 & -l_+ & -\ii l_2 \\ 0 & 0 & \ii l_2 & - l_- \\ -l_- & \ii l_2 & 0 & 0 \\ -\ii l_2 & -l_+ & 0 & 0 \end{pmatrix} , & \qquad C^{33} &= \begin{pmatrix} 0 & 0 & l & -l_0 \\ 0 & 0 & l_0 & -l^* \\ -l & -l_0 & 0 & 0 \\ l_0 & l^* & 0 & 0 \end{pmatrix} \end{alignat} \end{subequations} and, with the abbreviation $\tilde{C}^{\mu\nu} \equiv C \gamma^5 \gamma^\nu \lbrack \fmslash{k} , \gamma^\mu \rbrack$ (note the reversed order of the indices!) \begin{subequations} \begin{alignat}{2} \tilde{C}^{00} &= \begin{pmatrix} 0 & 0 & -l & l_3 \\ 0 & 0 & l_3 & l^* \\ l & -l_3 & 0 & 0 \\ -l_3 & -l^* & 0 & 0 \end{pmatrix} , & \qquad \tilde{C}^{20} &= \begin{pmatrix} 0 & 0 & -\ii l_- & \ii l_1 \\ 0 & 0 & \ii l_1 & -\ii l_+ \\ \ii l_+ & \ii l_1 & 0 & 0 \\ \ii l_1 & \ii l_- & 0 & 0 \end{pmatrix} \\ \tilde{C}^{01} &= \begin{pmatrix} 0 & 0 & -l_3 & -l^* \\ 0 & 0 & l & -l_3 \\ -l_3 & -l^* & 0 & 0 \\ l & -l_3 & 0 & 0 \end{pmatrix} , & \qquad \tilde{C}^{21} &= \begin{pmatrix} 0 & 0 & -\ii l_1 & \ii l_+ \\ 0 & 0 & \ii l_- & -\ii l_1 \\ \ii l_1 & \ii l_- & 0 & 0 \\ \ii l_+ & \ii l_1 & 0 & 0 \end{pmatrix} \\ \tilde{C}^{02} &= \begin{pmatrix} 0 & 0 & -\ii l_3 & -\ii l^* \\ 0 & 0 & -\ii l & \ii l_3 \\ -\ii l_3 & -\ii l^* & 0 & 0 \\ -\ii l & \ii l_3 & 0 & 0 \end{pmatrix} , & \qquad \tilde{C}^{22} &= \begin{pmatrix} 0 & 0 & l_1 & -l_+ \\ 0 & 0 & l_- & -l_1 \\ -l_1 & -l_- & 0 & 0 \\ l_+ & l_1 & 0 & 0 \end{pmatrix} \\ \tilde{C}^{03} &= \begin{pmatrix} 0 & 0 & l & -l_3 \\ 0 & 0 & l_3 & l^* \\ l & -l_3 & 0 & 0 \\ l_3 & l^* & 0 & 0 \end{pmatrix} , & \qquad \tilde{C}^{23} &= \begin{pmatrix} 0 & 0 & \ii l_- & -\ii l_1 \\ 0 & 0 & \ii l_1 & -\ii l_+ \\ \ii l_+ & \ii l_1 & 0 & 0 \\ -\ii l_1 & -\ii l_- & 0 & 0 \end{pmatrix} \\ \tilde{C}^{10} &= \begin{pmatrix} 0 & 0 & -l_- & -\ii l_2 \\ 0 & 0 & -\ii l_2 & l_+ \\ l_+ & -\ii l_2 & 0 & 0 \\ -\ii l_2 & -l_- & 0 & 0 \end{pmatrix} , & \qquad \tilde{C}^{30} &= \begin{pmatrix} 0 & 0 & -l & l_0 \\ 0 & 0 & l_0 & -l^* \\ -l & -l_0 & 0 & 0 \\ -l_0 & -l^* & 0 & 0 \end{pmatrix} \\ \tilde{C}^{11} &= \begin{pmatrix} 0 & 0 & \ii l_2 & -l_+ \\ 0 & 0 & l_- & \ii l_2 \\ -\ii l_2 & -l_- & 0 & 0 \\ l_+ & -\ii l_2 & 0 & 0 \end{pmatrix} , & \qquad \tilde{C}^{31} &= \begin{pmatrix} 0 & 0 & -l_0 & l^* \\ 0 & 0 & l & -l_0 \\ -l_0 & -l^* & 0 & 0 \\ -l & -l_0 & 0 & 0 \end{pmatrix} \\ \tilde{C}^{12} &= \begin{pmatrix} 0 & 0 & -l_2 & -\ii l_+ \\ 0 & 0 & -\ii l_- & l_2 \\ l_2 & -\ii l_- & 0 & 0 \\ -\ii l_+ & -l_2 & 0 & 0 \end{pmatrix} , & \qquad \tilde{C}^{32} &= \begin{pmatrix} 0 & 0 & -\ii l_0 & \ii l^* \\ 0 & 0 & -\ii l & \ii l_0 \\ -\ii l_0 & -\ii l^* & 0 & 0 \\ \ii l & \ii l_0 & 0 & 0 \end{pmatrix} \\ \tilde{C}^{13} &= \begin{pmatrix} 0 & 0 & l_- & \ii l_2 \\ 0 & 0 & -\ii l_2 & l_+ \\ l_+ & -\ii l_2 & 0 & 0 \\ \ii l_2 & l_- & 0 & 0 \end{pmatrix} , & \qquad \tilde{C}^{33} &= \begin{pmatrix} 0 & 0 & l & -l_0 \\ 0 & 0 & l_0 & -l^* \\ -l & -l_0 & 0 & 0 \\ l_0 & l^* & 0 & 0 \end{pmatrix} \end{alignat} \end{subequations} <>= pure function fggvvgr (v, psi, k) result (psikv) type(bispinor) :: psikv type(vectorspinor), intent(in) :: psi type(vector), intent(in) :: v, k complex(kind=default) :: kv30, kv21, kv01, kv31, kv02, kv32 complex(kind=default) :: ap, am, bp, bm, bps, bms kv30 = k%x(3) * v%t - k%t * v%x(3) kv21 = (0,1) * (k%x(2) * v%x(1) - k%x(1) * v%x(2)) kv01 = k%t * v%x(1) - k%x(1) * v%t kv31 = k%x(3) * v%x(1) - k%x(1) * v%x(3) kv02 = (0,1) * (k%t * v%x(2) - k%x(2) * v%t) kv32 = (0,1) * (k%x(3) * v%x(2) - k%x(2) * v%x(3)) ap = 2 * (kv30 + kv21) am = 2 * (-kv30 + kv21) bp = 2 * (kv01 + kv31 + kv02 + kv32) bm = 2 * (kv01 - kv31 + kv02 - kv32) bps = 2 * (kv01 + kv31 - kv02 - kv32) bms = 2 * (kv01 - kv31 - kv02 + kv32) psikv%a(1) = (-ap) * psi%psi(1)%a(3) + bps * psi%psi(1)%a(4) & + (-bm) * psi%psi(2)%a(3) + (-ap) * psi%psi(2)%a(4) & + (0,1) * (bm * psi%psi(3)%a(3) + ap * psi%psi(3)%a(4)) & + ap * psi%psi(4)%a(3) + (-bps) * psi%psi(4)%a(4) psikv%a(2) = bm * psi%psi(1)%a(3) + ap * psi%psi(1)%a(4) & + ap * psi%psi(2)%a(3) + (-bps) * psi%psi(2)%a(4) & + (0,1) * (ap * psi%psi(3)%a(3) - bps * psi%psi(3)%a(4)) & + bm * psi%psi(4)%a(3) + ap * psi%psi(4)%a(4) psikv%a(3) = am * psi%psi(1)%a(1) + bms * psi%psi(1)%a(2) & + bp * psi%psi(2)%a(1) + (-am) * psi%psi(2)%a(2) & + (0,-1) * (bp * psi%psi(3)%a(1) + (-am) * psi%psi(3)%a(2)) & + am * psi%psi(4)%a(1) + bms * psi%psi(4)%a(2) psikv%a(4) = bp * psi%psi(1)%a(1) + (-am) * psi%psi(1)%a(2) & + am * psi%psi(2)%a(1) + bms * psi%psi(2)%a(2) & + (0,1) * (am * psi%psi(3)%a(1) + bms * psi%psi(3)%a(2)) & + (-bp) * psi%psi(4)%a(1) + am * psi%psi(4)%a(2) end function fggvvgr @ <>= pure function f_vgr (g, v, psi, k) result (psikkkv) type(bispinor) :: psikkkv type(vectorspinor), intent(in) :: psi type(vector), intent(in) :: v type(momentum), intent(in) :: k complex(kind=default), intent(in) :: g type(vector) :: vk vk = k psikkkv = g * (fggvvgr (v, psi, vk)) end function f_vgr @ <>= pure function f_vlrgr (gl, gr, v, psi, k) result (psikv) type(bispinor) :: psikv type(vectorspinor), intent(in) :: psi type(vector), intent(in) :: v type(momentum), intent(in) :: k complex(kind=default), intent(in) :: gl, gr type(vector) :: vk vk = k psikv = fggvvgr (v, psi, vk) psikv%a(1:2) = gl * psikv%a(1:2) psikv%a(3:4) = gr * psikv%a(3:4) end function f_vlrgr @ <>= public :: gr_potf, gr_sf, gr_pf, gr_vf, gr_vlrf, gr_slf, gr_srf, gr_slrf @ <>= pure function gr_potf (g, phi, psi) result (phipsi) type(vectorspinor) :: phipsi complex(kind=default), intent(in) :: g complex(kind=default), intent(in) :: phi type(bispinor), intent(in) :: psi phipsi%psi(1)%a(1) = (g * phi) * psi%a(3) phipsi%psi(1)%a(2) = (g * phi) * psi%a(4) phipsi%psi(1)%a(3) = (g * phi) * psi%a(1) phipsi%psi(1)%a(4) = (g * phi) * psi%a(2) phipsi%psi(2)%a(1) = (g * phi) * psi%a(4) phipsi%psi(2)%a(2) = (g * phi) * psi%a(3) phipsi%psi(2)%a(3) = ((-g) * phi) * psi%a(2) phipsi%psi(2)%a(4) = ((-g) * phi) * psi%a(1) phipsi%psi(3)%a(1) = ((0,-1) * g * phi) * psi%a(4) phipsi%psi(3)%a(2) = ((0,1) * g * phi) * psi%a(3) phipsi%psi(3)%a(3) = ((0,1) * g * phi) * psi%a(2) phipsi%psi(3)%a(4) = ((0,-1) * g * phi) * psi%a(1) phipsi%psi(4)%a(1) = (g * phi) * psi%a(3) phipsi%psi(4)%a(2) = ((-g) * phi) * psi%a(4) phipsi%psi(4)%a(3) = ((-g) * phi) * psi%a(1) phipsi%psi(4)%a(4) = (g * phi) * psi%a(2) end function gr_potf @ <>= pure function grkgf (psi, k) result (kpsi) type(vectorspinor) :: kpsi complex(kind=default) :: kp, km, k12, k12s type(bispinor), intent(in) :: psi type(vector), intent(in) :: k kp = k%t + k%x(3) km = k%t - k%x(3) k12 = k%x(1) + (0,1)*k%x(2) k12s = k%x(1) - (0,1)*k%x(2) kpsi%psi(1)%a(1) = km * psi%a(1) - k12s * psi%a(2) kpsi%psi(1)%a(2) = (-k12) * psi%a(1) + kp * psi%a(2) kpsi%psi(1)%a(3) = kp * psi%a(3) + k12s * psi%a(4) kpsi%psi(1)%a(4) = k12 * psi%a(3) + km * psi%a(4) kpsi%psi(2)%a(1) = k12s * psi%a(1) - km * psi%a(2) kpsi%psi(2)%a(2) = (-kp) * psi%a(1) + k12 * psi%a(2) kpsi%psi(2)%a(3) = k12s * psi%a(3) + kp * psi%a(4) kpsi%psi(2)%a(4) = km * psi%a(3) + k12 * psi%a(4) kpsi%psi(3)%a(1) = (0,1) * (k12s * psi%a(1) + km * psi%a(2)) kpsi%psi(3)%a(2) = (0,-1) * (kp * psi%a(1) + k12 * psi%a(2)) kpsi%psi(3)%a(3) = (0,1) * (k12s * psi%a(3) - kp * psi%a(4)) kpsi%psi(3)%a(4) = (0,1) * (km * psi%a(3) - k12 * psi%a(4)) kpsi%psi(4)%a(1) = -(km * psi%a(1) + k12s * psi%a(2)) kpsi%psi(4)%a(2) = k12 * psi%a(1) + kp * psi%a(2) kpsi%psi(4)%a(3) = kp * psi%a(3) - k12s * psi%a(4) kpsi%psi(4)%a(4) = k12 * psi%a(3) - km * psi%a(4) end function grkgf @ <>= pure function gr_sf (g, phi, psi, k) result (phipsi) type(vectorspinor) :: phipsi complex(kind=default), intent(in) :: g complex(kind=default), intent(in) :: phi type(bispinor), intent(in) :: psi type(momentum), intent(in) :: k type(vector) :: vk vk = k phipsi = (g * phi) * grkgf (psi, vk) end function gr_sf @ <>= pure function gr_slf (gl, phi, psi, k) result (phipsi) type(vectorspinor) :: phipsi complex(kind=default), intent(in) :: gl complex(kind=default), intent(in) :: phi type(bispinor), intent(in) :: psi type(bispinor) :: psi_l type(momentum), intent(in) :: k psi_l%a(1:2) = psi%a(1:2) psi_l%a(3:4) = 0 phipsi = gr_sf (gl, phi, psi_l, k) end function gr_slf @ <>= pure function gr_srf (gr, phi, psi, k) result (phipsi) type(vectorspinor) :: phipsi complex(kind=default), intent(in) :: gr complex(kind=default), intent(in) :: phi type(bispinor), intent(in) :: psi type(bispinor) :: psi_r type(momentum), intent(in) :: k psi_r%a(1:2) = 0 psi_r%a(3:4) = psi%a(3:4) phipsi = gr_sf (gr, phi, psi_r, k) end function gr_srf @ <>= pure function gr_slrf (gl, gr, phi, psi, k) result (phipsi) type(vectorspinor) :: phipsi complex(kind=default), intent(in) :: gl, gr complex(kind=default), intent(in) :: phi type(bispinor), intent(in) :: psi type(momentum), intent(in) :: k phipsi = gr_slf (gl, phi, psi, k) + gr_srf (gr, phi, psi, k) end function gr_slrf @ <>= pure function grkggf (psi, k) result (kpsi) type(vectorspinor) :: kpsi complex(kind=default) :: kp, km, k12, k12s type(bispinor), intent(in) :: psi type(vector), intent(in) :: k kp = k%t + k%x(3) km = k%t - k%x(3) k12 = k%x(1) + (0,1)*k%x(2) k12s = k%x(1) - (0,1)*k%x(2) kpsi%psi(1)%a(1) = (-km) * psi%a(1) + k12s * psi%a(2) kpsi%psi(1)%a(2) = k12 * psi%a(1) - kp * psi%a(2) kpsi%psi(1)%a(3) = kp * psi%a(3) + k12s * psi%a(4) kpsi%psi(1)%a(4) = k12 * psi%a(3) + km * psi%a(4) kpsi%psi(2)%a(1) = (-k12s) * psi%a(1) + km * psi%a(2) kpsi%psi(2)%a(2) = kp * psi%a(1) - k12 * psi%a(2) kpsi%psi(2)%a(3) = k12s * psi%a(3) + kp * psi%a(4) kpsi%psi(2)%a(4) = km * psi%a(3) + k12 * psi%a(4) kpsi%psi(3)%a(1) = (0,-1) * (k12s * psi%a(1) + km * psi%a(2)) kpsi%psi(3)%a(2) = (0,1) * (kp * psi%a(1) + k12 * psi%a(2)) kpsi%psi(3)%a(3) = (0,1) * (k12s * psi%a(3) - kp * psi%a(4)) kpsi%psi(3)%a(4) = (0,1) * (km * psi%a(3) - k12 * psi%a(4)) kpsi%psi(4)%a(1) = km * psi%a(1) + k12s * psi%a(2) kpsi%psi(4)%a(2) = -(k12 * psi%a(1) + kp * psi%a(2)) kpsi%psi(4)%a(3) = kp * psi%a(3) - k12s * psi%a(4) kpsi%psi(4)%a(4) = k12 * psi%a(3) - km * psi%a(4) end function grkggf @ <>= pure function gr_pf (g, phi, psi, k) result (phipsi) type(vectorspinor) :: phipsi complex(kind=default), intent(in) :: g complex(kind=default), intent(in) :: phi type(bispinor), intent(in) :: psi type(momentum), intent(in) :: k type(vector) :: vk vk = k phipsi = (g * phi) * grkggf (psi, vk) end function gr_pf @ <>= pure function grkkggf (v, psi, k) result (psikv) type(vectorspinor) :: psikv type(bispinor), intent(in) :: psi type(vector), intent(in) :: v, k complex(kind=default) :: kv30, kv21, kv01, kv31, kv02, kv32 complex(kind=default) :: ap, am, bp, bm, bps, bms, imago imago = (0.0_default,1.0_default) kv30 = k%x(3) * v%t - k%t * v%x(3) kv21 = imago * (k%x(2) * v%x(1) - k%x(1) * v%x(2)) kv01 = k%t * v%x(1) - k%x(1) * v%t kv31 = k%x(3) * v%x(1) - k%x(1) * v%x(3) kv02 = imago * (k%t * v%x(2) - k%x(2) * v%t) kv32 = imago * (k%x(3) * v%x(2) - k%x(2) * v%x(3)) ap = 2 * (kv30 + kv21) am = 2 * ((-kv30) + kv21) bp = 2 * (kv01 + kv31 + kv02 + kv32) bm = 2 * (kv01 - kv31 + kv02 - kv32) bps = 2 * (kv01 + kv31 - kv02 - kv32) bms = 2 * (kv01 - kv31 - kv02 + kv32) psikv%psi(1)%a(1) = am * psi%a(3) + bms * psi%a(4) psikv%psi(1)%a(2) = bp * psi%a(3) + (-am) * psi%a(4) psikv%psi(1)%a(3) = (-ap) * psi%a(1) + bps * psi%a(2) psikv%psi(1)%a(4) = bm * psi%a(1) + ap * psi%a(2) psikv%psi(2)%a(1) = bms * psi%a(3) + am * psi%a(4) psikv%psi(2)%a(2) = (-am) * psi%a(3) + bp * psi%a(4) psikv%psi(2)%a(3) = (-bps) * psi%a(1) + ap * psi%a(2) psikv%psi(2)%a(4) = (-ap) * psi%a(1) + (-bm) * psi%a(2) psikv%psi(3)%a(1) = imago * (bms * psi%a(3) - am * psi%a(4)) psikv%psi(3)%a(2) = (-imago) * (am * psi%a(3) + bp * psi%a(4)) psikv%psi(3)%a(3) = (-imago) * (bps * psi%a(1) + ap * psi%a(2)) psikv%psi(3)%a(4) = imago * ((-ap) * psi%a(1) + bm * psi%a(2)) psikv%psi(4)%a(1) = am * psi%a(3) + (-bms) * psi%a(4) psikv%psi(4)%a(2) = bp * psi%a(3) + am * psi%a(4) psikv%psi(4)%a(3) = ap * psi%a(1) + bps * psi%a(2) psikv%psi(4)%a(4) = (-bm) * psi%a(1) + ap * psi%a(2) end function grkkggf @ <>= pure function gr_vf (g, v, psi, k) result (psikv) type(vectorspinor) :: psikv type(bispinor), intent(in) :: psi type(vector), intent(in) :: v type(momentum), intent(in) :: k complex(kind=default), intent(in) :: g type(vector) :: vk vk = k psikv = g * (grkkggf (v, psi, vk)) end function gr_vf @ <>= pure function gr_vlrf (gl, gr, v, psi, k) result (psikv) type(vectorspinor) :: psikv type(bispinor), intent(in) :: psi type(bispinor) :: psi_l, psi_r type(vector), intent(in) :: v type(momentum), intent(in) :: k complex(kind=default), intent(in) :: gl, gr type(vector) :: vk vk = k psi_l%a(1:2) = psi%a(1:2) psi_l%a(3:4) = 0 psi_r%a(1:2) = 0 psi_r%a(3:4) = psi%a(3:4) psikv = gl * grkkggf (v, psi_l, vk) + gr * grkkggf (v, psi_r, vk) end function gr_vlrf @ <>= public :: v_grf, v_fgr @ <>= public :: vlr_grf, vlr_fgr @ $V^\mu = \psi_\rho^T C^{\mu\rho} \psi$ <>= pure function grkgggf (psil, psir, k) result (j) type(vector) :: j type(vectorspinor), intent(in) :: psil type(bispinor), intent(in) :: psir type(vector), intent(in) :: k type(vectorspinor) :: c_psir0, c_psir1, c_psir2, c_psir3 complex(kind=default) :: kp, km, k12, k12s, ik2 kp = k%t + k%x(3) km = k%t - k%x(3) k12 = (k%x(1) + (0,1)*k%x(2)) k12s = (k%x(1) - (0,1)*k%x(2)) ik2 = (0,1) * k%x(2) !!! New version: c_psir0%psi(1)%a(1) = (-k%x(3)) * psir%a(3) + (-k12s) * psir%a(4) c_psir0%psi(1)%a(2) = (-k12) * psir%a(3) + k%x(3) * psir%a(4) c_psir0%psi(1)%a(3) = (-k%x(3)) * psir%a(1) + (-k12s) * psir%a(2) c_psir0%psi(1)%a(4) = (-k12) * psir%a(1) + k%x(3) * psir%a(2) c_psir0%psi(2)%a(1) = (-k12s) * psir%a(3) + (-k%x(3)) * psir%a(4) c_psir0%psi(2)%a(2) = k%x(3) * psir%a(3) + (-k12) * psir%a(4) c_psir0%psi(2)%a(3) = k12s * psir%a(1) + k%x(3) * psir%a(2) c_psir0%psi(2)%a(4) = (-k%x(3)) * psir%a(1) + k12 * psir%a(2) c_psir0%psi(3)%a(1) = (0,1) * ((-k12s) * psir%a(3) + k%x(3) * psir%a(4)) c_psir0%psi(3)%a(2) = (0,1) * (k%x(3) * psir%a(3) + k12 * psir%a(4)) c_psir0%psi(3)%a(3) = (0,1) * (k12s * psir%a(1) + (-k%x(3)) * psir%a(2)) c_psir0%psi(3)%a(4) = (0,1) * ((-k%x(3)) * psir%a(1) + (-k12) * psir%a(2)) c_psir0%psi(4)%a(1) = (-k%x(3)) * psir%a(3) + k12s * psir%a(4) c_psir0%psi(4)%a(2) = (-k12) * psir%a(3) + (-k%x(3)) * psir%a(4) c_psir0%psi(4)%a(3) = k%x(3) * psir%a(1) + (-k12s) * psir%a(2) c_psir0%psi(4)%a(4) = k12 * psir%a(1) + k%x(3) * psir%a(2) !!! c_psir1%psi(1)%a(1) = (-ik2) * psir%a(3) + (-km) * psir%a(4) c_psir1%psi(1)%a(2) = (-kp) * psir%a(3) + ik2 * psir%a(4) c_psir1%psi(1)%a(3) = ik2 * psir%a(1) + (-kp) * psir%a(2) c_psir1%psi(1)%a(4) = (-km) * psir%a(1) + (-ik2) * psir%a(2) c_psir1%psi(2)%a(1) = (-km) * psir%a(3) + (-ik2) * psir%a(4) c_psir1%psi(2)%a(2) = ik2 * psir%a(3) + (-kp) * psir%a(4) c_psir1%psi(2)%a(3) = kp * psir%a(1) + (-ik2) * psir%a(2) c_psir1%psi(2)%a(4) = ik2 * psir%a(1) + km * psir%a(2) c_psir1%psi(3)%a(1) = ((0,-1) * km) * psir%a(3) + (-k%x(2)) * psir%a(4) c_psir1%psi(3)%a(2) = (-k%x(2)) * psir%a(3) + ((0,1) * kp) * psir%a(4) c_psir1%psi(3)%a(3) = ((0,1) * kp) * psir%a(1) + (-k%x(2)) * psir%a(2) c_psir1%psi(3)%a(4) = (-k%x(2)) * psir%a(1) + ((0,-1) * km) * psir%a(2) c_psir1%psi(4)%a(1) = (-ik2) * psir%a(3) + km * psir%a(4) c_psir1%psi(4)%a(2) = (-kp) * psir%a(3) + (-ik2) * psir%a(4) c_psir1%psi(4)%a(3) = (-ik2) * psir%a(1) + (-kp) * psir%a(2) c_psir1%psi(4)%a(4) = km * psir%a(1) + (-ik2) * psir%a(2) !!! c_psir2%psi(1)%a(1) = (0,1) * (k%x(1) * psir%a(3) + km * psir%a(4)) c_psir2%psi(1)%a(2) = (0,-1) * (kp * psir%a(3) + k%x(1) * psir%a(4)) c_psir2%psi(1)%a(3) = (0,1) * ((-k%x(1)) * psir%a(1) + kp * psir%a(2)) c_psir2%psi(1)%a(4) = (0,1) * ((-km) * psir%a(1) + k%x(1) * psir%a(2)) c_psir2%psi(2)%a(1) = (0,1) * (km * psir%a(3) + k%x(1) * psir%a(4)) c_psir2%psi(2)%a(2) = (0,-1) * (k%x(1) * psir%a(3) + kp * psir%a(4)) c_psir2%psi(2)%a(3) = (0,-1) * (kp * psir%a(1) + (-k%x(1)) * psir%a(2)) c_psir2%psi(2)%a(4) = (0,-1) * (k%x(1) * psir%a(1) + (-km) * psir%a(2)) c_psir2%psi(3)%a(1) = (-km) * psir%a(3) + k%x(1) * psir%a(4) c_psir2%psi(3)%a(2) = k%x(1) * psir%a(3) + (-kp) * psir%a(4) c_psir2%psi(3)%a(3) = kp * psir%a(1) + k%x(1) * psir%a(2) c_psir2%psi(3)%a(4) = k%x(1) * psir%a(1) + km * psir%a(2) c_psir2%psi(4)%a(1) = (0,1) * (k%x(1) * psir%a(3) + (-km) * psir%a(4)) c_psir2%psi(4)%a(2) = (0,1) * ((-kp) * psir%a(3) + k%x(1) * psir%a(4)) c_psir2%psi(4)%a(3) = (0,1) * (k%x(1) * psir%a(1) + kp * psir%a(2)) c_psir2%psi(4)%a(4) = (0,1) * (km * psir%a(1) + k%x(1) * psir%a(2)) !!! c_psir3%psi(1)%a(1) = (-k%t) * psir%a(3) - k12s * psir%a(4) c_psir3%psi(1)%a(2) = k12 * psir%a(3) + k%t * psir%a(4) c_psir3%psi(1)%a(3) = (-k%t) * psir%a(1) + k12s * psir%a(2) c_psir3%psi(1)%a(4) = (-k12) * psir%a(1) + k%t * psir%a(2) c_psir3%psi(2)%a(1) = (-k12s) * psir%a(3) + (-k%t) * psir%a(4) c_psir3%psi(2)%a(2) = k%t * psir%a(3) + k12 * psir%a(4) c_psir3%psi(2)%a(3) = (-k12s) * psir%a(1) + k%t * psir%a(2) c_psir3%psi(2)%a(4) = (-k%t) * psir%a(1) + k12 * psir%a(2) c_psir3%psi(3)%a(1) = (0,-1) * (k12s * psir%a(3) + (-k%t) * psir%a(4)) c_psir3%psi(3)%a(2) = (0,1) * (k%t * psir%a(3) + (-k12) * psir%a(4)) c_psir3%psi(3)%a(3) = (0,-1) * (k12s * psir%a(1) + k%t * psir%a(2)) c_psir3%psi(3)%a(4) = (0,-1) * (k%t * psir%a(1) + k12 * psir%a(2)) c_psir3%psi(4)%a(1) = (-k%t) * psir%a(3) + k12s * psir%a(4) c_psir3%psi(4)%a(2) = k12 * psir%a(3) + (-k%t) * psir%a(4) c_psir3%psi(4)%a(3) = k%t * psir%a(1) + k12s * psir%a(2) c_psir3%psi(4)%a(4) = k12 * psir%a(1) + k%t * psir%a(2) j%t = 2 * (psil * c_psir0) j%x(1) = 2 * (psil * c_psir1) j%x(2) = 2 * (psil * c_psir2) j%x(3) = 2 * (psil * c_psir3) end function grkgggf @ <>= pure function v_grf (g, psil, psir, k) result (j) type(vector) :: j complex(kind=default), intent(in) :: g type(vectorspinor), intent(in) :: psil type(bispinor), intent(in) :: psir type(momentum), intent(in) :: k type(vector) :: vk vk = k j = g * grkgggf (psil, psir, vk) end function v_grf @ <>= pure function vlr_grf (gl, gr, psil, psir, k) result (j) type(vector) :: j complex(kind=default), intent(in) :: gl, gr type(vectorspinor), intent(in) :: psil type(bispinor), intent(in) :: psir type(bispinor) :: psir_l, psir_r type(momentum), intent(in) :: k type(vector) :: vk vk = k psir_l%a(1:2) = psir%a(1:2) psir_l%a(3:4) = 0 psir_r%a(1:2) = 0 psir_r%a(3:4) = psir%a(3:4) j = gl * grkgggf (psil, psir_l, vk) + gr * grkgggf (psil, psir_r, vk) end function vlr_grf @ $V^\mu = \psi^T \tilde{C}^{\mu\rho} \psi_\rho$; remember the reversed index order in $\tilde{C}$. <>= pure function fggkggr (psil, psir, k) result (j) type(vector) :: j type(vectorspinor), intent(in) :: psir type(bispinor), intent(in) :: psil type(vector), intent(in) :: k type(bispinor) :: c_psir0, c_psir1, c_psir2, c_psir3 complex(kind=default) :: kp, km, k12, k12s, ik1, ik2 kp = k%t + k%x(3) km = k%t - k%x(3) k12 = k%x(1) + (0,1)*k%x(2) k12s = k%x(1) - (0,1)*k%x(2) ik1 = (0,1) * k%x(1) ik2 = (0,1) * k%x(2) c_psir0%a(1) = k%x(3) * (psir%psi(1)%a(4) + psir%psi(4)%a(4) & + psir%psi(2)%a(3) + (0,1) * psir%psi(3)%a(3)) & - k12 * (psir%psi(1)%a(3) + psir%psi(4)%a(3)) & + k12s * (psir%psi(2)%a(4) + (0,1) * psir%psi(3)%a(4)) c_psir0%a(2) = k%x(3) * (psir%psi(1)%a(3) - psir%psi(4)%a(3) + & psir%psi(2)%a(4) - (0,1) * psir%psi(3)%a(4)) + & k12s * (psir%psi(1)%a(4) - psir%psi(4)%a(4)) - & k12 * (psir%psi(2)%a(3) - (0,1) * psir%psi(3)%a(3)) c_psir0%a(3) = k%x(3) * (-psir%psi(1)%a(2) + psir%psi(4)%a(2) + & psir%psi(2)%a(1) + (0,1) * psir%psi(3)%a(1)) + & k12 * (psir%psi(1)%a(1) - psir%psi(4)%a(1)) + & k12s * (psir%psi(2)%a(2) + (0,1) * psir%psi(3)%a(2)) c_psir0%a(4) = k%x(3) * (-psir%psi(1)%a(1) - psir%psi(4)%a(1) + & psir%psi(2)%a(2) - (0,1) * psir%psi(3)%a(2)) - & k12s * (psir%psi(1)%a(2) + psir%psi(4)%a(2)) - & k12 * (psir%psi(2)%a(1) - (0,1) * psir%psi(3)%a(1)) !!! c_psir1%a(1) = ik2 * (-psir%psi(1)%a(4) - psir%psi(4)%a(4) - & psir%psi(2)%a(3) - (0,1) * psir%psi(3)%a(3)) - & km * (psir%psi(1)%a(3) + psir%psi(4)%a(3)) + & kp * (psir%psi(2)%a(4) + (0,1) * psir%psi(3)%a(4)) c_psir1%a(2) = ik2 * (-psir%psi(1)%a(3) - psir%psi(2)%a(4) + & psir%psi(4)%a(3) + (0,1) * psir%psi(3)%a(4)) + & kp * (psir%psi(1)%a(4) - psir%psi(4)%a(4)) - & km * (psir%psi(2)%a(3) - (0,1) * psir%psi(3)%a(3)) c_psir1%a(3) = ik2 * (-psir%psi(1)%a(2) + psir%psi(2)%a(1) + & psir%psi(4)%a(2) + (0,1) * psir%psi(3)%a(1)) + & kp * (psir%psi(1)%a(1) - psir%psi(4)%a(1)) + & km * (psir%psi(2)%a(2) + (0,1) * psir%psi(3)%a(2)) c_psir1%a(4) = ik2 * (-psir%psi(1)%a(1) + psir%psi(2)%a(2) - & psir%psi(4)%a(1) - (0,1) * psir%psi(3)%a(2)) - & km * (psir%psi(1)%a(2) + psir%psi(4)%a(2)) - & kp * (psir%psi(2)%a(1) - (0,1) * psir%psi(3)%a(1)) !!! c_psir2%a(1) = ik1 * (psir%psi(2)%a(3) + psir%psi(1)%a(4) & + psir%psi(4)%a(4) + (0,1) * psir%psi(3)%a(3)) - & ((0,1)*km) * (psir%psi(1)%a(3) + psir%psi(4)%a(3)) & + kp * (psir%psi(3)%a(4) - (0,1) * psir%psi(2)%a(4)) c_psir2%a(2) = ik1 * (psir%psi(1)%a(3) + psir%psi(2)%a(4) - & psir%psi(4)%a(3) - (0,1) * psir%psi(3)%a(4)) - & ((0,1)*kp) * (psir%psi(1)%a(4) - psir%psi(4)%a(4)) & - km * (psir%psi(3)%a(3) + (0,1) * psir%psi(2)%a(3)) c_psir2%a(3) = ik1 * (psir%psi(1)%a(2) - psir%psi(2)%a(1) - & psir%psi(4)%a(2) - (0,1) * psir%psi(3)%a(1)) + & ((0,1)*kp) * (psir%psi(1)%a(1) - psir%psi(4)%a(1)) & + km * (psir%psi(3)%a(2) - (0,1) * psir%psi(2)%a(2)) c_psir2%a(4) = ik1 * (psir%psi(1)%a(1) - psir%psi(2)%a(2) + & psir%psi(4)%a(1) + (0,1) * psir%psi(3)%a(2)) + & ((0,1)*km) * (psir%psi(1)%a(2) + psir%psi(4)%a(2)) - & kp * (psir%psi(3)%a(1) + (0,1) * psir%psi(2)%a(1)) !!! c_psir3%a(1) = k%t * (psir%psi(1)%a(4) + psir%psi(4)%a(4) + & psir%psi(2)%a(3) + (0,1) * psir%psi(3)%a(3)) - & k12 * (psir%psi(1)%a(3) + psir%psi(4)%a(3)) - & k12s * (psir%psi(2)%a(4) + (0,1) * psir%psi(3)%a(4)) c_psir3%a(2) = k%t * (psir%psi(1)%a(3) - psir%psi(4)%a(3) + & psir%psi(2)%a(4) - (0,1) * psir%psi(3)%a(4)) - & k12s * (psir%psi(1)%a(4) - psir%psi(4)%a(4)) - & k12 * (psir%psi(2)%a(3) - (0,1) * psir%psi(3)%a(3)) c_psir3%a(3) = k%t * (-psir%psi(1)%a(2) + psir%psi(2)%a(1) + & psir%psi(4)%a(2) + (0,1) * psir%psi(3)%a(1)) - & k12 * (psir%psi(1)%a(1) - psir%psi(4)%a(1)) + & k12s * (psir%psi(2)%a(2) + (0,1) * psir%psi(3)%a(2)) c_psir3%a(4) = k%t * (-psir%psi(1)%a(1) + psir%psi(2)%a(2) - & psir%psi(4)%a(1) - (0,1) * psir%psi(3)%a(2)) - & k12s * (psir%psi(1)%a(2) + psir%psi(4)%a(2)) + & k12 * (psir%psi(2)%a(1) - (0,1) * psir%psi(3)%a(1)) !!! Because we explicitly multiplied the charge conjugation matrix !!! we have to omit it from the spinor product and take the !!! ordinary product! j%t = 2 * dot_product (conjg (psil%a), c_psir0%a) j%x(1) = 2 * dot_product (conjg (psil%a), c_psir1%a) j%x(2) = 2 * dot_product (conjg (psil%a), c_psir2%a) j%x(3) = 2 * dot_product (conjg (psil%a), c_psir3%a) end function fggkggr @ <>= pure function v_fgr (g, psil, psir, k) result (j) type(vector) :: j complex(kind=default), intent(in) :: g type(vectorspinor), intent(in) :: psir type(bispinor), intent(in) :: psil type(momentum), intent(in) :: k type(vector) :: vk vk = k j = g * fggkggr (psil, psir, vk) end function v_fgr @ <>= pure function vlr_fgr (gl, gr, psil, psir, k) result (j) type(vector) :: j complex(kind=default), intent(in) :: gl, gr type(vectorspinor), intent(in) :: psir type(bispinor), intent(in) :: psil type(bispinor) :: psil_l type(bispinor) :: psil_r type(momentum), intent(in) :: k type(vector) :: vk vk = k psil_l%a(1:2) = psil%a(1:2) psil_l%a(3:4) = 0 psil_r%a(1:2) = 0 psil_r%a(3:4) = psil%a(3:4) j = gl * fggkggr (psil_l, psir, vk) + gr * fggkggr (psil_r, psir, vk) end function vlr_fgr @ \subsection{Gravitino 4-Couplings} <>= public :: f_s2gr, f_svgr, f_slvgr, f_srvgr, f_slrvgr, f_pvgr, f_v2gr, f_v2lrgr @ <>= pure function f_s2gr (g, phi1, phi2, psi) result (phipsi) type(bispinor) :: phipsi type(vectorspinor), intent(in) :: psi complex(kind=default), intent(in) :: g complex(kind=default), intent(in) :: phi1, phi2 phipsi = phi2 * f_potgr (g, phi1, psi) end function f_s2gr @ <>= pure function f_svgr (g, phi, v, grav) result (phigrav) type(bispinor) :: phigrav type(vectorspinor), intent(in) :: grav type(vector), intent(in) :: v complex(kind=default), intent(in) :: g, phi phigrav = (g * phi) * fgvg5gr (grav, v) end function f_svgr @ <>= pure function f_slvgr (gl, phi, v, grav) result (phigrav) type(bispinor) :: phigrav, phidum type(vectorspinor), intent(in) :: grav type(vector), intent(in) :: v complex(kind=default), intent(in) :: gl, phi phidum = (gl * phi) * fgvg5gr (grav, v) phigrav%a(1:2) = phidum%a(1:2) phigrav%a(3:4) = 0 end function f_slvgr @ <>= pure function f_srvgr (gr, phi, v, grav) result (phigrav) type(bispinor) :: phigrav, phidum type(vectorspinor), intent(in) :: grav type(vector), intent(in) :: v complex(kind=default), intent(in) :: gr, phi phidum = (gr * phi) * fgvg5gr (grav, v) phigrav%a(1:2) = 0 phigrav%a(3:4) = phidum%a(3:4) end function f_srvgr @ <>= pure function f_slrvgr (gl, gr, phi, v, grav) result (phigrav) type(bispinor) :: phigrav type(vectorspinor), intent(in) :: grav type(vector), intent(in) :: v complex(kind=default), intent(in) :: gl, gr, phi phigrav = f_slvgr (gl, phi, v, grav) + f_srvgr (gr, phi, v, grav) end function f_slrvgr @ <>= pure function f_pvgr (g, phi, v, grav) result (phigrav) type(bispinor) :: phigrav type(vectorspinor), intent(in) :: grav type(vector), intent(in) :: v complex(kind=default), intent(in) :: g, phi phigrav = (g * phi) * fgvgr (grav, v) end function f_pvgr @ <>= pure function f_v2gr (g, v1, v2, grav) result (psi) type(bispinor) :: psi complex(kind=default), intent(in) :: g type(vectorspinor), intent(in) :: grav type(vector), intent(in) :: v1, v2 psi = g * fggvvgr (v2, grav, v1) end function f_v2gr @ <>= pure function f_v2lrgr (gl, gr, v1, v2, grav) result (psi) type(bispinor) :: psi complex(kind=default), intent(in) :: gl, gr type(vectorspinor), intent(in) :: grav type(vector), intent(in) :: v1, v2 psi = fggvvgr (v2, grav, v1) psi%a(1:2) = gl * psi%a(1:2) psi%a(3:4) = gr * psi%a(3:4) end function f_v2lrgr @ <>= public :: gr_s2f, gr_svf, gr_pvf, gr_slvf, gr_srvf, gr_slrvf, gr_v2f, gr_v2lrf @ <>= pure function gr_s2f (g, phi1, phi2, psi) result (phipsi) type(vectorspinor) :: phipsi type(bispinor), intent(in) :: psi complex(kind=default), intent(in) :: g complex(kind=default), intent(in) :: phi1, phi2 phipsi = phi2 * gr_potf (g, phi1, psi) end function gr_s2f @ <>= pure function gr_svf (g, phi, v, psi) result (phipsi) type(vectorspinor) :: phipsi type(bispinor), intent(in) :: psi type(vector), intent(in) :: v complex(kind=default), intent(in) :: g, phi phipsi = (g * phi) * grkggf (psi, v) end function gr_svf @ <>= pure function gr_slvf (gl, phi, v, psi) result (phipsi) type(vectorspinor) :: phipsi type(bispinor), intent(in) :: psi type(bispinor) :: psi_l type(vector), intent(in) :: v complex(kind=default), intent(in) :: gl, phi psi_l%a(1:2) = psi%a(1:2) psi_l%a(3:4) = 0 phipsi = (gl * phi) * grkggf (psi_l, v) end function gr_slvf @ <>= pure function gr_srvf (gr, phi, v, psi) result (phipsi) type(vectorspinor) :: phipsi type(bispinor), intent(in) :: psi type(bispinor) :: psi_r type(vector), intent(in) :: v complex(kind=default), intent(in) :: gr, phi psi_r%a(1:2) = 0 psi_r%a(3:4) = psi%a(3:4) phipsi = (gr * phi) * grkggf (psi_r, v) end function gr_srvf @ <>= pure function gr_slrvf (gl, gr, phi, v, psi) result (phipsi) type(vectorspinor) :: phipsi type(bispinor), intent(in) :: psi type(vector), intent(in) :: v complex(kind=default), intent(in) :: gl, gr, phi phipsi = gr_slvf (gl, phi, v, psi) + gr_srvf (gr, phi, v, psi) end function gr_slrvf @ <>= pure function gr_pvf (g, phi, v, psi) result (phipsi) type(vectorspinor) :: phipsi type(bispinor), intent(in) :: psi type(vector), intent(in) :: v complex(kind=default), intent(in) :: g, phi phipsi = (g * phi) * grkgf (psi, v) end function gr_pvf @ <>= pure function gr_v2f (g, v1, v2, psi) result (vvpsi) type(vectorspinor) :: vvpsi complex(kind=default), intent(in) :: g type(bispinor), intent(in) :: psi type(vector), intent(in) :: v1, v2 vvpsi = g * grkkggf (v2, psi, v1) end function gr_v2f @ <>= pure function gr_v2lrf (gl, gr, v1, v2, psi) result (vvpsi) type(vectorspinor) :: vvpsi complex(kind=default), intent(in) :: gl, gr type(bispinor), intent(in) :: psi type(bispinor) :: psi_l, psi_r type(vector), intent(in) :: v1, v2 psi_l%a(1:2) = psi%a(1:2) psi_l%a(3:4) = 0 psi_r%a(1:2) = 0 psi_r%a(3:4) = psi%a(3:4) vvpsi = gl * grkkggf (v2, psi_l, v1) + gr * grkkggf (v2, psi_r, v1) end function gr_v2lrf @ <>= public :: s2_grf, s2_fgr, sv1_grf, sv2_grf, sv1_fgr, sv2_fgr, & slv1_grf, slv2_grf, slv1_fgr, slv2_fgr, & srv1_grf, srv2_grf, srv1_fgr, srv2_fgr, & slrv1_grf, slrv2_grf, slrv1_fgr, slrv2_fgr, & pv1_grf, pv2_grf, pv1_fgr, pv2_fgr, v2_grf, v2_fgr, & v2lr_grf, v2lr_fgr @ <>= pure function s2_grf (g, gravbar, phi, psi) result (j) complex(kind=default) :: j complex(kind=default), intent(in) :: g, phi type(vectorspinor), intent(in) :: gravbar type(bispinor), intent(in) :: psi j = phi * pot_grf (g, gravbar, psi) end function s2_grf @ <>= pure function s2_fgr (g, psibar, phi, grav) result (j) complex(kind=default) :: j complex(kind=default), intent(in) :: g, phi type(bispinor), intent(in) :: psibar type(vectorspinor), intent(in) :: grav j = phi * pot_fgr (g, psibar, grav) end function s2_fgr @ <>= pure function sv1_grf (g, gravbar, v, psi) result (j) complex(kind=default) :: j complex(kind=default), intent(in) :: g type(vectorspinor), intent(in) :: gravbar type(bispinor), intent(in) :: psi type(vector), intent(in) :: v j = g * grg5vgf (gravbar, psi, v) end function sv1_grf @ <>= pure function slv1_grf (gl, gravbar, v, psi) result (j) complex(kind=default) :: j complex(kind=default), intent(in) :: gl type(vectorspinor), intent(in) :: gravbar type(bispinor), intent(in) :: psi type(bispinor) :: psi_l type(vector), intent(in) :: v psi_l%a(1:2) = psi%a(1:2) psi_l%a(3:4) = 0 j = gl * grg5vgf (gravbar, psi_l, v) end function slv1_grf @ <>= pure function srv1_grf (gr, gravbar, v, psi) result (j) complex(kind=default) :: j complex(kind=default), intent(in) :: gr type(vectorspinor), intent(in) :: gravbar type(bispinor), intent(in) :: psi type(bispinor) :: psi_r type(vector), intent(in) :: v psi_r%a(1:2) = 0 psi_r%a(3:4) = psi%a(3:4) j = gr * grg5vgf (gravbar, psi_r, v) end function srv1_grf @ <>= pure function slrv1_grf (gl, gr, gravbar, v, psi) result (j) complex(kind=default) :: j complex(kind=default), intent(in) :: gl, gr type(vectorspinor), intent(in) :: gravbar type(bispinor), intent(in) :: psi type(bispinor) :: psi_l, psi_r type(vector), intent(in) :: v psi_l%a(1:2) = psi%a(1:2) psi_l%a(3:4) = 0 psi_r%a(1:2) = 0 psi_r%a(3:4) = psi%a(3:4) j = gl * grg5vgf (gravbar, psi_l, v) + gr * grg5vgf (gravbar, psi_r, v) end function slrv1_grf @ \begin{subequations} \begin{align} C \gamma^0 \gamma^0 = - C \gamma^1 \gamma^1 = - C \gamma^2 \gamma^2 = C \gamma^3 \gamma^3 = C &= \begin{pmatrix} 0 & 1 & 0 & 0 \\ -1 & 0 & 0 & 0 \\ 0 & 0 & 0 & -1 \\ 0 & 0 & 1 & 0 \end{pmatrix} \\ C \gamma^0 \gamma^1 = - C \gamma^1 \gamma^0 &= \begin{pmatrix} -1 & 0 & 0 & 0 \\ 0 & 1 & 0 & 0 \\ 0 & 0 & -1 & 0 \\ 0 & 0 & 0 & 1 \end{pmatrix} \\ C \gamma^0 \gamma^2 = - C \gamma^2 \gamma^0 &= \begin{pmatrix} -\ii & 0 & 0 & 0 \\ 0 & -\ii & 0 & 0 \\ 0 & 0 & -\ii & 0 \\ 0 & 0 & 0 & -\ii \end{pmatrix} \\ C \gamma^0 \gamma^3 = - C \gamma^3 \gamma^0 &= \begin{pmatrix} 0 & 1 & 0 & 0 \\ 1 & 0 & 0 & 0 \\ 0 & 0 & 0 & 1 \\ 0 & 0 & 1 & 0 \end{pmatrix} \\ C \gamma^1 \gamma^2 = - C \gamma^2 \gamma^1 &= \begin{pmatrix} 0 & \ii & 0 & 0 \\ \ii & 0 & 0 & 0 \\ 0 & 0 & 0 & -\ii \\ 0 & 0 & -\ii & 0 \end{pmatrix} \\ C \gamma^1 \gamma^3 = - C \gamma^3 \gamma^1 &= \begin{pmatrix} -1 & 0 & 0 & 0 \\ 0 & -1 & 0 & 0 \\ 0 & 0 & 1 & 0 \\ 0 & 0 & 0 & 1 \end{pmatrix} \\ C \gamma^2 \gamma^3 = - C \gamma^3 \gamma^2 &= \begin{pmatrix} -\ii & 0 & 0 & 0 \\ 0 & \ii & 0 & 0 \\ 0 & 0 & \ii & 0 \\ 0 & 0 & 0 & -\ii \end{pmatrix} \end{align} \end{subequations} @ <>= pure function sv2_grf (g, gravbar, phi, psi) result (j) type(vector) :: j complex(kind=default), intent(in) :: g, phi type(vectorspinor), intent(in) :: gravbar type(bispinor), intent(in) :: psi type(vectorspinor) :: g0_psi, g1_psi, g2_psi, g3_psi g0_psi%psi(1)%a(1:2) = - psi%a(1:2) g0_psi%psi(1)%a(3:4) = psi%a(3:4) g0_psi%psi(2)%a(1) = psi%a(2) g0_psi%psi(2)%a(2) = psi%a(1) g0_psi%psi(2)%a(3) = psi%a(4) g0_psi%psi(2)%a(4) = psi%a(3) g0_psi%psi(3)%a(1) = (0,-1) * psi%a(2) g0_psi%psi(3)%a(2) = (0,1) * psi%a(1) g0_psi%psi(3)%a(3) = (0,-1) * psi%a(4) g0_psi%psi(3)%a(4) = (0,1) * psi%a(3) g0_psi%psi(4)%a(1) = psi%a(1) g0_psi%psi(4)%a(2) = - psi%a(2) g0_psi%psi(4)%a(3) = psi%a(3) g0_psi%psi(4)%a(4) = - psi%a(4) g1_psi%psi(1)%a(1:4) = - g0_psi%psi(2)%a(1:4) g1_psi%psi(2)%a(1:4) = - g0_psi%psi(1)%a(1:4) g1_psi%psi(3)%a(1) = (0,1) * psi%a(1) g1_psi%psi(3)%a(2) = (0,-1) * psi%a(2) g1_psi%psi(3)%a(3) = (0,-1) * psi%a(3) g1_psi%psi(3)%a(4) = (0,1) * psi%a(4) g1_psi%psi(4)%a(1) = - psi%a(2) g1_psi%psi(4)%a(2) = psi%a(1) g1_psi%psi(4)%a(3) = psi%a(4) g1_psi%psi(4)%a(4) = - psi%a(3) g2_psi%psi(1)%a(1:4) = - g0_psi%psi(3)%a(1:4) g2_psi%psi(2)%a(1:4) = - g1_psi%psi(3)%a(1:4) g2_psi%psi(3)%a(1:4) = - g0_psi%psi(1)%a(1:4) g2_psi%psi(4)%a(1) = (0,1) * psi%a(2) g2_psi%psi(4)%a(2) = (0,1) * psi%a(1) g2_psi%psi(4)%a(3) = (0,-1) * psi%a(4) g2_psi%psi(4)%a(4) = (0,-1) * psi%a(3) g3_psi%psi(1)%a(1:4) = - g0_psi%psi(4)%a(1:4) g3_psi%psi(2)%a(1:4) = - g1_psi%psi(4)%a(1:4) g3_psi%psi(3)%a(1:4) = - g2_psi%psi(4)%a(1:4) g3_psi%psi(4)%a(1:4) = - g0_psi%psi(1)%a(1:4) j%t = (g * phi) * (gravbar * g0_psi) j%x(1) = (g * phi) * (gravbar * g1_psi) j%x(2) = (g * phi) * (gravbar * g2_psi) j%x(3) = (g * phi) * (gravbar * g3_psi) end function sv2_grf @ <>= pure function slv2_grf (gl, gravbar, phi, psi) result (j) type(vector) :: j complex(kind=default), intent(in) :: gl, phi type(vectorspinor), intent(in) :: gravbar type(bispinor), intent(in) :: psi type(bispinor) :: psi_l psi_l%a(1:2) = psi%a(1:2) psi_l%a(3:4) = 0 j = sv2_grf (gl, gravbar, phi, psi_l) end function slv2_grf @ <>= pure function srv2_grf (gr, gravbar, phi, psi) result (j) type(vector) :: j complex(kind=default), intent(in) :: gr, phi type(vectorspinor), intent(in) :: gravbar type(bispinor), intent(in) :: psi type(bispinor) :: psi_r psi_r%a(1:2) = 0 psi_r%a(3:4) = psi%a(3:4) j = sv2_grf (gr, gravbar, phi, psi_r) end function srv2_grf @ <>= pure function slrv2_grf (gl, gr, gravbar, phi, psi) result (j) type(vector) :: j complex(kind=default), intent(in) :: gl, gr, phi type(vectorspinor), intent(in) :: gravbar type(bispinor), intent(in) :: psi type(bispinor) :: psi_l, psi_r psi_l%a(1:2) = psi%a(1:2) psi_l%a(3:4) = 0 psi_r%a(1:2) = 0 psi_r%a(3:4) = psi%a(3:4) j = sv2_grf (gl, gravbar, phi, psi_l) + sv2_grf (gr, gravbar, phi, psi_r) end function slrv2_grf @ <>= pure function sv1_fgr (g, psibar, v, grav) result (j) complex(kind=default) :: j complex(kind=default), intent(in) :: g type(bispinor), intent(in) :: psibar type(vectorspinor), intent(in) :: grav type(vector), intent(in) :: v j = g * fg5gkgr (psibar, grav, v) end function sv1_fgr @ <>= pure function slv1_fgr (gl, psibar, v, grav) result (j) complex(kind=default) :: j complex(kind=default), intent(in) :: gl type(bispinor), intent(in) :: psibar type(bispinor) :: psibar_l type(vectorspinor), intent(in) :: grav type(vector), intent(in) :: v psibar_l%a(1:2) = psibar%a(1:2) psibar_l%a(3:4) = 0 j = gl * fg5gkgr (psibar_l, grav, v) end function slv1_fgr @ <>= pure function srv1_fgr (gr, psibar, v, grav) result (j) complex(kind=default) :: j complex(kind=default), intent(in) :: gr type(bispinor), intent(in) :: psibar type(bispinor) :: psibar_r type(vectorspinor), intent(in) :: grav type(vector), intent(in) :: v psibar_r%a(1:2) = 0 psibar_r%a(3:4) = psibar%a(3:4) j = gr * fg5gkgr (psibar_r, grav, v) end function srv1_fgr @ <>= pure function slrv1_fgr (gl, gr, psibar, v, grav) result (j) complex(kind=default) :: j complex(kind=default), intent(in) :: gl, gr type(bispinor), intent(in) :: psibar type(bispinor) :: psibar_l, psibar_r type(vectorspinor), intent(in) :: grav type(vector), intent(in) :: v psibar_l%a(1:2) = psibar%a(1:2) psibar_l%a(3:4) = 0 psibar_r%a(1:2) = 0 psibar_r%a(3:4) = psibar%a(3:4) j = gl * fg5gkgr (psibar_l, grav, v) + gr * fg5gkgr (psibar_r, grav, v) end function slrv1_fgr @ <>= pure function sv2_fgr (g, psibar, phi, grav) result (j) type(vector) :: j complex(kind=default), intent(in) :: g, phi type(bispinor), intent(in) :: psibar type(vectorspinor), intent(in) :: grav type(bispinor) :: g0_grav, g1_grav, g2_grav, g3_grav g0_grav%a(1) = -grav%psi(1)%a(1) + grav%psi(2)%a(2) - & (0,1) * grav%psi(3)%a(2) + grav%psi(4)%a(1) g0_grav%a(2) = -grav%psi(1)%a(2) + grav%psi(2)%a(1) + & (0,1) * grav%psi(3)%a(1) - grav%psi(4)%a(2) g0_grav%a(3) = grav%psi(1)%a(3) + grav%psi(2)%a(4) - & (0,1) * grav%psi(3)%a(4) + grav%psi(4)%a(3) g0_grav%a(4) = grav%psi(1)%a(4) + grav%psi(2)%a(3) + & (0,1) * grav%psi(3)%a(3) - grav%psi(4)%a(4) !!! g1_grav%a(1) = grav%psi(1)%a(2) - grav%psi(2)%a(1) + & (0,1) * grav%psi(3)%a(1) - grav%psi(4)%a(2) g1_grav%a(2) = grav%psi(1)%a(1) - grav%psi(2)%a(2) - & (0,1) * grav%psi(3)%a(2) + grav%psi(4)%a(1) g1_grav%a(3) = grav%psi(1)%a(4) + grav%psi(2)%a(3) - & (0,1) * grav%psi(3)%a(3) + grav%psi(4)%a(4) g1_grav%a(4) = grav%psi(1)%a(3) + grav%psi(2)%a(4) + & (0,1) * grav%psi(3)%a(4) - grav%psi(4)%a(3) !!! g2_grav%a(1) = (0,1) * (-grav%psi(1)%a(2) - grav%psi(2)%a(1) + & grav%psi(4)%a(2)) - grav%psi(3)%a(1) g2_grav%a(2) = (0,1) * (grav%psi(1)%a(1) + grav%psi(2)%a(2) + & grav%psi(4)%a(1)) - grav%psi(3)%a(2) g2_grav%a(3) = (0,1) * (-grav%psi(1)%a(4) + grav%psi(2)%a(3) - & grav%psi(4)%a(4)) + grav%psi(3)%a(3) g2_grav%a(4) = (0,1) * (grav%psi(1)%a(3) - grav%psi(2)%a(4) - & grav%psi(4)%a(3)) + grav%psi(3)%a(4) !!! g3_grav%a(1) = -grav%psi(1)%a(2) + grav%psi(2)%a(2) - & (0,1) * grav%psi(3)%a(2) - grav%psi(4)%a(1) g3_grav%a(2) = grav%psi(1)%a(1) - grav%psi(2)%a(1) - & (0,1) * grav%psi(3)%a(1) - grav%psi(4)%a(2) g3_grav%a(3) = -grav%psi(1)%a(2) - grav%psi(2)%a(4) + & (0,1) * grav%psi(3)%a(4) + grav%psi(4)%a(3) g3_grav%a(4) = -grav%psi(1)%a(4) + grav%psi(2)%a(3) + & (0,1) * grav%psi(3)%a(3) + grav%psi(4)%a(4) j%t = (g * phi) * (psibar * g0_grav) j%x(1) = (g * phi) * (psibar * g1_grav) j%x(2) = (g * phi) * (psibar * g2_grav) j%x(3) = (g * phi) * (psibar * g3_grav) end function sv2_fgr @ <>= pure function slv2_fgr (gl, psibar, phi, grav) result (j) type(vector) :: j complex(kind=default), intent(in) :: gl, phi type(bispinor), intent(in) :: psibar type(bispinor) :: psibar_l type(vectorspinor), intent(in) :: grav psibar_l%a(1:2) = psibar%a(1:2) psibar_l%a(3:4) = 0 j = sv2_fgr (gl, psibar_l, phi, grav) end function slv2_fgr @ <>= pure function srv2_fgr (gr, psibar, phi, grav) result (j) type(vector) :: j complex(kind=default), intent(in) :: gr, phi type(bispinor), intent(in) :: psibar type(bispinor) :: psibar_r type(vectorspinor), intent(in) :: grav psibar_r%a(1:2) = 0 psibar_r%a(3:4) = psibar%a(3:4) j = sv2_fgr (gr, psibar_r, phi, grav) end function srv2_fgr @ <>= pure function slrv2_fgr (gl, gr, psibar, phi, grav) result (j) type(vector) :: j complex(kind=default), intent(in) :: gl, gr, phi type(bispinor), intent(in) :: psibar type(bispinor) :: psibar_l, psibar_r type(vectorspinor), intent(in) :: grav psibar_l%a(1:2) = psibar%a(1:2) psibar_l%a(3:4) = 0 psibar_r%a(1:2) = 0 psibar_r%a(3:4) = psibar%a(3:4) j = sv2_fgr (gl, psibar_l, phi, grav) + sv2_fgr (gr, psibar_r, phi, grav) end function slrv2_fgr @ <>= pure function pv1_grf (g, gravbar, v, psi) result (j) complex(kind=default) :: j complex(kind=default), intent(in) :: g type(vectorspinor), intent(in) :: gravbar type(bispinor), intent(in) :: psi type(vector), intent(in) :: v j = g * grvgf (gravbar, psi, v) end function pv1_grf @ <>= pure function pv2_grf (g, gravbar, phi, psi) result (j) type(vector) :: j complex(kind=default), intent(in) :: g, phi type(vectorspinor), intent(in) :: gravbar type(bispinor), intent(in) :: psi type(bispinor) :: g5_psi g5_psi%a(1:2) = - psi%a(1:2) g5_psi%a(3:4) = psi%a(3:4) j = sv2_grf (g, gravbar, phi, g5_psi) end function pv2_grf @ <>= pure function pv1_fgr (g, psibar, v, grav) result (j) complex(kind=default) :: j complex(kind=default), intent(in) :: g type(bispinor), intent(in) :: psibar type(vectorspinor), intent(in) :: grav type(vector), intent(in) :: v j = g * fgkgr (psibar, grav, v) end function pv1_fgr @ <>= pure function pv2_fgr (g, psibar, phi, grav) result (j) type(vector) :: j complex(kind=default), intent(in) :: g, phi type(vectorspinor), intent(in) :: grav type(bispinor), intent(in) :: psibar type(bispinor) :: psibar_g5 psibar_g5%a(1:2) = - psibar%a(1:2) psibar_g5%a(3:4) = psibar%a(3:4) j = sv2_fgr (g, psibar_g5, phi, grav) end function pv2_fgr @ <>= pure function v2_grf (g, gravbar, v, psi) result (j) type(vector) :: j complex(kind=default), intent(in) :: g type(vectorspinor), intent(in) :: gravbar type(bispinor), intent(in) :: psi type(vector), intent(in) :: v j = -g * grkgggf (gravbar, psi, v) end function v2_grf @ <>= pure function v2lr_grf (gl, gr, gravbar, v, psi) result (j) type(vector) :: j complex(kind=default), intent(in) :: gl, gr type(vectorspinor), intent(in) :: gravbar type(bispinor), intent(in) :: psi type(bispinor) :: psi_l, psi_r type(vector), intent(in) :: v psi_l%a(1:2) = psi%a(1:2) psi_l%a(3:4) = 0 psi_r%a(1:2) = 0 psi_r%a(3:4) = psi%a(3:4) j = -(gl * grkgggf (gravbar, psi_l, v) + gr * grkgggf (gravbar, psi_r, v)) end function v2lr_grf @ <>= pure function v2_fgr (g, psibar, v, grav) result (j) type(vector) :: j complex(kind=default), intent(in) :: g type(vectorspinor), intent(in) :: grav type(bispinor), intent(in) :: psibar type(vector), intent(in) :: v j = -g * fggkggr (psibar, grav, v) end function v2_fgr @ <>= pure function v2lr_fgr (gl, gr, psibar, v, grav) result (j) type(vector) :: j complex(kind=default), intent(in) :: gl, gr type(vectorspinor), intent(in) :: grav type(bispinor), intent(in) :: psibar type(bispinor) :: psibar_l, psibar_r type(vector), intent(in) :: v psibar_l%a(1:2) = psibar%a(1:2) psibar_l%a(3:4) = 0 psibar_r%a(1:2) = 0 psibar_r%a(3:4) = psibar%a(3:4) j = -(gl * fggkggr (psibar_l, grav, v) + gr * fggkggr (psibar_r, grav, v)) end function v2lr_fgr @ \subsection{On Shell Wave Functions} <>= public :: u, v, ghost @ \begin{subequations} \begin{align} \chi_+(\vec p) &= \frac{1}{\sqrt{2|\vec p|(|\vec p|+p_3)}} \begin{pmatrix} |\vec p|+p_3 \\ p_1 + \ii p_2 \end{pmatrix} \\ \chi_-(\vec p) &= \frac{1}{\sqrt{2|\vec p|(|\vec p|+p_3)}} \begin{pmatrix} - p_1 + \ii p_2 \\ |\vec p|+p_3 \end{pmatrix} \end{align} \end{subequations} @ \begin{equation} u_\pm(p) = \begin{pmatrix} \sqrt{p_0\mp|\vec p|} \cdot \chi_\pm(\vec p) \\ \sqrt{p_0\pm|\vec p|} \cdot \chi_\pm(\vec p) \end{pmatrix} \end{equation} <>= pure function u (mass, p, s) result (psi) type(bispinor) :: psi real(kind=default), intent(in) :: mass type(momentum), intent(in) :: p integer, intent(in) :: s complex(kind=default), dimension(2) :: chip, chim real(kind=default) :: pabs, norm, delta, m m = abs(mass) pabs = sqrt (dot_product (p%x, p%x)) if (m < epsilon (m) * pabs) then delta = 0 else delta = sqrt (max (p%t - pabs, 0._default)) end if if (pabs + p%x(3) <= 1000 * epsilon (pabs) * pabs) then chip = (/ cmplx ( 0.0, 0.0, kind=default), & cmplx ( 1.0, 0.0, kind=default) /) chim = (/ cmplx (-1.0, 0.0, kind=default), & cmplx ( 0.0, 0.0, kind=default) /) else norm = 1 / sqrt (2*pabs*(pabs + p%x(3))) chip = norm * (/ cmplx (pabs + p%x(3), kind=default), & cmplx (p%x(1), p%x(2), kind=default) /) chim = norm * (/ cmplx (-p%x(1), p%x(2), kind=default), & cmplx (pabs + p%x(3), kind=default) /) end if if (s > 0) then psi%a(1:2) = delta * chip psi%a(3:4) = sqrt (p%t + pabs) * chip else psi%a(1:2) = sqrt (p%t + pabs) * chim psi%a(3:4) = delta * chim end if pabs = m ! make the compiler happy and use m if (mass < 0) then psi%a(1:2) = - imago * psi%a(1:2) psi%a(3:4) = + imago * psi%a(3:4) end if end function u @ \begin{equation} v_\pm(p) = \begin{pmatrix} \mp\sqrt{p_0\pm|\vec p|} \cdot \chi_\mp(\vec p) \\ \pm\sqrt{p_0\mp|\vec p|} \cdot \chi_\mp(\vec p) \end{pmatrix} \end{equation} <>= pure function v (mass, p, s) result (psi) type(bispinor) :: psi real(kind=default), intent(in) :: mass type(momentum), intent(in) :: p integer, intent(in) :: s complex(kind=default), dimension(2) :: chip, chim real(kind=default) :: pabs, norm, delta, m pabs = sqrt (dot_product (p%x, p%x)) m = abs(mass) if (m < epsilon (m) * pabs) then delta = 0 else delta = sqrt (max (p%t - pabs, 0._default)) end if if (pabs + p%x(3) <= 1000 * epsilon (pabs) * pabs) then chip = (/ cmplx ( 0.0, 0.0, kind=default), & cmplx ( 1.0, 0.0, kind=default) /) chim = (/ cmplx (-1.0, 0.0, kind=default), & cmplx ( 0.0, 0.0, kind=default) /) else norm = 1 / sqrt (2*pabs*(pabs + p%x(3))) chip = norm * (/ cmplx (pabs + p%x(3), kind=default), & cmplx (p%x(1), p%x(2), kind=default) /) chim = norm * (/ cmplx (-p%x(1), p%x(2), kind=default), & cmplx (pabs + p%x(3), kind=default) /) end if if (s > 0) then psi%a(1:2) = - sqrt (p%t + pabs) * chim psi%a(3:4) = delta * chim else psi%a(1:2) = delta * chip psi%a(3:4) = - sqrt (p%t + pabs) * chip end if pabs = m ! make the compiler happy and use m if (mass < 0) then psi%a(1:2) = - imago * psi%a(1:2) psi%a(3:4) = + imago * psi%a(3:4) end if end function v @ <>= pure function ghost (m, p, s) result (psi) type(bispinor) :: psi real(kind=default), intent(in) :: m type(momentum), intent(in) :: p integer, intent(in) :: s psi%a(:) = 0 select case (s) case (1) psi%a(1) = 1 psi%a(2:4) = 0 case (2) psi%a(1) = 0 psi%a(2) = 1 psi%a(3:4) = 0 case (3) psi%a(1:2) = 0 psi%a(3) = 1 psi%a(4) = 0 case (4) psi%a(1:3) = 0 psi%a(4) = 1 case (5) psi%a(1) = 1.4 psi%a(2) = - 2.3 psi%a(3) = - 71.5 psi%a(4) = 0.1 end select end function ghost @ \subsection{Off Shell Wave Functions} This is the same as for the Dirac fermions except that the expressions for [ubar] and [vbar] are missing. <>= public :: brs_u, brs_v @ In momentum space we have: \begin{equation} brs u(p)=(-i) (\fmslash p-m)u(p) \end{equation} <>= pure function brs_u (m, p, s) result (dpsi) type(bispinor) :: dpsi, psi real(kind=default), intent(in) :: m type(momentum), intent(in) :: p integer, intent(in) :: s type (vector)::vp complex(kind=default), parameter :: one = (1, 0) vp=p psi=u(m,p,s) dpsi=cmplx(0.0,-1.0)*(f_vf(one,vp,psi)-m*psi) end function brs_u @ \begin{equation} brs v(p)=i (\fmslash p+m)v(p) \end{equation} <>= pure function brs_v (m, p, s) result (dpsi) type(bispinor) :: dpsi, psi real(kind=default), intent(in) :: m type(momentum), intent(in) :: p integer, intent(in) :: s type (vector)::vp complex(kind=default), parameter :: one = (1, 0) vp=p psi=v(m,p,s) dpsi=cmplx(0.0,1.0)*(f_vf(one,vp,psi)+m*psi) end function brs_v @ \subsection{Propagators} <>= public :: pr_psi, pr_grav public :: pj_psi, pg_psi @ \begin{equation} \frac{\ii(-\fmslash{p}+m)}{p^2-m^2+\ii m\Gamma}\psi \end{equation} NB: the sign of the momentum comes about because all momenta are treated as \emph{outgoing} and the particle charge flow is therefore opposite to the momentum. <>= pure function pr_psi (p, m, w, cms, psi) result (ppsi) type(bispinor) :: ppsi type(momentum), intent(in) :: p real(kind=default), intent(in) :: m, w type(bispinor), intent(in) :: psi logical, intent(in) :: cms type(vector) :: vp complex(kind=default), parameter :: one = (1, 0) complex(kind=default) :: num_mass vp = p if (cms) then num_mass = sqrt(cmplx(m**2, -m*w, kind=default)) else num_mass = cmplx (m, 0, kind=default) end if ppsi = (1 / cmplx (p*p - m**2, m*w, kind=default)) & * (- f_vf (one, vp, psi) + num_mass * psi) end function pr_psi @ \begin{equation} \sqrt{\frac{\pi}{M\Gamma}} (-\fmslash{p}+m)\psi \end{equation} <>= pure function pj_psi (p, m, w, psi) result (ppsi) type(bispinor) :: ppsi type(momentum), intent(in) :: p real(kind=default), intent(in) :: m, w type(bispinor), intent(in) :: psi type(vector) :: vp complex(kind=default), parameter :: one = (1, 0) vp = p ppsi = (0, -1) * sqrt (PI / m / w) * (- f_vf (one, vp, psi) + m * psi) end function pj_psi @ <>= pure function pg_psi (p, m, w, psi) result (ppsi) type(bispinor) :: ppsi type(momentum), intent(in) :: p real(kind=default), intent(in) :: m, w type(bispinor), intent(in) :: psi type(vector) :: vp complex(kind=default), parameter :: one = (1, 0) vp = p ppsi = gauss (p*p, m, w) * (- f_vf (one, vp, psi) + m * psi) end function pg_psi @ \begin{equation} \dfrac{\ii\biggl\{(-\fmslash{p} + m)\left(-\eta_{\mu\nu} + \dfrac{p_\mu p_\nu}{m^2}\right) + \dfrac{1}{3} \left(\gamma_\mu -\dfrac{p_\mu}{m}\right) (\fmslash{p} + m)\left(\gamma_\nu - \dfrac{p_\nu}{m}\right)\biggr\}}{p^2 - m^2 + \ii m \Gamma} \; \psi^\nu \end{equation} <>= pure function pr_grav (p, m, w, grav) result (propgrav) type(vectorspinor) :: propgrav type(momentum), intent(in) :: p real(kind=default), intent(in) :: m, w type(vectorspinor), intent(in) :: grav type(vector) :: vp type(bispinor) :: pgrav, ggrav, ggrav1, ggrav2, ppgrav type(vectorspinor) :: etagrav_dum, etagrav, pppgrav, & gg_grav_dum, gg_grav complex(kind=default), parameter :: one = (1, 0) real(kind=default) :: minv integer :: i vp = p minv = 1/m pgrav = p%t * grav%psi(1) - p%x(1) * grav%psi(2) - & p%x(2) * grav%psi(3) - p%x(3) * grav%psi(4) ggrav%a(1) = grav%psi(1)%a(3) - grav%psi(2)%a(4) + (0,1) * & grav%psi(3)%a(4) - grav%psi(4)%a(3) ggrav%a(2) = grav%psi(1)%a(4) - grav%psi(2)%a(3) - (0,1) * & grav%psi(3)%a(3) + grav%psi(4)%a(4) ggrav%a(3) = grav%psi(1)%a(1) + grav%psi(2)%a(2) - (0,1) * & grav%psi(3)%a(2) + grav%psi(4)%a(1) ggrav%a(4) = grav%psi(1)%a(2) + grav%psi(2)%a(1) + (0,1) * & grav%psi(3)%a(1) - grav%psi(4)%a(2) ggrav1 = ggrav - minv * pgrav ggrav2 = f_vf (one, vp, ggrav1) + m * ggrav - pgrav ppgrav = (-minv**2) * f_vf (one, vp, pgrav) + minv * pgrav do i = 1, 4 etagrav_dum%psi(i) = f_vf (one, vp, grav%psi(i)) end do etagrav = etagrav_dum - m * grav pppgrav%psi(1) = p%t * ppgrav pppgrav%psi(2) = p%x(1) * ppgrav pppgrav%psi(3) = p%x(2) * ppgrav pppgrav%psi(4) = p%x(3) * ppgrav gg_grav_dum%psi(1) = p%t * ggrav2 gg_grav_dum%psi(2) = p%x(1) * ggrav2 gg_grav_dum%psi(3) = p%x(2) * ggrav2 gg_grav_dum%psi(4) = p%x(3) * ggrav2 gg_grav = gr_potf (one, one, ggrav2) - minv * gg_grav_dum propgrav = (1 / cmplx (p*p - m**2, m*w, kind=default)) * & (etagrav + pppgrav + (1/3.0_default) * gg_grav) end function pr_grav @ \section{Polarization vectorspinors} Here we construct the wavefunctions for (massive) gravitinos out of the wavefunctions of (massive) vectorbosons and (massive) Majorana fermions. \begin{subequations} \begin{align} \psi^\mu_{(u; 3/2)} (k) &= \; \epsilon^\mu_+ (k) \cdot u (k, +) \\ \psi^\mu_{(u; 1/2)} (k) &= \; \sqrt{\dfrac{1}{3}} \, \epsilon^\mu_+ (k) \cdot u (k, -) + \sqrt{\dfrac{2}{3}} \, \epsilon^\mu_0 (k) \cdot u (k, +) \\ \psi^\mu_{(u; -1/2)} (k) &= \; \sqrt{\dfrac{2}{3}} \, \epsilon^\mu_0 (k) \cdot u (k, -) + \sqrt{\dfrac{1}{3}} \, \epsilon^\mu_- (k) \cdot u (k, +) \\ \psi^\mu_{(u; -3/2)} (k) &= \; \epsilon^\mu_- (k) \cdot u (k, -) \end{align} \end{subequations} and in the same manner for $\psi^\mu_{(v; s)}$ with $u$ replaced by $v$ and with the conjugated polarization vectors. These gravitino wavefunctions obey the Dirac equation, they are transverse and they fulfill the irreducibility condition \begin{equation} \gamma_\mu \psi^\mu_{(u/v; s)} = 0 . \end{equation} <<[[omega_vspinor_polarizations.f90]]>>= <> module omega_vspinor_polarizations use kinds use constants use omega_vectors use omega_bispinors use omega_bispinor_couplings use omega_vectorspinors implicit none <> integer, parameter, public :: omega_vspinor_pols_2010_01_A = 0 contains <> end module omega_vspinor_polarizations @ <>= public :: ueps, veps private :: eps private :: outer_product @ Here we implement the polarization vectors for vectorbosons with trigonometric functions, without the rotating of components done in HELAS~\cite{HELAS}. These are only used for generating the polarization vectorspinors. \begin{subequations} \begin{align} \epsilon^\mu_+(k) &= \frac{- e^{+\ii\phi}}{\sqrt{2}} \left(0; \cos\theta\cos\phi - \ii\sin\phi, \cos\theta\sin\phi + \ii\cos\phi, -\sin\theta \right) \\ \epsilon^\mu_-(k) &= \frac{e^{-\ii\phi}}{\sqrt{2}} \left(0; \cos\theta\cos\phi + \ii \sin\phi, \cos\theta\sin\phi - \ii \cos\phi, - \sin\theta \right) \\ \epsilon^\mu_0(k) &= \frac{1}{m} \left(|\vec k|; k^0\sin\theta\cos\phi, k^0\sin\theta\sin\phi, k^0\cos\theta\right) \end{align} \end{subequations} Determining the mass from the momenta is a numerically haphazardous for light particles. Therefore, we accept some redundancy and pass the mass explicitely. For the case that the momentum lies totally in the $z$-direction we take the convention $\cos\phi=1$ and $\sin\phi=0$. <>= pure function eps (mass, k, s) result (e) type(vector) :: e real(kind=default), intent(in) :: mass type(momentum), intent(in) :: k integer, intent(in) :: s real(kind=default) :: kabs, kabs2, sqrt2, m real(kind=default) :: cos_phi, sin_phi, cos_th, sin_th complex(kind=default) :: epiphi, emiphi sqrt2 = sqrt (2.0_default) kabs2 = dot_product (k%x, k%x) m = abs(mass) if (kabs2 > 0) then kabs = sqrt (kabs2) if ((k%x(1) == 0) .and. (k%x(2) == 0)) then cos_phi = 1 sin_phi = 0 else cos_phi = k%x(1) / sqrt(k%x(1)**2 + k%x(2)**2) sin_phi = k%x(2) / sqrt(k%x(1)**2 + k%x(2)**2) end if cos_th = k%x(3) / kabs sin_th = sqrt(1 - cos_th**2) epiphi = cos_phi + (0,1) * sin_phi emiphi = cos_phi - (0,1) * sin_phi e%t = 0 e%x = 0 select case (s) case (1) e%x(1) = epiphi * (-cos_th * cos_phi + (0,1) * sin_phi) / sqrt2 e%x(2) = epiphi * (-cos_th * sin_phi - (0,1) * cos_phi) / sqrt2 e%x(3) = epiphi * ( sin_th / sqrt2) case (-1) e%x(1) = emiphi * ( cos_th * cos_phi + (0,1) * sin_phi) / sqrt2 e%x(2) = emiphi * ( cos_th * sin_phi - (0,1) * cos_phi) / sqrt2 e%x(3) = emiphi * (-sin_th / sqrt2) case (0) if (m > 0) then e%t = kabs / m e%x = k%t / (m*kabs) * k%x end if case (4) if (m > 0) then e = (1 / m) * k else e = (1 / k%t) * k end if end select else !!! for particles in their rest frame defined to be !!! polarized along the 3-direction e%t = 0 e%x = 0 select case (s) case (1) e%x(1) = cmplx ( - 1, 0, kind=default) / sqrt2 e%x(2) = cmplx ( 0, 1, kind=default) / sqrt2 case (-1) e%x(1) = cmplx ( 1, 0, kind=default) / sqrt2 e%x(2) = cmplx ( 0, 1, kind=default) / sqrt2 case (0) if (m > 0) then e%x(3) = 1 end if case (4) if (m > 0) then e = (1 / m) * k else e = (1 / k%t) * k end if end select end if end function eps @ <>= pure function ueps (m, k, s) result (t) type(vectorspinor) :: t real(kind=default), intent(in) :: m type(momentum), intent(in) :: k integer, intent(in) :: s integer :: i type(vector) :: ep, e0, em type(bispinor) :: up, um do i = 1, 4 t%psi(i)%a = 0 end do select case (s) case (2) ep = eps (m, k, 1) up = u (m, k, 1) t = outer_product (ep, up) case (1) ep = eps (m, k, 1) e0 = eps (m, k, 0) up = u (m, k, 1) um = u (m, k, -1) t = (1 / sqrt (3.0_default)) * (outer_product (ep, um) & + sqrt (2.0_default) * outer_product (e0, up)) case (-1) e0 = eps (m, k, 0) em = eps (m, k, -1) up = u (m, k, 1) um = u (m, k, -1) t = (1 / sqrt (3.0_default)) * (sqrt (2.0_default) * & outer_product (e0, um) + outer_product (em, up)) case (-2) em = eps (m, k, -1) um = u (m, k, -1) t = outer_product (em, um) end select end function ueps @ <>= pure function veps (m, k, s) result (t) type(vectorspinor) :: t real(kind=default), intent(in) :: m type(momentum), intent(in) :: k integer, intent(in) :: s integer :: i type(vector) :: ep, e0, em type(bispinor) :: vp, vm do i = 1, 4 t%psi(i)%a = 0 end do select case (s) case (2) ep = conjg(eps (m, k, 1)) vp = v (m, k, 1) t = outer_product (ep, vp) case (1) ep = conjg(eps (m, k, 1)) e0 = conjg(eps (m, k, 0)) vp = v (m, k, 1) vm = v (m, k, -1) t = (1 / sqrt (3.0_default)) * (outer_product (ep, vm) & + sqrt (2.0_default) * outer_product (e0, vp)) case (-1) e0 = conjg(eps (m, k, 0)) em = conjg(eps (m, k, -1)) vp = v (m, k, 1) vm = v (m, k, -1) t = (1 / sqrt (3.0_default)) * (sqrt (2.0_default) & * outer_product (e0, vm) + outer_product (em, vp)) case (-2) em = conjg(eps (m, k, -1)) vm = v (m, k, -1) t = outer_product (em, vm) end select end function veps @ <>= pure function outer_product (ve, sp) result (vs) type(vectorspinor) :: vs type(vector), intent(in) :: ve type(bispinor), intent(in) :: sp integer :: i vs%psi(1)%a(1:4) = ve%t * sp%a(1:4) do i = 1, 3 vs%psi((i+1))%a(1:4) = ve%x(i) * sp%a(1:4) end do end function outer_product @ \section{Color} <<[[omega_color.f90]]>>= <> module omega_color use kinds implicit none private <> <> integer, parameter, public :: omega_color_2010_01_A = 0 contains <> end module omega_color @ \subsection{Color Sum} <>= public :: omega_color_factor type omega_color_factor integer :: i1, i2 real(kind=default) :: factor end type omega_color_factor @ <>= public :: omega_color_sum @ The [[!$omp]] instruction will result in parallel code if compiled with support for OpenMP otherwise it is ignored. @ <>= <<[[pure]] unless OpenMP>> function omega_color_sum (flv, hel, amp, cf) result (amp2) complex(kind=default) :: amp2 integer, intent(in) :: flv, hel complex(kind=default), dimension(:,:,:), intent(in) :: amp type(omega_color_factor), dimension(:), intent(in) :: cf integer :: n amp2 = 0 !$omp parallel do reduction(+:amp2) do n = 1, size (cf) amp2 = amp2 + cf(n)%factor * & amp(flv,cf(n)%i1,hel) * conjg (amp(flv,cf(n)%i2,hel)) end do !$omp end parallel do end function omega_color_sum @ In the bytecode for the OVM, we only save the symmetric part of the color factor table. This almost halves the size of $n$ gluon amplitudes for $n>6$. For $2\,\to\,(5,6)\,g$ the reduced color factor table still amounts for $\sim(75,93)\%$ of the bytecode, making it desirable to omit it completely by computing it dynamically to reduce memory requirements. Note that $2\text{Re}(A_{i_1}A_{i_2}^*)=A_{i_1}A_{i_2}^*+A_{i_2}A_{i_1}^*$. <>= public :: ovm_color_sum @ <>= <<[[pure]] unless OpenMP>> function ovm_color_sum (flv, hel, amp, cf) result (amp2) real(kind=default) :: amp2 integer, intent(in) :: flv, hel complex(kind=default), dimension(:,:,:), intent(in) :: amp type(omega_color_factor), dimension(:), intent(in) :: cf integer :: n amp2 = 0 !$omp parallel do reduction(+:amp2) do n = 1, size (cf) if (cf(n)%i1 == cf(n)%i2) then amp2 = amp2 + cf(n)%factor * & real(amp(flv,cf(n)%i1,hel) * conjg(amp(flv,cf(n)%i2,hel))) else amp2 = amp2 + cf(n)%factor * 2 * & real(amp(flv,cf(n)%i1,hel) * conjg(amp(flv,cf(n)%i2,hel))) end if end do !$omp end parallel do end function ovm_color_sum @ \section{Utilities} <<[[omega_utils.f90]]>>= <> module omega_utils use kinds use omega_vectors use omega_polarizations implicit none private <> <> integer, parameter, public :: omega_utils_2010_01_A = 0 contains <> end module omega_utils @ \subsection{Helicity Selection Rule Heuristics} <>= public :: omega_update_helicity_selection @ <>= pure subroutine omega_update_helicity_selection & (count, amp, max_abs, sum_abs, mask, threshold, cutoff, mask_dirty) integer, intent(inout) :: count complex(kind=default), dimension(:,:,:), intent(in) :: amp real(kind=default), dimension(:), intent(inout) :: max_abs real(kind=default), intent(inout) :: sum_abs logical, dimension(:), intent(inout) :: mask real(kind=default), intent(in) :: threshold integer, intent(in) :: cutoff logical, intent(out) :: mask_dirty integer :: h real(kind=default) :: avg mask_dirty = .false. if (threshold > 0) then count = count + 1 if (count <= cutoff) then forall (h = lbound (amp, 3) : ubound (amp, 3)) max_abs(h) = max (max_abs(h), maxval (abs (amp(:,:,h)))) end forall sum_abs = sum_abs + sum (abs (amp)) if (count == cutoff) then avg = sum_abs / size (amp) / cutoff mask = max_abs >= threshold * epsilon (avg) * avg mask_dirty = .true. end if end if end if end subroutine omega_update_helicity_selection @ \subsection{Diagnostics} <>= public :: omega_report_helicity_selection @ We shoul try to use [[msg_message]] from WHIZARD's [[diagnostics]] module, but this would spoil independent builds. <>= subroutine omega_report_helicity_selection (mask, spin_states, threshold, unit) logical, dimension(:), intent(in) :: mask integer, dimension(:,:), intent(in) :: spin_states real(kind=default), intent(in) :: threshold integer, intent(in), optional :: unit integer :: u integer :: h, i if (present(unit)) then u = unit else u = 6 end if if (u >= 0) then write (unit = u, & fmt = "('| ','Contributing Helicity Combinations: ', I5, ' of ', I5)") & count (mask), size (mask) write (unit = u, & fmt = "('| ','Threshold: amp / avg > ', E9.2, ' = ', E9.2, ' * epsilon()')") & threshold * epsilon (threshold), threshold i = 0 do h = 1, size (mask) if (mask(h)) then i = i + 1 write (unit = u, fmt = "('| ',I4,': ',20I4)") i, spin_states (:, h) end if end do end if end subroutine omega_report_helicity_selection @ <>= public :: omega_ward_warn, omega_ward_panic @ The O'Mega amplitudes have only one particle off shell and are the sum of \emph{all} possible diagrams with the other particles on-shell. \begin{dubious} The problem with these gauge checks is that are numerically very small amplitudes that vanish analytically and that violate transversality. The hard part is to determine the thresholds that make threse tests usable. \end{dubious} <>= subroutine omega_ward_warn (name, m, k, e) character(len=*), intent(in) :: name real(kind=default), intent(in) :: m type(momentum), intent(in) :: k type(vector), intent(in) :: e type(vector) :: ek real(kind=default) :: abs_eke, abs_ek_abs_e ek = eps (m, k, 4) abs_eke = abs (ek * e) abs_ek_abs_e = abs (ek) * abs (e) print *, name, ":", abs_eke / abs_ek_abs_e, abs (ek), abs (e) if (abs_eke > 1000 * epsilon (abs_ek_abs_e)) then print *, "O'Mega: warning: non-transverse vector field: ", & name, ":", abs_eke / abs_ek_abs_e, abs (e) end if end subroutine omega_ward_warn @ <>= subroutine omega_ward_panic (name, m, k, e) character(len=*), intent(in) :: name real(kind=default), intent(in) :: m type(momentum), intent(in) :: k type(vector), intent(in) :: e type(vector) :: ek real(kind=default) :: abs_eke, abs_ek_abs_e ek = eps (m, k, 4) abs_eke = abs (ek * e) abs_ek_abs_e = abs (ek) * abs (e) if (abs_eke > 1000 * epsilon (abs_ek_abs_e)) then print *, "O'Mega: panic: non-transverse vector field: ", & name, ":", abs_eke / abs_ek_abs_e, abs (e) stop end if end subroutine omega_ward_panic @ <>= public :: omega_slavnov_warn, omega_slavnov_panic @ <>= subroutine omega_slavnov_warn (name, m, k, e, phi) character(len=*), intent(in) :: name real(kind=default), intent(in) :: m type(momentum), intent(in) :: k type(vector), intent(in) :: e complex(kind=default), intent(in) :: phi type(vector) :: ek real(kind=default) :: abs_eke, abs_ek_abs_e ek = eps (m, k, 4) abs_eke = abs (ek * e - phi) abs_ek_abs_e = abs (ek) * abs (e) print *, name, ":", abs_eke / abs_ek_abs_e, abs (ek), abs (e) if (abs_eke > 1000 * epsilon (abs_ek_abs_e)) then print *, "O'Mega: warning: non-transverse vector field: ", & name, ":", abs_eke / abs_ek_abs_e, abs (e) end if end subroutine omega_slavnov_warn @ <>= subroutine omega_slavnov_panic (name, m, k, e, phi) character(len=*), intent(in) :: name real(kind=default), intent(in) :: m type(momentum), intent(in) :: k type(vector), intent(in) :: e complex(kind=default), intent(in) :: phi type(vector) :: ek real(kind=default) :: abs_eke, abs_ek_abs_e ek = eps (m, k, 4) abs_eke = abs (ek * e - phi) abs_ek_abs_e = abs (ek) * abs (e) if (abs_eke > 1000 * epsilon (abs_ek_abs_e)) then print *, "O'Mega: panic: non-transverse vector field: ", & name, ":", abs_eke / abs_ek_abs_e, abs (e) stop end if end subroutine omega_slavnov_panic @ <>= public :: omega_check_arguments_warn, omega_check_arguments_panic @ <>= subroutine omega_check_arguments_warn (n, k) integer, intent(in) :: n real(kind=default), dimension(0:,:), intent(in) :: k integer :: i i = size(k,dim=1) if (i /= 4) then print *, "O'Mega: warning: wrong # of dimensions:", i end if i = size(k,dim=2) if (i /= n) then print *, "O'Mega: warning: wrong # of momenta:", i, & ", expected", n end if end subroutine omega_check_arguments_warn @ <>= subroutine omega_check_arguments_panic (n, k) integer, intent(in) :: n real(kind=default), dimension(0:,:), intent(in) :: k logical :: error integer :: i error = .false. i = size(k,dim=1) if (i /= n) then print *, "O'Mega: warning: wrong # of dimensions:", i error = .true. end if i = size(k,dim=2) if (i /= n) then print *, "O'Mega: warning: wrong # of momenta:", i, & ", expected", n error = .true. end if if (error) then stop end if end subroutine omega_check_arguments_panic @ <>= public :: omega_check_helicities_warn, omega_check_helicities_panic private :: omega_check_helicity @ <>= function omega_check_helicity (m, smax, s) result (error) real(kind=default), intent(in) :: m integer, intent(in) :: smax, s logical :: error select case (smax) case (0) error = (s /= 0) case (1) error = (abs (s) /= 1) case (2) if (m == 0.0_default) then error = .not. (abs (s) == 1 .or. abs (s) == 4) else error = .not. (abs (s) <= 1 .or. abs (s) == 4) end if case (4) error = .true. case default error = .true. end select end function omega_check_helicity @ <>= subroutine omega_check_helicities_warn (m, smax, s) real(kind=default), dimension(:), intent(in) :: m integer, dimension(:), intent(in) :: smax, s integer :: i do i = 1, size (m) if (omega_check_helicity (m(i), smax(i), s(i))) then print *, "O'Mega: warning: invalid helicity", s(i) end if end do end subroutine omega_check_helicities_warn @ <>= subroutine omega_check_helicities_panic (m, smax, s) real(kind=default), dimension(:), intent(in) :: m integer, dimension(:), intent(in) :: smax, s logical :: error logical :: error1 integer :: i error = .false. do i = 1, size (m) error1 = omega_check_helicity (m(i), smax(i), s(i)) if (error1) then print *, "O'Mega: panic: invalid helicity", s(i) error = .true. end if end do if (error) then stop end if end subroutine omega_check_helicities_panic @ <>= public :: omega_check_momenta_warn, omega_check_momenta_panic private :: check_momentum_conservation, check_mass_shell @ <>= integer, parameter, private :: MOMENTUM_TOLERANCE = 10000 @ <>= function check_momentum_conservation (k) result (error) real(kind=default), dimension(0:,:), intent(in) :: k logical :: error error = any (abs (sum (k(:,3:), dim = 2) - k(:,1) - k(:,2)) > & MOMENTUM_TOLERANCE * epsilon (maxval (abs (k), dim = 2))) if (error) then print *, sum (k(:,3:), dim = 2) - k(:,1) - k(:,2) print *, MOMENTUM_TOLERANCE * epsilon (maxval (abs (k), dim = 2)), & maxval (abs (k), dim = 2) end if end function check_momentum_conservation @ <>= integer, parameter, private :: ON_SHELL_TOLERANCE = 1000000 @ <>= function check_mass_shell (m, k) result (error) real(kind=default), intent(in) :: m real(kind=default), dimension(0:), intent(in) :: k real(kind=default) :: e2 logical :: error e2 = k(1)**2 + k(2)**2 + k(3)**2 + m**2 error = abs (k(0)**2 - e2) > ON_SHELL_TOLERANCE * epsilon (max (k(0)**2, e2)) if (error) then print *, k(0)**2 - e2 print *, ON_SHELL_TOLERANCE * epsilon (max (k(0)**2, e2)), max (k(0)**2, e2) end if end function check_mass_shell @ <>= subroutine omega_check_momenta_warn (m, k) real(kind=default), dimension(:), intent(in) :: m real(kind=default), dimension(0:,:), intent(in) :: k integer :: i if (check_momentum_conservation (k)) then print *, "O'Mega: warning: momentum not conserved" end if do i = 1, size(m) if (check_mass_shell (m(i), k(:,i))) then print *, "O'Mega: warning: particle #", i, "not on-shell" end if end do end subroutine omega_check_momenta_warn @ <>= subroutine omega_check_momenta_panic (m, k) real(kind=default), dimension(:), intent(in) :: m real(kind=default), dimension(0:,:), intent(in) :: k logical :: error logical :: error1 integer :: i error = check_momentum_conservation (k) if (error) then print *, "O'Mega: panic: momentum not conserved" end if do i = 1, size(m) error1 = check_mass_shell (m(i), k(0:,i)) if (error1) then print *, "O'Mega: panic: particle #", i, "not on-shell" error = .true. end if end do if (error) then stop end if end subroutine omega_check_momenta_panic @ \subsection{Obsolete Summation} \subsubsection{Spin/Helicity Summation} <>= public :: omega_sum, omega_sum_nonzero, omega_nonzero private :: state_index @ <>= pure function omega_sum (omega, p, states, fixed) result (sigma) real(kind=default) :: sigma real(kind=default), dimension(0:,:), intent(in) :: p integer, dimension(:), intent(in), optional :: states, fixed <<[[interface]] for O'Mega Amplitude>> integer, dimension(size(p,dim=2)) :: s, nstates integer :: j complex(kind=default) :: a if (present (states)) then nstates = states else nstates = 2 end if sigma = 0 s = -1 sum_spins: do if (present (fixed)) then !!! print *, 's = ', s, ', fixed = ', fixed, ', nstates = ', nstates, & !!! ', fixed|s = ', merge (fixed, s, mask = nstates == 0) a = omega (p, merge (fixed, s, mask = nstates == 0)) else a = omega (p, s) end if sigma = sigma + a * conjg(a) <> end do sum_spins sigma = sigma / num_states (2, nstates(1:2)) end function omega_sum @ We're looping over all spins like a $n$-ary numbers $(-1,\ldots,-1,-1)$, $(-1,\ldots,-1,0)$, $(-1,\ldots,-1,1)$, $(-1,\ldots,0,-1)$, \ldots, $(1,\ldots,1,0)$, $(1,\ldots,1,1)$: <>= do j = size (p, dim = 2), 1, -1 select case (nstates (j)) case (3) ! massive vectors s(j) = modulo (s(j) + 2, 3) - 1 case (2) ! spinors, massless vectors s(j) = - s(j) case (1) ! scalars s(j) = -1 case (0) ! fized spin s(j) = -1 case default ! ??? s(j) = -1 end select if (s(j) /= -1) then cycle sum_spins end if end do exit sum_spins @ The dual operation evaluates an $n$-number: <>= pure function state_index (s, states) result (n) integer, dimension(:), intent(in) :: s integer, dimension(:), intent(in), optional :: states integer :: n integer :: j, p n = 1 p = 1 if (present (states)) then do j = size (s), 1, -1 select case (states(j)) case (3) n = n + p * (s(j) + 1) case (2) n = n + p * (s(j) + 1) / 2 end select p = p * states(j) end do else do j = size (s), 1, -1 n = n + p * (s(j) + 1) / 2 p = p * 2 end do end if end function state_index @ <<[[interface]] for O'Mega Amplitude>>= interface pure function omega (p, s) result (me) use kinds implicit none complex(kind=default) :: me real(kind=default), dimension(0:,:), intent(in) :: p integer, dimension(:), intent(in) :: s end function omega end interface @ <>= public :: num_states @ <>= pure function num_states (n, states) result (ns) integer, intent(in) :: n integer, dimension(:), intent(in), optional :: states integer :: ns if (present (states)) then ns = product (states, mask = states == 2 .or. states == 3) else ns = 2**n end if end function num_states @ \section{\texttt{omega95}} <<[[omega95.f90]]>>= <> module omega95 use constants use omega_spinors use omega_vectors use omega_polarizations use omega_tensors use omega_tensor_polarizations use omega_couplings use omega_spinor_couplings use omega_color use omega_utils public end module omega95 @ \section{\texttt{omega95} Revisited} <<[[omega95_bispinors.f90]]>>= <> module omega95_bispinors use constants use omega_bispinors use omega_vectors use omega_vectorspinors use omega_polarizations use omega_vspinor_polarizations use omega_couplings use omega_bispinor_couplings use omega_color use omega_utils public end module omega95_bispinors @ \section{Testing} <<[[omega_testtools.f90]]>>= <> module omega_testtools use kinds implicit none private real(kind=default), parameter, private :: ABS_THRESHOLD_DEFAULT = 1E-17 real(kind=default), parameter, private :: THRESHOLD_DEFAULT = 0.6 real(kind=default), parameter, private :: THRESHOLD_WARN = 0.8 <> contains <> end module omega_testtools @ Quantify the agreement of two real or complex numbers \begin{equation} \text{agreement}(x,y) = \frac{\ln \Delta(x,y)}{\ln\epsilon} \in[0,1] \end{equation} with \begin{equation} \Delta(x,y) = \frac{|x-y|}{\max(|x|,|y|)} \end{equation} and values outside~$[0,1]$ replaced the closed value in the interval. In other words \begin{itemize} \item $1$ for $x-y=\max(|x|,|y|)\cdot\mathcal{O}(\epsilon)$ and \item $0$~for $x-y=\max(|x|,|y|)\cdot\mathcal{O}(1)$ \end{itemize} with logarithmic interpolation. The cases~$x=0$ and~$y=0$ must be treated separately. <>= public :: agreement interface agreement module procedure agreement_real, agreement_complex, & agreement_real_complex, agreement_complex_real, & agreement_integer_complex, agreement_complex_integer, & agreement_integer_real, agreement_real_integer end interface private :: agreement_real, agreement_complex, & agreement_real_complex, agreement_complex_real, & agreement_integer_complex, agreement_complex_integer, & agreement_integer_real, agreement_real_integer @ <>= elemental function agreement_real (x, y, base) result (a) real(kind=default) :: a real(kind=default), intent(in) :: x, y real(kind=default), intent(in), optional :: base real(kind=default) :: scale, dxy if (present (base)) then scale = max (abs (x), abs (y), abs (base)) else scale = max (abs (x), abs (y)) end if if (ieee_is_nan (x) .or. ieee_is_nan (y)) then a = 0 else if (scale <= 0) then a = -1 else dxy = abs (x - y) / scale if (dxy <= 0.0_default) then a = 1 else a = log (dxy) / log (epsilon (scale)) a = max (0.0_default, min (1.0_default, a)) if (ieee_is_nan (a)) then a = 0 end if end if end if if (ieee_is_nan (a)) then a = 0 end if end function agreement_real @ Poor man's replacement <>= elemental function ieee_is_nan (x) result (yorn) logical :: yorn real (kind=default), intent(in) :: x yorn = (x /= x) end function ieee_is_nan @ <>= elemental function agreement_complex (x, y, base) result (a) real(kind=default) :: a complex(kind=default), intent(in) :: x, y real(kind=default), intent(in), optional :: base real(kind=default) :: scale, dxy if (present (base)) then scale = max (abs (x), abs (y), abs (base)) else scale = max (abs (x), abs (y)) end if if ( ieee_is_nan (real (x, kind=default)) .or. ieee_is_nan (aimag (x)) & .or. ieee_is_nan (real (y, kind=default)) .or. ieee_is_nan (aimag (y))) then a = 0 else if (scale <= 0) then a = -1 else dxy = abs (x - y) / scale if (dxy <= 0.0_default) then a = 1 else a = log (dxy) / log (epsilon (scale)) a = max (0.0_default, min (1.0_default, a)) if (ieee_is_nan (a)) then a = 0 end if end if end if if (ieee_is_nan (a)) then a = 0 end if end function agreement_complex @ <>= elemental function agreement_real_complex (x, y, base) result (a) real(kind=default) :: a real(kind=default), intent(in) :: x complex(kind=default), intent(in) :: y real(kind=default), intent(in), optional :: base a = agreement_complex (cmplx (x, kind=default), y, base) end function agreement_real_complex @ <>= elemental function agreement_complex_real (x, y, base) result (a) real(kind=default) :: a complex(kind=default), intent(in) :: x real(kind=default), intent(in) :: y real(kind=default), intent(in), optional :: base a = agreement_complex (x, cmplx (y, kind=default), base) end function agreement_complex_real @ <>= elemental function agreement_integer_complex (x, y, base) result (a) real(kind=default) :: a integer, intent(in) :: x complex(kind=default), intent(in) :: y real(kind=default), intent(in), optional :: base a = agreement_complex (cmplx (x, kind=default), y, base) end function agreement_integer_complex @ <>= elemental function agreement_complex_integer (x, y, base) result (a) real(kind=default) :: a complex(kind=default), intent(in) :: x integer, intent(in) :: y real(kind=default), intent(in), optional :: base a = agreement_complex (x, cmplx (y, kind=default), base) end function agreement_complex_integer @ <>= elemental function agreement_integer_real (x, y, base) result (a) real(kind=default) :: a integer, intent(in) :: x real(kind=default), intent(in) :: y real(kind=default), intent(in), optional :: base a = agreement_real (real(x, kind=default), y, base) end function agreement_integer_real @ <>= elemental function agreement_real_integer (x, y, base) result (a) real(kind=default) :: a real(kind=default), intent(in) :: x integer, intent(in) :: y real(kind=default), intent(in), optional :: base a = agreement_real (x, real (y, kind=default), base) end function agreement_real_integer @ <>= public:: vanishes interface vanishes module procedure vanishes_real, vanishes_complex end interface private :: vanishes_real, vanishes_complex @ <>= elemental function vanishes_real (x, scale) result (a) real(kind=default) :: a real(kind=default), intent(in) :: x real(kind=default), intent(in), optional :: scale real(kind=default) :: scaled_x if (x == 0.0_default) then a = 1 return else if (ieee_is_nan (x)) then a = 0 return end if scaled_x = x if (present (scale)) then if (scale /= 0) then scaled_x = x / abs (scale) else a = 0 return end if else end if a = log (abs (scaled_x)) / log (epsilon (scaled_x)) a = max (0.0_default, min (1.0_default, a)) if (ieee_is_nan (a)) then a = 0 end if end function vanishes_real @ <>= elemental function vanishes_complex (x, scale) result (a) real(kind=default) :: a complex(kind=default), intent(in) :: x real(kind=default), intent(in), optional :: scale a = vanishes_real (abs (x), scale) end function vanishes_complex @ <>= public :: expect interface expect module procedure expect_integer, expect_real, expect_complex, & expect_real_integer, expect_integer_real, & expect_complex_integer, expect_integer_complex, & expect_complex_real, expect_real_complex end interface private :: expect_integer, expect_real, expect_complex, & expect_real_integer, expect_integer_real, & expect_complex_integer, expect_integer_complex, & expect_complex_real, expect_real_complex @ <>= subroutine expect_integer (x, x0, msg, passed, quiet, buffer, unit) integer, intent(in) :: x, x0 character(len=*), intent(in) :: msg logical, intent(inout), optional :: passed logical, intent(in), optional :: quiet character(len=*), intent(inout), optional :: buffer integer, intent(in), optional :: unit logical :: failed, verbose character(len=*), parameter :: fmt = "(1X,A,': ',A)" character(len=*), parameter :: & fmt_verbose = "(1X,A,': ',A,' [expected ',I6,', got ',I6,']')" failed = .false. verbose = .true. if (present (quiet)) then verbose = .not.quiet end if if (x == x0) then if (verbose) then if (.not. (present (buffer) .or. present (unit))) then write (unit = *, fmt = fmt) msg, "passed" end if if (present (unit)) then write (unit = unit, fmt = fmt) msg, "passed" end if if (present (buffer)) then write (unit = buffer, fmt = fmt) msg, "passed" end if end if else if (.not. (present (buffer) .or. present (unit))) then write (unit = *, fmt = fmt_verbose) msg, "failed", x0, x end if if (present (unit)) then write (unit = unit, fmt = fmt_verbose) msg, "failed", x0, x end if if (present (buffer)) then write (unit = buffer, fmt = fmt_verbose) msg, "failed", x0, x end if failed = .true. end if if (present (passed)) then passed = passed .and. .not.failed end if end subroutine expect_integer @ <>= subroutine expect_real (x, x0, msg, passed, threshold, quiet, abs_threshold) real(kind=default), intent(in) :: x, x0 character(len=*), intent(in) :: msg logical, intent(inout), optional :: passed real(kind=default), intent(in), optional :: threshold real(kind=default), intent(in), optional :: abs_threshold logical, intent(in), optional :: quiet logical :: failed, verbose real(kind=default) :: agreement_threshold, abs_agreement_threshold character(len=*), parameter :: fmt = "(1X,A,': ',A,' at ',I4,'%')" character(len=*), parameter :: fmt_verbose = "(1X,A,': ',A,' at ',I4,'%'," // & "' [expected ',E10.3,', got ',E10.3,']')" real(kind=default) :: a failed = .false. verbose = .true. if (present (quiet)) then verbose = .not.quiet end if if (x == x0) then if (verbose) then write (unit = *, fmt = fmt) msg, "passed", 100 end if else if (x0 == 0) then a = vanishes (x) else a = agreement (x, x0) end if if (present (threshold)) then agreement_threshold = threshold else agreement_threshold = THRESHOLD_DEFAULT end if if (present (abs_threshold)) then abs_agreement_threshold = abs_threshold else abs_agreement_threshold = ABS_THRESHOLD_DEFAULT end if if (a >= agreement_threshold .or. & max(abs(x), abs(x0)) <= abs_agreement_threshold) then if (verbose) then if (a >= THRESHOLD_WARN) then write (unit = *, fmt = fmt) msg, "passed", int (a * 100) else write (unit = *, fmt = fmt_verbose) msg, "passed", int (a * 100), x0, x end if end if else failed = .true. write (unit = *, fmt = fmt_verbose) msg, "failed", int (a * 100), x0, x end if end if if (present (passed)) then passed = passed .and. .not. failed end if end subroutine expect_real @ <>= subroutine expect_complex (x, x0, msg, passed, threshold, quiet, abs_threshold) complex(kind=default), intent(in) :: x, x0 character(len=*), intent(in) :: msg logical, intent(inout), optional :: passed real(kind=default), intent(in), optional :: threshold real(kind=default), intent(in), optional :: abs_threshold logical, intent(in), optional :: quiet logical :: failed, verbose real(kind=default) :: agreement_threshold, abs_agreement_threshold character(len=*), parameter :: fmt = "(1X,A,': ',A,' at ',I4,'%')" character(len=*), parameter :: fmt_verbose = "(1X,A,': ',A,' at ',I4,'%'," // & "' [expected (',E10.3,',',E10.3,'), got (',E10.3,',',E10.3,')]')" character(len=*), parameter :: fmt_phase = "(1X,A,': ',A,' at ',I4,'%'," // & "' [modulus passed at ',I4,'%',', phases ',F5.3,' vs. ',F5.3,']')" real(kind=default) :: a, a_modulus failed = .false. verbose = .true. if (present (quiet)) then verbose = .not.quiet end if if (x == x0) then if (verbose) then write (unit = *, fmt = fmt) msg, "passed", 100 end if else if (x0 == 0) then a = vanishes (x) else a = agreement (x, x0) end if if (present (threshold)) then agreement_threshold = threshold else agreement_threshold = THRESHOLD_DEFAULT end if if (present (abs_threshold)) then abs_agreement_threshold = abs_threshold else abs_agreement_threshold = ABS_THRESHOLD_DEFAULT end if if (a >= agreement_threshold .or. & max(abs(x), abs(x0)) <= abs_agreement_threshold) then if (verbose) then if (a >= THRESHOLD_WARN) then write (unit = *, fmt = fmt) msg, "passed", int (a * 100) else write (unit = *, fmt = fmt_verbose) msg, "passed", int (a * 100), x0, x end if end if else a_modulus = agreement (abs (x), abs (x0)) if (a_modulus >= agreement_threshold) then write (unit = *, fmt = fmt_phase) msg, "failed", int (a * 100), & int (a_modulus * 100), & atan2 (real (x, kind=default), aimag (x)), & atan2 (real (x0, kind=default), aimag (x0)) else write (unit = *, fmt = fmt_verbose) msg, "failed", int (a * 100), x0, x end if failed = .true. end if end if if (present (passed)) then passed = passed .and. .not.failed end if end subroutine expect_complex @ <>= subroutine expect_real_integer (x, x0, msg, passed, threshold, quiet) real(kind=default), intent(in) :: x integer, intent(in) :: x0 character(len=*), intent(in) :: msg real(kind=default), intent(in), optional :: threshold logical, intent(inout), optional :: passed logical, intent(in), optional :: quiet call expect_real (x, real (x0, kind=default), msg, passed, threshold, quiet) end subroutine expect_real_integer @ <>= subroutine expect_integer_real (x, x0, msg, passed, threshold, quiet) integer, intent(in) :: x real(kind=default), intent(in) :: x0 character(len=*), intent(in) :: msg real(kind=default), intent(in), optional :: threshold logical, intent(inout), optional :: passed logical, intent(in), optional :: quiet call expect_real (real (x, kind=default), x0, msg, passed, threshold, quiet) end subroutine expect_integer_real @ <>= subroutine expect_complex_integer (x, x0, msg, passed, threshold, quiet) complex(kind=default), intent(in) :: x integer, intent(in) :: x0 character(len=*), intent(in) :: msg logical, intent(inout), optional :: passed real(kind=default), intent(in), optional :: threshold logical, intent(in), optional :: quiet call expect_complex (x, cmplx (x0, kind=default), msg, passed, threshold, quiet) end subroutine expect_complex_integer @ <>= subroutine expect_integer_complex (x, x0, msg, passed, threshold, quiet) integer, intent(in) :: x complex(kind=default), intent(in) :: x0 character(len=*), intent(in) :: msg logical, intent(inout), optional :: passed real(kind=default), intent(in), optional :: threshold logical, intent(in), optional :: quiet call expect_complex (cmplx (x, kind=default), x0, msg, passed, threshold, quiet) end subroutine expect_integer_complex @ <>= subroutine expect_complex_real (x, x0, msg, passed, threshold, quiet) complex(kind=default), intent(in) :: x real(kind=default), intent(in) :: x0 character(len=*), intent(in) :: msg logical, intent(inout), optional :: passed real(kind=default), intent(in), optional :: threshold logical, intent(in), optional :: quiet call expect_complex (x, cmplx (x0, kind=default), msg, passed, threshold, quiet) end subroutine expect_complex_real @ <>= subroutine expect_real_complex (x, x0, msg, passed, threshold, quiet) real(kind=default), intent(in) :: x complex(kind=default), intent(in) :: x0 character(len=*), intent(in) :: msg logical, intent(inout), optional :: passed real(kind=default), intent(in), optional :: threshold logical, intent(in), optional :: quiet call expect_complex (cmplx (x, kind=default), x0, msg, passed, threshold, quiet) end subroutine expect_real_complex @ <>= public :: expect_zero interface expect_zero module procedure expect_zero_integer, expect_zero_real, expect_zero_complex end interface private :: expect_zero_integer, expect_zero_real, expect_zero_complex @ <>= subroutine expect_zero_integer (x, msg, passed) integer, intent(in) :: x character(len=*), intent(in) :: msg logical, intent(inout), optional :: passed call expect_integer (x, 0, msg, passed) end subroutine expect_zero_integer @ <>= subroutine expect_zero_real (x, scale, msg, passed, threshold, quiet) real(kind=default), intent(in) :: x, scale character(len=*), intent(in) :: msg logical, intent(inout), optional :: passed real(kind=default), intent(in), optional :: threshold logical, intent(in), optional :: quiet logical :: failed, verbose real(kind=default) :: agreement_threshold character(len=*), parameter :: fmt = "(1X,A,': ',A,' at ',I4,'%')" character(len=*), parameter :: fmt_verbose = "(1X,A,': ',A,' at ',I4,'%'," // & "' [expected 0 (relative to ',E10.3,') got ',E10.3,']')" real(kind=default) :: a failed = .false. verbose = .true. if (present (quiet)) then verbose = .not.quiet end if if (x == 0) then if (verbose) then write (unit = *, fmt = fmt) msg, "passed", 100 end if else a = vanishes (x, scale = scale) if (present (threshold)) then agreement_threshold = threshold else agreement_threshold = THRESHOLD_DEFAULT end if if (a >= agreement_threshold) then if (verbose) then if (a >= THRESHOLD_WARN) then write (unit = *, fmt = fmt) msg, "passed", int (a * 100) else write (unit = *, fmt = fmt_verbose) msg, "passed", int (a * 100), scale, x end if end if else failed = .true. write (unit = *, fmt = fmt_verbose) msg, "failed", int (a * 100), scale, x end if end if if (present (passed)) then passed = passed .and. .not.failed end if end subroutine expect_zero_real @ <>= subroutine expect_zero_complex (x, scale, msg, passed, threshold, quiet) complex(kind=default), intent(in) :: x real(kind=default), intent(in) :: scale character(len=*), intent(in) :: msg logical, intent(inout), optional :: passed real(kind=default), intent(in), optional :: threshold logical, intent(in), optional :: quiet call expect_zero_real (abs (x), scale, msg, passed, threshold, quiet) end subroutine expect_zero_complex @ <>= subroutine print_matrix (a) complex(kind=default), dimension(:,:), intent(in) :: a integer :: row do row = 1, size (a, dim=1) write (unit = *, fmt = "(10(tr2, f5.2, '+', f5.2, 'I'))") a(row,:) end do end subroutine print_matrix @ <>= public :: print_matrix @ <<[[test_omega95.f90]]>>= <> program test_omega95 use kinds use omega95 use omega_testtools implicit none real(kind=default) :: m, pabs, qabs, w real(kind=default), dimension(0:3) :: r complex(kind=default) :: c_one, c_nil type(momentum) :: p, q, p0 type(vector) :: vp, vq, vtest, v0 type(tensor) :: ttest type(spinor) :: test_psi, test_spinor1, test_spinor2 type(conjspinor) :: test_psibar, test_conjspinor1, test_conjspinor2 integer, dimension(8) :: date_time integer :: rsize, i logical :: passed call date_and_time (values = date_time) call random_seed (size = rsize) call random_seed (put = spread (product (date_time), dim = 1, ncopies = rsize)) w = 1.4142 c_one = 1.0_default c_nil = 0.0_default m = 13 pabs = 42 qabs = 137 call random_number (r) vtest%t = cmplx (10.0_default * r(0), kind=default) vtest%x(1:3) = cmplx (10.0_default * r(1:3), kind=default) ttest = vtest.tprod.vtest call random_momentum (p, pabs, m) call random_momentum (q, qabs, m) call random_momentum (p0, 0.0_default, m) vp = p vq = q v0 = p0 passed = .true. <> if (.not. passed) then stop 1 end if end program test_omega95 @ <>= print *, "*** Checking the equations of motion ***:" call expect (abs(f_vf(c_one,vp,u(m,p,+1))-m*u(m,p,+1)), 0, "|[p-m]u(+)|=0", passed) call expect (abs(f_vf(c_one,vp,u(m,p,-1))-m*u(m,p,-1)), 0, "|[p-m]u(-)|=0", passed) call expect (abs(f_vf(c_one,vp,v(m,p,+1))+m*v(m,p,+1)), 0, "|[p+m]v(+)|=0", passed) call expect (abs(f_vf(c_one,vp,v(m,p,-1))+m*v(m,p,-1)), 0, "|[p+m]v(-)|=0", passed) call expect (abs(f_fv(c_one,ubar(m,p,+1),vp)-m*ubar(m,p,+1)), 0, "|ubar(+)[p-m]|=0", passed) call expect (abs(f_fv(c_one,ubar(m,p,-1),vp)-m*ubar(m,p,-1)), 0, "|ubar(-)[p-m]|=0", passed) call expect (abs(f_fv(c_one,vbar(m,p,+1),vp)+m*vbar(m,p,+1)), 0, "|vbar(+)[p+m]|=0", passed) call expect (abs(f_fv(c_one,vbar(m,p,-1),vp)+m*vbar(m,p,-1)), 0, "|vbar(-)[p+m]|=0", passed) print *, "*** Checking the equations of motion for negative mass***:" call expect (abs(f_vf(c_one,vp,u(-m,p,+1))+m*u(-m,p,+1)), 0, "|[p+m]u(+)|=0", passed) call expect (abs(f_vf(c_one,vp,u(-m,p,-1))+m*u(-m,p,-1)), 0, "|[p+m]u(-)|=0", passed) call expect (abs(f_vf(c_one,vp,v(-m,p,+1))-m*v(-m,p,+1)), 0, "|[p-m]v(+)|=0", passed) call expect (abs(f_vf(c_one,vp,v(-m,p,-1))-m*v(-m,p,-1)), 0, "|[p-m]v(-)|=0", passed) call expect (abs(f_fv(c_one,ubar(-m,p,+1),vp)+m*ubar(-m,p,+1)), 0, "|ubar(+)[p+m]|=0", passed) call expect (abs(f_fv(c_one,ubar(-m,p,-1),vp)+m*ubar(-m,p,-1)), 0, "|ubar(-)[p+m]|=0", passed) call expect (abs(f_fv(c_one,vbar(-m,p,+1),vp)-m*vbar(-m,p,+1)), 0, "|vbar(+)[p-m]|=0", passed) call expect (abs(f_fv(c_one,vbar(-m,p,-1),vp)-m*vbar(-m,p,-1)), 0, "|vbar(-)[p-m]|=0", passed) @ <>= print *, "*** Spin Sums" test_psi%a = [one, two, three, four] test_spinor1 = f_vf (c_one, vp, test_psi) + m * test_psi test_spinor2 = u (m, p, +1) * (ubar (m, p, +1) * test_psi) + & u (m, p, -1) * (ubar (m, p, -1) * test_psi) do i = 1, 4 call expect (test_spinor1%a(i), test_spinor2%a(i), "(p+m)1=(sum u ubar)1", passed) end do test_spinor1 = f_vf (c_one, vp, test_psi) - m * test_psi test_spinor2 = v (m, p, +1) * (vbar (m, p, +1) * test_psi) + & v (m, p, -1) * (vbar (m, p, -1) * test_psi) do i = 1, 4 call expect (test_spinor1%a(i), test_spinor2%a(i), "(p-m)1=(sum v vbar)1", passed) end do test_psibar%a = [one, two, three, four] test_conjspinor1 = f_fv (c_one, test_psibar, vp) - m * test_psibar test_conjspinor2 = (test_psibar * v (m, p, +1)) * vbar (m, p, +1) + & (test_psibar * v (m, p, -1)) * vbar (m, p, -1) do i = 1, 4 call expect (test_conjspinor1%a(i), test_conjspinor2%a(i), "(p-m)1=(sum v vbar)1", passed) end do @ <>= print *, "*** Checking the normalization ***:" call expect (ubar(m,p,+1)*u(m,p,+1), +2*m, "ubar(+)*u(+)=+2m", passed) call expect (ubar(m,p,-1)*u(m,p,-1), +2*m, "ubar(-)*u(-)=+2m", passed) call expect (vbar(m,p,+1)*v(m,p,+1), -2*m, "vbar(+)*v(+)=-2m", passed) call expect (vbar(m,p,-1)*v(m,p,-1), -2*m, "vbar(-)*v(-)=-2m", passed) call expect (ubar(m,p,+1)*v(m,p,+1), 0, "ubar(+)*v(+)=0 ", passed) call expect (ubar(m,p,-1)*v(m,p,-1), 0, "ubar(-)*v(-)=0 ", passed) call expect (vbar(m,p,+1)*u(m,p,+1), 0, "vbar(+)*u(+)=0 ", passed) call expect (vbar(m,p,-1)*u(m,p,-1), 0, "vbar(-)*u(-)=0 ", passed) print *, "*** Checking the normalization for negative masses***:" call expect (ubar(-m,p,+1)*u(-m,p,+1), -2*m, "ubar(+)*u(+)=-2m", passed) call expect (ubar(-m,p,-1)*u(-m,p,-1), -2*m, "ubar(-)*u(-)=-2m", passed) call expect (vbar(-m,p,+1)*v(-m,p,+1), +2*m, "vbar(+)*v(+)=+2m", passed) call expect (vbar(-m,p,-1)*v(-m,p,-1), +2*m, "vbar(-)*v(-)=+2m", passed) call expect (ubar(-m,p,+1)*v(-m,p,+1), 0, "ubar(+)*v(+)=0 ", passed) call expect (ubar(-m,p,-1)*v(-m,p,-1), 0, "ubar(-)*v(-)=0 ", passed) call expect (vbar(-m,p,+1)*u(-m,p,+1), 0, "vbar(+)*u(+)=0 ", passed) call expect (vbar(-m,p,-1)*u(-m,p,-1), 0, "vbar(-)*u(-)=0 ", passed) @ <>= print *, "*** Checking the currents ***:" call expect (abs(v_ff(c_one,ubar(m,p,+1),u(m,p,+1))-2*vp), 0, "ubar(+).V.u(+)=2p", passed) call expect (abs(v_ff(c_one,ubar(m,p,-1),u(m,p,-1))-2*vp), 0, "ubar(-).V.u(-)=2p", passed) call expect (abs(v_ff(c_one,vbar(m,p,+1),v(m,p,+1))-2*vp), 0, "vbar(+).V.v(+)=2p", passed) call expect (abs(v_ff(c_one,vbar(m,p,-1),v(m,p,-1))-2*vp), 0, "vbar(-).V.v(-)=2p", passed) print *, "*** Checking the currents for negative masses***:" call expect (abs(v_ff(c_one,ubar(-m,p,+1),u(-m,p,+1))-2*vp), 0, "ubar(+).V.u(+)=2p", passed) call expect (abs(v_ff(c_one,ubar(-m,p,-1),u(-m,p,-1))-2*vp), 0, "ubar(-).V.u(-)=2p", passed) call expect (abs(v_ff(c_one,vbar(-m,p,+1),v(-m,p,+1))-2*vp), 0, "vbar(+).V.v(+)=2p", passed) call expect (abs(v_ff(c_one,vbar(-m,p,-1),v(-m,p,-1))-2*vp), 0, "vbar(-).V.v(-)=2p", passed) @ <>= print *, "*** Checking current conservation ***:" call expect ((vp-vq)*v_ff(c_one,ubar(m,p,+1),u(m,q,+1)), 0, "d(ubar(+).V.u(+))=0", passed) call expect ((vp-vq)*v_ff(c_one,ubar(m,p,-1),u(m,q,-1)), 0, "d(ubar(-).V.u(-))=0", passed) call expect ((vp-vq)*v_ff(c_one,vbar(m,p,+1),v(m,q,+1)), 0, "d(vbar(+).V.v(+))=0", passed) call expect ((vp-vq)*v_ff(c_one,vbar(m,p,-1),v(m,q,-1)), 0, "d(vbar(-).V.v(-))=0", passed) print *, "*** Checking current conservation for negative masses***:" call expect ((vp-vq)*v_ff(c_one,ubar(-m,p,+1),u(-m,q,+1)), 0, "d(ubar(+).V.u(+))=0", passed) call expect ((vp-vq)*v_ff(c_one,ubar(-m,p,-1),u(-m,q,-1)), 0, "d(ubar(-).V.u(-))=0", passed) call expect ((vp-vq)*v_ff(c_one,vbar(-m,p,+1),v(-m,q,+1)), 0, "d(vbar(+).V.v(+))=0", passed) call expect ((vp-vq)*v_ff(c_one,vbar(-m,p,-1),v(-m,q,-1)), 0, "d(vbar(-).V.v(-))=0", passed) @ <>= if (m == 0) then print *, "*** Checking axial current conservation ***:" call expect ((vp-vq)*a_ff(c_one,ubar(m,p,+1),u(m,q,+1)), 0, "d(ubar(+).A.u(+))=0", passed) call expect ((vp-vq)*a_ff(c_one,ubar(m,p,-1),u(m,q,-1)), 0, "d(ubar(-).A.u(-))=0", passed) call expect ((vp-vq)*a_ff(c_one,vbar(m,p,+1),v(m,q,+1)), 0, "d(vbar(+).A.v(+))=0", passed) call expect ((vp-vq)*a_ff(c_one,vbar(m,p,-1),v(m,q,-1)), 0, "d(vbar(-).A.v(-))=0", passed) end if @ <>= print *, "*** Checking implementation of the sigma vertex funktions ***:" call expect ((vp*tvam_ff(c_one,c_nil,ubar(m,p,+1),u(m,q,+1),q) - (p*q-m**2)*(ubar(m,p,+1)*u(m,q,+1))), 0, & "p*[ubar(p,+).(Isigma*q).u(q,+)] - (p*q-m^2)*ubar(p,+).u(q,+) = 0", passed) call expect ((vp*tvam_ff(c_one,c_nil,ubar(m,p,-1),u(m,q,-1),q) - (p*q-m**2)*(ubar(m,p,-1)*u(m,q,-1))), 0, & "p*[ubar(p,-).(Isigma*q).u(q,-)] - (p*q-m^2)*ubar(p,-).u(q,-) = 0", passed) call expect ((vp*tvam_ff(c_one,c_nil,vbar(m,p,+1),v(m,q,+1),q) - (p*q-m**2)*(vbar(m,p,+1)*v(m,q,+1))), 0, & "p*[vbar(p,+).(Isigma*q).v(q,+)] - (p*q-m^2)*vbar(p,+).v(q,+) = 0", passed) call expect ((vp*tvam_ff(c_one,c_nil,vbar(m,p,-1),v(m,q,-1),q) - (p*q-m**2)*(vbar(m,p,-1)*v(m,q,-1))), 0, & "p*[vbar(p,-).(Isigma*q).v(q,-)] - (p*q-m^2)*vbar(p,-).v(q,-) = 0", passed) call expect ((ubar(m,p,+1)*f_tvamf(c_one,c_nil,vp,u(m,q,+1),q) - (p*q-m**2)*(ubar(m,p,+1)*u(m,q,+1))), 0, & "ubar(p,+).[p*(Isigma*q).u(q,+)] - (p*q-m^2)*ubar(p,+).u(q,+) = 0", passed) call expect ((ubar(m,p,-1)*f_tvamf(c_one,c_nil,vp,u(m,q,-1),q) - (p*q-m**2)*(ubar(m,p,-1)*u(m,q,-1))), 0, & "ubar(p,-).[p*(Isigma*q).u(q,-)] - (p*q-m^2)*ubar(p,-).u(q,-) = 0", passed) call expect ((vbar(m,p,+1)*f_tvamf(c_one,c_nil,vp,v(m,q,+1),q) - (p*q-m**2)*(vbar(m,p,+1)*v(m,q,+1))), 0, & "vbar(p,+).[p*(Isigma*q).v(q,+)] - (p*q-m^2)*vbar(p,+).v(q,+) = 0", passed) call expect ((vbar(m,p,-1)*f_tvamf(c_one,c_nil,vp,v(m,q,-1),q) - (p*q-m**2)*(vbar(m,p,-1)*v(m,q,-1))), 0, & "vbar(p,-).[p*(Isigma*q).v(q,-)] - (p*q-m^2)*vbar(p,-).v(q,-) = 0", passed) call expect ((f_ftvam(c_one,c_nil,ubar(m,p,+1),vp,q)*u(m,q,+1) - (p*q-m**2)*(ubar(m,p,+1)*u(m,q,+1))), 0, & "[ubar(p,+).p*(Isigma*q)].u(q,+) - (p*q-m^2)*ubar(p,+).u(q,+) = 0", passed) call expect ((f_ftvam(c_one,c_nil,ubar(m,p,-1),vp,q)*u(m,q,-1) - (p*q-m**2)*(ubar(m,p,-1)*u(m,q,-1))), 0, & "[ubar(p,-).p*(Isigma*q)].u(q,-) - (p*q-m^2)*ubar(p,-).u(q,-) = 0", passed) call expect ((f_ftvam(c_one,c_nil,vbar(m,p,+1),vp,q)*v(m,q,+1) - (p*q-m**2)*(vbar(m,p,+1)*v(m,q,+1))), 0, & "[vbar(p,+).p*(Isigma*q)].v(q,+) - (p*q-m^2)*vbar(p,+).v(q,+) = 0", passed) call expect ((f_ftvam(c_one,c_nil,vbar(m,p,-1),vp,q)*v(m,q,-1) - (p*q-m**2)*(vbar(m,p,-1)*v(m,q,-1))), 0, & "[vbar(p,-).p*(Isigma*q)].v(q,-) - (p*q-m^2)*vbar(p,-).v(q,-) = 0", passed) call expect ((vp*tvam_ff(c_nil,c_one,ubar(m,p,+1),u(m,q,+1),q) - (p*q+m**2)*p_ff(c_one,ubar(m,p,+1),u(m,q,+1))), 0, & "p*[ubar(p,+).(Isigma*q).g5.u(q,+)] - (p*q+m^2)*ubar(p,+).g5.u(q,+) = 0", passed) call expect ((vp*tvam_ff(c_nil,c_one,ubar(m,p,-1),u(m,q,-1),q) - (p*q+m**2)*p_ff(c_one,ubar(m,p,-1),u(m,q,-1))), 0, & "p*[ubar(p,-).(Isigma*q).g5.u(q,-)] - (p*q+m^2)*ubar(p,-).g5.u(q,-) = 0", passed) call expect ((vp*tvam_ff(c_nil,c_one,vbar(m,p,+1),v(m,q,+1),q) - (p*q+m**2)*p_ff(c_one,vbar(m,p,+1),v(m,q,+1))), 0, & "p*[vbar(p,+).(Isigma*q).g5.v(q,+)] - (p*q+m^2)*vbar(p,+).g5.v(q,+) = 0", passed) call expect ((vp*tvam_ff(c_nil,c_one,vbar(m,p,-1),v(m,q,-1),q) - (p*q+m**2)*p_ff(c_one,vbar(m,p,-1),v(m,q,-1))), 0, & "p*[vbar(p,-).(Isigma*q).g5.v(q,-)] - (p*q+m^2)*vbar(p,-).g5.v(q,-) = 0", passed) call expect ((ubar(m,p,+1)*f_tvamf(c_nil,c_one,vp,u(m,q,+1),q) - (p*q+m**2)*p_ff(c_one,ubar(m,p,+1),u(m,q,+1))), 0, & "p*[ubar(p,+).(Isigma*q).g5.u(q,+)] - (p*q+m^2)*ubar(p,+).g5.u(q,+) = 0", passed) call expect ((ubar(m,p,-1)*f_tvamf(c_nil,c_one,vp,u(m,q,-1),q) - (p*q+m**2)*p_ff(c_one,ubar(m,p,-1),u(m,q,-1))), 0, & "p*[ubar(p,-).(Isigma*q).g5.u(q,-)] - (p*q+m^2)*ubar(p,-).g5.u(q,-) = 0", passed) call expect ((vbar(m,p,+1)*f_tvamf(c_nil,c_one,vp,v(m,q,+1),q) - (p*q+m**2)*p_ff(c_one,vbar(m,p,+1),v(m,q,+1))), 0, & "p*[vbar(p,+).(Isigma*q).g5.v(q,+)] - (p*q+m^2)*vbar(p,+).g5.v(q,+) = 0", passed) call expect ((vbar(m,p,-1)*f_tvamf(c_nil,c_one,vp,v(m,q,-1),q) - (p*q+m**2)*p_ff(c_one,vbar(m,p,-1),v(m,q,-1))), 0, & "p*[vbar(p,-).(Isigma*q).g5.v(q,-)] - (p*q+m^2)*vbar(p,-).g5.v(q,-) = 0", passed) call expect ((f_ftvam(c_nil,c_one,ubar(m,p,+1),vp,q)*u(m,q,+1) - (p*q+m**2)*p_ff(c_one,ubar(m,p,+1),u(m,q,+1))), 0, & "p*[ubar(p,+).(Isigma*q).g5.u(q,+)] - (p*q+m^2)*ubar(p,+).g5.u(q,+) = 0", passed) call expect ((f_ftvam(c_nil,c_one,ubar(m,p,-1),vp,q)*u(m,q,-1) - (p*q+m**2)*p_ff(c_one,ubar(m,p,-1),u(m,q,-1))), 0, & "p*[ubar(p,-).(Isigma*q).g5.u(q,-)] - (p*q+m^2)*ubar(p,-).g5.u(q,-) = 0", passed) call expect ((f_ftvam(c_nil,c_one,vbar(m,p,+1),vp,q)*v(m,q,+1) - (p*q+m**2)*p_ff(c_one,vbar(m,p,+1),v(m,q,+1))), 0, & "p*[vbar(p,+).(Isigma*q).g5.v(q,+)] - (p*q+m^2)*vbar(p,+).g5.v(q,+) = 0", passed) call expect ((f_ftvam(c_nil,c_one,vbar(m,p,-1),vp,q)*v(m,q,-1) - (p*q+m**2)*p_ff(c_one,vbar(m,p,-1),v(m,q,-1))), 0, & "p*[vbar(p,-).(Isigma*q).g5.v(q,-)] - (p*q+m^2)*vbar(p,-).g5.v(q,-) = 0", passed) @ <>= print *, "*** Checking polarisation vectors: ***" call expect (conjg(eps(m,p, 1))*eps(m,p, 1), -1, "e( 1).e( 1)=-1", passed) call expect (conjg(eps(m,p, 1))*eps(m,p,-1), 0, "e( 1).e(-1)= 0", passed) call expect (conjg(eps(m,p,-1))*eps(m,p, 1), 0, "e(-1).e( 1)= 0", passed) call expect (conjg(eps(m,p,-1))*eps(m,p,-1), -1, "e(-1).e(-1)=-1", passed) call expect ( p*eps(m,p, 1), 0, " p.e( 1)= 0", passed) call expect ( p*eps(m,p,-1), 0, " p.e(-1)= 0", passed) if (m > 0) then call expect (conjg(eps(m,p, 1))*eps(m,p, 0), 0, "e( 1).e( 0)= 0", passed) call expect (conjg(eps(m,p, 0))*eps(m,p, 1), 0, "e( 0).e( 1)= 0", passed) call expect (conjg(eps(m,p, 0))*eps(m,p, 0), -1, "e( 0).e( 0)=-1", passed) call expect (conjg(eps(m,p, 0))*eps(m,p,-1), 0, "e( 0).e(-1)= 0", passed) call expect (conjg(eps(m,p,-1))*eps(m,p, 0), 0, "e(-1).e( 0)= 0", passed) call expect ( p*eps(m,p, 0), 0, " p.e( 0)= 0", passed) end if @ <>= print *, "*** Checking epsilon tensor: ***" call expect ( pseudo_scalar(eps(m,p,1),eps(m,q,1),eps(m,p,0),eps(m,q,0)), & - pseudo_scalar(eps(m,q,1),eps(m,p,1),eps(m,p,0),eps(m,q,0)), "eps(1<->2)", passed) call expect ( pseudo_scalar(eps(m,p,1),eps(m,q,1),eps(m,p,0),eps(m,q,0)), & - pseudo_scalar(eps(m,p,0),eps(m,q,1),eps(m,p,1),eps(m,q,0)), "eps(1<->3)", passed) call expect ( pseudo_scalar(eps(m,p,1),eps(m,q,1),eps(m,p,0),eps(m,q,0)), & - pseudo_scalar(eps(m,q,0),eps(m,q,1),eps(m,p,0),eps(m,p,1)), "eps(1<->4)", passed) call expect ( pseudo_scalar(eps(m,p,1),eps(m,q,1),eps(m,p,0),eps(m,q,0)), & - pseudo_scalar(eps(m,p,1),eps(m,p,0),eps(m,q,1),eps(m,q,0)), "eps(2<->3)", passed) call expect ( pseudo_scalar(eps(m,p,1),eps(m,q,1),eps(m,p,0),eps(m,q,0)), & - pseudo_scalar(eps(m,p,1),eps(m,q,0),eps(m,p,0),eps(m,q,1)), "eps(2<->4)", passed) call expect ( pseudo_scalar(eps(m,p,1),eps(m,q,1),eps(m,p,0),eps(m,q,0)), & - pseudo_scalar(eps(m,p,1),eps(m,q,1),eps(m,q,0),eps(m,p,0)), "eps(3<->4)", passed) call expect ( pseudo_scalar(eps(m,p,1),eps(m,q,1),eps(m,p,0),eps(m,q,0)), & eps(m,p,1)*pseudo_vector(eps(m,q,1),eps(m,p,0),eps(m,q,0)), "eps'", passed) @ \begin{equation} \frac{1}{2} [x\wedge y]^*_{\mu\nu} [x\wedge y]^{\mu\nu} = \frac{1}{2} (x^*_\mu y^*_\nu-x^*_\nu y^*_\mu) (x^\mu y^\nu-x^\nu y^\mu) = (x^*x) (y^*y) - (x^*y) (y^*x) \end{equation} <>= print *, "*** Checking tensors: ***" call expect (conjg(p.wedge.q)*(p.wedge.q), (p*p)*(q*q)-(p*q)**2, & "[p,q].[q,p]=p.p*q.q-p.q^2", passed) call expect (conjg(p.wedge.q)*(q.wedge.p), (p*q)**2-(p*p)*(q*q), & "[p,q].[q,p]=p.q^2-p.p*q.q", passed) @ i.\,e. \begin{equation} \frac{1}{2} [p\wedge\epsilon(p,i)]^*_{\mu\nu} [p\wedge\epsilon(p,j)]^{\mu\nu} = - p^2 \delta_{ij} \end{equation} <>= call expect (conjg(p.wedge.eps(m,p, 1))*(p.wedge.eps(m,p, 1)), -p*p, & "[p,e( 1)].[p,e( 1)]=-p.p", passed) call expect (conjg(p.wedge.eps(m,p, 1))*(p.wedge.eps(m,p,-1)), 0, & "[p,e( 1)].[p,e(-1)]=0", passed) call expect (conjg(p.wedge.eps(m,p,-1))*(p.wedge.eps(m,p, 1)), 0, & "[p,e(-1)].[p,e( 1)]=0", passed) call expect (conjg(p.wedge.eps(m,p,-1))*(p.wedge.eps(m,p,-1)), -p*p, & "[p,e(-1)].[p,e(-1)]=-p.p", passed) if (m > 0) then call expect (conjg(p.wedge.eps(m,p, 1))*(p.wedge.eps(m,p, 0)), 0, & "[p,e( 1)].[p,e( 0)]=0", passed) call expect (conjg(p.wedge.eps(m,p, 0))*(p.wedge.eps(m,p, 1)), 0, & "[p,e( 0)].[p,e( 1)]=0", passed) call expect (conjg(p.wedge.eps(m,p, 0))*(p.wedge.eps(m,p, 0)), -p*p, & "[p,e( 0)].[p,e( 0)]=-p.p", passed) call expect (conjg(p.wedge.eps(m,p, 0))*(p.wedge.eps(m,p,-1)), 0, & "[p,e( 1)].[p,e(-1)]=0", passed) call expect (conjg(p.wedge.eps(m,p,-1))*(p.wedge.eps(m,p, 0)), 0, & "[p,e(-1)].[p,e( 0)]=0", passed) end if @ also \begin{align} [x\wedge y]_{\mu\nu} z^\nu &= x_\mu (yz) - y_\mu (xz) \\ z_\mu [x\wedge y]^{\mu\nu} &= (zx) y^\nu - (zy) x^\nu \end{align} <>= call expect (abs ((p.wedge.eps(m,p, 1))*p + (p*p)*eps(m,p, 1)), 0, & "[p,e( 1)].p=-p.p*e( 1)]", passed) call expect (abs ((p.wedge.eps(m,p, 0))*p + (p*p)*eps(m,p, 0)), 0, & "[p,e( 0)].p=-p.p*e( 0)]", passed) call expect (abs ((p.wedge.eps(m,p,-1))*p + (p*p)*eps(m,p,-1)), 0, & "[p,e(-1)].p=-p.p*e(-1)]", passed) call expect (abs (p*(p.wedge.eps(m,p, 1)) - (p*p)*eps(m,p, 1)), 0, & "p.[p,e( 1)]=p.p*e( 1)]", passed) call expect (abs (p*(p.wedge.eps(m,p, 0)) - (p*p)*eps(m,p, 0)), 0, & "p.[p,e( 0)]=p.p*e( 0)]", passed) call expect (abs (p*(p.wedge.eps(m,p,-1)) - (p*p)*eps(m,p,-1)), 0, & "p.[p,e(-1)]=p.p*e(-1)]", passed) @ <>= print *, "*** Checking polarisation tensors: ***" call expect (conjg(eps2(m,p, 2))*eps2(m,p, 2), 1, "e2( 2).e2( 2)=1", passed) call expect (conjg(eps2(m,p, 2))*eps2(m,p,-2), 0, "e2( 2).e2(-2)=0", passed) call expect (conjg(eps2(m,p,-2))*eps2(m,p, 2), 0, "e2(-2).e2( 2)=0", passed) call expect (conjg(eps2(m,p,-2))*eps2(m,p,-2), 1, "e2(-2).e2(-2)=1", passed) if (m > 0) then call expect (conjg(eps2(m,p, 2))*eps2(m,p, 1), 0, "e2( 2).e2( 1)=0", passed) call expect (conjg(eps2(m,p, 2))*eps2(m,p, 0), 0, "e2( 2).e2( 0)=0", passed) call expect (conjg(eps2(m,p, 2))*eps2(m,p,-1), 0, "e2( 2).e2(-1)=0", passed) call expect (conjg(eps2(m,p, 1))*eps2(m,p, 2), 0, "e2( 1).e2( 2)=0", passed) call expect (conjg(eps2(m,p, 1))*eps2(m,p, 1), 1, "e2( 1).e2( 1)=1", passed) call expect (conjg(eps2(m,p, 1))*eps2(m,p, 0), 0, "e2( 1).e2( 0)=0", passed) call expect (conjg(eps2(m,p, 1))*eps2(m,p,-1), 0, "e2( 1).e2(-1)=0", passed) call expect (conjg(eps2(m,p, 1))*eps2(m,p,-2), 0, "e2( 1).e2(-2)=0", passed) call expect (conjg(eps2(m,p, 0))*eps2(m,p, 2), 0, "e2( 0).e2( 2)=0", passed) call expect (conjg(eps2(m,p, 0))*eps2(m,p, 1), 0, "e2( 0).e2( 1)=0", passed) call expect (conjg(eps2(m,p, 0))*eps2(m,p, 0), 1, "e2( 0).e2( 0)=1", passed) call expect (conjg(eps2(m,p, 0))*eps2(m,p,-1), 0, "e2( 0).e2(-1)=0", passed) call expect (conjg(eps2(m,p, 0))*eps2(m,p,-2), 0, "e2( 0).e2(-2)=0", passed) call expect (conjg(eps2(m,p,-1))*eps2(m,p, 2), 0, "e2(-1).e2( 2)=0", passed) call expect (conjg(eps2(m,p,-1))*eps2(m,p, 1), 0, "e2(-1).e2( 1)=0", passed) call expect (conjg(eps2(m,p,-1))*eps2(m,p, 0), 0, "e2(-1).e2( 0)=0", passed) call expect (conjg(eps2(m,p,-1))*eps2(m,p,-1), 1, "e2(-1).e2(-1)=1", passed) call expect (conjg(eps2(m,p,-1))*eps2(m,p,-2), 0, "e2(-1).e2(-2)=0", passed) call expect (conjg(eps2(m,p,-2))*eps2(m,p, 1), 0, "e2(-2).e2( 1)=0", passed) call expect (conjg(eps2(m,p,-2))*eps2(m,p, 0), 0, "e2(-2).e2( 0)=0", passed) call expect (conjg(eps2(m,p,-2))*eps2(m,p,-1), 0, "e2(-2).e2(-1)=0", passed) end if @ <>= call expect ( abs(p*eps2(m,p, 2) ), 0, " |p.e2( 2)| =0", passed) call expect ( abs(eps2(m,p, 2)*p), 0, " |e2( 2).p|=0", passed) call expect ( abs(p*eps2(m,p,-2) ), 0, " |p.e2(-2)| =0", passed) call expect ( abs(eps2(m,p,-2)*p), 0, " |e2(-2).p|=0", passed) if (m > 0) then call expect ( abs(p*eps2(m,p, 1) ), 0, " |p.e2( 1)| =0", passed) call expect ( abs(eps2(m,p, 1)*p), 0, " |e2( 1).p|=0", passed) call expect ( abs(p*eps2(m,p, 0) ), 0, " |p.e2( 0)| =0", passed) call expect ( abs(eps2(m,p, 0)*p), 0, " |e2( 0).p|=0", passed) call expect ( abs(p*eps2(m,p,-1) ), 0, " |p.e2(-1)| =0", passed) call expect ( abs(eps2(m,p,-1)*p), 0, " |e2(-1).p|=0", passed) end if @ <>= print *, " *** Checking the polarization tensors for massive gravitons:" call expect (abs(p * eps2(m,p,2)), 0, "p.e(+2)=0", passed) call expect (abs(p * eps2(m,p,1)), 0, "p.e(+1)=0", passed) call expect (abs(p * eps2(m,p,0)), 0, "p.e( 0)=0", passed) call expect (abs(p * eps2(m,p,-1)), 0, "p.e(-1)=0", passed) call expect (abs(p * eps2(m,p,-2)), 0, "p.e(-2)=0", passed) call expect (abs(trace(eps2 (m,p,2))), 0, "Tr[e(+2)]=0", passed) call expect (abs(trace(eps2 (m,p,1))), 0, "Tr[e(+1)]=0", passed) call expect (abs(trace(eps2 (m,p,0))), 0, "Tr[e( 0)]=0", passed) call expect (abs(trace(eps2 (m,p,-1))), 0, "Tr[e(-1)]=0", passed) call expect (abs(trace(eps2 (m,p,-2))), 0, "Tr[e(-2)]=0", passed) call expect (abs(eps2(m,p,2) * eps2(m,p,2)), 1, & "e(2).e(2) = 1", passed) call expect (abs(eps2(m,p,2) * eps2(m,p,1)), 0, & "e(2).e(1) = 0", passed) call expect (abs(eps2(m,p,2) * eps2(m,p,0)), 0, & "e(2).e(0) = 0", passed) call expect (abs(eps2(m,p,2) * eps2(m,p,-1)), 0, & "e(2).e(-1) = 0", passed) call expect (abs(eps2(m,p,2) * eps2(m,p,-2)), 0, & "e(2).e(-2) = 0", passed) call expect (abs(eps2(m,p,1) * eps2(m,p,1)), 1, & "e(1).e(1) = 1", passed) call expect (abs(eps2(m,p,1) * eps2(m,p,0)), 0, & "e(1).e(0) = 0", passed) call expect (abs(eps2(m,p,1) * eps2(m,p,-1)), 0, & "e(1).e(-1) = 0", passed) call expect (abs(eps2(m,p,1) * eps2(m,p,-2)), 0, & "e(1).e(-2) = 0", passed) call expect (abs(eps2(m,p,0) * eps2(m,p,0)), 1, & "e(0).e(0) = 1", passed) call expect (abs(eps2(m,p,0) * eps2(m,p,-1)), 0, & "e(0).e(-1) = 0", passed) call expect (abs(eps2(m,p,0) * eps2(m,p,-2)), 0, & "e(0).e(-2) = 0", passed) call expect (abs(eps2(m,p,-1) * eps2(m,p,-1)), 1, & "e(-1).e(-1) = 1", passed) call expect (abs(eps2(m,p,-1) * eps2(m,p,-2)), 0, & "e(-1).e(-2) = 0", passed) call expect (abs(eps2(m,p,-2) * eps2(m,p,-2)), 1, & "e(-2).e(-2) = 1", passed) @ <>= print *, " *** Checking the graviton propagator:" call expect (abs(p * (cmplx (p*p - m**2, m*w, kind=default) * & pr_tensor(p,m,w,eps2(m,p,-2)))), 0, "p.pr.e(-2)", passed) call expect (abs(p * (cmplx (p*p - m**2, m*w, kind=default) * & pr_tensor(p,m,w,eps2(m,p,-1)))), 0, "p.pr.e(-1)", passed) call expect (abs(p * (cmplx (p*p - m**2, m*w, kind=default) * & pr_tensor(p,m,w,eps2(m,p,0)))), 0, "p.pr.e(0)", passed) call expect (abs(p * (cmplx (p*p - m**2, m*w, kind=default) * & pr_tensor(p,m,w,eps2(m,p,1)))), 0, "p.pr.e(1)", passed) call expect (abs(p * (cmplx (p*p - m**2, m*w, kind=default) * & pr_tensor(p,m,w,eps2(m,p,2)))), 0, "p.pr.e(2)", passed) call expect (abs(p * (cmplx (p*p - m**2, m*w, kind=default) * & pr_tensor(p,m,w,ttest))), 0, "p.pr.ttest", passed) @ <<[[test_omega95_bispinors.f90]]>>= <> program test_omega95_bispinors use kinds use omega95_bispinors use omega_vspinor_polarizations use omega_testtools implicit none integer :: i, j real(kind=default) :: m, pabs, qabs, tabs, zabs, w real(kind=default), dimension(4) :: r complex(kind=default) :: c_nil, c_one, c_two type(momentum) :: p, q, t, z, p_0 type(vector) :: vp, vq, vt, vz type(vectorspinor) :: testv type(bispinor) :: vv logical :: passed call random_seed () c_nil = 0.0_default c_one = 1.0_default c_two = 2.0_default w = 1.4142 m = 13 pabs = 42 qabs = 137 tabs = 84 zabs = 3.1415 p_0%t = m p_0%x = 0 call random_momentum (p, pabs, m) call random_momentum (q, qabs, m) call random_momentum (t, tabs, m) call random_momentum (z, zabs, m) call random_number (r) do i = 1, 4 testv%psi(1)%a(i) = (0.0_default, 0.0_default) end do do i = 2, 3 do j = 1, 4 testv%psi(i)%a(j) = cmplx (10.0_default * r(j), kind=default) end do end do testv%psi(4)%a(1) = (1.0_default, 0.0_default) testv%psi(4)%a(2) = (0.0_default, 2.0_default) testv%psi(4)%a(3) = (1.0_default, 0.0_default) testv%psi(4)%a(4) = (3.0_default, 0.0_default) vp = p vq = q vt = t vz = z passed = .true. vv%a(1) = (1.0_default, 0.0_default) vv%a(2) = (0.0_default, 2.0_default) vv%a(3) = (1.0_default, 0.0_default) vv%a(4) = (3.0_default, 0.0_default) vv = pr_psi(p, m, w, .false., vv) <> if (.not. passed) then stop 1 end if end program test_omega95_bispinors @ <>= print *, "*** Checking the equations of motion ***:" call expect (abs(f_vf(c_one,vp,u(m,p,+1))-m*u(m,p,+1)), 0, "|[p-m]u(+)|=0", passed) call expect (abs(f_vf(c_one,vp,u(m,p,-1))-m*u(m,p,-1)), 0, "|[p-m]u(-)|=0", passed) call expect (abs(f_vf(c_one,vp,v(m,p,+1))+m*v(m,p,+1)), 0, "|[p+m]v(+)|=0", passed) call expect (abs(f_vf(c_one,vp,v(m,p,-1))+m*v(m,p,-1)), 0, "|[p+m]v(-)|=0", passed) print *, "*** Checking the equations of motion for negative masses***:" call expect (abs(f_vf(c_one,vp,u(-m,p,+1))+m*u(-m,p,+1)), 0, "|[p+m]u(+)|=0", passed) call expect (abs(f_vf(c_one,vp,u(-m,p,-1))+m*u(-m,p,-1)), 0, "|[p+m]u(-)|=0", passed) call expect (abs(f_vf(c_one,vp,v(-m,p,+1))-m*v(-m,p,+1)), 0, "|[p-m]v(+)|=0", passed) call expect (abs(f_vf(c_one,vp,v(-m,p,-1))-m*v(-m,p,-1)), 0, "|[p-m]v(-)|=0", passed) @ <>= print *, "*** Checking the normalization ***:" call expect (s_ff(c_one,v(m,p,+1),u(m,p,+1)), +2*m, "ubar(+)*u(+)=+2m", passed) call expect (s_ff(c_one,v(m,p,-1),u(m,p,-1)), +2*m, "ubar(-)*u(-)=+2m", passed) call expect (s_ff(c_one,u(m,p,+1),v(m,p,+1)), -2*m, "vbar(+)*v(+)=-2m", passed) call expect (s_ff(c_one,u(m,p,-1),v(m,p,-1)), -2*m, "vbar(-)*v(-)=-2m", passed) call expect (s_ff(c_one,v(m,p,+1),v(m,p,+1)), 0, "ubar(+)*v(+)=0 ", passed) call expect (s_ff(c_one,v(m,p,-1),v(m,p,-1)), 0, "ubar(-)*v(-)=0 ", passed) call expect (s_ff(c_one,u(m,p,+1),u(m,p,+1)), 0, "vbar(+)*u(+)=0 ", passed) call expect (s_ff(c_one,u(m,p,-1),u(m,p,-1)), 0, "vbar(-)*u(-)=0 ", passed) print *, "*** Checking the normalization for negative masses***:" call expect (s_ff(c_one,v(-m,p,+1),u(-m,p,+1)), -2*m, "ubar(+)*u(+)=-2m", passed) call expect (s_ff(c_one,v(-m,p,-1),u(-m,p,-1)), -2*m, "ubar(-)*u(-)=-2m", passed) call expect (s_ff(c_one,u(-m,p,+1),v(-m,p,+1)), +2*m, "vbar(+)*v(+)=+2m", passed) call expect (s_ff(c_one,u(-m,p,-1),v(-m,p,-1)), +2*m, "vbar(-)*v(-)=+2m", passed) call expect (s_ff(c_one,v(-m,p,+1),v(-m,p,+1)), 0, "ubar(+)*v(+)=0 ", passed) call expect (s_ff(c_one,v(-m,p,-1),v(-m,p,-1)), 0, "ubar(-)*v(-)=0 ", passed) call expect (s_ff(c_one,u(-m,p,+1),u(-m,p,+1)), 0, "vbar(+)*u(+)=0 ", passed) call expect (s_ff(c_one,u(-m,p,-1),u(-m,p,-1)), 0, "vbar(-)*u(-)=0 ", passed) @ <>= print *, "*** Checking the currents ***:" call expect (abs(v_ff(c_one,v(m,p,+1),u(m,p,+1))-2*vp), 0, "ubar(+).V.u(+)=2p", passed) call expect (abs(v_ff(c_one,v(m,p,-1),u(m,p,-1))-2*vp), 0, "ubar(-).V.u(-)=2p", passed) call expect (abs(v_ff(c_one,u(m,p,+1),v(m,p,+1))-2*vp), 0, "vbar(+).V.v(+)=2p", passed) call expect (abs(v_ff(c_one,u(m,p,-1),v(m,p,-1))-2*vp), 0, "vbar(-).V.v(-)=2p", passed) print *, "*** Checking the currents for negative masses***:" call expect (abs(v_ff(c_one,v(-m,p,+1),u(-m,p,+1))-2*vp), 0, "ubar(+).V.u(+)=2p", passed) call expect (abs(v_ff(c_one,v(-m,p,-1),u(-m,p,-1))-2*vp), 0, "ubar(-).V.u(-)=2p", passed) call expect (abs(v_ff(c_one,u(-m,p,+1),v(-m,p,+1))-2*vp), 0, "vbar(+).V.v(+)=2p", passed) call expect (abs(v_ff(c_one,u(-m,p,-1),v(-m,p,-1))-2*vp), 0, "vbar(-).V.v(-)=2p", passed) @ <>= print *, "*** Checking current conservation ***:" call expect ((vp-vq)*v_ff(c_one,v(m,p,+1),u(m,q,+1)), 0, "d(ubar(+).V.u(+))=0", passed) call expect ((vp-vq)*v_ff(c_one,v(m,p,-1),u(m,q,-1)), 0, "d(ubar(-).V.u(-))=0", passed) call expect ((vp-vq)*v_ff(c_one,u(m,p,+1),v(m,q,+1)), 0, "d(vbar(+).V.v(+))=0", passed) call expect ((vp-vq)*v_ff(c_one,u(m,p,-1),v(m,q,-1)), 0, "d(vbar(-).V.v(-))=0", passed) <>= print *, "*** Checking current conservation for negative masses***:" call expect ((vp-vq)*v_ff(c_one,v(-m,p,+1),u(-m,q,+1)), 0, "d(ubar(+).V.u(+))=0", passed) call expect ((vp-vq)*v_ff(c_one,v(-m,p,-1),u(-m,q,-1)), 0, "d(ubar(-).V.u(-))=0", passed) call expect ((vp-vq)*v_ff(c_one,u(-m,p,+1),v(-m,q,+1)), 0, "d(vbar(+).V.v(+))=0", passed) call expect ((vp-vq)*v_ff(c_one,u(-m,p,-1),v(-m,q,-1)), 0, "d(vbar(-).V.v(-))=0", passed) @ <>= if (m == 0) then print *, "*** Checking axial current conservation ***:" call expect ((vp-vq)*a_ff(c_one,v(m,p,+1),u(m,q,+1)), 0, "d(ubar(+).A.u(+))=0", passed) call expect ((vp-vq)*a_ff(c_one,v(m,p,-1),u(m,q,-1)), 0, "d(ubar(-).A.u(-))=0", passed) call expect ((vp-vq)*a_ff(c_one,u(m,p,+1),v(m,q,+1)), 0, "d(vbar(+).A.v(+))=0", passed) call expect ((vp-vq)*a_ff(c_one,u(m,p,-1),v(m,q,-1)), 0, "d(vbar(-).A.v(-))=0", passed) end if <>= print *, "*** Checking implementation of the sigma vertex funktions ***:" call expect ((vp*tvam_ff(c_one,c_nil,v(m,p,+1),u(m,q,+1),q) - (p*q-m**2)*(v(m,p,+1)*u(m,q,+1))), 0, & "p*[ubar(p,+).(Isigma*q).u(q,+)] - (p*q-m^2)*ubar(p,+).u(q,+) = 0", passed) call expect ((vp*tvam_ff(c_one,c_nil,v(m,p,-1),u(m,q,-1),q) - (p*q-m**2)*(v(m,p,-1)*u(m,q,-1))), 0, & "p*[ubar(p,-).(Isigma*q).u(q,-)] - (p*q-m^2)*ubar(p,-).u(q,-) = 0", passed) call expect ((vp*tvam_ff(c_one,c_nil,u(m,p,+1),v(m,q,+1),q) - (p*q-m**2)*(u(m,p,+1)*v(m,q,+1))), 0, & "p*[vbar(p,+).(Isigma*q).v(q,+)] - (p*q-m^2)*vbar(p,+).v(q,+) = 0", passed) call expect ((vp*tvam_ff(c_one,c_nil,u(m,p,-1),v(m,q,-1),q) - (p*q-m**2)*(u(m,p,-1)*v(m,q,-1))), 0, & "p*[vbar(p,-).(Isigma*q).v(q,-)] - (p*q-m^2)*vbar(p,-).v(q,-) = 0", passed) call expect ((v(m,p,+1)*f_tvamf(c_one,c_nil,vp,u(m,q,+1),q) - (p*q-m**2)*(v(m,p,+1)*u(m,q,+1))), 0, & "ubar(p,+).[p*(Isigma*q).u(q,+)] - (p*q-m^2)*ubar(p,+).u(q,+) = 0", passed) call expect ((v(m,p,-1)*f_tvamf(c_one,c_nil,vp,u(m,q,-1),q) - (p*q-m**2)*(v(m,p,-1)*u(m,q,-1))), 0, & "ubar(p,-).[p*(Isigma*q).u(q,-)] - (p*q-m^2)*ubar(p,-).u(q,-) = 0", passed) call expect ((u(m,p,+1)*f_tvamf(c_one,c_nil,vp,v(m,q,+1),q) - (p*q-m**2)*(u(m,p,+1)*v(m,q,+1))), 0, & "vbar(p,+).[p*(Isigma*q).v(q,+)] - (p*q-m^2)*vbar(p,+).v(q,+) = 0", passed) call expect ((u(m,p,-1)*f_tvamf(c_one,c_nil,vp,v(m,q,-1),q) - (p*q-m**2)*(u(m,p,-1)*v(m,q,-1))), 0, & "vbar(p,-).[p*(Isigma*q).v(q,-)] - (p*q-m^2)*vbar(p,-).v(q,-) = 0", passed) call expect ((vp*tvam_ff(c_nil,c_one,v(m,p,+1),u(m,q,+1),q) - (p*q+m**2)*p_ff(c_one,v(m,p,+1),u(m,q,+1))), 0, & "p*[ubar(p,+).(Isigma*q).g5.u(q,+)] - (p*q+m^2)*ubar(p,+).g5.u(q,+) = 0", passed) call expect ((vp*tvam_ff(c_nil,c_one,v(m,p,-1),u(m,q,-1),q) - (p*q+m**2)*p_ff(c_one,v(m,p,-1),u(m,q,-1))), 0, & "p*[ubar(p,-).(Isigma*q).g5.u(q,-)] - (p*q+m^2)*ubar(p,-).g5.u(q,-) = 0", passed) call expect ((vp*tvam_ff(c_nil,c_one,u(m,p,+1),v(m,q,+1),q) - (p*q+m**2)*p_ff(c_one,u(m,p,+1),v(m,q,+1))), 0, & "p*[vbar(p,+).(Isigma*q).g5.v(q,+)] - (p*q+m^2)*vbar(p,+).g5.v(q,+) = 0", passed) call expect ((vp*tvam_ff(c_nil,c_one,u(m,p,-1),v(m,q,-1),q) - (p*q+m**2)*p_ff(c_one,u(m,p,-1),v(m,q,-1))), 0, & "p*[vbar(p,-).(Isigma*q).g5.v(q,-)] - (p*q+m^2)*vbar(p,-).g5.v(q,-) = 0", passed) call expect ((v(m,p,+1)*f_tvamf(c_nil,c_one,vp,u(m,q,+1),q) - (p*q+m**2)*p_ff(c_one,v(m,p,+1),u(m,q,+1))), 0, & "p*[ubar(p,+).(Isigma*q).g5.u(q,+)] - (p*q+m^2)*ubar(p,+).g5.u(q,+) = 0", passed) call expect ((v(m,p,-1)*f_tvamf(c_nil,c_one,vp,u(m,q,-1),q) - (p*q+m**2)*p_ff(c_one,v(m,p,-1),u(m,q,-1))), 0, & "p*[ubar(p,-).(Isigma*q).g5.u(q,-)] - (p*q+m^2)*ubar(p,-).g5.u(q,-) = 0", passed) call expect ((u(m,p,+1)*f_tvamf(c_nil,c_one,vp,v(m,q,+1),q) - (p*q+m**2)*p_ff(c_one,u(m,p,+1),v(m,q,+1))), 0, & "p*[vbar(p,+).(Isigma*q).g5.v(q,+)] - (p*q+m^2)*vbar(p,+).g5.v(q,+) = 0", passed) call expect ((u(m,p,-1)*f_tvamf(c_nil,c_one,vp,v(m,q,-1),q) - (p*q+m**2)*p_ff(c_one,u(m,p,-1),v(m,q,-1))), 0, & "p*[vbar(p,-).(Isigma*q).g5.v(q,-)] - (p*q+m^2)*vbar(p,-).g5.v(q,-) = 0", passed) @ <>= print *, "*** Checking polarization vectors: ***" call expect (conjg(eps(m,p, 1))*eps(m,p, 1), -1, "e( 1).e( 1)=-1", passed) call expect (conjg(eps(m,p, 1))*eps(m,p,-1), 0, "e( 1).e(-1)= 0", passed) call expect (conjg(eps(m,p,-1))*eps(m,p, 1), 0, "e(-1).e( 1)= 0", passed) call expect (conjg(eps(m,p,-1))*eps(m,p,-1), -1, "e(-1).e(-1)=-1", passed) call expect ( p*eps(m,p, 1), 0, " p.e( 1)= 0", passed) call expect ( p*eps(m,p,-1), 0, " p.e(-1)= 0", passed) if (m > 0) then call expect (conjg(eps(m,p, 1))*eps(m,p, 0), 0, "e( 1).e( 0)= 0", passed) call expect (conjg(eps(m,p, 0))*eps(m,p, 1), 0, "e( 0).e( 1)= 0", passed) call expect (conjg(eps(m,p, 0))*eps(m,p, 0), -1, "e( 0).e( 0)=-1", passed) call expect (conjg(eps(m,p, 0))*eps(m,p,-1), 0, "e( 0).e(-1)= 0", passed) call expect (conjg(eps(m,p,-1))*eps(m,p, 0), 0, "e(-1).e( 0)= 0", passed) call expect ( p*eps(m,p, 0), 0, " p.e( 0)= 0", passed) end if @ <>= print *, "*** Checking polarization vectorspinors: ***" call expect (abs(p * ueps(m, p, 2)), 0, "p.ueps ( 2)= 0", passed) call expect (abs(p * ueps(m, p, 1)), 0, "p.ueps ( 1)= 0", passed) call expect (abs(p * ueps(m, p, -1)), 0, "p.ueps (-1)= 0", passed) call expect (abs(p * ueps(m, p, -2)), 0, "p.ueps (-2)= 0", passed) call expect (abs(p * veps(m, p, 2)), 0, "p.veps ( 2)= 0", passed) call expect (abs(p * veps(m, p, 1)), 0, "p.veps ( 1)= 0", passed) call expect (abs(p * veps(m, p, -1)), 0, "p.veps (-1)= 0", passed) call expect (abs(p * veps(m, p, -2)), 0, "p.veps (-2)= 0", passed) print *, "*** Checking polarization vectorspinors (neg. masses): ***" call expect (abs(p * ueps(-m, p, 2)), 0, "p.ueps ( 2)= 0", passed) call expect (abs(p * ueps(-m, p, 1)), 0, "p.ueps ( 1)= 0", passed) call expect (abs(p * ueps(-m, p, -1)), 0, "p.ueps (-1)= 0", passed) call expect (abs(p * ueps(-m, p, -2)), 0, "p.ueps (-2)= 0", passed) call expect (abs(p * veps(-m, p, 2)), 0, "p.veps ( 2)= 0", passed) call expect (abs(p * veps(-m, p, 1)), 0, "p.veps ( 1)= 0", passed) call expect (abs(p * veps(-m, p, -1)), 0, "p.veps (-1)= 0", passed) call expect (abs(p * veps(-m, p, -2)), 0, "p.veps (-2)= 0", passed) print *, "*** in the rest frame ***" call expect (abs(p_0 * ueps(m, p_0, 2)), 0, "p0.ueps ( 2)= 0", passed) call expect (abs(p_0 * ueps(m, p_0, 1)), 0, "p0.ueps ( 1)= 0", passed) call expect (abs(p_0 * ueps(m, p_0, -1)), 0, "p0.ueps (-1)= 0", passed) call expect (abs(p_0 * ueps(m, p_0, -2)), 0, "p0.ueps (-2)= 0", passed) call expect (abs(p_0 * veps(m, p_0, 2)), 0, "p0.veps ( 2)= 0", passed) call expect (abs(p_0 * veps(m, p_0, 1)), 0, "p0.veps ( 1)= 0", passed) call expect (abs(p_0 * veps(m, p_0, -1)), 0, "p0.veps (-1)= 0", passed) call expect (abs(p_0 * veps(m, p_0, -2)), 0, "p0.veps (-2)= 0", passed) print *, "*** in the rest frame (neg. masses) ***" call expect (abs(p_0 * ueps(-m, p_0, 2)), 0, "p0.ueps ( 2)= 0", passed) call expect (abs(p_0 * ueps(-m, p_0, 1)), 0, "p0.ueps ( 1)= 0", passed) call expect (abs(p_0 * ueps(-m, p_0, -1)), 0, "p0.ueps (-1)= 0", passed) call expect (abs(p_0 * ueps(-m, p_0, -2)), 0, "p0.ueps (-2)= 0", passed) call expect (abs(p_0 * veps(-m, p_0, 2)), 0, "p0.veps ( 2)= 0", passed) call expect (abs(p_0 * veps(-m, p_0, 1)), 0, "p0.veps ( 1)= 0", passed) call expect (abs(p_0 * veps(-m, p_0, -1)), 0, "p0.veps (-1)= 0", passed) call expect (abs(p_0 * veps(-m, p_0, -2)), 0, "p0.veps (-2)= 0", passed) @ <>= print *, "*** Checking the irreducibility condition: ***" call expect (abs(f_potgr (c_one, c_one, ueps(m, p, 2))), 0, "g.ueps ( 2)", passed) call expect (abs(f_potgr (c_one, c_one, ueps(m, p, 1))), 0, "g.ueps ( 1)", passed) call expect (abs(f_potgr (c_one, c_one, ueps(m, p, -1))), 0, "g.ueps (-1)", passed) call expect (abs(f_potgr (c_one, c_one, ueps(m, p, -2))), 0, "g.ueps (-2)", passed) call expect (abs(f_potgr (c_one, c_one, veps(m, p, 2))), 0, "g.veps ( 2)", passed) call expect (abs(f_potgr (c_one, c_one, veps(m, p, 1))), 0, "g.veps ( 1)", passed) call expect (abs(f_potgr (c_one, c_one, veps(m, p, -1))), 0, "g.veps (-1)", passed) call expect (abs(f_potgr (c_one, c_one, veps(m, p, -2))), 0, "g.veps (-2)", passed) print *, "*** Checking the irreducibility condition (neg. masses): ***" call expect (abs(f_potgr (c_one, c_one, ueps(-m, p, 2))), 0, "g.ueps ( 2)", passed) call expect (abs(f_potgr (c_one, c_one, ueps(-m, p, 1))), 0, "g.ueps ( 1)", passed) call expect (abs(f_potgr (c_one, c_one, ueps(-m, p, -1))), 0, "g.ueps (-1)", passed) call expect (abs(f_potgr (c_one, c_one, ueps(-m, p, -2))), 0, "g.ueps (-2)", passed) call expect (abs(f_potgr (c_one, c_one, veps(-m, p, 2))), 0, "g.veps ( 2)", passed) call expect (abs(f_potgr (c_one, c_one, veps(-m, p, 1))), 0, "g.veps ( 1)", passed) call expect (abs(f_potgr (c_one, c_one, veps(-m, p, -1))), 0, "g.veps (-1)", passed) call expect (abs(f_potgr (c_one, c_one, veps(-m, p, -2))), 0, "g.veps (-2)", passed) print *, "*** in the rest frame ***" call expect (abs(f_potgr (c_one, c_one, ueps(m, p_0, 2))), 0, "g.ueps ( 2)", passed) call expect (abs(f_potgr (c_one, c_one, ueps(m, p_0, 1))), 0, "g.ueps ( 1)", passed) call expect (abs(f_potgr (c_one, c_one, ueps(m, p_0, -1))), 0, "g.ueps (-1)", passed) call expect (abs(f_potgr (c_one, c_one, ueps(m, p_0, -2))), 0, "g.ueps (-2)", passed) call expect (abs(f_potgr (c_one, c_one, veps(m, p_0, 2))), 0, "g.veps ( 2)", passed) call expect (abs(f_potgr (c_one, c_one, veps(m, p_0, 1))), 0, "g.veps ( 1)", passed) call expect (abs(f_potgr (c_one, c_one, veps(m, p_0, -1))), 0, "g.veps (-1)", passed) call expect (abs(f_potgr (c_one, c_one, veps(m, p_0, -2))), 0, "g.veps (-2)", passed) print *, "*** in the rest frame (neg. masses) ***" call expect (abs(f_potgr (c_one, c_one, ueps(m, p_0, 2))), 0, "g.ueps ( 2)", passed) call expect (abs(f_potgr (c_one, c_one, ueps(m, p_0, 1))), 0, "g.ueps ( 1)", passed) call expect (abs(f_potgr (c_one, c_one, ueps(m, p_0, -1))), 0, "g.ueps (-1)", passed) call expect (abs(f_potgr (c_one, c_one, ueps(m, p_0, -2))), 0, "g.ueps (-2)", passed) call expect (abs(f_potgr (c_one, c_one, veps(m, p_0, 2))), 0, "g.veps ( 2)", passed) call expect (abs(f_potgr (c_one, c_one, veps(m, p_0, 1))), 0, "g.veps ( 1)", passed) call expect (abs(f_potgr (c_one, c_one, veps(m, p_0, -1))), 0, "g.veps (-1)", passed) call expect (abs(f_potgr (c_one, c_one, veps(m, p_0, -2))), 0, "g.veps (-2)", passed) @ <>= print *, "*** Testing vectorspinor normalization ***" call expect (veps(m,p, 2)*ueps(m,p, 2), -2*m, "ueps( 2).ueps( 2)= -2m", passed) call expect (veps(m,p, 1)*ueps(m,p, 1), -2*m, "ueps( 1).ueps( 1)= -2m", passed) call expect (veps(m,p,-1)*ueps(m,p,-1), -2*m, "ueps(-1).ueps(-1)= -2m", passed) call expect (veps(m,p,-2)*ueps(m,p,-2), -2*m, "ueps(-2).ueps(-2)= -2m", passed) call expect (ueps(m,p, 2)*veps(m,p, 2), 2*m, "veps( 2).veps( 2)= +2m", passed) call expect (ueps(m,p, 1)*veps(m,p, 1), 2*m, "veps( 1).veps( 1)= +2m", passed) call expect (ueps(m,p,-1)*veps(m,p,-1), 2*m, "veps(-1).veps(-1)= +2m", passed) call expect (ueps(m,p,-2)*veps(m,p,-2), 2*m, "veps(-2).veps(-2)= +2m", passed) call expect (ueps(m,p, 2)*ueps(m,p, 2), 0, "ueps( 2).veps( 2)= 0", passed) call expect (ueps(m,p, 1)*ueps(m,p, 1), 0, "ueps( 1).veps( 1)= 0", passed) call expect (ueps(m,p,-1)*ueps(m,p,-1), 0, "ueps(-1).veps(-1)= 0", passed) call expect (ueps(m,p,-2)*ueps(m,p,-2), 0, "ueps(-2).veps(-2)= 0", passed) call expect (veps(m,p, 2)*veps(m,p, 2), 0, "veps( 2).ueps( 2)= 0", passed) call expect (veps(m,p, 1)*veps(m,p, 1), 0, "veps( 1).ueps( 1)= 0", passed) call expect (veps(m,p,-1)*veps(m,p,-1), 0, "veps(-1).ueps(-1)= 0", passed) call expect (veps(m,p,-2)*veps(m,p,-2), 0, "veps(-2).ueps(-2)= 0", passed) print *, "*** Testing vectorspinor normalization (neg. masses) ***" call expect (veps(-m,p, 2)*ueps(-m,p, 2), +2*m, "ueps( 2).ueps( 2)= +2m", passed) call expect (veps(-m,p, 1)*ueps(-m,p, 1), +2*m, "ueps( 1).ueps( 1)= +2m", passed) call expect (veps(-m,p,-1)*ueps(-m,p,-1), +2*m, "ueps(-1).ueps(-1)= +2m", passed) call expect (veps(-m,p,-2)*ueps(-m,p,-2), +2*m, "ueps(-2).ueps(-2)= +2m", passed) call expect (ueps(-m,p, 2)*veps(-m,p, 2), -2*m, "veps( 2).veps( 2)= -2m", passed) call expect (ueps(-m,p, 1)*veps(-m,p, 1), -2*m, "veps( 1).veps( 1)= -2m", passed) call expect (ueps(-m,p,-1)*veps(-m,p,-1), -2*m, "veps(-1).veps(-1)= -2m", passed) call expect (ueps(-m,p,-2)*veps(-m,p,-2), -2*m, "veps(-2).veps(-2)= -2m", passed) call expect (ueps(-m,p, 2)*ueps(-m,p, 2), 0, "ueps( 2).veps( 2)= 0", passed) call expect (ueps(-m,p, 1)*ueps(-m,p, 1), 0, "ueps( 1).veps( 1)= 0", passed) call expect (ueps(-m,p,-1)*ueps(-m,p,-1), 0, "ueps(-1).veps(-1)= 0", passed) call expect (ueps(-m,p,-2)*ueps(-m,p,-2), 0, "ueps(-2).veps(-2)= 0", passed) call expect (veps(-m,p, 2)*veps(-m,p, 2), 0, "veps( 2).ueps( 2)= 0", passed) call expect (veps(-m,p, 1)*veps(-m,p, 1), 0, "veps( 1).ueps( 1)= 0", passed) call expect (veps(-m,p,-1)*veps(-m,p,-1), 0, "veps(-1).ueps(-1)= 0", passed) call expect (veps(-m,p,-2)*veps(-m,p,-2), 0, "veps(-2).ueps(-2)= 0", passed) print *, "*** in the rest frame ***" call expect (veps(m,p_0, 2)*ueps(m,p_0, 2), -2*m, "ueps( 2).ueps( 2)= -2m", passed) call expect (veps(m,p_0, 1)*ueps(m,p_0, 1), -2*m, "ueps( 1).ueps( 1)= -2m", passed) call expect (veps(m,p_0,-1)*ueps(m,p_0,-1), -2*m, "ueps(-1).ueps(-1)= -2m", passed) call expect (veps(m,p_0,-2)*ueps(m,p_0,-2), -2*m, "ueps(-2).ueps(-2)= -2m", passed) call expect (ueps(m,p_0, 2)*veps(m,p_0, 2), 2*m, "veps( 2).veps( 2)= +2m", passed) call expect (ueps(m,p_0, 1)*veps(m,p_0, 1), 2*m, "veps( 1).veps( 1)= +2m", passed) call expect (ueps(m,p_0,-1)*veps(m,p_0,-1), 2*m, "veps(-1).veps(-1)= +2m", passed) call expect (ueps(m,p_0,-2)*veps(m,p_0,-2), 2*m, "veps(-2).veps(-2)= +2m", passed) call expect (ueps(m,p_0, 2)*ueps(m,p_0, 2), 0, "ueps( 2).veps( 2)= 0", passed) call expect (ueps(m,p_0, 1)*ueps(m,p_0, 1), 0, "ueps( 1).veps( 1)= 0", passed) call expect (ueps(m,p_0,-1)*ueps(m,p_0,-1), 0, "ueps(-1).veps(-1)= 0", passed) call expect (ueps(m,p_0,-2)*ueps(m,p_0,-2), 0, "ueps(-2).veps(-2)= 0", passed) call expect (veps(m,p_0, 2)*veps(m,p_0, 2), 0, "veps( 2).ueps( 2)= 0", passed) call expect (veps(m,p_0, 1)*veps(m,p_0, 1), 0, "veps( 1).ueps( 1)= 0", passed) call expect (veps(m,p_0,-1)*veps(m,p_0,-1), 0, "veps(-1).ueps(-1)= 0", passed) call expect (veps(m,p_0,-2)*veps(m,p_0,-2), 0, "veps(-2).ueps(-2)= 0", passed) print *, "*** in the rest frame (neg. masses) ***" call expect (veps(-m,p_0, 2)*ueps(-m,p_0, 2), +2*m, "ueps( 2).ueps( 2)= +2m", passed) call expect (veps(-m,p_0, 1)*ueps(-m,p_0, 1), +2*m, "ueps( 1).ueps( 1)= +2m", passed) call expect (veps(-m,p_0,-1)*ueps(-m,p_0,-1), +2*m, "ueps(-1).ueps(-1)= +2m", passed) call expect (veps(-m,p_0,-2)*ueps(-m,p_0,-2), +2*m, "ueps(-2).ueps(-2)= +2m", passed) call expect (ueps(-m,p_0, 2)*veps(-m,p_0, 2), -2*m, "veps( 2).veps( 2)= -2m", passed) call expect (ueps(-m,p_0, 1)*veps(-m,p_0, 1), -2*m, "veps( 1).veps( 1)= -2m", passed) call expect (ueps(-m,p_0,-1)*veps(-m,p_0,-1), -2*m, "veps(-1).veps(-1)= -2m", passed) call expect (ueps(-m,p_0,-2)*veps(-m,p_0,-2), -2*m, "veps(-2).veps(-2)= -2m", passed) call expect (ueps(-m,p_0, 2)*ueps(-m,p_0, 2), 0, "ueps( 2).veps( 2)= 0", passed) call expect (ueps(-m,p_0, 1)*ueps(-m,p_0, 1), 0, "ueps( 1).veps( 1)= 0", passed) call expect (ueps(-m,p_0,-1)*ueps(-m,p_0,-1), 0, "ueps(-1).veps(-1)= 0", passed) call expect (ueps(-m,p_0,-2)*ueps(-m,p_0,-2), 0, "ueps(-2).veps(-2)= 0", passed) call expect (veps(-m,p_0, 2)*veps(-m,p_0, 2), 0, "veps( 2).ueps( 2)= 0", passed) call expect (veps(-m,p_0, 1)*veps(-m,p_0, 1), 0, "veps( 1).ueps( 1)= 0", passed) call expect (veps(-m,p_0,-1)*veps(-m,p_0,-1), 0, "veps(-1).ueps(-1)= 0", passed) call expect (veps(-m,p_0,-2)*veps(-m,p_0,-2), 0, "veps(-2).ueps(-2)= 0", passed) @ <>= print *, "*** Majorana properties of gravitino vertices: ***" call expect (abs(u (m,q,1) * f_sgr (c_one, c_one, ueps(m,p,2), t) + & ueps(m,p,2) * gr_sf(c_one,c_one,u(m,q,1),t)), 0, "f_sgr + gr_sf = 0", passed) !!! call expect (abs(u (m,q,-1) * f_sgr (c_one, c_one, ueps(m,p,2), t) + & !!! ueps(m,p,2) * gr_sf(c_one,c_one,u(m,q,-1),t)), 0, "f_sgr + gr_sf = 0", passed) !!! call expect (abs(u (m,q,1) * f_sgr (c_one, c_one, ueps(m,p,1), t) + & !!! ueps(m,p,1) * gr_sf(c_one,c_one,u(m,q,1),t)), 0, "f_sgr + gr_sf = 0", passed) !!! call expect (abs(u (m,q,-1) * f_sgr (c_one, c_one, ueps(m,p,1), t) + & !!! ueps(m,p,1) * gr_sf(c_one,c_one,u(m,q,-1),t)), 0, "f_sgr + gr_sf = 0", passed) !!! call expect (abs(u (m,q,1) * f_sgr (c_one, c_one, ueps(m,p,-1), t) + & !!! ueps(m,p,-1) * gr_sf(c_one,c_one,u(m,q,1),t)), 0, "f_sgr + gr_sf = 0", passed) !!! call expect (abs(u (m,q,-1) * f_sgr (c_one, c_one, ueps(m,p,-1), t) + & !!! ueps(m,p,-1) * gr_sf(c_one,c_one,u(m,q,-1),t)), 0, "f_sgr + gr_sf = 0", passed) !!! call expect (abs(u (m,q,1) * f_sgr (c_one, c_one, ueps(m,p,-2), t) + & !!! ueps(m,p,-2) * gr_sf(c_one,c_one,u(m,q,1),t)), 0, "f_sgr + gr_sf = 0", passed) !!! call expect (abs(u (m,q,-1) * f_sgr (c_one, c_one, ueps(m,p,-2), t) + & !!! ueps(m,p,-2) * gr_sf(c_one,c_one,u(m,q,-1),t)), 0, "f_sgr + gr_sf = 0", passed) call expect (abs(u (m,q,1) * f_slgr (c_one, c_one, ueps(m,p,2), t) + & ueps(m,p,2) * gr_slf(c_one,c_one,u(m,q,1),t)), 0, "f_slgr + gr_slf = 0", passed, threshold = 0.5_default) call expect (abs(u (m,q,1) * f_srgr (c_one, c_one, ueps(m,p,2), t) + & ueps(m,p,2) * gr_srf(c_one,c_one,u(m,q,1),t)), 0, "f_srgr + gr_srf = 0", passed, threshold = 0.5_default) call expect (abs(u (m,q,1) * f_slrgr (c_one, c_two, c_one, ueps(m,p,2), t) + & ueps(m,p,2) * gr_slrf(c_one,c_two,c_one,u(m,q,1),t)), 0, "f_slrgr + gr_slrf = 0", passed, threshold = 0.5_default) call expect (abs(u (m,q,1) * f_pgr (c_one, c_one, ueps(m,p,2), t) + & ueps(m,p,2) * gr_pf(c_one,c_one,u(m,q,1),t)), 0, "f_pgr + gr_pf = 0", passed, threshold = 0.5_default) call expect (abs(u (m,q,1) * f_vgr (c_one, vt, ueps(m,p,2), p+q) + & ueps(m,p,2) * gr_vf(c_one,vt,u(m,q,1),p+q)), 0, "f_vgr + gr_vf = 0", passed, threshold = 0.5_default) call expect (abs(u (m,q,1) * f_vlrgr (c_one, c_two, vt, ueps(m,p,2), p+q) + & ueps(m,p,2) * gr_vlrf(c_one,c_two,vt,u(m,q,1),p+q)), 0, "f_vlrgr + gr_vlrf = 0", & passed, threshold = 0.5_default) !!! call expect (abs(u (m,q,-1) * f_vgr (c_one, vt, ueps(m,p,2), p+q) + & !!! ueps(m,p,2) * gr_vf(c_one,vt,u(m,q,-1),p+q)), 0, "f_vgr + gr_vf = 0", passed) !!! call expect (abs(u (m,q,1) * f_vgr (c_one, vt, ueps(m,p,1), p+q) + & !!! ueps(m,p,1) * gr_vf(c_one,vt,u(m,q,1),p+q)), 0, "f_vgr + gr_vf = 0", passed) !!! call expect (abs(u (m,q,-1) * f_vgr (c_one, vt, ueps(m,p,1), p+q) + & !!! ueps(m,p,1) * gr_vf(c_one,vt,u(m,q,-1),p+q)), 0, "f_vgr + gr_vf = 0", passed) !!! call expect (abs(u (m,q,1) * f_vgr (c_one, vt, ueps(m,p,-1), p+q) + & !!! ueps(m,p,-1) * gr_vf(c_one,vt,u(m,q,1),p+q)), 0, "f_vgr + gr_vf = 0", passed) !!! call expect (abs(u (m,q,-1) * f_vgr (c_one, vt, veps(m,p,-1), p+q) + & !!! veps(m,p,-1) * gr_vf(c_one,vt,u(m,q,-1),p+q)), 0, "f_vgr + gr_vf = 0", passed) !!! call expect (abs(v (m,q,1) * f_vgr (c_one, vt, ueps(m,p,-2), p+q) + & !!! ueps(m,p,-2) * gr_vf(c_one,vt,v(m,q,1),p+q)), 0, "f_vgr + gr_vf = 0", passed) !!! call expect (abs(u (m,q,-1) * f_vgr (c_one, vt, ueps(m,p,-2), p+q) + & !!! ueps(m,p,-2) * gr_vf(c_one,vt,u(m,q,-1),p+q)), 0, "f_vgr + gr_vf = 0", passed) call expect (abs(s_grf (c_one, ueps(m,p,2), u(m,q,1),t) + & s_fgr(c_one,u(m,q,1),ueps(m,p,2),t)), 0, "s_grf + s_fgr = 0", passed) call expect (abs(sl_grf (c_one, ueps(m,p,2), u(m,q,1),t) + & sl_fgr(c_one,u(m,q,1),ueps(m,p,2),t)), 0, "sl_grf + sl_fgr = 0", passed) call expect (abs(sr_grf (c_one, ueps(m,p,2), u(m,q,1),t) + & sr_fgr(c_one,u(m,q,1),ueps(m,p,2),t)), 0, "sr_grf + sr_fgr = 0", passed) call expect (abs(slr_grf (c_one, c_two, ueps(m,p,2), u(m,q,1),t) + & slr_fgr(c_one,c_two,u(m,q,1),ueps(m,p,2),t)), 0, "slr_grf + slr_fgr = 0", passed) call expect (abs(p_grf (c_one, ueps(m,p,2), u(m,q,1),t) + & p_fgr(c_one,u(m,q,1),ueps(m,p,2),t)), 0, "p_grf + p_fgr = 0", passed) call expect (abs(v_grf (c_one, ueps(m,p,2), u(m,q,1),t) + & v_fgr(c_one,u(m,q,1),ueps(m,p,2),t)), 0, "v_grf + v_fgr = 0", passed) call expect (abs(vlr_grf (c_one, c_two, ueps(m,p,2), u(m,q,1),t) + & vlr_fgr(c_one,c_two,u(m,q,1),ueps(m,p,2),t)), 0, "vlr_grf + vlr_fgr = 0", passed) call expect (abs(u(m,p,1) * f_potgr (c_one,c_one,testv) - testv * gr_potf & (c_one,c_one,u (m,p,1))), 0, "f_potgr - gr_potf = 0", passed) call expect (abs (pot_fgr (c_one,u(m,p,1),testv) - pot_grf(c_one, & testv,u(m,p,1))), 0, "pot_fgr - pot_grf = 0", passed) call expect (abs(u(m,p,1) * f_s2gr (c_one,c_one,c_one,testv) - testv * gr_s2f & (c_one,c_one,c_one,u (m,p,1))), 0, "f_s2gr - gr_s2f = 0", passed) call expect (abs (s2_fgr (c_one,u(m,p,1),c_one,testv) - s2_grf(c_one, & testv,c_one,u(m,p,1))), 0, "s2_fgr - s2_grf = 0", passed) call expect (abs(u (m,q,1) * f_svgr (c_one, c_one, vt, ueps(m,p,2)) + & ueps(m,p,2) * gr_svf(c_one,c_one,vt,u(m,q,1))), 0, "f_svgr + gr_svf = 0", passed) call expect (abs(u (m,q,1) * f_slvgr (c_one, c_one, vt, ueps(m,p,2)) + & ueps(m,p,2) * gr_slvf(c_one,c_one,vt,u(m,q,1))), 0, "f_slvgr + gr_slvf = 0", passed) call expect (abs(u (m,q,1) * f_srvgr (c_one, c_one, vt, ueps(m,p,2)) + & ueps(m,p,2) * gr_srvf(c_one,c_one,vt,u(m,q,1))), 0, "f_srvgr + gr_srvf = 0", passed) call expect (abs(u (m,q,1) * f_slrvgr (c_one, c_two, c_one, vt, ueps(m,p,2)) + & ueps(m,p,2) * gr_slrvf(c_one,c_two,c_one,vt,u(m,q,1))), 0, "f_slrvgr + gr_slrvf = 0", passed) call expect (abs (sv1_fgr (c_one,u(m,p,1),vt,ueps(m,q,2)) + sv1_grf(c_one, & ueps(m,q,2),vt,u(m,p,1))), 0, "sv1_fgr + sv1_grf = 0", passed) call expect (abs (sv2_fgr (c_one,u(m,p,1),c_one,ueps(m,q,2)) + sv2_grf(c_one, & ueps(m,q,2),c_one,u(m,p,1))), 0, "sv2_fgr + sv2_grf = 0", passed) call expect (abs (slv1_fgr (c_one,u(m,p,1),vt,ueps(m,q,2)) + slv1_grf(c_one, & ueps(m,q,2),vt,u(m,p,1))), 0, "slv1_fgr + slv1_grf = 0", passed) call expect (abs (srv2_fgr (c_one,u(m,p,1),c_one,ueps(m,q,2)) + srv2_grf(c_one, & ueps(m,q,2),c_one,u(m,p,1))), 0, "srv2_fgr + srv2_grf = 0", passed) call expect (abs (slrv1_fgr (c_one,c_two,u(m,p,1),vt,ueps(m,q,2)) + slrv1_grf(c_one,c_two, & ueps(m,q,2),vt,u(m,p,1))), 0, "slrv1_fgr + slrv1_grf = 0", passed) call expect (abs (slrv2_fgr (c_one,c_two,u(m,p,1),c_one,ueps(m,q,2)) + slrv2_grf(c_one, & c_two,ueps(m,q,2),c_one,u(m,p,1))), 0, "slrv2_fgr + slrv2_grf = 0", passed) call expect (abs(u (m,q,1) * f_pvgr (c_one, c_one, vt, ueps(m,p,2)) + & ueps(m,p,2) * gr_pvf(c_one,c_one,vt,u(m,q,1))), 0, "f_pvgr + gr_pvf = 0", passed) call expect (abs (pv1_fgr (c_one,u(m,p,1),vt,ueps(m,q,2)) + pv1_grf(c_one, & ueps(m,q,2),vt,u(m,p,1))), 0, "pv1_fgr + pv1_grf = 0", passed) call expect (abs (pv2_fgr (c_one,u(m,p,1),c_one,ueps(m,q,2)) + pv2_grf(c_one, & ueps(m,q,2),c_one,u(m,p,1))), 0, "pv2_fgr + pv2_grf = 0", passed) call expect (abs(u (m,q,1) * f_v2gr (c_one, vt, vz, ueps(m,p,2)) + & ueps(m,p,2) * gr_v2f(c_one,vt,vz,u(m,q,1))), 0, "f_v2gr + gr_v2f = 0", passed) call expect (abs(u (m,q,1) * f_v2lrgr (c_one, c_two, vt, vz, ueps(m,p,2)) + & ueps(m,p,2) * gr_v2lrf(c_one,c_two,vt,vz,u(m,q,1))), 0, "f_v2lrgr + gr_v2lrf = 0", passed) call expect (abs (v2_fgr (c_one,u(m,p,1),vt,ueps(m,q,2)) + v2_grf(c_one, & ueps(m,q,2),vt,u(m,p,1))), 0, "v2_fgr + v2_grf = 0", passed) call expect (abs (v2lr_fgr (c_one,c_two,u(m,p,1),vt,ueps(m,q,2)) + v2lr_grf(c_one, c_two, & ueps(m,q,2),vt,u(m,p,1))), 0, "v2lr_fgr + v2lr_grf = 0", passed) @ <>= print *, "*** Testing the gravitino propagator: ***" print *, "Transversality:" call expect (abs(p * (cmplx (p*p - m**2, m*w, kind=default) * & pr_grav(p,m,w,testv))), 0, "p.pr.test", passed) call expect (abs(p * (cmplx (p*p - m**2, m*w, kind=default) * & pr_grav(p,m,w,ueps(m,p,2)))), 0, "p.pr.ueps ( 2)", passed) call expect (abs(p * (cmplx (p*p - m**2, m*w, kind=default) * & pr_grav(p,m,w,ueps(m,p,1)))), 0, "p.pr.ueps ( 1)", passed) call expect (abs(p * (cmplx (p*p - m**2, m*w, kind=default) * & pr_grav(p,m,w,ueps(m,p,-1)))), 0, "p.pr.ueps (-1)", passed) call expect (abs(p * (cmplx (p*p - m**2, m*w, kind=default) * & pr_grav(p,m,w,ueps(m,p,-2)))), 0, "p.pr.ueps (-2)", passed) call expect (abs(p * (cmplx (p*p - m**2, m*w, kind=default) * & pr_grav(p,m,w,veps(m,p,2)))), 0, "p.pr.veps ( 2)", passed) call expect (abs(p * (cmplx (p*p - m**2, m*w, kind=default) * & pr_grav(p,m,w,veps(m,p,1)))), 0, "p.pr.veps ( 1)", passed) call expect (abs(p * (cmplx (p*p - m**2, m*w, kind=default) * & pr_grav(p,m,w,veps(m,p,-1)))), 0, "p.pr.veps (-1)", passed) call expect (abs(p * (cmplx (p*p - m**2, m*w, kind=default) * & pr_grav(p,m,w,veps(m,p,-2)))), 0, "p.pr.veps (-2)", passed) print *, "Irreducibility:" call expect (abs(f_potgr (c_one, c_one, (cmplx (p*p - m**2, m*w, & kind=default) * pr_grav(p,m,w,testv)))), 0, "g.pr.test", passed) call expect (abs(f_potgr (c_one, c_one, (cmplx (p*p - m**2, m*w, & kind=default) * pr_grav(p,m,w,ueps(m,p,2))))), 0, & "g.pr.ueps ( 2)", passed) call expect (abs(f_potgr (c_one, c_one, (cmplx (p*p - m**2, m*w, & kind=default) * pr_grav(p,m,w,ueps(m,p,1))))), 0, & "g.pr.ueps ( 1)", passed) call expect (abs(f_potgr (c_one, c_one, (cmplx (p*p - m**2, m*w, & kind=default) * pr_grav(p,m,w,ueps(m,p,-1))))), 0, & "g.pr.ueps (-1)", passed) call expect (abs(f_potgr (c_one, c_one, (cmplx (p*p - m**2, m*w, & kind=default) * pr_grav(p,m,w,ueps(m,p,-2))))), 0, & "g.pr.ueps (-2)", passed) call expect (abs(f_potgr (c_one, c_one, (cmplx (p*p - m**2, m*w, & kind=default) * pr_grav(p,m,w,veps(m,p,2))))), 0, & "g.pr.veps ( 2)", passed) call expect (abs(f_potgr (c_one, c_one, (cmplx (p*p - m**2, m*w, & kind=default) * pr_grav(p,m,w,veps(m,p,1))))), 0, & "g.pr.veps ( 1)", passed) call expect (abs(f_potgr (c_one, c_one, (cmplx (p*p - m**2, m*w, & kind=default) * pr_grav(p,m,w,veps(m,p,-1))))), 0, & "g.pr.veps (-1)", passed) call expect (abs(f_potgr (c_one, c_one, (cmplx (p*p - m**2, m*w, & kind=default) * pr_grav(p,m,w,veps(m,p,-2))))), 0, & "g.pr.veps (-2)", passed) @ <<[[omega_bundle.f90]]>>= <<[[omega_vectors.f90]]>> <<[[omega_spinors.f90]]>> <<[[omega_bispinors.f90]]>> <<[[omega_vectorspinors.f90]]>> <<[[omega_polarizations.f90]]>> <<[[omega_tensors.f90]]>> <<[[omega_tensor_polarizations.f90]]>> <<[[omega_couplings.f90]]>> <<[[omega_spinor_couplings.f90]]>> <<[[omega_bispinor_couplings.f90]]>> <<[[omega_vspinor_polarizations.f90]]>> <<[[omega_utils.f90]]>> <<[[omega95.f90]]>> <<[[omega95_bispinors.f90]]>> <<[[omega_parameters.f90]]>> <<[[omega_parameters_madgraph.f90]]>> @ <<[[omega_bundle_whizard.f90]]>>= <<[[omega_bundle.f90]]>> <<[[omega_parameters_whizard.f90]]>> @ %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% \section{O'Mega Virtual Machine} This module defines the O'Mega Virtual Machine (OVM) completely, whereby all environmental dependencies like masses, widths and couplings have to be given to the constructor [[vm%init]] at runtime. Support for Majorana particles and vectorspinors is only partially, especially all fusions are missing. Maybe it would be easier to make an additional [[omegavm95_bispinors]] to avoid namespace issues. Non-type specific chunks could be reused <<[[omegavm95.f90]]>>= <> module omegavm95 use kinds, only: default use constants use iso_varying_string, string_t => varying_string use, intrinsic :: iso_fortran_env, only : input_unit, output_unit, error_unit use omega95 use omega95_bispinors, only: bispinor, vectorspinor, veps, pr_grav use omega95_bispinors, only: bi_u => u use omega95_bispinors, only: bi_v => v use omega95_bispinors, only: bi_pr_psi => pr_psi use omega_bispinors, only: operator (*), operator (+) use omega_color, only: ovm_color_sum, OCF => omega_color_factor implicit none private <> <> <> contains <> <> end module omegavm95 @ This might not be the proper place but I don't know where to put it <>= integer, parameter, public :: stdin = input_unit integer, parameter, public :: stdout = output_unit integer, parameter, public :: stderr = error_unit integer, parameter :: MIN_UNIT = 11, MAX_UNIT = 99 @ <>= subroutine find_free_unit (u, iostat) integer, intent(out) :: u integer, intent(out), optional :: iostat logical :: exists, is_open integer :: i, status do i = MIN_UNIT, MAX_UNIT inquire (unit = i, exist = exists, opened = is_open, & iostat = status) if (status == 0) then if (exists .and. .not. is_open) then u = i if (present (iostat)) then iostat = 0 end if return end if end if end do if (present (iostat)) then iostat = -1 end if u = -1 end subroutine find_free_unit @ These abstract data types would ideally be the interface to communicate quantum numbers between O'Mega and Whizard. This gives full flexibility to change the representation at any time <>= public :: color_t type color_t contains procedure :: write => color_write end type color_t public :: col_discrete type, extends(color_t) :: col_discrete integer :: i end type col_discrete public :: flavor_t type flavor_t contains procedure :: write => flavor_write end type flavor_t public :: flv_discrete type, extends(flavor_t) :: flv_discrete integer :: i end type flv_discrete public :: helicity_t type :: helicity_t contains procedure :: write => helicity_write end type helicity_t public :: hel_discrete type, extends(helicity_t) :: hel_discrete integer :: i end type hel_discrete public :: hel_trigonometric type, extends(helicity_t) :: hel_trigonometric real :: theta end type hel_trigonometric public :: hel_exponential type, extends(helicity_t) :: hel_exponential real :: phi end type hel_exponential public :: hel_spherical type, extends(helicity_t) :: hel_spherical real :: theta, phi end type hel_spherical <>= subroutine color_write (color, fh) class(color_t), intent(in) :: color integer, intent(in) :: fh select type(color) type is (col_discrete) write(fh, *) 'color_discrete%i = ', color%i end select end subroutine color_write subroutine helicity_write (helicity, fh) class(helicity_t), intent(in) :: helicity integer, intent(in) :: fh select type(helicity) type is (hel_discrete) write(fh, *) 'helicity_discrete%i = ', helicity%i type is (hel_trigonometric) write(fh, *) 'helicity_trigonometric%theta = ', helicity%theta type is (hel_exponential) write(fh, *) 'helicity_exponential%phi = ', helicity%phi type is (hel_spherical) write(fh, *) 'helicity_spherical%phi = ', helicity%phi write(fh, *) 'helicity_spherical%theta = ', helicity%theta end select end subroutine helicity_write subroutine flavor_write (flavor, fh) class(flavor_t), intent(in) :: flavor integer, intent(in) :: fh select type(flavor) type is (flv_discrete) write(fh, *) 'flavor_discrete%i = ', flavor%i end select end subroutine flavor_write @ \subsection{Memory Layout} Some internal parameters <>= integer, parameter :: len_instructions = 8 integer, parameter :: N_version_lines = 2 ! Comment lines including the first header description line integer, parameter :: N_comments = 6 ! Actual data lines plus intermediate description lines ! 'description \n 1 2 3 \n description \n 3 2 1' would count as 3 integer, parameter :: N_header_lines = 5 real(default), parameter, public :: N_ = three @ This is the basic type of a VM <>= type :: basic_vm_t private logical :: verbose type(string_t) :: bytecode_file integer :: bytecode_fh, out_fh integer :: N_instructions, N_levels integer :: N_table_lines integer, dimension(:, :), allocatable :: instructions integer, dimension(:), allocatable :: levels end type @ To allow for a lazy evaluation of amplitudes, we have to keep track whether a wave function has already been computed, to avoid multiple-computing that would arise when the bytecode has redundant fusions, which is necessary for flavor and color MC (and helicity MC when we use Weyl-van-der-Waerden-spinors) <>= type :: vm_scalar logical :: c complex(kind=default) :: v end type type :: vm_spinor logical :: c type(spinor) :: v end type type :: vm_conjspinor logical :: c type(conjspinor) :: v end type type :: vm_bispinor logical :: c type(bispinor) :: v end type type :: vm_vector logical :: c type(vector) :: v end type type :: vm_tensor_2 logical :: c type(tensor) :: v end type type :: vm_tensor_1 logical :: c type(tensor2odd) :: v end type type :: vm_vectorspinor logical :: c type(vectorspinor) :: v end type @ We need a memory pool for all the intermediate results <>= type, public, extends (basic_vm_t) :: vm_t private type(string_t) :: version type(string_t) :: model integer :: N_momenta, N_particles, N_prt_in, N_prt_out, N_amplitudes ! helicities = helicity combinations integer :: N_helicities, N_col_flows, N_col_indices, N_flavors, N_col_factors integer :: N_scalars, N_spinors, N_conjspinors, N_bispinors integer :: N_vectors, N_tensors_2, N_tensors_1, N_vectorspinors integer :: N_coupl_real, N_coupl_real2, N_coupl_cmplx, N_coupl_cmplx2 integer, dimension(:, :), allocatable :: table_flavor integer, dimension(:, :, :), allocatable :: table_color_flows integer, dimension(:, :), allocatable :: table_spin logical, dimension(:, :), allocatable :: table_ghost_flags type(OCF), dimension(:), allocatable :: table_color_factors logical, dimension(:, :), allocatable :: table_flv_col_is_allowed real(default), dimension(:), allocatable :: coupl_real real(default), dimension(:, :), allocatable :: coupl_real2 complex(default), dimension(:), allocatable :: coupl_cmplx complex(default), dimension(:, :), allocatable :: coupl_cmplx2 real(default), dimension(:), allocatable :: mass real(default), dimension(:), allocatable :: width type(momentum), dimension(:), allocatable :: momenta complex(default), dimension(:), allocatable :: amplitudes complex(default), dimension(:, :, :), allocatable :: table_amplitudes class(flavor_t), dimension(:), allocatable :: flavor class(color_t), dimension(:), allocatable :: color ! gfortran 4.7 !class(helicity_t), dimension(:), pointer :: helicity => null() integer, dimension(:), allocatable :: helicity type(vm_scalar), dimension(:), allocatable :: scalars type(vm_spinor), dimension(:), allocatable :: spinors type(vm_conjspinor), dimension(:), allocatable :: conjspinors type(vm_bispinor), dimension(:), allocatable :: bispinors type(vm_vector), dimension(:), allocatable :: vectors type(vm_tensor_2), dimension(:), allocatable :: tensors_2 type(vm_tensor_1), dimension(:), allocatable :: tensors_1 type(vm_vectorspinor), dimension(:), allocatable :: vectorspinors logical, dimension(:), allocatable :: hel_is_allowed real(default), dimension(:), allocatable :: hel_max_abs real(default) :: hel_sum_abs = 0, hel_threshold = 1E10 integer :: hel_count = 0, hel_cutoff = 100 integer, dimension(:), allocatable :: hel_map integer :: hel_finite logical :: cms logical :: openmp contains <> end type @ <>= subroutine alloc_arrays (vm) type(vm_t), intent(inout) :: vm integer :: i allocate (vm%table_flavor(vm%N_particles, vm%N_flavors)) allocate (vm%table_color_flows(vm%N_col_indices, vm%N_particles, & vm%N_col_flows)) allocate (vm%table_spin(vm%N_particles, vm%N_helicities)) allocate (vm%table_ghost_flags(vm%N_particles, vm%N_col_flows)) allocate (vm%table_color_factors(vm%N_col_factors)) allocate (vm%table_flv_col_is_allowed(vm%N_flavors, vm%N_col_flows)) allocate (vm%momenta(vm%N_momenta)) allocate (vm%amplitudes(vm%N_amplitudes)) allocate (vm%table_amplitudes(vm%N_flavors, vm%N_col_flows, & vm%N_helicities)) vm%table_amplitudes = zero allocate (vm%scalars(vm%N_scalars)) allocate (vm%spinors(vm%N_spinors)) allocate (vm%conjspinors(vm%N_conjspinors)) allocate (vm%bispinors(vm%N_bispinors)) allocate (vm%vectors(vm%N_vectors)) allocate (vm%tensors_2(vm%N_tensors_2)) allocate (vm%tensors_1(vm%N_tensors_1)) allocate (vm%vectorspinors(vm%N_vectorspinors)) allocate (vm%hel_is_allowed(vm%N_helicities)) vm%hel_is_allowed = .True. allocate (vm%hel_max_abs(vm%N_helicities)) vm%hel_max_abs = 0 allocate (vm%hel_map(vm%N_helicities)) vm%hel_map = (/(i, i = 1, vm%N_helicities)/) vm%hel_finite = vm%N_helicities end subroutine alloc_arrays @ \subsection{Controlling the VM} These type-bound procedures steer the VM <>= procedure :: init => vm_init procedure :: write => vm_write procedure :: reset => vm_reset procedure :: run => vm_run procedure :: final => vm_final @ The [[init]] completely sets the environment for the OVM. Parameters can be changed with [[reset]] without reloading the bytecode. <>= subroutine vm_init (vm, bytecode_file, version, model, & coupl_real, coupl_real2, coupl_cmplx, coupl_cmplx2, & mass, width, verbose, out_fh, openmp) class(vm_t), intent(out) :: vm type(string_t), intent(in) :: bytecode_file type(string_t), intent(in) :: version type(string_t), intent(in) :: model real(default), dimension(:), optional, intent(in) :: coupl_real real(default), dimension(:, :), optional, intent(in) :: coupl_real2 complex(default), dimension(:), optional, intent(in) :: coupl_cmplx complex(default), dimension(:, :), optional, intent(in) :: coupl_cmplx2 real(default), dimension(:), optional, intent(in) :: mass real(default), dimension(:), optional, intent(in) :: width logical, optional, intent(in) :: verbose integer, optional, intent(in) :: out_fh logical, optional, intent(in) :: openmp vm%bytecode_file = bytecode_file vm%version = version vm%model = model if (present (coupl_real)) then allocate (vm%coupl_real (size (coupl_real)), source=coupl_real) end if if (present (coupl_real2)) then allocate (vm%coupl_real2 (2, size (coupl_real2, 2)), source=coupl_real2) end if if (present (coupl_cmplx)) then allocate (vm%coupl_cmplx (size (coupl_cmplx)), source=coupl_cmplx) end if if (present (coupl_cmplx2)) then allocate (vm%coupl_cmplx2 (2, size (coupl_cmplx2, 2)), & source=coupl_cmplx2) end if if (present (mass)) then allocate (vm%mass(size(mass)), source=mass) end if if (present (width)) then allocate (vm%width(size (width)), source=width) end if if (present (openmp)) then vm%openmp = openmp else vm%openmp = .false. end if vm%cms = .false. call basic_init (vm, verbose, out_fh) end subroutine vm_init @ <>= subroutine vm_reset (vm, & coupl_real, coupl_real2, coupl_cmplx, coupl_cmplx2, & mass, width, verbose, out_fh) class(vm_t), intent(inout) :: vm real(default), dimension(:), optional, intent(in) :: coupl_real real(default), dimension(:, :), optional, intent(in) :: coupl_real2 complex(default), dimension(:), optional, intent(in) :: coupl_cmplx complex(default), dimension(:, :), optional, intent(in) :: coupl_cmplx2 real(default), dimension(:), optional, intent(in) :: mass real(default), dimension(:), optional, intent(in) :: width logical, optional, intent(in) :: verbose integer, optional, intent(in) :: out_fh if (present (coupl_real)) then vm%coupl_real = coupl_real end if if (present (coupl_real2)) then vm%coupl_real2 = coupl_real2 end if if (present (coupl_cmplx)) then vm%coupl_cmplx = coupl_cmplx end if if (present (coupl_cmplx2)) then vm%coupl_cmplx2 = coupl_cmplx2 end if if (present (mass)) then vm%mass = mass end if if (present (width)) then vm%width = width end if if (present (verbose)) then vm%verbose = verbose end if if (present (out_fh)) then vm%out_fh = out_fh end if end subroutine vm_reset @ Mainly for debugging <>= subroutine vm_write (vm) class(vm_t), intent(in) :: vm integer :: i, j, k call basic_write (vm) write(vm%out_fh, *) 'table_flavor = ', vm%table_flavor write(vm%out_fh, *) 'table_color_flows = ', vm%table_color_flows write(vm%out_fh, *) 'table_spin = ', vm%table_spin write(vm%out_fh, *) 'table_ghost_flags = ', vm%table_ghost_flags write(vm%out_fh, *) 'table_color_factors = ' do i = 1, size(vm%table_color_factors) write(vm%out_fh, *) vm%table_color_factors(i)%i1, & vm%table_color_factors(i)%i2, & vm%table_color_factors(i)%factor end do write(vm%out_fh, *) 'table_flv_col_is_allowed = ', & vm%table_flv_col_is_allowed do i = 1, vm%N_flavors do j = 1, vm%N_col_flows do k = 1, vm%N_helicities write(vm%out_fh, *) 'table_amplitudes(f,c,h), f, c, h = ', vm%table_amplitudes(i,j,k), i, j, k end do end do end do if (allocated(vm%coupl_real)) then write(vm%out_fh, *) 'coupl_real = ', vm%coupl_real end if if (allocated(vm%coupl_real2)) then write(vm%out_fh, *) 'coupl_real2 = ', vm%coupl_real2 end if if (allocated(vm%coupl_cmplx)) then write(vm%out_fh, *) 'coupl_cmplx = ', vm%coupl_cmplx end if if (allocated(vm%coupl_cmplx2)) then write(vm%out_fh, *) 'coupl_cmplx2 = ', vm%coupl_cmplx2 end if write(vm%out_fh, *) 'mass = ', vm%mass write(vm%out_fh, *) 'width = ', vm%width write(vm%out_fh, *) 'momenta = ', vm%momenta ! gfortran 4.7 !do i = 1, size(vm%flavor) !call vm%flavor(i)%write (vm%out_fh) !end do !do i = 1, size(vm%color) !call vm%color(i)%write (vm%out_fh) !end do !do i = 1, size(vm%helicity) !call vm%helicity(i)%write (vm%out_fh) !end do write(vm%out_fh, *) 'helicity = ', vm%helicity write(vm%out_fh, *) 'amplitudes = ', vm%amplitudes write(vm%out_fh, *) 'scalars = ', vm%scalars write(vm%out_fh, *) 'spinors = ', vm%spinors write(vm%out_fh, *) 'conjspinors = ', vm%conjspinors write(vm%out_fh, *) 'bispinors = ', vm%bispinors write(vm%out_fh, *) 'vectors = ', vm%vectors write(vm%out_fh, *) 'tensors_2 = ', vm%tensors_2 write(vm%out_fh, *) 'tensors_1 = ', vm%tensors_1 !!! !!! !!! Regression with ifort 16.0.0 !!! write(vm%out_fh, *) 'vectorspinors = ', vm%vectorspinors write(vm%out_fh, *) 'N_momenta = ', vm%N_momenta write(vm%out_fh, *) 'N_particles = ', vm%N_particles write(vm%out_fh, *) 'N_prt_in = ', vm%N_prt_in write(vm%out_fh, *) 'N_prt_out = ', vm%N_prt_out write(vm%out_fh, *) 'N_amplitudes = ', vm%N_amplitudes write(vm%out_fh, *) 'N_helicities = ', vm%N_helicities write(vm%out_fh, *) 'N_col_flows = ', vm%N_col_flows write(vm%out_fh, *) 'N_col_indices = ', vm%N_col_indices write(vm%out_fh, *) 'N_flavors = ', vm%N_flavors write(vm%out_fh, *) 'N_col_factors = ', vm%N_col_factors write(vm%out_fh, *) 'N_scalars = ', vm%N_scalars write(vm%out_fh, *) 'N_spinors = ', vm%N_spinors write(vm%out_fh, *) 'N_conjspinors = ', vm%N_conjspinors write(vm%out_fh, *) 'N_bispinors = ', vm%N_bispinors write(vm%out_fh, *) 'N_vectors = ', vm%N_vectors write(vm%out_fh, *) 'N_tensors_2 = ', vm%N_tensors_2 write(vm%out_fh, *) 'N_tensors_1 = ', vm%N_tensors_1 write(vm%out_fh, *) 'N_vectorspinors = ', vm%N_vectorspinors write(vm%out_fh, *) 'Overall size of VM: ' ! GNU extension ! write(vm%out_fh, *) 'sizeof(wavefunctions) = ', & ! sizeof(vm%scalars) + sizeof(vm%spinors) + sizeof(vm%conjspinors) + & ! sizeof(vm%bispinors) + sizeof(vm%vectors) + sizeof(vm%tensors_2) + & ! sizeof(vm%tensors_1) + sizeof(vm%vectorspinors) ! write(vm%out_fh, *) 'sizeof(mometa) = ', sizeof(vm%momenta) ! write(vm%out_fh, *) 'sizeof(amplitudes) = ', sizeof(vm%amplitudes) ! write(vm%out_fh, *) 'sizeof(tables) = ', & ! sizeof(vm%table_amplitudes) + sizeof(vm%table_spin) + & ! sizeof(vm%table_flavor) + sizeof(vm%table_flv_col_is_allowed) + & ! sizeof(vm%table_color_flows) + sizeof(vm%table_color_factors) + & ! sizeof(vm%table_ghost_flags) end subroutine vm_write @ Most of this is redundant (Fortran will deallocate when we leave the scope) but when we change from [[allocatable]]s to [[pointer]]s, it is necessary to avoid leaks <>= subroutine vm_final (vm) class(vm_t), intent(inout) :: vm deallocate (vm%table_flavor) deallocate (vm%table_color_flows) deallocate (vm%table_spin) deallocate (vm%table_ghost_flags) deallocate (vm%table_color_factors) deallocate (vm%table_flv_col_is_allowed) if (allocated (vm%coupl_real)) then deallocate (vm%coupl_real) end if if (allocated (vm%coupl_real2)) then deallocate (vm%coupl_real2) end if if (allocated (vm%coupl_cmplx)) then deallocate (vm%coupl_cmplx) end if if (allocated (vm%coupl_cmplx2)) then deallocate (vm%coupl_cmplx2) end if if (allocated (vm%mass)) then deallocate (vm%mass) end if if (allocated (vm%width)) then deallocate (vm%width) end if deallocate (vm%momenta) deallocate (vm%flavor) deallocate (vm%color) deallocate (vm%helicity) deallocate (vm%amplitudes) deallocate (vm%table_amplitudes) deallocate (vm%scalars) deallocate (vm%spinors) deallocate (vm%conjspinors) deallocate (vm%bispinors) deallocate (vm%vectors) deallocate (vm%tensors_2) deallocate (vm%tensors_1) deallocate (vm%vectorspinors) end subroutine vm_final @ Handing over the polymorph object helicity didn't work out as planned. A work-around is the use of [[pointer]]s. [[flavor]] and [[color]] are not yet used but would have to be changed to [[pointer]]s as well. At least this potentially avoids copying. Actually, neither the allocatable nor the pointer version works in [[gfortran 4.7]] due to the broken [[select type]]. Back to Stone Age, i.e. integers. <>= subroutine vm_run (vm, mom, flavor, color, helicity) class(vm_t), intent(inout) :: vm real(default), dimension(0:3, *), intent(in) :: mom class(flavor_t), dimension(:), optional, intent(in) :: flavor class(color_t), dimension(:), optional, intent(in) :: color ! gfortran 4.7 !class(helicity_t), dimension(:), optional, target, intent(in) :: helicity integer, dimension(:), optional, intent(in) :: helicity integer :: i, h, hi do i = 1, vm%N_particles if (i <= vm%N_prt_in) then vm%momenta(i) = - mom(:, i) ! incoming, crossing symmetry else vm%momenta(i) = mom(:, i) ! outgoing end if end do if (present (flavor)) then allocate(vm%flavor(size(flavor)), source=flavor) else if (.not. (allocated (vm%flavor))) then allocate(flv_discrete::vm%flavor(vm%N_particles)) end if end if if (present (color)) then allocate(vm%color(size(color)), source=color) else if (.not. (allocated (vm%color))) then allocate(col_discrete::vm%color(vm%N_col_flows)) end if end if ! gfortran 4.7 if (present (helicity)) then !vm%helicity => helicity vm%helicity = helicity call vm_run_one_helicity (vm, 1) else !if (.not. (associated (vm%helicity))) then !allocate(hel_discrete::vm%helicity(vm%N_particles)) !end if if (.not. (allocated (vm%helicity))) then allocate(vm%helicity(vm%N_particles)) end if if (vm%hel_finite == 0) return do hi = 1, vm%hel_finite h = vm%hel_map(hi) !> vm%helicity = vm%table_spin(:,h) call vm_run_one_helicity (vm, h) end do end if end subroutine vm_run @ This only removes the [[ICE]] but still leads to a segmentation fault in [[gfortran 4.7]]. I am running out of ideas how to make this compiler work with arrays of polymorph datatypes. <>= integer :: hj <>= do hj = 1, size(vm%helicity) select type (hel => vm%helicity(hj)) type is (hel_discrete) hel%i = vm%table_spin(hj,h) end select end do @ <>= select type (hel => vm%helicity) type is (hel_discrete) hel(:)%i = vm%table_spin(:,h) end select @ <>= subroutine vm_run_one_helicity (vm, h) class(vm_t), intent(inout) :: vm integer, intent(in) :: h integer :: f, c, i vm%amplitudes = zero if (vm%N_levels > 0) then call null_all_wfs (vm) call iterate_instructions (vm) end if i = 1 do c = 1, vm%N_col_flows do f = 1, vm%N_flavors if (vm%table_flv_col_is_allowed(f,c)) then vm%table_amplitudes(f,c,h) = vm%amplitudes(i) i = i + 1 end if end do end do end subroutine @ <>= subroutine null_all_wfs (vm) type(vm_t), intent(inout) :: vm integer :: i, j vm%scalars%c = .False. vm%scalars%v = zero vm%spinors%c = .False. vm%conjspinors%c = .False. vm%bispinors%c = .False. vm%vectorspinors%c = .False. do i = 1, 4 vm%spinors%v%a(i) = zero vm%conjspinors%v%a(i) = zero vm%bispinors%v%a(i) = zero do j = 1, 4 vm%vectorspinors%v%psi(i)%a(j) = zero end do end do vm%vectors%c = .False. vm%vectors%v%t = zero vm%tensors_1%c = .False. vm%tensors_2%c = .False. do i = 1, 3 vm%vectors%v%x(i) = zero vm%tensors_1%v%e(i) = zero vm%tensors_1%v%b(i) = zero do j = 1, 3 vm%tensors_2%v%t(i,j) = zero end do end do end subroutine @ \subsection{Reading the bytecode} <>= subroutine load_header (vm, IO) type(vm_t), intent(inout) :: vm integer, intent(inout) :: IO integer, dimension(len_instructions) :: line read(vm%bytecode_fh, fmt = *, iostat = IO) line vm%N_momenta = line(1) vm%N_particles = line(2) vm%N_prt_in = line(3) vm%N_prt_out = line(4) vm%N_amplitudes = line(5) vm%N_helicities = line(6) vm%N_col_flows = line(7) if (vm%N_momenta == 0) then vm%N_col_indices = 2 else vm%N_col_indices = line(8) end if read(vm%bytecode_fh, fmt = *, iostat = IO) read(vm%bytecode_fh, fmt = *, iostat = IO) line vm%N_flavors = line(1) vm%N_col_factors = line(2) vm%N_scalars = line(3) vm%N_spinors = line(4) vm%N_conjspinors = line(5) vm%N_bispinors = line(6) vm%N_vectors = line(7) vm%N_tensors_2 = line(8) read(vm%bytecode_fh, fmt = *, iostat = IO) read(vm%bytecode_fh, fmt = *, iostat = IO) line vm%N_tensors_1 = line(1) vm%N_vectorspinors = line(2) ! Add 1 for seperating label lines like 'Another table' vm%N_table_lines = vm%N_helicities + 1 + vm%N_flavors + 1 + vm%N_col_flows & + 1 + vm%N_col_flows + 1 + vm%N_col_factors + 1 + vm%N_col_flows end subroutine load_header @ <>= subroutine read_tables (vm, IO) type(vm_t), intent(inout) :: vm integer, intent(inout) :: IO integer :: i integer, dimension(2) :: tmpcf integer, dimension(3) :: tmpfactor integer, dimension(vm%N_flavors) :: tmpF integer, dimension(vm%N_particles) :: tmpP real(default) :: factor do i = 1, vm%N_helicities read(vm%bytecode_fh, fmt = *, iostat = IO) vm%table_spin(:, i) end do read(vm%bytecode_fh, fmt = *, iostat = IO) do i = 1, vm%N_flavors read(vm%bytecode_fh, fmt = *, iostat = IO) vm%table_flavor(:, i) end do read(vm%bytecode_fh, fmt = *, iostat = IO) do i = 1, vm%N_col_flows read(vm%bytecode_fh, fmt = *, iostat = IO) vm%table_color_flows(:, :, i) end do read(vm%bytecode_fh, fmt = *, iostat = IO) do i = 1, vm%N_col_flows read(vm%bytecode_fh, fmt = *, iostat = IO) tmpP vm%table_ghost_flags(:, i) = int_to_log(tmpP) end do read(vm%bytecode_fh, fmt = *, iostat = IO) do i = 1, vm%N_col_factors read(vm%bytecode_fh, fmt = '(2I9)', iostat = IO, advance='no') tmpcf factor = zero do read(vm%bytecode_fh, fmt = '(3I9)', iostat = IO, advance='no', EOR=10) tmpfactor factor = factor + color_factor(tmpfactor(1), tmpfactor(2), tmpfactor(3)) end do 10 vm%table_color_factors(i) = OCF(tmpcf(1), tmpcf(2), factor) end do read(vm%bytecode_fh, fmt = *, iostat = IO) do i = 1, vm%N_col_flows read(vm%bytecode_fh, fmt = *, iostat = IO) tmpF vm%table_flv_col_is_allowed(:, i) = int_to_log(tmpF) end do end subroutine read_tables @ This checking has proven useful more than once <>= subroutine extended_version_check (vm, IO) type(vm_t), intent(in) :: vm integer, intent(inout) :: IO character(256) :: buffer read(vm%bytecode_fh, fmt = *, iostat = IO) buffer if (vm%model /= buffer) then print *, "Warning: Bytecode has been generated with an older SVN revision." else if (vm%verbose) then write (vm%out_fh, fmt = *) "Using the model: " write (vm%out_fh, fmt = *) char(vm%model) end if end if end subroutine extended_version_check @ This chunk is copied verbatim from the [[basic_vm]] <>= subroutine basic_init (vm, verbose, out_fh) type(vm_t), intent(inout) :: vm logical, optional, intent(in) :: verbose integer, optional, intent(in) :: out_fh if (present (verbose)) then vm%verbose = verbose else vm%verbose = .true. end if if (present (out_fh)) then vm%out_fh = out_fh else vm%out_fh = stdout end if call set_stream (vm) call alloc_and_count (vm) if (vm%N_levels > 0) then call read_bytecode (vm) call sanity_check (vm) end if close (vm%bytecode_fh) end subroutine basic_init subroutine basic_write (vm) type(vm_t), intent(in) :: vm integer :: i write (vm%out_fh, *) '=====> VM ', char(vm%version), ' <=====' write (vm%out_fh, *) 'verbose = ', vm%verbose write (vm%out_fh, *) 'bytecode_file = ', char (vm%bytecode_file) write (vm%out_fh, *) 'N_instructions = ', vm%N_instructions write (vm%out_fh, *) 'N_levels = ', vm%N_levels write (vm%out_fh, *) 'instructions = ' do i = 1, vm%N_instructions write (vm%out_fh, *) vm%instructions(:, i) end do write (vm%out_fh, *) 'levels = ', vm%levels end subroutine basic_write subroutine alloc_and_count (vm) type(vm_t), intent(inout) :: vm integer, dimension(len_instructions) :: line character(256) :: buffer integer :: i, IO read(vm%bytecode_fh, fmt = *, iostat = IO) buffer if (vm%version /= buffer) then print *, "Warning: Bytecode has been generated with an older SVN revision." else if (vm%verbose) then write (vm%out_fh, fmt = *) "Bytecode version fits." end if end if call extended_version_check (vm, IO) if (vm%verbose) then write (vm%out_fh, fmt = *) "Trying to allocate." end if do i = 1, N_comments read(vm%bytecode_fh, fmt = *, iostat = IO) end do call load_header (vm, IO) call alloc_arrays (vm) if (vm%N_momenta /= 0) then do i = 1, vm%N_table_lines + 1 read(vm%bytecode_fh, fmt = *, iostat = IO) end do vm%N_instructions = 0 vm%N_levels = 0 do read(vm%bytecode_fh, fmt = *, end = 42) line if (line(1) /= 0) then vm%N_instructions = vm%N_instructions + 1 else vm%N_levels = vm%N_levels + 1 end if end do 42 rewind(vm%bytecode_fh, iostat = IO) allocate (vm%instructions(len_instructions, vm%N_instructions)) allocate (vm%levels(vm%N_levels)) if (IO /= 0) then print *, "Error: vm.alloc : Couldn't load bytecode!" stop 1 end if end if end subroutine alloc_and_count subroutine read_bytecode (vm) type(vm_t), intent(inout) :: vm integer, dimension(len_instructions) :: line integer :: i, j, IO ! Jump over version number, comments, header and first table description do i = 1, N_version_lines + N_comments + N_header_lines + 1 read (vm%bytecode_fh, fmt = *, iostat = IO) end do call read_tables (vm, IO) read (vm%bytecode_fh, fmt = *, iostat = IO) i = 0; j = 0 do read (vm%bytecode_fh, fmt = *, iostat = IO) line if (IO /= 0) exit if (line(1) == 0) then if (j <= vm%N_levels) then j = j + 1 vm%levels(j) = i ! last index of a level is saved else print *, 'Error: vm.read_bytecode: File has more levels than anticipated!' stop 1 end if else if (i <= vm%N_instructions) then i = i + 1 ! A valid instruction line vm%instructions(:, i) = line else print *, 'Error: vm.read_bytecode: File is larger than anticipated!' stop 1 end if end if end do end subroutine read_bytecode subroutine iterate_instructions (vm) type(vm_t), intent(inout) :: vm integer :: i, j if (vm%openmp) then !$omp parallel do j = 1, vm%N_levels - 1 !$omp do schedule (static) do i = vm%levels (j) + 1, vm%levels (j + 1) call decode (vm, i) end do !$omp end do end do !$omp end parallel else do j = 1, vm%N_levels - 1 do i = vm%levels (j) + 1, vm%levels (j + 1) call decode (vm, i) end do end do end if end subroutine iterate_instructions subroutine set_stream (vm) type(vm_t), intent(inout) :: vm integer :: IO call find_free_unit (vm%bytecode_fh, IO) open (vm%bytecode_fh, file = char (vm%bytecode_file), form = 'formatted', & access = 'sequential', status = 'old', position = 'rewind', iostat = IO, & action = 'read') if (IO /= 0) then print *, "Error: vm.set_stream: Bytecode file '", char(vm%bytecode_file), & "' not found!" stop 1 end if end subroutine set_stream subroutine sanity_check (vm) type(vm_t), intent(in) :: vm if (vm%levels(1) /= 0) then print *, "Error: vm.vm_init: levels(1) != 0" stop 1 end if if (vm%levels(vm%N_levels) /= vm%N_instructions) then print *, "Error: vm.vm_init: levels(N_levels) != N_instructions" stop 1 end if if (vm%verbose) then write(vm%out_fh, *) "vm passed sanity check. Starting calculation." end if end subroutine sanity_check @ \subsection{Main Decode Function} This is the heart of the OVM <>= ! pure & ! if no warnings subroutine decode (vm, instruction_index) type(vm_t), intent(inout) :: vm integer, intent(in) :: instruction_index integer, dimension(len_instructions) :: i, curr complex(default) :: braket integer :: tmp real(default) :: w i = vm%instructions (:, instruction_index) select case (i(1)) case ( : -1) ! Jump over subinstructions <<[[case]]s of [[decode]]>> case (0) print *, 'Error: Levelbreak put in decode! Line:', & instruction_index stop 1 case default print *, "Error: Decode has case not catched! Line: ", & instruction_index stop 1 end select end subroutine decode @ \subsubsection{Momenta} The most trivial instruction <>= integer, parameter :: ovm_ADD_MOMENTA = 1 @ <<[[case]]s of [[decode]]>>= case (ovm_ADD_MOMENTA) vm%momenta(i(4)) = vm%momenta(i(5)) + vm%momenta(i(6)) if (i(7) > 0) then vm%momenta(i(4)) = vm%momenta(i(4)) + vm%momenta(i(7)) end if @ \subsubsection{Loading External states} <>= integer, parameter :: ovm_LOAD_SCALAR = 10 integer, parameter :: ovm_LOAD_SPINOR_INC = 11 integer, parameter :: ovm_LOAD_SPINOR_OUT = 12 integer, parameter :: ovm_LOAD_CONJSPINOR_INC = 13 integer, parameter :: ovm_LOAD_CONJSPINOR_OUT = 14 integer, parameter :: ovm_LOAD_MAJORANA_INC = 15 integer, parameter :: ovm_LOAD_MAJORANA_OUT = 16 integer, parameter :: ovm_LOAD_VECTOR_INC = 17 integer, parameter :: ovm_LOAD_VECTOR_OUT = 18 integer, parameter :: ovm_LOAD_VECTORSPINOR_INC = 19 integer, parameter :: ovm_LOAD_VECTORSPINOR_OUT = 20 integer, parameter :: ovm_LOAD_TENSOR2_INC = 21 integer, parameter :: ovm_LOAD_TENSOR2_OUT = 22 integer, parameter :: ovm_LOAD_BRS_SCALAR = 30 integer, parameter :: ovm_LOAD_BRS_SPINOR_INC = 31 integer, parameter :: ovm_LOAD_BRS_SPINOR_OUT = 32 integer, parameter :: ovm_LOAD_BRS_CONJSPINOR_INC = 33 integer, parameter :: ovm_LOAD_BRS_CONJSPINOR_OUT = 34 integer, parameter :: ovm_LOAD_BRS_VECTOR_INC = 37 integer, parameter :: ovm_LOAD_BRS_VECTOR_OUT = 38 integer, parameter :: ovm_LOAD_MAJORANA_GHOST_INC = 23 integer, parameter :: ovm_LOAD_MAJORANA_GHOST_OUT = 24 integer, parameter :: ovm_LOAD_BRS_MAJORANA_INC = 35 integer, parameter :: ovm_LOAD_BRS_MAJORANA_OUT = 36 @ <<[[case]]s of [[decode]]>>= case (ovm_LOAD_SCALAR) vm%scalars(i(4))%v = one vm%scalars(i(4))%c = .True. case (ovm_LOAD_SPINOR_INC) call load_spinor(vm%spinors(i(4)), - <

>, <>, & vm%helicity(i(5)), ovm_LOAD_SPINOR_INC) case (ovm_LOAD_SPINOR_OUT) call load_spinor(vm%spinors(i(4)), <

>, <>, & vm%helicity(i(5)), ovm_LOAD_SPINOR_OUT) case (ovm_LOAD_CONJSPINOR_INC) call load_conjspinor(vm%conjspinors(i(4)), - <

>, & <>, vm%helicity(i(5)), ovm_LOAD_CONJSPINOR_INC) case (ovm_LOAD_CONJSPINOR_OUT) call load_conjspinor(vm%conjspinors(i(4)), <

>, & <>, vm%helicity(i(5)), ovm_LOAD_CONJSPINOR_OUT) case (ovm_LOAD_MAJORANA_INC) call load_bispinor(vm%bispinors(i(4)), - <

>, & <>, vm%helicity(i(5)), ovm_LOAD_MAJORANA_INC) case (ovm_LOAD_MAJORANA_OUT) call load_bispinor(vm%bispinors(i(4)), <

>, <>, & vm%helicity(i(5)), ovm_LOAD_MAJORANA_OUT) case (ovm_LOAD_VECTOR_INC) call load_vector(vm%vectors(i(4)), - <

>, <>, & vm%helicity(i(5)), ovm_LOAD_VECTOR_INC) case (ovm_LOAD_VECTOR_OUT) call load_vector(vm%vectors(i(4)), <

>, <>, & vm%helicity(i(5)), ovm_LOAD_VECTOR_OUT) case (ovm_LOAD_VECTORSPINOR_INC) !select type (h => vm%helicity(i(5))) !type is (hel_discrete) !vm%vectorspinors(i(4))%v = veps(<>, - <

>, & !h%i) !end select vm%vectorspinors(i(4))%v = veps(<>, - <

>, & vm%helicity(i(5))) vm%vectorspinors(i(4))%c = .True. case (ovm_LOAD_VECTORSPINOR_OUT) !select type (h => vm%helicity(i(5))) !type is (hel_discrete) !vm%vectorspinors(i(4))%v = veps(<>, <

>, & !h%i) !end select vm%vectorspinors(i(4))%v = veps(<>, <

>, & vm%helicity(i(5))) vm%vectorspinors(i(4))%c = .True. case (ovm_LOAD_TENSOR2_INC) !select type (h => vm%helicity(i(5))) !type is (hel_discrete) !vm%tensors_2(i(4))%v = eps2(<>, - <

>, & !h%i) !end select vm%tensors_2(i(4))%c = .True. case (ovm_LOAD_TENSOR2_OUT) !select type (h => vm%helicity(i(5))) !type is (hel_discrete) !vm%tensors_2(i(4))%v = eps2(<>, <

>, h%i) !end select vm%tensors_2(i(4))%c = .True. case (ovm_LOAD_BRS_SCALAR) vm%scalars(i(4))%v = (0, -1) * (<

> * <

> - & <>**2) vm%scalars(i(4))%c = .True. case (ovm_LOAD_BRS_SPINOR_INC) print *, 'not implemented' stop 1 case (ovm_LOAD_BRS_SPINOR_OUT) print *, 'not implemented' stop 1 case (ovm_LOAD_BRS_CONJSPINOR_INC) print *, 'not implemented' stop 1 case (ovm_LOAD_BRS_CONJSPINOR_OUT) print *, 'not implemented' stop 1 case (ovm_LOAD_BRS_VECTOR_INC) print *, 'not implemented' stop 1 case (ovm_LOAD_BRS_VECTOR_OUT) print *, 'not implemented' stop 1 case (ovm_LOAD_MAJORANA_GHOST_INC) print *, 'not implemented' stop 1 case (ovm_LOAD_MAJORANA_GHOST_OUT) print *, 'not implemented' stop 1 case (ovm_LOAD_BRS_MAJORANA_INC) print *, 'not implemented' stop 1 case (ovm_LOAD_BRS_MAJORANA_OUT) print *, 'not implemented' stop 1 @ \subsubsection{Brakets and Fusions} NB: during, execution, the type of the coupling constant is implicit in the instruction <>= integer, parameter :: ovm_CALC_BRAKET = 2 integer, parameter :: ovm_FUSE_V_FF = -1 integer, parameter :: ovm_FUSE_F_VF = -2 integer, parameter :: ovm_FUSE_F_FV = -3 integer, parameter :: ovm_FUSE_VA_FF = -4 integer, parameter :: ovm_FUSE_F_VAF = -5 integer, parameter :: ovm_FUSE_F_FVA = -6 integer, parameter :: ovm_FUSE_VA2_FF = -7 integer, parameter :: ovm_FUSE_F_VA2F = -8 integer, parameter :: ovm_FUSE_F_FVA2 = -9 integer, parameter :: ovm_FUSE_A_FF = -10 integer, parameter :: ovm_FUSE_F_AF = -11 integer, parameter :: ovm_FUSE_F_FA = -12 integer, parameter :: ovm_FUSE_VL_FF = -13 integer, parameter :: ovm_FUSE_F_VLF = -14 integer, parameter :: ovm_FUSE_F_FVL = -15 integer, parameter :: ovm_FUSE_VR_FF = -16 integer, parameter :: ovm_FUSE_F_VRF = -17 integer, parameter :: ovm_FUSE_F_FVR = -18 integer, parameter :: ovm_FUSE_VLR_FF = -19 integer, parameter :: ovm_FUSE_F_VLRF = -20 integer, parameter :: ovm_FUSE_F_FVLR = -21 integer, parameter :: ovm_FUSE_SP_FF = -22 integer, parameter :: ovm_FUSE_F_SPF = -23 integer, parameter :: ovm_FUSE_F_FSP = -24 integer, parameter :: ovm_FUSE_S_FF = -25 integer, parameter :: ovm_FUSE_F_SF = -26 integer, parameter :: ovm_FUSE_F_FS = -27 integer, parameter :: ovm_FUSE_P_FF = -28 integer, parameter :: ovm_FUSE_F_PF = -29 integer, parameter :: ovm_FUSE_F_FP = -30 integer, parameter :: ovm_FUSE_SL_FF = -31 integer, parameter :: ovm_FUSE_F_SLF = -32 integer, parameter :: ovm_FUSE_F_FSL = -33 integer, parameter :: ovm_FUSE_SR_FF = -34 integer, parameter :: ovm_FUSE_F_SRF = -35 integer, parameter :: ovm_FUSE_F_FSR = -36 integer, parameter :: ovm_FUSE_SLR_FF = -37 integer, parameter :: ovm_FUSE_F_SLRF = -38 integer, parameter :: ovm_FUSE_F_FSLR = -39 integer, parameter :: ovm_FUSE_G_GG = -40 integer, parameter :: ovm_FUSE_V_SS = -41 integer, parameter :: ovm_FUSE_S_VV = -42 integer, parameter :: ovm_FUSE_S_VS = -43 integer, parameter :: ovm_FUSE_V_SV = -44 integer, parameter :: ovm_FUSE_S_SS = -45 integer, parameter :: ovm_FUSE_S_SVV = -46 integer, parameter :: ovm_FUSE_V_SSV = -47 integer, parameter :: ovm_FUSE_S_SSS = -48 integer, parameter :: ovm_FUSE_V_VVV = -49 integer, parameter :: ovm_FUSE_S_G2 = -50 integer, parameter :: ovm_FUSE_G_SG = -51 integer, parameter :: ovm_FUSE_G_GS = -52 integer, parameter :: ovm_FUSE_S_G2_SKEW = -53 integer, parameter :: ovm_FUSE_G_SG_SKEW = -54 integer, parameter :: ovm_FUSE_G_GS_SKEW = -55 @ Shorthands <

>= vm%momenta(i(5)) <>= vm%mass(i(2)) <>= vm%momenta(curr(6)) <>= vm%momenta(curr(8)) <>= vm%vectors(curr(5))%v <>= vm%vectors(curr(7))%v <>= vm%scalars(curr(5))%v <>= vm%scalars(curr(7))%v <>= sgn_coupl_cmplx(vm, curr(2)) <>= sgn_coupl_cmplx2(vm, curr(2), 1) <>= sgn_coupl_cmplx2(vm, curr(2), 2) @ <>= if ((i(4) == o%cols(1)) .or. (i(4) == o%cols(2)) .or. & ((mode%col_MC .eq. FULL_SUM) .or. (mode%col_MC .eq. DIAG_COL))) then @ Just a stub for now. Will be reimplemented with the polymorph type [[color]] similar to the [[select type(helicity)]] when we need it. <>= @ <<[[case]]s of [[decode]]>>= case (ovm_CALC_BRAKET) <> tmp = instruction_index + 1 do if (tmp > vm%N_instructions) exit curr = vm%instructions(:, tmp) if (curr(1) >= 0) exit ! End of fusions select case (curr(1)) case (ovm_FUSE_V_FF, ovm_FUSE_VL_FF, ovm_FUSE_VR_FF) braket = vm%vectors(curr(4))%v * vec_ff(vm, curr) case (ovm_FUSE_F_VF, ovm_FUSE_F_VLF, ovm_FUSE_F_VRF) braket = vm%conjspinors(curr(4))%v * ferm_vf(vm, curr) case (ovm_FUSE_F_FV, ovm_FUSE_F_FVL, ovm_FUSE_F_FVR) braket = ferm_fv(vm, curr) * vm%spinors(curr(4))%v case (ovm_FUSE_VA_FF) braket = vm%vectors(curr(4))%v * vec_ff2(vm, curr) case (ovm_FUSE_F_VAF) braket = vm%conjspinors(curr(4))%v * ferm_vf2(vm, curr) case (ovm_FUSE_F_FVA) braket = ferm_fv2(vm, curr) * vm%spinors(curr(4))%v case (ovm_FUSE_S_FF, ovm_FUSE_SP_FF) braket = vm%scalars(curr(4))%v * scal_ff(vm, curr) case (ovm_FUSE_F_SF, ovm_FUSE_F_SPF) braket = vm%conjspinors(curr(4))%v * ferm_sf(vm, curr) case (ovm_FUSE_F_FS, ovm_FUSE_F_FSP) braket = ferm_fs(vm, curr) * vm%spinors(curr(4))%v case (ovm_FUSE_G_GG) braket = vm%vectors(curr(4))%v * & g_gg(<>, & <>, <>, & <>, <>) case (ovm_FUSE_S_VV) braket = vm%scalars(curr(4))%v * <> * & (<> * vm%vectors(curr(6))%v) case (ovm_FUSE_V_SS) braket = vm%vectors(curr(4))%v * & v_ss(<>, <>, <>, & <>, <>) case (ovm_FUSE_S_G2, ovm_FUSE_S_G2_SKEW) braket = vm%scalars(curr(4))%v * scal_g2(vm, curr) case (ovm_FUSE_G_SG, ovm_FUSE_G_GS, ovm_FUSE_G_SG_SKEW, ovm_FUSE_G_GS_SKEW) braket = vm%vectors(curr(4))%v * gauge_sg(vm, curr) case (ovm_FUSE_S_VS) braket = vm%scalars(curr(4))%v * & s_vs(<>, & <>, <>, & <>, <>) case (ovm_FUSE_V_SV) braket = (vm%vectors(curr(4))%v * vm%vectors(curr(6))%v) * & (<> * <>) case (ovm_FUSE_S_SS) braket = vm%scalars(curr(4))%v * & <> * & (<> * vm%scalars(curr(6))%v) case (ovm_FUSE_S_SSS) braket = vm%scalars(curr(4))%v * & <> * & (<> * vm%scalars(curr(6))%v * & <>) case (ovm_FUSE_S_SVV) braket = vm%scalars(curr(4))%v * & <> * & <> * (vm%vectors(curr(6))%v * & <>) case (ovm_FUSE_V_SSV) braket = vm%vectors(curr(4))%v * & (<> * <> * & vm%scalars(curr(6))%v) * <> case (ovm_FUSE_V_VVV) braket = <> * & (<> * vm%vectors(curr(6))%v) * & (vm%vectors(curr(4))%v * <>) case default print *, 'Braket', curr(1), 'not implemented' stop 1 end select vm%amplitudes(i(4)) = vm%amplitudes(i(4)) + curr(3) * braket tmp = tmp + 1 end do vm%amplitudes(i(4)) = vm%amplitudes(i(4)) * i(2) if (i(5) > 1) then vm%amplitudes(i(4)) = vm%amplitudes(i(4)) * & ! Symmetry factor (one / sqrt(real(i(5), kind=default))) end if @ \subsubsection{Propagators} <>= integer, parameter :: ovm_PROPAGATE_SCALAR = 51 integer, parameter :: ovm_PROPAGATE_COL_SCALAR = 52 integer, parameter :: ovm_PROPAGATE_GHOST = 53 integer, parameter :: ovm_PROPAGATE_SPINOR = 54 integer, parameter :: ovm_PROPAGATE_CONJSPINOR = 55 integer, parameter :: ovm_PROPAGATE_MAJORANA = 56 integer, parameter :: ovm_PROPAGATE_COL_MAJORANA = 57 integer, parameter :: ovm_PROPAGATE_UNITARITY = 58 integer, parameter :: ovm_PROPAGATE_COL_UNITARITY = 59 integer, parameter :: ovm_PROPAGATE_FEYNMAN = 60 integer, parameter :: ovm_PROPAGATE_COL_FEYNMAN = 61 integer, parameter :: ovm_PROPAGATE_VECTORSPINOR = 62 integer, parameter :: ovm_PROPAGATE_TENSOR2 = 63 integer, parameter :: ovm_PROPAGATE_NONE = 64 @ <>= if ((mode%col_MC .eq. FULL_SUM) .or. (mode%col_MC .eq. DIAG_COL)) then select case(i(1)) case (ovm_PROPAGATE_PSI) go = .not. vm%spinors%c(i(4)) case (ovm_PROPAGATE_PSIBAR) go = .not. vm%conjspinors%c(i(4)) case (ovm_PROPAGATE_UNITARITY, ovm_PROPAGATE_FEYNMAN, & ovm_PROPAGATE_COL_FEYNMAN) go = .not. vm%vectors%c(i(4)) end select else go = (i(8) == o%cols(1)) .or. (i(8) == o%cols(2)) end if if (go) then <<[[case]]s of [[decode]]>>= <> case (ovm_PROPAGATE_SCALAR : ovm_PROPAGATE_NONE) tmp = instruction_index + 1 do curr = vm%instructions(:,tmp) if (curr(1) >= 0) exit ! End of fusions select case (curr(1)) case (ovm_FUSE_V_FF, ovm_FUSE_VL_FF, ovm_FUSE_VR_FF) vm%vectors(curr(4))%v = vm%vectors(curr(4))%v + curr(3) * & vec_ff(vm, curr) case (ovm_FUSE_F_VF, ovm_FUSE_F_VLF, ovm_FUSE_F_VRF) vm%spinors(curr(4))%v = vm%spinors(curr(4))%v + curr(3) * & ferm_vf(vm, curr) case (ovm_FUSE_F_FV, ovm_FUSE_F_FVL, ovm_FUSE_F_FVR) vm%conjspinors(curr(4))%v = vm%conjspinors(curr(4))%v + curr(3) * & ferm_fv(vm, curr) case (ovm_FUSE_VA_FF) vm%vectors(curr(4))%v = vm%vectors(curr(4))%v + curr(3) * & vec_ff2(vm, curr) case (ovm_FUSE_F_VAF) vm%spinors(curr(4))%v = vm%spinors(curr(4))%v + curr(3) * & ferm_vf2(vm, curr) case (ovm_FUSE_F_FVA) vm%conjspinors(curr(4))%v = vm%conjspinors(curr(4))%v + curr(3) * & ferm_fv2(vm, curr) case (ovm_FUSE_S_FF, ovm_FUSE_SP_FF) vm%scalars(curr(4))%v = vm%scalars(curr(4))%v + curr(3) * & scal_ff(vm, curr) case (ovm_FUSE_F_SF, ovm_FUSE_F_SPF) vm%spinors(curr(4))%v = vm%spinors(curr(4))%v + curr(3) * & ferm_sf(vm, curr) case (ovm_FUSE_F_FS, ovm_FUSE_F_FSP) vm%conjspinors(curr(4))%v = vm%conjspinors(curr(4))%v + curr(3) * & ferm_fs(vm, curr) case (ovm_FUSE_G_GG) vm%vectors(curr(4))%v = vm%vectors(curr(4))%v + curr(3) * & g_gg(<>, <>, & <>, <>, & <>) case (ovm_FUSE_S_VV) vm%scalars(curr(4))%v = vm%scalars(curr(4))%v + curr(3) * & <> * & (<> * vm%vectors(curr(6))%v) case (ovm_FUSE_V_SS) vm%vectors(curr(4))%v = vm%vectors(curr(4))%v + curr(3) * & v_ss(<>, <>, <>, & <>, <>) case (ovm_FUSE_S_G2, ovm_FUSE_S_G2_SKEW) vm%scalars(curr(4))%v = vm%scalars(curr(4))%v + & scal_g2(vm, curr) * curr(3) case (ovm_FUSE_G_SG, ovm_FUSE_G_GS, ovm_FUSE_G_SG_SKEW, ovm_FUSE_G_GS_SKEW) vm%vectors(curr(4))%v = vm%vectors(curr(4))%v + & gauge_sg(vm, curr) * curr(3) case (ovm_FUSE_S_VS) vm%scalars(curr(4))%v = vm%scalars(curr(4))%v + & s_vs(<>, & <>, <>, & <>, <>) * curr(3) case (ovm_FUSE_V_SV) vm%vectors(curr(4))%v = vm%vectors(curr(4))%v + & vm%vectors(curr(6))%v * & (<> * <> * curr(3)) case (ovm_FUSE_S_SS) vm%scalars(curr(4))%v = vm%scalars(curr(4))%v + & <> * & (<> * vm%scalars(curr(6))%v) * curr(3) case (ovm_FUSE_S_SSS) vm%scalars(curr(4))%v = vm%scalars(curr(4))%v + & <> * & (<> * vm%scalars(curr(6))%v * & <>) * curr(3) case (ovm_FUSE_S_SVV) vm%scalars(curr(4))%v = vm%scalars(curr(4))%v + & <> * & <> * (vm%vectors(curr(6))%v * & <>) * curr(3) case (ovm_FUSE_V_SSV) vm%vectors(curr(4))%v = vm%vectors(curr(4))%v + & (<> * <> * & vm%scalars(curr(6))%v) * <> * curr(3) case (ovm_FUSE_V_VVV) vm%vectors(curr(4))%v = vm%vectors(curr(4))%v + & (<> * (<> * & vm%vectors(curr(6))%v)) * curr(3) * <> case default print *, 'Fusion', curr(1), 'not implemented' stop 1 end select tmp = tmp + 1 end do select case (i(3)) case (0) w = zero case (1) w = vm%width(i(2)) vm%cms = .false. case (2) w = wd_tl(<

>, vm%width(i(2))) case (3) w = vm%width(i(2)) vm%cms = .true. case (4) w = wd_run(<

>, <>, vm%width(i(2))) case default print *, 'not implemented' stop 1 end select select case (i(1)) <> end select @ <>= case (ovm_PROPAGATE_SCALAR) vm%scalars(i(4))%v = pr_phi(<

>, <>, & w, vm%scalars(i(4))%v) vm%scalars(i(4))%c = .True. case (ovm_PROPAGATE_COL_SCALAR) vm%scalars(i(4))%v = - one / N_ * pr_phi(<

>, & <>, w, vm%scalars(i(4))%v) vm%scalars(i(4))%c = .True. case (ovm_PROPAGATE_GHOST) vm%scalars(i(4))%v = imago * pr_phi(<

>, <>, & w, vm%scalars(i(4))%v) vm%scalars(i(4))%c = .True. case (ovm_PROPAGATE_SPINOR) vm%spinors(i(4))%v = pr_psi(<

>, <>, & w, vm%cms, vm%spinors(i(4))%v) vm%spinors(i(4))%c = .True. case (ovm_PROPAGATE_CONJSPINOR) vm%conjspinors(i(4))%v = pr_psibar(<

>, <>, & w, vm%cms, vm%conjspinors(i(4))%v) vm%conjspinors(i(4))%c = .True. case (ovm_PROPAGATE_MAJORANA) vm%bispinors(i(4))%v = bi_pr_psi(<

>, <>, & w, vm%cms, vm%bispinors(i(4))%v) vm%bispinors(i(4))%c = .True. case (ovm_PROPAGATE_COL_MAJORANA) vm%bispinors(i(4))%v = (- one / N_) * & bi_pr_psi(<

>, <>, & w, vm%cms, vm%bispinors(i(4))%v) vm%bispinors(i(4))%c = .True. case (ovm_PROPAGATE_UNITARITY) vm%vectors(i(4))%v = pr_unitarity(<

>, <>, & w, vm%cms, vm%vectors(i(4))%v) vm%vectors(i(4))%c = .True. case (ovm_PROPAGATE_COL_UNITARITY) vm%vectors(i(4))%v = - one / N_ * pr_unitarity(<

>, & <>, w, vm%cms, vm%vectors(i(4))%v) vm%vectors(i(4))%c = .True. case (ovm_PROPAGATE_FEYNMAN) vm%vectors(i(4))%v = pr_feynman(<

>, vm%vectors(i(4))%v) vm%vectors(i(4))%c = .True. case (ovm_PROPAGATE_COL_FEYNMAN) vm%vectors(i(4))%v = - one / N_ * & pr_feynman(<

>, vm%vectors(i(4))%v) vm%vectors(i(4))%c = .True. case (ovm_PROPAGATE_VECTORSPINOR) vm%vectorspinors(i(4))%v = pr_grav(<

>, <>, & w, vm%vectorspinors(i(4))%v) vm%vectorspinors(i(4))%c = .True. case (ovm_PROPAGATE_TENSOR2) vm%tensors_2(i(4))%v = pr_tensor(<

>, <>, & w, vm%tensors_2(i(4))%v) vm%tensors_2(i(4))%c = .True. case (ovm_PROPAGATE_NONE) ! This will not work with color MC. Appropriate type%c has to be set to ! .True. @ \subsection{Helper functions} Factoring out these parts helps a lot to keep sane but might hurt the performance of the VM noticably. In that case, we have to copy \& paste to avoid the additional function calls. Note that with preprocessor macros, we could maintain this factorized form (and factor out even more since types don't have to match), in case we would decide to allow this <>= !select type (h) !type is (hel_trigonometric) !wf%v = (cos (h%theta) * load_wf (m, p, + 1) + & !sin (h%theta) * load_wf (m, p, - 1)) * sqrt2 !type is (hel_exponential) !wf%v = exp (+ imago * h%phi) * load_wf (m, p, + 1) + & !exp (- imago * h%phi) * load_wf (m, p, - 1) !type is (hel_spherical) !wf%v = (exp (+ imago * h%phi) * cos (h%theta) * load_wf (m, p, + 1) + & !exp (- imago * h%phi) * sin (h%theta) * load_wf (m, p, - 1)) * & !sqrt2 !type is(hel_discrete) !wf%v = load_wf (m, p, h%i) !end select wf%v = load_wf (m, p, h) wf%c = .True. @ Caveat: Helicity MC not tested with Majorana particles but should be fine <>= if ((mode%col_MC .eq. FULL_SUM) .or. (mode%col_MC .eq. DIAG_COL)) then go = .not. vm%spinors%c(i(4)) else go = (i(8) == o%cols(1)) .or. (i(8) == o%cols(2)) end if if (go) .. <>= subroutine load_bispinor(wf, p, m, h, opcode) type(vm_bispinor), intent(out) :: wf type(momentum), intent(in) :: p real(default), intent(in) :: m !class(helicity_t), intent(in) :: h integer, intent(in) :: h integer, intent(in) :: opcode procedure(bi_u), pointer :: load_wf <> select case (opcode) case (ovm_LOAD_MAJORANA_INC) load_wf => bi_u case (ovm_LOAD_MAJORANA_OUT) load_wf => bi_v case default load_wf => null() end select <> end subroutine load_bispinor subroutine load_spinor(wf, p, m, h, opcode) type(vm_spinor), intent(out) :: wf type(momentum), intent(in) :: p real(default), intent(in) :: m !class(helicity_t), intent(in) :: h integer, intent(in) :: h integer, intent(in) :: opcode procedure(u), pointer :: load_wf <> select case (opcode) case (ovm_LOAD_SPINOR_INC) load_wf => u case (ovm_LOAD_SPINOR_OUT) load_wf => v case default load_wf => null() end select <> end subroutine load_spinor subroutine load_conjspinor(wf, p, m, h, opcode) type(vm_conjspinor), intent(out) :: wf type(momentum), intent(in) :: p real(default), intent(in) :: m !class(helicity_t), intent(in) :: h integer, intent(in) :: h integer, intent(in) :: opcode procedure(ubar), pointer :: load_wf <> select case (opcode) case (ovm_LOAD_CONJSPINOR_INC) load_wf => vbar case (ovm_LOAD_CONJSPINOR_OUT) load_wf => ubar case default load_wf => null() end select <> end subroutine load_conjspinor subroutine load_vector(wf, p, m, h, opcode) type(vm_vector), intent(out) :: wf type(momentum), intent(in) :: p real(default), intent(in) :: m !class(helicity_t), intent(in) :: h integer, intent(in) :: h integer, intent(in) :: opcode procedure(eps), pointer :: load_wf <> load_wf => eps <> if (opcode == ovm_LOAD_VECTOR_OUT) then wf%v = conjg(wf%v) end if end subroutine load_vector @ <>= function ferm_vf(vm, curr) result (x) type(spinor) :: x class(vm_t), intent(in) :: vm integer, dimension(:), intent(in) :: curr procedure(f_vf), pointer :: load_wf select case (curr(1)) case (ovm_FUSE_F_VF) load_wf => f_vf case (ovm_FUSE_F_VLF) load_wf => f_vlf case (ovm_FUSE_F_VRF) load_wf => f_vrf case default load_wf => null() end select x = load_wf(<>, <>, vm%spinors(curr(6))%v) end function ferm_vf function ferm_vf2(vm, curr) result (x) type(spinor) :: x class(vm_t), intent(in) :: vm integer, dimension(:), intent(in) :: curr procedure(f_vaf), pointer :: load_wf select case (curr(1)) case (ovm_FUSE_F_VAF) load_wf => f_vaf case default load_wf => null() end select x = f_vaf(<>, <>, <>, vm%spinors(curr(6))%v) end function ferm_vf2 function ferm_sf(vm, curr) result (x) type(spinor) :: x class(vm_t), intent(in) :: vm integer, dimension(:), intent(in) :: curr select case (curr(1)) case (ovm_FUSE_F_SF) x = f_sf(<>, <>, vm%spinors(curr(6))%v) case (ovm_FUSE_F_SPF) x = f_spf(<>, <>, <>, vm%spinors(curr(6))%v) case default end select end function ferm_sf function ferm_fv(vm, curr) result (x) type(conjspinor) :: x class(vm_t), intent(in) :: vm integer, dimension(:), intent(in) :: curr procedure(f_fv), pointer :: load_wf select case (curr(1)) case (ovm_FUSE_F_FV) load_wf => f_fv case (ovm_FUSE_F_FVL) load_wf => f_fvl case (ovm_FUSE_F_FVR) load_wf => f_fvr case default load_wf => null() end select x = load_wf(<>, vm%conjspinors(curr(5))%v, vm%vectors(curr(6))%v) end function ferm_fv function ferm_fv2(vm, curr) result (x) type(conjspinor) :: x class(vm_t), intent(in) :: vm integer, dimension(:), intent(in) :: curr procedure(f_fva), pointer :: load_wf select case (curr(1)) case (ovm_FUSE_F_FVA) load_wf => f_fva case default load_wf => null() end select x = f_fva(<>, <>, & vm%conjspinors(curr(5))%v, vm%vectors(curr(6))%v) end function ferm_fv2 function ferm_fs(vm, curr) result (x) type(conjspinor) :: x class(vm_t), intent(in) :: vm integer, dimension(:), intent(in) :: curr procedure(f_fs), pointer :: load_wf select case (curr(1)) case (ovm_FUSE_F_FS) x = f_fs(<>, vm%conjspinors(curr(5))%v, vm%scalars(curr(6))%v) case (ovm_FUSE_F_FSP) x = f_fsp(<>, <>, & vm%conjspinors(curr(5))%v, vm%scalars(curr(6))%v) case default x%a = zero end select end function ferm_fs function vec_ff(vm, curr) result (x) type(vector) :: x class(vm_t), intent(in) :: vm integer, dimension(:), intent(in) :: curr procedure(v_ff), pointer :: load_wf select case (curr(1)) case (ovm_FUSE_V_FF) load_wf => v_ff case (ovm_FUSE_VL_FF) load_wf => vl_ff case (ovm_FUSE_VR_FF) load_wf => vr_ff case default load_wf => null() end select x = load_wf(<>, vm%conjspinors(curr(5))%v, vm%spinors(curr(6))%v) end function vec_ff function vec_ff2(vm, curr) result (x) type(vector) :: x class(vm_t), intent(in) :: vm integer, dimension(:), intent(in) :: curr procedure(va_ff), pointer :: load_wf select case (curr(1)) case (ovm_FUSE_VA_FF) load_wf => va_ff case default load_wf => null() end select x = load_wf(<>, <>, & vm%conjspinors(curr(5))%v, vm%spinors(curr(6))%v) end function vec_ff2 function scal_ff(vm, curr) result (x) complex(default) :: x class(vm_t), intent(in) :: vm integer, dimension(:), intent(in) :: curr select case (curr(1)) case (ovm_FUSE_S_FF) x = s_ff(<>, & vm%conjspinors(curr(5))%v, vm%spinors(curr(6))%v) case (ovm_FUSE_SP_FF) x = sp_ff(<>, <>, & vm%conjspinors(curr(5))%v, vm%spinors(curr(6))%v) case default x = zero end select end function scal_ff function scal_g2(vm, curr) result (x) complex(default) :: x class(vm_t), intent(in) :: vm integer, dimension(:), intent(in) :: curr select case (curr(1)) case (ovm_FUSE_S_G2) x = <> * ((<> * <>) * & (<> * <>) - & (<> * <>) * & (<> * <>)) case (ovm_FUSE_S_G2_SKEW) x = - phi_vv(<>, <>, <>, & <>, <>) case default x = zero end select end function scal_g2 pure function gauge_sg(vm, curr) result (x) type(vector) :: x class(vm_t), intent(in) :: vm integer, dimension(:), intent(in) :: curr select case (curr(1)) case (ovm_FUSE_G_SG) x = <> * <> * ( & -((<> + <>) * & <>) * <> - & (-(<> + <>) * & <>) * <>) case (ovm_FUSE_G_GS) x = <> * <> * ( & -((<> + <>) * & <>) * <> - & (-(<> + <>) * & <>) * <>) case (ovm_FUSE_G_SG_SKEW) x = - v_phiv(<>, <>, <>, & <>, <>) case (ovm_FUSE_G_GS_SKEW) x = - v_phiv(<>, <>, <>, & <>, <>) case default x = [zero, zero, zero, zero] end select end function gauge_sg @ Some really tiny ones that hopefully get inlined by the compiler <>= elemental function sgn_coupl_cmplx(vm, j) result (s) class(vm_t), intent(in) :: vm integer, intent(in) :: j complex(default) :: s s = isign(1, j) * vm%coupl_cmplx(abs(j)) end function sgn_coupl_cmplx elemental function sgn_coupl_cmplx2(vm, j, i) result (s) class(vm_t), intent(in) :: vm integer, intent(in) :: j, i complex(default) :: s if (i == 1) then s = isign(1, j) * vm%coupl_cmplx2(i, abs(j)) else s = isign(1, j) * vm%coupl_cmplx2(i, abs(j)) end if end function sgn_coupl_cmplx2 elemental function int_to_log(i) result(yorn) integer, intent(in) :: i logical :: yorn if (i /= 0) then yorn = .true. else yorn = .false. end if end function elemental function color_factor(num, den, pwr) result (cf) integer, intent(in) :: num, den, pwr real(kind=default) :: cf if (pwr == 0) then cf = (one * num) / den else cf = (one * num) / den * (N_**pwr) end if end function color_factor @ \subsection{O'Mega Interface} We want to keep the interface close to the native Fortran code but of course one has to hand over the [[vm]] additionally <>= procedure :: number_particles_in => vm_number_particles_in procedure :: number_particles_out => vm_number_particles_out procedure :: number_color_indices => vm_number_color_indices procedure :: reset_helicity_selection => vm_reset_helicity_selection procedure :: new_event => vm_new_event procedure :: color_sum => vm_color_sum procedure :: spin_states => vm_spin_states procedure :: number_spin_states => vm_number_spin_states procedure :: number_color_flows => vm_number_color_flows procedure :: flavor_states => vm_flavor_states procedure :: number_flavor_states => vm_number_flavor_states procedure :: color_flows => vm_color_flows procedure :: color_factors => vm_color_factors procedure :: number_color_factors => vm_number_color_factors procedure :: is_allowed => vm_is_allowed procedure :: get_amplitude => vm_get_amplitude @ <>= elemental function vm_number_particles_in (vm) result (n) class(vm_t), intent(in) :: vm integer :: n n = vm%N_prt_in end function vm_number_particles_in elemental function vm_number_particles_out (vm) result (n) class(vm_t), intent(in) :: vm integer :: n n = vm%N_prt_out end function vm_number_particles_out elemental function vm_number_spin_states (vm) result (n) class(vm_t), intent(in) :: vm integer :: n n = vm%N_helicities end function vm_number_spin_states pure subroutine vm_spin_states (vm, a) class(vm_t), intent(in) :: vm integer, dimension(:,:), intent(out) :: a a = vm%table_spin end subroutine vm_spin_states elemental function vm_number_flavor_states (vm) result (n) class(vm_t), intent(in) :: vm integer :: n n = vm%N_flavors end function vm_number_flavor_states pure subroutine vm_flavor_states (vm, a) class(vm_t), intent(in) :: vm integer, dimension(:,:), intent(out) :: a a = vm%table_flavor end subroutine vm_flavor_states elemental function vm_number_color_indices (vm) result (n) class(vm_t), intent(in) :: vm integer :: n n = vm%N_col_indices end function vm_number_color_indices elemental function vm_number_color_flows (vm) result (n) class(vm_t), intent(in) :: vm integer :: n n = vm%N_col_flows end function vm_number_color_flows pure subroutine vm_color_flows (vm, a, g) class(vm_t), intent(in) :: vm integer, dimension(:,:,:), intent(out) :: a logical, dimension(:,:), intent(out) :: g a = vm%table_color_flows g = vm%table_ghost_flags end subroutine vm_color_flows elemental function vm_number_color_factors (vm) result (n) class(vm_t), intent(in) :: vm integer :: n n = vm%N_col_factors end function vm_number_color_factors pure subroutine vm_color_factors (vm, cf) class(vm_t), intent(in) :: vm type(OCF), dimension(:), intent(out) :: cf cf = vm%table_color_factors end subroutine vm_color_factors ! pure & ! pure unless OpenMp function vm_color_sum (vm, flv, hel) result (amp2) class(vm_t), intent(in) :: vm integer, intent(in) :: flv, hel real(default) :: amp2 amp2 = ovm_color_sum (flv, hel, vm%table_amplitudes, vm%table_color_factors) end function vm_color_sum subroutine vm_new_event (vm, p) class(vm_t), intent(inout) :: vm real(default), dimension(0:3,*), intent(in) :: p logical :: mask_dirty integer :: hel call vm%run (p) if ((vm%hel_threshold .gt. 0) .and. (vm%hel_count .le. vm%hel_cutoff)) then call omega_update_helicity_selection (vm%hel_count, vm%table_amplitudes, & vm%hel_max_abs, vm%hel_sum_abs, vm%hel_is_allowed, vm%hel_threshold, & vm%hel_cutoff, mask_dirty) if (mask_dirty) then vm%hel_finite = 0 do hel = 1, vm%N_helicities if (vm%hel_is_allowed(hel)) then vm%hel_finite = vm%hel_finite + 1 vm%hel_map(vm%hel_finite) = hel end if end do end if end if end subroutine vm_new_event pure subroutine vm_reset_helicity_selection (vm, threshold, cutoff) class(vm_t), intent(inout) :: vm real(kind=default), intent(in) :: threshold integer, intent(in) :: cutoff integer :: i vm%hel_is_allowed = .True. vm%hel_max_abs = 0 vm%hel_sum_abs = 0 vm%hel_count = 0 vm%hel_threshold = threshold vm%hel_cutoff = cutoff vm%hel_map = (/(i, i = 1, vm%N_helicities)/) vm%hel_finite = vm%N_helicities end subroutine vm_reset_helicity_selection pure function vm_is_allowed (vm, flv, hel, col) result (yorn) class(vm_t), intent(in) :: vm logical :: yorn integer, intent(in) :: flv, hel, col yorn = vm%table_flv_col_is_allowed(flv,col) .and. vm%hel_is_allowed(hel) end function vm_is_allowed pure function vm_get_amplitude (vm, flv, hel, col) result (amp_result) class(vm_t), intent(in) :: vm complex(kind=default) :: amp_result integer, intent(in) :: flv, hel, col amp_result = vm%table_amplitudes(flv, col, hel) end function vm_get_amplitude @ @ %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% <>= ! omegalib.nw -- ! ! Copyright (C) 1999-2020 by ! Wolfgang Kilian ! Thorsten Ohl ! Juergen Reuter ! with contributions from ! Fabian Bach ! Bijan Chokoufe Nejad ! 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. ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! @ %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% Index: trunk/omega/tests/Makefile.am =================================================================== --- trunk/omega/tests/Makefile.am (revision 8475) +++ trunk/omega/tests/Makefile.am (revision 8476) @@ -1,979 +1,1023 @@ # Makefile.am -- Makefile for O'Mega within and without WHIZARD ## ## Process this file with automake to produce Makefile.in ## ######################################################################## # # Copyright (C) 1999-2020 by # Wolfgang Kilian # Thorsten Ohl # Juergen Reuter # with contributions from # cf. main AUTHORS file # # WHIZARD is free software; you can redistribute it and/or modify it # under the terms of the GNU General Public License as published by # the Free Software Foundation; either version 2, or (at your option) # any later version. # # WHIZARD is distributed in the hope that it will be useful, but # WITHOUT ANY WARRANTY; without even the implied warranty of # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the # GNU General Public License for more details. # # You should have received a copy of the GNU General Public License # along with this program; if not, write to the Free Software # Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. # ######################################################################## SUBDIRS = UFO DIST_SUBDIRS = UFO # OMEGA_SPLIT = -target:single_function OMEGA_SPLIT = -target:split_function 10 # OMEGA_SPLIT = -target:split_module 10 # OMEGA_SPLIT = -target:split_file 10 OMEGA_QED = $(top_builddir)/omega/bin/omega_QED$(OCAML_NATIVE_EXT) OMEGA_QED_OPTS = $(OMEGA_SPLIT) -target:parameter_module parameters_QED OMEGA_QCD = $(top_builddir)/omega/bin/omega_QCD$(OCAML_NATIVE_EXT) OMEGA_QCD_OPTS = $(OMEGA_SPLIT) -target:parameter_module parameters_QCD OMEGA_SYM = $(top_builddir)/omega/bin/omega_SYM$(OCAML_NATIVE_EXT) OMEGA_SYM_OPTS = $(OMEGA_SPLIT) -target:parameter_module parameters_SYM OMEGA_SM = $(top_builddir)/omega/bin/omega_SM$(OCAML_NATIVE_EXT) OMEGA_SM_OPTS = $(OMEGA_SPLIT) -target:parameter_module parameters_SM OMEGA_SM_CKM = $(top_builddir)/omega/bin/omega_SM_CKM$(OCAML_NATIVE_EXT) OMEGA_SM_Higgs = $(top_builddir)/omega/bin/omega_SM_Higgs$(OCAML_NATIVE_EXT) OMEGA_THDM = $(top_builddir)/omega/bin/omega_THDM$(OCAML_NATIVE_EXT) OMEGA_THDM_CKM = $(top_builddir)/omega/bin/omega_THDM_CKM$(OCAML_NATIVE_EXT) OMEGA_HSExt = $(top_builddir)/omega/bin/omega_HSExt$(OCAML_NATIVE_EXT) OMEGA_Zprime = $(top_builddir)/omega/bin/omega_Zprime$(OCAML_NATIVE_EXT) OMEGA_SM_top_anom = $(top_builddir)/omega/bin/omega_SM_top_anom$(OCAML_NATIVE_EXT) OMEGA_SM_top_anom_OPTS = $(OMEGA_SPLIT) -target:parameter_module parameters_SM_top_anom OMEGA_UFO = $(top_builddir)/omega/bin/omega_UFO$(OCAML_NATIVE_EXT) OMEGA_UFO_MAJORANA = \ $(top_builddir)/omega/bin/omega_UFO_Majorana$(OCAML_NATIVE_EXT) OMEGA_UFO_OPTS = -target:parameter_module parameters_UFO OMEGA_UFO_PATH = $(top_srcdir)/omega/tests/UFO OMEGA_XXX = $(top_builddir)/omega/bin/omega_%%%$(OCAML_NATIVE_EXT) OMEGA_XXX_OPTS = -target:parameter_module parameters_%%% OMEGA_UFO_XXX_OPTS = \ "-model:UFO_dir $(top_srcdir)/omega/tests/UFO/%%%/ -model:exec" OMEGA_XXX_MAJORANA = \ $(top_builddir)/omega/bin/omega_%%%_Majorana$(OCAML_NATIVE_EXT) OMEGA_XXX_MAJORANA_LEGACY = \ $(top_builddir)/omega/bin/omega_%%%_Majorana_legacy$(OCAML_NATIVE_EXT) OMEGA_QED_VM = $(top_builddir)/omega/bin/omega_QED_VM$(OCAML_NATIVE_EXT) OMEGA_QCD_VM = $(top_builddir)/omega/bin/omega_QCD_VM$(OCAML_NATIVE_EXT) OMEGA_SM_VM = $(top_builddir)/omega/bin/omega_SM_VM$(OCAML_NATIVE_EXT) OMEGA_SM_CKM_VM = $(top_builddir)/omega/bin/omega_SM_CKM_VM$(OCAML_NATIVE_EXT) OMEGA_THDM_VM = $(top_builddir)/omega/bin/omega_THDM_VM$(OCAML_NATIVE_EXT) OMEGA_THDM_CKM_VM = $(top_builddir)/omega/bin/omega_THDM_CKM_VM$(OCAML_NATIVE_EXT) OMEGA_HSExt_VM = $(top_builddir)/omega/bin/omega_HSExt_VM$(OCAML_NATIVE_EXT) OMEGA_Zprime_VM = $(top_builddir)/omega/bin/omega_Zprime_VM$(OCAML_NATIVE_EXT) OMEGA_SM_Higgs_VM = $(top_builddir)/omega/bin/omega_SM_Higgs_VM$(OCAML_NATIVE_EXT) OMEGA_XXX_VM = $(top_builddir)/omega/bin/omega_%%%_VM$(OCAML_NATIVE_EXT) OMEGA_XXX_VM_PARAMS_OPTS = -params -target:parameter_module_external \ parameters_%%% -target:wrapper_module %% -target:bytecode_file % AM_FCFLAGS = -I$(top_builddir)/omega/src AM_LDFLAGS = ######################################################################## ## Default Fortran compiler options ## OpenMP if FC_USE_OPENMP AM_FCFLAGS += $(FCFLAGS_OPENMP) AM_TESTS_ENVIRONMENT = \ export OMP_NUM_THREADS=1; endif ######################################################################## TESTS = XFAIL_TESTS = EXTRA_PROGRAMS = EXTRA_DIST = ######################################################################## include $(top_srcdir)/omega/src/Makefile.ocaml if OCAML_AVAILABLE OCAMLFLAGS += -I $(top_builddir)/omega/src OMEGA_CORE = $(top_builddir)/omega/src/omega_core.cmxa OMEGA_MODELS = $(top_builddir)/omega/src/omega_models.cmxa TESTS += omega_unit EXTRA_PROGRAMS += omega_unit omega_unit_SOURCES = omega_unit.ml omega_unit: $(OMEGA_CORE) omega_unit.cmx @if $(AM_V_P); then :; else echo " OCAMLOPT " $@; fi $(AM_V_at)$(OCAMLOPT) $(OCAMLFLAGS) $(OCAMLOPTFLAGS) -o omega_unit \ unix.cmxa $(OMEGA_CORE) omega_unit.cmx omega_unit.cmx: omega_unit.ml omega_unit.cmx: $(OMEGA_CORE) endif ######################################################################## KINDS = $(top_builddir)/omega/src/kinds.lo TESTS += test_omega95 test_omega95_bispinors EXTRA_PROGRAMS += test_omega95 test_omega95_bispinors test_omega95_SOURCES = test_omega95.f90 omega_testtools.f90 test_omega95_LDADD = $(KINDS) $(top_builddir)/omega/src/libomega_core.la test_omega95_bispinors_SOURCES = test_omega95_bispinors.f90 omega_testtools.f90 test_omega95_bispinors_LDADD = $(KINDS) $(top_builddir)/omega/src/libomega_core.la test_omega95.o test_omega95_bispinors.o: omega_testtools.o if NOWEB_AVAILABLE test_omega95.f90: $(top_srcdir)/omega/src/omegalib.nw $(NOTANGLE) -R[[$@]] $< | $(CPIF) $@ test_omega95_bispinors.f90: $(top_srcdir)/omega/src/omegalib.nw $(NOTANGLE) -R[[$@]] $< | $(CPIF) $@ omega_testtools.f90: $(top_srcdir)/omega/src/omegalib.nw $(NOTANGLE) -R[[$@]] $< | $(CPIF) $@ endif NOWEB_AVAILABLE ######################################################################## if OCAML_AVAILABLE TESTS += test_qed_eemm EXTRA_PROGRAMS += test_qed_eemm test_qed_eemm_SOURCES = test_qed_eemm.f90 parameters_QED.f90 nodist_test_qed_eemm_SOURCES = amplitude_qed_eemm.f90 test_qed_eemm_LDADD = $(KINDS) $(top_builddir)/omega/src/libomega_core.la amplitude_qed_eemm.f90: $(OMEGA_QED) Makefile $(OMEGA_QED) $(OMEGA_QED_OPTS) -target:module amplitude_qed_eemm \ -scatter "e+ e- -> m+ m-" > $@ test_qed_eemm.o: amplitude_qed_eemm.o test_qed_eemm.o: parameters_QED.o amplitude_qed_eemm.o: parameters_QED.o endif ######################################################################## EXTENDED_COLOR_TESTS = \ $(srcdir)/fc_s.ects \ $(srcdir)/fc_a.ects $(srcdir)/cf_a.ects $(srcdir)/fa_f.ects \ $(srcdir)/ca_c.ects $(srcdir)/af_f.ects $(srcdir)/ac_c.ects \ $(srcdir)/aa_a.ects \ $(srcdir)/fc_fc.ects \ $(srcdir)/aa_s.ects $(srcdir)/as_a.ects $(srcdir)/sa_a.ects TESTS += ects EXTRA_PROGRAMS += ects EXTRA_DIST += ects_driver.sh $(EXTENDED_COLOR_TESTS) # Explicitly state dependence on model files ects.f90: $(OMEGA_QCD) $(OMEGA_SYM) $(OMEGA_SM) ects.f90: ects_driver.sh $(EXTENDED_COLOR_TESTS) @if $(AM_V_P); then :; else echo " ECTS_DRIVER"; fi $(AM_V_at)$(SHELL) $(srcdir)/ects_driver.sh \ $(OMEGA_XXX) $(EXTENDED_COLOR_TESTS) > $@ ects_SOURCES = color_test_lib.f90 \ parameters_SM.f90 parameters_QED.f90 parameters_QCD.f90 parameters_SYM.f90 nodist_ects_SOURCES = ects.f90 ects_LDADD = $(KINDS) $(top_builddir)/omega/src/libomega_core.la ######################################################################## TESTS += cascade # if there is some debugging output ... # XFAIL_TESTS += cascade CASCADE_TESTS = \ bhabha-s-channel.cascade bhabha-t-channel.cascade bhabha-full.cascade \ ww-onlycc.cascade ww-notgc.cascade \ jjj-notgc.cascade \ vbf-noh.cascade cascade: cascade_driver.sh Makefile $(SED) -e 's|%%cascade_tests%%|$(CASCADE_TESTS)|' \ -e 's|%%srcdir%%|$(srcdir)|' \ -e 's|%%SED%%|$(SED)|' \ -e 's|%%top_builddir%%|$(top_builddir)|' \ -e 's|%%OCAML_NATIVE_EXT%%|$(OCAML_NATIVE_EXT)|' $< >$@ chmod +x $@ EXTRA_DIST += cascade_driver.sh $(CASCADE_TESTS) ######################################################################## TESTS += phase_space PHASE_SPACE_TESTS = eeee.phs qqggg.phs phase_space: phase_space_driver.sh Makefile $(SED) -e 's|%%phase_space_tests%%|$(PHASE_SPACE_TESTS)|' \ -e 's|%%srcdir%%|$(srcdir)|' \ -e 's|%%SED%%|$(SED)|' \ -e 's|%%top_builddir%%|$(top_builddir)|' \ -e 's|%%OCAML_NATIVE_EXT%%|$(OCAML_NATIVE_EXT)|' $< >$@ chmod +x $@ EXTRA_DIST += phase_space_driver.sh $(PHASE_SPACE_TESTS) ######################################################################## TESTS += fermi # XFAIL_TESTS += fermi EXTRA_PROGRAMS += fermi EXTRA_DIST += fermi_driver.sh EXTRA_DIST += fermi.list FERMI_SUPPORT_F90 = \ omega_interface.f90 omega_testtools.f90 tao_random_numbers.f90 \ parameters_QED.f90 parameters_QCD.f90 parameters_SYM.f90 \ parameters_SM.f90 parameters_MSSM.f90 parameters_SM_top_anom.f90 FERMI_SUPPORT_O = $(FERMI_SUPPORT_F90:.f90=.o) fermi_lib.o: $(FERMI_SUPPORT_O) FERMI_LIB_F90 = fermi_lib.f90 $(FERMI_SUPPORT_F90) FERMI_LIB_O = $(FERMI_LIB_F90:.f90=.o) run_fermi: fermi ./fermi fermi.f90: fermi_driver.sh $(OMEGA_QED) $(OMEGA_QCD) $(OMEGA_SYM) fermi.f90: $(OMEGA_SM) $(OMEGA_SM_top_anom) fermi.f90: fermi.list @if $(AM_V_P); then :; else echo " FERMI_DRIVER"; fi $(AM_V_at)$(SHELL) $(srcdir)/fermi_driver.sh \ $(OMEGA_XXX) $(OMEGA_SPLIT) < $< > $@ fermi_SOURCES = $(FERMI_LIB_F90) nodist_fermi_SOURCES = fermi.f90 fermi_LDADD = $(KINDS) $(top_builddir)/omega/src/libomega_core.la fermi.o: $(FERMI_LIB_O) ######################################################################## TESTS += ward EXTRA_PROGRAMS += ward EXTRA_DIST += ward_driver.sh EXTRA_DIST += ward_identities.list WARD_SUPPORT_F90 = \ omega_interface.f90 omega_testtools.f90 tao_random_numbers.f90 \ parameters_QED.f90 parameters_QCD.f90 parameters_SYM.f90 \ parameters_SM.f90 parameters_SM_top_anom.f90 WARD_SUPPORT_O = $(WARD_SUPPORT_F90:.f90=.o) ward_lib.o: $(WARD_SUPPORT_O) WARD_LIB_F90 = ward_lib.f90 $(WARD_SUPPORT_F90) WARD_LIB_O = $(WARD_LIB_F90:.f90=.o) run_ward: ward ./ward ward.f90: ward_driver.sh $(OMEGA_QED) $(OMEGA_QCD) $(OMEGA_SYM) ward.f90: $(OMEGA_SM) $(OMEGA_SM_top_anom) ward.f90: ward_identities.list @if $(AM_V_P); then :; else echo " WARD_DRIVER"; fi $(AM_V_at)$(SHELL) $(srcdir)/ward_driver.sh \ $(OMEGA_XXX) $(OMEGA_SPLIT) < $< > $@ ward_SOURCES = $(WARD_LIB_F90) nodist_ward_SOURCES = ward.f90 ward_LDADD = $(KINDS) $(top_builddir)/omega/src/libomega_core.la ward.o: $(WARD_LIB_O) ######################################################################## EXTRA_PROGRAMS += ward_long EXTRA_DIST += ward_identities_long.list run_ward_long: ward_long ./ward_long ward_long.f90: ward_driver.sh ward_long.f90: ward_identities_long.list @if $(AM_V_P); then :; else echo " WARD_DRIVER"; fi $(AM_V_at)$(SHELL) $(srcdir)/ward_driver.sh \ $(OMEGA_XXX) $(OMEGA_SPLIT) < $< > $@ ward_long_SOURCES = $(WARD_LIB_F90) nodist_ward_long_SOURCES = ward_long.f90 ward_long_LDADD = $(KINDS) $(top_builddir)/omega/src/libomega_core.la # ward_long.o: ward_long.f90 # $(FCCOMPILE) -c -o $@ $(FCFLAGS_f90) -O0 $< ward_long.o: $(WARD_LIB_O) ######################################################################## EXTRA_PROGRAMS += ward_fail EXTRA_DIST += ward_identities_fail.list run_ward_fail: ward_fail ./ward_fail ward_fail.f90: ward_driver.sh ward_fail.f90: ward_identities_fail.list @if $(AM_V_P); then :; else echo " WARD_DRIVER"; fi $(AM_V_at)$(SHELL) $(srcdir)/ward_driver.sh \ $(OMEGA_XXX) $(OMEGA_SPLIT) < $< > $@ ward_fail_SOURCES = $(WARD_LIB_F90) nodist_ward_fail_SOURCES = ward_fail.f90 ward_fail_LDADD = $(KINDS) $(top_builddir)/omega/src/libomega_core.la ward_fail.o: ward_fail.f90 $(FCCOMPILE) -c -o $@ $(FCFLAGS_f90) -O0 $< ward_fail.o: $(WARD_LIB_O) ######################################################################## TESTS += compare_split_function compare_split_module EXTRA_PROGRAMS += compare_split_function compare_split_module EXTRA_DIST += compare_driver.sh EXTRA_DIST += comparisons.list COMPARE_SUPPORT_F90 = $(WARD_SUPPORT_F90) COMPARE_SUPPORT_O = $(WARD_SUPPORT_O) compare_lib.o: $(COMPARE_SUPPORT_O) COMPARE_LIB_F90 = compare_lib.f90 $(COMPARE_SUPPORT_F90) COMPARE_LIB_O = $(COMPARE_LIB_F90:.f90=.o) run_compare: compare_split_function compare_split_module ./compare_split_function ./compare_split_module compare_split_function.f90: comparisons.list @if $(AM_V_P); then :; else echo " COMPARE_DRIVER"; fi $(AM_V_at)$(SHELL) $(srcdir)/compare_driver.sh SF \ "$(OMEGA_XXX) -target:single_function" \ "$(OMEGA_XXX) -target:split_function 10" < $< > $@ compare_split_module.f90: comparisons.list @if $(AM_V_P); then :; else echo " COMPARE_DRIVER"; fi $(AM_V_at)$(SHELL) $(srcdir)/compare_driver.sh SM \ "$(OMEGA_XXX) -target:single_function" \ "$(OMEGA_XXX) -target:split_module 10" < $< > $@ compare_split_function.f90 compare_split_module.f90: \ compare_driver.sh $(OMEGA_QCD) $(OMEGA_SM) compare_split_function_SOURCES = $(COMPARE_LIB_F90) nodist_compare_split_function_SOURCES = compare_split_function.f90 compare_split_function_LDADD = $(KINDS) $(top_builddir)/omega/src/libomega_core.la compare_split_module_SOURCES = $(COMPARE_LIB_F90) nodist_compare_split_module_SOURCES = compare_split_module.f90 compare_split_module_LDADD = $(KINDS) $(top_builddir)/omega/src/libomega_core.la compare_split_function.o compare_split_module.o: $(COMPARE_LIB_O) ######################################################################## if OCAML_AVAILABLE TESTS += compare_majorana compare_majorana_legacy compare_majorana_UFO EXTRA_PROGRAMS += compare_majorana compare_majorana_legacy compare_majorana_UFO EXTRA_DIST += compare_driver_majorana.sh compare_driver_majorana_UFO.sh EXTRA_DIST += comparisons_majorana.list comparisons_majorana_legacy.list \ comparisons_majorana_UFO.list compare_majorana.f90: comparisons_majorana.list @if $(AM_V_P); then :; else echo " COMPARE_DRIVER"; fi $(AM_V_at)$(SHELL) $(srcdir)/compare_driver_majorana.sh Maj \ "$(OMEGA_XXX)" "$(OMEGA_XXX_MAJORANA)" < $< > $@ compare_majorana_legacy.f90: comparisons_majorana_legacy.list @if $(AM_V_P); then :; else echo " COMPARE_DRIVER"; fi $(AM_V_at)$(SHELL) $(srcdir)/compare_driver_majorana.sh MajL \ "$(OMEGA_XXX)" "$(OMEGA_XXX_MAJORANA_LEGACY)" < $< > $@ compare_majorana_UFO.f90: comparisons_majorana_UFO.list @if $(AM_V_P); then :; else echo " COMPARE_DRIVER"; fi $(AM_V_at)$(SHELL) $(srcdir)/compare_driver_majorana_UFO.sh MajU \ "$(OMEGA_UFO)" "$(OMEGA_UFO_MAJORANA)" "$(OMEGA_UFO_PATH)" < $< > $@ compare_majorana.f90 compare_majorana_legacy.f90 compare_majorana_UFO.f90: \ compare_driver_majorana.sh $(OMEGA_UFO) $(OMEGA_UFO_MAJORANA) compare_majorana_SOURCES = $(COMPARE_LIB_F90) nodist_compare_majorana_SOURCES = compare_majorana.f90 compare_majorana_LDADD = $(KINDS) $(top_builddir)/omega/src/libomega_core.la compare_majorana_legacy_SOURCES = $(COMPARE_LIB_F90) nodist_compare_majorana_legacy_SOURCES = compare_majorana_legacy.f90 compare_majorana_legacy_LDADD = $(KINDS) $(top_builddir)/omega/src/libomega_core.la compare_majorana_UFO_SOURCES = $(COMPARE_LIB_F90) parameters_SM_UFO.f90 nodist_compare_majorana_UFO_SOURCES = compare_majorana_UFO.f90 compare_majorana_UFO_LDADD = $(KINDS) $(top_builddir)/omega/src/libomega_core.la compare_majorana.o compare_majorana_legacy.o compare_majorana_UFO.o: $(COMPARE_LIB_O) endif ######################################################################## if OCAML_AVAILABLE # At quadruple or extended precision, these tests take waaaaaayyyy too long! if FC_PREC else TESTS += compare_amplitude_UFO # XFAIL_TESTS += compare_amplitude_UFO EXTRA_PROGRAMS += compare_amplitude_UFO EXTRA_DIST += compare_driver_UFO.sh EXTRA_DIST += comparisons_UFO.list compare_amplitude_UFO_SOURCES = \ parameters_SM_from_UFO.f90 compare_lib.f90 \ omega_interface.f90 omega_testtools.f90 tao_random_numbers.f90 compare_amplitude_UFO.f90: comparisons_UFO.list compare_driver_UFO.sh $(OMEGA_UFO) @if $(AM_V_P); then :; else echo " COMPARE_DRIVER_UFO"; fi $(AM_V_at)$(SHELL) $(srcdir)/compare_driver_UFO.sh UFO \ "$(OMEGA_XXX) -model:constant_width" \ "$(OMEGA_UFO) -model:UFO_dir $(top_srcdir)/omega/tests/UFO/%%%/ -model:exec" \ < $< > $@ # -model:long_flavors nodist_compare_amplitude_UFO_SOURCES = \ compare_amplitude_UFO.f90 parameters_SM_UFO.f90 compare_amplitude_UFO_LDADD = $(KINDS) $(top_builddir)/omega/src/libomega_core.la parameters_SM_from_UFO.o: parameters_SM_UFO.o compare_amplitude_UFO.o: parameters_SM_UFO.o parameters_SM_from_UFO.o compare_amplitude_UFO.o: $(COMPARE_LIB_O) endif parameters_SM_UFO.f90: $(OMEGA_UFO) $(OMEGA_UFO) \ -model:UFO_dir $(top_srcdir)/omega/tests/UFO/SM/ -model:exec \ -target:parameter_module parameters_sm_ufo -params > $@ endif ######################################################################## if OCAML_AVAILABLE # At quadruple or extended precision, these tests take waaaaaayyyy too long! if FC_PREC else TESTS += fermi_UFO # XFAIL_TESTS += fermi_UFO # We need more work on the parameters to pass the tests # at quadruple or extended precision. if FC_PREC XFAIL_TESTS += fermi_UFO endif EXTRA_PROGRAMS += fermi_UFO EXTRA_DIST += fermi_driver_UFO.sh EXTRA_DIST += fermi_UFO.list FERMI_UFO_SUPPORT_F90 = \ omega_interface.f90 omega_testtools.f90 tao_random_numbers.f90 FERMI_UFO_SUPPORT_O = $(FERMI_UFO_SUPPORT_F90:.f90=.o) fermi_UFO_lib.o: $(FERMI_SUPPORT_O) FERMI_UFO_LIB_F90 = fermi_lib.f90 $(FERMI_UFO_SUPPORT_F90) FERMI_UFO_LIB_O = $(FERMI_UFO_LIB_F90:.f90=.o) run_fermi_UFO: fermi_UFO ./fermi_UFO fermi_UFO.f90: fermi_UFO.list fermi_driver_UFO.sh $(OMEGA_UFO) @if $(AM_V_P); then :; else echo " FERMI_UFO_DRIVER"; fi $(AM_V_at)$(SHELL) $(srcdir)/fermi_driver_UFO.sh \ $(OMEGA_UFO) $(OMEGA_UFO_MAJORANA) $(OMEGA_UFO_PATH) \ $(OMEGA_SPLIT) < $< > $@ fermi_UFO_SOURCES = $(FERMI_UFO_LIB_F90) nodist_fermi_UFO_SOURCES = fermi_UFO.f90 parameters_SM_UFO.f90 fermi_UFO_LDADD = $(KINDS) $(top_builddir)/omega/src/libomega_core.la fermi_UFO.o: $(FERMI_UFO_LIB_O) endif endif ######################################################################## if OCAML_AVAILABLE # At quadruple or extended precision, these tests take waaaaaayyyy too long! if FC_PREC else TESTS += ward_UFO # We need more work on the parameters to pass the tests # at quadruple or extended precision. if FC_PREC XFAIL_TESTS += ward_UFO endif EXTRA_PROGRAMS += ward_UFO EXTRA_DIST += ward_driver_UFO.sh EXTRA_DIST += ward_identities_UFO.list WARD_UFO_SUPPORT_F90 = \ omega_interface.f90 omega_testtools.f90 tao_random_numbers.f90 WARD_UFO_SUPPORT_O = $(WARD_UFO_SUPPORT_F90:.f90=.o) ward_UFO_lib.o: $(WARD_SUPPORT_O) WARD_UFO_LIB_F90 = ward_lib.f90 $(WARD_UFO_SUPPORT_F90) WARD_UFO_LIB_O = $(WARD_UFO_LIB_F90:.f90=.o) run_ward_UFO: ward_UFO ./ward_UFO ward_UFO.f90: ward_identities_UFO.list ward_driver_UFO.sh $(OMEGA_UFO) @if $(AM_V_P); then :; else echo " WARD_UFO_DRIVER"; fi $(AM_V_at)$(SHELL) $(srcdir)/ward_driver_UFO.sh \ $(OMEGA_UFO) -model:UFO_dir $(top_srcdir)/omega/tests/UFO/SM/ \ $(OMEGA_SPLIT) < $< > $@ ward_UFO_SOURCES = $(WARD_UFO_LIB_F90) nodist_ward_UFO_SOURCES = ward_UFO.f90 parameters_SM_UFO.f90 ward_UFO_LDADD = $(KINDS) $(top_builddir)/omega/src/libomega_core.la ward_UFO.o: $(WARD_UFO_LIB_O) endif endif ######################################################################## TESTS += compare_amplitude_VM EXTRA_PROGRAMS += compare_amplitude_VM EXTRA_DIST += compare_driver_VM.sh compare_driver_VM_wrappers.sh EXTRA_DIST += comparisons_VM.list compare_amplitude_VM.f90: comparisons_VM.list comparisons_VM.wrappers.o @if $(AM_V_P); then :; else echo " COMPARE_DRIVER_VM"; fi $(AM_V_at)$(SHELL) $(srcdir)/compare_driver_VM.sh \ "$(OMEGA_XXX) " "$(OMEGA_XXX_VM) " "$(OMEGA_XXX_VM_PARAMS_OPTS)" < $< > $@ comparisons_VM.wrappers.f90: comparisons_VM.list @if $(AM_V_P); then :; else echo " COMPARE_DRIVER_VM_WRAPPERS"; fi $(AM_V_at)$(SHELL) $(srcdir)/compare_driver_VM_wrappers.sh \ "$(OMEGA_XXX) " "$(OMEGA_XXX_VM) " "$(OMEGA_XXX_VM_PARAMS_OPTS)" < $< > $@ # Explicitly state dependence on model files compare_amplitude_VM.f90: compare_driver_VM.sh \ $(OMEGA_QED) $(OMEGA_QED_VM) \ $(OMEGA_QCD) $(OMEGA_QCD_VM) \ $(OMEGA_SM) $(OMEGA_SM_VM) \ $(OMEGA_SM_CKM) $(OMEGA_SM_CKM_VM) \ $(OMEGA_SM_Higgs) $(OMEGA_SM_Higgs_VM) \ $(OMEGA_THDM) $(OMEGA_THDM_VM) \ $(OMEGA_THDM_CKM) $(OMEGA_THDM_CKM_VM) \ $(OMEGA_HSExt) $(OMEGA_HSExt_VM) \ $(OMEGA_Zprime) $(OMEGA_Zprime_VM) COMPARE_EXTRA_MODELS = parameters_SM_CKM.f90 parameters_SM_Higgs.f90 \ parameters_THDM.f90 parameters_THDM_CKM.f90 parameters_HSExt.f90 \ parameters_Zprime.f90 compare_amplitude_VM_SOURCES = $(COMPARE_LIB_F90) $(COMPARE_EXTRA_MODELS) nodist_compare_amplitude_VM_SOURCES = compare_amplitude_VM.f90 comparisons_VM.wrappers.f90 compare_amplitude_VM_LDADD = $(KINDS) $(top_builddir)/omega/src/libomega_core.la compare_amplitude_VM.o: $(COMPARE_LIB_O) ######################################################################## if FC_USE_OPENMP TESTS += test_openmp EXTRA_PROGRAMS += test_openmp TESTOPENMP_SUPPORT_F90 = $(WARD_SUPPORT_F90) TESTOPENMP_SUPPORT_O = $(WARD_SUPPORT_O) test_openmp_SOURCES = test_openmp.f90 $(TESTOPENMP_SUPPORT_F90) nodist_test_openmp_SOURCES = amplitude_openmp.f90 test_openmp_LDADD = $(KINDS) $(top_builddir)/omega/src/libomega_core.la amplitude_openmp.f90: $(OMEGA_QCD) Makefile $(OMEGA_QCD) $(OMEGA_QCD_OPTS) -target:openmp \ -target:module amplitude_openmp -scatter "gl gl -> gl gl gl" > $@ test_openmp.o: amplitude_openmp.o test_openmp.o: $(TESTOPENMP_SUPPORT_O) amplitude_openmp.o: parameters_QCD.o endif ######################################################################## EXTRA_PROGRAMS += benchmark_VM_vs_Fortran EXTRA_DIST += benchmark_VM_vs_Fortran_driver.sh BENCHMARK_LIB_F90 = benchmark_lib.f90 $(WARD_SUPPORT_F90) BENCHMARK_LIB_O = $(BENCHMARK_LIB_F90:.f90=.o) benchmark_VM_vs_Fortran.f90: benchmark_processes.list benchmark_processes.wrappers.o @if $(AM_V_P); then :; else echo " BENCHMARK_VM_DRIVER"; fi $(AM_V_at)$(SHELL) $(srcdir)/benchmark_VM_vs_Fortran_driver.sh \ "$(OMEGA_XXX) " "$(OMEGA_XXX_VM) " "$(OMEGA_XXX_VM_PARAMS_OPTS)" < $< > $@ benchmark_processes.wrappers.f90: benchmark_processes.list @if $(AM_V_P); then :; else echo " BENCHMARK_DRIVER_WRAPPERS"; fi $(AM_V_at)$(SHELL) $(srcdir)/benchmark_driver_wrappers.sh \ "$(OMEGA_XXX) " "$(OMEGA_XXX_VM) " "$(OMEGA_XXX_VM_PARAMS_OPTS)" < $< > $@ # Explicitly state dependence on model files benchmark_VM_vs_Fortran.f90: benchmark_VM_vs_Fortran_driver.sh \ $(OMEGA_QED) $(OMEGA_QED_VM) \ $(OMEGA_QCD) $(OMEGA_QCD_VM) \ $(OMEGA_SM) $(OMEGA_SM_VM) benchmark_VM_vs_Fortran_SOURCES = $(BENCHMARK_LIB_F90) nodist_benchmark_VM_vs_Fortran_SOURCES = benchmark_VM_vs_Fortran.f90 benchmark_processes.wrappers.f90 benchmark_VM_vs_Fortran_LDADD = $(KINDS) $(top_builddir)/omega/src/libomega_core.la benchmark_VM_vs_Fortran.o: $(BENCHMARK_LIB_O) ######################################################################## if FC_USE_OPENMP EXTRA_PROGRAMS += benchmark_amp_parallel benchmark_amp_parallel.f90: benchmark_processes.list benchmark_processes.wrappers.o @if $(AM_V_P); then :; else echo " BENCHMARK_PARALLEL_DRIVER"; fi $(AM_V_at)$(SHELL) $(srcdir)/benchmark_amp_parallel_driver.sh \ "$(OMEGA_XXX) " "$(OMEGA_XXX_VM) " "$(OMEGA_XXX_VM_PARAMS_OPTS)" < $< > $@ # Explicitly state dependence on model files benchmark_amp_parallel.f90: benchmark_amp_parallel_driver.sh \ $(OMEGA_QED) $(OMEGA_QED_VM) \ $(OMEGA_QCD) $(OMEGA_QCD_VM) \ $(OMEGA_SM) $(OMEGA_SM_VM) benchmark_amp_parallel_SOURCES = $(BENCHMARK_LIB_F90) nodist_benchmark_amp_parallel_SOURCES = benchmark_amp_parallel.f90 benchmark_processes.wrappers.f90 benchmark_amp_parallel_LDADD = $(KINDS) $(top_builddir)/omega/src/libomega_core.la benchmark_amp_parallel.o: $(BENCHMARK_LIB_O) endif ######################################################################## EXTRA_PROGRAMS += benchmark run_benchmark: benchmark ./benchmark BENCHMARK_PROCESS = -scatter "gl gl -> gl gl gl" BENCHMARK_SPLIT_SIZE = 10 benchmark_SOURCES = benchmark.f90 parameters_QCD.f90 nodist_benchmark_SOURCES = \ amplitude_benchmark_v1.f90 amplitude_benchmark_v2.f90 \ amplitude_benchmark_v3.f90 # amplitude_benchmark_v4.f90 benchmark_LDADD = $(KINDS) $(top_builddir)/omega/src/libomega_core.la amplitude_benchmark_v1.f90: $(OMEGA_QCD) Makefile $(OMEGA_QCD) $(OMEGA_QCD_OPTS) -target:module amplitude_benchmark_v1 \ $(BENCHMARK_PROCESS) -target:single_function > $@ amplitude_benchmark_v2.f90: $(OMEGA_QCD) Makefile $(OMEGA_QCD) $(OMEGA_QCD_OPTS) -target:module amplitude_benchmark_v2 \ $(BENCHMARK_PROCESS) -target:split_function $(BENCHMARK_SPLIT_SIZE) > $@ amplitude_benchmark_v3.f90: $(OMEGA_QCD) Makefile $(OMEGA_QCD) $(OMEGA_QCD_OPTS) -target:module amplitude_benchmark_v3 \ $(BENCHMARK_PROCESS) -target:split_module $(BENCHMARK_SPLIT_SIZE) > $@ amplitude_benchmark_v4.f90: $(OMEGA_QCD) Makefile $(OMEGA_QCD) $(OMEGA_QCD_OPTS) -target:module amplitude_benchmark_v4 \ $(BENCHMARK_PROCESS) -target:split_file $(BENCHMARK_SPLIT_SIZE) > $@ benchmark.o: \ amplitude_benchmark_v1.o amplitude_benchmark_v2.o \ amplitude_benchmark_v3.o # amplitude_benchmark_v4.o benchmark.o: parameters_QCD.o amplitude_benchmark_v1.o amplitude_benchmark_v2.o \ amplitude_benchmark_v3.o amplitude_benchmark_v4.o: parameters_QCD.o ######################################################################## +EXTRA_PROGRAMS += benchmark_UFO_SMEFT + +run_benchmark_UFO_SMEFT: benchmark_UFO_SMEFT + ./benchmark_UFO_SMEFT + +# NB: This is NOT portable ... +UFO_SMEFT = /home/ohl/physics/SMEFT_mW_UFO/ + +BENCHMARK_UFO_SMEFT_PROCESS = -scatter "e+ e- -> W+ W- Z" + +benchmark_UFO_SMEFT_SOURCES = benchmark_UFO_SMEFT.f90 +nodist_benchmark_UFO_SMEFT_SOURCES = \ + amplitude_benchmark_UFO_SMEFT.f90 \ + amplitude_benchmark_UFO_SMEFT_opt.f90 \ + parameters_UFO_SMEFT.f90 + +benchmark_UFO_SMEFT_LDADD = $(KINDS) $(top_builddir)/omega/src/libomega_core.la + +amplitude_benchmark_UFO_SMEFT.f90: $(OMEGA_UFO) Makefile + $(OMEGA_UFO) -model:UFO_dir $(UFO_SMEFT) -model:exec \ + -target:module amplitude_benchmark_UFO_SMEFT \ + -target:parameter_module parameters_UFO_SMEFT \ + $(BENCHMARK_UFO_SMEFT_PROCESS) | $(SED) 's/g == 0/.false./' > $@ + +amplitude_benchmark_UFO_SMEFT_opt.f90: $(OMEGA_UFO) Makefile + $(OMEGA_UFO) -model:UFO_dir $(UFO_SMEFT) -model:exec \ + -target:module amplitude_benchmark_UFO_SMEFT_opt \ + -target:parameter_module parameters_UFO_SMEFT \ + $(BENCHMARK_UFO_SMEFT_PROCESS) > $@ + +benchmark_UFO_SMEFT.o: \ + amplitude_benchmark_UFO_SMEFT.o amplitude_benchmark_UFO_SMEFT_opt.o + +benchmark_UFO_SMEFT.o: parameters_QCD.o +amplitude_benchmark_UFO_SMEFT.o amplitude_benchmark_UFO_SMEFT_opt.o: \ + parameters_QCD.o + +parameters_UFO_SMEFT.f90: $(OMEGA_UFO) + $(OMEGA_UFO) -model:UFO_dir $(UFO_SMEFT) -model:exec \ + -target:parameter_module parameters_UFO_SMEFT -params > $@ + +######################################################################## + if OCAML_AVAILABLE TESTS += vertex_unit EXTRA_PROGRAMS += vertex_unit vertex_unit_SOURCES = vertex_unit.ml vertex_unit: $(OMEGA_CORE) vertex_unit.cmx @if $(AM_V_P); then :; else echo " OCAMLOPT " $@; fi $(AM_V_at)$(OCAMLOPT) $(OCAMLFLAGS) $(OCAMLOPTFLAGS) -o vertex_unit \ unix.cmxa $(OMEGA_CORE) $(OMEGA_MODELS) vertex_unit.cmx vertex_unit.cmx: vertex_unit.ml vertex_unit.cmx: $(OMEGA_CORE) $(OMEGA_MODELS) endif ######################################################################## if OCAML_AVAILABLE TESTS += ufo_unit EXTRA_PROGRAMS += ufo_unit ufo_unit_SOURCES = ufo_unit.ml ufo_unit: $(OMEGA_CORE) ufo_unit.cmx @if $(AM_V_P); then :; else echo " OCAMLOPT " $@; fi $(AM_V_at)$(OCAMLOPT) $(OCAMLFLAGS) $(OCAMLOPTFLAGS) -o ufo_unit \ unix.cmxa $(OMEGA_CORE) $(OMEGA_MODELS) ufo_unit.cmx ufo_unit.cmx: ufo_unit.ml ufo_unit.cmx: $(OMEGA_CORE) $(OMEGA_MODELS) endif ######################################################################## if OCAML_AVAILABLE TESTS += keystones_omegalib keystones_UFO TESTS += keystones_omegalib_bispinors keystones_UFO_bispinors # XFAIL_TESTS += keystones_UFO # XFAIL_TESTS += keystones_UFO_bispinors EXTRA_PROGRAMS += keystones_omegalib keystones_UFO EXTRA_PROGRAMS += keystones_omegalib_bispinors keystones_UFO_bispinors keystones_omegalib_SOURCES = omega_testtools.f90 keystones_tools.f90 nodist_keystones_omegalib_SOURCES = keystones_omegalib.f90 keystones_omegalib_LDADD = $(KINDS) $(top_builddir)/omega/src/libomega_core.la keystones_UFO_SOURCES = omega_testtools.f90 keystones_tools.f90 nodist_keystones_UFO_SOURCES = keystones_UFO.f90 keystones_UFO_LDADD = $(KINDS) $(top_builddir)/omega/src/libomega_core.la keystones_omegalib_bispinors_SOURCES = omega_testtools.f90 keystones_tools.f90 nodist_keystones_omegalib_bispinors_SOURCES = keystones_omegalib_bispinors.f90 keystones_omegalib_bispinors_LDADD = $(KINDS) $(top_builddir)/omega/src/libomega_core.la keystones_UFO_bispinors_SOURCES = omega_testtools.f90 keystones_tools.f90 nodist_keystones_UFO_bispinors_SOURCES = keystones_UFO_bispinors.f90 keystones_UFO_bispinors_LDADD = $(KINDS) $(top_builddir)/omega/src/libomega_core.la EXTRA_PROGRAMS += keystones_omegalib_generate keystones_UFO_generate EXTRA_PROGRAMS += keystones_omegalib_bispinors_generate keystones_UFO_bispinors_generate keystones_omegalib_generate_SOURCES = \ keystones.ml keystones.mli keystones_omegalib_generate.ml keystones_UFO_generate_SOURCES = \ keystones.ml keystones.mli keystones_UFO_generate.ml keystones_omegalib_bispinors_generate_SOURCES = \ keystones.ml keystones.mli keystones_omegalib_bispinors_generate.ml keystones_UFO_bispinors_generate_SOURCES = \ keystones.ml keystones.mli keystones_UFO_bispinors_generate.ml keystones_omegalib.f90: keystones_omegalib_generate ./keystones_omegalib_generate -cat > $@ keystones_UFO.f90: keystones_UFO_generate ./keystones_UFO_generate -cat > $@ keystones_omegalib_bispinors.f90: keystones_omegalib_bispinors_generate ./keystones_omegalib_bispinors_generate -cat > $@ keystones_UFO_bispinors.f90: keystones_UFO_bispinors_generate ./keystones_UFO_bispinors_generate -cat > $@ keystones_omegalib_generate: $(OMEGA_CORE) keystones_omegalib_generate.cmx @if $(AM_V_P); then :; else echo " OCAMLOPT " $@; fi $(AM_V_at)$(OCAMLOPT) $(OCAMLFLAGS) $(OCAMLOPTFLAGS) \ -o keystones_omegalib_generate \ unix.cmxa $(OMEGA_CORE) $(OMEGA_MODELS) \ keystones.cmx keystones_omegalib_generate.cmx keystones_UFO_generate: $(OMEGA_CORE) keystones_UFO_generate.cmx @if $(AM_V_P); then :; else echo " OCAMLOPT " $@; fi $(AM_V_at)$(OCAMLOPT) $(OCAMLFLAGS) $(OCAMLOPTFLAGS) \ -o keystones_UFO_generate \ unix.cmxa $(OMEGA_CORE) $(OMEGA_MODELS) \ keystones.cmx keystones_UFO_generate.cmx keystones_omegalib_bispinors_generate: $(OMEGA_CORE) keystones_omegalib_bispinors_generate.cmx @if $(AM_V_P); then :; else echo " OCAMLOPT " $@; fi $(AM_V_at)$(OCAMLOPT) $(OCAMLFLAGS) $(OCAMLOPTFLAGS) \ -o keystones_omegalib_bispinors_generate \ unix.cmxa $(OMEGA_CORE) $(OMEGA_MODELS) \ keystones.cmx keystones_omegalib_bispinors_generate.cmx keystones_UFO_bispinors_generate: $(OMEGA_CORE) keystones_UFO_bispinors_generate.cmx @if $(AM_V_P); then :; else echo " OCAMLOPT " $@; fi $(AM_V_at)$(OCAMLOPT) $(OCAMLFLAGS) $(OCAMLOPTFLAGS) \ -o keystones_UFO_bispinors_generate \ unix.cmxa $(OMEGA_CORE) $(OMEGA_MODELS) \ keystones.cmx keystones_UFO_bispinors_generate.cmx keystones_omegalib_generate.cmx: \ keystones.cmi keystones.cmx keystones_omegalib_generate.ml keystones_omegalib_generate.cmx: $(OMEGA_CORE) $(OMEGA_MODELS) keystones_UFO_generate.cmx: \ keystones.cmi keystones.cmx keystones_UFO_generate.ml keystones_UFO_generate.cmx: $(OMEGA_CORE) $(OMEGA_MODELS) keystones_omegalib_bispinors_generate.cmx: \ keystones.cmi keystones.cmx keystones_omegalib_bispinors_generate.ml keystones_omegalib_bispinors_generate.cmx: $(OMEGA_CORE) $(OMEGA_MODELS) keystones_UFO_bispinors_generate.cmx: \ keystones.cmi keystones.cmx keystones_UFO_bispinors_generate.ml keystones_UFO_bispinors_generate.cmx: $(OMEGA_CORE) $(OMEGA_MODELS) keystones.cmx: keystones.ml keystones.cmi keystones.cmx: $(OMEGA_CORE) $(OMEGA_MODELS) keystones.cmi: keystones.mli endif ######################################################################## if RECOLA_AVAILABLE TESTS += compare_amplitude_recola # We need more work on the parameters to pass the tests # at quadruple or extended precision if FC_PREC XFAIL_TESTS += compare_amplitude_recola endif EXTRA_PROGRAMS += compare_amplitude_recola AM_FCFLAGS += $(RECOLA_INCLUDES) compare_amplitude_recola_SOURCES = \ parameters_SM_Higgs_recola.f90 \ omega_interface.f90 compare_lib.f90 compare_lib_recola.f90 \ omega_testtools.f90 tao_random_numbers.f90 nodist_compare_amplitude_recola_SOURCES = compare_amplitude_recola.f90 compare_amplitude_recola.f90: comparisons_recola.list compare_driver_recola.sh @if $(AM_V_P); then :; else echo " COMPARE_DRIVER_RECOLA"; fi $(AM_V_at)$(SHELL) $(srcdir)/compare_driver_recola.sh \ "$(OMEGA_XXX) -model:constant_width" < $< > $@ compare_amplitude_recola.o: \ omega_testtools.f90 compare_lib.o compare_lib_recola.o \ tao_random_numbers.o \ parameters_SM_Higgs_recola.o compare_lib_recola.o: \ omega_testtools.f90 compare_lib.o tao_random_numbers.o \ parameters_SM_Higgs_recola.o compare_amplitude_recola_LDADD = \ $(LDFLAGS_RECOLA) \ $(KINDS) $(top_builddir)/omega/src/libomega_core.la run_compare_recola: compare_amplitude_recola ./compare_amplitude_recola endif ######################################################################## installcheck-local: PATH=$(DESTDIR)$(bindir):$$PATH; export PATH; \ LD_LIBRARY_PATH=$(DESTDIR)$(libdir):$(DESTDIR)$(pkglibdir):$$LD_LIBRARY_PATH; \ export LD_LIBRARY_PATH; \ omega_QED.opt $(OMEGA_QED_OPTS) -scatter "e+ e- -> m+ m-" \ -target:module amplitude_qed_eemm > amplitude_qed_eemm.f90; \ $(FC) $(AM_FCFLAGS) $(FCFLAGS) -I$(pkgincludedir) \ -L$(DESTDIR)$(libdir) -L$(DESTDIR)$(pkglibdir) \ $(srcdir)/parameters_QED.f90 amplitude_qed_eemm.f90 \ $(srcdir)/test_qed_eemm.f90 -lomega_core; \ ./a.out ######################################################################## ### Remove DWARF debug information on MAC OS X clean-macosx: -rm -rf a.out.dSYM -rm -rf compare_amplitude_UFO.dSYM -rm -rf compare_amplitude_VM.dSYM -rm -rf compare_split_function.dSYM -rm -rf compare_split_module.dSYM -rm -rf ects.dSYM -rm -rf test_omega95.dSYM -rm -rf test_omega95_bispinors.dSYM -rm -rf test_qed_eemm.dSYM -rm -rf ward.dSYM .PHONY: clean-macosx clean-local: clean-macosx rm -f a.out gmon.out *.$(FCMOD) \ *.o *.cmi *.cmo *.cmx amplitude_*.f90 \ $(EXTRA_PROGRAMS) ects.f90 ward.f90 ward_UFO.f90 \ fermi.f90 fermi_UFO.f90 compare_*.f90 \ parameters_SM_UFO.f90 keystones_omegalib.f90 keystones_UFO.f90 \ keystones_UFO_bispinors.f90 keystones_omegalib_bispinors.f90 \ omega_testtools.f90 test_omega95*.f90 benchmark*.f90 \ + parameters_UFO_SMEFT.f90 \ *.hbc *wrappers.f90 cascade phase_space \ output.rcl recola.log rm -fr output_cll if FC_SUBMODULES -rm -f *.smod endif ######################################################################## ## The End. ######################################################################## Index: trunk/omega/tests/benchmark_UFO_SMEFT.f90 =================================================================== --- trunk/omega/tests/benchmark_UFO_SMEFT.f90 (revision 0) +++ trunk/omega/tests/benchmark_UFO_SMEFT.f90 (revision 8476) @@ -0,0 +1,138 @@ +! benchmark.f90 -- +! benchmark.f90 -- race O'Mega matrix elements +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! +! +! Copyright (C) 1999-2020 by +! Wolfgang Kilian +! Thorsten Ohl +! Juergen Reuter +! Christian Speckner +! +! WHIZARD is free software; you can redistribute it and/or modify it +! under the terms of the GNU General Public License as published by +! the Free Software Foundation; either version 2, or (at your option) +! any later version. +! +! WHIZARD is distributed in the hope that it will be useful, but +! WITHOUT ANY WARRANTY; without even the implied warranty of +! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +! GNU General Public License for more details. +! +! You should have received a copy of the GNU General Public License +! along with this program; if not, write to the Free Software +! Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. +! +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + +program benchmark + + use kinds + use constants + use amplitude_benchmark_UFO_SMEFT, only: new_event, & + number_particles_in, number_particles_out + use amplitude_benchmark_UFO_SMEFT_opt, only: new_event_opt => new_event + + use parameters_UFO_SMEFT + implicit none + + integer, parameter :: NCALLS = 2000 + real(kind=double), parameter :: ROOTS = 1000 + + real(kind=default), dimension(:,:), allocatable :: p + real(kind=double) :: wtime_start, wtime + integer, dimension(:), allocatable :: seed + integer :: i, seed_size + + call random_seed (seed_size) + allocate (seed(seed_size)) + seed = 42 + call random_seed (put = seed) + deallocate (seed) + + call setup_parameters + allocate (p(0:3,number_particles_in()+number_particles_out())) + call beams (roots, 0.0_default, 0.0_default, p(:,1), p(:,2)) + + call cpu_time (wtime_start) + do i = 1, NCALLS + call massless_isotropic_decay (roots, p(:,3:)) + call new_event (p) + end do + call cpu_time (wtime) + write (*, "(1X,A,F10.4,A)") "not optimized: " ,& + 1000 * (wtime - wtime_start) / NCALLS, ' milliseconds / evaluation' + + call cpu_time (wtime_start) + do i = 1, NCALLS + call massless_isotropic_decay (roots, p(:,3:)) + call new_event_opt (p) + end do + call cpu_time (wtime) + write (*, "(1X,A,F10.4,A)") " optimized: " ,& + 1000 * (wtime - wtime_start) / NCALLS, ' milliseconds / evaluation' + + deallocate (p) + stop 0 + +contains + + pure function dot (p, q) result (pq) + real(kind=default), dimension(0:), intent(in) :: p, q + real(kind=default) :: pq + pq = p(0)*q(0) - dot_product (p(1:), q(1:)) + end function dot + + pure function mass2 (p) result (m2) + real(kind=default), dimension(0:), intent(in) :: p + real(kind=default) :: m2 + m2 = p(0)*p(0) - p(1)*p(1) - p(2)*p(2) - p(3)*p(3) + end function mass2 + + pure subroutine beams (roots, m1, m2, p1, p2) + real(kind=default), intent(in) :: roots, m1, m2 + real(kind=default), dimension(0:), intent(out) :: p1, p2 + real(kind=default) :: m12, m22 + m12 = m1**2 + m22 = m2**2 + p1(0) = (roots**2 + m12 - m22) / (2*roots) + p1(1:2) = 0 + p1(3) = sqrt (p1(0)**2 - m12) + p2(0) = roots - p1(0) + p2(1:3) = - p1(1:3) + end subroutine beams + + ! The massless RAMBO algorithm + subroutine massless_isotropic_decay (roots, p) + real(kind=default), intent(in) :: roots + real(kind=default), dimension(0:,:), intent(out) :: p + real(kind=default), dimension(0:3,size(p,dim=2)) :: q + real(kind=default), dimension(0:3) :: qsum + real(kind=default), dimension(4) :: ran + real(kind=default) :: c, s, f, qabs, x, r, z + integer :: k + ! Generate isotropic null vectors + do k = 1, size (p, dim = 2) + call random_number (ran) + ! generate a x*exp(-x) distribution for q(0,k) + q(0,k)= -log(ran(1)*ran(2)) + c = 2*ran(3)-1 + f = 2*PI*ran(4) + s = sqrt(1-c*c) + q(2,k) = q(0,k)*s*sin(f) + q(3,k) = q(0,k)*s*cos(f) + q(1,k) = q(0,k)*c + enddo + ! Boost and rescale the vectors + qsum = sum (q, dim = 2) + qabs = sqrt (dot (qsum, qsum)) + x = roots/qabs + do k = 1, size (p, dim = 2) + r = dot (q(0:,k), qsum) / qabs + z = (q(0,k)+r)/(qsum(0)+qabs) + p(1:3,k) = x*(q(1:3,k)-qsum(1:3)*z) + p(0,k) = x*r + enddo + end subroutine massless_isotropic_decay + +end program benchmark +